mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2025-09-12 09:59:39 +02:00
new version of a minimally working example
This commit is contained in:
parent
7b1d55ebc8
commit
fb2569c647
3 changed files with 546 additions and 658 deletions
|
|
@ -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)) {
|
||||
#' 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")
|
||||
}
|
||||
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
|
||||
}
|
||||
|
||||
} else {
|
||||
breaks <- "hour"
|
||||
}
|
||||
}
|
||||
if (!breaks %in% c("hour", "dn")) {
|
||||
#' @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_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))
|
||||
breaks <- quantile(
|
||||
x,
|
||||
probs = seq(0, 1, 1 / breaks),
|
||||
right = right,
|
||||
include.lowest = include.lowest,
|
||||
na.rm=TRUE
|
||||
)
|
||||
} else if (breaks == "dn") {
|
||||
splitter <- num %in% 8:20 + 1
|
||||
}
|
||||
|
||||
## 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 {
|
||||
stop("No other methods than hour cut is implemented.")
|
||||
l <- c(l, max(as.character(x)))
|
||||
}
|
||||
}
|
||||
} else if (length(l) < length(breaks_o)) {
|
||||
l <- breaks_o
|
||||
}
|
||||
|
||||
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")
|
||||
attr(out, which = "brks") <- l
|
||||
out
|
||||
}
|
||||
|
||||
#' Title
|
||||
#' @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",
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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]]
|
||||
# # )
|
||||
# )
|
||||
# )
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue