new version of a minimally working example

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")
+#   if (identical(breaks, "hour")) {
-# classInt::classIntervals(readr::parse_time(c("01:00:20","03:00:20","01:20:20","03:02:20")), 2, style = "quantile")
+#     # splitter <- match(
-# int_x|> dput()
+#     #   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"))
+#   if (is.numeric(breaks)) {
-# cut(x)
+#     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)) |>
+#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut("min")
-#'   cut() |>
+#' 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")
-#'   dput()
+#' 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")))
-cut.hms <- function(x, breaks = "hour", ...) {
+#' d_t <- readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA))
-  browser()
+#' f <- d_t |> cut(2)
-  # For now, this function will allways try to cut to hours
+#' 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)
-  # This limits time cutting to only do hour-binning, no matter the
+cut.hms <- function(x, breaks, ...) {
-  if (length(breaks) != 1) {
+  if (hms::is_hms(breaks)) {
-    if ("hms" %in% class(breaks)) {
+    breaks <- lubridate::as_datetime(breaks, tz = "UTC")
-
-    } else {
-      breaks <- "hour"
   }
-  }
+  x <- lubridate::as_datetime(x, tz = "UTC")
-  if (!breaks %in% c("hour", "dn")) {
+  out <- cut.POSIXt(x, breaks = breaks, ...)
-    if (is.numeric(breaks)) {
+  attr(out, which = "brks") <- hms::as_hms(lubridate::as_datetime(attr(out, which = "brks")))
-      breaks_n <- quantile(x, probs = seq(0, 1, 1 / breaks))
+  attr(out, which = "levels") <- as.character(hms::as_hms(lubridate::as_datetime(attr(out, which = "levels"))))
-      ## Use lapply or similar to go through levels two at a time
+  out
-
-    } 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
+#' @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(
+        shiny::uiOutput(ns("cut_method"))
-          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,
@@ -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)),
+          min = lower,
-          max = ceiling(max(data[[variable]], na.rm = TRUE)),
+          max = upper,
-          value = classInt::classIntervals(
+          value = brks,
-            var = as.numeric(data[[variable]]),
-            n = input$n_breaks,
-            style = "quantile"
-          )$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)
+          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
         )

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)
+  from_env <- import_globalenv_server(
-  #
+    id = "env",
-  # shiny::observeEvent(data_file$data(), {
+    trigger_return = "change",
-  #   data_rv$data <- data_file$data() |>
+    btn_show_data = FALSE,
-  #           REDCapCAST::numchar2fct()
+    reset = reactive(input$hidden)
-  # })
+  )
-  #
-  # shiny::observeEvent(purrr::pluck(ds(), "data")(), {
-  #   data_rv$data <- purrr::pluck(ds(), "data")() |>
-  #           REDCapCAST::parse_data() |>
-  #           REDCapCAST::as_factor() |>
-  #           REDCapCAST::numchar2fct()
-  # })
 
+  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) {
+    # if (v$input) {
-      out <- webResearch_data
+    #   out <- webResearch_data
-    } else if (input$source == "file") {
+    # } else if (input$source == "file") {
-      req(data_file$data())
+    #   req(data_file$data())
-      out <- data_file$data()
+    #   out <- data_file$data()
-    } else if (input$source == "redcap") {
+    # } else if (input$source == "redcap") {
-      req(purrr::pluck(data_redcap(), "data")())
+    #   req(purrr::pluck(data_redcap(), "data")())
-      out <- purrr::pluck(data_redcap(), "data")()
+    #   out <- purrr::pluck(data_redcap(), "data")()
-    }
-
-    v$ds <- "loaded"
-    # browser()
-    # if (input$factorize == "yes") {
-    #   out <- out |>
-    #     REDCapCAST::numchar2fct()
     # }
