## ----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) # ) # } # }) # ) # ) # ) # }) # } ## flowchart TD ## subgraph board[board] ## subgraph plugins[plugins] ## subgraph manage_blocks[Manage blocks] ## end ## subgraph manage_links[Manage links] ## end ## subgraph manage_stacks[Manage stacks] ## end ## subgraph preserve_board[Preserve board] ## end ## subgraph generate_code[Generate code] ## end ## subgraph notify_user[Notify user] ## end ## subgraph edit_block[Edit block] ## end ## subgraph edit_stack[Edit stack] ## end ## end ## end ## ----eval=FALSE--------------------------------------------------------------- # main_ui <- function(id, board) { # ns <- NS(id) # board_ui( # ns("board"), # board, # plugins = board_plugins( # c( # "preserve_board", # "manage_blocks", # "manage_links", # "manage_stacks", # "generate_code", # "notify_user" # ) # ) # ) # } ## ----eval=FALSE--------------------------------------------------------------- # main_server <- function(id, board) { # moduleServer( # id, # function(input, output, session) { # ns <- session$n # # app_state <- reactiveValues( # # App state for module communication # ) # # # Board module # board_server( # "board", # board, # plugins = board_plugins( # c( # "preserve_board", # "manage_blocks", # "manage_links", # "manage_stacks", # "generate_code", # "notify_user" # ) # ), # callbacks = list(), # parent = app_state # ) # } # ) # } ## ----eval=FALSE--------------------------------------------------------------- # board_plugins <- function(which = NULL) { # # plugins <- plugins( # preserve_board(server = ser_deser_server, ui = ser_deser_ui), # manage_blocks(server = add_rm_block_server, ui = add_rm_block_ui), # manage_links(server = add_rm_link_server, ui = add_rm_link_ui), # manage_stacks(server = add_rm_stack_server, ui = add_rm_stack_ui), # notify_user(server = block_notification_server), # generate_code(server = gen_code_server, ui = gen_code_ui), # edit_block(server = edit_block_server, ui = edit_block_ui), # edit_stack(server = edit_stack_server, ui = edit_stack_ui) # ) # # if (is.null(which)) { # return(plugins) # } # # plugins[which] # } ## ----eval=FALSE--------------------------------------------------------------- # manage_blocks <- function(server, ui) { # new_plugin(server, ui, validator = expect_null, class = "manage_blocks") # } ## ----custom-plugin-ui, 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 # ), # actionButton( # NS(id, "add_block"), # "New block", # icon = icon("circle-plus"), # ) # ) # } ## ----eval=FALSE--------------------------------------------------------------- # #' Add/remove block module # #' # #' Customizable logic for adding/removing blocks to the board. # #' # #' @param id Namespace ID # #' @param board Reactive values object # #' @param update Reactive value object to initiate board updates # #' @param ... Extra arguments passed from parent scope # #' # #' @return A [shiny::reactiveValues()] object with components `add` and `rm`, # #' where `add` may be `NULL` or a `block` object and `rm` be `NULL` or a string # #' (block ID). # #' # #' @rdname add_rm_block # #' @export # add_rm_block_server <- function(id, board, update, ...) { # moduleServer( # id, # function(input, output, session) { # # SERVER LOGIC # # NULL # } # ) # } ## ----eval=FALSE--------------------------------------------------------------- # add_rm_block_server <- function(id, board, update, ...) { # moduleServer( # id, # function(input, output, session) { # # Trigger add block # observeEvent( # input$add_block, # { # update_scoutbar( # session, # "scoutbar", # revealScoutbar = TRUE # ) # } # ) # # NULL # } # ) # } ## ----custom-plugin-server, eval=FALSE----------------------------------------- # add_rm_block_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-helpers, eval=FALSE---------------------------------------- # custom_board_plugins <- function(which = NULL) { # plugins <- plugins( # manage_blocks(server = add_rm_block_server, ui = add_rm_block_ui) # ) # # if (is.null(which)) { # return(plugins) # } # # plugins[which] # } ## ----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$n # # # Board module # board_server( # "board", # board, # plugins = custom_board_plugins( # c( # "manage_blocks" # ) # ), # 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" )