diff --git a/.lintr b/.lintr new file mode 100644 index 00000000..93d33d05 --- /dev/null +++ b/.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 ... + ) diff --git a/NAMESPACE b/NAMESPACE index eaae10cc..faad3008 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -58,6 +58,7 @@ export(new_select_block) export(new_select_field) export(new_stack) export(new_string_field) +export(select_block) export(select_field) export(serve_stack) export(server_code) diff --git a/R/block.R b/R/block.R index c1331091..862bdae6 100644 --- a/R/block.R +++ b/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"` @@ -48,7 +49,6 @@ is_initialized.block <- function(x) { #' @rdname new_block #' @export initialize_block <- function(x, ...) { - if (is_initialized(x)) { return(x) } @@ -73,7 +73,7 @@ generate_code <- function(x) { generate_code.block <- function(x) { # TO DO: find a better way to handle this ... tmp_expr <- if (inherits(x, "filter_block")) { - if (is.na(x[["value"]]) || nchar(x[["value"]]) == 0) { + if (is.na(x[["value"]]) || nchar(x[["value"]]) == 0) { attr(x, "default_expr") } else { attr(x, "expr") @@ -93,7 +93,6 @@ generate_code.block <- function(x) { #' @rdname new_block #' @export generate_code.transform_block <- function(x) { - if (!is_initialized(x)) { return(quote(identity())) } @@ -124,7 +123,6 @@ 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))), @@ -150,7 +148,6 @@ evalute_block.plot_block <- function(x, data, ...) { #' @rdname new_block #' @export new_data_block <- function(...) { - is_dataset_eligible <- function(x) { inherits( get(x, envir = as.environment("package:datasets"), inherits = FALSE), @@ -186,7 +183,6 @@ data_block <- function(...) { #' @rdname new_block #' @export initialize_block.data_block <- function(x, ...) { - env <- list() for (field in names(x)) { @@ -203,7 +199,6 @@ initialize_block.data_block <- function(x, ...) { #' @export new_filter_block <- function(data, column = character(), value = character(), ...) { - cols <- quote(colnames(.(data))) fields <- list( @@ -266,7 +261,6 @@ select_block <- function(data, ...) { #' @import ggplot2 #' @export new_plot_block <- function(dat, x, y, plot_opts = list(color = "blue"), ...) { - # For plot blocks, fields will create input to style the plot ... fields <- list( x = string_field(colnames(dat)[[1]]), @@ -292,16 +286,15 @@ new_plot_block <- function(dat, x, y, plot_opts = list(color = "blue"), ...) { ) } -##' @rdname new_block +##' @rdname new_block #nolint start ##' @export -#plot_block <- function(data, ...) { +# plot_block <- function(data, ...) { # initialize_block(new_plot_block(data, ...), data) -#} +# } #nolint end #' @rdname new_block #' @export initialize_block.transform_block <- function(x, data, ...) { - env <- list(data = data) for (field in names(x)) { @@ -328,13 +321,11 @@ update_fields.block <- 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) @@ -348,13 +339,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)] @@ -368,5 +357,5 @@ update_fields.transform_block <- function(x, session, data, ...) { } update_fields.select_block <- function(x, data, session, ...) { - #browser() + # browser() #nolint } diff --git a/R/field.R b/R/field.R index 912e064f..febce243 100644 --- a/R/field.R +++ b/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)) @@ -29,7 +28,6 @@ is_initialized.field <- function(x) { #' @rdname new_field #' @export validate_field <- function(x) { - if (is_initialized(x)) { UseMethod("validate_field", x) } @@ -55,7 +53,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) value(x) <- new @@ -77,7 +74,6 @@ initialize_field.field <- function(x, env = list()) { } eval_set_field_value <- function(x, env) { - for (cmp in names(x)[lgl_ply(x, is.language)]) { expr <- do.call(bquote, list(expr = x[[cmp]], where = env)) value(x, cmp) <- eval(expr) @@ -93,7 +89,6 @@ is_field <- function(x) inherits(x, "field") #' @rdname new_field #' @export validate_field.string_field <- function(x) { - val <- value(x) stopifnot(is.character(val), length(val) <= 1L) @@ -114,7 +109,6 @@ string_field <- function(...) validate_field(new_string_field(...)) #' @rdname new_field #' @export validate_field.select_field <- function(x) { - val <- value(x) stopifnot(is.character(val), length(val) <= 1L) @@ -141,7 +135,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]] @@ -163,7 +156,6 @@ values <- function(x, name = names(x)) { #' @rdname new_field #' @export `value<-` <- function(x, name = "value", value) { - stopifnot(is_field(x)) if (is.language(x[[name]])) { diff --git a/R/server.R b/R/server.R index 30511731..bfda6586 100644 --- a/R/server.R +++ b/R/server.R @@ -19,7 +19,6 @@ generate_server.block <- function(x, ...) { #' @rdname generate_server #' @export generate_server.data_block <- function(x, ...) { - fields <- names(x) quot_inp <- lapply(fields, quoted_input_entry) @@ -37,7 +36,6 @@ generate_server.data_block <- function(x, ...) { shiny::moduleServer( attr(x, "name"), function(input, output, session) { - module_name <- sprintf("module %s %s", class(x)[[1]], attr(x, "name")) blk <- shiny::reactiveVal(x) @@ -66,7 +64,6 @@ generate_server.data_block <- function(x, ...) { #' @rdname generate_server #' @export generate_server.transform_block <- function(x, in_dat, ...) { - fields <- names(x) quot_inp <- lapply(fields, quoted_input_entry) @@ -84,7 +81,6 @@ generate_server.transform_block <- function(x, in_dat, ...) { shiny::moduleServer( attr(x, "name"), function(input, output, session) { - blk <- shiny::reactiveVal(x) shiny::observeEvent( @@ -110,13 +106,11 @@ generate_server.transform_block <- function(x, in_dat, ...) { #' @rdname generate_server #' @export generate_server.stack <- function(x, ...) { - stopifnot(...length() == 0L) shiny::moduleServer( attr(x, "name"), function(input, output, session) { - res <- vector("list", length(x)) res[[1L]] <- generate_server(x[[1L]]) @@ -155,7 +149,6 @@ server_code <- function(x, state, output) { #' @rdname generate_ui #' @export server_code.block <- function(x, state, output) { - output$code <- shiny::renderPrint( cat(deparse(generate_code(state())), sep = "\n") ) diff --git a/R/stack.R b/R/stack.R index 531b1a7d..0cbc0265 100644 --- a/R/stack.R +++ b/R/stack.R @@ -8,7 +8,6 @@ #' #' @export new_stack <- function(..., name = rand_names()) { - ctors <- c(...) names <- names(ctors) @@ -35,7 +34,6 @@ new_stack <- function(..., name = rand_names()) { #' @rdname new_stack #' @export serve_stack <- function(stack) { - ui <- generate_ui(stack) server <- function(input, output, session) { diff --git a/R/ui.R b/R/ui.R index f1a218b2..e8ea7fca 100644 --- a/R/ui.R +++ b/R/ui.R @@ -14,7 +14,6 @@ generate_ui <- function(x, ...) { #' @rdname generate_ui #' @export generate_ui.block <- function(x, id, ...) { - stopifnot(...length() == 0L) ns <- shiny::NS( @@ -49,18 +48,20 @@ generate_ui.block <- function(x, id, ...) { } shiny::tagList( - # Ensure collapse is visible - shiny::tags$head( - shiny::tags$script( - sprintf("$(function() { + # Ensure collapse is visible + shiny::tags$head( + shiny::tags$script( + sprintf( + "$(function() { const bsCollapse = new bootstrap.Collapse('#%s', { toggle: true }); });", ns("collapse_data") - )) - ), - div_card( + ) + ) + ), + div_card( title = shiny::h4(attr(x, "name")), bslib::layout_sidebar( sidebar = shiny::tagList( @@ -82,19 +83,18 @@ generate_ui.block <- function(x, id, ...) { #' @rdname generate_ui #' @export generate_ui.stack <- function(x, ...) { - stopifnot(...length() == 0L) bslib::page_fluid( do.call( - bslib::accordion, - c( - lapply(x, generate_ui, id = attr(x, "name")), - title = attr(x, "name"), - open = TRUE + bslib::accordion, + c( + lapply(x, generate_ui, id = attr(x, "name")), + title = attr(x, "name"), + open = TRUE + ) ) ) - ) } #' @param name Field name @@ -174,14 +174,14 @@ ui_update.select_field <- function(x, session, id, name) { #' @keywords internal div_card <- function(..., title = NULL, footer = NULL) { bslib::accordion_panel( - #class = "panel panel-default", - #style = "margin: 10px;", + # class = "panel panel-default", #nolint start + # style = "margin: 10px;", title = if (not_null(title)) title, value = "plop", - ...#, - #if (not_null(footer)) { + ... # , + # if (not_null(footer)) { # shiny::div(footer, class = "panel-footer") - #} + # } #nolint end ) } diff --git a/R/utils.R b/R/utils.R index eb091f03..a4b18118 100644 --- a/R/utils.R +++ b/R/utils.R @@ -15,7 +15,6 @@ NULL rand_names <- function(old_names = character(0L), n = 1L, length = 15L, chars = letters, prefix = "", suffix = "") { - stopifnot( is.null(old_names) || is.character(old_names), is_count(n), is_count(length), @@ -27,8 +26,8 @@ rand_names <- function(old_names = character(0L), n = 1L, length = 15L, length <- length - (nchar(prefix) + nchar(suffix)) repeat { - - res <- replicate(n, + res <- replicate( + n, paste0( prefix, paste(sample(chars, length, replace = TRUE), collapse = ""), @@ -48,6 +47,7 @@ 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) } @@ -89,7 +89,6 @@ is_intish <- function(x) { } is_count <- function(x, include_zero = TRUE) { - if (length(x) != 1) { return(FALSE) } @@ -126,11 +125,9 @@ splice_args <- function(expr, ...) { } type_trans <- function(x) { - res <- value(x) - switch( - attr(x, "type"), + switch(attr(x, "type"), literal = res, name = as.name(res) ) diff --git a/man/new_block.Rd b/man/new_block.Rd index 4db512cd..8459623f 100644 --- a/man/new_block.Rd +++ b/man/new_block.Rd @@ -19,10 +19,10 @@ \alias{data_block} \alias{initialize_block.data_block} \alias{new_filter_block} +\alias{filter_block} \alias{new_select_block} +\alias{select_block} \alias{new_plot_block} -\alias{filter_block} -\alias{initialize_block.transform_block} \alias{update_fields} \alias{update_fields.block} \alias{update_fields.data_block} @@ -66,13 +66,13 @@ data_block(...) new_filter_block(data, column = character(), value = character(), ...) -new_select_block(dat, cols = colnames(dat)[1L], ...) +filter_block(data, ...) -new_plot_block(dat, x, y, plot_opts = list(color = "blue"), ...) +new_select_block(dat, cols = colnames(dat)[1L], ...) -filter_block(data, ...) +select_block(data, ...) -\method{initialize_block}{transform_block}(x, data, ...) +new_plot_block(dat, x, y, plot_opts = list(color = "blue"), ...) update_fields(x, ...)