diff --git a/R/cut-variable-dates.R b/R/cut-variable-dates.R index 43b85c4..78b07f7 100644 --- a/R/cut-variable-dates.R +++ b/R/cut-variable-dates.R @@ -2,92 +2,159 @@ library(datamods) library(toastui) library(phosphoricons) library(rlang) +library(shiny) -# x <- lubridate::as_datetime(seq(1,1000000,2000), origin = "2000-12-31") -# class(x) + +# old_deprecated_cut.hms <- function(x, breaks = "hour", ...) { +# # For now, this function will allways try to cut to hours +# # This limits time cutting to only do hour-binning, no matter the # -# lubridate::hms(c("01:00:20")) +# breaks_o <- breaks # -# int_x <- classInt::classIntervals(lubridate::as_datetime(seq(1,1000000,2000), origin = "2000-12-31"), 4, style = "quantile") -# classInt::classIntervals(readr::parse_time(c("01:00:20","03:00:20","01:20:20","03:02:20")), 2, style = "quantile") -# int_x|> dput() +# if (identical(breaks, "hour")) { +# # splitter <- match( +# # num, +# # levels(factor(num)) +# # ) +# breaks <- hms::as_hms(paste0(1:23, ":00:00")) +# } # -# library(hms) +# # if (identical(breaks, "daynight")) { +# # # splitter <- num %in% 8:20 + 1 +# # breaks <- hms::as_hms(c("08:00:00","20:00:00")) +# # } # -# ?cut.POSIXt +# if (length(breaks) != 1) { +# if ("hms" %in% class(breaks)) { +# splitter <- seq_along(breaks) |> +# purrr::map(\(.x){ +# # browser() +# out <- x %in% x[x >= breaks[.x] & x < breaks[.x + 1]] +# if (.x == length(breaks)) { +# out[match(breaks[length(breaks)], x)] <- TRUE +# } +# ifelse(out, .x, 0) +# }) |> +# dplyr::bind_cols(.name_repair = "unique_quiet") |> +# rowSums() +# splitter[splitter == 0] <- NA +# } else { +# breaks <- "hour" +# } +# } # -# x <- readr::parse_time(c("01:00:20","03:00:20","01:20:20","03:02:20")) -# cut(x) +# if (is.numeric(breaks)) { +# breaks_n <- quantile(x, probs = seq(0, 1, 1 / breaks)) +# ## Use lapply or similar to go through levels two at a time +# splitter <- seq(breaks) |> +# purrr::map(\(.x){ +# # browser() +# out <- x %in% x[x >= breaks_n[.x] & x < breaks_n[.x + 1]] +# if (.x == breaks) { +# out[match(breaks_n[length(breaks_n)], x)] <- TRUE +# } +# ifelse(out, .x, 0) +# }) |> +# dplyr::bind_cols(.name_repair = "unique_quiet") |> +# rowSums() +# } +# +# # browser() +# +# num <- strsplit(as.character(x), ":") |> +# lapply(\(.x).x[[1]]) |> +# unlist() |> +# as.numeric() +# +# # browser() +# labs <- split(x, splitter) |> +# purrr::imap(\(.x, .i){ +# # if (identical(breaks_o, "daynight") && .i == 1) { +# # h <- hms::as_hms(hms::hms(hours = 24) - abs(.x - hms::hms(hours = 8))) +# # +# # paste0("[", .x[match(sort(h)[1], h)], ",", .x[match(sort(h)[length(h)], h)], "]") +# # } else { +# .x <- sort(.x) +# paste0("[", .x[1], ",", .x[length(.x)], "]") +# # } +# }) |> +# unlist() +# +# structure(match(splitter, names(labs)), levels = labs, class = "factor") +# } #' Title #' #' @param x an object inheriting from class "hms" -#' @param breaks Can be "hour" or "dn" #' @param ... passed on #' +#' @rdname cut +#' #' @return #' @export #' #' @examples #' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut(2) -#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA)) |> -#' cut() |> -#' dput() -cut.hms <- function(x, breaks = "hour", ...) { - browser() - # For now, this function will allways try to cut to hours - # This limits time cutting to only do hour-binning, no matter the - if (length(breaks) != 1) { - if ("hms" %in% class(breaks)) { - - } else { - breaks <- "hour" - } +#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut("min") +#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut(breaks = "hour") +#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut(breaks = hms::as_hms(c("01:00:00", "03:01:20", "9:20:20"))) +#' d_t <- readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA)) +#' f <- d_t |> cut(2) +#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA)) |> cut(breaks = lubridate::as_datetime(c(hms::as_hms(levels(f)), hms::as_hms(max(d_t, na.rm = TRUE) + 1))), right = FALSE) +cut.hms <- function(x, breaks, ...) { + if (hms::is_hms(breaks)) { + breaks <- lubridate::as_datetime(breaks, tz = "UTC") } - if (!breaks %in% c("hour", "dn")) { - if (is.numeric(breaks)) { - breaks_n <- quantile(x, probs = seq(0, 1, 1 / breaks)) - ## Use lapply or similar to go through levels two at a time - - } else { - breaks <- "hour" - } - } - - ch <- strsplit(as.character(x), ":") |> - lapply(\(.x).x[[1]]) |> - unlist() - - num <- as.numeric(ch) - - if (breaks == "hour") { - splitter <- match( - num, - levels(factor(num)) - ) - } else if (breaks == "dn") { - splitter <- num %in% 8:20 + 1 - } else { - stop("No other methods than hour cut is implemented.") - } - - labs <- split(x, splitter) |> - purrr::imap(\(.x, .i){ - if (breaks == "dn" && .i == 1) { - h <- hms::as_hms(hms::hms(hours = 24) - abs(.x - hms::hms(hours = 8))) - - paste0("[", .x[match(sort(h)[1], h)], ",", .x[match(sort(h)[length(h)], h)], "]") - } else { - .x <- sort(.x) - paste0("[", .x[1], ",", .x[length(.x)], "]") - } - }) |> - unlist() - - structure(match(num, l), levels = labs, class = "factor") + x <- lubridate::as_datetime(x, tz = "UTC") + out <- cut.POSIXt(x, breaks = breaks, ...) + attr(out, which = "brks") <- hms::as_hms(lubridate::as_datetime(attr(out, which = "brks"))) + attr(out, which = "levels") <- as.character(hms::as_hms(lubridate::as_datetime(attr(out, which = "levels")))) + out } -#' Title +#' @rdname cut +#' @param x an object inheriting from class "POSIXt" or "Date" +cut.POSIXt <- function(x, breaks, right = FALSE, include.lowest = TRUE, ...) { + breaks_o <- breaks + # browser() + if (is.numeric(breaks)) { + breaks <- quantile( + x, + probs = seq(0, 1, 1 / breaks), + right = right, + include.lowest = include.lowest, + na.rm=TRUE + ) + } + + ## Doesn't really work very well for breaks other than the special character cases as right border is excluded + out <- base::cut.POSIXt(x, breaks=breaks,right=right,...) |> forcats::fct_drop() + # browser() + + l <- levels(out) + if (is.numeric(breaks_o)) { + l <- breaks + } else if (is.character(breaks) && length(breaks) == 1) { + if (include.lowest) { + if (right) { + l <- c(l, min(as.character(x))) + } else { + l <- c(l, max(as.character(x))) + } + } + } else if (length(l) < length(breaks_o)) { + l <- breaks_o + } + + attr(out, which = "brks") <- l + out +} + +#' @rdname cut +#' @param x an object inheriting from class "POSIXct" +cut.POSIXct <- cut.POSIXt + +#' Test class #' #' @param data data #' @param class.vec vector of class names to test @@ -103,7 +170,7 @@ is_any_class <- function(data, class.vec) { any(class(data) %in% class.vec) } -#' Title +#' Test is date/datetime/time #' #' @param data data #' @@ -137,7 +204,7 @@ is_datetime <- function(data) { cut_variable_ui <- function(id) { ns <- NS(id) tagList( - fluidRow( + shiny::fluidRow( column( width = 3, virtualSelectInput( @@ -149,33 +216,7 @@ cut_variable_ui <- function(id) { ), column( width = 3, - virtualSelectInput( - inputId = ns("method"), - label = i18n("Method:"), - choices = c( - "fixed", - # "sd", - # "equal", - # "pretty", - "quantile", - # "kmeans", - # "hclust", - # "bclust", - # "fisher", - # "jenks", - "headtails", - # "maximum", - # "box", - "hour", - "day", - "week", - "month", - "quarter", - "year" - ), - selected = "quantile", - width = "100%" - ) + shiny::uiOutput(ns("cut_method")) ), column( width = 3, @@ -253,21 +294,90 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { data <- req(data_r()) variable <- req(input$variable) req(hasName(data, variable)) + + if (is_datetime(data[[variable]])) { + brks <- cut(data[[variable]], + breaks = input$n_breaks + )$brks + } else { + brks <- classInt::classIntervals( + var = data[[variable]], + n = input$n_breaks, + style = "quantile" + )$brks + } + + if (is_datetime(data[[variable]])) { + lower <- min(data[[variable]], na.rm = TRUE) + } else { + lower <- floor(min(data[[variable]], na.rm = TRUE)) + } + + if (is_datetime(data[[variable]])) { + upper <- max(data[[variable]], na.rm = TRUE) + } else { + upper <- ceiling(max(data[[variable]], na.rm = TRUE)) + } + + noUiSliderInput( inputId = session$ns("fixed_brks"), label = i18n("Fixed breaks:"), - min = floor(min(data[[variable]], na.rm = TRUE)), - max = ceiling(max(data[[variable]], na.rm = TRUE)), - value = classInt::classIntervals( - var = as.numeric(data[[variable]]), - n = input$n_breaks, - style = "quantile" - )$brks, + min = lower, + max = upper, + value = brks, color = datamods:::get_primary_color(), width = "100%" ) }) + output$cut_method <- renderUI({ + data <- req(data_r()) + variable <- req(input$variable) + + choices <- c( + # "quantile" + ) + + if ("hms" %in% class(data[[variable]])) { + choices <- c(choices, "hour") + } else if (any(c("POSIXt","Date") %in% class(data[[variable]]))) { + choices <- c( + choices, "day", + "week", + "month", + "quarter", + "year" + ) + } else { + choices <- c( + choices, + "fixed", + "quantile", + # "sd", + # "equal", + # "pretty", + # "kmeans", + # "hclust", + # "bclust", + # "fisher", + # "jenks", + "headtails" # , + # "maximum", + # "box" + ) + } + + shinyWidgets::virtualSelectInput( + inputId = session$ns("method"), + label = i18n("Method:"), + choices = choices, + selected = "quantile", + width = "100%" + ) + }) + + breaks_r <- reactive({ data <- req(data_r()) variable <- req(input$variable) @@ -275,12 +385,31 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { req(input$n_breaks, input$method) if (input$method == "fixed") { req(input$fixed_brks) - classInt::classIntervals( - var = as.numeric(data[[variable]]), - n = input$n_breaks, - style = "fixed", - fixedBreaks = input$fixed_brks - ) + if (any(c("hms", "POSIXt") %in% class(data[[variable]]))) { + cut.POSIXct <- cut.POSIXt + f <- cut(data[[variable]], breaks = input$fixed_brks) + list(var = f, brks = levels(f)) + } else { + classInt::classIntervals( + var = as.numeric(data[[variable]]), + n = input$n_breaks, + style = "fixed", + fixedBreaks = input$fixed_brks + ) + } + } else if (input$method == "quantile") { + req(input$fixed_brks) + if (any(c("hms", "POSIXt") %in% class(data[[variable]]))) { + cut.POSIXct <- cut.POSIXt + f <- cut(data[[variable]], breaks = input$n_breaks) + list(var = f, brks = levels(f)) + } else { + classInt::classIntervals( + var = as.numeric(data[[variable]]), + n = input$n_breaks, + style = "quantile" + ) + } } else if (input$method %in% c( "day", "week", @@ -318,7 +447,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { variable <- req(input$variable) data[[paste0(variable, "_cut")]] <- cut( x = data[[variable]], - breaks = if (input$method %in% c("day","week","month","quarter","year","hour")) input$method else breaks_r()$brks, + breaks = if (input$method %in% c("day", "week", "month", "quarter", "year", "hour")) input$method else breaks_r()$brks, include.lowest = input$include_lowest, right = input$right ) diff --git a/inst/apps/data_analysis_modules/server.R b/inst/apps/data_analysis_modules/server.R index 4c634ec..07da214 100644 --- a/inst/apps/data_analysis_modules/server.R +++ b/inst/apps/data_analysis_modules/server.R @@ -40,16 +40,24 @@ server <- function(input, output, session) { ## everything else. files.to.keep <- list.files("www/") - v <- shiny::reactiveValues( + rv <- shiny::reactiveValues( list = NULL, ds = NULL, input = exists("webResearch_data"), local_temp = NULL, quarto = NULL, test = "no", - data = NULL + data_original = NULL, + data = NULL, + data_filtered = NULL ) + ############################################################################## + ######### + ######### Data import section + ######### + ############################################################################## + data_file <- datamods::import_file_server( id = "file_import", show_data_in = "popup", @@ -65,11 +73,20 @@ server <- function(input, output, session) { ) ) + shiny::observeEvent(data_file$data(), { + shiny::req(data_file$data()) + rv$data_original <- data_file$data() + }) + data_redcap <- m_redcap_readServer( id = "redcap_import", output.format = "list" ) + shiny::observeEvent(data_redcap(), { + rv$data_original <- purrr::pluck(data_redcap(), "data")() + }) + output$redcap_prev <- DT::renderDT( { DT::datatable(head(purrr::pluck(data_redcap(), "data")(), 5), @@ -79,68 +96,45 @@ server <- function(input, output, session) { server = TRUE ) - data_rv <- shiny::reactiveValues(data = NULL) - # - # shiny::observeEvent(data_file$data(), { - # data_rv$data <- data_file$data() |> - # REDCapCAST::numchar2fct() - # }) - # - # shiny::observeEvent(purrr::pluck(ds(), "data")(), { - # data_rv$data <- purrr::pluck(ds(), "data")() |> - # REDCapCAST::parse_data() |> - # REDCapCAST::as_factor() |> - # REDCapCAST::numchar2fct() - # }) + from_env <- import_globalenv_server( + id = "env", + trigger_return = "change", + btn_show_data = FALSE, + reset = reactive(input$hidden) + ) + shiny::observeEvent(from_env$data(), { + shiny::req(from_env$data()) + rv$data_original <- from_env$data() + }) ds <- shiny::reactive({ # input$file1 will be NULL initially. After the user selects # and uploads a file, head of that data file by default, # or all rows if selected, will be shown. - if (v$input) { - out <- webResearch_data - } else if (input$source == "file") { - req(data_file$data()) - out <- data_file$data() - } else if (input$source == "redcap") { - req(purrr::pluck(data_redcap(), "data")()) - out <- purrr::pluck(data_redcap(), "data")() - } - - v$ds <- "loaded" - # browser() - # if (input$factorize == "yes") { - # out <- out |> - # REDCapCAST::numchar2fct() + # if (v$input) { + # out <- webResearch_data + # } else if (input$source == "file") { + # req(data_file$data()) + # out <- data_file$data() + # } else if (input$source == "redcap") { + # req(purrr::pluck(data_redcap(), "data")()) + # out <- purrr::pluck(data_redcap(), "data")() # } - out <- out|> + + req(rv$data_original) + rv$data_original <- rv$data_original |> REDCapCAST::parse_data() |> REDCapCAST::as_factor() |> REDCapCAST::numchar2fct() - data_rv$data <- shiny::reactive(out) + rv$ds <- "loaded" - out + rv$data <- rv$data_original + + rv$data_original }) - # shiny::reactive({ - # if (!is.null(data_rv$data)){ - # data_rv$data <- shiny::reactive(data_rv$data() |> REDCapCAST::parse_data() |> - # REDCapCAST::as_factor() |> - # REDCapCAST::numchar2fct()) - # } - # }) - - output$table <- - DT::renderDT( - { - DT::datatable( - ds()) - }, - server = FALSE - ) - ############################################################################## ######### ######### Data modification section @@ -149,28 +143,26 @@ server <- function(input, output, session) { ######### Modifications - rv <- shiny::reactiveValues(data = reactive(ds() )) - - observeEvent(ds(), rv$data <- ds()) - observeEvent(input$data_reset, rv$data <- ds()) + shiny::observeEvent(rv$data_original, rv$data <- rv$data_original) + shiny::observeEvent(input$data_reset, rv$data <- rv$data_original) ## Using modified version of the datamods::cut_variable_server function ## Further modifications are needed to have cut/bin options based on class of variable ## Could be defined server-side - observeEvent(input$modal_cut, modal_cut_variable("modal_cut")) + shiny::observeEvent(input$modal_cut, modal_cut_variable("modal_cut")) data_modal_cut <- cut_variable_server( id = "modal_cut", - data_r = reactive(rv$data) + data_r = shiny::reactive(rv$data) ) - observeEvent(data_modal_cut(), rv$data <- data_modal_cut()) + shiny::observeEvent(data_modal_cut(), rv$data <- data_modal_cut()) - observeEvent(input$modal_update, datamods::modal_update_factor("modal_update")) + shiny::observeEvent(input$modal_update, datamods::modal_update_factor("modal_update")) data_modal_update <- datamods::update_factor_server( id = "modal_update", data_r = reactive(rv$data) ) - observeEvent(data_modal_update(), { + shiny::observeEvent(data_modal_update(), { shiny::removeModal() rv$data <- data_modal_update() }) @@ -178,11 +170,12 @@ server <- function(input, output, session) { # Show result - output$table_mod <- toastui::renderDatagrid2({ - req(rv$data) + output$table_mod <- toastui::renderDatagrid({ + shiny::req(rv$data) # data <- rv$data toastui::datagrid( - data = rv$data#, + # data = rv$data # , + data = data_filter() # bordered = TRUE, # compact = TRUE, # striped = TRUE @@ -211,54 +204,27 @@ server <- function(input, output, session) { rv$data <- updated_data() }) - # datamods filtering has the least attractive ui, but it does work well - # - # output$filter_vars <- shiny::renderUI({ - # shinyWidgets::virtualSelectInput( - # inputId = "filter_vars", - # selected = NULL, - # label = "Covariables to include", - # choices = colnames(ds()), - # multiple = TRUE, - # updateOn = "change" - # ) - # }) - # data_filter <- datamods::filter_data_server( - # id = "filtering", - # data = ds, - # widget_num = "slider", - # widget_date = "slider", - # label_na = "Missing", - # vars = shiny::reactive(input$filter_vars) - # ) - # - # output$filtered_table <- - # DT::renderDT( - # { - # DT::datatable(data_filter$filtered()) - # }, - # server = TRUE - # ) - # - # output$filtered_code <- shiny::renderPrint({ - # data_filter$code() - # }) - # IDEAFilter has the least cluttered UI, but might have a License issue data_filter <- IDEAFilter::IDEAFilter("data_filter", data = reactive(rv$data), verbose = TRUE) - observeEvent(input$save_filter, { - rv$data <- data_filter() - }) + # shiny::observeEvent(data_filter(), { + # rv$data_filtered <- data_filter() + # }) output$filtered_code <- shiny::renderPrint({ - gsub("reactive(rv$data)", "data", - cat(gsub("%>%", "|> \n ", - gsub("\\s{2,}", " ", - paste0( - capture.output(attr(data_filter(), "code")), - collapse = " ")) - ))) + cat(gsub( + "%>%", "|> \n ", + gsub( + "\\s{2,}", " ", + gsub( + "reactive(rv$data)", "data", + paste0( + capture.output(attr(data_filter(), "code")), + collapse = " " + ) + ) + ) + )) }) @@ -276,7 +242,7 @@ server <- function(input, output, session) { inputId = "include_vars", selected = NULL, label = "Covariables to include", - choices = colnames(rv$data), + choices = colnames(data_filter()), multiple = TRUE ) }) @@ -286,40 +252,41 @@ server <- function(input, output, session) { inputId = "outcome_var", selected = NULL, label = "Select outcome variable", - choices = colnames(rv$data), + choices = colnames(data_filter()), multiple = FALSE ) }) + + output$factor_vars <- shiny::renderUI({ + shiny::selectizeInput( + inputId = "factor_vars", + selected = colnames(data_filter())[sapply(data_filter(), is.factor)], + label = "Covariables to format as categorical", + choices = colnames(data_filter()), + multiple = TRUE + ) + }) + + base_vars <- shiny::reactive({ + if (is.null(input$include_vars)) { + out <- colnames(data_filter()) + } else { + out <- unique(c(input$include_vars, input$outcome_var)) + } + return(out) + }) + output$strat_var <- shiny::renderUI({ shiny::selectInput( inputId = "strat_var", selected = "none", label = "Select variable to stratify baseline", - choices = c("none", colnames(rv$data[base_vars()])), + choices = c("none", colnames(data_filter()[base_vars()])), multiple = FALSE ) }) - output$factor_vars <- shiny::renderUI({ - shiny::selectizeInput( - inputId = "factor_vars", - selected = colnames(rv$data)[sapply(rv$data, is.factor)], - label = "Covariables to format as categorical", - choices = colnames(rv$data), - multiple = TRUE - ) - }) - - base_vars <- shiny::reactive({ - if (is.null(input$include_vars)) { - out <- colnames(rv$data) - } else { - out <- unique(c(input$include_vars, input$outcome_var)) - } - return(out) - }) - ## Have a look at column filters at some point ## There should be a way to use the filtering the filter data for further analyses ## Disabled for now, as the JS is apparently not isolated @@ -353,17 +320,11 @@ server <- function(input, output, session) { # browser() # Assumes all character variables can be formatted as factors # data <- data_filter$filtered() |> - data <- rv$data |> + data <- data_filter() |> dplyr::mutate(dplyr::across(dplyr::where(is.character), as.factor)) |> REDCapCAST::fct_drop.data.frame() |> factorize(vars = input$factor_vars) - # if (is.factor(data[[input$strat_var]])) { - # by.var <- input$strat_var - # } else { - # by.var <- NULL - # } - if (input$strat_var == "none") { by.var <- NULL } else { @@ -398,18 +359,10 @@ server <- function(input, output, session) { ) }) - # browser() - # check <- performance::check_model(purrr::pluck(models,"Multivariable") |> - # (\(x){ - # class(x) <- class(x)[class(x) != "webresearch_model"] - # return(x) - # })()) - check <- purrr::pluck(models, "Multivariable") |> performance::check_model() - - v$list <- list( + rv$list <- list( data = data, check = check, table1 = data |> @@ -442,12 +395,12 @@ server <- function(input, output, session) { ) output$table1 <- gt::render_gt( - v$list$table1 |> + rv$list$table1 |> gtsummary::as_gt() ) output$table2 <- gt::render_gt( - v$list$table2 |> + rv$list$table2 |> gtsummary::as_gt() ) @@ -469,10 +422,19 @@ server <- function(input, output, session) { ) + shiny::conditionalPanel( + condition = "output.uploaded == 'yes'", + ) + + # observeEvent(input$act_start, { + # nav_show(id = "overview",target = "Import" + # ) + # }) + output$uploaded <- shiny::reactive({ - if (is.null(v$ds)) { + if (is.null(rv$ds)) { "no" } else { "yes" @@ -481,15 +443,17 @@ server <- function(input, output, session) { shiny::outputOptions(output, "uploaded", suspendWhenHidden = FALSE) - output$has_input <- shiny::reactive({ - if (v$input) { - "yes" - } else { - "no" - } - }) - shiny::outputOptions(output, "has_input", suspendWhenHidden = FALSE) + # Reimplement from environment at later time + # output$has_input <- shiny::reactive({ + # if (rv$input) { + # "yes" + # } else { + # "no" + # } + # }) + + # shiny::outputOptions(output, "has_input", suspendWhenHidden = FALSE) # Could be rendered with other tables or should show progress # Investigate quarto render problems @@ -502,7 +466,7 @@ server <- function(input, output, session) { ## Notification is not progressing ## Presumably due to missing shiny::withProgress(message = "Generating report. Hold on for a moment..", { - v$list |> + rv$list |> write_quarto( output_format = type, input = file.path(getwd(), "www/report.qmd") diff --git a/inst/apps/data_analysis_modules/ui.R b/inst/apps/data_analysis_modules/ui.R index c1397c6..b756cff 100644 --- a/inst/apps/data_analysis_modules/ui.R +++ b/inst/apps/data_analysis_modules/ui.R @@ -19,36 +19,41 @@ ui_elements <- list( column( width = 6, shiny::h4("Choose your data source"), - shiny::conditionalPanel( - condition = "output.has_input=='yes'", - # Input: Select a file ---- - shiny::helpText("Analyses are performed on provided data") + # shiny::conditionalPanel( + # condition = "output.has_input=='yes'", + # # Input: Select a file ---- + # shiny::helpText("Analyses are performed on provided data") + # ), + # shiny::conditionalPanel( + # condition = "output.has_input=='no'", + # Input: Select a file ---- + shinyWidgets::radioGroupButtons( + inputId = "source", + # label = "Choice: ", + choices = c("File upload" = "file", "REDCap server" = "redcap","Sample data"="env"), + checkIcon = list( + yes = icon("square-check"), + no = icon("square") + ) ), shiny::conditionalPanel( - condition = "output.has_input=='no'", - # Input: Select a file ---- - shiny::radioButtons( - inputId = "source", - label = "Upload file or export from REDCap?", - selected = "file", - inline = TRUE, - choices = list( - "File" = "file", - "REDCap" = "redcap" - ) - ), - shiny::conditionalPanel( - condition = "input.source=='file'", - datamods::import_file_ui("file_import", - title = "Choose a datafile to upload", - file_extensions = c(".csv", ".txt", ".xls", ".xlsx", ".rds", ".fst", ".sas7bdat", ".sav", ".ods", ".dta") - ) - ), - shiny::conditionalPanel( - condition = "input.source=='redcap'", - m_redcap_readUI("redcap_import") + condition = "input.source=='file'", + datamods::import_file_ui("file_import", + title = "Choose a datafile to upload", + file_extensions = c(".csv", ".txt", ".xls", ".xlsx", ".rds", ".fst", ".sas7bdat", ".sav", ".ods", ".dta") ) + ), + shiny::conditionalPanel( + condition = "input.source=='redcap'", + m_redcap_readUI("redcap_import") + ), + shiny::conditionalPanel( + condition = "input.source=='env'", + import_globalenv_ui(id = "env", title = NULL) ) + + + # ) ), column( width = 6, @@ -73,171 +78,181 @@ ui_elements <- list( ######### Data overview panel ######### ############################################################################## - "overview" = bslib::nav_panel( - title = "Overview and modifications", - bslib::navset_bar(fillable = TRUE, - # bslib::nav_panel( - # title = "Edit", - # datamods::edit_data_ui(id = "edit_data") - # ), - # bslib::nav_panel( - # title = "Overview", - # DT::DTOutput(outputId = "table") - # ), - bslib::nav_panel( - title = "Rename and select", - tags$h3("Select, rename and convert variables"), - fluidRow( - column( - width = 6, - # radioButtons() - shiny::actionButton("data_reset", "Restore original data"), - datamods::update_variables_ui("vars_update") - ), - column( - width = 6, - tags$b("Original data:"), - # verbatimTextOutput("original"), - verbatimTextOutput("original_str"), - tags$b("Modified data:"), - # verbatimTextOutput("modified"), - verbatimTextOutput("modified_str") - ) - ) - ), - bslib::nav_panel( - title = "Filter and modify", - shinyWidgets::html_dependency_winbox(), - fluidRow( - # column( - # width = 3, - # shiny::uiOutput("filter_vars"), - # shiny::conditionalPanel( - # condition = "(typeof input.filter_vars !== 'undefined' && input.filter_vars.length > 0)", - # datamods::filter_data_ui("filtering", max_height = "500px") - # ) - # ), - # column( - # width = 9, - # DT::DTOutput(outputId = "filtered_table"), - # tags$b("Code dplyr:"), - # verbatimTextOutput(outputId = "filtered_code") - # ), - shiny::column( - width = 8, - toastui::datagridOutput2(outputId = "table_mod"), - shiny::tags$b("Reproducible code:"), - shiny::verbatimTextOutput(outputId = "filtered_code") - ), - shiny::column( - width = 4, - shiny::actionButton("modal_cut", "Cut a variable"), - shiny::tags$br(), - shiny::tags$br(), - shiny::actionButton("modal_update", "Update factor's levels"), - shiny::tags$br(), - shiny::tags$br(), - IDEAFilter::IDEAFilter_ui("data_filter"), - shiny::actionButton("save_filter", "Apply the filter") + "overview" = + # bslib::nav_panel_hidden( + bslib::nav_panel( + # value = "overview", + title = "Overview and modifications", + bslib::navset_bar( + fillable = TRUE, + # bslib::nav_panel( + # title = "Edit", + # datamods::edit_data_ui(id = "edit_data") + # ), + # bslib::nav_panel( + # title = "Overview", + # DT::DTOutput(outputId = "table") + # ), + bslib::nav_panel( + title = "Rename and select", + tags$h3("Select, rename and convert variables"), + fluidRow( + column( + width = 6, + # radioButtons(), + shiny::actionButton("data_reset", "Restore original data"), + shiny::tags$br(), + shiny::helpText("Reset to original imported dataset"), + shiny::tags$br(), + datamods::update_variables_ui("vars_update") + ), + column( + width = 6, + tags$b("Original data:"), + # verbatimTextOutput("original"), + verbatimTextOutput("original_str"), + tags$b("Modified data:"), + # verbatimTextOutput("modified"), + verbatimTextOutput("modified_str") + ) + ) + ), + bslib::nav_panel( + title = "Filter and modify", + shinyWidgets::html_dependency_winbox(), + fluidRow( + # column( + # width = 3, + # shiny::uiOutput("filter_vars"), + # shiny::conditionalPanel( + # condition = "(typeof input.filter_vars !== 'undefined' && input.filter_vars.length > 0)", + # datamods::filter_data_ui("filtering", max_height = "500px") + # ) + # ), + # column( + # width = 9, + # DT::DTOutput(outputId = "filtered_table"), + # tags$b("Code dplyr:"), + # verbatimTextOutput(outputId = "filtered_code") + # ), + shiny::column( + width = 8, + toastui::datagridOutput(outputId = "table_mod"), + shiny::tags$b("Reproducible code:"), + shiny::verbatimTextOutput(outputId = "filtered_code") + ), + shiny::column( + width = 4, + shiny::actionButton("modal_cut", "Create factor from a variable"), + shiny::tags$br(), + shiny::tags$br(), + shiny::actionButton("modal_update", "Reorder factor levels"), + shiny::tags$br(), + shiny::tags$br(), + IDEAFilter::IDEAFilter_ui("data_filter") # , + # shiny::actionButton("save_filter", "Apply the filter") + ) ) ) + + + # column( + # 8, + # shiny::verbatimTextOutput("filtered_code"), + # DT::DTOutput("filtered_table") + # ), + # column(4, IDEAFilter::IDEAFilter_ui("data_filter")) ) - - - # column( - # 8, - # shiny::verbatimTextOutput("filtered_code"), - # DT::DTOutput("filtered_table") - # ), - # column(4, IDEAFilter::IDEAFilter_ui("data_filter")) - ) - ), + ), ############################################################################## ######### ######### Data analyses panel ######### ############################################################################## - "analyze" = bslib::nav_panel( - title = "Analysis", - bslib::navset_bar( - title = "", - # bslib::layout_sidebar( - # fillable = TRUE, - sidebar = bslib::sidebar( - shiny::helpText(em("Please specify relevant settings for your data, and press 'Analyse'")), - shiny::uiOutput("outcome_var"), - shiny::uiOutput("strat_var"), - shiny::conditionalPanel( - condition = "input.strat_var!='none'", + "analyze" = + # bslib::nav_panel_hidden( + bslib::nav_panel( + # value = "analyze", + title = "Analyses", + bslib::navset_bar( + title = "", + # bslib::layout_sidebar( + # fillable = TRUE, + sidebar = bslib::sidebar( + shiny::helpText(em("Please specify relevant settings for your data, and press 'Analyse'")), + shiny::uiOutput("outcome_var"), + shiny::uiOutput("strat_var"), + shiny::conditionalPanel( + condition = "input.strat_var!='none'", + shiny::radioButtons( + inputId = "add_p", + label = "Compare strata?", + selected = "no", + inline = TRUE, + choices = list( + "No" = "no", + "Yes" = "yes" + ) + ), + shiny::helpText("Option to perform statistical comparisons between strata in baseline table.") + ), shiny::radioButtons( - inputId = "add_p", - label = "Compare strata?", + inputId = "all", + label = "Specify covariables", + inline = TRUE, selected = 2, + choiceNames = c( + "Yes", + "No" + ), + choiceValues = c(1, 2) + ), + shiny::conditionalPanel( + condition = "input.all==1", + shiny::uiOutput("include_vars") + ), + shiny::radioButtons( + inputId = "specify_factors", + label = "Specify categorical variables?", selected = "no", inline = TRUE, choices = list( - "No" = "no", - "Yes" = "yes" + "Yes" = "yes", + "No" = "no" ) ), - shiny::helpText("Option to perform statistical comparisons between strata in baseline table.") - ), - shiny::radioButtons( - inputId = "all", - label = "Specify covariables", - inline = TRUE, selected = 2, - choiceNames = c( - "Yes", - "No" + shiny::conditionalPanel( + condition = "input.specify_factors=='yes'", + shiny::uiOutput("factor_vars") ), - choiceValues = c(1, 2) - ), - shiny::conditionalPanel( - condition = "input.all==1", - shiny::uiOutput("include_vars") - ), - shiny::radioButtons( - inputId = "specify_factors", - label = "Specify categorical variables?", - selected = "no", - inline = TRUE, - choices = list( - "Yes" = "yes", - "No" = "no" - ) - ), - shiny::conditionalPanel( - condition = "input.specify_factors=='yes'", - shiny::uiOutput("factor_vars") - ), - bslib::input_task_button( - id = "load", - label = "Analyse", - icon = shiny::icon("pencil", lib = "glyphicon"), - label_busy = "Working...", - icon_busy = fontawesome::fa_i("arrows-rotate", - class = "fa-spin", - "aria-hidden" = "true" + bslib::input_task_button( + id = "load", + label = "Analyse", + icon = shiny::icon("pencil", lib = "glyphicon"), + label_busy = "Working...", + icon_busy = fontawesome::fa_i("arrows-rotate", + class = "fa-spin", + "aria-hidden" = "true" + ), + type = "primary", + auto_reset = TRUE ), - type = "primary", - auto_reset = TRUE + shiny::helpText("If you change the parameters, press 'Analyse' again to update the tables") + # ) ), - shiny::helpText("If you change the parameters, press 'Analyse' again to update the tables") - # ) - ), - bslib::nav_panel( - title = "Baseline characteristics", - gt::gt_output(outputId = "table1") - ), - bslib::nav_panel( - title = "Regression table", - gt::gt_output(outputId = "table2") - ), - bslib::nav_panel( - title = "Regression checks", - shiny::plotOutput(outputId = "check") + bslib::nav_panel( + title = "Baseline characteristics", + gt::gt_output(outputId = "table1") + ), + bslib::nav_panel( + title = "Regression table", + gt::gt_output(outputId = "table2") + ), + bslib::nav_panel( + title = "Regression checks", + shiny::plotOutput(outputId = "check") + ) ) - ) - ), + ), ############################################################################## ######### ######### Documentation panel @@ -245,35 +260,11 @@ ui_elements <- list( ############################################################################## "docs" = bslib::nav_panel( title = "Documentation", - shiny::markdown(readLines("www/intro.md")), + shiny::markdown(readLines(here::here("inst/apps/data_analysis_modules/www/intro.md"))), shiny::br() ) ) -# cards <- list( -# "overview"=bslib::card( -# title = "Data overview", -# # shiny::uiOutput("data.classes"), -# # shiny::uiOutput("data.input"), -# # shiny::p("Classes of uploaded data"), -# # gt::gt_output("data.classes"), -# shiny::p("Subset data"), -# DT::DTOutput(outputId = "data_table") -# ), -# "baseline"=bslib::card( -# title = "Baseline characteristics", -# gt::gt_output(outputId = "table1") -# ), -# "regression"= bslib::card( -# title = "Regression table", -# gt::gt_output(outputId = "table2") -# ), -# "checks" =bslib::card( -# title = "Regression checks", -# shiny::plotOutput(outputId = "check") -# ) -# ) - ui <- bslib::page( title = "freesearcheR", theme = bslib::bs_theme( @@ -291,199 +282,3 @@ ui <- bslib::page( ui_elements$docs ) ) - - - - - - - -# ui <- bslib::page( -# theme = bslib::bs_theme( -# bootswatch = "minty", -# base_font = font_google("Inter"), -# code_font = font_google("JetBrains Mono") -# ), -# title = "fresearcheR - free, web-based research analyses", -# bslib::page_navbar( -# title = "fresearcheR - free, web-based research analyses", -# header = h6("Welcome to the fresearcheR tool. This is an early alpha version to act as a proof-of-concept and in no way intended for wider public use."), -# sidebar = bslib::sidebar( -# width = 300, -# open = "open", -# shiny::h4("Upload your dataset"), -# shiny::conditionalPanel( -# condition = "output.has_input=='yes'", -# # Input: Select a file ---- -# shiny::helpText("Analyses are performed on provided data") -# ), -# shiny::conditionalPanel( -# condition = "output.has_input=='no'", -# # Input: Select a file ---- -# shiny::radioButtons( -# inputId = "source", -# label = "Upload file or export from REDCap?", -# selected = "file", -# inline = TRUE, -# choices = list( -# "File" = "file", -# "REDCap" = "redcap" -# ) -# ), -# shiny::conditionalPanel( -# condition = "input.source=='file'", -# datamods::import_file_ui("file_import", -# file_extensions = c(".csv", ".txt", ".xls", ".xlsx", ".rds", ".fst", ".sas7bdat", ".sav",".ods",".dta")) -# ) -# , -# shiny::conditionalPanel( -# condition = "input.source=='redcap'", -# m_redcap_readUI("redcap_import") -# ), -# # Does not work?? -# # shiny::actionButton(inputId = "test_data", -# # label = "Load test data", class = "btn-primary") -# ), -# shiny::conditionalPanel( -# condition = "output.uploaded=='yes'", -# shiny::h4("Parameter specifications"), -# shiny::radioButtons( -# inputId = "factorize", -# label = "Factorize variables with few levels?", -# selected = "yes", -# inline = TRUE, -# choices = list( -# "Yes" = "yes", -# "No" = "no" -# ) -# ), -# shiny::radioButtons( -# inputId = "regression_auto", -# label = "Automatically choose function", -# inline = TRUE, -# choiceNames = c( -# "Yes", -# "No" -# ), -# choiceValues = c(1, 2) -# ), -# shiny::conditionalPanel( -# condition = "input.regression_auto==2", -# shiny::textInput( -# inputId = "regression_formula", -# label = "Formula string to render with 'glue::glue'", -# value = NULL -# ), -# shiny::textInput( -# inputId = "regression_fun", -# label = "Function to use for analysis (needs pasckage and name)", -# value = "stats::lm" -# ), -# shiny::textInput( -# inputId = "regression_args", -# label = "Arguments to pass to the function (provided as a string)", -# value = "" -# ) -# ), -# shiny::helpText(em("Please specify relevant settings for your data, and press 'Analyse'")), -# shiny::uiOutput("outcome_var"), -# shiny::uiOutput("strat_var"), -# shiny::conditionalPanel( -# condition = "input.strat_var!='none'", -# shiny::radioButtons( -# inputId = "add_p", -# label = "Compare strata?", -# selected = "no", -# inline = TRUE, -# choices = list( -# "No" = "no", -# "Yes" = "yes" -# ) -# ), -# shiny::helpText("Option to perform statistical comparisons between strata in baseline table.") -# ), -# shiny::radioButtons( -# inputId = "all", -# label = "Specify covariables", -# inline = TRUE, selected = 2, -# choiceNames = c( -# "Yes", -# "No" -# ), -# choiceValues = c(1, 2) -# ), -# shiny::conditionalPanel( -# condition = "input.all==1", -# shiny::uiOutput("include_vars") -# ), -# shiny::radioButtons( -# inputId = "specify_factors", -# label = "Specify categorical variables?", -# selected = "no", -# inline = TRUE, -# choices = list( -# "Yes" = "yes", -# "No" = "no" -# ) -# ), -# shiny::conditionalPanel( -# condition = "input.specify_factors=='yes'", -# shiny::uiOutput("factor_vars") -# ), -# bslib::input_task_button( -# id = "load", -# label = "Analyse", -# icon = shiny::icon("pencil", lib = "glyphicon"), -# label_busy = "Working...", -# icon_busy = fontawesome::fa_i("arrows-rotate", -# class = "fa-spin", -# "aria-hidden" = "true" -# ), -# type = "primary", -# auto_reset = TRUE -# ), -# shiny::helpText("If you change the parameters, press 'Analyse' again to update the tables"), -# # shiny::actionButton("load", "Analyse", class = "btn-primary"), -# # -# # # Horizontal line ---- -# tags$hr(), -# shiny::conditionalPanel( -# condition = "input.load", -# h4("Download results"), -# shiny::helpText("Choose your favourite output file format for further work."), -# shiny::selectInput( -# inputId = "output_type", -# label = "Choose your desired output format", -# selected = NULL, -# choices = list( -# "Word" = "docx", -# "LibreOffice" = "odt" -# # , -# # "PDF" = "pdf", -# # "All the above" = "all" -# ) -# ), -# -# # Button -# downloadButton( -# outputId = "report", -# label = "Download", -# icon = shiny::icon("download") -# ) -# ) -# ) -# ), -# bslib::nav_spacer(), -# panels[[1]], -# panels[[2]], -# panels[[3]], -# panels[[4]] -# -# # layout_columns( -# # cards[[1]] -# # ), -# # layout_columns( -# # cards[[2]], cards[[3]] -# # ) -# ) -# )