Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.
library(nrba) library(dplyr) library(survey) library(shinyjs) library(openxlsx) enableBookmarking("server") options(shiny.maxRequestSize=30*1024^2) options(survey.lonely.psu = 'adjust') options(survey.adjust.domain.lonely = TRUE)
types <- read.csv(system.file("types.csv", package = "idcnrba")) routines <- read.csv(system.file("routines.csv", package = "idcnrba")) parameters <- read.csv(system.file("parameters.csv", package = "idcnrba")) parameters_html_crosswalk <- read.csv(system.file("parameters_html_crosswalk.csv", package = "idcnrba")) output_table_dictionary <- read.csv(system.file("output_table_dictionary.csv", package = "idcnrba")) errors <- read.csv(system.file("errors.csv", package = "idcnrba")) setup_module_checks <- read.csv(system.file("setup_module_checks.csv", package = "idcnrba")) # removes excess spaces at the ends and beginnings of strings in csv's types <- types %>% mutate_if(is.character, function(x) trimws(x)) routines <- routines %>% mutate_if(is.character, function(x) trimws(x)) parameters <- parameters %>% mutate_if(is.character, function(x) trimws(x)) parameters_html_crosswalk <- parameters_html_crosswalk %>% mutate_if(is.character, function(x) trimws(x)) output_table_dictionary <- output_table_dictionary %>% mutate_if(is.character, function(x) trimws(x)) errors <- errors %>% mutate_if(is.character, function(x) trimws(x)) setup_module_checks <- setup_module_checks %>% mutate_if(is.character, function(x) trimws(x)) analysis_store <<- list(`1` = list(), `2` = list(), `3` = list(), `4` = list(), `5` = list(), `6` = list(), `7` = list(), `8` = list(), `9` = list()) report_input_counter <<- 1 previous_report_input_counter <<- report_input_counter global_values <- reactiveValues() routine_name <<- NA rotuine_label <<- NA
onBookmarked(function(url) { updateQueryString(url) })
tooltips <- read.csv(system.file("html_identifiers.csv", package = "idcnrba")) tooltips_js_object <- paste0( "var nrba_tooltips = [", paste(paste0("['", tooltips$html_id, "',", "'", gsub("'", "\\\\'", tooltips$tooltip), "']"), collapse = ","), "];") tags$script(HTML(tooltips_js_object))
cat("<div style=\"height: 0px; visibility: hidden\">") htmlOutput(outputId = "report_link_container", container = div) cat("</div>")
percent <- function(x, digits = 2) { if (digits < 2) { stop("'digits' must be at least '2'") } format <- paste0("%0.", digits - 2, "f%%") sprintf(format, round(x, digits = digits) * 100) } as_survey_formula <- function(x, ids = FALSE) { if (is.null(x) || all(nchar(x) == 0)) { if (ids) { return(~1) } else return(NULL) } else { return(as.formula(paste0("~", paste(x, collapse = "+")))) } } as_numeric_input <- function(x) { if (is.null(x) || all(nchar(x) == 0)) { return(NULL) } else if (suppressWarnings(is.na(as.numeric(x)))) { input_name <- deparse(substitute(x)) stop(input_name, ": ", dQuote(x, F), " is not a numeric input.") } else { as.numeric(x) } } get_survey_design_object <- function(data, input, secondary_raked = FALSE) { if (input$sampling_weight_variable == "[No Weights]") { sampling_weight_variable_input <- NULL } else { sampling_weight_variable_input <- input$sampling_weight_variable } if (secondary_raked) { rscales_input <- input$t5_raked_rscales %>% strsplit(",") %>% unlist() %>% lapply(as_numeric_input, USE.NAMES = F) if (length(rscales_input) == 0) rscales_input <- NULL survey_design <- svrepdesign( data = data, weights = as_survey_formula(sampling_weight_variable_input), repweights = select(data, input$t5_raked_replicate_weight_variables), type = input$t5_raked_replicate_weight_method, combined.weights = input$t5_raked_combined_weights, rho = as_numeric_input(input$t5_raked_rho), scale = as_numeric_input(input$t5_raked_scale), rscales = rscales_input ) } else if (input$replicate_weights == "Yes") { rscales_input <- input$rscales %>% strsplit(",") %>% unlist() %>% lapply(as_numeric_input, USE.NAMES = F) if (length(rscales_input) == 0) rscales_input <- NULL survey_design <- svrepdesign( data = data, weights = as_survey_formula(sampling_weight_variable_input), repweights = select(data, input$replicate_weight_variables), type = input$replicate_weight_method, combined.weights = input$combined_weights, rho = as_numeric_input(input$rho), scale = as_numeric_input(input$scale), rscales = rscales_input ) } else { if (input$data_collection_method == "Attempted Census") { survey_design <- svydesign( data = data, weights = as_survey_formula(sampling_weight_variable_input), ids = ~1, fpc = as_survey_formula(input$population_size_variables) ) } else { survey_design <- svydesign( data = data, weights = as_survey_formula(sampling_weight_variable_input), strata = as_survey_formula(input$strata_variables), ids = as_survey_formula(c(input$psu_cluster_variables, input$ssu_cluster_variables), ids = T), nest = TRUE, fpc = as_survey_formula(input$population_size_variables) ) } } if (input$sampling_weight_variable == "[No Weights]") { survey_design$prob <- rep(1, times = nrow(data)) } return(survey_design) } analysisButton <- function(inputId, label, description = NA, info_link = "#") { fluidRow( column(actionButton( inputId = inputId, label = label, description = description, class = "btn-analysis", width = "99%" ), width = 11, style = "padding-right: 0px;"), hidden(column(tags$a( id = paste(inputId, "info", sep = "_"), icon("info-circle"), class = "action-button", style = "font-size: 16px; color: #1e857b;", href = info_link, target = "_blank" ), width = 1, style = "padding-left: 0px;")), style = "padding: .5px;" ) } # creates reactive add-to-report button report_rv <- reactiveValues(report_add_button = FALSE) output$report_add_button <- reactive({report_rv$report_add_button}) outputOptions(output, "report_add_button", suspendWhenHidden = FALSE) # creates reactive add-to-report button report_rv <- reactiveValues(report_remove_button = FALSE) output$report_remove_button <- reactive({report_rv$report_remove_button}) outputOptions(output, "report_remove_button", suspendWhenHidden = FALSE) render_analysis_output <- function(output_table) { most_recent_output_table <<- output_table renderUI({ if("error" %in% class(output_table) | length(output_table) == 0) { error <- "" if (is.na(routine_name)) { error <- "Variable `routine_name` not set. Please see detailed R message below." } else { for (iterate_error in errors$errors[errors$routine_name == routine_name]) { error <- paste0(iterate_error, "<br><br>", error) } } modal_out <- modalDialog( h3("Error in analysis:", style = "font-color: red;"), tags$p("Please check that the Setup module and the specific analysis options have been configured correctly. Below are some checks that may identify the source of the problem.\n", style = "font-weight: bold;"), HTML(paste0(error, "\n")), h3("Below is a more detailed error message from R", style = "font-color: red;"), tags$blockquote(output_table$message) ) } else { column_dictionary <- output_table_dictionary %>% rename(routine_name_lookup = routine_name) %>% # names in global env and table cannot be the same when comparing filter(routine_name_lookup == routine_name) %>% filter(nchar(short_label) > 0) %>% mutate(label = sprintf("<span title='%s'>%s</span>", description, short_label)) column_lookup <- column_dictionary$column_name names(column_lookup) <- column_dictionary$label column_lookup <- column_lookup[column_lookup %in% colnames(output_table)] # for (i in seq_along(output_table)) { # attr(output_table[[i]], "original_column_name") <- colnames(output_table)[i] # } for(i in 1:ncol(output_table)){ # only looks at output_dictionary with same routine name routine_dictionary <- output_table_dictionary[output_table_dictionary$routine_name == routine_name,] if (names(output_table)[i] %in% routine_dictionary$column_name){ # if str is double then it is rounded to value in dictionary which_routine_dictionary_row <- which(routine_dictionary$column_name[routine_dictionary$routine_name == routine_name] == names(output_table)[i]) precision_to_use <- routine_dictionary$precision[which_routine_dictionary_row] if (is.double(output_table[,i])) { output_table[,i] <- round(output_table[,i,drop=TRUE], digits = precision_to_use) } else if (nrow(as.data.frame(output_table[,i])) > 1){ output_table <- as_tibble(output_table) if (is.numeric(output_table[[i]])) { output_table[[i]] <- round(output_table[[i]], digits = precision_to_use) } } which_routine_dictionary_row <- which(routine_dictionary$column_name == names(output_table)[i]) # checks if output column is labeled as percent is_percentage <- tolower(routine_dictionary$is_percentage[which_routine_dictionary_row]) is_percentage <- ifelse(is.na(is_percentage), "no", is_percentage) if (is_percentage == "yes") { output_table[,i] <- percent(output_table[,i,drop=TRUE], precision_to_use) } if (is_percentage == "maybe") { col_to_check <- routine_dictionary$percent_determiner[which_routine_dictionary_row] if (col_to_check %in% colnames(output_table)) { for (row_index in seq_len(nrow(output_table))) { if ((!is.na(output_table[[col_to_check]][row_index])) & (output_table[[col_to_check]][row_index] != "")) { output_table[[i]][row_index] <- percent(as.numeric(output_table[[i]][row_index]), precision_to_use) } } } } } } most_recent_output_table <<- output_table set_action_button() modal_out <- modalDialog(size = "l", DT::renderDT({ DT::datatable( data = output_table, colnames = colnames(rename(output_table, column_lookup)), escape = FALSE, extensions = "Scroller", class = "compact", selection = 'none', options = list( dom = "t", ordering = FALSE, scrollX = TRUE, #scrollY = 250, scrollCollapse = TRUE, scroller = TRUE ) ) %>% DT::formatStyle(columns = column_dictionary[column_dictionary$is_emphasized == "Yes" & column_dictionary$column_name %in% colnames(output_table),"column_name"], fontWeight = 'bold') }), HTML(ifelse(is.null(footer_value), "", footer_value)), conditionalPanel( condition = "output.report_remove_button == true", br(), fluidRow ( align = "right", actionButton("remove_from_report", "Remove"), modalButton("Close") ) ), conditionalPanel( condition = "output.report_add_button == true", br(), fluidRow ( align = "right", actionButton("add_to_report", "Add"), modalButton("Close") ) ), footer = NULL ) } return(modal_out) }) } set_action_button <- function() { type <- types$type[which(types$type_label == routine_label)] report_rv$report_remove_button <- FALSE report_rv$report_add_button <- TRUE # searches through the list of analysis methods and finds which matches the submitted param_list # if found, add and remove buttons are switched if (length(analysis_store[[type]]) > 0) { for (i in 1:length(analysis_store[[type]])) { if (length(analysis_store[[type]][[i]]) > 0) { if (identical(analysis_store[[type]][[i]][["param_list"]], param_list) == TRUE) { report_rv$report_remove_button <- TRUE report_rv$report_add_button <- FALSE break } } } } } observeEvent(input$add_to_report, { report_rv$report_add_button <- FALSE report_rv$report_remove_button <- TRUE type <- types$type[which(types$type_label == routine_label)] new_index <- length(analysis_store[[type]])+1 parameters <- inner_join(parameters, parameters_html_crosswalk, by = c("type", "routine_name", "parameter")) input_vars <- parameters[parameters$parameter_label == "Input Variable",] input_vars <- input_vars[which(input_vars$routine_name == routine_name),] # primary key input_vars <- input_vars[which(input_vars$type == as.integer(type)),] variable <- '' for (i in 1:nrow(input_vars)) { if (nrow(input_vars) > 1 && i != nrow(input_vars)){ variable <- paste0(variable, paste(input[[input_vars$html_id[i]]], collapse = ", "), ", ") } else { variable <- paste0(variable, paste(input[[input_vars$html_id[i]]], collapse = ", ")) } } analysis_store[[type]][[new_index]] <<- list( "param_list" = param_list, "output" = most_recent_output_table, "time" = Sys.time(), "type" = type, "title" = paste0(types[types$type == type, "type_label"], " (", variable, ")"), "export" = TRUE, "routine" = routine_name, "footer_value" = footer_value ) df <- get_report() output$output_report_df <- DT::renderDataTable({render_data_report(df)}) }) observeEvent(input$remove_from_report, { report_rv$report_remove_button <- FALSE report_rv$report_add_button <- TRUE # types comes from a CSV currently and won't work at the moment type <- types$type[which(types$type_label == routine_label)] for (j in 1:length(analysis_store[[type]])) { if (length(analysis_store[[type]][[j]]) > 0) { if (identical(analysis_store[[type]][[j]][["param_list"]], param_list) == TRUE) { analysis_store[[type]][[j]] <<- NULL break } } } df <- get_report() output$output_report_df <- DT::renderDataTable({render_data_report(df)}) })
weclcome_md_file <- system.file(package = "idcnrba", "resources/App-Guide-for-Welcome-Page.md") welcome_md <- readLines(weclcome_md_file) %>% paste(collapse = "\n") welcome_html <- markdown::renderMarkdown(text = welcome_md) cat(welcome_html)
fileInput( inputId = "input_file", label = "Choose File", multiple = TRUE, accept = c(".csv",".xlsx",".sas7bdat",".sav") ) DT::DTOutput("output_files_df") global_values$file_metadata <- data.frame( "Filename" = character(), "Rows" = character(), "Columns" = character(), "Column Names" = character(), check.names = FALSE ) global_values$repaired_names <- list() observeEvent(input$input_file, { for(i in 1:nrow(input$input_file)) { base_filename <- basename(input$input_file[i, "name"]) full_filename <- input$input_file[i, "datapath"] if(grepl("\\.csv$", base_filename)) { new_data <- readr::read_csv(full_filename, name_repair = "minimal") } else if(grepl("\\.xlsx$", base_filename)) { new_data <- openxlsx::read.xlsx(full_filename, check.names = FALSE) } else if(grepl("\\.sas7bdat$", base_filename)) { new_data <- haven::read_sas(full_filename, .name_repair = "minimal") } else if(grepl("\\.sav$", base_filename)) { new_data <- haven::read_sav(full_filename, .name_repair = "minimal") } column_names <- names(new_data) column_names_repaired <- make.names(column_names) for(column_idx in 1:length(column_names)) { column_name <- column_names[column_idx] r_allowed_name <- column_names_repaired[column_idx] if(column_name != r_allowed_name) { global_values$repaired_names[[base_filename]][[r_allowed_name]]$repaired_from = column_name global_values$repaired_names[[base_filename]][[r_allowed_name]]$repaired_to = r_allowed_name names(new_data)[names(new_data) == column_name] <- r_allowed_name } } global_values[[base_filename]] <- new_data global_values$file_metadata <- rbind( global_values$file_metadata, data.frame( "Filename" = base_filename, "Rows" = nrow(new_data), "Columns" = ncol(new_data), "Column Names" = paste(names(new_data), collapse = ", "), check.names = FALSE ) ) } output$output_files_df <- DT::renderDT({ DT::datatable( data = global_values$file_metadata, class = "compact cell-border hover", rownames = F, escape = FALSE, selection = list(mode = "single", selected = nrow(global_values$file_metadata)), options = list( dom = "", columnDefs = list(list(className = 'dt-left', targets = '_all')) ) ) }) }, ignoreInit = TRUE)
DT::DTOutput("output_file_display") #click_input <- reactive({list(input$output_files_df_cell_clicked, input$input_file)}) observeEvent({input$output_files_df_cell_clicked; input$input_file}, { if(length(input$output_files_df_cell_clicked) == 0){ if(nrow(global_values$file_metadata) <= 0){ return(NULL) } clicked_row <- nrow(global_values$file_metadata) } else { clicked_row <- input$output_files_df_cell_clicked$row } file_name <- global_values$file_metadata$Filename[clicked_row] global_values$selected_data <- global_values[[file_name]] output$output_file_display <- DT::renderDT({ DT::datatable( data = global_values$selected_data, class = "compact cell-border", selection = "none", rownames = FALSE, escape = TRUE, style = "default", options = list( dom = "t", pagingType = "simple", headerCallback = htmlwidgets::JS( "function(thead, data, start, end, display) { $('.dataTables_scrollBody').each(function() { $(this).css('max-height',''); }); }") ) ) }) }, ignoreInit = TRUE)
# Using Shinyjs to enable/disable for fields useShinyjs(rmd = T) disabled(radioButtons( inputId = "data_collection_method", label = "Select the option which best describes the way in which the data were collected:", choices = c("Attempted Census", "Survey Sample"), inline = T, width = "95%" )) hr()# margin-left: 1in; margin-right: 1in;") disabled(selectizeInput( inputId = "response_eligibility_variable", label = "Select the variable in your dataset that indicates each individual's eligibility/response status:", choices = NULL, multiple = FALSE, selected = "", width = "95%" )) div(id = "options-label-1", h5("For each category of response and eligibility status, select the appropriate value. These fields cannot be blank.", style = "font-family: 'Calibri', sans-serif;")) fluidRow( column(width = 6, disabled(selectizeInput( inputId = "eligible_respondents", label = "Eligible Respondents", choices = NULL )), disabled(selectizeInput( inputId = "eligible_nonrespondents", label = "Eligible Nonrespondents", choices = NULL )) ), column(width = 6, disabled(selectizeInput( inputId = "known_ineligible", label = "Cases known to be ineligible", choices = NULL )), disabled(selectizeInput( inputId = "unknown_ineligible", label = "Cases whose eligibility status is unknown", choices = NULL )) ) ) fluidRow( column(width = 12, div(id = "group_nonrespondents_div", disabled(radioButtons( input = "group_nonrespondents", label = "Should cases with unknown eligibility be grouped with nonrespondents for all analysis types other than response rates?", choices = c("Yes", "No"), selected = "No", width = "95%", inline = TRUE )) ) ) ) hr() disabled(selectizeInput( inputId = "population_size_variables", label = "Select the variables in your dataset, if any, giving the population size. Use one variable for each stage of sampling.", multiple = TRUE, choices = NULL, width = "95%" )) hidden(fluidRow( column(width = 6, disabled(radioButtons( input = "replicate_weights", label = "Does the data include replicate weights?", choices = c("Yes", "No"), selected = "No", width = "95%", inline = TRUE )) ), column(width = 6, hidden(checkboxInput( inputId = 'combined_weights', label = "Do the replicate weights already include sampling weights?", value = TRUE, width = "95%" )) ) )) hidden(selectizeInput( inputId = "replicate_weight_variables", label = "Select the data columns containing replicate weights", multiple = TRUE, choices = NULL, width = "95%" )) fluidRow( column(width = 6, hidden(selectInput( inputId = "replicate_weight_method", label = "Please select the replication method used to create these weights", choices = c("BRR", "Fay", "JK1","JKn","bootstrap", "ACS","successive-difference","JK2","other"), width = "95%" )) ), column(width = 6, hidden(textInput( inputId = "rho", label = "Rho shrinkage factor", value = "", width = "95%" )) ) ) fluidRow( column(width = 6, hidden(textInput( inputId = 'scales', label = "scales", value = "", width = "95%" )) ), column(width = 6, hidden(textInput( inputId = 'rscales', label = "rscales", value = "", width = "95%" )) ) ) div( id = "strata_cluster_pop_div", hr(), disabled(selectizeInput( inputId = "sampling_weight_variable", label = "Select the variable in your dataset, if any, that indicates the sampling weight for each case.", choices = NULL, multiple = FALSE, width = "95%" )), disabled(selectizeInput( inputId = "strata_variables", label = "Select the variables in your dataset, if any, that indicate the stratum to which each case belongs.", multiple = TRUE, choices = NULL, width = "95%" )), div(id = "cluster_label", h5("Select the variables in your dataset, if any, representing the clusters to which each case belongs." , style = "font-family: 'Calibri', sans-serif;")), fluidRow( column(width = 6, disabled(selectizeInput( inputId = "psu_cluster_variables", label = "First Stage Cluster (PSU)", multiple = TRUE, choices = NULL )) ), column(width = 6, disabled(selectizeInput( inputId = "ssu_cluster_variables", label = "Second Stage Cluster (SSU)", multiple = TRUE, choices = NULL )) ) ) ) actionButton("proceed_to_analysis", label = "Proceed to Analysis", class="btn btn-default btn-sm" ) observeEvent(input$proceed_to_analysis, { proceed_errors <<- "" # counts errors and determines whether or not error checks renders modal error_counter <<- 0 for (i in 1:nrow(setup_module_checks[setup_module_checks$is_enabled == 1,])) { result <- regmatches(setup_module_checks$error_message[i], gregexpr("\\[\\$(.*?)\\]", setup_module_checks$error_message[i])) result <- unique(result[[1]]) # setup check 13 doesn't have a variable name and I'm out of ideas (see error function in tryCatch for more details) # result <- ifelse(setup_module_checks$query_id[i] != 13, gsub("\\[\\$|\\]", "", result), "ssu_cluster_variables") if (setup_module_checks$query_id[i] != 13){ result <- gsub("\\[\\$|\\]", "", result) } else{ result <- "ssu_cluster_variables" } tryCatch({ # if the query returns true, then there is an error on the setup page if (eval(parse(text = setup_module_checks$setup_query_code[i]))) { # if result isn't an empty string and you can evaluate input$[result] replace the error message variable result was pulled from with the input value. This is here because some error messages (checks 1-6) don't have variables to pull from if (!any(is.na(result)) & length(result) > 0){ for (j in 1:length(result)) { setup_module_checks$error_message[i] <<- gsub(paste0("\\[\\$",result[j],"\\]"), paste(eval(parse(text = paste0("input$",result[j]))), collapse = ", "), setup_module_checks$error_message[i]) } } proceed_errors <<- paste0(proceed_errors, "- ", setup_module_checks$error_message[i], "<br><br>") error_counter <<- error_counter + 1 } }, error = function(err){ if (length(result) > 0) { for (j in 1:length(result)) { setup_module_checks$error_message[i] <<- gsub(paste0("\\[\\$",result[j],"\\]"), "NULL", setup_module_checks$error_message[i]) } } # check 13 is looking to see if psu_cluster_variables is set or not. Since the input isn't set, the query returns an error. Since we don't want to write error messages for every variable that isn't set, I've hard coded this until a better solution is found proceed_errors <<- ifelse((setup_module_checks$query_id[i] == 13 & isTruthy(input$ssu_cluster_variables)), paste0(proceed_errors, "- ", setup_module_checks$error_message[i], "<br><br>"), proceed_errors) error_counter <<- error_counter + 1 }) } cat(paste0("\nerrors: ", proceed_errors)) if (error_counter > 0 & proceed_errors != "") { output$setup_errors <- showModal(renderUI(modalDialog( HTML(paste0("There are one or more errors in the options selected in the Setup module. <br><br>",proceed_errors))) )) shinyjs::runjs(paste0('window.location.href = "#section-setup";')) } else { shinyjs::runjs(paste0('window.location.href = "#section-analysis";')) } }, ignoreInit = TRUE) # Update inputs that use variable names based on selected data file #click_input <- reactive({list(input$output_files_df_cell_clicked, input$input_file)}) observeEvent({input$output_files_df_cell_clicked; input$input_file}, { enable("data_collection_method") enable("response_eligibility_variable") enable("replicate_weights") enable("strata_variables") enable("psu_cluster_variables") enable("ssu_cluster_variables") enable("sampling_weight_variable") enable("population_size_variables") variable_names <- colnames(global_values$selected_data) updateSelectizeInput(inputId = "replicate_weight_variables", choices = variable_names) updateSelectizeInput(inputId = "response_eligibility_variable", choices = variable_names, selected = "") updateSelectizeInput( inputId = "strata_variables", choices = variable_names, options = list(placeholder = '[No Strata Variables]') ) updateSelectizeInput( inputId = "psu_cluster_variables", choices = variable_names, options = list(placeholder = '[No Cluster Variables]'), ) updateSelectizeInput( inputId = "ssu_cluster_variables", choices = variable_names, options = list(placeholder = '[No Cluster Variables]') ) updateSelectInput( inputId = "sampling_weight_variable", choices = c("[No Weights]", variable_names), selected = "[No Weights]" ) updateSelectInput( inputId = "population_size_variables", choices = c("[No Population Size Variables]" = "", variable_names) ) }, ignoreInit = TRUE) # Update inputs that use variables values based on selected response eligibility variable observeEvent(input$response_eligibility_variable, { if (length(input$response_eligibility_variable) > 0) { enable("eligible_respondents") enable("eligible_nonrespondents") enable("known_ineligible") enable("unknown_ineligible") } variable_values <- unique(global_values$selected_data[[input$response_eligibility_variable]]) cat(length(variable_values)) # Note each DOES NOT APPLY value has to be a unique value for response rate calculations updateSelectizeInput( inputId = "eligible_respondents", options = list(onInitialize = I('function() { this.setValue(""); }')), choices = c(variable_values, "[DOES NOT APPLY]" = "does_not_apply_1")) updateSelectizeInput( inputId = "eligible_nonrespondents", options = list(onInitialize = I('function() { this.setValue(""); }')), choices = c(variable_values, "[DOES NOT APPLY]" = "does_not_apply_2")) updateSelectizeInput( inputId = "known_ineligible", options = list(onInitialize = I('function() { this.setValue(""); }')), choices = c(variable_values, "[DOES NOT APPLY]" = "does_not_apply_3")) updateSelectizeInput( inputId = "unknown_ineligible", options = list(onInitialize = I('function() { this.setValue(""); }')), choices = c(variable_values, "[DOES NOT APPLY]" = "does_not_apply_4")) if (input$data_collection_method == "Attempted Census") { hide("strata_cluster_pop_div") } else { show("strata_cluster_pop_div") } }, ignoreInit = TRUE) observeEvent(input$unknown_ineligible, { global_values$selected_data[, "analysis_response_eligibility_variable"] <- global_values$selected_data[, input$response_eligibility_variable] if(input$unknown_ineligible != "does_not_apply_4") { enable("group_nonrespondents") show("group_nonrespondents_div") # set default variables global_values$analysis_ue_category <- input$unknown_ineligible } else { enable("group_nonrespondents") hide("group_nonrespondents_div") } }, ignoreInit = TRUE) observeEvent(input$group_nonrespondents, { if(input$group_nonrespondents == "Yes") { global_values$analysis_ue_category <- "does_not_apply_4" global_values$selected_data[, "analysis_response_eligibility_variable"] <- global_values$selected_data[, input$response_eligibility_variable] global_values$selected_data[which(global_values$selected_data[, "analysis_response_eligibility_variable"] == input$unknown_ineligible), "analysis_response_eligibility_variable"] <- input$eligible_nonrespondents } else { global_values$analysis_ue_category <- input$unknown_ineligible global_values$selected_data[, "analysis_response_eligibility_variable"] <- global_values$selected_data[, input$response_eligibility_variable] } }, ignoreInit = TRUE) observeEvent(input$replicate_weights, { if (input$replicate_weights == "Yes") { show("combined_weights") show("replicate_weight_method") show("scales") show("rscales") show("replicate_weight_variables") show("rho") if (input$replicate_weight_method == "BRR") { enable("rho") } else { disable("rho") } hide("strata_cluster_pop_div") } else { hide("combined_weights") hide("replicate_weight_variables") hide("replicate_weight_method") hide("scales") hide("rscales") hide("rho") if(input$data_collection_method != "Attempted Census"){ show("strata_cluster_pop_div") } } }, ignoreInit = TRUE) observeEvent(input$replicate_weight_method, { if (input$replicate_weight_method == "BRR") { enable("rho") } else { disable("rho") } }) observeEvent(input$data_collection_method, { if (input$data_collection_method == "Attempted Census") { hide("strata_cluster_pop_div") } else { show("strata_cluster_pop_div") } }) #nonrespondent_census_list <- reactive({list(input$data_collection_method, input$eligible_nonrespondents, input$unknown_ineligible, input$analysis_adjust_weights)}) observeEvent({input$data_collection_method; input$eligible_nonrespondents; input$unknown_ineligible}, { if (input$data_collection_method == "Attempted Census") { if (input$eligible_nonrespondents != "does_not_apply_2") { global_values$is_census_data_with_nonrespondents <- TRUE hide("population_size_variables") } else if (input$unknown_ineligible != "does_not_apply_4") { global_values$is_census_data_with_nonrespondents <- TRUE hide("population_size_variables") } else { global_values$is_census_data_with_nonrespondents <- FALSE show("population_size_variables") } } else { global_values$is_census_data_with_nonrespondents <- FALSE show("population_size_variables") } }, ignoreInit = TRUE) # set respondents_only value if both eligible nonrespondent and # unknown ineligible are both [Does Not Apply] observeEvent({input$eligible_nonrespondents; input$unknown_ineligible}, { if (input$eligible_nonrespondents == "does_not_apply_2" & input$unknown_ineligible == "does_not_apply_4") { global_values$respondents_only <- TRUE } else { global_values$respondents_only <- FALSE } })
h3(strong("What are our response rates and do they differ across subgroups?")) analysisButton( inputId = "analysis_response_rates", label = types$type_label[1], description = types$type_description[1], info_link = system.file("shiny/analysis-guides/response-rates-analysis_shiny.html", package = 'nrba') ) analysisButton( inputId = "analysis_subpop_differ", label = types$type_label[2], description = types$type_description[2] ) analysisButton( inputId = "analysis_predict_response", label = types$type_label[3], description = types$type_description[3] ) h3(strong("Are some subgroups in the population overrepresented or underrepresented in our respondent data?")) analysisButton( inputId = "analysis_compare_sample", label = types$type_label[4], description = types$type_description[4] ) analysisButton( inputId = "analysis_compare_external", label = types$type_label[5], description = types$type_description[5] ) h3(strong("How do survey outcomes differ across subgroups?")) analysisButton( inputId = "analysis_across_subgroups", label = types$type_label[6], description = types$type_description[6] ) analysisButton( inputId = "analysis_aux_predictive", label = types$type_label[7], description = types$type_description[7] ) analysisButton( inputId = "analysis_cumulative_estimates", label = types$type_label[8], description = types$type_description[8] ) h3(strong("Can statistical adjustments reduce nonresponse bias?")) analysisButton( inputId = "analysis_adjust_weights", label = types$type_label[9], description = types$type_description[9] )
observeEvent(input$analysis_response_rates, { global_values$last_analysis_clicked <- "analysis_response_rates" }, ignoreInit = TRUE) observeEvent(input$analysis_response_rates, { output$analysis_config <- renderUI({ div( fluidRow( column(width = 6, selectizeInput( inputId = "analysis_response_rates_group", label = "Choose grouping variable(s):", multiple = TRUE, choices = colnames(global_values$selected_data), options = list(placeholder = '[None]') ) ), column(width = 6, selectizeInput( inputId = "rr_formula", label = "Choose the response rate formula:", selected = "RR3", multiple = FALSE, choices = c("RR1" = "RR1", "RR3 (recommended)" = "RR3", "RR5" = "RR5") ) ) ), fluidRow( column(width = 6, selectizeInput( inputId = "elig_method", label = "Choose method for estimating eligibility rate for unknown eligibility cases:", multiple = FALSE, choices = c("CASRO overall","CASRO subgroup (recommended)","specified"), selected = "CASRO subgroup (recommended)" ) ), column(width = 6, textInput( inputId = "e_specified", label = "Estimated eligibility rate:" ) ) ), actionButton("analysis_response_rates_submit", "Submit"), hr() ) }) }) observeEvent(input$rr_formula , { if (input$rr_formula == "RR3") { enable("elig_method") } else { disable("elig_method") updateTextInput(inputId = "e_specified", value = "") disable("e_specified") } }) observeEvent(input$elig_method , { if (input$elig_method == "specified") { enable("e_specified") } else { updateTextInput(inputId = "e_specified", value = "") disable("e_specified") } }) observeEvent(input$analysis_response_rates_submit, { routine_name <<- "calculate_response_rates" routine_label <<- routines[which(routines$routine_name == routine_name), "routine_label"] withProgress(message = "Running Analysis...", { n = 1/3 output_table <- tryCatch({ if (global_values$respondents_only & is.null(input$analysis_response_rates_group)) { stop("Response rates by subgroup cannot be calculated since the dataset does not contain any eligible nonrespondents or cases with unknown eligibility.") } if (global_values$respondents_only & input$data_collection_method == "Survey Sample") { stop("Response rates cannot be calculated for a survey sample when the dataset does not contain any eligible nonrespondents or cases with unknown eligibility.") } if (global_values$respondents_only & input$data_collection_method == "Attempted Census" & is.null(input$population_size_variables)) { stop("Can only calculate an overall response rate for an attempted census if the data contain eligible respondents or cases with unknown eligibility, or if a population size was specified during setup.") } if (input$sampling_weight_variable == "[No Weights]") { sampling_weight_variable_input <- NULL } else { sampling_weight_variable_input <- input$sampling_weight_variable } incProgress(n) if (input$elig_method == "CASRO subgroup (recommended)") { elig_method_input <- "CASRO-subgroup" } else if (input$elig_method == "CASRO overall") { elig_method_input <- "CASRO-overall" } else { elig_method_input <- input$elig_method } data <-group_by(global_values$selected_data, across(input$analysis_response_rates_group)) incProgress(n) param_list <<- list( "data" = data, "status" = input$response_eligibility_variable, "status_codes" = c( "ER" = input$eligible_respondents, "EN" = input$eligible_nonrespondents, "IE" = input$known_ineligible, "UE" = input$unknown_ineligible ), "weights" = sampling_weight_variable_input, "rr_formula" = input$rr_formula, "elig_method" = elig_method_input, "e" = as_numeric_input(input$e_specified) ) footer_value <<- NULL do.call(calculate_response_rates, param_list) }, error = function(e) { return(e) }) incProgress(n) }) output$analysis_output <- render_analysis_output(output_table) })
observeEvent(input$analysis_subpop_differ, { global_values$last_analysis_clicked <- "analysis_subpop_differ" }, ignoreInit = TRUE) observeEvent(input$analysis_subpop_differ, { output$analysis_config <- renderUI({ tagList( selectizeInput( inputId = "chisq_aux_variables", label = "Choose grouping variable(s):", multiple = TRUE, choices = colnames(global_values$selected_data), options = list(placeholder = '[None]') ), actionButton("analysis_subpop_differ_submit", "Submit") ) }) }) observeEvent(input$analysis_subpop_differ_submit, { routine_name <<- "chisq_test_ind_response" routine_label <<- routines[which(routines$routine_name == routine_name), "routine_label"] withProgress(message = "Running Analysis...", { n = 1/3 output_table <- tryCatch({ if (global_values$respondents_only){ stop("The dataset does not contain any eligible nonrespondents or cases with unknown eligibility.") } survey_design <- get_survey_design_object( data = global_values$selected_data, input = input ) incProgress(n) status_codes <- c( "ER" = input$eligible_respondents, "EN" = input$eligible_nonrespondents, "IE" = input$known_ineligible, "UE" = global_values$analysis_ue_category ) incProgress(n) param_list <<- list( "survey_design" = survey_design, "status" = "analysis_response_eligibility_variable", "status_codes" = status_codes, "aux_vars" = input$chisq_aux_variables) footer_value <<- NULL do.call(chisq_test_ind_response, param_list) }, error = function(e) { return(e) }) incProgress(n) }) output$analysis_output <- render_analysis_output(output_table) })
observeEvent(input$analysis_compare_external, { global_values$last_analysis_clicked <- "analysis_compare_external" }, ignoreInit = TRUE) observeEvent(input$analysis_compare_external, { output$analysis_config <- renderUI({ tagList( selectizeInput( inputId = "t3_y_var", label = "Choose a grouping variable:", multiple = FALSE, choices = colnames(global_values$selected_data), width = "95%", options = list( placeholder = '[None]', onInitialize = I('function() { this.setValue(""); }')) ), fluidRow( column(width = 7, radioButtons( input = "t3_y_var_categorical", label = "Is the grouping variable categorical?", choices = c("Yes", "No"), selected = "No", width = "95%", inline = TRUE ) )), uiOutput("external_benchmark_input"), radioButtons( inputId = "t3_drop_missing_y_var", label = "Drop cases with missing values for the grouping variable?", choices = c("Yes", "No"), selected = "No", width = "95%", inline = TRUE ), fluidRow( column(width = 5, radioButtons( input = "t3_t_or_chisq_test", label = "Choose the test:", choices = c("t test", "Chi-squared test"), selected = "t test", width = "95%", inline = TRUE ) )), numericInput( inputId = "t3_null_difference", label = "Enter the value of the hypothesized difference between the estimate and the benchmark:", value = 0, width = "95%" ), selectizeInput( inputId = "t3_alternative", label = "Choose alternative hypothesis for this test:", multiple = FALSE, choices = c( "Actual difference is unequal to hypothesized difference." = "unequal", "Actual difference is less than hypothesized difference." = "less", "Actual difference is greater than hypothesized difference." = "greater" ), width = "95%" ), hide(textInput( inputId = "t3_degrees_of_freedom", label = "Specify degrees of freedom:", value = "", width = "95%" )), actionButton("analysis_compare_external_submit", "Submit") ) }) }) observeEvent(input$t3_y_var_categorical, { if (input$t3_y_var_categorical == "Yes") { enable("t3_t_or_chisq_test") } else { updateRadioButtons(inputId = "t3_t_or_chisq_test", selected = "t test") disable("t3_t_or_chisq_test") } }) observeEvent(input$t3_t_or_chisq_test, { if (input$t3_t_or_chisq_test == "Chi-squared test") { hide("t3_null_difference") hide("t3_alternative") } else { show("t3_null_difference") show("t3_alternative") } }) observeEvent({input$t3_y_var; input$t3_y_var_categorical}, { if (input$t3_y_var_categorical == "Yes" & nchar(input$t3_y_var) > 0) { y_var_values <- sort(unique(global_values$selected_data[[input$t3_y_var]])) external_benchmark_table_edited <<- tibble( "{input$t3_y_var}" := y_var_values[!is.na(y_var_values)] ) %>% mutate(Percentages = NA_real_) %>% mutate(`Standard Error` = NA_real_) output$external_benchmark_table <- DT::renderDataTable({ DT::datatable( data = external_benchmark_table_edited, rownames = FALSE, extensions = 'KeyTable', caption = tags$caption( 'Enter values from external data (double-click cells in yellow to edit):', style = 'caption-side: top;text-align:center;color:black;' ), class = "compact cell-border", selection = "none", editable = list( target = 'cell', enable = list(columns = 1:2), disable = list(columns = 0) ), options = list( dom = "t", ordering = FALSE, keys = TRUE, autoWidth = TRUE, columnDefs = list( list(width = '200px', targets = 0), list(width = '20px', targets = 1:2) ) ) ) %>% DT::formatStyle( columns = 1, fontWeight = "bold" ) %>% DT::formatStyle( columns = 2:3, backgroundColor = "lightYellow", fontStyle = "italic", fontSize = "18px", cursor = "cell" ) }) output$external_benchmark_input <- renderUI({ fluidRow(column(align = "center", width = 12, DT::DTOutput("external_benchmark_table"))) }) } else { output$external_benchmark_input <- renderUI({ numericInput( inputId = "external_benchmark_value", label = "Enter value from external data:", value = 0 ) }) } }) # Listen to whether table cells have been updated and update accordingly observeEvent(input$external_benchmark_table_cell_edit, { external_benchmark_table_edited[ input$external_benchmark_table_cell_edit$row, input$external_benchmark_table_cell_edit$col + 1 ] <<- as.double(input$external_benchmark_table_cell_edit$value) }) observeEvent(input$analysis_compare_external_submit, { withProgress(message = "Running Analysis...", { n <- 1/4 output_table <- tryCatch({ if (global_values$respondents_only){ stop("The dataset does not contain any eligible nonrespondents or cases with unknown eligibility.") } if (input$t3_t_or_chisq_test == "t test") { routine_name <<- "t_test_vs_external_estimate" routine_label <<- routines[which(routines$routine_name == routine_name), "routine_label"] } else { routine_name <<- "chisq_test_vs_external_estimate" routine_label <<- routines[which(routines$routine_name == routine_name), "routine_label"] } if (exists("external_benchmark_table_edited")) { if (any(external_benchmark_table_edited$Percentages < 0)) { stop("Percentages for external data cannot be below 0") } # checks if values are entered as 0.5 or 50%, assumes no one would type 1.3 meaning 130% if (all(external_benchmark_table_edited$Percentages <= 1)) { if (sum(external_benchmark_table_edited$Percentages) <= 0.99 | sum(external_benchmark_table_edited$Percentages) >= 1.01) { stop("Percentages for external data must add up to 100%") } } else { if (sum(external_benchmark_table_edited$Percentages) <= 99 | sum(external_benchmark_table_edited$Percentages) >= 101) { stop("Percentages for external data must add up to 100%") } } } survey_design <- get_survey_design_object( data = global_values$selected_data, input = input ) resp_design <- subset( x = survey_design, get(input$response_eligibility_variable) == input$eligible_respondents ) incProgress(n) if (input$t3_y_var_categorical == "Yes") { # Transform edited table into named vector external_estimates <- external_benchmark_table_edited %>% tibble::column_to_rownames(input$t3_y_var) %>% select(Percentages) %>% t() %>% drop() external_standard_errors <- external_benchmark_table_edited %>% tibble::column_to_rownames(input$t3_y_var) %>% select(`Standard Error`) %>% t() %>% drop() if (anyNA(external_standard_errors)) external_standard_errors <- NULL } else { external_estimates <- input$external_benchmark_value external_standard_errors <- NULL } incProgress(n) degrees_of_freedom <- ifelse( is.null(as_numeric_input(input$t3_degrees_of_freedom)), survey::degf(resp_design) - 1, as_numeric_input(input$t3_degrees_of_freedom) ) incProgress(n) if (input$t3_t_or_chisq_test == "t test") { param_list <<- list( "survey_design" = resp_design, "y_var" = input$t3_y_var, "ext_ests" = external_estimates, "ext_std_errors" = external_standard_errors, "na.rm" = switch(input$t3_drop_missing_y_var, "Yes" = TRUE, "No" = FALSE), "null_difference" = input$t3_null_difference, "alternative" = input$t3_alternative, "degrees_of_freedom" = degrees_of_freedom) footer_value <<- NULL do.call(t_test_vs_external_estimate, param_list) } else { param_list <<- list( "survey_design" = resp_design, "y_var" = input$t3_y_var, "ext_ests" = external_estimates, "na.rm" = switch(input$t3_drop_missing_y_var, "Yes" = TRUE, "No" = FALSE) ) footer_value <<- NULL do.call(chisq_test_vs_external_estimate, param_list) } }, error = function(e) { return(e) }) incProgress(n) }) output$analysis_output <- render_analysis_output(output_table) })
observeEvent(input$analysis_compare_sample, { global_values$last_analysis_clicked <- "analysis_compare_sample" }, ignoreInit = TRUE) observeEvent(input$analysis_compare_sample, { output$analysis_config <- renderUI({ tagList( selectizeInput( inputId = "t4_y_var", label = "Choose one or more grouping variable(s):", multiple = TRUE, choices = colnames(global_values$selected_data), width = "95%", options = list( placeholder = '[None]', onInitialize = I('function() { this.setValue(""); }')) ), fluidRow( column(width = 10, hide( radioButtons( input = "t4_t_full_or_elig", label = "Choose the comparison:", choices = c("Respondents vs. Respondents and Nonrespondents", "Respondents vs. All sampled cases (regardless of response or eligibility status)"), selected = "Respondents vs. Respondents and Nonrespondents", width = "95%", inline = FALSE ) ) ) ), numericInput( inputId = "t4_null_difference", label = "Enter the value of the hypothesized difference between the estimate and the full sample:", value = 0, width = "95%" ), selectizeInput( inputId = "t4_alternative", label = "Choose alternative hypothesis for this test:", multiple = FALSE, choices = c( "Actual difference is unequal to hypothesized difference." = "unequal", "Actual difference is less than hypothesized difference." = "less", "Actual difference is greater than hypothesized difference." = "greater" ), width = "95%" ), hide(textInput( inputId = "t4_degrees_of_freedom", label = "Specify degrees of freedom:", value = "", width = "95%" )), actionButton("t4_analysis_compare_sample_submit", "Submit") ) }) }) observeEvent(input$t4_analysis_compare_sample_submit, { withProgress(message = "Running Analysis...", { n <- 1/4 output_table <- tryCatch({ survey_design <- get_survey_design_object( data = global_values$selected_data, input = input ) incProgress(amount = n) degrees_of_freedom <- ifelse( is.null(as_numeric_input(input$t4_degrees_of_freedom)), survey::degf(survey_design) - 1, as_numeric_input(input$t4_degrees_of_freedom) ) status_codes <- c( "ER" = input$eligible_respondents, "EN" = input$eligible_nonrespondents, "IE" = input$known_ineligible, "UE" = global_values$analysis_ue_category ) incProgress(amount = n) if (is.null(input$t4_t_full_or_elig)) { t4_comparison <- "Respondents vs. Respondents and Nonrespondents" } else { t4_comparison <- input$t4_t_full_or_elig } incProgress(amount = n) if (t4_comparison == "Respondents vs. All sampled cases (regardless of response or eligibility status)") { routine_name <<- "t_test_resp_vs_full" routine_label <<- routines[which(routines$routine_name == routine_name), "routine_label"] param_list <<- list( "survey_design" = survey_design, "y_var" = input$t4_y_var, "status" = "analysis_response_eligibility_variable", "status_codes" = status_codes, "null_difference" = input$t4_null_difference, "alternative" = input$t4_alternative, "degrees_of_freedom" = degrees_of_freedom) footer_value <<- NULL do.call(t_test_resp_vs_full, param_list) } else { routine_name <<- "t_test_resp_vs_elig" routine_label <<- routines[which(routines$routine_name == routine_name), "routine_label"] param_list <<- list( "survey_design" = survey_design, "y_var" = input$t4_y_var, "status" = "analysis_response_eligibility_variable", "status_codes" = status_codes, "null_difference" = input$t4_null_difference, "alternative" = input$t4_alternative, "degrees_of_freedom" = degrees_of_freedom) footer_value <<- NULL do.call(t_test_resp_vs_elig, param_list) } }, error = function(e) { return(e) }) incProgress(amount = n) output$analysis_output <- render_analysis_output(output_table) }) })
# Using Shinyjs to enable/disable for fields useShinyjs(rmd = T) observeEvent(input$analysis_adjust_weights, { global_values$last_analysis_clicked <- "analysis_adjust_weights" }, ignoreInit = TRUE) observeEvent({input$analysis_adjust_weights; global_values$is_census_data_with_nonrespondents}, { variable_names <- colnames(global_values$selected_data) # T5 Analysis Updates updateSelectInput(inputId = "t5_raked_replicate_weight_variables", choices = variable_names) updateSelectInput(inputId = "t5_raking_group_vars", choices = variable_names) updateSelectInput(inputId = "t5_raking_benchmark_vars", choices = variable_names) updateSelectInput(inputId = "t5_wt_adj_comparison_vars", choices = variable_names) global_values$survey_design <- tryCatch({ get_survey_design_object( data = global_values$selected_data, input = input ) }, error = function(e) { return(e) }) if ("svyrep.design" %in% class(global_values$survey_design)) { # Create rep survey design call but do not evaluate yet # orig_rep_design_call <- substitute(global_values$survey_design) output$as_rep_design_controls <- NULL } else if ("survey.design" %in% class(global_values$survey_design)) { output$as_rep_design_controls <- renderUI({ tagList( { if (global_values$is_census_data_with_nonrespondents) { div(id = "t5_replicate_weight_method_div") } else { div(id = "t5_replicate_weight_method_div", selectInput( inputId = "t5_replicate_weight_method", label = paste( "For this analysis, replicate weights will be created.", "Select a type of replicate weight:" ), choices = c("Jackknife (JKn or JK1)","Bootstrap (Recommended)"), selected = "Bootstrap (Recommended)", width = "95%" ) ) } }, { if (global_values$is_census_data_with_nonrespondents) { div(id = "t5_n_replicates_div") } else { div(id = "t5_n_replicates_div", numericInput( inputId = "t5_n_replicates", label = "Select number of bootstrap replicates (500 or more):", value = pmin(500, 2 * degf(global_values$survey_design)), width = "95%" ) ) } } ) }) } else { output$as_rep_design_controls <- renderUI({ tags$h4(global_values$survey_design, style = "color: darkred;") }) } if (is.character(global_values$last_analysis_clicked)){ if (global_values$last_analysis_clicked == "analysis_adjust_weights"){ output$analysis_config <- renderUI({ tagList( uiOutput("as_rep_design_controls"), hidden(checkboxInput( inputId = "t5_raked_reps_included", label = "Are there raked replicate weights already included in the data?", width = "95%" )), #hr(), hidden(div(id = "t5_reps_exist_controls", selectizeInput( inputId = "t5_raked_replicate_weight_variables", label = "Select the data columns containing replicate weights", multiple = TRUE, choices = NULL, width = "95%" ), checkboxInput( inputId = 't5_raked_combined_weights', label = "Do the replicate weights already include sampling weights?", value = TRUE, width = "95%" ), fluidRow( column(width = 6, selectInput( inputId = "t5_raked_replicate_weight_method", label = "Select the replication method used to create these weights", choices = c("BRR", "Fay", "JK1","JKn","bootstrap", "ACS","successive-difference","JK2","other"), width = "95%" ) ), column(width = 6, textInput( inputId = "t5_raked_rho", label = "Rho shrinkage factor", value = "", width = "95%" ) ) ), fluidRow( column(width = 6, textInput( inputId = 't5_raked_scales', label = "scales", value = "", width = "95%" ) ), column(width = 6, textInput( inputId = 't5_raked_rscales', label = "rscales", value = "", width = "95%" ) ) ) )), div(id = "t5_reps_absent_controls", selectizeInput( inputId = "t5_raking_group_vars", label = "Choose grouping variables to use for raking", multiple = TRUE, choices = NULL, width = "95%", options = list( placeholder = '[None]') )), { if (global_values$is_census_data_with_nonrespondents){ div(id = "t5_raking_benchmarks") } else { div(id = "t5_raking_benchmarks", selectizeInput( inputId = "t5_raking_benchmark_vars", label = "Choose corresponding variables with values of benchmarks", multiple = TRUE, choices = NULL, width = "95%", options = list( placeholder = '[None]')) ) } }, #hr(), selectizeInput( inputId = "t5_wt_adj_comparison_vars", label = "Choose variables whose means should be compared before and after raking", multiple = TRUE, choices = NULL, width = "95%", options = list( placeholder = '[None]') ), #hr(), actionButton("t5_analysis_adjust_weights_submit", "Submit") ) }) } } }, ignoreInit = TRUE) observeEvent(input$t5_raked_reps_included, { if (input$t5_raked_reps_included) { show("t5_reps_exist_controls") hide("t5_reps_absent_controls") } else { hide("t5_reps_exist_controls") show("t5_reps_absent_controls") } }) observeEvent(input$t5_replicate_weight_method, { if (input$t5_replicate_weight_method == "Bootstrap (Recommended)") { enable("t5_n_replicates") } else if (input$t5_replicate_weight_method == "Jackknife (JKn or JK1)") { disable("t5_n_replicates") } }) observeEvent(input$t5_analysis_adjust_weights_submit, { routine_name <<- "t_test_of_weight_adjustment" routine_label <<- routines[which(routines$routine_name == routine_name), "routine_label"] withProgress(message = "Running Analysis...", { # n equals the subdivision of steps in this process used for incrementing the progress bar, here there are 5 steps so n = 1/5 n <- 1/5 output_table <- tryCatch({ # Create rep survey design calls but do not evaluate yet if (!global_values$is_census_data_with_nonrespondents) { if (input$t5_replicate_weight_method == "Bootstrap (Recommended)") { orig_rep_design <- as.svrepdesign( design = global_values$survey_design, type = "subbootstrap", replicates = input$t5_n_replicates ) } else if (input$t5_replicate_weight_method == "Jackknife (JKn or JK1)") { orig_rep_design <- as.svrepdesign( design = global_values$survey_design, type = "auto" ) } } else { orig_rep_design <- svrep::as_random_group_jackknife_design( design = global_values$survey_design, replicates = 50, adj_method = "variance-stratum-psus", scale_method = "variance-stratum-psus" ) orig_rep_design$type <- "other" } incProgress(amount = n) # Subset orig rep design to only include eligible respondents orig_resp_rep_design <- subset( x = orig_rep_design, get(input$response_eligibility_variable) == input$eligible_respondents ) incProgress(amount = n) if (input$t5_raked_reps_included) { raked_rep_design <- get_survey_design_object( data = global_values$selected_data, input = input, secondary_raked = TRUE ) raked_resp_rep_design <- subset( raked_rep_design, get(input$response_eligibility_variable) == input$eligible_respondents ) incProgress(amount = n) } else if (!global_values$is_census_data_with_nonrespondents) { raked_resp_rep_design <- rake_to_benchmarks( survey_design = orig_resp_rep_design, group_vars = input$t5_raking_group_vars, group_benchmark_vars = input$t5_raking_benchmark_vars ) incProgress(amount = n) } else if (global_values$is_census_data_with_nonrespondents) { # Produce population counts for each raking variable, excluding known ineligibles pop_data_for_counts <- orig_rep_design$variables |> subset( get(input$response_eligibility_variable) != input$known_ineligible ) incProgress(amount = n/3) benchmark_counts <- lapply(input$t5_raking_group_vars, function(var_name) { count_var_name <- paste0("RAKING_BENCHMARK_VAR_", var_name) count_df <- pop_data_for_counts |> dplyr::count(!!sym(var_name), name = count_var_name) #colnames(count_df) count_df #cat(paste0("\nCount_Df: ",str(count_df))) }) incProgress(amount = n/3) # Add population counts to the dataset used for the analysis names(benchmark_counts) <- input$t5_raking_group_vars for (raking_group_var_name in names(benchmark_counts)) { orig_resp_rep_design$variables <- dplyr::left_join( x = orig_resp_rep_design$variables, y = as.data.frame(benchmark_counts[[raking_group_var_name]]), by = raking_group_var_name ) } incProgress(amount = n/3) benchmark_vars <- paste0("RAKING_BENCHMARK_VAR_", input$t5_raking_group_vars) # Use the raking function raked_resp_rep_design <- rake_to_benchmarks( survey_design = orig_resp_rep_design, group_vars = input$t5_raking_group_vars, group_benchmark_vars = benchmark_vars ) } # t_test_of_weight_adjustment( # orig_design = orig_resp_rep_design, # updated_design = raked_resp_rep_design, # y_vars = wt_adj_comparison_vars # ) param_list <<- list( "orig_design" = orig_resp_rep_design, "updated_design" = raked_resp_rep_design, "y_vars" = input$t5_wt_adj_comparison_vars ) footer_value <<- sprintf( "The following variables were used to weight data from respondents: %s", paste(input$t5_raking_group_vars, collapse = ", ") ) incProgress(amount = n) do.call(t_test_of_weight_adjustment, param_list) }, error = function(e) { return(e) }) incProgress(amount = n) }) output$analysis_output <- render_analysis_output(output_table) })
observeEvent(input$analysis_predict_response, { global_values$last_analysis_clicked <- "analysis_predict_response" }, ignoreInit = TRUE) observeEvent(input$analysis_predict_response, { output$analysis_config <- renderUI({ tagList( fluidRow( column(width = 6, selectizeInput( inputId = "t6_numeric_predictors", label = "Select numeric predictor variables to use in the regression model:", multiple = TRUE, choices = colnames(global_values$selected_data), options = list(placeholder = "[None]"), width = "95%" ) ), column(width = 6, selectizeInput( inputId = "t6_categorical_predictors", label = "Select categorical predictor variables to use in the regression model:", multiple = TRUE, choices = colnames(global_values$selected_data), options = list(placeholder = "[None]"), width = "95%" ) ) ), selectizeInput( inputId = "t6_model_selection", label = "Choose which of the predictor variables selected above to include in the regression model:", multiple = FALSE, choices = c( "All of the variables listed above" = "main-effects", "A subset of the variables, chosen using stepwise model selection" = "stepwise" ), width = "95%" ), hidden(tags$div( id = "t6_selection_controls", numericInput( inputId = "t6_alpha_enter", label = "Maximum p-value for variable to enter model", value = 0.5, min = 0, max = 1 ), numericInput( inputId = "t6_alpha_remain", label = "Maximum p-value for variable to remain in model", value = 0.5, min = 0, max = 1 ), numericInput( inputId = "t6_max_iterations", label = "Maximum number of iterations for stepwise algorithm", value = 100, step = 1 ) )), actionButton("analysis_predict_response_submit", "Submit") ) }) }) observeEvent(input$t6_model_selection, { if (input$t6_model_selection == "stepwise") { show("t6_selection_controls") } else { hide("t6_selection_controls") } }) observeEvent(input$analysis_predict_response_submit, { routine_name <<- "predict_response_status_via_glm" routine_label <<- routines[which(routines$routine_name == routine_name), "routine_label"] withProgress(message = "Running Analysis...", { n = 1/5 output_table <- tryCatch({ if (global_values$respondents_only){ stop("The dataset does not contain any eligible nonrespondents or cases with unknown eligibility.") } survey_design <- get_survey_design_object( data = global_values$selected_data, input = input ) incProgress(n) status_codes <- c( "ER" = input$eligible_respondents, "EN" = input$eligible_nonrespondents, "IE" = input$known_ineligible, "UE" = global_values$analysis_ue_category ) selection_controls <- list( alpha_enter = input$t6_alpha_enter, alpha_remain = input$t6_alpha_remain, max_iterations = input$t6_max_iterations ) param_list <<- list( "survey_design" = survey_design, "status" = "analysis_response_eligibility_variable", "status_codes" = status_codes, "numeric_predictors" = input$t6_numeric_predictors, "categorical_predictors" = input$t6_categorical_predictors, "model_selection" = input$t6_model_selection, "selection_controls" = selection_controls ) incProgress(n) result <- do.call(predict_response_status_via_glm, param_list) incProgress(n) # If there are categorical predictors, produce a text string # describing the reference levels in the regression ref_levels_table <- attr(result, 'reference_levels') if (!is.null(ref_levels_table)) { ref_levels_string <- sprintf( '%s "%s"', ref_levels_table[['variable']], ref_levels_table[['variable_category']] ) |> paste(collapse = "; ") ref_levels_string <- paste0( "For categorical predictor variables, the following categories were used as reference levels for the regression: ", " ", ref_levels_string ) } else { ref_levels_string <- NULL } footer_value <<- ref_levels_string incProgress(n) # Return the result result }, error = function(e) { return(e) }) incProgress(n) }) output$analysis_output <- render_analysis_output(output_table) })
observeEvent(input$analysis_aux_predictive, { global_values$last_analysis_clicked <- "analysis_aux_predictive" }, ignoreInit = TRUE) observeEvent(input$analysis_aux_predictive, { output$analysis_config <- renderUI({ tagList( fluidRow( column(width = 6, selectizeInput( inputId = "t7_numeric_predictors", label = "Select numeric predictor variables to use in the regression model:", multiple = TRUE, choices = colnames(global_values$selected_data), options = list(placeholder = "[None]"), width = "95%" ) ), column(width = 6, selectizeInput( inputId = "t7_categorical_predictors", label = "Select categorical predictor variables to use in the regression model:", multiple = TRUE, choices = colnames(global_values$selected_data), options = list(placeholder = "[None]"), width = "95%" ) ) ), fluidRow( column(width = 6, selectizeInput( inputId = "t7_outcome_variable", label = "Select outcome variable.", multiple = FALSE, choices = colnames(global_values$selected_data), width = "95%", options = list( placeholder = '[None]', onInitialize = I('function() { this.setValue(""); }')) ), ), column(width = 6, selectizeInput( inputId = "t7_outcome_type", label = "Choose type of outcome variable.", multiple = FALSE, choices = c("Numeric variable" = "continuous", "Binary categorical variable" = "binary"), width = "95%" ) ) ), hidden(selectizeInput( inputId = "t7_outcome_to_predict", label = "Choose category to predict.", multiple = FALSE, choices = c(""), options = list(placeholder = "[None]"), width = "95%" )), selectizeInput( inputId = "t7_model_selection", label = "Choose which of the predictor variables selected above to include in the regression model:", multiple = FALSE, choices = c( "All of the variables listed above" = "main-effects", "A subset of the variables, chosen using stepwise model selection" = "stepwise" ), width = "95%" ), hidden(tags$div( id = "t7_selection_controls", numericInput( inputId = "t7_alpha_enter", label = "Maximum p-value for variable to enter model", value = 0.5, min = 0, max = 1 ), numericInput( inputId = "t7_alpha_remain", label = "Maximum p-value for variable to remain in model", value = 0.5, min = 0, max = 1 ), numericInput( inputId = "t7_max_iterations", label = "Maximum number of iterations for stepwise algorithm", value = 100, step = 1 ) )), actionButton("analysis_aux_predictive_submit", "Submit") ) }) }) observeEvent(input$t7_outcome_variable, { if (length(input$t7_outcome_variable) > 0 && input$t7_outcome_variable %in% colnames(global_values$selected_data)) { unique_outcomes_to_predict <- global_values$selected_data %>% pull(input$t7_outcome_variable) %>% unique() unique_outcomes_to_predict <- unique_outcomes_to_predict[ !is.na(unique_outcomes_to_predict) ] updateSelectizeInput( inputId = "t7_outcome_to_predict", choices = unique_outcomes_to_predict ) } }) observeEvent(input$t7_outcome_type, { if (input$t7_outcome_type == "continuous") { hide("t7_outcome_to_predict") } else { show("t7_outcome_to_predict") } }) observeEvent(input$t7_model_selection, { if (input$t7_model_selection == "stepwise") { show("t7_selection_controls") } else { hide("t7_selection_controls") } }) observeEvent(input$analysis_aux_predictive_submit, { routine_name <<- "predict_outcome_via_glm" routine_label <<- routines[which(routines$routine_name == routine_name), "routine_label"] withProgress(message = "Running Analysis...", { n <- 1/4 output_table <- tryCatch({ survey_design <- get_survey_design_object( data = global_values$selected_data, input = input ) survey_design <- subset( survey_design, survey_design[['variables']][["analysis_response_eligibility_variable"]] == input$eligible_respondents ) survey_design <- subset( survey_design, !is.na(get(input$t7_outcome_variable)) ) incProgress(n) selection_controls <- list( alpha_enter = input$t7_alpha_enter, alpha_remain = input$t7_alpha_remain, max_iterations = input$t7_max_iterations ) param_list <<- list( "survey_design" = survey_design, "outcome_variable" = input$t7_outcome_variable, "outcome_type" = input$t7_outcome_type, "outcome_to_predict" = input$t7_outcome_to_predict, "numeric_predictors" = input$t7_numeric_predictors, "categorical_predictors" = input$t7_categorical_predictors, "model_selection" = input$t7_model_selection, "selection_controls" = selection_controls ) result <- do.call(predict_outcome_via_glm, param_list) incProgress(n) # If there are categorical predictors, produce a text string # describing the reference levels in the regression ref_levels_table <- attr(result, 'reference_levels') if (!is.null(ref_levels_table)) { ref_levels_string <- sprintf( '%s "%s"', ref_levels_table[['variable']], ref_levels_table[['variable_category']] ) |> paste(collapse = "; ") ref_levels_string <- paste0( "For categorical predictor variables, the following categories were used as reference levels for the regression: ", " ", ref_levels_string ) } else { ref_levels_string <- NULL } footer_value <<- ref_levels_string incProgress(n) # Return the result result }, error = function(e) { return(e) }) incProgress(n) }) output$analysis_output <- render_analysis_output(output_table) })
observeEvent(input$analysis_cumulative_estimates, { global_values$last_analysis_clicked <- "analysis_cumulative_estimates" }, ignoreInit = TRUE) observeEvent(input$analysis_cumulative_estimates, { output$analysis_config <- renderUI({ tagList( selectizeInput( inputId = "t8_y_var", label = "Select the outcome variable for which estimates will be calculated:", multiple = TRUE, choices = colnames(global_values$selected_data), selected = NULL, options = list(placeholder = "[None]", maxItems = 1), width = "95%" ), selectizeInput( inputId = "t8_y_var_type", label = "Select type of variable for which estimates will be calculated:", multiple = FALSE, choices = c("Numeric variable" = "numeric", "Categorical variable" = "categorical"), width = "95%" ), selectizeInput( inputId = "t8_predictor_variable", label = "Choose the level-of-effort variable:", multiple = TRUE, choices = colnames(global_values$selected_data), selected = NULL, options = list(placeholder = "[None]", maxItems = 1), width = "95%" ), actionButton("analysis_cumulative_estimates_submit", "Submit") ) }) }) observeEvent(input$analysis_cumulative_estimates_submit, { routine_name <<- "get_cumulative_estimates" routine_label <<- routines[which(routines$routine_name == routine_name), "routine_label"] withProgress(message = "Running Analysis...", { n <- 1/3 output_table <- tryCatch({ survey_design <- get_survey_design_object( data = global_values$selected_data, input = input ) incProgress(n) survey_design <- subset( survey_design, get(input$response_eligibility_variable) == input$eligible_respondents ) incProgress(n) param_list <<- list( "survey_design" = survey_design, "y_var" = input$t8_y_var, "y_var_type" = input$t8_y_var_type, "predictor_variable" = input$t8_predictor_variable ) footer_value <<- NULL do.call(get_cumulative_estimates, param_list) }, error = function(e) { return(e) }) incProgress(n) }) output$analysis_output <- render_analysis_output(output_table) })
observeEvent(input$analysis_across_subgroups, { global_values$last_analysis_clicked <- "analysis_across_subgroups" }, ignoreInit = TRUE) observeEvent(input$analysis_across_subgroups, { output$analysis_config <- renderUI({ tagList( selectizeInput( inputId = "t9_grouping_variable", label = "Choose grouping variable:", multiple = FALSE, choices = colnames(global_values$selected_data), options = list( placeholder = '[None]', onInitialize = I('function() { this.setValue(""); }')) ), selectizeInput( inputId = "t9_outcome_variable", label = "Choose outcome variable:", multiple = FALSE, choices = colnames(global_values$selected_data), options = list( placeholder = '[None]', onInitialize = I('function() { this.setValue(""); }')) ), actionButton("analysis_across_subgroups_submit", "Submit") ) }) }) observeEvent(input$analysis_across_subgroups_submit, { withProgress(message = "Running Analysis...", { n <- 1/8 output_table <- tryCatch({ routine_name <<- "analysis_across_subgroups" routine_label <<- routines[which(routines$routine_name == routine_name), "routine_label"] grouping_variable <- input$t9_grouping_variable outcome_variable <- input$t9_outcome_variable # Create example survey design ---- survey_design <- get_survey_design_object( data = global_values$selected_data, input = input ) incProgress(n) # Subset the survey design object to relevant data ---- survey_design <- survey_design |> srvyr::as_survey() if (!is.null(grouping_variable) && (grouping_variable != "")) { subsetted_survey_design <- survey_design |> srvyr::filter(!is.na(.data[[grouping_variable]])) } subsetted_survey_design <- survey_design |> srvyr::filter(!is.na(.data[[outcome_variable]])) incProgress(n) # Produce the desired output table ---- output_table <- subsetted_survey_design |> srvyr::group_by(dplyr::across(dplyr::one_of(grouping_variable, outcome_variable))) |> srvyr::summarize( Percent = srvyr::survey_prop(vartype = "ci", proportion = TRUE, prop_method = "logit"), Weighted_Count = srvyr::survey_total(vartype = NULL), Unweighted_Count = srvyr::unweighted(n()) ) |> ungroup() |> dplyr::arrange(dplyr::across(dplyr::one_of(outcome_variable, grouping_variable))) |> dplyr::rename_with(.fn = function(x) dplyr::case_when( x == "Percent_low" ~ "Lower_95_CI", x == "Percent_upp" ~ "Upper_95_CI", TRUE ~ x )) incProgress(n) status_codes <- c( "ER" = input$eligible_respondents, "EN" = input$eligible_nonrespondents, "IE" = input$known_ineligible, "UE" = global_values$analysis_ue_category ) chisq_formula <- stats::reformulate(termlabels = c(outcome_variable, grouping_variable)) incProgress(n) htest_obj <- tryCatch( survey::svychisq( design = subsetted_survey_design, formula = chisq_formula, statistic = "F" ), error = function(e) {list( "statistic" = NA, "p.value" = NA, "parameter" = c("ndf" = NA, "ddf" = NA) )} ) incProgress(n) result_df <- data.frame(statistic = htest_obj[["statistic"]], ndf = htest_obj[["parameter"]][["ndf"]], ddf = htest_obj[["parameter"]][["ddf"]], p_value = htest_obj[["p.value"]], test_method = "Rao-Scott Chi-Square test (second-order adjustment)") rownames(result_df) <- NULL incProgress(n) if (!is.na(result_df$p_value)) { p_value_text <- sprintf( "The test of whether the survey outcome, %s, differs among subgroups defined by %s has a p-value of %s, based on a Chi-squared test of independence.", outcome_variable, grouping_variable, format.pval(result_df$p_value, eps = 0.001) ) } else { p_value_text <- paste0( "A Chi-squared test of independence could not be conducted", " due to perfect correlation between categories of the survey outcome and the grouping variable.", " Consider updating the grouping variable to use broader categories." ) } incProgress(n) param_list <<- list( "survey_design" = survey_design, "status" = "analysis_response_eligibility_variable", "status_codes" = status_codes, "aux_vars" = input$chisq_aux_variables, "grouping_variable" = input$t9_grouping_variable, "outcome_variable" = input$t9_outcome_variable ) footer_value <<- p_value_text output_table }, error = function(e) { return(e) }) incProgress(n) }) output$analysis_output <- render_analysis_output(output_table) })
div( uiOutput("analysis_config"), uiOutput("analysis_output") )
# actionButton("save_report_docx", "Save to Word") actionButton("save_report_xlsx", "Save to Excel") #uiOutput("select_row_output")
get_report <- function(user_input = TRUE) { data_report <- data.frame(matrix(ncol=4,nrow=0, dimnames=list(NULL, c("type", "time", "title", "export")))) data_report <- data_report[order("Time"),] report_index <- 1 previous_report_input_counter <<- report_input_counter title_index <- 1 titles <- list() # loop through each analysis method for (i in 1:length(analysis_store)) { if (length(analysis_store[[i]]) > 0) { # loop through each submission for(j in 1:length(analysis_store[[i]])){ if (length(analysis_store[[i]][[j]]) > 0 && !is.null(analysis_store[[i]][[j]][["type"]])){ if (analysis_store[[i]][[j]][["title"]] %in% titles){ analysis_store[[i]][[j]][["title"]] <- paste0(analysis_store[[i]][[j]][["title"]], "_",title_index) title_index <- title_index + 1 } titles[[report_index]] <- analysis_store[[i]][[j]][["title"]] data_report[report_index, "type"] <- toString(analysis_store[[i]][[j]][["type"]]) data_report[report_index, "time"] <- toString(analysis_store[[i]][[j]][["time"]]) if (user_input == TRUE) { # enabling textInput data_report[report_index, "title"] <- as.character(textInput(paste0("text_", (report_input_counter)), label = "", width = '70%', placeholder = analysis_store[[i]][[j]][["title"]])) # data_report[report_index, "title"] <- analysis_store[[i]][[j]][["title"]] data_report[report_index, "export"] <- as.character(checkboxInput(paste0("cb_", (report_input_counter)), label = "", value = TRUE, width = '5%')) } else { data_report[report_index, "title"] <- analysis_store[[i]][[j]][["title"]] data_report[report_index, "export"] <- analysis_store[[i]][[j]][["export"]] } #cat(str(colnames(analysis_store[[i]][[j]][["output"]][1]))) report_input_counter <<- report_input_counter + 1 report_index <- report_index + 1 } } } } data_report <- data_report[, c("time", "title", "export")] return(data_report) } # datatable output DT::DTOutput("output_report_df") render_data_report <- function(report_summary_table) { report_summary_table <- report_summary_table[, c("time", "title", "export")] names(report_summary_table) <- c("Created On", "Title", "Include in Report") table <- DT::datatable( data = report_summary_table, class = "cell-border hover", rownames = F, escape = FALSE, selection = 'none', fillContainer = TRUE, options = list( dom = "t", pageLength = nrow(report_summary_table), columnDefs = list( list(targets = "_all", className = "dt-left"), list(targets = c(0, 2), width = "10%"), list(targets = c(1), width = "80%") ), preDrawCallback = DT::JS('function() { Shiny.unbindAll(this.api().table().node()); }'), drawCallback = DT::JS('function() { Shiny.bindAll(this.api().table().node()); } ') ) ) %>% DT::formatDate(1, method = "toLocaleString", params = list("en-US")) return(table) } observeEvent(input$active_tab, { if (input$active_tab != 3) { report_index <- 1 for (i in 1:length(analysis_store)) { if (length(analysis_store[[i]]) > 0) { cat(paste0("\n2: ", str(input$active_tab))) for(j in 1:length(analysis_store[[i]])){ if (length(analysis_store[[i]][[j]]) > 0 && !is.null(analysis_store[[i]][[j]][["type"]])) { if (isTruthy(input[[paste0("text_", (report_index + (previous_report_input_counter - 1)))]])) { # change analysis_store title if title has been editted if (input[[paste0("text_", (report_index + (previous_report_input_counter - 1)))]] != ''){ analysis_store[[i]][[j]][["title"]] <<- input[[paste0("text_", (report_index + (previous_report_input_counter - 1)))]] } } } report_index <- report_index + 1 } } } } }, ignoreInit = TRUE) observeEvent(input$save_report_xlsx, { excel_book <- createWorkbook(creator = "Westat") addWorksheet(excel_book, "Table of Contents") writeData(excel_book, "Table of Contents", x = matrix(c("ID", "Time", "Title"), nrow = 1), colNames = FALSE) # report index is used to check the true/false html tags from the report page report_index <- 1 # table index is used to add values to excel data table table_index <- 1 for (i in 1:length(analysis_store)) { if (length(analysis_store[[i]]) > 0) { # loop through each submission for(j in 1:length(analysis_store[[i]])){ # report_index + (previous_report_input_counter - 1) keeps track of the html checkbox tags if (length(analysis_store[[i]][[j]]) > 0 && !is.null(analysis_store[[i]][[j]][["type"]]) && input[[paste0("cb_", (report_index + (previous_report_input_counter - 1)))]] == TRUE) { writeData(excel_book, "Table of Contents", x = table_index, table_index+1, startCol = 1) writeData(excel_book, "Table of Contents", x = toString(analysis_store[[i]][[j]][["time"]]), table_index+1, startCol = 2) sheet_name <- toString(table_index) addWorksheet(excel_book, sheet_name) # change analysis_store title if title has been editted if (input[[paste0("text_", (report_index + (previous_report_input_counter - 1)))]] != ''){ analysis_store[[i]][[j]][["title"]] <<- input[[paste0("text_", (report_index + (previous_report_input_counter - 1)))]] } # add output table dictionary comments output_table <- analysis_store[[i]][[j]][["output"]] columns <- as.data.frame(colnames(output_table)) colnames(columns) <- "column_name" routine_dictionary <- output_table_dictionary[which(output_table_dictionary$routine_name == analysis_store[[i]][[j]][["routine"]]),] columns <- left_join(columns, routine_dictionary) for (a in 1:nrow(columns)){ if (!is.na(columns$description[a])){ writeComment(excel_book, sheet_name, comment = createComment(comment = columns$description[a], visible = FALSE), row = 3, col = a) } } # round and add percentage to excel report for(z in 1:ncol(output_table)){ if (is.double(output_table[,z]) && names(output_table)[z] %in% routine_dictionary$column_name) { output_table[,z] <- round(output_table[,z], digits = routine_dictionary$precision[which(names(output_table)[z] == routine_dictionary$column_name[routine_dictionary$routine_name == analysis_store[[i]][[j]][["routine"]]])]) } if (names(output_table)[z] %in% routine_dictionary$column_name) { if (routine_dictionary$is_percentage[which(names(output_table)[z] == routine_dictionary$column_name)] == "Yes"){ numFmt <- "0." # loops over how many digits for numFmt for(x in 1:(routine_dictionary$precision[which(names(output_table)[z] == routine_dictionary$column_name[routine_dictionary$routine_name ==analysis_store[[i]][[j]][["routine"]]])]-2)){ numFmt <- paste0(numFmt, "0") } numFmt <- paste0(numFmt, "%") addStyle(excel_book, sheet_name, style=createStyle(numFmt = numFmt), cols=z, rows = 3:(nrow(output_table)+3)) } # highlighting if (routine_dictionary$is_emphasized[which(names(output_table)[z] == routine_dictionary$column_name)] == "Yes") { addStyle(excel_book, sheet_name, style=createStyle(textDecoration = "bold"), cols=z, rows = 3:(nrow(output_table)+3)) } } } # change column names for output column_lookup <- routine_dictionary %>% filter(nchar(short_label) > 0) %>% pull(column_name) names(column_lookup) <- routine_dictionary %>% filter(nchar(short_label) > 0) %>% pull(short_label) column_lookup <- column_lookup[column_lookup %in% colnames(output_table)] output_table <- output_table %>% rename(column_lookup) # Write the content to the sheet: Title writeData(excel_book, sheet_name, x = analysis_store[[i]][[j]][["title"]], startRow = 1, startCol = 1) addStyle( wb = excel_book, sheet = sheet_name, rows = 1, cols = seq_len(ncol(output_table)), style = createStyle( fontName = "Calibri", fontSize = 14, textDecoration = "bold", fontColour = "white", fgFill = "#4F81BD", borderStyle = "thin", border = c("Top", "Bottom"), borderColour = "black" ) ) # Write the content to the sheet: Table writeDataTable(excel_book, sheet_name, x = output_table, startRow = 3, withFilter = FALSE, tableStyle = "TableStyleMedium16") # Write the content to the sheet: Footer writeData(excel_book, sheet_name, x = analysis_store[[i]][[j]][["footer_value"]], startRow = 5+nrow(output_table)) # Add a row to the table of contents writeFormula(excel_book, "Table of Contents", x = paste0('=HYPERLINK("#',sheet_name,'!A1", "',analysis_store[[i]][[j]][["title"]],'")'), startRow = table_index+1, startCol = 3) table_index <- table_index + 1 } report_index <- report_index + 1 } } } full_file_name <- file.path(tempdir(), "excel_book.xlsx") saveWorkbook(excel_book, file = full_file_name, overwrite = TRUE) report_as_base64 <- base64enc::base64encode(full_file_name) output$report_link_container <- renderUI({ HTML(paste0("<a id=\"report_link\" download=\"report.xlsx\" href=\"data:application/vnd.openxmlformats-officedocument.spreadsheetml.sheet;base64,", report_as_base64, "\">Download Report</a>")) }); shinyjs::runjs(" document.getElementById('save_report_xlsx').disabled = true; setTimeout(function() { document.getElementById('report_link').click(); document.getElementById('save_report_xlsx').disabled = false; }, 1000) "); file.remove(full_file_name) })
uiOutput("select_row_output")
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.