checking soft dependencies

DESCRIPTION

@@ -30,11 +30,18 @@ Depends:
     teal (>= 0.15.2.9079),
     teal.transform (>= 0.5.0.9015)
 Imports:
+    broom (>= 0.7.10),
     checkmate (>= 2.1.0),
+    colourpicker,
     dplyr (>= 1.0.5),
     DT (>= 0.13),
     forcats (>= 1.0.0),
     grid,
+    ggExtra,
+    goftest,
+    ggrepel,
+    lattice (>= 0.18-4),
+    logger (>= 0.3.0),
     scales,
     shinyjs,
     shinyTree (>= 0.2.8),
@@ -53,18 +60,12 @@ Imports:
     tools,
     utils
 Suggests:
-    broom (>= 0.7.10),
-    colourpicker,
-    ggExtra,
     ggpmisc (>= 0.4.3),
     ggpp,
-    ggrepel,
-    goftest,
     gridExtra,
     htmlwidgets,
     jsonlite,
     knitr (>= 1.42),
-    lattice (>= 0.18-4),
     logger (>= 0.2.0),
     MASS,
     nestcolor (>= 0.1.0),

R/tm_g_distribution.R

@@ -124,16 +124,6 @@ tm_g_distribution <- function(label = "Distribution Module",
                               post_output = NULL) {
   message("Initializing tm_g_distribution")
 
-  # Requires Suggested packages
-  extra_packages <- c("ggpmisc", "ggpp", "goftest", "MASS", "broom")
-  missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)
-  if (length(missing_packages) > 0L) {
-    stop(sprintf(
-      "Cannot load package(s): %s.\nInstall or restart your session.",
-      toString(missing_packages)
-    ))
-  }
-
   # Normalize the parameters
   if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var)
   if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var)
@@ -520,7 +510,11 @@ srv_distribution <- function(id,
                 return(stats::setNames(range(x, na.rm = TRUE), c("min", "max")))
               }
               tryCatch(
-                MASS::fitdistr(x, densfun = dist)$estimate,
+                if (requireNamespace("MASS", quietly = TRUE)) {
+                  MASS::fitdistr(x, densfun = dist)$estimate
+                } else {
+                  stop()
+                } ,
                 error = function(e) c(param1 = NA_real_, param2 = NA_real_)
               )
             }
@@ -836,14 +830,16 @@ srv_distribution <- function(id,
           datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))
           label <- quote(tb)
 
-          plot_call <- substitute(
-            expr = plot_call + ggpp::geom_table_npc(
-              data = data,
-              aes(npcx = x, npcy = y, label = label),
-              hjust = 0, vjust = 1, size = 4
-            ),
-            env = list(plot_call = plot_call, data = datas, label = label)
-          )
+          if (requireNamespace("ggpp", quietly = TRUE)) {
+            plot_call <- substitute(
+              expr = plot_call + ggpp::geom_table_npc(
+                data = data,
+                aes(npcx = x, npcy = y, label = label),
+                hjust = 0, vjust = 1, size = 4
+              ),
+              env = list(plot_call = plot_call, data = datas, label = label)
+            )
+          }
         }
 
         if (
@@ -983,21 +979,23 @@ srv_distribution <- function(id,
           datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))
           label <- quote(tb)
 
-          plot_call <- substitute(
-            expr = plot_call +
-              ggpp::geom_table_npc(
-                data = data,
-                aes(npcx = x, npcy = y, label = label),
-                hjust = 0,
-                vjust = 1,
-                size = 4
-              ),
-            env = list(
-              plot_call = plot_call,
-              data = datas,
-              label = label
+          if (requireNamespace("ggpp", quietly = TRUE)) {
+            plot_call <- substitute(
+              expr = plot_call +
+                ggpp::geom_table_npc(
+                  data = data,
+                  aes(npcx = x, npcy = y, label = label),
+                  hjust = 0,
+                  vjust = 1,
+                  size = 4
+                ),
+              env = list(
+                plot_call = plot_call,
+                data = datas,
+                label = label
+              )
             )
-          )
+          }
         }
 
         if (isTRUE(input$qq_line)) {

R/tm_g_scatterplot.R

@@ -232,16 +232,6 @@ tm_g_scatterplot <- function(label = "Scatterplot",
                              ggplot2_args = teal.widgets::ggplot2_args()) {
   message("Initializing tm_g_scatterplot")
 
-  # Requires Suggested packages
-  extra_packages <- c("ggpmisc", "ggExtra", "colourpicker")
-  missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)
-  if (length(missing_packages) > 0L) {
-    stop(sprintf(
-      "Cannot load package(s): %s.\nInstall or restart your session.",
-      toString(missing_packages)
-    ))
-  }
-
   # Normalize the parameters
   if (inherits(x, "data_extract_spec")) x <- list(x)
   if (inherits(y, "data_extract_spec")) y <- list(y)
@@ -830,28 +820,31 @@ srv_g_scatterplot <- function(id,
           ),
           if (sum(show_form, show_r2, show_count) > 1) ", sep = '*\", \"*'))" else ")"
         )
