WIP: y scrolling code block, select block added, debug filter block e…

.Rbuildignore

@@ -1,3 +1,6 @@
 ^LICENSE\.md$
 ^README\.(Rmd|html)$
 ^\.github$
+^\.lintr$
+^.*\.Rproj$
+^\.Rproj\.user$

.gitignore

@@ -1 +1,2 @@
 README.html
+.Rproj.user

.lintr

@@ -0,0 +1,4 @@
+linters: linters_with_defaults(
+  object_name_linter = NULL, # Because we use S3 and end up with is_initialized.field
+  object_usage_linter = NULL # When code is WIP this is annoying ...
+  )

DESCRIPTION

@@ -20,7 +20,10 @@ Imports:
     shiny,
     dplyr,
     utils,
-    methods
+    ggplot2,
+    bslib,
+    methods,
+    DT
 Suggests: 
     testthat (>= 3.0.0)
 Config/testthat/edition: 3

NAMESPACE

@@ -1,16 +1,19 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(evalute_block,data_block)
+S3method(evalute_block,plot_block)
 S3method(evalute_block,transform_block)
 S3method(generate_code,block)
 S3method(generate_code,transform_block)
 S3method(generate_server,block)
 S3method(generate_server,data_block)
+S3method(generate_server,plot_block)
 S3method(generate_server,stack)
 S3method(generate_server,transform_block)
 S3method(generate_ui,block)
 S3method(generate_ui,stack)
 S3method(initialize_block,data_block)
+S3method(initialize_block,plot_block)
 S3method(initialize_block,transform_block)
 S3method(initialize_field,field)
 S3method(input_ids,block)
@@ -20,6 +23,7 @@ S3method(is_initialized,block)
 S3method(is_initialized,field)
 S3method(server_code,block)
 S3method(server_output,block)
+S3method(server_output,plot_block)
 S3method(ui_code,block)
 S3method(ui_input,hidden_field)
 S3method(ui_input,list_field)
@@ -28,6 +32,7 @@ S3method(ui_input,select_field)
 S3method(ui_input,string_field)
 S3method(ui_input,variable_field)
 S3method(ui_output,block)
+S3method(ui_output,plot_block)
 S3method(ui_update,hidden_field)
 S3method(ui_update,list_field)
 S3method(ui_update,range_field)
@@ -36,6 +41,7 @@ S3method(ui_update,string_field)
 S3method(ui_update,variable_field)
 S3method(update_field,field)
 S3method(update_fields,data_block)
+S3method(update_fields,plot_block)
 S3method(update_fields,transform_block)
 S3method(validate_field,hidden_field)
 S3method(validate_field,list_field)
@@ -65,12 +71,16 @@ export(new_field)
 export(new_filter_block)
 export(new_hidden_field)
 export(new_list_field)
+export(new_plot_block)
 export(new_range_field)
+export(new_select_block)
 export(new_select_field)
 export(new_stack)
 export(new_string_field)
 export(new_variable_field)
+export(plot_block)
 export(range_field)
+export(select_block)
 export(select_field)
 export(serve_stack)
 export(server_code)
@@ -86,4 +96,5 @@ export(validate_field)
 export(value)
 export(values)
 export(variable_field)
+import(ggplot2)
 importFrom(magrittr,"%>%")

R/block.R

@@ -15,15 +15,16 @@
 #' @export
 new_block <- function(fields, expr, name = rand_names(), ...,
                       class = character()) {
-
   stopifnot(
     is.list(fields), length(fields) >= 1L, all(lgl_ply(fields, is_field)),
     is.language(expr),
     is_string(name)
   )
 
-  structure(fields, name = name, expr = expr, result = NULL, ...,
-            class = c(class, "block"))
+  structure(fields,
+    name = name, expr = expr, result = NULL, ...,
+    class = c(class, "block")
+  )
 }
 
 #' @param x An object inheriting form `"block"`
@@ -66,7 +67,6 @@ generate_code.block <- function(x) {
 #' @rdname new_block
 #' @export
 generate_code.transform_block <- function(x) {
-
   if (!is_initialized(x)) {
     return(quote(identity()))
   }
@@ -91,19 +91,31 @@ evalute_block.data_block <- function(x, ...) {
 #' @rdname new_block
 #' @export
 evalute_block.transform_block <- function(x, data, ...) {
+  stopifnot(...length() == 0L)
+  eval(
+    substitute(data %>% expr, list(expr = generate_code(x))),
+    list(data = data)
+  )
+}
 
+#' @param data Result from previous block
+#' @rdname new_block
+#' @export
+evalute_block.plot_block <- function(x, data, ...) {
   stopifnot(...length() == 0L)
+  tmp_expr <- strsplit(deparse1(generate_code(x)), "\\+")[[1]]
+  gg_init <- str2lang(tmp_expr[[1]])
+  gg_geom <- str2lang(tmp_expr[[2]])
 
   eval(
-    substitute(data %>% expr, list(expr = generate_code(x))),
+    substitute(data %>% expr + expr2, list(expr = gg_init, expr2 = gg_geom)),
     list(data = data)
   )
 }
 
 #' @rdname new_block
 #' @export
 new_data_block <- function(...) {
-
   is_dataset_eligible <- function(x) {
     inherits(
       get(x, envir = as.environment("package:datasets"), inherits = FALSE),
@@ -139,7 +151,6 @@ data_block <- function(...) {
 #' @rdname new_block
 #' @export
 initialize_block.data_block <- function(x, ...) {
-
   env <- list()
 
   for (field in names(x)) {
@@ -151,7 +162,8 @@ initialize_block.data_block <- function(x, ...) {
 }
 
 #' @param data Tabular data to filter (rows)
-#' @param columns,values Definition of the equality filter
+#' @param columns Definition of the equality filter.
+#' @param values Definition of the equality filter.
 #' @rdname new_block
 #' @export
 new_filter_block <- function(data, columns = colnames(data)[1L],
@@ -240,10 +252,80 @@ filter_block <- function(data, ...) {
   initialize_block(new_filter_block(data, ...), data)
 }
 
+#' @param data Tabular data in which to select some columns.
+#' @param columns Column(s) to select.
 #' @rdname new_block
 #' @export
-initialize_block.transform_block <- function(x, data, ...) {
+new_select_block <- function(data, columns = colnames(data)[1], ...) {
+  all_cols <- function(data) colnames(data)
+
+  # Select_field only allow one value, not multi select
+  fields <- list(
+    column = new_select_field(columns, all_cols, multiple = TRUE)
+  )
+
+  new_block(
+    fields = fields,
+    expr = quote(
+      dplyr::select(.(column))
+    ),
+    ...,
+    class = c("select_block", "transform_block")
+  )
+}
+
+#' @rdname new_block
+#' @export
+select_block <- function(data, ...) {
+  initialize_block(new_select_block(data, ...), data)
+}
 
+#' @param data Tabular data in which to select some columns.
+#' @param plot_opts List containing options for ggplot (color, ...).
+#' @param ... Any other params. TO DO
+#' @rdname new_block
+#' @import ggplot2
+#' @export
+new_plot_block <- function(
+  data,
+  plot_opts = list(colors = c("blue", "red")),
+  ...
+) {
+  # For plot blocks, fields will create input to style the plot ...
+  all_cols <- function(data) colnames(data)
+  fields <- list(
+    x_var = new_select_field(all_cols(data)[[1]], all_cols),
+    y_var = new_select_field(all_cols(data)[[2]], all_cols),
+    color = new_select_field(plot_opts$colors[[1]], plot_opts$colors)
+  )
+
+  new_block(
+    fields = fields,
+    expr = quote(
+      ggplot() +
+        geom_point(
+          # We have to use aes_string over aes
+          mapping = aes_string(
+            x = .(x_var),
+            y = .(y_var)
+          ),
+          color = .(color)
+        )
+    ),
+    ...,
+    class = c("plot_block")
+  )
+}
+
+#' @rdname new_block
+#' @export
+plot_block <- function(data, ...) {
+  initialize_block(new_plot_block(data, ...), data)
+}
+
+#' @rdname new_block
+#' @export
+initialize_block.transform_block <- function(x, data, ...) {
   env <- list(data = data)
 
   for (field in names(x)) {
@@ -254,6 +336,10 @@ initialize_block.transform_block <- function(x, data, ...) {
   x
 }
 
+#' @rdname new_block
+#' @export
+initialize_block.plot_block <- initialize_block.transform_block
+
 #' @rdname new_block
 #' @export
 update_fields <- function(x, ...) {
@@ -264,13 +350,11 @@ update_fields <- function(x, ...) {
 #' @rdname new_block
 #' @export
 update_fields.data_block <- function(x, session, ...) {
-
   args <- list(...)
 
   stopifnot(setequal(names(args), names(x)))
 
   for (field in names(x)) {
-
     env <- args[-which(names(args) == field)]
 
     x[[field]] <- update_field(x[[field]], args[[field]], env)
@@ -284,13 +368,11 @@ update_fields.data_block <- function(x, session, ...) {
 #' @rdname new_block
 #' @export
 update_fields.transform_block <- function(x, session, data, ...) {
-
   args <- list(...)
 
   stopifnot(setequal(names(args), names(x)))
 
   for (field in names(x)) {
-
     env <- c(
       list(data = data),
       args[-which(names(args) == field)]
@@ -302,3 +384,8 @@ update_fields.transform_block <- function(x, session, data, ...) {
 
   x
 }
+
+#' @param data Block input data
+#' @rdname new_block
+#' @export
+update_fields.plot_block <- update_fields.transform_block

R/field.R

@@ -11,7 +11,6 @@
 #' @export
 new_field <- function(value, ..., type = c("literal", "name"),
                       class = character()) {
-
   x <- list(value = value, ...)
 
   stopifnot(is.list(x), length(unique(names(x))) == length(x))
@@ -44,7 +43,6 @@ update_field <- function(x, new, env = list()) {
 #' @rdname new_field
 #' @export
 update_field.field <- function(x, new, env = list()) {
-
   x <- eval_set_field_value(x, env)
 
   if (is_truthy(new)) {
@@ -85,7 +83,6 @@ is_field <- function(x) inherits(x, "field")
 #' @rdname new_field
 #' @export
 validate_field.string_field <- function(x) {
-
   val <- value(x)
 
   if (!is.character(val) || length(val) != 1L) {
@@ -108,7 +105,6 @@ string_field <- function(...) validate_field(new_string_field(...))
 #' @rdname new_field
 #' @export
 validate_field.select_field <- function(x) {
-
   val <- value(x)
   opt <- value(x, "choices")
 
@@ -144,7 +140,6 @@ select_field <- function(...) validate_field(new_select_field(...))
 #' @rdname new_field
 #' @export
 value <- function(x, name = "value") {
-
   stopifnot(is_field(x))
 
   res <- x[[name]]