## ----include = FALSE---------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ## ----packages, message=FALSE, warning=FALSE----------------------------------- library(shiny) library(bslib) library(scoutbaR) library(blockr.core) ## ----custom-plugin-setup, eval = FALSE, echo=FALSE---------------------------- # chr_ply <- function(x, fun, ..., length = 1L, use_names = FALSE) { # vapply(x, fun, character(length), ..., USE.NAMES = use_names) # } # # #' @keywords internal # lgl_ply <- function(x, fun, ..., length = 1L, use_names = FALSE) { # vapply(x, fun, logical(length), ..., USE.NAMES = use_names) # } # # dropNulls <- function(x) { # x[!lgl_ply(x, is.null)] # } # # blk_icon <- function(category) { # switch( # category, # "data" = "table", # "file" = "file-import", # "parse" = "cogs", # "plot" = "chart-line", # "transform" = "wand-magic-sparkles", # "table" = "table" # ) # } # # blk_choices <- function() { # blk_cats <- sort( # unique(chr_ply(available_blocks(), \(b) attr(b, "category"))) # ) # # lapply(blk_cats, \(cat) { # scout_section( # label = cat, # .list = dropNulls( # unname( # lapply(available_blocks(), \(choice) { # if (attr(choice, "category") == cat) { # scout_action( # id = attr(choice, "classes")[1], # label = attr(choice, "name"), # description = attr(choice, "description"), # icon = blk_icon(cat) # ) # } # }) # ) # ) # ) # }) # } ## ----custom-plugin-server, eval=FALSE----------------------------------------- # new_manage_blocks_server <- function(id, board, update, ...) { # moduleServer( # id, # function(input, output, session) { # # Trigger add block # observeEvent( # input$add_block, # { # update_scoutbar( # session, # "scoutbar", # revealScoutbar = TRUE # ) # } # ) # # observeEvent(input$scoutbar, { # new_blk <- as_blocks(create_block(input$scoutbar)) # update( # list(blocks = list(add = new_blk)) # ) # }) # # NULL # } # ) # } ## ----custom-plugin-app, eval=FALSE-------------------------------------------- #| code-fold: true # main_ui <- function(id, board) { # ns <- NS(id) # board_ui( # ns("board"), # board, # plugins = custom_board_plugins( # c( # "manage_blocks" # ) # ) # ) # } # # main_server <- function(id, board) { # moduleServer( # id, # function(input, output, session) { # ns <- session$ns # # # Board module # board_server( # "board", # board, # plugins = plugins( # manage_blocks(server = new_manage_blocks_server, ui = new_manage_blocks_ui) # ), # callbacks = list() # ) # } # ) # } # # board <- new_board() # # ui <- page_fluid( # main_ui("app", board) # ) # # server <- function(input, output, session) { # main_server("app", board) # } # # shinyApp(ui, server) ## ----shinylive_url, echo = FALSE, results = 'asis'---------------------------- # extract the code from knitr code chunks by ID code <- paste0( c( "webr::install(\"blockr.core\", repos = \"https://cynkra.github.io/blockr.webR/\")", knitr::knit_code$get("packages"), knitr::knit_code$get("custom-plugin-setup"), knitr::knit_code$get("custom-plugin-ui"), knitr::knit_code$get("custom-plugin-server"), knitr::knit_code$get("custom-plugin-helpers"), knitr::knit_code$get("custom-plugin-app") ), collapse = "\n" ) url <- roxy.shinylive::create_shinylive_url(code, header = FALSE) ## ----shinylive_iframe, echo = FALSE, eval = TRUE------------------------------ shiny::tags$iframe( class = "border border-5 rounded shadow-lg", src = url, style = "zoom: 0.75;", width = "100%", height = "1100px" ) ## ----custom-board-ui, eval=FALSE---------------------------------------------- # board_ui.custom_board <- function(id, x, plugins = list(), ...) { # plugins <- as_plugins(plugins) # div( # id = paste0(id, "_board"), # board_ui(id, plugins[["manage_blocks"]], x), # div( # id = paste0(id, "_blocks"), # block_ui(id, x) # ) # ) # } ## ----custom-block-ui, eval=FALSE---------------------------------------------- # get_block_registry <- function(x) { # stopifnot(is_block(x)) # available_blocks()[[strsplit(attr(x, "ctor"), "new_")[[1]][2]]] # } # # block_ui.custom_board <- function(id, x, blocks = NULL, ...) { # block_card <- function(x, id, ns) { # id <- paste0("block_", id) # # blk_info <- get_block_registry(x) # # div( # class = "m-2", # id = ns(id), # shinyNextUI::card( # variant = "bordered", # shinyNextUI::card_header( # className = "d-flex justify-content-between", # icon(blk_icon(attr(blk_info, "category"))), # sprintf( # "Block: %s (id: %s)", # attr(blk_info, "name"), # gsub("block_", "", id) # ), # shinyNextUI::tooltip( # icon("info-circle"), # content = tagList( # p( # icon("lightbulb"), # "How to use this block?", # ), # p(attr(blk_info, "description"), ".") # ) # ) # ), # shinyNextUI::divider(), # shinyNextUI::card_body( # expr_ui(ns(id), x), # block_ui(ns(id), x) # ), # shinyNextUI::divider(), # shinyNextUI::card_footer( # sprintf( # "Type: %s; Package: %s", # attr(blk_info, "category"), # attr(blk_info, "package") # ) # ) # ) # ) # } # # stopifnot(is.character(id) && length(id) == 1L) # # if (is.null(blocks)) { # blocks <- board_blocks(x) # } else if (is.character(blocks)) { # blocks <- board_blocks(x)[blocks] # } # # stopifnot(is_blocks(blocks)) # # tagList( # Map( # block_card, # blocks, # names(blocks), # MoreArgs = list(ns = NS(id)), # USE.NAMES = FALSE # ) # ) # } ## ----custom-plugin-ui-nextui, eval=FALSE-------------------------------------- # add_rm_block_ui <- function(id, board) { # tagList( # scoutbar( # NS(id, "scoutbar"), # placeholder = "Search for a block", # actions = blk_choices(), # theme = "dark", # showRecentSearch = TRUE # ), # shinyNextUI::actionButton( # NS(id, "add_block"), # "New block", # icon = icon("circle-plus"), # ) # ) # } ## ----custom-ui-app, eval=FALSE------------------------------------------------ #| code-fold: true # board <- new_board(class = "custom_board") # # ui <- nextui_page( # board_ui( # "board", # board, # plugins = custom_board_plugins( # c( # "manage_blocks" # ) # ) # ) # ) # # server <- function(input, output, session) { # board_server( # "board", # board, # plugins = custom_board_plugins( # c( # "manage_blocks" # ) # ), # callbacks = list() # ) # } # # shinyApp(ui, server) ## ----shinylive2_url, echo = FALSE, results = 'asis'--------------------------- # extract the code from knitr code chunks by ID code <- paste0( c( "webr::install(\"blockr.core\", repos = \"https://cynkra.github.io/blockr.webR/\")", "library(shiny)", "library(scoutbaR)", "library(blockr.core)", "library(shinyNextUI)", knitr::knit_code$get("custom-plugin-setup"), knitr::knit_code$get("custom-plugin-ui-nextui"), knitr::knit_code$get("custom-plugin-server"), knitr::knit_code$get("custom-plugin-helpers"), knitr::knit_code$get("custom-block-ui"), knitr::knit_code$get("custom-board-ui"), knitr::knit_code$get("custom-ui-app") ), collapse = "\n" ) url <- roxy.shinylive::create_shinylive_url(code, header = FALSE) ## ----shinylive2_iframe, echo = FALSE, eval = TRUE----------------------------- shiny::tags$iframe( class = "border border-5 rounded shadow-lg", src = url, style = "zoom: 0.75;", width = "100%", height = "1100px" )