-        label_geom <- substitute(
-          expr = ggpmisc::stat_poly_eq(
-            mapping = aes_label,
-            formula = rhs_formula,
-            parse = TRUE,
-            label.x = pos,
-            size = label_size
-          ),
-          env = list(
-            rhs_formula = rhs_formula,
-            pos = pos,
-            aes_label = str2lang(aes_label),
-            label_size = label_size
+
+        if (requireNamespace("ggpmisc", quietly = TRUE)) {
+          label_geom <- substitute(
+            expr = ggpmisc::stat_poly_eq(
+              mapping = aes_label,
+              formula = rhs_formula,
+              parse = TRUE,
+              label.x = pos,
+              size = label_size
+            ),
+            env = list(
+              rhs_formula = rhs_formula,
+              pos = pos,
+              aes_label = str2lang(aes_label),
+              label_size = label_size
+            )
           )
-        )
-        substitute(
-          expr = plot_call + label_geom,
-          env = list(
-            plot_call = plot_call,
-            label_geom = label_geom
+          substitute(
+            expr = plot_call + label_geom,
+            env = list(
+              plot_call = plot_call,
+              label_geom = label_geom
+            )
           )
-        )
+        }
       }
 
       if (trend_line_is_applicable()) {
@@ -952,20 +945,23 @@ srv_g_scatterplot <- function(id,
 
 
       if (add_density) {
-        plot_call <- substitute(
-          expr = ggExtra::ggMarginal(
-            plot_call + labs + ggthemes + themes,
-            type = "density",
-            groupColour = group_colour
-          ),
-          env = list(
-            plot_call = plot_call,
-            group_colour = if (length(color_by_var) > 0) TRUE else FALSE,
-            labs = parsed_ggplot2_args$labs,
-            ggthemes = parsed_ggplot2_args$ggtheme,
-            themes = parsed_ggplot2_args$theme
+        if (requireNamespace("ggExtra", quietly = TRUE)) {
+          plot_call <- substitute(
+            expr = ggExtra::ggMarginal(
+              plot_call + labs + ggthemes + themes,
+              type = "density",
+              groupColour = group_colour
+            ),
+            env = list(
+              plot_call = plot_call,
+              group_colour = if (length(color_by_var) > 0) TRUE else FALSE,
+              labs = parsed_ggplot2_args$labs,
+              ggthemes = parsed_ggplot2_args$ggtheme,
+              themes = parsed_ggplot2_args$theme
+            )
           )
-        )
+        }
+
       } else {
         plot_call <- substitute(
           expr = plot_call +

R/tm_g_scatterplotmatrix.R

@@ -171,11 +171,6 @@ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",
                                    post_output = NULL) {
   message("Initializing tm_g_scatterplotmatrix")
 
-  # Requires Suggested packages
-  if (!requireNamespace("lattice", quietly = TRUE)) {
-    stop("Cannot load lattice - please install the package or restart your session.")
-  }
-
   # Normalize the parameters
   if (inherits(variables, "data_extract_spec")) variables <- list(variables)
 

R/tm_missing_data.R

@@ -90,14 +90,6 @@ tm_missing_data <- function(label = "Missing data",
                             post_output = NULL) {
   message("Initializing tm_missing_data")
 
-  # Requires Suggested packages
-  if (!requireNamespace("gridExtra", quietly = TRUE)) {
-    stop("Cannot load gridExtra - please install the package or restart your session.")
-  }
-  if (!requireNamespace("rlang", quietly = TRUE)) {
-    stop("Cannot load rlang - please install the package or restart your session.")
-  }
-
   # Normalize the parameters
   if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)
 
@@ -1158,14 +1150,23 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par
               dplyr::summarise_all(anyNA) %>%
               dplyr::ungroup()
 
+            create_hash_base <- function(x) {
+              if(requireNamespace("rlang", quietly = TRUE)) {
+                rlang::hash(x)
+              } else {
+                raw_serialized <- serialize(x, NULL)
+                paste(as.integer(raw_serialized), collapse = "")
+              }
+            }
+
             # order subjects by decreasing number of missing and then by
             # missingness pattern (defined using sha1)
             order_subjects <- summary_plot_patients %>%
               dplyr::select(-"id", -dplyr::all_of(parent_keys)) %>%
               dplyr::transmute(
                 id = dplyr::row_number(),
                 number_NA = apply(., 1, sum),
-                sha = apply(., 1, rlang::hash)
+                sha = apply(., 1, create_hash_base)
               ) %>%
               dplyr::arrange(dplyr::desc(number_NA), sha) %>%
               getElement(name = "id")

R/tm_variable_browser.R

@@ -89,14 +89,10 @@ tm_variable_browser <- function(label = "Variable Browser",
   message("Initializing tm_variable_browser")
 
   # Requires Suggested packages
-  if (!requireNamespace("sparkline", quietly = TRUE)) {
-    stop("Cannot load sparkline - please install the package or restart your session.")
-  }
-  if (!requireNamespace("htmlwidgets", quietly = TRUE)) {
-    stop("Cannot load htmlwidgets - please install the package or restart your session.")
-  }
-  if (!requireNamespace("jsonlite", quietly = TRUE)) {
-    stop("Cannot load jsonlite - please install the package or restart your session.")
+  if (requireNamespace("sparkline", quietly = TRUE)) {
+    lapply(c("htmlwidgets", "jsonlite"), function(pkg) {
+      if (!requireNamespace(pkg, quietly = TRUE)) stop(paste("Cannot load", pkg, "- please install the package or restart your session."))
+    })
   }
 
   # Start of assertions
@@ -141,7 +137,9 @@ ui_variable_browser <- function(id,
     shinyjs::useShinyjs(),
     teal.widgets::standard_layout(
       output = fluidRow(
-        htmlwidgets::getDependency("sparkline"), # needed for sparklines to work
+        if (requireNamespace("htmlwidgets", quietly = TRUE)) {
+          htmlwidgets::getDependency("sparkline")
+        }, # needed for sparklines to work
         column(
           6,
           # variable browser
@@ -995,22 +993,36 @@ render_tab_table <- function(dataset_name, parent_dataname, output, data, input,
       }
       icons <- variable_type_icons(icons)
 
-      # generate sparklines
-      sparklines_html <- vapply(
-        df,
-        create_sparklines,
-        FUN.VALUE = character(1),
-        USE.NAMES = FALSE
-      )
+      # Generate summaries or sparklines based on the availability of the sparkline package
+      if (requireNamespace("sparkline", quietly = TRUE)) {
+        sparklines_html <- vapply(
+          df,
+          create_sparklines,
+          FUN.VALUE = character(1),
+          USE.NAMES = FALSE
+        )
+        summary_column_name <- "Sparklines"
+        summary_content <- sparklines_html
+      } else {
+        summaries <- vapply(
+          df,
+          create_text_summary,
+          FUN.VALUE = character(1),
+          USE.NAMES = FALSE
+        )
+        summary_column_name <- "Summaries"
+        summary_content <- summaries
+      }
 
+      # Create the output data frame
       df_output <- data.frame(
         Type = icons,
         Variable = names(labels),
         Label = labels,
         Missings = missings,
-        Sparklines = sparklines_html,
         stringsAsFactors = FALSE
       )
+      df_output[[summary_column_name]] <- summary_content
     }
 
     # Select row 1 as default / fallback
@@ -1041,7 +1053,9 @@ render_tab_table <- function(dataset_name, parent_dataname, output, data, input,
       rownames = FALSE,
       selection = list(mode = "single", target = "row", selected = selected_ix),
       options = list(
-        fnDrawCallback = htmlwidgets::JS("function() { HTMLWidgets.staticRender(); }"),
+        fnDrawCallback = if (requireNamespace("htmlwidgets", quietly = TRUE)) {
+          htmlwidgets::JS("function() { HTMLWidgets.staticRender(); }")
+        },
         pageLength = input[[paste0(table_ui_id, "_rows")]],
         displayStart = selected_page_ix
       )
@@ -1302,3 +1316,23 @@ custom_sparkline_formatter <- function(labels, counts) {
     )
   )
 }
+
+# Function to create text summaries
+create_text_summary <- function(arr) {
+  if (is.numeric(arr)) {
+    summary <- sprintf("Min: %.2f, Median: %.2f, Max: %.2f", min(arr, na.rm = TRUE), median(arr, na.rm = TRUE), max(arr, na.rm = TRUE))
+  } else if (is.factor(arr) || is.character(arr)) {
+    tbl <- sort(table(arr), decreasing = TRUE)
+    most_common <- names(tbl)[1]
+    least_common <- names(tbl)[length(tbl)]
+    summary <- sprintf("Most common: %s, Least common: %s", most_common, least_common)
+  } else if (inherits(arr, "Date") || inherits(arr, "POSIXct") || inherits(arr, "POSIXlt")) {
+    summary <- sprintf("Range: %s to %s", min(arr, na.rm = TRUE), max(arr, na.rm = TRUE))
+  } else if (is.logical(arr)) {
+    summary <- sprintf("TRUE: %d, FALSE: %d", sum(arr, na.rm = TRUE), sum(!arr, na.rm = TRUE))
+  } else {
+    summary <- "Unsupported type"
+  }
+
+  summary
+}