Accept functions

DESCRIPTION

@@ -52,6 +52,7 @@ Imports:
     teal.logger (>= 0.2.0),
     teal.reporter (>= 0.3.1.9004),
     teal.widgets (>= 0.4.0),
+    tools,
     utils
 Suggests:
     bslib,

R/module_data_summary.R

@@ -3,15 +3,17 @@
 #' Module and its utils to display the number of rows and subjects in the filtered and unfiltered data.
 #'
 #' @details Handling different data classes:
-#' `get_object_filter_overview()` is a pseudo S3 method which has variants for:
+#' `get_filter_overview()` is a pseudo S3 method which has variants for:
 #' - `array` (`data.frame`, `DataFrame`, `array`, `Matrix` and `SummarizedExperiment`): Method variant
 #' can be applied to any two-dimensional objects on which [ncol()] can be used.
 #' - `MultiAssayExperiment`: for which summary contains counts for `colData` and all `experiments`.
+#' - For other data types module displays data name with warning icon and no more details.
 #'
-#' @param id (`character(1)`)
-#'  `shiny` module instance id.
-#' @param teal_data (`reactive` returning `teal_data`)
+#' Module includes also "Show/Hide unsupported" button to toggle rows of the summary table
+#' containing datasets where number of observations are not calculated.
 #'
+#' @param id (`character(1)`) `shiny` module instance id.
+#' @param teal_data (`reactive` returning `teal_data`)
 #'
 #' @name module_data_summary
 #' @rdname module_data_summary
@@ -65,24 +67,7 @@ srv_data_summary <- function(id, teal_data) {
         if (!length(ls(teal.code::get_env(teal_data())))) {
           return(NULL)
         }
-
-        filter_overview <- get_filter_overview(teal_data)
-        names(filter_overview)[[1]] <- "Data Name"
-
-        filter_overview$Obs <- ifelse(
-          !is.na(filter_overview$obs),
-          sprintf("%s/%s", filter_overview$obs_filtered, filter_overview$obs),
-          ifelse(!is.na(filter_overview$obs_filtered), sprintf("%s", filter_overview$obs_filtered), "")
-        )
-
-        filter_overview$Subjects <- ifelse(
-          !is.na(filter_overview$subjects),
-          sprintf("%s/%s", filter_overview$subjects_filtered, filter_overview$subjects),
-          ""
-        )
-
-        filter_overview <- filter_overview[, colnames(filter_overview) %in% c("Data Name", "Obs", "Subjects")]
-        Filter(function(col) !all(col == ""), filter_overview)
+        get_filter_overview_wrapper(teal_data)
       })
 
       output$table <- renderUI({
@@ -95,60 +80,79 @@ srv_data_summary <- function(id, teal_data) {
         } else if (is.null(summary_table_out)) {
           "no datasets to show"
         } else {
+          is_unsupported <- apply(summary_table(), 1, function(x) all(is.na(x[-1])))
+          summary_table_out[is.na(summary_table_out)] <- ""
           body_html <- apply(
             summary_table_out,
             1,
             function(x) {
-              tags$tr(
-                tagList(
-                  tags$td(
-                    if (all(x[-1] == "")) {
-                      icon(
-                        name = "fas fa-exclamation-triangle",
-                        title = "Unsupported dataset",
-                        `data-container` = "body",
-                        `data-toggle` = "popover",
-                        `data-content` = "object not supported by the data_summary module"
-                      )
-                    },
-                    x[1]
-                  ),
-                  lapply(x[-1], tags$td)
+              is_supported <- !all(x[-1] == "")
+              if (is_supported) {
+                tags$tr(
+                  tagList(
+                    tags$td(x[1]),
+                    lapply(x[-1], tags$td)
+                  )
                 )
-              )
+              }
             }
           )
 
-          header_labels <- names(summary_table())
+          header_labels <- tools::toTitleCase(names(summary_table_out))
+          header_labels[header_labels == "Dataname"] <- "Data Name"
           header_html <- tags$tr(tagList(lapply(header_labels, tags$td)))
 
           table_html <- tags$table(
             class = "table custom-table",
             tags$thead(header_html),
             tags$tbody(body_html)
           )
-          table_html
+          div(
+            table_html,
+            if (any(is_unsupported)) {
+              p(
+                class = c("pull-right", "float-right", "text-secondary"),
+                style = "font-size: 0.8em;",
+                sprintf("And %s more unfilterable object(s)", sum(is_unsupported)),
+                icon(
+                  name = "far fa-circle-question",
+                  title = paste(
+                    sep = "",
+                    collapse = "\n",
+                    shQuote(summary_table()[is_unsupported, "dataname"]),
+                    " (",
+                    vapply(
+                      summary_table()[is_unsupported, "dataname"],
+                      function(x) class(teal_data()[[x]])[1],
+                      character(1L)
+                    ),
+                    ")"
+                  )
+                )
+              )
+            }
+          )
         }
       })
 
-      summary_table # testing purpose
+      NULL
     }
   )
 }
 
 #' @rdname module_data_summary
