From 825ed8174c981c7ceae8932dab415961f78078bb Mon Sep 17 00:00:00 2001 From: John Coene Date: Fri, 27 Oct 2023 14:48:21 +0200 Subject: [PATCH 1/4] feat: create block skeleton closes #59 --- NAMESPACE | 1 + R/create.R | 40 ++++++++++++++++++++++++++++++++ inst/templates/plot_block.R | 31 +++++++++++++++++++++++++ inst/templates/transform_block.R | 19 +++++++++++++++ man/create_block.Rd | 19 +++++++++++++++ man/new_block.Rd | 2 +- 6 files changed, 111 insertions(+), 1 deletion(-) create mode 100644 R/create.R create mode 100644 inst/templates/plot_block.R create mode 100644 inst/templates/transform_block.R create mode 100644 man/create_block.Rd diff --git a/NAMESPACE b/NAMESPACE index 2e4f188f..c1df12c6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -67,6 +67,7 @@ export(add_block) export(arrange_block) export(asfactor_block) export(cheat_block) +export(create_block) export(data_block) export(demo_arrange_block) export(demo_data_block) diff --git a/R/create.R b/R/create.R new file mode 100644 index 00000000..60651611 --- /dev/null +++ b/R/create.R @@ -0,0 +1,40 @@ +#' Create a new block +#' +#' Create a new block +#' +#' @param name Block name. +#' @param type Type of block to create. +#' @param file Output file. +#' If `NULL` then it constructs `R/-block.R`. +#' +#' @export +create_block <- function( + name, + type = c("transform", "plot"), + file = NULL +){ + if(missing(name)) + stop("Missing `name`") + + type <- match.arg(type) |> + (\(.) sprintf("%s_block", .))() + + if(is.null(file)) + file <- file.path( + "R", + sprintf("%s-block.R", name) + ) + + file_name <- sprintf("%s.R", type) + infile <- system.file( + file.path("templates", file_name), + package = "blockr" + ) + + content <- readLines(infile) |> + gsub("NAME", name, x = _) + + writeLines(content, con = file) + + cat("File", file, "created!\n") +} diff --git a/inst/templates/plot_block.R b/inst/templates/plot_block.R new file mode 100644 index 00000000..8562ebf7 --- /dev/null +++ b/inst/templates/plot_block.R @@ -0,0 +1,31 @@ +#' NAME +#' +#' A new plot block. +#' +#' @export +NAME_block <- function(data, ...){ + all_cols <- function(data) colnames(data) + + fields <- list( + x_var = new_select_field("VISIT", all_cols), + y_var = new_select_field("MEAN", all_cols) + ) + + new_block( + fields = fields, + expr = quote({ + ggplot( + data, + mapping = aes_string( + x = .(x_var), + y = .(y_var) + ) + ) + + geom_point() + + geom_line() + }), + ..., + class = c("NAME_block", "plot_block") + ) +} + diff --git a/inst/templates/transform_block.R b/inst/templates/transform_block.R new file mode 100644 index 00000000..4d12bcf1 --- /dev/null +++ b/inst/templates/transform_block.R @@ -0,0 +1,19 @@ +#' NAME +#' +#' A new transform block. +#' +#' @export +NAME_block <- function(data, ...){ + fields <- list( + n_rows = new_numeric_field(10, 10, nrow(data)) + ) + + new_block( + fields = fields, + expr = quote({ + head(data, .(n_rows)) + }), + ..., + class = c("NAME_block", "transform_block") + ) +} diff --git a/man/create_block.Rd b/man/create_block.Rd new file mode 100644 index 00000000..10193159 --- /dev/null +++ b/man/create_block.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/create.R +\name{create_block} +\alias{create_block} +\title{Create a new block} +\usage{ +create_block(name, type = c("transform", "plot"), file = NULL) +} +\arguments{ +\item{name}{Block name.} + +\item{type}{Type of block to create.} + +\item{file}{Output file. +If \code{NULL} then it constructs \verb{R/-block.R}.} +} +\description{ +Create a new block +} diff --git a/man/new_block.Rd b/man/new_block.Rd index dce2e100..a8599b75 100644 --- a/man/new_block.Rd +++ b/man/new_block.Rd @@ -185,7 +185,7 @@ new_cheat_block(data, ...) cheat_block(data, ...) -new_asfactor_block(data, column = character(), ...) +new_asfactor_block(data, column = "VISIT", ...) asfactor_block(data, ...) From 31f5023b8828faf0ce24336501df893dd16f9e9a Mon Sep 17 00:00:00 2001 From: John Coene Date: Fri, 27 Oct 2023 15:17:45 +0200 Subject: [PATCH 2/4] fix: style --- R/block.R | 196 +++++++++++++++++------------------- R/create.R | 21 ++-- R/demo-block.R | 8 +- R/field.R | 35 +++---- R/layout.R | 4 +- R/server.R | 193 ++++++++++++++++++----------------- R/stack.R | 2 +- R/ui.R | 12 +-- R/utils.R | 25 +++-- makefile | 5 +- tests/testthat/test-block.R | 5 - tests/testthat/test-field.R | 4 - tests/testthat/test-stack.R | 1 - 13 files changed, 247 insertions(+), 264 deletions(-) diff --git a/R/block.R b/R/block.R index 79cf4ab4..477177f7 100644 --- a/R/block.R +++ b/R/block.R @@ -140,10 +140,9 @@ evaluate_block.ggiraph_block <- evaluate_block.plot_block #' @param selected Selected dataset. #' @export new_data_block <- function( - ..., - dat = as.environment("package:blockr.data"), - selected = character() -) { + ..., + dat = as.environment("package:blockr.data"), + selected = character()) { is_dataset_eligible <- function(x) { inherits( get(x, envir = dat, inherits = FALSE), @@ -204,18 +203,14 @@ initialize_block.data_block <- function(x, ...) { #' @rdname new_block #' @export new_filter_block <- function( - data, - columns = colnames(data)[1L], - values = character(), - filter_fun = "==", - ... -) { - + data, + columns = colnames(data)[1L], + values = character(), + filter_fun = "==", + ...) { sub_fields <- function(data, columns) { - determine_field <- function(x) { - switch( - class(x), + switch(class(x), factor = select_field, numeric = range_field, string_field @@ -223,9 +218,7 @@ new_filter_block <- function( } field_args <- function(x) { - - switch( - class(x), + switch(class(x), factor = list(levels(x)[1L], choices = levels(x)), numeric = list(range(x), min = min(x), max = max(x)), list() @@ -242,15 +235,12 @@ new_filter_block <- function( filter_exps <- function(data, values, filter_func) { - filter_exp <- function(cls, col, val) { - if (is.null(val)) { return(quote(TRUE)) } - switch( - cls, + switch(cls, numeric = bquote( dplyr::between(.(column), ..(values)), list(column = as.name(col), values = val), @@ -343,12 +333,10 @@ new_select_block <- function(data, columns = colnames(data)[1], ...) { #' @rdname new_block #' @export new_summarize_block <- function( - data, - func = character(), - default_columns = character(), - ... -) { - + data, + func = character(), + default_columns = character(), + ...) { if (length(default_columns) > 0) { stopifnot(length(func) == length(default_columns)) } @@ -374,14 +362,22 @@ new_summarize_block <- function( summarize_expr <- function(data, funcs, columns) { # Build expressions that will go inside the summarize - if (length(funcs) == 0) return(quote(TRUE)) - if (length(columns) == 0) return(quote(TRUE)) + if (length(funcs) == 0) { + return(quote(TRUE)) + } + if (length(columns) == 0) { + return(quote(TRUE)) + } tmp_exprs <- lapply(funcs, function(fun) { col <- columns[[fun]] - if (is.null(col)) return(quote(TRUE)) - if (!any(col %in% colnames(data))) return(quote(TRUE)) + if (is.null(col)) { + return(quote(TRUE)) + } + if (!any(col %in% colnames(data))) { + return(quote(TRUE)) + } col <- as.name(col) expr <- if (fun == "se") { @@ -479,12 +475,11 @@ group_by_block <- function(data, ...) { #' to join #' @export new_join_block <- function( - data, - y = data(package = "blockr.data")$result[, "Item"], - type = character(), - by_col = character(), - ... -) { + data, + y = data(package = "blockr.data")$result[, "Item"], + type = character(), + by_col = character(), + ...) { # by depends on selected dataset and the input data. by_choices <- function(data, y) { choices <- intersect( @@ -566,7 +561,6 @@ join_block <- function(data, ...) { #' @param n_rows Number of rows to return. #' @export new_head_block <- function(data, n_rows = numeric(), ...) { - tmp_expr <- function(n_rows) { bquote( head(n = .(n_rows)), @@ -600,36 +594,35 @@ head_block <- function(data, ...) { #' @import ggplot2 #' @export new_plot_block <- function( - data, - plot_opts = list( - colors = c("blue", "red"), # when outside aes ... - point_size = 3, - title = "Plot title", - theme = c( - "theme_minimal", - "theme_gray", - "theme_linedraw", - "theme_dark", - "theme_light", - "theme_classic", - "theme_void", - "theme_bw" - ), - x_lab = "X axis label", - y_lab = "Y axis label", - errors = list( - show = FALSE, - ymin = character(), - ymax = character() + data, + plot_opts = list( + colors = c("blue", "red"), # when outside aes ... + point_size = 3, + title = "Plot title", + theme = c( + "theme_minimal", + "theme_gray", + "theme_linedraw", + "theme_dark", + "theme_light", + "theme_classic", + "theme_void", + "theme_bw" + ), + x_lab = "X axis label", + y_lab = "Y axis label", + errors = list( + show = FALSE, + ymin = character(), + ymax = character() + ), + lines = list( + show = FALSE, + group = character(), + color = character() + ) ), - lines = list( - show = FALSE, - group = character(), - color = character() - ) - ), - ... -) { + ...) { # For plot blocks, fields will create input to style the plot ... all_cols <- function(data) colnames(data) fields <- list( @@ -665,7 +658,7 @@ new_plot_block <- function( color = .data[[color]], shape = .data[[shape]] ), - size = 3 #.(point_size) TO DO: allow slide to have 1 value + size = 3 # .(point_size) TO DO: allow slide to have 1 value ) # Adding errors @@ -693,13 +686,13 @@ new_plot_block <- function( ) } - p + + p + labs( title = .(title), x = .(x_lab), y = .(y_lab) ) + - #theme_update(.(theme)) + + # theme_update(.(theme)) + theme( axis.text.x = element_text(angle = 45, hjust = 1), legend.title = element_text(face = "bold"), @@ -730,36 +723,35 @@ plot_block <- function(data, ...) { #' @import ggiraph #' @export new_ggiraph_block <- function( - data, - plot_opts = list( - colors = c("blue", "red"), # when outside aes ... - point_size = 3, - title = "Plot title", - theme = c( - "theme_minimal", - "theme_gray", - "theme_linedraw", - "theme_dark", - "theme_light", - "theme_classic", - "theme_void", - "theme_bw" - ), - x_lab = "X axis label", - y_lab = "Y axis label", - errors = list( - show = TRUE, - ymin = character(), - ymax = character() + data, + plot_opts = list( + colors = c("blue", "red"), # when outside aes ... + point_size = 3, + title = "Plot title", + theme = c( + "theme_minimal", + "theme_gray", + "theme_linedraw", + "theme_dark", + "theme_light", + "theme_classic", + "theme_void", + "theme_bw" + ), + x_lab = "X axis label", + y_lab = "Y axis label", + errors = list( + show = TRUE, + ymin = character(), + ymax = character() + ), + lines = list( + show = TRUE, + group = character(), + color = character() + ) ), - lines = list( - show = TRUE, - group = character(), - color = character() - ) - ), - ... -) { + ...) { # For plot blocks, fields will create input to style the plot ... all_cols <- function(data) colnames(data) fields <- list( @@ -791,7 +783,7 @@ new_ggiraph_block <- function( TOOLTIP_SE = sprintf( "x: %s\ny: %s\nmin: %s\nmax: %s", .data[[x_var]], .data[[y_var]], - ymin, ymax + ymin, ymax ) ) @@ -805,7 +797,7 @@ new_ggiraph_block <- function( shape = .data[[shape]], tooltip = TOOLTIP ), - size = 3 #.(point_size) TO DO: allow slide to have 1 value + size = 3 # .(point_size) TO DO: allow slide to have 1 value ) # Adding errors @@ -834,7 +826,7 @@ new_ggiraph_block <- function( ) } - p <- p + + p <- p + labs( title = .(title), x = .(x_lab), diff --git a/R/create.R b/R/create.R index 60651611..07a920d0 100644 --- a/R/create.R +++ b/R/create.R @@ -1,29 +1,30 @@ #' Create a new block -#' +#' #' Create a new block -#' +#' #' @param name Block name. #' @param type Type of block to create. #' @param file Output file. #' If `NULL` then it constructs `R/-block.R`. -#' +#' #' @export create_block <- function( - name, - type = c("transform", "plot"), - file = NULL -){ - if(missing(name)) + name, + type = c("transform", "plot"), + file = NULL) { + if (missing(name)) { stop("Missing `name`") + } type <- match.arg(type) |> (\(.) sprintf("%s_block", .))() - if(is.null(file)) + if (is.null(file)) { file <- file.path( "R", sprintf("%s-block.R", name) ) + } file_name <- sprintf("%s.R", type) infile <- system.file( @@ -35,6 +36,6 @@ create_block <- function( gsub("NAME", name, x = _) writeLines(content, con = file) - + cat("File", file, "created!\n") } diff --git a/R/demo-block.R b/R/demo-block.R index 64bca555..5a0a08e7 100644 --- a/R/demo-block.R +++ b/R/demo-block.R @@ -38,12 +38,12 @@ cheat_block <- function(data, ...) { #' @param column Column to apply the operation on. #' @export new_asfactor_block <- function(data, column = "VISIT", ...) { - all_cols <- function(data) colnames(data) mutate_expr <- function(data, column) { - - if (is.null(column)) return(NULL) + if (is.null(column)) { + return(NULL) + } if (!(column %in% colnames(data))) { return(NULL) } @@ -166,4 +166,4 @@ demo_summarize_block <- function(data, ...) { ), data ) -} \ No newline at end of file +} diff --git a/R/field.R b/R/field.R index 5a77443d..7a271ab2 100644 --- a/R/field.R +++ b/R/field.R @@ -75,7 +75,6 @@ initialize_field.field <- function(x, env = list()) { } eval_set_field_value <- function(x, env) { - for (cmp in names(x)[lgl_ply(x, is.function)]) { fun <- x[[cmp]] tmp <- do.call(fun, env[methods::formalArgs(fun)]) @@ -138,9 +137,10 @@ validate_field.select_field <- function(x) { #' @export new_select_field <- function(value = character(), choices = character(), multiple = FALSE, ...) { - - new_field(value, choices = choices, multiple = multiple, ..., - class = "select_field") + new_field(value, + choices = choices, multiple = multiple, ..., + class = "select_field" + ) } #' @rdname new_field @@ -160,7 +160,6 @@ switch_field <- function(...) validate_field(new_switch_field(...)) #' @rdname new_field #' @export validate_field.switch_field <- function(x) { - val <- value(x) if (length(val) == 0) { @@ -172,12 +171,10 @@ validate_field.switch_field <- function(x) { #' @rdname new_field #' @export new_numeric_field <- function( - value = numeric(), - min = numeric(), - max = numeric(), - ... -) { - + value = numeric(), + min = numeric(), + max = numeric(), + ...) { new_field(value, min = min, max = max, ..., class = "numeric_field") } @@ -228,7 +225,6 @@ values <- function(x, name = names(x)) { #' @rdname new_field #' @export `value<-` <- function(x, name = "value", value) { - if (is.null(x)) { return(NULL) } @@ -250,9 +246,10 @@ values <- function(x, name = names(x)) { #' @export new_variable_field <- function(value = character(), field = character(), components = list(), ...) { - - new_field(value, field = field, components = components, ..., - class = "variable_field") + new_field(value, + field = field, components = components, ..., + class = "variable_field" + ) } #' @rdname new_field @@ -262,7 +259,6 @@ variable_field <- function(...) validate_field(new_variable_field(...)) #' @rdname new_field #' @export validate_field.variable_field <- function(x) { - val <- value(x, "field") opt <- c( "string_field", @@ -287,7 +283,6 @@ validate_field.variable_field <- function(x) { } materialize_variable_field <- function(x) { - cmp <- value(x, "components") val <- value(x) @@ -303,7 +298,6 @@ materialize_variable_field <- function(x) { #' @export new_range_field <- function(value = numeric(), min = numeric(), max = numeric(), ...) { - new_field(value, min = min, max = max, ..., class = "range_field") } @@ -314,7 +308,6 @@ range_field <- function(...) validate_field(new_range_field(...)) #' @rdname new_field #' @export validate_field.range_field <- function(x) { - val <- value(x) if (!is.numeric(val) || length(val) < 2L) { @@ -358,13 +351,11 @@ list_field <- function(...) validate_field(new_list_field(...)) #' @rdname new_field #' @export validate_field.list_field <- function(x) { - val <- value(x) sub <- value(x, "sub_fields") if (!is.list(val) || length(val) != length(sub) || - !setequal(names(val), names(sub))) { - + !setequal(names(val), names(sub))) { value(x) <- lst_xtr(sub, "value") } diff --git a/R/layout.R b/R/layout.R index 2b8e2c8f..7032c7e0 100644 --- a/R/layout.R +++ b/R/layout.R @@ -60,7 +60,7 @@ plot_layout_fields <- function(fields, ...) { ggiraph_layout_fields <- plot_layout_fields -filter_layout_fields <- function(fields, ...){ +filter_layout_fields <- function(fields, ...) { tagList( div( class = "row", @@ -98,7 +98,7 @@ summarize_layout_fields <- function(fields, ...) { ) } -join_layout_fields <- function(fields, ...){ +join_layout_fields <- function(fields, ...) { tagList( div( class = "row", diff --git a/R/server.R b/R/server.R index d4c52d25..e3f63a54 100644 --- a/R/server.R +++ b/R/server.R @@ -20,7 +20,6 @@ generate_server.block <- function(x, ...) { #' @rdname generate_server #' @export generate_server.data_block <- function(x, id, ...) { - obs_expr <- function(x) { splice_args( list(..(args)), @@ -56,22 +55,25 @@ generate_server.data_block <- function(x, id, ...) { # Cleanup module inputs (UI and server side) # and observer - observeEvent(input$remove, { - # Trick to be able to tell the stack to wait - # for this event to run. - session$userData$is_cleaned(FALSE) - # Can only remove when it is the last stack block - if (length(session$userData$stack) == 1) { - message(sprintf("CLEANING UP BLOCK %s", id)) - remove_shiny_inputs(id = id, input) - o$destroy() - session$userData$is_cleaned(TRUE) - } - # We have to set high priority so this event - # executes before the one in the stack which - # updates the stack. If we don't, this will - # never execute because the stack will be empty :) - }, priority = 500) + observeEvent(input$remove, + { + # Trick to be able to tell the stack to wait + # for this event to run. + session$userData$is_cleaned(FALSE) + # Can only remove when it is the last stack block + if (length(session$userData$stack) == 1) { + message(sprintf("CLEANING UP BLOCK %s", id)) + remove_shiny_inputs(id = id, input) + o$destroy() + session$userData$is_cleaned(TRUE) + } + # We have to set high priority so this event + # executes before the one in the stack which + # updates the stack. If we don't, this will + # never execute because the stack will be empty :) + }, + priority = 500 + ) out_dat } @@ -82,7 +84,6 @@ generate_server.data_block <- function(x, id, ...) { #' @rdname generate_server #' @export generate_server.transform_block <- function(x, in_dat, id, ...) { - obs_expr <- function(x) { splice_args( list(in_dat(), ..(args)), @@ -134,7 +135,6 @@ generate_server.transform_block <- function(x, in_dat, id, ...) { #' @rdname generate_server #' @export generate_server.plot_block <- function(x, in_dat, id, ...) { - obs_expr <- function(x) { splice_args( list(in_dat(), ..(args)), @@ -207,47 +207,50 @@ generate_server.stack <- function(x, id = NULL, new_blocks = NULL, ...) { vals$remove <- TRUE }) - observeEvent({ - req(new_blocks) - new_blocks() - }, { - # Update stack - block_to_add <- new_blocks()$block - position <- new_blocks()$position - - vals$stack <- add_block(vals$stack, block_to_add, position) - - # Call module - p <- if (is.null(position)) { - length(vals$stack) - } else { - position + 1 - } - vals$blocks[[p]] <- init_block(p, vals) - - # Insert UI - insertUI( - selector = sprintf( - "[data-value='%s-block']", - session$ns(attr(vals$stack[[p - 1]], "name")) - ), - where = "afterEnd", - generate_ui( - vals$stack[[p]], - id = session$ns(attr(vals$stack[[p]], "name")), - .hidden = FALSE + observeEvent( + { + req(new_blocks) + new_blocks() + }, + { + # Update stack + block_to_add <- new_blocks()$block + position <- new_blocks()$position + + vals$stack <- add_block(vals$stack, block_to_add, position) + + # Call module + p <- if (is.null(position)) { + length(vals$stack) + } else { + position + 1 + } + vals$blocks[[p]] <- init_block(p, vals) + + # Insert UI + insertUI( + selector = sprintf( + "[data-value='%s-block']", + session$ns(attr(vals$stack[[p - 1]], "name")) + ), + where = "afterEnd", + generate_ui( + vals$stack[[p]], + id = session$ns(attr(vals$stack[[p]], "name")), + .hidden = FALSE + ) ) - ) - # Necessary to communicate with downstream modules - session$userData$stack <- vals$stack + # Necessary to communicate with downstream modules + session$userData$stack <- vals$stack - # trigger javascript-ui functionalities on add - session$sendCustomMessage( - "blockr-add-block", - list(stack = session$ns(NULL)) - ) - }) + # trigger javascript-ui functionalities on add + session$sendCustomMessage( + "blockr-add-block", + list(stack = session$ns(NULL)) + ) + } + ) # Remove block from stack (can't be done within the block) to_remove <- reactive({ @@ -269,37 +272,40 @@ generate_server.stack <- function(x, id = NULL, new_blocks = NULL, ...) { session$userData$is_cleaned <- reactiveVal(FALSE) - observeEvent({ - c( - to_remove(), - session$userData$is_cleaned() - ) - }, { - # We can't remove the data block if there are downstream consumers... - if (to_remove() == 1 && length(vals$stack) > 1) { - showModal( - modalDialog( - title = h3(icon("xmark"), "Error"), - "Can't remove a datablock whenever there are - downstream data block consumers." - ) + observeEvent( + { + c( + to_remove(), + session$userData$is_cleaned() ) - } else { - if (session$userData$is_cleaned()) { - message(sprintf("REMOVING BLOCK %s", to_remove())) - removeUI( - selector = sprintf( - "[data-value='%s%s-block']", - session$ns(""), - attr(vals$stack[[to_remove()]], "name") + }, + { + # We can't remove the data block if there are downstream consumers... + if (to_remove() == 1 && length(vals$stack) > 1) { + showModal( + modalDialog( + title = h3(icon("xmark"), "Error"), + "Can't remove a datablock whenever there are + downstream data block consumers." ) ) - vals$stack[[to_remove()]] <- NULL - session$userData$stack <- vals$stack - session$userData$is_cleaned(FALSE) + } else { + if (session$userData$is_cleaned()) { + message(sprintf("REMOVING BLOCK %s", to_remove())) + removeUI( + selector = sprintf( + "[data-value='%s%s-block']", + session$ns(""), + attr(vals$stack[[to_remove()]], "name") + ) + ) + vals$stack[[to_remove()]] <- NULL + session$userData$stack <- vals$stack + session$userData$is_cleaned(FALSE) + } } } - }) + ) observe({ session$sendCustomMessage( @@ -368,16 +374,19 @@ server_output <- function(x, result, output) { #' @rdname generate_ui #' @export server_output.block <- function(x, result, output) { - DT::renderDT({ - result() |> - DT::datatable( - selection = "none", - options = list( - pageLength = 5L, - processing = FALSE + DT::renderDT( + { + result() |> + DT::datatable( + selection = "none", + options = list( + pageLength = 5L, + processing = FALSE + ) ) - ) - }, server = TRUE) + }, + server = TRUE + ) } #' @rdname generate_ui diff --git a/R/stack.R b/R/stack.R index 580fedb1..382c4b69 100644 --- a/R/stack.R +++ b/R/stack.R @@ -67,7 +67,7 @@ add_block <- function(stack, block, position = NULL) { # get data from the previous block if (length(stack) == 1) { - data <- evaluate_block(stack[[position]]) + data <- evaluate_block(stack[[position]]) } else { data <- evaluate_block(stack[[1]]) for (i in seq_along(stack)[-1L]) { diff --git a/R/ui.R b/R/ui.R index 14963048..25042615 100644 --- a/R/ui.R +++ b/R/ui.R @@ -32,12 +32,14 @@ generate_ui.block <- function(x, id, ..., .hidden = TRUE) { header <- block_title(x, code_id, output_id, ns) block_class <- "block" - if (.hidden) + if (.hidden) { block_class <- sprintf("%s d-none", block_class) + } inputs_hidden <- "" - if (.hidden) + if (.hidden) { inputs_hidden <- "d-none" + } layout <- attr(x, "layout") @@ -254,7 +256,7 @@ ui_input.switch_field <- function(x, id, name) { #' @export ui_input.numeric_field <- function(x, id, name) { numericInput( - input_ids(x, id), name, value(x), value(x, "min"), value(x, "max") + input_ids(x, id), name, value(x), value(x, "min"), value(x, "max") ) } @@ -286,7 +288,6 @@ input_ids.list_field <- function(x, name, ...) { #' @rdname generate_ui #' @export ui_input.variable_field <- function(x, id, name) { - field <- validate_field( materialize_variable_field(x) ) @@ -314,7 +315,6 @@ ui_input.hidden_field <- function(x, id, name) { #' @rdname generate_ui #' @export ui_input.list_field <- function(x, id, name) { - fields <- lapply( update_sub_fields(value(x, "sub_fields"), value(x)), validate_field @@ -361,7 +361,6 @@ ui_update.switch_field <- function(x, session, id, name) { #' @rdname generate_ui #' @export ui_update.variable_field <- function(x, session, id, name) { - ns <- session$ns ns_id <- ns(id) @@ -406,7 +405,6 @@ ui_update.hidden_field <- function(x, session, id, name) { #' @rdname generate_ui #' @export ui_update.list_field <- function(x, session, id, name) { - ns <- session$ns ns_id <- ns(id) diff --git a/R/utils.R b/R/utils.R index bd6412f5..667d4840 100644 --- a/R/utils.R +++ b/R/utils.R @@ -114,7 +114,6 @@ quoted_input_entry <- function(x) { } quoted_input_entries <- function(x) { - if (length(x) == 1L && is.null(names(x))) { return(quoted_input_entry(x)) } @@ -143,7 +142,6 @@ type_trans <- function(x) { } is_truthy <- function(x) { - if (inherits(x, "try-error")) { FALSE } else if (!is.atomic(x)) { @@ -206,12 +204,10 @@ convert_block <- function(from = new_select_block, to, data, ...) { #' #' @keywords internal off_canvas <- function( - id, - title, - ..., - position = c("start", "top", "bottom", "end") -) { - + id, + title, + ..., + position = c("start", "top", "bottom", "end")) { position <- match.arg(position) label <- rand_names() @@ -266,9 +262,12 @@ create_modal <- function(...) { #' #' @keywords internal secure <- function(expr) { - tryCatch({ - expr - }, error = function(e) { - create_modal(e$message) - }) + tryCatch( + { + expr + }, + error = function(e) { + create_modal(e$message) + } + ) } diff --git a/makefile b/makefile index c98b1028..afc1a902 100644 --- a/makefile +++ b/makefile @@ -13,9 +13,12 @@ bundle_dev: sass install: check Rscript -e "devtools::install()" -sass: +sass: style Rscript dev/sass.R +style: + Rscript -e "styler::style_pkg()" + run: bundle_dev Rscript test.R diff --git a/tests/testthat/test-block.R b/tests/testthat/test-block.R index 092d2525..fee0dac9 100644 --- a/tests/testthat/test-block.R +++ b/tests/testthat/test-block.R @@ -1,7 +1,6 @@ library(dplyr) library(blockr.data) test_that("data blocks", { - block <- data_block() expect_s3_class(block, "data_block") @@ -18,7 +17,6 @@ test_that("data blocks", { }) test_that("filter blocks", { - data <- datasets::iris block <- filter_block(data) @@ -38,7 +36,6 @@ test_that("filter blocks", { }) test_that("select blocks", { - data <- datasets::iris block <- select_block(data) @@ -54,7 +51,6 @@ test_that("select blocks", { }) test_that("arrange blocks", { - data <- datasets::iris min_sepal_len <- min(data$Sepal.Length) @@ -71,7 +67,6 @@ test_that("arrange blocks", { }) test_that("group_by blocks", { - data <- datasets::iris block <- group_by_block(data, columns = "Species") diff --git a/tests/testthat/test-field.R b/tests/testthat/test-field.R index 87473dc3..dcd3b602 100644 --- a/tests/testthat/test-field.R +++ b/tests/testthat/test-field.R @@ -1,5 +1,4 @@ test_that("string fields", { - field <- string_field("foo") expect_s3_class(field, "string_field") @@ -14,7 +13,6 @@ test_that("string fields", { }) test_that("select fields", { - field <- select_field("a", letters) expect_s3_class(field, "select_field") @@ -35,7 +33,6 @@ test_that("select fields", { }) test_that("range fields", { - field <- range_field(min = 0, max = 10) expect_s3_class(field, "range_field") @@ -44,7 +41,6 @@ test_that("range fields", { }) test_that("numeric fields", { - field <- numeric_field(min = 0, max = 10) expect_s3_class(field, "numeric_field") diff --git a/tests/testthat/test-stack.R b/tests/testthat/test-stack.R index e2a84806..8287e53b 100644 --- a/tests/testthat/test-stack.R +++ b/tests/testthat/test-stack.R @@ -1,5 +1,4 @@ test_that("stacks", { - stack <- new_stack( new_data_block, new_filter_block From 4b75a3e63966ff1f348beadfdb758a66936e6389 Mon Sep 17 00:00:00 2001 From: DivadNojnarg Date: Fri, 27 Oct 2023 17:49:55 +0200 Subject: [PATCH 3/4] finish lint --- .lintr | 1 + R/field.R | 2 +- inst/templates/plot_block.R | 19 +++++++++---------- inst/templates/transform_block.R | 6 +++--- 4 files changed, 14 insertions(+), 14 deletions(-) diff --git a/.lintr b/.lintr index c3ce2491..5e6f73df 100644 --- a/.lintr +++ b/.lintr @@ -1,4 +1,5 @@ linters: linters_with_defaults( + line_length_linter(length = 100L), 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 ... ) diff --git a/R/field.R b/R/field.R index 7a271ab2..372007e9 100644 --- a/R/field.R +++ b/R/field.R @@ -355,7 +355,7 @@ validate_field.list_field <- function(x) { sub <- value(x, "sub_fields") if (!is.list(val) || length(val) != length(sub) || - !setequal(names(val), names(sub))) { + !setequal(names(val), names(sub))) { value(x) <- lst_xtr(sub, "value") } diff --git a/inst/templates/plot_block.R b/inst/templates/plot_block.R index 8562ebf7..2fb24579 100644 --- a/inst/templates/plot_block.R +++ b/inst/templates/plot_block.R @@ -1,9 +1,9 @@ #' NAME -#' +#' #' A new plot block. -#' +#' #' @export -NAME_block <- function(data, ...){ +NAME_block <- function(data, ...) { all_cols <- function(data) colnames(data) fields <- list( @@ -15,12 +15,12 @@ NAME_block <- function(data, ...){ fields = fields, expr = quote({ ggplot( - data, - mapping = aes_string( - x = .(x_var), - y = .(y_var) - ) - ) + + data, + mapping = aes_string( + x = .(x_var), + y = .(y_var) + ) + ) + geom_point() + geom_line() }), @@ -28,4 +28,3 @@ NAME_block <- function(data, ...){ class = c("NAME_block", "plot_block") ) } - diff --git a/inst/templates/transform_block.R b/inst/templates/transform_block.R index 4d12bcf1..b53b224c 100644 --- a/inst/templates/transform_block.R +++ b/inst/templates/transform_block.R @@ -1,9 +1,9 @@ #' NAME -#' +#' #' A new transform block. -#' +#' #' @export -NAME_block <- function(data, ...){ +NAME_block <- function(data, ...) { fields <- list( n_rows = new_numeric_field(10, 10, nrow(data)) ) From 8c606ed714ffff7f2f3bc3968e7b82f74c3be72a Mon Sep 17 00:00:00 2001 From: DivadNojnarg Date: Fri, 27 Oct 2023 17:56:18 +0200 Subject: [PATCH 4/4] lint config issue --- .lintr | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.lintr b/.lintr index 5e6f73df..e98afdcb 100644 --- a/.lintr +++ b/.lintr @@ -1,5 +1,5 @@ linters: linters_with_defaults( - line_length_linter(length = 100L), + line_length_linter = line_length_linter(100L), 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 ... )