new version of a minimally working example

This commit is contained in:
Andreas Gammelgaard Damsbo 2024-12-16 22:21:54 +01:00
parent 7b1d55ebc8
commit fb2569c647
No known key found for this signature in database
3 changed files with 546 additions and 658 deletions

View file

@ -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)
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
)

View file

@ -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,}", " ",
cat(gsub(
"%>%", "|> \n ",
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()
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")

View file

@ -19,22 +19,21 @@ ui_elements <- list(
column(
width = 6,
shiny::h4("Choose your data source"),
shiny::conditionalPanel(
condition = "output.has_input=='yes'",
# 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::helpText("Analyses are performed on provided data")
),
shiny::conditionalPanel(
condition = "output.has_input=='no'",
# Input: Select a file ----
shiny::radioButtons(
shinyWidgets::radioGroupButtons(
inputId = "source",
label = "Upload file or export from REDCap?",
selected = "file",
inline = TRUE,
choices = list(
"File" = "file",
"REDCap" = "redcap"
# label = "Choice: ",
choices = c("File upload" = "file", "REDCap server" = "redcap","Sample data"="env"),
checkIcon = list(
yes = icon("square-check"),
no = icon("square")
)
),
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"),
shiny::actionButton("save_filter", "Apply the filter")
IDEAFilter::IDEAFilter_ui("data_filter") # ,
# shiny::actionButton("save_filter", "Apply the filter")
)
)
)
@ -157,8 +169,11 @@ ui_elements <- list(
######### Data analyses panel
#########
##############################################################################
"analyze" = bslib::nav_panel(
title = "Analysis",
"analyze" =
# 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]]
# # )
# )
# )