diff --git a/DESCRIPTION b/DESCRIPTION index 3c0af05ee..cb6eee452 100644 --- a/DESCRIPTION +++ b/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), diff --git a/R/tm_g_distribution.R b/R/tm_g_distribution.R index 22d5fec89..9fc6e3a6b 100644 --- a/R/tm_g_distribution.R +++ b/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)) { diff --git a/R/tm_g_scatterplot.R b/R/tm_g_scatterplot.R index 1f2d9d58a..696ff4eb6 100644 --- a/R/tm_g_scatterplot.R +++ b/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 + diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index 70f5d4b7e..89fa86935 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/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) diff --git a/R/tm_missing_data.R b/R/tm_missing_data.R index d57c616bd..079a87718 100644 --- a/R/tm_missing_data.R +++ b/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,6 +1150,15 @@ 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 %>% @@ -1165,7 +1166,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par 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") diff --git a/R/tm_variable_browser.R b/R/tm_variable_browser.R index 708c835e7..b6837157c 100644 --- a/R/tm_variable_browser.R +++ b/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 +}