will fix lintr

BristolMyersSquibb · Sep 26, 2023 · 0ba8093 · 0ba8093
1 parent 83241f1
commit 0ba8093
Show file tree

Hide file tree

Showing 9 changed files with 44 additions and 70 deletions.
diff --git a/.lintr 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
   )
 }