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