-get_filter_overview <- function(teal_data) {
+get_filter_overview_wrapper <- function(teal_data) {
   datanames <- teal.data::datanames(teal_data())
   joinkeys <- teal.data::join_keys(teal_data())
 
-  filtered_data_objs <- sapply(
+  current_data_objs <- sapply(
     datanames,
     function(name) teal.code::get_var(teal_data(), name),
     simplify = FALSE
   )
-  unfiltered_data_objs <- teal.code::get_var(teal_data(), ".raw_data")
+  initial_data_objs <- teal.code::get_var(teal_data(), ".raw_data")
 
-  rows <- lapply(
+  out <- lapply(
     datanames,
     function(dataname) {
       parent <- teal.data::parent(joinkeys, dataname)
@@ -163,83 +167,86 @@ get_filter_overview <- function(teal_data) {
       } else {
         joinkeys[dataname, dataname]
       }
-      get_object_filter_overview(
-        filtered_data = filtered_data_objs[[dataname]],
-        unfiltered_data = unfiltered_data_objs[[dataname]],
+      get_filter_overview(
+        current_data = current_data_objs[[dataname]],
+        initial_data = initial_data_objs[[dataname]],
         dataname = dataname,
         subject_keys = subject_keys
       )
     }
   )
 
-  unssuported_idx <- vapply(rows, function(x) all(is.na(x[-1])), logical(1)) # this is mainly for vectors
-  do.call(rbind, c(rows[!unssuported_idx], rows[unssuported_idx]))
+  do.call(.smart_rbind, out)
 }
 
+
 #' @rdname module_data_summary
-#' @param filtered_data (`list`) of filtered objects
-#' @param unfiltered_data (`list`) of unfiltered objects
+#' @param current_data (`object`) current object (after filtering and transforming).
+#' @param initial_data (`object`) initial object.
 #' @param dataname (`character(1)`)
-get_object_filter_overview <- function(filtered_data, unfiltered_data, dataname, subject_keys) {
-  if (inherits(filtered_data, c("data.frame", "DataFrame", "array", "Matrix", "SummarizedExperiment"))) {
-    get_object_filter_overview_array(filtered_data, unfiltered_data, dataname, subject_keys)
-  } else if (inherits(filtered_data, "MultiAssayExperiment")) {
-    get_object_filter_overview_MultiAssayExperiment(filtered_data, unfiltered_data, dataname)
+#' @param subject_keys (`character`) names of the columns which determine a single unique subjects
+get_filter_overview <- function(current_data, initial_data, dataname, subject_keys) {
+  if (inherits(current_data, c("data.frame", "DataFrame", "array", "Matrix", "SummarizedExperiment"))) {
+    get_filter_overview_array(current_data, initial_data, dataname, subject_keys)
+  } else if (inherits(current_data, "MultiAssayExperiment")) {
+    get_filter_overview_MultiAssayExperiment(current_data, initial_data, dataname)
   } else {
-    data.frame(
-      dataname = dataname,
-      obs = NA,
-      obs_filtered = NA,
-      subjects = NA,
-      subjects_filtered = NA
-    )
+    data.frame(dataname = dataname)
   }
 }
 
 #' @rdname module_data_summary
-get_object_filter_overview_array <- function(filtered_data, # nolint: object_length.
-                                             unfiltered_data,
-                                             dataname,
-                                             subject_keys) {
+get_filter_overview_array <- function(current_data,
+                                      initial_data,
+                                      dataname,
+                                      subject_keys) {
   if (length(subject_keys) == 0) {
     data.frame(
       dataname = dataname,
-      obs = ifelse(!is.null(nrow(unfiltered_data)), nrow(unfiltered_data), NA),
-      obs_filtered = nrow(filtered_data),
-      subjects = NA,
-      subjects_filtered = NA
+      obs = if (!is.null(initial_data)) {
+        sprintf("%s/%s", nrow(current_data), nrow(initial_data))
+      } else {
+        nrow(current_data)
+      }
     )
   } else {
     data.frame(
       dataname = dataname,
-      obs = ifelse(!is.null(nrow(unfiltered_data)), nrow(unfiltered_data), NA),
-      obs_filtered = nrow(filtered_data),
-      subjects = nrow(unique(unfiltered_data[subject_keys])),
-      subjects_filtered = nrow(unique(filtered_data[subject_keys]))
+      obs = if (!is.null(initial_data)) {
+        sprintf("%s/%s", nrow(current_data), nrow(initial_data))
+      } else {
+        nrow(current_data)
+      },
+      subjects = if (!is.null(initial_data)) {
+        sprintf("%s/%s", nrow(unique(current_data[subject_keys])), nrow(unique(initial_data[subject_keys])))
+      } else {
+        nrow(unique(current_data[subject_keys]))
+      }
     )
   }
 }
 
 #' @rdname module_data_summary
-get_object_filter_overview_MultiAssayExperiment <- function(filtered_data, # nolint: object_length, object_name.
-                                                            unfiltered_data,
-                                                            dataname) {
-  experiment_names <- names(unfiltered_data)
+get_filter_overview_MultiAssayExperiment <- function(current_data, # nolint: object_length, object_name.
+                                                     initial_data,
+                                                     dataname) {
+  experiment_names <- names(current_data)
   mae_info <- data.frame(
     dataname = dataname,
-    obs = NA,
-    obs_filtered = NA,
-    subjects = nrow(unfiltered_data@colData),
-    subjects_filtered = nrow(filtered_data@colData)
+    subjects = if (!is.null(initial_data)) {
+      sprintf("%s/%s", nrow(current_data@colData), nrow(initial_data@colData))
+    } else {
+      nrow(current_data@colData)
+    }
   )
 
   experiment_obs_info <- do.call("rbind", lapply(
     experiment_names,
     function(experiment_name) {
       transform(
-        get_object_filter_overview(
-          filtered_data[[experiment_name]],
-          unfiltered_data[[experiment_name]],
+        get_filter_overview(
+          current_data[[experiment_name]],
+          initial_data[[experiment_name]],
           dataname = experiment_name,
           subject_keys = join_keys() # empty join keys
         ),
@@ -257,12 +264,19 @@ get_object_filter_overview_MultiAssayExperiment <- function(filtered_data, # nol
     experiment_names,
     function(experiment_name) {
       data.frame(
-        subjects = get_experiment_keys(filtered_data, unfiltered_data[[experiment_name]]),
-        subjects_filtered = get_experiment_keys(filtered_data, filtered_data[[experiment_name]])
+        subjects = if (!is.null(initial_data)) {
+          sprintf(
+            "%s/%s",
+            get_experiment_keys(current_data, current_data[[experiment_name]]),
+            get_experiment_keys(current_data, initial_data[[experiment_name]])
+          )
+        } else {
+          get_experiment_keys(current_data, current_data[[experiment_name]])
+        }
       )
     }
   ))
 
-  experiment_info <- cbind(experiment_obs_info[, c("dataname", "obs", "obs_filtered")], experiment_subjects_info)
-  rbind(mae_info, experiment_info)
+  experiment_info <- cbind(experiment_obs_info, experiment_subjects_info)
+  .smart_rbind(mae_info, experiment_info)
 }

R/module_init_data.R

@@ -95,7 +95,6 @@ srv_init_data <- function(id, data) {
 #' @keywords internal
 .add_signature_to_data <- function(data) {
   hashes <- .get_hashes_code(data)
-
   tdata <- do.call(
     teal.data::teal_data,
     c(

R/utils.R

@@ -376,3 +376,79 @@ strip_style <- function(string) {
     useBytes = TRUE
   )
 }
+
+#' Convert character list to human readable html with commas and "and"
+#' @noRd
+paste_datanames_character <- function(x,
+                                      tags = list(span = shiny::tags$span, code = shiny::tags$code),
+                                      tagList = shiny::tagList) { # nolint: object_name.
+  checkmate::assert_character(x)
+  do.call(
+    tagList,
+    lapply(seq_along(x), function(.ix) {
+      tagList(
+        tags$code(x[.ix]),
+        if (.ix != length(x)) {
+          tags$span(ifelse(.ix == length(x) - 1, " and ", ", "))
+        }
+      )
+    })
+  )
+}
+
+#' Build datanames error string for error message
+#'
+#' tags and tagList are overwritten in arguments allowing to create strings for
+#' logging purposes
+#' @noRd
+build_datanames_error_message <- function(label = NULL,
+                                          datanames,
+                                          extra_datanames,
+                                          tags = list(span = shiny::tags$span, code = shiny::tags$code),
+                                          tagList = shiny::tagList) { # nolint: object_name.
+  tags$span(
+    tags$span(ifelse(length(extra_datanames) > 1, "Datasets", "Dataset")),
+    paste_datanames_character(extra_datanames, tags, tagList),
+    tags$span(
+      paste0(
+        ifelse(length(extra_datanames) > 1, "are missing", "is missing"),
+        ifelse(is.null(label), ".", sprintf(" for tab '%s'.", label))
+      )
+    ),
+    if (length(datanames) >= 1) {
+      tagList(
+        tags$span(ifelse(length(datanames) > 1, "Datasets", "Dataset")),
+        tags$span("available in data:"),
+        tagList(
+          tags$span(
+            paste_datanames_character(datanames, tags, tagList),
+            tags$span(".", .noWS = "outside"),
+            .noWS = c("outside")
+          )
+        )
+      )
+    } else {
+      tags$span("No datasets are available in data.")
+    }
+  )
+}
+
+#' Smart `rbind`
+#'
+#' Combine `data.frame` objects which have different columns
+#'
+#' @param ... (`data.frame`)
+#' @keywords internal
+.smart_rbind <- function(...) {
+  dots <- list(...)
+  checkmate::assert_list(dots, "data.frame", .var.name = "...")
+  Reduce(
+    x = dots,
+    function(x, y) {
+      all_columns <- union(colnames(x), colnames(y))
+      x[setdiff(all_columns, colnames(x))] <- NA
+      y[setdiff(all_columns, colnames(y))] <- NA
+      rbind(x, y)
+    }
+  )
+}