diff --git a/DESCRIPTION b/DESCRIPTION index ca0e24c..d52d41a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -41,7 +41,10 @@ Imports: IDEAFilter, sparkline, datamods, - toastui + toastui, + webshot, + matPkg, + lubridate Suggests: styler, devtools, diff --git a/R/cut-variable-dates.R b/R/cut-variable-dates.R new file mode 100644 index 0000000..43b85c4 --- /dev/null +++ b/R/cut-variable-dates.R @@ -0,0 +1,458 @@ +library(datamods) +library(toastui) +library(phosphoricons) +library(rlang) + +# x <- lubridate::as_datetime(seq(1,1000000,2000), origin = "2000-12-31") +# class(x) +# +# lubridate::hms(c("01:00:20")) +# +# 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() +# +# library(hms) +# +# ?cut.POSIXt +# +# x <- readr::parse_time(c("01:00:20","03:00:20","01:20:20","03:02:20")) +# cut(x) + +#' Title +#' +#' @param x an object inheriting from class "hms" +#' @param breaks Can be "hour" or "dn" +#' @param ... passed on +#' +#' @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" + } + } + 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") +} + +#' Title +#' +#' @param data data +#' @param class.vec vector of class names to test +#' +#' @return +#' @export +#' +#' @examples +#' vapply(REDCapCAST::redcapcast_data, \(.x){ +#' is_any_class(.x, c("hms", "Date", "POSIXct", "POSIXt")) +#' }, logical(1)) +is_any_class <- function(data, class.vec) { + any(class(data) %in% class.vec) +} + +#' Title +#' +#' @param data data +#' +#' @return +#' @export +#' +#' @examples +#' vapply(REDCapCAST::redcapcast_data, is_datetime, logical(1)) +is_datetime <- function(data) { + is_any_class(data, class.vec = c("hms", "Date", "POSIXct", "POSIXt")) +} + +#' @title Module to Convert Numeric to Factor +#' +#' @description +#' This module contain an interface to cut a numeric into several intervals. +#' +#' +#' @param id Module ID. +#' +#' @return A [shiny::reactive()] function returning the data. +#' @export +#' +#' @importFrom shiny NS fluidRow column numericInput checkboxInput checkboxInput plotOutput uiOutput +#' @importFrom shinyWidgets virtualSelectInput +#' @importFrom toastui datagridOutput2 +#' +#' @name cut-variable +#' +#' @example examples/cut_variable.R +cut_variable_ui <- function(id) { + ns <- NS(id) + tagList( + fluidRow( + column( + width = 3, + virtualSelectInput( + inputId = ns("variable"), + label = i18n("Variable to cut:"), + choices = NULL, + width = "100%" + ) + ), + 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%" + ) + ), + column( + width = 3, + numericInput( + inputId = ns("n_breaks"), + label = i18n("Number of breaks:"), + value = 5, + min = 2, + max = 12, + width = "100%" + ) + ), + column( + width = 3, + checkboxInput( + inputId = ns("right"), + label = i18n("Close intervals on the right"), + value = TRUE + ), + checkboxInput( + inputId = ns("include_lowest"), + label = i18n("Include lowest value"), + value = TRUE + ) + ) + ), + conditionalPanel( + condition = "input.method == 'fixed'", + ns = ns, + uiOutput(outputId = ns("slider_fixed")) + ), + plotOutput(outputId = ns("plot"), width = "100%", height = "270px"), + datagridOutput2(outputId = ns("count")), + actionButton( + inputId = ns("create"), + label = tagList(ph("scissors"), i18n("Create factor variable")), + class = "btn-outline-primary float-end" + ), + tags$div(class = "clearfix") + ) +} + +#' @param data_r A [shiny::reactive()] function returning a `data.frame`. +#' +#' @export +#' +#' @importFrom shiny moduleServer observeEvent reactive req bindEvent renderPlot +#' @importFrom shinyWidgets updateVirtualSelect noUiSliderInput +#' @importFrom toastui renderDatagrid2 datagrid grid_colorbar +#' @importFrom rlang %||% call2 set_names expr syms +#' @importFrom classInt classIntervals +#' +#' @rdname cut-variable +cut_variable_server <- function(id, data_r = reactive(NULL)) { + moduleServer( + id, + function(input, output, session) { + rv <- reactiveValues(data = NULL) + + bindEvent(observe({ + data <- data_r() + rv$data <- data + vars_num <- vapply(data, \(.x){ + is.numeric(.x) || is_datetime(.x) + }, logical(1)) + vars_num <- names(vars_num)[vars_num] + updateVirtualSelect( + inputId = "variable", + choices = vars_num, + selected = if (isTruthy(input$variable)) input$variable else vars_num[1] + ) + }), data_r(), input$hidden) + + output$slider_fixed <- renderUI({ + data <- req(data_r()) + variable <- req(input$variable) + req(hasName(data, variable)) + 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, + color = datamods:::get_primary_color(), + width = "100%" + ) + }) + + breaks_r <- reactive({ + data <- req(data_r()) + variable <- req(input$variable) + req(hasName(data, variable)) + 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 + ) + } else if (input$method %in% c( + "day", + "week", + "month", + "quarter", + "year" + )) { + # To enable datetime cutting + cut.POSIXct <- cut.POSIXt + f <- cut(data[[variable]], breaks = input$method) + list(var = f, brks = levels(f)) + } else if (input$method %in% c("hour")) { + # To enable datetime cutting + cut.POSIXct <- cut.POSIXt + f <- cut(data[[variable]], breaks = "hour") + list(var = f, brks = levels(f)) + } else { + classInt::classIntervals( + var = as.numeric(data[[variable]]), + n = input$n_breaks, + style = input$method + ) + } + }) + + output$plot <- renderPlot({ + data <- req(data_r()) + variable <- req(input$variable) + plot_histogram(data, variable, breaks = breaks_r()$brks, color = datamods:::get_primary_color()) + }) + + + data_cutted_r <- reactive({ + data <- req(data_r()) + 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, + include.lowest = input$include_lowest, + right = input$right + ) + code <- call2( + "mutate", + !!!set_names( + list( + expr(cut( + !!!syms(list(x = variable)), + !!!list(breaks = breaks_r()$brks, include.lowest = input$include_lowest, right = input$right) + )) + ), + paste0(variable, "_cut") + ) + ) + attr(data, "code") <- Reduce( + f = function(x, y) expr(!!x %>% !!y), + x = c(attr(data, "code"), code) + ) + data + }) + + output$count <- renderDatagrid2({ + data <- req(data_cutted_r()) + variable <- req(input$variable) + count_data <- as.data.frame( + table( + breaks = data[[paste0(variable, "_cut")]], + useNA = "ifany" + ), + responseName = "count" + ) + gridTheme <- getOption("datagrid.theme") + if (length(gridTheme) < 1) { + datamods:::apply_grid_theme() + } + on.exit(toastui::reset_grid_theme()) + grid <- datagrid( + data = count_data, + colwidths = "guess", + theme = "default", + bodyHeight = "auto" + ) + grid <- toastui::grid_columns(grid, className = "font-monospace") + grid_colorbar( + grid, + column = "count", + label_outside = TRUE, + label_width = "40px", + bar_bg = datamods:::get_primary_color(), + from = c(0, max(count_data$count) + 1) + ) + }) + + data_returned_r <- observeEvent(input$create, { + rv$data <- data_cutted_r() + }) + return(reactive(rv$data)) + } + ) +} + + + +#' @inheritParams shiny::modalDialog +#' @export +#' +#' @importFrom shiny showModal modalDialog textInput +#' @importFrom htmltools tagList +#' +#' @rdname cut-variable +modal_cut_variable <- function(id, + title = i18n("Convert Numeric to Factor"), + easyClose = TRUE, + size = "l", + footer = NULL) { + ns <- NS(id) + showModal(modalDialog( + title = tagList(title, datamods:::button_close_modal()), + cut_variable_ui(id), + tags$div( + style = "display: none;", + textInput(inputId = ns("hidden"), label = NULL, value = datamods:::genId()) + ), + easyClose = easyClose, + size = size, + footer = footer + )) +} + + +#' @inheritParams shinyWidgets::WinBox +#' @export +#' +#' @importFrom shinyWidgets WinBox wbOptions wbControls +#' @importFrom htmltools tagList +#' @rdname cut-variable +winbox_cut_variable <- function(id, + title = i18n("Convert Numeric to Factor"), + options = shinyWidgets::wbOptions(), + controls = shinyWidgets::wbControls()) { + ns <- NS(id) + WinBox( + title = title, + ui = tagList( + cut_variable_ui(id), + tags$div( + style = "display: none;", + textInput(inputId = ns("hidden"), label = NULL, value = genId()) + ) + ), + options = modifyList( + shinyWidgets::wbOptions(height = "750px", modal = TRUE), + options + ), + controls = controls, + auto_height = FALSE + ) +} + + +#' @importFrom graphics abline axis hist par plot.new plot.window +plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112466") { + x <- data[[column]] + x <- as.numeric(x) + op <- par(mar = rep(1.5, 4)) + on.exit(par(op)) + plot.new() + plot.window(xlim = range(pretty(x)), ylim = range(pretty(hist(x, breaks = bins, plot = FALSE)$counts))) + abline(v = pretty(x), col = "#D8D8D8") + abline(h = pretty(hist(x, breaks = bins, plot = FALSE)$counts), col = "#D8D8D8") + hist(x, breaks = bins, xlim = range(pretty(x)), xaxs = "i", yaxs = "i", col = color, add = TRUE) + axis(side = 1, at = pretty(x), pos = 0) + axis(side = 2, at = pretty(hist(x, breaks = bins, plot = FALSE)$counts), pos = min(pretty(x))) + abline(v = breaks, col = "#FFFFFF", lty = 1, lwd = 1.5) + abline(v = breaks, col = "#2E2E2E", lty = 2, lwd = 1.5) +} diff --git a/R/helpers.R b/R/helpers.R index 5c4efca..f537d80 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -149,7 +149,10 @@ file_export <- function(data, output.format = c("df", "teal", "list"), filename, datanames(out) <- filename } else if (output.format == "df") { - out <- data + out <- data|> + REDCapCAST::parse_data() |> + REDCapCAST::as_factor() |> + REDCapCAST::numchar2fct() } else if (output.format == "list") { out <- list( data = data, diff --git a/R/modules.R b/R/modules.R index 8da7b6e..43b7024 100644 --- a/R/modules.R +++ b/R/modules.R @@ -6,7 +6,7 @@ #' @export #' m_datafileUI <- function(id) { - ns <- NS(id) + ns <- shiny::NS(id) shiny::tagList( shiny::fileInput( inputId = ns("file"), @@ -22,7 +22,7 @@ m_datafileUI <- function(id) { ) ), shiny::h4("Parameter specifications"), - shiny::helpText(em("Select the desired variables and press 'Submit'")), + shiny::helpText(shiny::em("Select the desired variables and press 'Submit'")), shiny::uiOutput(ns("include_vars")), DT::DTOutput(ns("data_input")), shiny::actionButton(ns("submit"), "Submit") @@ -38,7 +38,7 @@ m_datafileServer <- function(id, output.format = "df") { output$include_vars <- shiny::renderUI({ shiny::req(input$file) - selectizeInput( + shiny::selectizeInput( inputId = ns("include_vars"), selected = NULL, label = "Covariables to include", @@ -81,38 +81,44 @@ m_datafileServer <- function(id, output.format = "df") { #' Shiny module to browser and export REDCap data #' #' @param id Namespace id +#' @param include_title logical to include title +#' #' @rdname redcap_read_shiny_module #' #' @return shiny ui element #' @export -m_redcap_readUI <- function(id) { +m_redcap_readUI <- function(id, include_title = TRUE) { ns <- shiny::NS(id) - server_ui <- fluidRow( - column( - width = 6, - shiny::textInput( - inputId = ns("uri"), - label = "URI", - value = "https://redcap.your.institution/api/" - ), - shiny::textInput( - inputId = ns("api"), - label = "API token", - value = "" - ) + server_ui <- shiny::column( + width = 6, + shiny::tags$h4("REDCap server information"), + shiny::textInput( + inputId = ns("uri"), + label = "URI/Address", + value = "https://redcap.your.institution/api/" + ), + shiny::textInput( + inputId = ns("api"), + label = "API token", + value = "" ) ) - params_ui <- fluidRow( - column( + + params_ui <- + shiny::column( width = 6, + shiny::tags$h4("Data import parameters"), + shiny::helpText("Options here will show, when API and uri are typed"), shiny::uiOutput(outputId = ns("fields")), shinyWidgets::switchInput( inputId = "do_filter", label = "Apply filter?", value = FALSE, - inline = TRUE + inline = FALSE, + onLabel = "YES", + offLabel = "NO" ), # shiny::radioButtons( # inputId = "do_filter", @@ -133,14 +139,35 @@ m_redcap_readUI <- function(id) { ) ) ) - ) + shiny::fluidPage( + if (include_title) shiny::tags$h3("Import data from REDCap"), + fluidRow( server_ui, - params_ui, - shiny::actionButton(inputId = ns("import"), label = "Import"), - shiny::br(), - DT::DTOutput(outputId = ns("table")) + params_ui), + shiny::column( + width = 12, + # shiny::actionButton(inputId = ns("import"), label = "Import"), + bslib::input_task_button( + id = ns("import"), + label = "Import", + icon = shiny::icon("download", lib = "glyphicon"), + label_busy = "Just a minute...", + icon_busy = fontawesome::fa_i("arrows-rotate", + class = "fa-spin", + "aria-hidden" = "true" + ), + type = "primary", + auto_reset = TRUE + ), + shiny::helpText("Press 'Import' after having specified API token and URI to export data from the REDCap server. A preview will show below the DataDictionary."), + shiny::br(), + shiny::br(), + shiny::br(), + DT::DTOutput(outputId = ns("table")) + # toastui::datagridOutput2(outputId = ns("table")) + ) # toastui::datagridOutput2(outputId = ns("table")), # toastui::datagridOutput2(outputId = ns("data")), # shiny::actionButton(inputId = ns("submit"), label = "Submit"), @@ -161,30 +188,58 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) { # ns <- shiny::NS(id) ns <- session$ns + # data_list <- shiny::reactiveValues( + # dict = NULL, + # stat = NULL, + # arms = NULL, + # data = NULL, + # name = NULL + # ) + dd <- shiny::reactive({ shiny::req(input$api) shiny::req(input$uri) + REDCapR::redcap_metadata_read( - redcap_uri = input$uri, - token = input$api - )$data + redcap_uri = input$uri, + token = input$api + )$data }) + # dd <- shiny::reactive({ + # shiny::req(input$api) + # shiny::req(input$uri) + # + # + # out <- REDCapR::redcap_metadata_read( + # redcap_uri = input$uri, + # token = input$api + # ) + # + # data_list$dict <- out$data + # data_list$stat <- out$success + # + # out$data + # }) + arms <- shiny::reactive({ shiny::req(input$api) shiny::req(input$uri) REDCapR::redcap_event_read( - redcap_uri = input$uri, - token = input$api - )$data + redcap_uri = input$uri, + token = input$api + )$data + + # data_list$arms <- out + # out }) output$fields <- shiny::renderUI({ shinyWidgets::virtualSelectInput( inputId = ns("fields"), - label = "Multiple select:", + label = "Select fields/variables to import:", choices = dd() |> dplyr::select(field_name, form_name) |> (\(.x){ @@ -193,7 +248,9 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) { # stats::setNames(instr()[["data"]][[2]]) , updateOn = "close", - multiple = TRUE + multiple = TRUE, + search = TRUE, + showValueAsTags = TRUE ) }) @@ -212,8 +269,10 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) { { shiny::req(input$api) shiny::req(input$uri) + # shiny::req(data_list$dict) # dd()[["data"]][c(1,2,4,5,6,8)] - data.df <- dd()[c(1, 2, 4, 5, 6, 8)] + # browser() + data.df <- dd()[, c(1, 2, 4, 5, 6, 8)] DT::datatable(data.df, caption = "Subset of data dictionary" ) @@ -221,7 +280,20 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) { server = TRUE ) - name <- reactive({ + # Messes up the overlay of other objects. JS thing? + # output$table <- toastui::renderDatagrid2( + # { + # shiny::req(input$api) + # shiny::req(input$uri) + # # shiny::req(data_list$dict) + # # dd()[["data"]][c(1,2,4,5,6,8)] + # # browser() + # toastui::datagrid(dd()[,c(1, 2, 4, 5, 6, 8)] + # ) + # } + # ) + + name <- shiny::reactive({ shiny::req(input$api) REDCapR::redcap_project_info_read( redcap_uri = input$uri, @@ -231,6 +303,7 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) { shiny::eventReactive(input$import, { shiny::req(input$api) + shiny::req(input$fields) record_id <- dd()[[1]][1] redcap_data <- REDCapCAST::read_redcap_tables( @@ -254,12 +327,11 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) { if (output.format == "list") { out <- list( - data = shiny::reactive(redcap_data), - meta = dd()[["dd"]], - name = name, - filter = input$filter - ) - + data = shiny::reactive(redcap_data), + meta = dd(), + name = name(), + filter = input$filter + ) } else { out <- out_object } @@ -274,7 +346,6 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) { ) } - tdm_redcap_read <- teal::teal_data_module( ui <- function(id) { shiny::fluidPage( @@ -299,26 +370,111 @@ tdm_data_upload <- teal::teal_data_module( redcap_app <- function() { - ui <- fluidPage( + ui <- shiny::fluidPage( m_redcap_readUI("data"), - DT::DTOutput(outputId = "redcap_prev") + # DT::DTOutput(outputId = "redcap_prev") + toastui::datagridOutput2(outputId = "redcap_prev"), + shiny::fluidRow( + shiny::column( + 8, + # verbatimTextOutput("data_filter_code"), + DT::DTOutput("data_summary") + ), + shiny::column(4, IDEAFilter::IDEAFilter_ui("data_filter")) + ) ) server <- function(input, output, session) { - ds <- m_redcap_readServer("data") - output$redcap_prev <- DT::renderDT( - { + data_val <- shiny::reactiveValues(data=NULL) - # df <- shiny::isolate(data_redcap()) - # browser() - # - DT::datatable(ds(), - caption = "Observations" - ) + ds <- m_redcap_readServer("data", output.format = "df") + # output$redcap_prev <- DT::renderDT( + # { + # DT::datatable(purrr::pluck(ds(), "data")(), + # caption = "Observations" + # ) + # }, + # server = TRUE + # ) + + # shiny::reactive({ + # data_val$data <- purrr::pluck(ds(), "data")() + # }) + + output$redcap_prev <- toastui::renderDatagrid2({ + # toastui::datagrid(purrr::pluck(ds(), "data")()) + # toastui::datagrid(data_val$data) + toastui::datagrid(ds()) + }) + + filtered_data <- IDEAFilter::IDEAFilter("data_filter", + data = ds, + verbose = FALSE) + + # filtered_data <- shiny::reactive({ + # IDEAFilter::IDEAFilter("data_filter", + # data = purrr::pluck(ds(), "data")(), + # verbose = FALSE) + # }) + + # output$data_filter_code <- renderPrint({ + # cat(gsub( + # "%>%", "%>% \n ", + # gsub( + # "\\s{2,}", " ", + # paste0( + # capture.output(attr(filtered_data(), "code")), + # collapse = " " + # ) + # ) + # )) + # }) + + output$data_summary <- DT::renderDataTable( + { + filtered_data() }, - server = TRUE + options = list( + scrollX = TRUE, + pageLength = 5 + ) ) } - shinyApp(ui, server) + shiny::shinyApp(ui, server) } + redcap_app() + + +file_app <- function() { + ui <- shiny::fluidPage( + m_datafileUI("data"), + # DT::DTOutput(outputId = "redcap_prev") + toastui::datagridOutput2(outputId = "redcap_prev") + ) + server <- function(input, output, session) { + m_datafileServer("data", output.format = "list") + } + shiny::shinyApp(ui, server) +} + +file_app() + + +tdm_data_read <- teal::teal_data_module( + ui <- function(id) { + shiny::fluidPage( + m_redcap_readUI(id = "redcap") + ) + }, + server = function(id) { + moduleServer( + id, + function(input, output, session) { + ns <- session$ns + + m_redcap_readServer(id = "redcap", output.format = "teal") + } + ) + } +) diff --git a/inst/apps/data_analysis_modules/server.R b/inst/apps/data_analysis_modules/server.R index 43ba086..4c634ec 100644 --- a/inst/apps/data_analysis_modules/server.R +++ b/inst/apps/data_analysis_modules/server.R @@ -23,6 +23,9 @@ library(REDCapCAST) library(easystats) library(patchwork) library(DHARMa) +library(datamods) +library(toastui) +library(IDEAFilter) # if (!requireNamespace("webResearch")) { # devtools::install_github("agdamsbo/webResearch", quiet = TRUE, upgrade = "never") # } @@ -43,13 +46,14 @@ server <- function(input, output, session) { input = exists("webResearch_data"), local_temp = NULL, quarto = NULL, - test = "no" + test = "no", + data = NULL ) data_file <- datamods::import_file_server( id = "file_import", show_data_in = "popup", - trigger_return = "button", + trigger_return = "change", return_class = "data.frame", read_fns = list( ods = function(file) { @@ -68,13 +72,28 @@ server <- function(input, output, session) { output$redcap_prev <- DT::renderDT( { - DT::datatable(head(purrr::pluck(data_redcap(), 1)(), 5), + DT::datatable(head(purrr::pluck(data_redcap(), "data")(), 5), caption = "First 5 observations" ) }, 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() + # }) + + ds <- shiny::reactive({ # input$file1 will be NULL initially. After the user selects # and uploads a file, head of that data file by default, @@ -82,13 +101,11 @@ server <- function(input, output, session) { if (v$input) { out <- webResearch_data } else if (input$source == "file") { - out <- data_file$data() |> - REDCapCAST::numchar2fct() + req(data_file$data()) + out <- data_file$data() } else if (input$source == "redcap") { - out <- purrr::pluck(data_redcap(), 1)() |> - REDCapCAST::parse_data() |> - REDCapCAST::as_factor() |> - REDCapCAST::numchar2fct() + req(purrr::pluck(data_redcap(), "data")()) + out <- purrr::pluck(data_redcap(), "data")() } v$ds <- "loaded" @@ -97,53 +114,206 @@ server <- function(input, output, session) { # out <- out |> # REDCapCAST::numchar2fct() # } + out <- out|> + REDCapCAST::parse_data() |> + REDCapCAST::as_factor() |> + REDCapCAST::numchar2fct() + + data_rv$data <- shiny::reactive(out) out }) + # 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 + ######### + ############################################################################## + + ######### Modifications + + rv <- shiny::reactiveValues(data = reactive(ds() )) + + observeEvent(ds(), rv$data <- ds()) + observeEvent(input$data_reset, rv$data <- ds()) + + ## 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")) + data_modal_cut <- cut_variable_server( + id = "modal_cut", + data_r = reactive(rv$data) + ) + observeEvent(data_modal_cut(), rv$data <- data_modal_cut()) + + + 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::removeModal() + rv$data <- data_modal_update() + }) + + + + # Show result + output$table_mod <- toastui::renderDatagrid2({ + req(rv$data) + # data <- rv$data + toastui::datagrid( + data = rv$data#, + # bordered = TRUE, + # compact = TRUE, + # striped = TRUE + ) + }) + + output$code <- renderPrint({ + attr(rv$data, "code") + }) + + updated_data <- datamods::update_variables_server( + id = "vars_update", + data = reactive(rv$data), + return_data_on_init = FALSE + ) + + output$original_str <- renderPrint({ + str(ds()) + }) + + output$modified_str <- renderPrint({ + str(rv$data) + }) + + observeEvent(updated_data(), { + 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() + }) + + output$filtered_code <- shiny::renderPrint({ + gsub("reactive(rv$data)", "data", + cat(gsub("%>%", "|> \n ", + gsub("\\s{2,}", " ", + paste0( + capture.output(attr(data_filter(), "code")), + collapse = " ")) + ))) + }) + + + + ############################################################################## + ######### + ######### Data analyses section + ######### + ############################################################################## + + ## Keep these "old" selection options as a simple alternative to the modification pane + output$include_vars <- shiny::renderUI({ - selectizeInput( + shiny::selectizeInput( inputId = "include_vars", selected = NULL, label = "Covariables to include", - choices = colnames(ds()), + choices = colnames(rv$data), multiple = TRUE ) }) output$outcome_var <- shiny::renderUI({ - selectInput( + shiny::selectInput( inputId = "outcome_var", selected = NULL, label = "Select outcome variable", - choices = colnames(ds()), + choices = colnames(rv$data), multiple = FALSE ) }) output$strat_var <- shiny::renderUI({ - selectInput( + shiny::selectInput( inputId = "strat_var", selected = "none", label = "Select variable to stratify baseline", - choices = c("none", colnames(ds()[base_vars()])), + choices = c("none", colnames(rv$data[base_vars()])), multiple = FALSE ) }) output$factor_vars <- shiny::renderUI({ - selectizeInput( + shiny::selectizeInput( inputId = "factor_vars", - selected = colnames(ds())[sapply(ds(), is.factor)], + selected = colnames(rv$data)[sapply(rv$data, is.factor)], label = "Covariables to format as categorical", - choices = colnames(ds()), + choices = colnames(rv$data), multiple = TRUE ) }) base_vars <- shiny::reactive({ if (is.null(input$include_vars)) { - out <- colnames(ds()) + out <- colnames(rv$data) } else { out <- unique(c(input$include_vars, input$outcome_var)) } @@ -171,7 +341,7 @@ server <- function(input, output, session) { }) shiny::observeEvent(input$act_start, { - bslib::nav_select(id = "main_panel", selected = "Data analysis") + bslib::nav_select(id = "main_panel", selected = "Overview and modifications") }) shiny::observeEvent( @@ -180,12 +350,13 @@ server <- function(input, output, session) { }, { shiny::req(input$outcome_var) - + # browser() # Assumes all character variables can be formatted as factors - data <- ds() |> - dplyr::mutate(dplyr::across(dplyr::where(is.character), as.factor)) - - data <- data |> factorize(vars = input$factor_vars) + # data <- data_filter$filtered() |> + data <- rv$data |> + 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 diff --git a/inst/apps/data_analysis_modules/ui.R b/inst/apps/data_analysis_modules/ui.R index 3e46894..c1397c6 100644 --- a/inst/apps/data_analysis_modules/ui.R +++ b/inst/apps/data_analysis_modules/ui.R @@ -8,68 +8,149 @@ requireNamespace("gt") # ns <- NS(id) ui_elements <- list( - # bslib::nav_panel( - # 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.input") - # ), - # 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") - # ), ############################################################################## ######### ######### Import panel ######### ############################################################################## "import" = bslib::nav_panel( - title = "Data import", - 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" + title = "Import", + shiny::fluidRow( + 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=='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") + ) ) ), - 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"), - DT::DTOutput(outputId = "redcap_prev") + column( + width = 6, + shiny::markdown(" + # Welcome + + This is the ***freesearchR*** web data analysis tool. An opiniotaed tool for easy data analysis at the hands of the clinician. + + By intention, this is a focused app, with only few data modification tools included to keep the workflow streamlined. + ") ) ), + shiny::conditionalPanel( + condition = "input.source=='redcap'", + DT::DTOutput(outputId = "redcap_prev") + ), shiny::br(), - shiny::actionButton(inputId = "act_start",label = "Start") + shiny::actionButton(inputId = "act_start", label = "Start") + ), + ############################################################################## + ######### + ######### 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") + ) + ) + ) + + + # column( + # 8, + # shiny::verbatimTextOutput("filtered_code"), + # DT::DTOutput("filtered_table") + # ), + # column(4, IDEAFilter::IDEAFilter_ui("data_filter")) + ) ), ############################################################################## ######### @@ -77,77 +158,72 @@ ui_elements <- list( ######### ############################################################################## "analyze" = bslib::nav_panel( - title = "Data analysis", - bslib::page_navbar( + 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'", - 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.") - ), + 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 = "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?", + inputId = "add_p", + label = "Compare strata?", selected = "no", inline = TRUE, choices = list( - "Yes" = "yes", - "No" = "no" + "No" = "no", + "Yes" = "yes" ) ), - shiny::conditionalPanel( - condition = "input.specify_factors=='yes'", - shiny::uiOutput("factor_vars") + 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" ), - 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 + 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" ), - shiny::helpText("If you change the parameters, press 'Analyse' again to update the tables") + type = "primary", + auto_reset = TRUE + ), + shiny::helpText("If you change the parameters, press 'Analyse' again to update the tables") # ) ), - bslib::nav_spacer(), - bslib::nav_panel( - title = "Data overview", - DT::DTOutput(outputId = "data_table") - ), bslib::nav_panel( title = "Baseline characteristics", gt::gt_output(outputId = "table1") @@ -168,22 +244,22 @@ ui_elements <- list( ######### ############################################################################## "docs" = bslib::nav_panel( - title = "Intro", + title = "Documentation", shiny::markdown(readLines("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") - # ), +# "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") @@ -210,6 +286,7 @@ ui <- bslib::page( bslib::page_navbar( id = "main_panel", ui_elements$import, + ui_elements$overview, ui_elements$analyze, ui_elements$docs ) diff --git a/inst/apps/teal_test/app.R b/inst/apps/teal_test/app.R index 344a631..76a194c 100644 --- a/inst/apps/teal_test/app.R +++ b/inst/apps/teal_test/app.R @@ -97,6 +97,8 @@ footer <- tags$p( # redcap_browser_app <- teal_init(data = tdm_data_upload) app <- teal::init( + # data=tdm_data_read, + # data = tdm_data_upload, data = tdm_redcap_read, filter = filters, modules = modules(