Merge pull request #14 from Boehringer-Ingelheim/6-include-several-fi…

…lters-in-dvmanager

6 include several filters in dvmanager

DESCRIPTION

@@ -16,7 +16,7 @@ Imports:
     bslib (>= 0.3.0),
     purrr (>= 0.3.4),
     dplyr (>= 1.0.3),
-    dv.filter (>= 1.0.0),
+    dv.filter (>= 3.0.1),
     lubridate (>= 1.7.9.2),
     shinymeta (>= 0.2.0.1),
     shinyjs (>= 2.0.0),

R/app_server.R

@@ -90,6 +90,8 @@ app_server_ <- function(input, output, session, opts) {
   startup_msg <- opts[["startup_msg"]]
   reload_period <- opts[["reload_period"]]
 
+  datasets_filters_info <- get_dataset_filters_info(data, filter_data)
+
   # Check if dataset must be reloaded in the next session
   check_data_reload(reload_period)
 
@@ -121,18 +123,64 @@ app_server_ <- function(input, output, session, opts) {
     }
   })
 
-  filtered_values <- dv.filter::data_filter_server(
+  global_filtered_values <- dv.filter::data_filter_server(
     "global_filter",
     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
+  })
+
   filtered_dataset <- shinymeta::metaReactive({
     # dv.filter returns a logical vector. This contemplates the case of empty lists
-    shiny::req(is.logical(filtered_values()))
-    log_inform("New filter applied")
-    filtered_key_values <- unfiltered_dataset()[[filter_data]][[filter_key]][filtered_values()] # nolint
-    purrr::map(
-      unfiltered_dataset(),
+    shiny::req(is.logical(global_filtered_values()))
+
+    # Depend on all datasets
+    purrr::walk(dataset_filters, ~ .x())
+
+    # 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())
+
+    curr_dataset_filters <- dataset_filters[intersect(names(dataset_filters), names(ufds))]
+
+    # 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)))
+
+    filtered_key_values <- ufds[[filter_data]][[filter_key]][global_filtered_values()]
+
+    fds <- ufds
+
+    # 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]
+      }
+    )
+
+    # Global dataset filtering
+    global_filtered <- purrr::map(
+      fds,
       ~ dplyr::filter(.x, .data[[filter_key]] %in% filtered_key_values) # nolint
     )
   })

R/app_ui.R

