Merge pull request #43 from Boehringer-Ingelheim/42-make-dataset-filt…

…ers-and-optional-feature

42 make dataset filters and optional feature

NAMESPACE

@@ -20,6 +20,7 @@ export(log_use_log)
 export(mm_dispatch)
 export(mm_resolve_dispatcher)
 export(mod_simple)
+export(mod_simple2)
 export(run_app)
 export(simple_UI)
 export(simple_server)

NEWS.md

@@ -1,6 +1,7 @@
 # dv.manager 2.1.4.9000
 
 - dv.manager filter hide/shows filters depending on the selected module
+- dv.manager dataset filters are now deactivated by default and can be activated by setting `enable_dataset_filter` parameter in `run_app`.
 
 # dv.manager 2.1.4
 

R/aaaa_info_strings.R

@@ -5,7 +5,7 @@ TT <- local({
     "Apply a filter to the dataset and use the resulting subject IDs (default) to consistently filter the rest of datasets."
 
   DATASET_FILTER <-
-    "Apply a filter to an specific dataset. Does not impact the rest of datasets."
+    "Apply a filter to a specific dataset. Does not impact the rest of datasets. Only datasets that are used by the currently selected module are shown in this dataset."
 
   poc(
     SUBJECT_LEVEL_FILTER = SUBJECT_LEVEL_FILTER,

R/app_server.R

@@ -51,7 +51,8 @@ app_server <- function(input = NULL, output = NULL, session = NULL) {
     "filter_data" = get_config("filter_data"),
     "filter_key" = get_config("filter_key"),
     "startup_msg" = get_config("startup_msg"),
-    "reload_period" = get_config("reload_period")
+    "reload_period" = get_config("reload_period"),
+    "enable_dataset_filter" = get_config("enable_dataset_filter")
   )
 
   app_server_(input, output, session, opts)
@@ -93,6 +94,7 @@ app_server_ <- function(input, output, session, opts) {
   filter_key <- opts[["filter_key"]]
   startup_msg <- opts[["startup_msg"]]
   reload_period <- opts[["reload_period"]]
+  enable_dataset_filter <- opts[["enable_dataset_filter"]]
 
   datasets_filters_info <- get_dataset_filters_info(data, filter_data)
 
@@ -132,7 +134,12 @@ app_server_ <- function(input, output, session, opts) {
     shiny::reactive(unfiltered_dataset()[[filter_data]])
   )
 
-  dataset_filters <- local({
+
+  if(enable_dataset_filter) {
+
+    log_inform("Dataset filter server")
+
+    dataset_filters <- local({
     l <- vector(mode = "list", length = length(datasets_filters_info))
     names(l) <- names(datasets_filters_info)
     for (idx in seq_along(datasets_filters_info)) {
@@ -150,7 +157,7 @@ app_server_ <- function(input, output, session, opts) {
     l
   })
 
-  filtered_dataset <- shinymeta::metaReactive({
+    filtered_dataset <- shinymeta::metaReactive({
     # dv.filter returns a logical vector. This contemplates the case of empty lists
     shiny::req(is.logical(global_filtered_values()))
 
@@ -167,7 +174,7 @@ app_server_ <- function(input, output, session, opts) {
 
     # Current dataset must be logical with length above 0
     # Check dataset filters check all datafilters are initialized
-    purrr::walk(curr_dataset_filters, ~ shiny::req(checkmate::test_logical(.x(), min.len = 1)))
+    purrr::walk(curr_dataset_filters, ~ shiny::req(checkmate::test_logical(.x(), min.len = 0)))
 
     filtered_key_values <- ufds[[filter_data]][[filter_key]][global_filtered_values()]
 
@@ -189,6 +196,57 @@ app_server_ <- function(input, output, session, opts) {
     )
   })
 
+    tab_ids <- c("__tabset_0__", names(opts[["module_info"]][["tab_group_names"]]))
+  shiny::observeEvent(
+    {
+      purrr::map(tab_ids, ~ input[[.x]])
+    },
+    {
+      current_tab <- "__tabset_0__"
+      zero_tabs <- length(input[["__tabset_0__"]]) == 0
+      if (!zero_tabs) {
+        while (!current_tab %in% opts[["module_info"]][["module_id_list"]]) {
+          current_tab <- input[[current_tab]]
+        }
+      }
+
+      used_ds <- used_datasets[[current_tab]]
+      all_nm <- names(datasets_filters_info)
+      if (!zero_tabs && !is.null(used_ds)) {
+        used_nm <- intersect(used_datasets[[current_tab]], names(datasets_filters_info))
+        unused_nm <- setdiff(all_nm, used_nm)
+      } else {
+        used_nm <- all_nm
+        unused_nm <- character(0)
+      }
+
+      for (nm in unused_nm) {
+        shinyjs::hide(datasets_filters_info[[nm]][["id_cont"]])
+      }
+
+      for (nm in used_nm) {
+        shinyjs::show(datasets_filters_info[[nm]][["id_cont"]])
+      }
+    }
+  )
+
+  } else {
+
+    log_inform("Single filter server")
+
+      filtered_dataset <- shinymeta::metaReactive({
+    # dv.filter returns a logical vector. This contemplates the case of empty lists
+    shiny::req(is.logical(global_filtered_values()))
+    log_inform("New filter applied")
+    filtered_key_values <- unfiltered_dataset()[[filter_data]][[filter_key]][global_filtered_values()] # nolint
+    purrr::map(
+      unfiltered_dataset(),
+      ~ dplyr::filter(.x, .data[[filter_key]] %in% filtered_key_values) # nolint
+    )
+  })
+
+  }
+
   # Prepare module_output argument
   module_output_env <- rlang::current_env()
   module_output_func <- function() {
@@ -270,39 +328,7 @@ app_server_ <- function(input, output, session, opts) {
   }
 
 
-  tab_ids <- c("__tabset_0__", names(opts[["module_info"]][["tab_group_names"]]))
-  shiny::observeEvent(
-    {
-      purrr::map(tab_ids, ~ input[[.x]])
-    },
-    {
-      current_tab <- "__tabset_0__"
-      zero_tabs <- length(input[["__tabset_0__"]]) == 0
-      if (!zero_tabs) {
-        while (!current_tab %in% opts[["module_info"]][["module_id_list"]]) {
-          current_tab <- input[[current_tab]]
-        }
-      }
 
-      used_ds <- used_datasets[[current_tab]]
-      all_nm <- names(datasets_filters_info)
-      if (!zero_tabs && !is.null(used_ds)) {
-        used_nm <- intersect(used_datasets[[current_tab]], names(datasets_filters_info))
-        unused_nm <- setdiff(all_nm, used_nm)
-      } else {
-        used_nm <- all_nm
-        unused_nm <- character(0)
-      }
-
-      for (nm in unused_nm) {
-        shinyjs::hide(datasets_filters_info[[nm]][["id_cont"]])
-      }
-
-      for (nm in used_nm) {
-        shinyjs::show(datasets_filters_info[[nm]][["id_cont"]])
-      }
-    }
-  )
 
   #### Report modal
 

R/app_ui.R

@@ -25,6 +25,7 @@ app_ui <- function(request_id) {
   data <- get_config("data")
   module_info <- get_config("module_info")
   filter_data <- get_config("filter_data")
+  enable_dataset_filter <- get_config("enable_dataset_filter")
 
   log_inform("Initializing HTML template UI")
   log_inform(glue::glue("Available modules (N): {length(module_info[[\"ui_list\"]])}"))
@@ -71,7 +72,8 @@ app_ui <- function(request_id) {
             dv.filter::data_filter_ui(ns("global_filter"))
           )
         ),
-        shiny::div(
+        if (enable_dataset_filter) {
+          shiny::div(
           class = "c-well shiny_filter",
           shiny::tags$label(
             "Dataset Filter(s)",
@@ -80,6 +82,7 @@ app_ui <- function(request_id) {
           ),
           dataset_filters_ui
         )
+        }        
       )
     )
 

R/checker.R

@@ -4,11 +4,21 @@ check_resolved_modules <- function(resolved_module_list) {
     log_warn(msg)
   }
 
+  if (!all(is.character(resolved_module_list[["module_id_list"]]))) {
+    msg <- "module_list has at least one module_id that is not of type character"
+    rlang::abort(msg)
+  }
+
   if (any(duplicated(resolved_module_list[["module_id_list"]]))) {
     msg <- "module_list has repeated module_ids"
     rlang::abort(msg)
   }
 
+  if (any(nchar(resolved_module_list[["module_id_list"]]) == 0)) {
+    msg <- "module ids must have at least one character"
+    rlang::abort(msg)
+  }
+
   if (any(duplicated(resolved_module_list[["module_name_list"]]))) {
     msg <- "module_list has repeated module_names"
     rlang::abort(msg)

R/run_app.R

@@ -26,6 +26,7 @@
 #' externally.
 #' @param reload_period Either a lubridate object to specify a duration
 #' or a positive numeric value which is then interpreted as a lubridate duration object in days. By default NULL
+#' @param enable_dataset_filter a boolean flag indicating if dataset filters are enabled
 #' @param .launch by default it should always be TRUE. It should only be false for debugging and testing.
 #' When TRUE it will return the app. When FALSE it will return the options with which the app will be launched.
 #' @inheritParams shiny::shinyApp
@@ -47,6 +48,7 @@ run_app <- function(data = NULL,
                     azure_options = NULL,
                     reload_period = NULL,
                     enableBookmarking = "server", # nolint
+                    enable_dataset_filter = FALSE,
                     .launch = TRUE) {
   check_deprecated_calls(filter_data)
 
@@ -68,6 +70,7 @@ run_app <- function(data = NULL,
   config[["startup_msg"]] <- check_startup_msg(startup_msg)
   config[["title"]] <- title
   config[["reload_period"]] <- get_reload_period(check_reload_period(reload_period))
+  config[["enable_dataset_filter"]] <- enable_dataset_filter
 
   check_meta_mtime_attribute(data)
 

R/testing_module.R

@@ -934,66 +934,21 @@ run_mock_app_css <- function() {
   )
 }
 
-########### Simple module
-
-#' @describeIn mod_simple
-#' Module UI
-#'
-#' @param id shiny id
-#'
-#' @export
-simple_UI <- function(id) { # nolint
-  ns <- shiny::NS(id)
-  shiny::tagList(
-    shiny::textOutput(ns("text")),
-    shiny::verbatimTextOutput(ns("code"))
-  )
-}
-
-#' @describeIn mod_simple
-#' Module server
-#'
-#' @param dataset input dataset
-#'
-#' @export
-simple_server <- function(id, dataset) {
-  shiny::moduleServer(
-    id,
-    function(input, output, session) {
-      output$text <- shinymeta::metaRender(
-        shiny::renderText,
-        {
-          log_inform(paste(nrow(dataset())))
-          nrow(shinymeta::..(dataset()))
-        }
-      )
-
-      # nolint start
-      # output$code <- shiny::renderPrint({
-      #   shinymeta::expandChain(output$text())
-      # })
-      # nolint end
-
-      return(structure(list(),
-        code = output$text
-      ))
-    }
-  )
-}
-
 #' A simple module that counts the number of rows
 #'
 #' This simple module is used for demonstration purposes in documentation
 #'
 #' It is similar to mod_simple but does not use dispatchers
 #'
 #' @param module_id shiny module ID
+#' 
+#' @keywords internal
 #'
 #' @export
 mod_simple2 <- function(dataset_name, module_id) {
   mod <- list(
     ui = simple_UI,
-    server = function(afmm) {
+    server = function(afmm) {      
       simple_server(module_id, shiny::reactive(afmm[["filtered_dataset"]]()[[dataset_name]]))
     },
     module_id = module_id,

inst/validation/specs.R

@@ -35,7 +35,8 @@ fs_spec <- specs_list(
   "module_name_access" = "Modules will have access to its name and the name of the other modules",
   "modification_dates_access" = "Modules will have access to the earliest and latest modification dates of all the data tables.",
   "module_tab_switching" = "dv.manager allows programatically switching from one module tab to another",  
-  "SSO_authentication_option" = "Modulemanager provides the option to enable the authentication of App Users with SSO to access the app."
+  "SSO_authentication_option" = "dv.manager provides the option to enable the authentication of App Users with SSO to access the app.",
+  "empty_datasets" = "dv.manager supports datasets with 0 rows"
 )
 
 sds_spec <- specs_list(