inst/doc/create-block.R

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

## ----include = FALSE----------------------------------------------------------
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>"
)


## ----setup--------------------------------------------------------------------
library(blockr.core)


## flowchart LR
##   subgraph block[Block]
##     subgraph ctor[constructor]
##       block_ui[UI]
##       subgraph block_server[server]
##         blk_state[State]
##         blk_expr[Expression]
##       end
##     end
##   end

## ----eval = FALSE-------------------------------------------------------------
# ui <- function(id) {
#   tagList(
#     # Wrap widgets in `tagList()`
#     textInput(
#       NS(id, "my_input") # Use `shiny::NS()` to construct namespaces
#     )
#   )
# }


## flowchart TB
##   data_blk[data block 1]
##   data_blk_2[data block 2]
##   data_blk_3[data block 3]
##   data_blk_4[data block 4]
##   select_blk[select block]
##   join_blk[join block]
##   rbind_blk[rbind block]
##   data_blk --> |data| select_blk
##   data_blk_2 -->|data1| join_blk
##   data_blk_3 --> |data2| join_blk
## 
##   data_blk --> |1| rbind_blk
##   select_blk --> |2| rbind_blk
##   data_blk_4 --> |3| rbind_blk
##   join_blk --> |4| rbind_blk

## ----eval = FALSE-------------------------------------------------------------
# server <- function(id, data) {
#   moduleServer(id, function(input, output, session) {
#     # Reactive logic goes here
# 
#     # Return a list with "expr" and "state"
#     list(
#       expr = reactive(quote(identity(data))),
#       state = list(
#         input_one = reactive(input_one()),
#         input_two = reactive(input_two())
#       )
#     )
#   })
# }


## ----eval = FALSE-------------------------------------------------------------
# example_constructor <- function(ui_state = character(), ...) {
#   ui <- function(id) { #nolint
#     tagList(textInput(NS(id, "ui_state")))
#   }
# 
#   server <- function(id, data) {
#     moduleServer(id, function(input, output, session) {
#       # Reactive logic goes here
# 
#       # Return a list with "expr" and "state"
#       list(
#         expr = reactive(quote(identity(data))),
#         state = list(
#           # name must match what is defined in the constructor signature
#           ui_state = <STATE_VALUE>
#         )
#       )
#     })
#   }
# 
#   # Return call to `new_block()`
#   new_block(
#     server = server,
#     ui = ui,
#     class = "my_block",
#     ...
#   )
# }


## -----------------------------------------------------------------------------
new_head_block <- function(n = 6L, ...) {
  new_transform_block(
    function(id, data) {
      moduleServer(
        id,
        function(input, output, session) {
          n_rows <- reactiveVal(n)

          observeEvent(input$n, n_rows(input$n))

          observeEvent(
            nrow(data()),
            updateNumericInput(
              inputId = "n",
              value = n_rows(),
              min = 1L,
              max = nrow(data())
            )
          )

          list(
            expr = reactive(
              bquote(utils::head(data, n = .(n)), list(n = n_rows()))
            ),
            state = list(
              n = n_rows
            )
          )
        }
      )
    },
    function(id) {
      tagList(
        numericInput(
          inputId = NS(id, "n"),
          label = "Number of rows",
          value = n,
          min = 1L
        )
      )
    },
    dat_val = function(data) {
      stopifnot(is.data.frame(data) || is.matrix(data))
    },
    class = "head_block",
    ...
  )
}


## ----eval = FALSE-------------------------------------------------------------
# serve(new_head_block(n = 10L), list(data = mtcars))


## ----eval = FALSE-------------------------------------------------------------
# serve(
#   new_merge_block(by = "Time"),
#   data = list(x = datasets::BOD, y = datasets::ChickWeight)
# )


## ----esquisse-server, eval=FALSE----------------------------------------------
# esquisse_block_server <- function(id, data) {
#   moduleServer(
#     id,
#     function(input, output, session) {
#       results <- esquisse::esquisse_server(
#         id = "esquisse",
#         data_rv = data
#       )
#       list(
#         expr = reactive({
#           bquote(
#             list(
#               dat = as.data.frame(.(dat)),
#               filters = .(filters)
#             ),
#             list(
#               filters = results$code_plot,
#               dat = results$data
#             )
#           )
#         }),
#         state = list()
#       )
#     }
#   )
# }


## ----esquisse-complex-block, eval=FALSE---------------------------------------
# new_complex_block <- function(server, ui, class, ctor = sys.parent(), ...) {
#   new_block(server, ui, c(class, "complex_block"), ctor, ...)
# }


## ----esquisse-block-output, eval=FALSE----------------------------------------
# #' @export
# block_output.complex_block <- function(x, result, session) {
#   session$output$filters <- renderPrint(result$filters)
#   # result must come at the end of the output list if you have multiple outputs
#   session$output$result <- dt_result(result$dat, session)
# }


## ----esquisse-block-ui, eval=FALSE--------------------------------------------
# #' @export
# block_ui.complex_block <- function(id, x, ...) {
#   tagList(
#     h1("Transformed data from {esquisse}"),
#     DT::dataTableOutput(NS(id, "result")),
#     verbatimTextOutput(NS(id, "filters"))
#   )
# }


## ----esquisse-ui, eval=FALSE--------------------------------------------------
# esquisse_block_ui <- function(id) {
#   tagList(
#     esquisse::esquisse_ui(
#       id = NS(id, "esquisse"),
#       header = FALSE # dont display gadget title
#     )
#   )
# }


## ----esquisse-ctor, eval=FALSE------------------------------------------------
# new_esquisse_block <- function(...) {
#   new_complex_block(
#     server = esquisse_block_server,
#     ui = esquisse_block_ui,
#     class = "esquisse_block",
#     dat_valid = NULL,
#     allow_empty_state = TRUE,
#     ...
#   )
# }


## ----esquisse-app, eval=FALSE-------------------------------------------------
# serve(
#   new_board(
#     blocks = list(
#       a = new_dataset_block(iris),
#       b = new_esquisse_block()
#     ),
#     links = list(
#       new_link("a", "b", "data")
#     )
#   )
# )


## ----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/\")",
    "library(blockr.core)",
    "library(esquisse)",
    "library(plotly)",
    knitr::knit_code$get("esquisse-server"),
    knitr::knit_code$get("esquisse-ui"),
    knitr::knit_code$get("esquisse-complex-block"),
    knitr::knit_code$get("esquisse-ctor"),
    knitr::knit_code$get("esquisse-block-ui"),
    knitr::knit_code$get("esquisse-block-output"),
    knitr::knit_code$get("esquisse-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"
)