@@ -22,6 +22,7 @@ app_ui <- function(id) {
 
   data <- get_config("data")
   module_list <- get_config("module_list")
+  filter_data <- get_config("filter_data")
 
   log_inform("Initializing HTML template UI")
   log_inform(glue::glue(
@@ -30,6 +31,23 @@ app_ui <- function(id) {
   log_inform(glue::glue("Available modules (N): {length(module_list)}"))
   log_inform(glue::glue("Dataset options (N): {length(data)}"))
 
+
+  dataset_filters_ui <- local({
+    datasets_filters_info <- get_dataset_filters_info(data, filter_data)
+    purrr::map(
+      datasets_filters_info,
+      function(entry) {
+        shiny::div(
+          id = entry[["id_cont"]],
+          class = "filter-control  filter-filters",
+          shiny::tags[["label"]](entry[["name"]]),
+          dv.filter::data_filter_ui(ns(entry[["id"]])),
+          shiny::hr(style = "border-top: 2px solid gray; height: 10px;")
+        )
+      }
+    )
+  })
+
   collapsable_ui <-
     shiny::div(
       class = "menu-contents",
@@ -44,10 +62,25 @@ app_ui <- function(id) {
           shiny::selectInput(ns("selector"), label = NULL, choices = names(data))
         )),
         shiny::div(
-          id = ns("shiny_filter"),
-          class = "c-well",
-          shiny::tags$label("Filters", class = "text-primary"),
-          dv.filter::data_filter_ui(ns("global_filter"))
+          class = "c-well shiny_filter",
+          shiny::tags$label("Global Filter", class = "text-primary"),
+          # shiny::tags$button(
+          #   id = ns("global_button"),
+          #   class = "btn btn-primary filter_button",
+          #   shiny::span("Global Filter"),
+          #   # shiny::span("TAG", class = "dv_hidden badge"),
+          #   # shiny::span(class = "caret"),
+          #   # onclick = sprintf("dv_manager.hide_filters('%s')", ns("global_button"))
+          # ),
+          shiny::div(
+            class = "filter-control  filter-filters",
+            dv.filter::data_filter_ui(ns("global_filter"))
+          )
+        ),
+        shiny::div(
+          class = "c-well shiny_filter",
+          shiny::tags$label("Dataset Filter", class = "text-primary"),
+          dataset_filters_ui
         )
       )
     )

R/pharmaverse_data.R

@@ -1,10 +1,33 @@
 get_pharmaverse_data <- function(dataset) {
   if (!rlang::is_installed("pharmaverseadam")) stop("Please, install.package('pharmaverseadam')")
+
+  chr2fct <- function(x) {
+    x[] <- purrr::map(x, ~ if (is.character(.x)) factor(.x) else .x)
+    x
+  }
+
+  cd2fct <- function(x) {
+    x[] <- purrr::imap(x, ~ if (endsWith(.y, "CD")) factor(.x) else .x)
+    x
+  }
+
   if (dataset == "adsl") {
-    return(pharmaverseadam::adsl)
+    res <- pharmaverseadam::adsl |>
+      chr2fct() |>
+      cd2fct()
+    return(res)
   }
   if (dataset == "adae") {
-    return(pharmaverseadam::adae)
+    res <- pharmaverseadam::adae |>
+      chr2fct() |>
+      cd2fct()
+    return(res)
+  }
+  if (dataset == "adlb") {
+    res <- pharmaverseadam::adlb |>
+      chr2fct() |>
+      cd2fct()
+    return(res)
   }
   stop("Unknown dataset")
 }

R/testing_module.R

@@ -125,7 +125,7 @@ mod_simple <- function(dataset, module_id) {
 
 run_mock_app <- function() {
   run_app(
-    data = list("D1" = list(adsl = get_pharmaverse_data("adsl"))),
+    data = list("D1" = list(adsl = get_pharmaverse_data("adsl"), adae = get_pharmaverse_data("adae"))),
     module_list = list(
       "Simple" = mod_simple(mm_dispatch("filtered_dataset", "adsl"), "mod1"),
       "Simple2" = mod_simple(mm_dispatch("unfiltered_dataset", "adsl"), "mod2")
@@ -135,6 +135,29 @@ run_mock_app <- function() {
   )
 }
 
+run_mock_app_two_datasets <- function() {
+  run_app(
+    data = list(
+      "D1" = list(
+        adsl = get_pharmaverse_data("adsl"),
+        adae = get_pharmaverse_data("adae")
+      ),
+      "D2" = list(
+        adsl = get_pharmaverse_data("adsl"),
+        adae = get_pharmaverse_data("adae"),
+        adlb = get_pharmaverse_data("adlb")
+      )
+    ),
+    module_list = list(
+      "Simple" = mod_simple(mm_dispatch("filtered_dataset", "adsl"), "mod1"),
+      "Simple2" = mod_simple(mm_dispatch("unfiltered_dataset", "adsl"), "mod2"),
+      "Simple3" = mod_simple(mm_dispatch("filtered_dataset", "adae"), "mod3")
+    ),
+    filter_data = "adsl",
+    filter_key = "USUBJID"
+  )
+}
+
 ########## URL READING
 
 url_reader_UI <- function(id) { # nolint

R/utils_helpers.R

@@ -51,3 +51,31 @@ create_options_modal <- function(session, input, ns) {
     easyClose = TRUE
   )
 }
+
+#' Get the set of all possible data table names for filtering
+get_data_tables_names <- function(data) {
+  nm <- character(0)
+  for (idx in seq_along(data)) {
+    curr_data <- if (is.function(data[[idx]])) data[[idx]]() else data[[idx]]
+    nm <- union(nm, names(curr_data))
+  }
+  return(nm)
+}
+
+get_dataset_filters_info <- function(data, filter_data) {
+  dataset_filter_names <- setdiff(get_data_tables_names(data), filter_data)
+  purrr::map(
+    dataset_filter_names,
+    function(nm) {
+      name <- nm
+      hash <- digest::digest(nm, "murmur32")
+      id <- sprintf("dataset_filter_%s", hash)
+      cont_id <- paste0(id, "_cont")
+      list(name = nm, id = id, hash = hash, id_cont = cont_id)
+    }
+  ) |> purrr::set_names(dataset_filter_names)
+}
+
+`%||%` <- function(x, y) {
+  if (!is.null(x)) x else y
+}

inst/app/www/css/custom.scss

@@ -218,7 +218,7 @@ input[type="checkbox"]#click {
   flex-direction: column;
   justify-content: flex-start;
 
-  #shiny_filter {
+  .shiny_filter {
     flex: 1 0 auto;
     display: flex;
     flex-direction: column;

inst/validation/specs.R

@@ -18,8 +18,10 @@ fs_spec <- specs_list(
   "modification_dates_display" = "The earliest and latest modification dates of all the data tables are displayed for the active dataset",
   "date_unavailability_message" = "If no date is available for any of the data tables in the loaded dataset the system displays a 'Date unavailable' message",
   "data_reloading" = "dv.manager allows the reloading of the data after a specific amount of time.",
-  "filtering_menu_display" = "The sidebar menu will display a filtering menu using the datafilter module (GUI).",
-  "active_dataset_filtering" = "The active dataset can be filtered through the datafilter module.",
+  "filtering_menu_display" = "The sidebar menu will display a filtering menu/s using the datafilter module (GUI).",
+  "active_dataset_filtering" = "The active dataset can be filtered.",
+  "global_filtering" = "A global filter will be available in dv.manager. One table of the dataset will be used to filter all other tables in the dataset and itself by using a common field among them.",
+  "single_filtering" = "All data tables, with exception of the one used in the global filter, will have its own independent filter that only affects itself. These filters will not influence other datasets.",  
   "bookmarking_features" = "Bookmarking will include:
 - the identity of the loaded dataset
 - the set of filters applied to the loaded dataset
@@ -75,7 +77,7 @@ or a positive numeric value which is then interpreted as a lubridate duration ob
 - ids of the modules in module_list are not repeated. Otherwise it throws an informative error.",
   "startup_message_check" = "- startup_message is null or a shiny::modalDialog. Otherwise it throws an informative error.",
   "azure_options_check" = "-azure_options: must be a list with all the required fields or NULL. Otherwise an error is thrown.",
-  "filtering_menu" = "- A filtering menu that is an instance of datafilter",
+  "filtering_menus" = "- A filtering menu that is an/several instances of datafilter",
   "dataset_selector" = "- A dataset selector that:
     - contains one entry per entry in the data parameters list
     - when changed will load the selected dataset in the application

inst/www/css/custom.scss

@@ -213,18 +213,25 @@ input[type="checkbox"]#click {
   opacity: 1;
 }
 
-#shiny_filter_panel {
+#shiny_filter_panel {  
   height: 94vh;
-  display: flex;
-  flex-direction: column;
-  justify-content: flex-start;
-
-  #shiny_filter {
-    flex: 1 0 auto;
-    display: flex;
-    flex-direction: column;
-    justify-content: flex-start;
+  overflow-y: auto;  
+  overflow-x: hidden;
+
+  .shiny_filter{
+    .dropdown-menu.open{
+      min-width: min-content;
+      position: fixed;
+      left: $sidebar-width-open;
+      top: 25vh;
+      max-height: 75vh !important;
+      .inner.open{
+        max-height: 75vh !important;        
+      }
+    }
+
   }
+
   .c-well {
     min-height: 20px;
     padding: 15px;
@@ -234,45 +241,7 @@ input[type="checkbox"]#click {
 
   #dataset_selector {
     flex: 0 0 auto;
-  }
-}
-
-#global_filter-filters {
-  margin-top: 1rem;
-  .dropdown-menu {
-    left: $sidebar-width-open;
-  }
-}
-
-#global_filter-controls {
-  overflow-y: auto;
-  overflow-x: hidden;
-  scrollbar-width: thin;
-  margin-right: -15px;
-  flex: 1 10 1vh;
-  min-height: 7.5rem;
-  padding: 25px 15px 15px !important;
-  margin-right: -15px !important;
-  margin-left: -15px !important;
-
-  .dropdown-menu {
-    position: fixed;
-    top: 25vh;
-    left: $sidebar-width-open;
-    min-width: min-content;
-
-    &.open {
-      left: 320px;
-      min-height: max-content;
-      height: max-content;
-    }
-
-    &.inner {
-      position: inherit;
-      min-height: max-content;
-      overflow-x: hidden;
-      overflow-y: auto;
-    }
+    max-height: 200px;
   }
 }
 

inst/www/js/init.js

@@ -13,3 +13,23 @@ $(document).ready(function () {
     }
   });
 });
+
+// const dv_manager = {
+//   hide_filters: function(button_id) {
+//     var button = document.getElementById(button_id);
+//     var tag = button.querySelectorAll("span")[1];
+//     var container = button.nextElementSibling;
+//     var hidden = container.classList.toggle("dv_hidden");
+//     var controls_container = container.querySelectorAll(":scope > div")[2];
+//     var active_filters = controls_container.querySelectorAll(":scope > div").length;
+
+//     tag.textContent=active_filters;
+
+//     if (hidden) {
+//       tag.classList.remove("dv_hidden");      
+//     } else {
+//       tag.classList.add("dv_hidden");
+//     }
+//   }
+// };
+