Merge pull request #2 from Boehringer-Ingelheim/fix_lintr

Fix lintr failures

R/create_filter_ui.R

@@ -50,7 +50,7 @@ create_filter_ui <- function(x, id, var, val) {
     if (na_sum > 0) color[1] <- "#8B0000" # "darkred"
     # https://blog.prototypr.io/css-only-multi-color-backgrounds-4d96a5569a20?gi=ae55142ef933
     style <- glue::glue(
-      "color: {color}; border: 1px solid black; background: 
+      "color: {color}; border: 1px solid black; background:
        linear-gradient(90deg, rgba(173, 216, 230, 1) {N_pct}%, rgba(0, 0, 0, 0) {N_pct}%);"
     )
     picker_ui <- shinyWidgets::pickerInput(

R/data_filter_server.R

@@ -16,9 +16,13 @@ data_filter_server <- function(id, data) {
     shiny::observeEvent(data(), {
       purrr::walk(names(data()), function(var) {
         input_init_null[[var]] <- NA
-        shiny::observeEvent(input[[var]], {
-          input_init_null[[var]] <- input[[var]]
-        }, ignoreNULL = FALSE, ignoreInit = TRUE)
+        shiny::observeEvent(input[[var]],
+          {
+            input_init_null[[var]] <- input[[var]]
+          },
+          ignoreNULL = FALSE,
+          ignoreInit = TRUE
+        )
       })
     })
 
@@ -120,9 +124,12 @@ data_filter_server <- function(id, data) {
         # don't need to re-enter the values when a filter is added or removed.
         val <- shiny::isolate(input[[filter_var]])
         if (get_input_type(x) == "slider") {
-          output[[paste0(filter_var, "_plot")]] <- shiny::renderPlot({
-            hist_plot(x, selected())
-          }, bg = "transparent")
+          output[[paste0(filter_var, "_plot")]] <- shiny::renderPlot(
+            {
+              hist_plot(x, selected())
+            },
+            bg = "transparent"
+          )
         }
         create_filter_ui(x = x, id = session$ns(filter_var), var = filter_var, val = val)
       })
@@ -133,55 +140,58 @@ data_filter_server <- function(id, data) {
         "{sum(selected())} of {length(selected())} total entries selected"
       )
     })
