inst/doc/extend-blockr.R

In blockr.core: Graphical Web-Framework for Data Manipulation and Visualization

## ----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"
)