Merge pull request #7 from blockr-org/code-block

Code block

DESCRIPTION

@@ -26,7 +26,7 @@ Description: Experimental Blocks for blockr.
 License: GPL (>= 3)
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.1
 Depends:
     blockr
 Imports:
@@ -40,6 +40,7 @@ Remotes:
     blockr-org/blockr
 Suggests:
     knitr,
+    shinyAce,
     rmarkdown,
     testthat (>= 3.0.0),
     pkgload,

NAMESPACE

@@ -1,12 +1,20 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(layout,code_plot_block)
+S3method(layout,code_transform_block)
 S3method(server_output,ggiraph_block)
 S3method(uiOutputBlock,ggiraph_block)
 S3method(ui_fields,admiral_dpc_block)
 S3method(ui_fields,filter_expr_block)
 S3method(ui_fields,summarize_expr_block)
+S3method(ui_input,code_field)
+S3method(ui_update,code_field)
+S3method(validate_field,code_field)
 export(admiral_dpc_block)
 export(asfactor_block)
+export(code_field)
+export(code_plot_block)
+export(code_transform_block)
 export(demo_arrange_block)
 export(demo_data_block)
 export(demo_filter_block_1)
@@ -17,6 +25,9 @@ export(demo_summarize_block)
 export(filter_expr_block)
 export(ggiraph_block)
 export(new_asfactor_block)
+export(new_code_field)
+export(new_code_plot_block)
+export(new_code_transform_block)
 export(new_ggiraph_block)
 export(new_plot_block)
 export(plot_block)

R/code.R

@@ -0,0 +1,104 @@
+#' Code field
+#' @param value Initial code.
+#' @param x Object.
+#' @param ... Ignored.
+#' @name code_field
+#' @export
+new_code_field <- function(value = character(), ...) {
+  new_field(
+    value,
+    class = "code_field"
+  )
+}
+
+#' @rdname code_field
+#' @export
+code_field <- function(...) validate_field(new_code_field(...))
+
+#' @rdname code_field
+#' @export
+validate_field.code_field <- function(x) {
+  x
+}
+
+#' @export
+ui_input.code_field <- function(x, id, name) {
+  shinyAce::aceEditor(
+    id,
+    value(x),
+    mode = "r",
+    theme = "github",
+    autoComplete = "live",
+    fontSize = 14
+  )
+}
+
+#' @export
+ui_update.code_field <- function(x, session, id, name) {
+  NULL
+}
+
+#' Code Block
+#' @param data Dataset.
+#' @param ... Ignored.
+#' @name code_block
+#' @export
+new_code_transform_block <- function(data, ...) {
+  new_block(
+    fields = list(
+      code = new_code_field("data # from parent block")
+    ),
+    expr = quote({
+      .(code) |>
+        parse(text = _) |>
+        eval()
+    }),
+    ...,
+    class = c("code_transform_block", "transform_block", "submit_block")
+  )
+}
+
+#' @rdname code_block
+#' @export
+code_transform_block <- function(data, ...) {
+  initialize_block(new_code_transform_block(data, ...), data)
+}
+
+#' @rdname code_block
+#' @export
+new_code_plot_block <- function(data, ...) {
+  new_block(
+    fields = list(
+      code = new_code_field("plot(data) # from parent block")
+    ),
+    expr = quote({
+      .(code) |>
+        parse(text = _) |>
+        eval()
+    }),
+    ...,
+    class = c("code_transform_block", "plot_block", "submit_block")
+  )
+}
+
+#' @rdname code_block
+#' @export
+code_plot_block <- function(data, ...) {
+  initialize_block(new_code_plot_block(data, ...), data)
+}
+
+code_layout_fields <- function(x, fields, ...) {
+  # we apply padding because there seems to be some
+  # CSS that pushes the editor up and hides the buttons
+  div(
+    class = "mt-4",
+    fields$code,
+    fields$submit
+  )
+}
+
+#' @export
+layout.code_transform_block <- code_layout_fields
+
+#' @export
+layout.code_plot_block <- code_layout_fields

inst/examples/code-block/app.R

@@ -0,0 +1,18 @@
+devtools::load_all()
+library(shiny)
+
+stack <- new_stack(
+  data_block,
+  code_transform_block
+)
+
+ui <- fluidPage(
+  theme = bslib::bs_theme(5L),
+  generate_ui(stack)
+)
+
+server <- function(input, output, session) {
+  generate_server(stack)
+}
+
+shinyApp(ui, server)