-
-    shiny::observeEvent(selected(), {
-      shiny::req(length(input$vars) > 0)
-      purrr::walk(input$vars, function(var) {
-        x <- data()[[var]]
-        if (get_input_type(x) == "picker") {
-          y <- factor(selected(), levels = c(FALSE, TRUE))
-          # create a contingency table to calculate number of rows in filtered and full data
-          tbl <- stats::addmargins(table(x, y), margin = 2) %>% 
-            as.data.frame.matrix()
-          # arrange the contingency table in an descending order by the number of rows in full data
-          tbl_desc <- dplyr::arrange(tbl, -.data[["Sum"]])
-          # subset the contingency table by excluding categories that have empty rows in full data
-          tbl_desc <- dplyr::filter(tbl_desc, .data[["Sum"]] > 0)
-          choices <- rownames(tbl_desc)
-          n <- tbl_desc[["TRUE"]]
-          N <- tbl_desc[["Sum"]] # nolint
-          color <- rep("#000000", length(N)) # "black"
-          if (any(is.na(x))) {
-            choices <- c("<MISSING>", choices)
-            n <- c(sum(is.na(x[y == TRUE])), n)
-            N <- c(sum(is.na(x)), N) # nolint
-            color <- c("#8B0000", color) # "darkred"
-          }
-          N_pct <- floor(100 * N / max(N)) # nolint
-          n_pct <- floor(100 * n / max(N))
-          # https://blog.prototypr.io/css-only-multi-color-backgrounds-4d96a5569a20?gi=ae55142ef933
-          style <- glue::glue(
-            "color: {color}; border: 1px solid black; background:
+
+    shiny::observeEvent(selected(),
+      {
+        shiny::req(length(input$vars) > 0)
+        purrr::walk(input$vars, function(var) {
+          x <- data()[[var]]
+          if (get_input_type(x) == "picker") {
+            y <- factor(selected(), levels = c(FALSE, TRUE))
+            # create a contingency table to calculate number of rows in filtered and full data
+            tbl <- stats::addmargins(table(x, y), margin = 2) %>%
+              as.data.frame.matrix()
+            # arrange the contingency table in an descending order by the number of rows in full data
+            tbl_desc <- dplyr::arrange(tbl, -.data[["Sum"]])
+            # subset the contingency table by excluding categories that have empty rows in full data
+            tbl_desc <- dplyr::filter(tbl_desc, .data[["Sum"]] > 0)
+            choices <- rownames(tbl_desc)
+            n <- tbl_desc[["TRUE"]]
+            N <- tbl_desc[["Sum"]] # nolint
+            color <- rep("#000000", length(N)) # "black"
+            if (any(is.na(x))) {
+              choices <- c("<MISSING>", choices)
+              n <- c(sum(is.na(x[y == TRUE])), n)
+              N <- c(sum(is.na(x)), N) # nolint
+              color <- c("#8B0000", color) # "darkred"
+            }
+            N_pct <- floor(100 * N / max(N)) # nolint
+            n_pct <- floor(100 * n / max(N))
+            # https://blog.prototypr.io/css-only-multi-color-backgrounds-4d96a5569a20?gi=ae55142ef933
+            style <- glue::glue(
+              "color: {color}; border: 1px solid black; background:
              linear-gradient(90deg, rgba(173, 216, 230, 1) {n_pct}%, rgba(0, 0, 0, 0) {n_pct}%),
              linear-gradient(90deg, rgba(211, 211, 211, 1) {N_pct}%, rgba(0, 0, 0, 0) {N_pct}%);"
-          )
-
-          shinyWidgets::updatePickerInput(
-            session = session,
-            inputId = var,
-            choices = choices,
-            selected = input[[var]],
-            choicesOpt = list(
-              subtext = glue::glue("{n} / {N}"),
-              style = style
             )
-          )
-        }
-      })
-    }, ignoreInit = TRUE)
+
+            shinyWidgets::updatePickerInput(
+              session = session,
+              inputId = var,
+              choices = choices,
+              selected = input[[var]],
+              choicesOpt = list(
+                subtext = glue::glue("{n} / {N}"),
+                style = style
+              )
+            )
+          }
+        })
+      },
+      ignoreInit = TRUE
+    )
     # Do not update the filter unless there has been any change in the returned vector
     # The returned attribute maybe inconsistent, as filterings that return exactly the same
-    # logical vector may not update the expression attribute. 
+    # logical vector may not update the expression attribute.
     # This should not be much of a problem as no is using that expression.
     # A solution to the above is that the code is returned as part of a list of two reactives,
     # list (value, code). This way altering the code does not necessarily update the depending

R/utils.R

@@ -38,8 +38,7 @@ get_input_type <- function(x) {
 get_icon_label <- function(data) {
   out <- purrr::map(names(data), function(var) {
     x <- data[[var]]
-    name <- switch(
-      get_first_class(x),
+    name <- switch(get_first_class(x),
       numeric = "sort-numeric-up",
       integer = "sort-numeric-up",
       Date = "calendar",
@@ -54,8 +53,10 @@ get_icon_label <- function(data) {
     icon <- toString(shiny::icon(name))
     label <- attr(x, "label")
     n_miss <- sum(is.na(x))
-    text_code <- paste0("<code style='color:darkblue;'>",
-                        get_first_class(x), "</code>")
+    text_code <- paste0(
+      "<code style='color:darkblue;'>",
+      get_first_class(x), "</code>"
+    )
     text_miss <- ifelse(n_miss == 0, "", paste0("<small style='color:darkred;'>(", n_miss, " missing)</small>"))
     text_label <- ifelse(is.null(label), "", paste0("<br><small><em>", label, "</em></small>"))
     paste0(icon, " ", var, " ", text_code, text_miss, text_label)

tests/testthat/shiny/adam/app.R

@@ -15,14 +15,14 @@ ui <- shiny::fluidPage(
 # App server function
 server <- function(input, output, session) {
   selected <- dv.filter::data_filter_server(
-    id = "data_filter", 
+    id = "data_filter",
     data = shiny::reactive(adsl)
   )
-  
+
   output$table <- shiny::renderPrint({
     table(selected())
   })
-  
+
   shiny::exportTestValues(
     selected = selected()
   )

tests/testthat/test-categorical-filter-missing.R

@@ -1,4 +1,4 @@
-test_that("For a chosen categorical filter with missing values, an item signifying missingness is incorporated at the top of the filter dropdown menu. By default, all missing values are included.", {
+test_that("For a chosen categorical filter with missing values, an item signifying missingness is incorporated at the top of the filter dropdown menu. By default, all missing values are included.", { # nolint
   adsl <- pharmaverseadam::adsl
   expect_true(sum(is.na(adsl$EOSSTT)) > 0)
 

tests/testthat/test-categorical-filter.R

@@ -1,8 +1,8 @@
-test_that("For a chosen categorical fitler, the data filter module provides users with the capability to deselect all categories.", {
+test_that("For a chosen categorical fitler, the data filter module provides users with the capability to deselect all categories.", { # nolint
   app <- shinytest2::AppDriver$new(app_dir = "shiny/adam/")
-  
+
   app$set_inputs(`data_filter-vars` = "SEX")
-  app$wait_for_idle(1000)  
+  app$wait_for_idle(1000)
   expect_true(all(app$get_value(export = "selected") == TRUE))
 
   app$set_inputs(`data_filter-SEX` = character(0))

tests/testthat/test-filter-ui-server.R

@@ -7,7 +7,7 @@ get_id <- function(html, name) {
 adsl <- pharmaverseadam::adsl
 
 test_that(
-  "The UI of the data filter module includes selection and input controls, allowing users to establish and modify filtering criteria.",
+  "The UI of the data filter module includes selection and input controls, allowing users to establish and modify filtering criteria.", # nolint
   {
     id <- "data_filter"
     ns <- shiny::NS(id)
@@ -21,7 +21,7 @@ test_that(
 )
 
 test_that(
-  "The server component of the data filter module generates a logical vector, signifying if a row of data should be selected (TRUE) or disregarded (FALSE).",
+  "The server component of the data filter module generates a logical vector, signifying if a row of data should be selected (TRUE) or disregarded (FALSE).", # nolint
   {
     data <- shiny::reactive(adsl)
     shiny::testServer(

tests/testthat/test-filtered-rows.R

@@ -1,21 +1,21 @@
-test_that("The data filter module presents a text output, signifying the number of entries selected in the filtered data.", {
+test_that("The data filter module presents a text output, signifying the number of entries selected in the filtered data.", { # nolint
   adsl <- pharmaverseadam::adsl
-  N <- nrow(adsl)
+  n <- nrow(adsl)
 
   app <- shinytest2::AppDriver$new(app_dir = "shiny/adam/")
   app$wait_for_idle(1000)
   expect_equal(
     app$get_value(output = "data_filter-text"),
-    paste(N, "of", N, "total entries selected")
+    paste(n, "of", n, "total entries selected")
   )
-  
+
   app$set_inputs(`data_filter-vars` = "SEX")
   app$set_inputs(`data_filter-SEX` = "M")
   app$wait_for_idle(1000)
   expect_equal(
     app$get_value(output = "data_filter-text"),
-    paste(sum(adsl$SEX == "M"), "of", N, "total entries selected")
+    paste(sum(adsl$SEX == "M"), "of", n, "total entries selected")
   )
-    
+
   app$stop()
 })

tests/testthat/test-numeric-filter-missing.R

@@ -1,16 +1,16 @@
-test_that("For a chosen numeric filter with missing values, the data filter module includes a checkbox enabling users to either incorporate or omit missing values. By default, all missing values are included.", {
+test_that("For a chosen numeric filter with missing values, the data filter module includes a checkbox enabling users to either incorporate or omit missing values. By default, all missing values are included.", { # nolint
   adsl <- pharmaverseadam::adsl
   expect_true(sum(is.na(adsl$EOSDT)) > 0)
-  
+
   app <- shinytest2::AppDriver$new(app_dir = "shiny/adam/")
-  
+
   app$set_inputs(`data_filter-vars` = "EOSDT")
   app$wait_for_idle(1000)
   expect_true(all(app$get_value(export = "selected") == TRUE))
- 
+
   app$set_inputs(`data_filter-EOSDT_na` = FALSE)
   app$wait_for_idle(1000)
   expect_true(all(app$get_value(export = "selected") == !is.na(adsl$EOSDT)))
-  
+
   app$stop()
 })

tests/testthat/test-numeric-filter.R

@@ -1,11 +1,11 @@
-test_that("For a chosen numeric filter, the data filter module provides a range slider and displays a histogram of the numeric variable.", {
+test_that("For a chosen numeric filter, the data filter module provides a range slider and displays a histogram of the numeric variable.", { # nolint
   adsl <- pharmaverseadam::adsl
   app <- shinytest2::AppDriver$new(app_dir = "shiny/adam/")
-  
+
   app$set_inputs(`data_filter-vars` = "AGE")
-  app$wait_for_idle(1000)  
+  app$wait_for_idle(1000)
   expect_equal(app$get_value(input = "data_filter-AGE"), range(adsl$AGE))
   expect_false(is.null(app$get_value(output = "data_filter-AGE_plot")))
-  
+
   app$stop()
 })

tests/testthat/test-remove-all-filters.R

@@ -1,14 +1,14 @@
 test_that("The data filter module allow users to remove all chosen filters simultaneously.", {
   app <- shinytest2::AppDriver$new(app_dir = "shiny/adam/")
-  
+
   app$set_inputs(`data_filter-vars` = "AGE")
   app$set_inputs(`data_filter-vars` = c("AGE", "SEX"))
   app$wait_for_idle(1000)
   expect_equal(app$get_value(input = "data_filter-vars"), c("AGE", "SEX"))
-    
+
   app$click("data_filter-clear_filters")
   app$wait_for_idle(1000)
   expect_null(app$get_value(input = "data_filter-vars"))
-  
+
   app$stop()
 })

vignettes/dv.filter.Rmd

@@ -33,7 +33,7 @@ ui <- shiny::fluidPage(
 
 server <- function(input, output, session) {
   selected <- dv.filter::data_filter_server("data_filter", data = data)
-  
+
   output$data_table <- shiny::renderDataTable({
     data()[selected(), ]
   })