Merge pull request #46 from Boehringer-Ingelheim/dev

Release 2.1.5

.github/workflows/ci.yml

@@ -10,6 +10,7 @@ on:
       - ready_for_review
     branches:
       - main
+      - dev
   push:
     branches:
       - main

DESCRIPTION

@@ -1,10 +1,10 @@
 Package: dv.manager
 Type: Package
 Title: DaVinci Module Manager
-Version: 2.1.4
+Version: 2.1.5
 Authors@R: c(person("Boehringer-Ingelheim Pharma GmbH & Co.KG", role = c("cph", "fnd")),
-    person('Sorin', 'Voicu', email = 'sorin.voicu.ext@boehringer-ingelheim.com', role = c('aut')),
-             person('Luis', 'Morís Fernández', email = 'luis.moris.fernandez@gmail.com', role = c('cre', 'aut')))
+    person('Luis', 'Morís Fernández', email = 'luis.moris.fernandez@gmail.com', role = c('cre', 'aut')),
+    person('Sorin', 'Voicu', email = 'sorin.voicu.ext@boehringer-ingelheim.com', role = c('aut')))
 Description: DaVinci Module Manager.
 License: Apache License (>= 2)
 Imports: 

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,3 +1,11 @@
+# dv.manager 2.1.5
+
+- dv.manager dataset filters are now deactivated by default and can be activated by setting `enable_dataset_filter` parameter in `run_app`.
+- dv.manager filter hide/shows filters depending on the selected module.
+- Empty datasets can be included in the application again.
+- Fixed a bug that removed labels from column datasets when data was filtered.
+- Module names can no longer be an empty string `''`.
+
 # dv.manager 2.1.4
 
 - Removes leftover title automatic capitalization.

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)
@@ -85,13 +86,15 @@ app_server_ <- function(input, output, session, opts) {
   )
 
   module_server <- opts[["module_info"]][["server_list"]]
+  module_meta <- opts[["module_info"]][["meta_list"]]
   module_names <- opts[["module_info"]][["module_name_list"]]
   module_hierarchy_list <- opts[["module_info"]][["hierarchy_list"]]
   data <- opts[["data"]]
   filter_data <- opts[["filter_data"]]
   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)
 
@@ -131,62 +134,120 @@ app_server_ <- function(input, output, session, opts) {
     shiny::reactive(unfiltered_dataset()[[filter_data]])
   )
 
-  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)) {
-      l[[idx]] <- local({
-        curr_dataset_filter_info <- datasets_filters_info[[idx]]
-        dv.filter::data_filter_server(
-          curr_dataset_filter_info[["id"]],
-          shiny::reactive({
-            unfiltered_dataset()[[curr_dataset_filter_info[["name"]]]] %||% data.frame()
-          })
-        )
-      })
-    }
 
-    l
-  })
+  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)) {
+        l[[idx]] <- local({
+          curr_dataset_filter_info <- datasets_filters_info[[idx]]
+          dv.filter::data_filter_server(
+            curr_dataset_filter_info[["id"]],
+            shiny::reactive({
+              unfiltered_dataset()[[curr_dataset_filter_info[["name"]]]] %||% data.frame()
+            })
+          )
+        })
+      }
 
-  filtered_dataset <- shinymeta::metaReactive({
-    # dv.filter returns a logical vector. This contemplates the case of empty lists
-    shiny::req(is.logical(global_filtered_values()))
+      l
+    })
 