-    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() ))
+  shiny::observeEvent(rv$data_original, rv$data <- rv$data_original)
-
+  shiny::observeEvent(input$data_reset, rv$data <- rv$data_original)
-  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"))
+  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({
+  output$table_mod <- toastui::renderDatagrid({
-    req(rv$data)
+    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, {
+  # shiny::observeEvent(data_filter(), {
-    rv$data <- data_filter()
+  #   rv$data_filtered <- data_filter()
-  })
+  # })
 
   output$filtered_code <- shiny::renderPrint({
-    gsub("reactive(rv$data)", "data",
+    cat(gsub(
-         cat(gsub("%>%", "|> \n ",
+      "%>%", "|> \n ",
-             gsub("\\s{2,}", " ",
+      gsub(
+        "\\s{2,}", " ",
+        gsub(
+          "reactive(rv$data)", "data",
           paste0(
             capture.output(attr(data_filter(), "code")),
-                    collapse = " "))
+            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()
 
-
+      rv$list <- list(
-      v$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")

inst/apps/data_analysis_modules/ui.R

@@ -19,22 +19,21 @@ ui_elements <- list(
       column(
         width = 6,
         shiny::h4("Choose your data source"),
-        shiny::conditionalPanel(
+        # shiny::conditionalPanel(
-          condition = "output.has_input=='yes'",
+        #   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::helpText("Analyses are performed on provided data")
+        shinyWidgets::radioGroupButtons(
-        ),
-        shiny::conditionalPanel(
-          condition = "output.has_input=='no'",
-          # Input: Select a file ----
-          shiny::radioButtons(
           inputId = "source",
-            label = "Upload file or export from REDCap?",
+          # label = "Choice: ",
-            selected = "file",
+          choices = c("File upload" = "file", "REDCap server" = "redcap","Sample data"="env"),
-            inline = TRUE,
+          checkIcon = list(
-            choices = list(
+            yes = icon("square-check"),
-              "File" = "file",
+            no = icon("square")
-              "REDCap" = "redcap"
           )
         ),
         shiny::conditionalPanel(
@@ -47,8 +46,14 @@ ui_elements <- list(
         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,9 +78,13 @@ ui_elements <- list(
   #########  Data overview panel
   #########
   ##############################################################################
-  "overview" = bslib::nav_panel(
+  "overview" =
+    # bslib::nav_panel_hidden(
+    bslib::nav_panel(
+      # value = "overview",
       title = "Overview and modifications",
-    bslib::navset_bar(fillable = TRUE,
+      bslib::navset_bar(
+        fillable = TRUE,
         # bslib::nav_panel(
         #   title = "Edit",
         #   datamods::edit_data_ui(id = "edit_data")
@@ -90,8 +99,11 @@ ui_elements <- list(
           fluidRow(
             column(
               width = 6,
-            # radioButtons()
+              # 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(
@@ -125,20 +137,20 @@ ui_elements <- list(
             # ),
             shiny::column(
               width = 8,
-            toastui::datagridOutput2(outputId = "table_mod"),
+              toastui::datagridOutput(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::actionButton("modal_cut", "Create factor from a variable"),
               shiny::tags$br(),
               shiny::tags$br(),
-            shiny::actionButton("modal_update", "Update factor's levels"),
+              shiny::actionButton("modal_update", "Reorder factor levels"),
               shiny::tags$br(),
               shiny::tags$br(),
-            IDEAFilter::IDEAFilter_ui("data_filter"),
+              IDEAFilter::IDEAFilter_ui("data_filter") # ,
-            shiny::actionButton("save_filter", "Apply the filter")
+              # shiny::actionButton("save_filter", "Apply the filter")
             )
           )
         )
@@ -157,8 +169,11 @@ ui_elements <- list(
   #########  Data analyses panel
   #########
   ##############################################################################
-  "analyze" = bslib::nav_panel(
+  "analyze" =
-    title = "Analysis",
+    # bslib::nav_panel_hidden(
+    bslib::nav_panel(
+      # value = "analyze",
+      title = "Analyses",
       bslib::navset_bar(
         title = "",
         # bslib::layout_sidebar(
@@ -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]]
-#     # )
-#   )
-# )