diff --git a/.lintr b/.lintr index b2279e658..113ca30c1 100644 --- a/.lintr +++ b/.lintr @@ -2,5 +2,6 @@ linters: linters_with_defaults( line_length_linter = line_length_linter(120), cyclocomp_linter = NULL, object_usage_linter = NULL, - object_name_linter = object_name_linter(styles = c("snake_case", "symbols"), regexes = c(ANL = "^ANL_?[0-9A-Z_]*$", ADaM = "^r?AD[A-Z]{2,3}_?[0-9]*$")) + object_name_linter = object_name_linter(styles = c("snake_case", "symbols"), regexes = c(ANL = "^ANL_?[0-9A-Z_]*$", ADaM = "^r?AD[A-Z]{2,3}_?[0-9]*$")), + indentation_linter = NULL ) diff --git a/R/tm_a_pca.R b/R/tm_a_pca.R index 7360ea2bc..42261b2f0 100644 --- a/R/tm_a_pca.R +++ b/R/tm_a_pca.R @@ -161,7 +161,7 @@ tm_a_pca <- function(label = "Principal Component Analysis", data_extract_list <- list(dat = dat) - module( + ans <- module( label = label, server = srv_a_pca, ui = ui_a_pca, @@ -176,6 +176,8 @@ tm_a_pca <- function(label = "Principal Component Analysis", ), datanames = teal.transform::get_extract_datanames(data_extract_list) ) + attr(ans, "teal_bookmarkable") <- FALSE + ans } # UI function for the PCA module @@ -753,7 +755,11 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl dev_labs <- list(color = varname_w_label(resp_col, ANL)) scales_biplot <- - if (is.character(response) || is.factor(response) || (is.numeric(response) && length(unique(response)) <= 6)) { # nolint: line_length. + if ( + is.character(response) || + is.factor(response) || + (is.numeric(response) && length(unique(response)) <= 6) + ) { qenv <- teal.code::eval_code( qenv, quote(pca_rot$response <- as.factor(response)) diff --git a/R/tm_a_regression.R b/R/tm_a_regression.R index 228da3079..d276aaa2d 100644 --- a/R/tm_a_regression.R +++ b/R/tm_a_regression.R @@ -225,7 +225,7 @@ tm_a_regression <- function(label = "Regression Analysis", response = response ) - module( + ans <- module( label = label, server = srv_a_regression, ui = ui_a_regression, @@ -241,6 +241,8 @@ tm_a_regression <- function(label = "Regression Analysis", ), datanames = teal.transform::get_extract_datanames(data_extract_list) ) + attr(ans, "teal_bookmarkable") <- FALSE + ans } # UI function for the regression module @@ -370,6 +372,8 @@ srv_a_regression <- function(id, checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { + ns <- session$ns + rule_rvr1 <- function(value) { if (isTRUE(input$plot_type == "Response vs Regressor")) { if (length(value) > 1L) { @@ -472,7 +476,7 @@ srv_a_regression <- function(id, session = session, inputId = "label_var", choices = opts, - selected = selected + selected = restoreInput(ns("label_var"), selected) ) data <- fortify(stats::lm(form, data = ANL)) @@ -484,7 +488,7 @@ srv_a_regression <- function(id, inputId = "outlier", min = 1, max = max_outlier, - value = if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9 + value = restoreInput(ns("outlier"), if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9) ) } diff --git a/R/tm_data_table.R b/R/tm_data_table.R index 522f8aa0f..db9f42681 100644 --- a/R/tm_data_table.R +++ b/R/tm_data_table.R @@ -116,7 +116,7 @@ tm_data_table <- function(label = "Data Table", checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) # End of assertions - module( + ans <- module( label, server = srv_page_data_table, ui = ui_page_data_table, @@ -133,6 +133,8 @@ tm_data_table <- function(label = "Data Table", post_output = post_output ) ) + attr(ans, "teal_bookmarkable") <- TRUE + ans } # UI page module @@ -196,41 +198,44 @@ srv_page_data_table <- function(id, output$dataset_table <- renderUI({ do.call( tabsetPanel, - lapply( - datanames, - function(x) { - dataset <- isolate(data()[[x]]) - choices <- names(dataset) - labels <- vapply( - dataset, - function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")), - character(1) - ) - names(choices) <- ifelse( - is.na(labels) | labels == "", - choices, - paste(choices, labels, sep = ": ") - ) - variables_selected <- if (!is.null(variables_selected[[x]])) { - variables_selected[[x]] - } else { - utils::head(choices) - } - tabPanel( - title = x, - column( - width = 12, - tags$div( - class = "mt-4", - ui_data_table( - id = session$ns(x), - choices = choices, - selected = variables_selected + c( + list(id = session$ns("dataname_tab")), + lapply( + datanames, + function(x) { + dataset <- isolate(data()[[x]]) + choices <- names(dataset) + labels <- vapply( + dataset, + function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")), + character(1) + ) + names(choices) <- ifelse( + is.na(labels) | labels == "", + choices, + paste(choices, labels, sep = ": ") + ) + variables_selected <- if (!is.null(variables_selected[[x]])) { + variables_selected[[x]] + } else { + utils::head(choices) + } + tabPanel( + title = x, + column( + width = 12, + div( + class = "mt-4", + ui_data_table( + id = session$ns(x), + choices = choices, + selected = variables_selected + ) ) ) ) - ) - } + } + ) ) ) }) @@ -296,7 +301,7 @@ srv_data_table <- function(id, iv <- shinyvalidate::InputValidator$new() iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names")) iv$add_rule("variables", shinyvalidate::sv_in_set( - set = names(data()[[dataname]]), message_fmt = "Not all selected variables exist in the data" + set = names(isolate(data())[[dataname]]), message_fmt = "Not all selected variables exist in the data" )) iv$enable() diff --git a/R/tm_file_viewer.R b/R/tm_file_viewer.R index dbf9f3674..8564cf6ab 100644 --- a/R/tm_file_viewer.R +++ b/R/tm_file_viewer.R @@ -82,7 +82,7 @@ tm_file_viewer <- function(label = "File Viewer Module", # Make UI args args <- as.list(environment()) - module( + ans <- module( label = label, server = srv_viewer, server_args = list(input_path = input_path), @@ -90,6 +90,8 @@ tm_file_viewer <- function(label = "File Viewer Module", ui_args = args, datanames = NULL ) + attr(ans, "teal_bookmarkable") <- FALSE + ans } # UI function for the file viewer module diff --git a/R/tm_front_page.R b/R/tm_front_page.R index 7d5c02f04..45bde2fe7 100644 --- a/R/tm_front_page.R +++ b/R/tm_front_page.R @@ -81,7 +81,7 @@ tm_front_page <- function(label = "Front page", # Make UI args args <- as.list(environment()) - module( + ans <- module( label = label, server = srv_front_page, ui = ui_front_page, @@ -89,6 +89,8 @@ tm_front_page <- function(label = "Front page", server_args = list(tables = tables, show_metadata = show_metadata), datanames = if (show_metadata) "all" else NULL ) + attr(ans, "teal_bookmarkable") <- TRUE + ans } # UI function for the front page module @@ -137,6 +139,8 @@ srv_front_page <- function(id, data, tables, show_metadata) { moduleServer(id, function(input, output, session) { ns <- session$ns + setBookmarkExclude("metadata_button") + lapply(seq_along(tables), function(idx) { output[[paste0("table_", idx)]] <- renderTable( tables[[idx]], diff --git a/R/tm_g_association.R b/R/tm_g_association.R index 5eeca0240..ae1ccebe6 100644 --- a/R/tm_g_association.R +++ b/R/tm_g_association.R @@ -177,7 +177,7 @@ tm_g_association <- function(label = "Association", vars = vars ) - module( + ans <- module( label = label, server = srv_tm_g_association, ui = ui_tm_g_association, @@ -188,6 +188,8 @@ tm_g_association <- function(label = "Association", ), datanames = teal.transform::get_extract_datanames(data_extract_list) ) + attr(ans, "teal_bookmarkable") <- TRUE + ans } # UI function for the association module diff --git a/R/tm_g_bivariate.R b/R/tm_g_bivariate.R index 7e67adcbb..7c3fa8ee6 100644 --- a/R/tm_g_bivariate.R +++ b/R/tm_g_bivariate.R @@ -288,7 +288,7 @@ tm_g_bivariate <- function(label = "Bivariate Plots", size = size ) - module( + ans <- module( label = label, server = srv_g_bivariate, ui = ui_g_bivariate, @@ -299,6 +299,8 @@ tm_g_bivariate <- function(label = "Bivariate Plots", ), datanames = teal.transform::get_extract_datanames(data_extract_list) ) + attr(ans, "teal_bookmarkable") <- TRUE + ans } # UI function for the bivariate module @@ -463,6 +465,8 @@ srv_g_bivariate <- function(id, checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { + ns <- session$ns + data_extract <- list( x = x, y = y, row_facet = row_facet, col_facet = col_facet, color = color, fill = fill, size = size @@ -586,7 +590,7 @@ srv_g_bivariate <- function(id, } } else { shinyjs::hide("add_lines") - updateCheckboxInput(session, "add_lines", value = FALSE) + updateCheckboxInput(session, "add_lines", value = restoreInput(ns("add_lines"), FALSE)) shinyjs::hide("alpha") shinyjs::hide("fixed_size") shinyjs::hide("size_settings") diff --git a/R/tm_g_distribution.R b/R/tm_g_distribution.R index 2f962ba15..50630b10e 100644 --- a/R/tm_g_distribution.R +++ b/R/tm_g_distribution.R @@ -180,7 +180,7 @@ tm_g_distribution <- function(label = "Distribution Module", group_var = group_var ) - module( + ans <- module( label = label, server = srv_distribution, server_args = c( @@ -191,6 +191,8 @@ tm_g_distribution <- function(label = "Distribution Module", ui_args = args, datanames = teal.transform::get_extract_datanames(data_extract_list) ) + attr(ans, "teal_bookmarkable") <- TRUE + ans } # UI function for the distribution module @@ -291,7 +293,7 @@ ui_distribution <- function(id, ...) { ), numericInput(ns("dist_param1"), label = "param1", value = NULL), numericInput(ns("dist_param2"), label = "param2", value = NULL), - tags$span(actionButton(ns("params_reset"), "Reset params")), + tags$span(actionButton(ns("params_reset"), "Default params")), collapsed = FALSE ) ) @@ -355,6 +357,8 @@ srv_distribution <- function(id, checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { + ns <- session$ns + rule_req <- function(value) { if (isTRUE(input$dist_tests %in% c( "Fligner-Killeen", @@ -486,7 +490,7 @@ srv_distribution <- function(id, output$scales_types_ui <- renderUI({ if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) { shinyWidgets::prettyRadioButtons( - session$ns("scales_type"), + ns("scales_type"), label = "Scales:", choices = c("Fixed", "Free"), selected = "Fixed", @@ -503,36 +507,48 @@ srv_distribution <- function(id, selector_list()$dist_i()$select ), handlerExpr = { - if (length(input$t_dist) != 0) { - dist_var2 <- as.vector(merged$anl_input_r()$columns_source$dist_i) - - get_dist_params <- function(x, dist) { - if (dist == "unif") { - res <- as.list(range(x)) - names(res) <- c("min", "max") - return(res) + req(input$params_reset) + params <- + if (length(input$t_dist) != 0) { + dist_var2 <- as.vector(merged$anl_input_r()$columns_source$dist_i) + + get_dist_params <- function(x, dist) { + if (dist == "unif") { + return(stats::setNames(range(x, na.rm = TRUE), c("min", "max"))) + } + tryCatch( + MASS::fitdistr(x, densfun = dist)$estimate, + error = function(e) c(param1 = NA_real_, param2 = NA_real_) + ) } - tryCatch( - as.list(MASS::fitdistr(x, densfun = dist)$estimate), - error = function(e) list(param1 = NA, param2 = NA) - ) + + ANL <- merged$anl_q_r()[[as.character(dist_var[[1]]$dataname)]] + round(get_dist_params(as.numeric(stats::na.omit(ANL[[dist_var2]])), input$t_dist), 2) + } else { + c("param1" = NA_real_, "param2" = NA_real_) } - ANL <- merged$anl_q_r()[[as.character(dist_var[[1]]$dataname)]] - params <- get_dist_params(as.numeric(stats::na.omit(ANL[[dist_var2]])), input$t_dist) - params_vec <- round(unname(unlist(params)), 2) - params_names <- names(params) + params_vals <- unname(params) + params_names <- names(params) - updateNumericInput(session, "dist_param1", label = params_names[1], value = params_vec[1]) - updateNumericInput(session, "dist_param2", label = params_names[2], value = params_vec[2]) - } else { - updateNumericInput(session, "dist_param1", label = "param1", value = NA) - updateNumericInput(session, "dist_param2", label = "param2", value = NA) - } + updateNumericInput( + inputId = "dist_param1", + label = params_names[1], + value = restoreInput(ns("dist_param1"), params_vals[1]) + ) + updateNumericInput( + inputId = "dist_param2", + label = params_names[2], + value = restoreInput(ns("dist_param1"), params_vals[2]) + ) }, ignoreInit = TRUE ) + observeEvent(input$params_reset, { + updateActionButton(inputId = "params_reset", label = "Reset params") + }) + merge_vars <- reactive({ teal::validate_inputs(iv_r()) diff --git a/R/tm_g_response.R b/R/tm_g_response.R index dc2250b1a..980994f54 100644 --- a/R/tm_g_response.R +++ b/R/tm_g_response.R @@ -206,7 +206,7 @@ tm_g_response <- function(label = "Response Plot", col_facet = col_facet ) - module( + ans <- module( label = label, server = srv_g_response, ui = ui_g_response, @@ -217,6 +217,8 @@ tm_g_response <- function(label = "Response Plot", ), datanames = teal.transform::get_extract_datanames(data_extract_list) ) + attr(ans, "teal_bookmarkable") <- TRUE + ans } # UI function for the response module diff --git a/R/tm_g_scatterplot.R b/R/tm_g_scatterplot.R index 65dd295ec..e1ee34d10 100644 --- a/R/tm_g_scatterplot.R +++ b/R/tm_g_scatterplot.R @@ -308,7 +308,7 @@ tm_g_scatterplot <- function(label = "Scatterplot", col_facet = col_facet ) - module( + ans <- module( label = label, server = srv_g_scatterplot, ui = ui_g_scatterplot, @@ -319,6 +319,8 @@ tm_g_scatterplot <- function(label = "Scatterplot", ), datanames = teal.transform::get_extract_datanames(data_extract_list) ) + attr(ans, "teal_bookmarkable") <- TRUE + ans } # UI function for the scatterplot module diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index 1020eaa3f..ef329c3d7 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -191,7 +191,7 @@ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix", # Make UI args args <- as.list(environment()) - module( + ans <- module( label = label, server = srv_g_scatterplotmatrix, ui = ui_g_scatterplotmatrix, @@ -199,6 +199,8 @@ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix", server_args = list(variables = variables, plot_height = plot_height, plot_width = plot_width), datanames = teal.transform::get_extract_datanames(variables) ) + attr(ans, "teal_bookmarkable") <- TRUE + ans } # UI function for the scatterplot matrix module diff --git a/R/tm_missing_data.R b/R/tm_missing_data.R index 3c4ffef84..12eb6835f 100644 --- a/R/tm_missing_data.R +++ b/R/tm_missing_data.R @@ -124,7 +124,7 @@ tm_missing_data <- function(label = "Missing data", checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) # End of assertions - module( + ans <- module( label, server = srv_page_missing_data, server_args = list( @@ -135,6 +135,8 @@ tm_missing_data <- function(label = "Missing data", datanames = "all", ui_args = list(pre_output = pre_output, post_output = post_output) ) + attr(ans, "teal_bookmarkable") <- TRUE + ans } # UI function for the missing data module (all datasets) @@ -165,12 +167,15 @@ ui_page_missing_data <- function(id, pre_output = NULL, post_output = NULL) { # Server function for the missing data module (all datasets) srv_page_missing_data <- function(id, data, reporter, filter_panel_api, parent_dataname, plot_height, plot_width, ggplot2_args, ggtheme) { + with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") + with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") moduleServer(id, function(input, output, session) { datanames <- isolate(teal.data::datanames(data())) datanames <- Filter(function(name) { is.data.frame(isolate(data())[[name]]) }, datanames) if_subject_plot <- length(parent_dataname) > 0 && parent_dataname %in% datanames + ns <- session$ns output$dataset_tabs <- renderUI({ @@ -236,8 +241,8 @@ srv_page_missing_data <- function(id, data, reporter, filter_panel_api, parent_d srv_missing_data( id = x, data = data, - reporter = reporter, - filter_panel_api = filter_panel_api, + reporter = if (with_reporter) reporter, + filter_panel_api = if (with_filter) filter_panel_api, dataname = x, parent_dataname = parent_dataname, plot_height = plot_height, @@ -416,6 +421,8 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { + ns <- session$ns + prev_group_by_var <- reactiveVal("") data_r <- reactive(data()[[dataname]]) data_keys <- reactive(unlist(teal.data::join_keys(data())[[dataname]])) @@ -550,7 +557,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par selected <- choices <- unname(unlist(choices)) teal.widgets::optionalSelectInput( - session$ns("variables_select"), + ns("variables_select"), label = "Select variables", label_help = HTML(paste0("Dataset: ", tags$code(dataname))), choices = teal.transform::variable_choices(data_r(), choices), @@ -573,7 +580,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par session = session, inputId = "variables_select", choices = teal.transform::variable_choices(data_r()), - selected = selected + selected = restoreInput(ns("variables_select"), selected) ) }) @@ -584,7 +591,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par need(cat_choices, "Dataset does not have any non-numeric or non-datetime variables to use to group data with") ) teal.widgets::optionalSelectInput( - session$ns("group_by_var"), + ns("group_by_var"), label = "Group by variable", choices = cat_choices, selected = `if`( @@ -625,7 +632,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par validate(need(length(choices) < 100, "Please select group-by variable with fewer than 100 unique values")) teal.widgets::optionalSelectInput( - session$ns("group_by_vals"), + ns("group_by_vals"), label = "Filter levels", choices = choices, selected = selected, @@ -872,7 +879,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ) teal.widgets::optionalSliderInputValMinMax( - session$ns("combination_cutoff"), + ns("combination_cutoff"), "Combination cut-off", c(value, range(x)) ) diff --git a/R/tm_outliers.R b/R/tm_outliers.R index 88c947e3a..84b323008 100644 --- a/R/tm_outliers.R +++ b/R/tm_outliers.R @@ -177,7 +177,7 @@ tm_outliers <- function(label = "Outliers Module", categorical_var = categorical_var ) - module( + ans <- module( label = label, server = srv_outliers, server_args = c( @@ -188,6 +188,8 @@ tm_outliers <- function(label = "Outliers Module", ui_args = args, datanames = teal.transform::get_extract_datanames(data_extract_list) ) + attr(ans, "teal_bookmarkable") <- TRUE + ans } # UI function for the outliers module @@ -331,6 +333,8 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var, checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { + ns <- session$ns + vars <- list(outlier_var = outlier_var, categorical_var = categorical_var) rule_diff <- function(other) { @@ -1056,15 +1060,15 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var, brushing = TRUE ) - choices <- teal.transform::variable_choices(data()[[dataname_first]]) + choices <- reactive(teal.transform::variable_choices(data()[[dataname_first]])) observeEvent(common_code_q(), { ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] teal.widgets::updateOptionalSelectInput( session, inputId = "table_ui_columns", - choices = dplyr::setdiff(choices, names(ANL_OUTLIER)), - selected = isolate(input$table_ui_columns) + choices = dplyr::setdiff(choices(), names(ANL_OUTLIER)), + selected = restoreInput(ns("table_ui_columns"), isolate(input$table_ui_columns)) ) }) @@ -1204,14 +1208,14 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var, req(iv_r()$is_valid()) tagList( teal.widgets::optionalSelectInput( - inputId = session$ns("table_ui_columns"), + inputId = ns("table_ui_columns"), label = "Choose additional columns", choices = NULL, selected = NULL, multiple = TRUE ), tags$h4("Outlier Table"), - teal.widgets::get_dt_rows(session$ns("table_ui"), session$ns("table_ui_rows")) + teal.widgets::get_dt_rows(ns("table_ui"), ns("table_ui_rows")) ) }) diff --git a/R/tm_t_crosstable.R b/R/tm_t_crosstable.R index 5adc366e9..61f236df4 100644 --- a/R/tm_t_crosstable.R +++ b/R/tm_t_crosstable.R @@ -173,7 +173,7 @@ tm_t_crosstable <- function(label = "Cross Table", basic_table_args = basic_table_args ) - module( + ans <- module( label = label, server = srv_t_crosstable, ui = ui_t_crosstable, @@ -181,6 +181,8 @@ tm_t_crosstable <- function(label = "Cross Table", server_args = server_args, datanames = teal.transform::get_extract_datanames(list(x = x, y = y)) ) + attr(ans, "teal_bookmarkable") <- TRUE + ans } # UI function for the cross-table module diff --git a/R/tm_variable_browser.R b/R/tm_variable_browser.R index 283a48855..591137ccb 100644 --- a/R/tm_variable_browser.R +++ b/R/tm_variable_browser.R @@ -100,7 +100,7 @@ tm_variable_browser <- function(label = "Variable Browser", datasets_selected <- unique(datasets_selected) - module( + ans <- module( label, server = srv_variable_browser, ui = ui_variable_browser, @@ -115,6 +115,9 @@ tm_variable_browser <- function(label = "Variable Browser", post_output = post_output ) ) + # `shiny` inputs are stored properly but the majority of the module is state of `datatable` which is not stored. + attr(ans, "teal_bookmarkable") <- NULL + ans } # UI function for the variable browser module