-    # Depend on all datasets
-    purrr::walk(dataset_filters, ~ .x())
+    filtered_dataset <- shinymeta::metaReactive({
+      # dv.filter returns a logical vector. This contemplates the case of empty lists
+      shiny::req(is.logical(global_filtered_values()))
 
-    # We do not react to changed in unfiltered dataset, otherwise when a dataset changes
-    # We filter the previous dataset which in the best case produces and extra reactive beat
-    # and in the worst case produces an error in (mvbc)
-    # We don't want to control the error in (mvbc) because filtered dataset only changes when filter changes
-    ufds <- shiny::isolate(unfiltered_dataset())
+      # Depend on all datasets
+      purrr::walk(dataset_filters, ~ .x())
 
-    curr_dataset_filters <- dataset_filters[intersect(names(dataset_filters), names(ufds))]
+      # We do not react to changed in unfiltered dataset, otherwise when a dataset changes
+      # We filter the previous dataset which in the best case produces and extra reactive beat
+      # and in the worst case produces an error in (mvbc)
+      # We don't want to control the error in (mvbc) because filtered dataset only changes when filter changes
+      ufds <- shiny::isolate(unfiltered_dataset())
 
-    # 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)))
+      curr_dataset_filters <- dataset_filters[intersect(names(dataset_filters), names(ufds))]
 
-    filtered_key_values <- ufds[[filter_data]][[filter_key]][global_filtered_values()]
+      # 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 = 0)))
 
-    fds <- ufds
+      filtered_key_values <- ufds[[filter_data]][[filter_key]][global_filtered_values()]
 
-    # Single dataset filtering
-    fds[names(curr_dataset_filters)] <- purrr::imap(
-      fds[names(curr_dataset_filters)],
-      function(val, nm) {
-        # (mvbc)
-        fds[[nm]][dataset_filters[[nm]](), , drop = FALSE]
-      }
-    )
+      fds <- ufds
 
-    # Global dataset filtering
-    global_filtered <- purrr::map(
-      fds,
-      ~ dplyr::filter(.x, .data[[filter_key]] %in% filtered_key_values) # nolint
+      # Single dataset filtering
+      fds[names(curr_dataset_filters)] <- purrr::imap(
+        fds[names(curr_dataset_filters)],
+        function(val, nm) {
+          # (mvbc)
+          labels <- get_lbls(fds[[nm]])
+          current_fds <- fds[[nm]][dataset_filters[[nm]](), , drop = FALSE]
+          set_lbls(current_fds, labels)
+        }
+      )
+
+      # Global dataset filtering
+      global_filtered <- purrr::map(
+        fds, function(current_ds) {
+          mask <- current_ds[[filter_key]] %in% filtered_key_values
+          labels <- get_lbls(current_ds)
+          current_ds <- current_ds[mask, , drop = FALSE]
+          set_lbls(current_ds, labels)
+        }
+      )
+    })
+
+    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()
@@ -257,11 +318,20 @@ app_server_ <- function(input, output, session, opts) {
     )
   )
 
+  used_datasets <- list()
+
   module_output <- list()
   for (srv in module_server) {
-    module_output[[srv[["module_id"]]]] <- srv[["server"]](module_args)
+    mod_id <- srv[["module_id"]]
+    srv_fun <- srv[["server"]]
+
+    module_output[[mod_id]] <- srv_fun(module_args)
+    used_datasets[[mod_id]] <- module_meta[[mod_id]][["meta"]][["dataset_info"]][["all"]]
   }
 
+
+
+
   #### Report modal
 
   # REPORT IS DEACTIVATED

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. The default value is FALSE.
 #' @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/tab_group.R

@@ -112,6 +112,7 @@ resolve_tab_group <- function(x, nm, hierarchy, tab_group_count, nested_hierarch
     list(
       ui_list = r[["ui_list"]],
       server_list = r[["server_list"]],
+      meta_list = r[["meta_list"]],
       module_id_list = r[["module_id_list"]],
       module_name_list = r[["module_name_list"]],
       tab_label_list = r[["tab_label_list"]],
@@ -132,12 +133,17 @@ resolve_plain <- function(x, nm, hierarchy, nested_hierarchy) {
   )
 
   server_list <- list()
-
   server_list[[x[["module_id"]]]] <- list(
     server = x[["server"]],
     module_id = x[["module_id"]]
   )
 
+  meta_list <- list()
+  meta_list[[x[["module_id"]]]] <- list(
+    meta = x[["meta"]],
+    module_id = x[["module_id"]]
+  )
+
   module_id_list <- character(0)
   module_id_list[[nm]] <- x[["module_id"]]
 
@@ -155,6 +161,7 @@ resolve_plain <- function(x, nm, hierarchy, nested_hierarchy) {
   r <- list(
     ui_list = ui_list,
     server_list = server_list,
+    meta_list = meta_list,
     module_id_list = module_id_list,
     module_name_list = module_name_list,
     hierarchy_list = hierarchy_list,
@@ -173,6 +180,7 @@ resolve_module_list <- function(
     )) {
   server_list <- list()
   ui_list <- list()
+  meta_list <- list()
   module_id_list <- character(0)
   module_name_list <- character(0)
   tab_group_names <- character(0)
@@ -193,6 +201,7 @@ resolve_module_list <- function(
     ui_list <- c(ui_list, r[["ui_list"]])
     module_id_list <- c(module_id_list, r[["module_id_list"]])
     server_list <- c(server_list, r[["server_list"]])
+    meta_list <- c(meta_list, r[["meta_list"]])
     module_name_list <- c(module_name_list, r[["module_name_list"]])
     hierarchy_list <- c(hierarchy_list, r[["hierarchy_list"]])
     tab_group_names <- c(tab_group_names, r[["tab_group_names"]])
@@ -202,6 +211,7 @@ resolve_module_list <- function(
   res <- list(
     ui_list = ui_list,
     server_list = server_list,
+    meta_list = meta_list,
     module_id_list = module_id_list,
     module_name_list = module_name_list,
     hierarchy_list = hierarchy_list,