mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2025-09-12 18:09:39 +02:00
evolving
This commit is contained in:
parent
ab2dedb66f
commit
7b1d55ebc8
7 changed files with 1071 additions and 201 deletions
|
|
@ -41,7 +41,10 @@ Imports:
|
|||
IDEAFilter,
|
||||
sparkline,
|
||||
datamods,
|
||||
toastui
|
||||
toastui,
|
||||
webshot,
|
||||
matPkg,
|
||||
lubridate
|
||||
Suggests:
|
||||
styler,
|
||||
devtools,
|
||||
|
|
|
|||
458
R/cut-variable-dates.R
Normal file
458
R/cut-variable-dates.R
Normal file
|
|
@ -0,0 +1,458 @@
|
|||
library(datamods)
|
||||
library(toastui)
|
||||
library(phosphoricons)
|
||||
library(rlang)
|
||||
|
||||
# x <- lubridate::as_datetime(seq(1,1000000,2000), origin = "2000-12-31")
|
||||
# class(x)
|
||||
#
|
||||
# lubridate::hms(c("01:00:20"))
|
||||
#
|
||||
# int_x <- classInt::classIntervals(lubridate::as_datetime(seq(1,1000000,2000), origin = "2000-12-31"), 4, style = "quantile")
|
||||
# classInt::classIntervals(readr::parse_time(c("01:00:20","03:00:20","01:20:20","03:02:20")), 2, style = "quantile")
|
||||
# int_x|> dput()
|
||||
#
|
||||
# library(hms)
|
||||
#
|
||||
# ?cut.POSIXt
|
||||
#
|
||||
# x <- readr::parse_time(c("01:00:20","03:00:20","01:20:20","03:02:20"))
|
||||
# cut(x)
|
||||
|
||||
#' Title
|
||||
#'
|
||||
#' @param x an object inheriting from class "hms"
|
||||
#' @param breaks Can be "hour" or "dn"
|
||||
#' @param ... passed on
|
||||
#'
|
||||
#' @return
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut(2)
|
||||
#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA)) |>
|
||||
#' cut() |>
|
||||
#' dput()
|
||||
cut.hms <- function(x, breaks = "hour", ...) {
|
||||
browser()
|
||||
# For now, this function will allways try to cut to hours
|
||||
# This limits time cutting to only do hour-binning, no matter the
|
||||
if (length(breaks) != 1) {
|
||||
if ("hms" %in% class(breaks)) {
|
||||
|
||||
} else {
|
||||
breaks <- "hour"
|
||||
}
|
||||
}
|
||||
if (!breaks %in% c("hour", "dn")) {
|
||||
if (is.numeric(breaks)) {
|
||||
breaks_n <- quantile(x, probs = seq(0, 1, 1 / breaks))
|
||||
## Use lapply or similar to go through levels two at a time
|
||||
|
||||
} else {
|
||||
breaks <- "hour"
|
||||
}
|
||||
}
|
||||
|
||||
ch <- strsplit(as.character(x), ":") |>
|
||||
lapply(\(.x).x[[1]]) |>
|
||||
unlist()
|
||||
|
||||
num <- as.numeric(ch)
|
||||
|
||||
if (breaks == "hour") {
|
||||
splitter <- match(
|
||||
num,
|
||||
levels(factor(num))
|
||||
)
|
||||
} else if (breaks == "dn") {
|
||||
splitter <- num %in% 8:20 + 1
|
||||
} else {
|
||||
stop("No other methods than hour cut is implemented.")
|
||||
}
|
||||
|
||||
labs <- split(x, splitter) |>
|
||||
purrr::imap(\(.x, .i){
|
||||
if (breaks == "dn" && .i == 1) {
|
||||
h <- hms::as_hms(hms::hms(hours = 24) - abs(.x - hms::hms(hours = 8)))
|
||||
|
||||
paste0("[", .x[match(sort(h)[1], h)], ",", .x[match(sort(h)[length(h)], h)], "]")
|
||||
} else {
|
||||
.x <- sort(.x)
|
||||
paste0("[", .x[1], ",", .x[length(.x)], "]")
|
||||
}
|
||||
}) |>
|
||||
unlist()
|
||||
|
||||
structure(match(num, l), levels = labs, class = "factor")
|
||||
}
|
||||
|
||||
#' Title
|
||||
#'
|
||||
#' @param data data
|
||||
#' @param class.vec vector of class names to test
|
||||
#'
|
||||
#' @return
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' vapply(REDCapCAST::redcapcast_data, \(.x){
|
||||
#' is_any_class(.x, c("hms", "Date", "POSIXct", "POSIXt"))
|
||||
#' }, logical(1))
|
||||
is_any_class <- function(data, class.vec) {
|
||||
any(class(data) %in% class.vec)
|
||||
}
|
||||
|
||||
#' Title
|
||||
#'
|
||||
#' @param data data
|
||||
#'
|
||||
#' @return
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' vapply(REDCapCAST::redcapcast_data, is_datetime, logical(1))
|
||||
is_datetime <- function(data) {
|
||||
is_any_class(data, class.vec = c("hms", "Date", "POSIXct", "POSIXt"))
|
||||
}
|
||||
|
||||
#' @title Module to Convert Numeric to Factor
|
||||
#'
|
||||
#' @description
|
||||
#' This module contain an interface to cut a numeric into several intervals.
|
||||
#'
|
||||
#'
|
||||
#' @param id Module ID.
|
||||
#'
|
||||
#' @return A [shiny::reactive()] function returning the data.
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shiny NS fluidRow column numericInput checkboxInput checkboxInput plotOutput uiOutput
|
||||
#' @importFrom shinyWidgets virtualSelectInput
|
||||
#' @importFrom toastui datagridOutput2
|
||||
#'
|
||||
#' @name cut-variable
|
||||
#'
|
||||
#' @example examples/cut_variable.R
|
||||
cut_variable_ui <- function(id) {
|
||||
ns <- NS(id)
|
||||
tagList(
|
||||
fluidRow(
|
||||
column(
|
||||
width = 3,
|
||||
virtualSelectInput(
|
||||
inputId = ns("variable"),
|
||||
label = i18n("Variable to cut:"),
|
||||
choices = NULL,
|
||||
width = "100%"
|
||||
)
|
||||
),
|
||||
column(
|
||||
width = 3,
|
||||
virtualSelectInput(
|
||||
inputId = ns("method"),
|
||||
label = i18n("Method:"),
|
||||
choices = c(
|
||||
"fixed",
|
||||
# "sd",
|
||||
# "equal",
|
||||
# "pretty",
|
||||
"quantile",
|
||||
# "kmeans",
|
||||
# "hclust",
|
||||
# "bclust",
|
||||
# "fisher",
|
||||
# "jenks",
|
||||
"headtails",
|
||||
# "maximum",
|
||||
# "box",
|
||||
"hour",
|
||||
"day",
|
||||
"week",
|
||||
"month",
|
||||
"quarter",
|
||||
"year"
|
||||
),
|
||||
selected = "quantile",
|
||||
width = "100%"
|
||||
)
|
||||
),
|
||||
column(
|
||||
width = 3,
|
||||
numericInput(
|
||||
inputId = ns("n_breaks"),
|
||||
label = i18n("Number of breaks:"),
|
||||
value = 5,
|
||||
min = 2,
|
||||
max = 12,
|
||||
width = "100%"
|
||||
)
|
||||
),
|
||||
column(
|
||||
width = 3,
|
||||
checkboxInput(
|
||||
inputId = ns("right"),
|
||||
label = i18n("Close intervals on the right"),
|
||||
value = TRUE
|
||||
),
|
||||
checkboxInput(
|
||||
inputId = ns("include_lowest"),
|
||||
label = i18n("Include lowest value"),
|
||||
value = TRUE
|
||||
)
|
||||
)
|
||||
),
|
||||
conditionalPanel(
|
||||
condition = "input.method == 'fixed'",
|
||||
ns = ns,
|
||||
uiOutput(outputId = ns("slider_fixed"))
|
||||
),
|
||||
plotOutput(outputId = ns("plot"), width = "100%", height = "270px"),
|
||||
datagridOutput2(outputId = ns("count")),
|
||||
actionButton(
|
||||
inputId = ns("create"),
|
||||
label = tagList(ph("scissors"), i18n("Create factor variable")),
|
||||
class = "btn-outline-primary float-end"
|
||||
),
|
||||
tags$div(class = "clearfix")
|
||||
)
|
||||
}
|
||||
|
||||
#' @param data_r A [shiny::reactive()] function returning a `data.frame`.
|
||||
#'
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shiny moduleServer observeEvent reactive req bindEvent renderPlot
|
||||
#' @importFrom shinyWidgets updateVirtualSelect noUiSliderInput
|
||||
#' @importFrom toastui renderDatagrid2 datagrid grid_colorbar
|
||||
#' @importFrom rlang %||% call2 set_names expr syms
|
||||
#' @importFrom classInt classIntervals
|
||||
#'
|
||||
#' @rdname cut-variable
|
||||
cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
||||
moduleServer(
|
||||
id,
|
||||
function(input, output, session) {
|
||||
rv <- reactiveValues(data = NULL)
|
||||
|
||||
bindEvent(observe({
|
||||
data <- data_r()
|
||||
rv$data <- data
|
||||
vars_num <- vapply(data, \(.x){
|
||||
is.numeric(.x) || is_datetime(.x)
|
||||
}, logical(1))
|
||||
vars_num <- names(vars_num)[vars_num]
|
||||
updateVirtualSelect(
|
||||
inputId = "variable",
|
||||
choices = vars_num,
|
||||
selected = if (isTruthy(input$variable)) input$variable else vars_num[1]
|
||||
)
|
||||
}), data_r(), input$hidden)
|
||||
|
||||
output$slider_fixed <- renderUI({
|
||||
data <- req(data_r())
|
||||
variable <- req(input$variable)
|
||||
req(hasName(data, variable))
|
||||
noUiSliderInput(
|
||||
inputId = session$ns("fixed_brks"),
|
||||
label = i18n("Fixed breaks:"),
|
||||
min = floor(min(data[[variable]], na.rm = TRUE)),
|
||||
max = ceiling(max(data[[variable]], na.rm = TRUE)),
|
||||
value = classInt::classIntervals(
|
||||
var = as.numeric(data[[variable]]),
|
||||
n = input$n_breaks,
|
||||
style = "quantile"
|
||||
)$brks,
|
||||
color = datamods:::get_primary_color(),
|
||||
width = "100%"
|
||||
)
|
||||
})
|
||||
|
||||
breaks_r <- reactive({
|
||||
data <- req(data_r())
|
||||
variable <- req(input$variable)
|
||||
req(hasName(data, variable))
|
||||
req(input$n_breaks, input$method)
|
||||
if (input$method == "fixed") {
|
||||
req(input$fixed_brks)
|
||||
classInt::classIntervals(
|
||||
var = as.numeric(data[[variable]]),
|
||||
n = input$n_breaks,
|
||||
style = "fixed",
|
||||
fixedBreaks = input$fixed_brks
|
||||
)
|
||||
} else if (input$method %in% c(
|
||||
"day",
|
||||
"week",
|
||||
"month",
|
||||
"quarter",
|
||||
"year"
|
||||
)) {
|
||||
# To enable datetime cutting
|
||||
cut.POSIXct <- cut.POSIXt
|
||||
f <- cut(data[[variable]], breaks = input$method)
|
||||
list(var = f, brks = levels(f))
|
||||
} else if (input$method %in% c("hour")) {
|
||||
# To enable datetime cutting
|
||||
cut.POSIXct <- cut.POSIXt
|
||||
f <- cut(data[[variable]], breaks = "hour")
|
||||
list(var = f, brks = levels(f))
|
||||
} else {
|
||||
classInt::classIntervals(
|
||||
var = as.numeric(data[[variable]]),
|
||||
n = input$n_breaks,
|
||||
style = input$method
|
||||
)
|
||||
}
|
||||
})
|
||||
|
||||
output$plot <- renderPlot({
|
||||
data <- req(data_r())
|
||||
variable <- req(input$variable)
|
||||
plot_histogram(data, variable, breaks = breaks_r()$brks, color = datamods:::get_primary_color())
|
||||
})
|
||||
|
||||
|
||||
data_cutted_r <- reactive({
|
||||
data <- req(data_r())
|
||||
variable <- req(input$variable)
|
||||
data[[paste0(variable, "_cut")]] <- cut(
|
||||
x = data[[variable]],
|
||||
breaks = if (input$method %in% c("day","week","month","quarter","year","hour")) input$method else breaks_r()$brks,
|
||||
include.lowest = input$include_lowest,
|
||||
right = input$right
|
||||
)
|
||||
code <- call2(
|
||||
"mutate",
|
||||
!!!set_names(
|
||||
list(
|
||||
expr(cut(
|
||||
!!!syms(list(x = variable)),
|
||||
!!!list(breaks = breaks_r()$brks, include.lowest = input$include_lowest, right = input$right)
|
||||
))
|
||||
),
|
||||
paste0(variable, "_cut")
|
||||
)
|
||||
)
|
||||
attr(data, "code") <- Reduce(
|
||||
f = function(x, y) expr(!!x %>% !!y),
|
||||
x = c(attr(data, "code"), code)
|
||||
)
|
||||
data
|
||||
})
|
||||
|
||||
output$count <- renderDatagrid2({
|
||||
data <- req(data_cutted_r())
|
||||
variable <- req(input$variable)
|
||||
count_data <- as.data.frame(
|
||||
table(
|
||||
breaks = data[[paste0(variable, "_cut")]],
|
||||
useNA = "ifany"
|
||||
),
|
||||
responseName = "count"
|
||||
)
|
||||
gridTheme <- getOption("datagrid.theme")
|
||||
if (length(gridTheme) < 1) {
|
||||
datamods:::apply_grid_theme()
|
||||
}
|
||||
on.exit(toastui::reset_grid_theme())
|
||||
grid <- datagrid(
|
||||
data = count_data,
|
||||
colwidths = "guess",
|
||||
theme = "default",
|
||||
bodyHeight = "auto"
|
||||
)
|
||||
grid <- toastui::grid_columns(grid, className = "font-monospace")
|
||||
grid_colorbar(
|
||||
grid,
|
||||
column = "count",
|
||||
label_outside = TRUE,
|
||||
label_width = "40px",
|
||||
bar_bg = datamods:::get_primary_color(),
|
||||
from = c(0, max(count_data$count) + 1)
|
||||
)
|
||||
})
|
||||
|
||||
data_returned_r <- observeEvent(input$create, {
|
||||
rv$data <- data_cutted_r()
|
||||
})
|
||||
return(reactive(rv$data))
|
||||
}
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
|
||||
#' @inheritParams shiny::modalDialog
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shiny showModal modalDialog textInput
|
||||
#' @importFrom htmltools tagList
|
||||
#'
|
||||
#' @rdname cut-variable
|
||||
modal_cut_variable <- function(id,
|
||||
title = i18n("Convert Numeric to Factor"),
|
||||
easyClose = TRUE,
|
||||
size = "l",
|
||||
footer = NULL) {
|
||||
ns <- NS(id)
|
||||
showModal(modalDialog(
|
||||
title = tagList(title, datamods:::button_close_modal()),
|
||||
cut_variable_ui(id),
|
||||
tags$div(
|
||||
style = "display: none;",
|
||||
textInput(inputId = ns("hidden"), label = NULL, value = datamods:::genId())
|
||||
),
|
||||
easyClose = easyClose,
|
||||
size = size,
|
||||
footer = footer
|
||||
))
|
||||
}
|
||||
|
||||
|
||||
#' @inheritParams shinyWidgets::WinBox
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shinyWidgets WinBox wbOptions wbControls
|
||||
#' @importFrom htmltools tagList
|
||||
#' @rdname cut-variable
|
||||
winbox_cut_variable <- function(id,
|
||||
title = i18n("Convert Numeric to Factor"),
|
||||
options = shinyWidgets::wbOptions(),
|
||||
controls = shinyWidgets::wbControls()) {
|
||||
ns <- NS(id)
|
||||
WinBox(
|
||||
title = title,
|
||||
ui = tagList(
|
||||
cut_variable_ui(id),
|
||||
tags$div(
|
||||
style = "display: none;",
|
||||
textInput(inputId = ns("hidden"), label = NULL, value = genId())
|
||||
)
|
||||
),
|
||||
options = modifyList(
|
||||
shinyWidgets::wbOptions(height = "750px", modal = TRUE),
|
||||
options
|
||||
),
|
||||
controls = controls,
|
||||
auto_height = FALSE
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
#' @importFrom graphics abline axis hist par plot.new plot.window
|
||||
plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112466") {
|
||||
x <- data[[column]]
|
||||
x <- as.numeric(x)
|
||||
op <- par(mar = rep(1.5, 4))
|
||||
on.exit(par(op))
|
||||
plot.new()
|
||||
plot.window(xlim = range(pretty(x)), ylim = range(pretty(hist(x, breaks = bins, plot = FALSE)$counts)))
|
||||
abline(v = pretty(x), col = "#D8D8D8")
|
||||
abline(h = pretty(hist(x, breaks = bins, plot = FALSE)$counts), col = "#D8D8D8")
|
||||
hist(x, breaks = bins, xlim = range(pretty(x)), xaxs = "i", yaxs = "i", col = color, add = TRUE)
|
||||
axis(side = 1, at = pretty(x), pos = 0)
|
||||
axis(side = 2, at = pretty(hist(x, breaks = bins, plot = FALSE)$counts), pos = min(pretty(x)))
|
||||
abline(v = breaks, col = "#FFFFFF", lty = 1, lwd = 1.5)
|
||||
abline(v = breaks, col = "#2E2E2E", lty = 2, lwd = 1.5)
|
||||
}
|
||||
|
|
@ -149,7 +149,10 @@ file_export <- function(data, output.format = c("df", "teal", "list"), filename,
|
|||
|
||||
datanames(out) <- filename
|
||||
} else if (output.format == "df") {
|
||||
out <- data
|
||||
out <- data|>
|
||||
REDCapCAST::parse_data() |>
|
||||
REDCapCAST::as_factor() |>
|
||||
REDCapCAST::numchar2fct()
|
||||
} else if (output.format == "list") {
|
||||
out <- list(
|
||||
data = data,
|
||||
|
|
|
|||
226
R/modules.R
226
R/modules.R
|
|
@ -6,7 +6,7 @@
|
|||
#' @export
|
||||
#'
|
||||
m_datafileUI <- function(id) {
|
||||
ns <- NS(id)
|
||||
ns <- shiny::NS(id)
|
||||
shiny::tagList(
|
||||
shiny::fileInput(
|
||||
inputId = ns("file"),
|
||||
|
|
@ -22,7 +22,7 @@ m_datafileUI <- function(id) {
|
|||
)
|
||||
),
|
||||
shiny::h4("Parameter specifications"),
|
||||
shiny::helpText(em("Select the desired variables and press 'Submit'")),
|
||||
shiny::helpText(shiny::em("Select the desired variables and press 'Submit'")),
|
||||
shiny::uiOutput(ns("include_vars")),
|
||||
DT::DTOutput(ns("data_input")),
|
||||
shiny::actionButton(ns("submit"), "Submit")
|
||||
|
|
@ -38,7 +38,7 @@ m_datafileServer <- function(id, output.format = "df") {
|
|||
|
||||
output$include_vars <- shiny::renderUI({
|
||||
shiny::req(input$file)
|
||||
selectizeInput(
|
||||
shiny::selectizeInput(
|
||||
inputId = ns("include_vars"),
|
||||
selected = NULL,
|
||||
label = "Covariables to include",
|
||||
|
|
@ -81,19 +81,21 @@ m_datafileServer <- function(id, output.format = "df") {
|
|||
#' Shiny module to browser and export REDCap data
|
||||
#'
|
||||
#' @param id Namespace id
|
||||
#' @param include_title logical to include title
|
||||
#'
|
||||
#' @rdname redcap_read_shiny_module
|
||||
#'
|
||||
#' @return shiny ui element
|
||||
#' @export
|
||||
m_redcap_readUI <- function(id) {
|
||||
m_redcap_readUI <- function(id, include_title = TRUE) {
|
||||
ns <- shiny::NS(id)
|
||||
|
||||
server_ui <- fluidRow(
|
||||
column(
|
||||
server_ui <- shiny::column(
|
||||
width = 6,
|
||||
shiny::tags$h4("REDCap server information"),
|
||||
shiny::textInput(
|
||||
inputId = ns("uri"),
|
||||
label = "URI",
|
||||
label = "URI/Address",
|
||||
value = "https://redcap.your.institution/api/"
|
||||
),
|
||||
shiny::textInput(
|
||||
|
|
@ -102,17 +104,21 @@ m_redcap_readUI <- function(id) {
|
|||
value = ""
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
params_ui <- fluidRow(
|
||||
column(
|
||||
|
||||
params_ui <-
|
||||
shiny::column(
|
||||
width = 6,
|
||||
shiny::tags$h4("Data import parameters"),
|
||||
shiny::helpText("Options here will show, when API and uri are typed"),
|
||||
shiny::uiOutput(outputId = ns("fields")),
|
||||
shinyWidgets::switchInput(
|
||||
inputId = "do_filter",
|
||||
label = "Apply filter?",
|
||||
value = FALSE,
|
||||
inline = TRUE
|
||||
inline = FALSE,
|
||||
onLabel = "YES",
|
||||
offLabel = "NO"
|
||||
),
|
||||
# shiny::radioButtons(
|
||||
# inputId = "do_filter",
|
||||
|
|
@ -133,14 +139,35 @@ m_redcap_readUI <- function(id) {
|
|||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
shiny::fluidPage(
|
||||
if (include_title) shiny::tags$h3("Import data from REDCap"),
|
||||
fluidRow(
|
||||
server_ui,
|
||||
params_ui,
|
||||
shiny::actionButton(inputId = ns("import"), label = "Import"),
|
||||
params_ui),
|
||||
shiny::column(
|
||||
width = 12,
|
||||
# shiny::actionButton(inputId = ns("import"), label = "Import"),
|
||||
bslib::input_task_button(
|
||||
id = ns("import"),
|
||||
label = "Import",
|
||||
icon = shiny::icon("download", lib = "glyphicon"),
|
||||
label_busy = "Just a minute...",
|
||||
icon_busy = fontawesome::fa_i("arrows-rotate",
|
||||
class = "fa-spin",
|
||||
"aria-hidden" = "true"
|
||||
),
|
||||
type = "primary",
|
||||
auto_reset = TRUE
|
||||
),
|
||||
shiny::helpText("Press 'Import' after having specified API token and URI to export data from the REDCap server. A preview will show below the DataDictionary."),
|
||||
shiny::br(),
|
||||
shiny::br(),
|
||||
shiny::br(),
|
||||
DT::DTOutput(outputId = ns("table"))
|
||||
# toastui::datagridOutput2(outputId = ns("table"))
|
||||
)
|
||||
# toastui::datagridOutput2(outputId = ns("table")),
|
||||
# toastui::datagridOutput2(outputId = ns("data")),
|
||||
# shiny::actionButton(inputId = ns("submit"), label = "Submit"),
|
||||
|
|
@ -161,16 +188,41 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) {
|
|||
# ns <- shiny::NS(id)
|
||||
ns <- session$ns
|
||||
|
||||
# data_list <- shiny::reactiveValues(
|
||||
# dict = NULL,
|
||||
# stat = NULL,
|
||||
# arms = NULL,
|
||||
# data = NULL,
|
||||
# name = NULL
|
||||
# )
|
||||
|
||||
dd <- shiny::reactive({
|
||||
shiny::req(input$api)
|
||||
shiny::req(input$uri)
|
||||
|
||||
|
||||
REDCapR::redcap_metadata_read(
|
||||
redcap_uri = input$uri,
|
||||
token = input$api
|
||||
)$data
|
||||
})
|
||||
|
||||
# dd <- shiny::reactive({
|
||||
# shiny::req(input$api)
|
||||
# shiny::req(input$uri)
|
||||
#
|
||||
#
|
||||
# out <- REDCapR::redcap_metadata_read(
|
||||
# redcap_uri = input$uri,
|
||||
# token = input$api
|
||||
# )
|
||||
#
|
||||
# data_list$dict <- out$data
|
||||
# data_list$stat <- out$success
|
||||
#
|
||||
# out$data
|
||||
# })
|
||||
|
||||
arms <- shiny::reactive({
|
||||
shiny::req(input$api)
|
||||
shiny::req(input$uri)
|
||||
|
|
@ -179,12 +231,15 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) {
|
|||
redcap_uri = input$uri,
|
||||
token = input$api
|
||||
)$data
|
||||
|
||||
# data_list$arms <- out
|
||||
# out
|
||||
})
|
||||
|
||||
output$fields <- shiny::renderUI({
|
||||
shinyWidgets::virtualSelectInput(
|
||||
inputId = ns("fields"),
|
||||
label = "Multiple select:",
|
||||
label = "Select fields/variables to import:",
|
||||
choices = dd() |>
|
||||
dplyr::select(field_name, form_name) |>
|
||||
(\(.x){
|
||||
|
|
@ -193,7 +248,9 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) {
|
|||
# stats::setNames(instr()[["data"]][[2]])
|
||||
,
|
||||
updateOn = "close",
|
||||
multiple = TRUE
|
||||
multiple = TRUE,
|
||||
search = TRUE,
|
||||
showValueAsTags = TRUE
|
||||
)
|
||||
})
|
||||
|
||||
|
|
@ -212,8 +269,10 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) {
|
|||
{
|
||||
shiny::req(input$api)
|
||||
shiny::req(input$uri)
|
||||
# shiny::req(data_list$dict)
|
||||
# dd()[["data"]][c(1,2,4,5,6,8)]
|
||||
data.df <- dd()[c(1, 2, 4, 5, 6, 8)]
|
||||
# browser()
|
||||
data.df <- dd()[, c(1, 2, 4, 5, 6, 8)]
|
||||
DT::datatable(data.df,
|
||||
caption = "Subset of data dictionary"
|
||||
)
|
||||
|
|
@ -221,7 +280,20 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) {
|
|||
server = TRUE
|
||||
)
|
||||
|
||||
name <- reactive({
|
||||
# Messes up the overlay of other objects. JS thing?
|
||||
# output$table <- toastui::renderDatagrid2(
|
||||
# {
|
||||
# shiny::req(input$api)
|
||||
# shiny::req(input$uri)
|
||||
# # shiny::req(data_list$dict)
|
||||
# # dd()[["data"]][c(1,2,4,5,6,8)]
|
||||
# # browser()
|
||||
# toastui::datagrid(dd()[,c(1, 2, 4, 5, 6, 8)]
|
||||
# )
|
||||
# }
|
||||
# )
|
||||
|
||||
name <- shiny::reactive({
|
||||
shiny::req(input$api)
|
||||
REDCapR::redcap_project_info_read(
|
||||
redcap_uri = input$uri,
|
||||
|
|
@ -231,6 +303,7 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) {
|
|||
|
||||
shiny::eventReactive(input$import, {
|
||||
shiny::req(input$api)
|
||||
shiny::req(input$fields)
|
||||
record_id <- dd()[[1]][1]
|
||||
|
||||
redcap_data <- REDCapCAST::read_redcap_tables(
|
||||
|
|
@ -255,11 +328,10 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) {
|
|||
if (output.format == "list") {
|
||||
out <- list(
|
||||
data = shiny::reactive(redcap_data),
|
||||
meta = dd()[["dd"]],
|
||||
name = name,
|
||||
meta = dd(),
|
||||
name = name(),
|
||||
filter = input$filter
|
||||
)
|
||||
|
||||
} else {
|
||||
out <- out_object
|
||||
}
|
||||
|
|
@ -274,7 +346,6 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) {
|
|||
)
|
||||
}
|
||||
|
||||
|
||||
tdm_redcap_read <- teal::teal_data_module(
|
||||
ui <- function(id) {
|
||||
shiny::fluidPage(
|
||||
|
|
@ -299,26 +370,111 @@ tdm_data_upload <- teal::teal_data_module(
|
|||
|
||||
|
||||
redcap_app <- function() {
|
||||
ui <- fluidPage(
|
||||
ui <- shiny::fluidPage(
|
||||
m_redcap_readUI("data"),
|
||||
DT::DTOutput(outputId = "redcap_prev")
|
||||
# DT::DTOutput(outputId = "redcap_prev")
|
||||
toastui::datagridOutput2(outputId = "redcap_prev"),
|
||||
shiny::fluidRow(
|
||||
shiny::column(
|
||||
8,
|
||||
# verbatimTextOutput("data_filter_code"),
|
||||
DT::DTOutput("data_summary")
|
||||
),
|
||||
shiny::column(4, IDEAFilter::IDEAFilter_ui("data_filter"))
|
||||
)
|
||||
)
|
||||
server <- function(input, output, session) {
|
||||
ds <- m_redcap_readServer("data")
|
||||
output$redcap_prev <- DT::renderDT(
|
||||
{
|
||||
data_val <- shiny::reactiveValues(data=NULL)
|
||||
|
||||
# df <- shiny::isolate(data_redcap())
|
||||
# browser()
|
||||
#
|
||||
DT::datatable(ds(),
|
||||
caption = "Observations"
|
||||
)
|
||||
ds <- m_redcap_readServer("data", output.format = "df")
|
||||
# output$redcap_prev <- DT::renderDT(
|
||||
# {
|
||||
# DT::datatable(purrr::pluck(ds(), "data")(),
|
||||
# caption = "Observations"
|
||||
# )
|
||||
# },
|
||||
# server = TRUE
|
||||
# )
|
||||
|
||||
# shiny::reactive({
|
||||
# data_val$data <- purrr::pluck(ds(), "data")()
|
||||
# })
|
||||
|
||||
output$redcap_prev <- toastui::renderDatagrid2({
|
||||
# toastui::datagrid(purrr::pluck(ds(), "data")())
|
||||
# toastui::datagrid(data_val$data)
|
||||
toastui::datagrid(ds())
|
||||
})
|
||||
|
||||
filtered_data <- IDEAFilter::IDEAFilter("data_filter",
|
||||
data = ds,
|
||||
verbose = FALSE)
|
||||
|
||||
# filtered_data <- shiny::reactive({
|
||||
# IDEAFilter::IDEAFilter("data_filter",
|
||||
# data = purrr::pluck(ds(), "data")(),
|
||||
# verbose = FALSE)
|
||||
# })
|
||||
|
||||
# output$data_filter_code <- renderPrint({
|
||||
# cat(gsub(
|
||||
# "%>%", "%>% \n ",
|
||||
# gsub(
|
||||
# "\\s{2,}", " ",
|
||||
# paste0(
|
||||
# capture.output(attr(filtered_data(), "code")),
|
||||
# collapse = " "
|
||||
# )
|
||||
# )
|
||||
# ))
|
||||
# })
|
||||
|
||||
output$data_summary <- DT::renderDataTable(
|
||||
{
|
||||
filtered_data()
|
||||
},
|
||||
server = TRUE
|
||||
options = list(
|
||||
scrollX = TRUE,
|
||||
pageLength = 5
|
||||
)
|
||||
)
|
||||
}
|
||||
shinyApp(ui, server)
|
||||
shiny::shinyApp(ui, server)
|
||||
}
|
||||
|
||||
|
||||
redcap_app()
|
||||
|
||||
|
||||
file_app <- function() {
|
||||
ui <- shiny::fluidPage(
|
||||
m_datafileUI("data"),
|
||||
# DT::DTOutput(outputId = "redcap_prev")
|
||||
toastui::datagridOutput2(outputId = "redcap_prev")
|
||||
)
|
||||
server <- function(input, output, session) {
|
||||
m_datafileServer("data", output.format = "list")
|
||||
}
|
||||
shiny::shinyApp(ui, server)
|
||||
}
|
||||
|
||||
file_app()
|
||||
|
||||
|
||||
tdm_data_read <- teal::teal_data_module(
|
||||
ui <- function(id) {
|
||||
shiny::fluidPage(
|
||||
m_redcap_readUI(id = "redcap")
|
||||
)
|
||||
},
|
||||
server = function(id) {
|
||||
moduleServer(
|
||||
id,
|
||||
function(input, output, session) {
|
||||
ns <- session$ns
|
||||
|
||||
m_redcap_readServer(id = "redcap", output.format = "teal")
|
||||
}
|
||||
)
|
||||
}
|
||||
)
|
||||
|
|
|
|||
|
|
@ -23,6 +23,9 @@ library(REDCapCAST)
|
|||
library(easystats)
|
||||
library(patchwork)
|
||||
library(DHARMa)
|
||||
library(datamods)
|
||||
library(toastui)
|
||||
library(IDEAFilter)
|
||||
# if (!requireNamespace("webResearch")) {
|
||||
# devtools::install_github("agdamsbo/webResearch", quiet = TRUE, upgrade = "never")
|
||||
# }
|
||||
|
|
@ -43,13 +46,14 @@ server <- function(input, output, session) {
|
|||
input = exists("webResearch_data"),
|
||||
local_temp = NULL,
|
||||
quarto = NULL,
|
||||
test = "no"
|
||||
test = "no",
|
||||
data = NULL
|
||||
)
|
||||
|
||||
data_file <- datamods::import_file_server(
|
||||
id = "file_import",
|
||||
show_data_in = "popup",
|
||||
trigger_return = "button",
|
||||
trigger_return = "change",
|
||||
return_class = "data.frame",
|
||||
read_fns = list(
|
||||
ods = function(file) {
|
||||
|
|
@ -68,13 +72,28 @@ server <- function(input, output, session) {
|
|||
|
||||
output$redcap_prev <- DT::renderDT(
|
||||
{
|
||||
DT::datatable(head(purrr::pluck(data_redcap(), 1)(), 5),
|
||||
DT::datatable(head(purrr::pluck(data_redcap(), "data")(), 5),
|
||||
caption = "First 5 observations"
|
||||
)
|
||||
},
|
||||
server = TRUE
|
||||
)
|
||||
|
||||
data_rv <- shiny::reactiveValues(data = NULL)
|
||||
#
|
||||
# shiny::observeEvent(data_file$data(), {
|
||||
# data_rv$data <- data_file$data() |>
|
||||
# REDCapCAST::numchar2fct()
|
||||
# })
|
||||
#
|
||||
# shiny::observeEvent(purrr::pluck(ds(), "data")(), {
|
||||
# data_rv$data <- purrr::pluck(ds(), "data")() |>
|
||||
# REDCapCAST::parse_data() |>
|
||||
# REDCapCAST::as_factor() |>
|
||||
# REDCapCAST::numchar2fct()
|
||||
# })
|
||||
|
||||
|
||||
ds <- shiny::reactive({
|
||||
# input$file1 will be NULL initially. After the user selects
|
||||
# and uploads a file, head of that data file by default,
|
||||
|
|
@ -82,13 +101,11 @@ server <- function(input, output, session) {
|
|||
if (v$input) {
|
||||
out <- webResearch_data
|
||||
} else if (input$source == "file") {
|
||||
out <- data_file$data() |>
|
||||
REDCapCAST::numchar2fct()
|
||||
req(data_file$data())
|
||||
out <- data_file$data()
|
||||
} else if (input$source == "redcap") {
|
||||
out <- purrr::pluck(data_redcap(), 1)() |>
|
||||
REDCapCAST::parse_data() |>
|
||||
REDCapCAST::as_factor() |>
|
||||
REDCapCAST::numchar2fct()
|
||||
req(purrr::pluck(data_redcap(), "data")())
|
||||
out <- purrr::pluck(data_redcap(), "data")()
|
||||
}
|
||||
|
||||
v$ds <- "loaded"
|
||||
|
|
@ -97,53 +114,206 @@ server <- function(input, output, session) {
|
|||
# out <- out |>
|
||||
# REDCapCAST::numchar2fct()
|
||||
# }
|
||||
out <- out|>
|
||||
REDCapCAST::parse_data() |>
|
||||
REDCapCAST::as_factor() |>
|
||||
REDCapCAST::numchar2fct()
|
||||
|
||||
data_rv$data <- shiny::reactive(out)
|
||||
|
||||
out
|
||||
})
|
||||
|
||||
# shiny::reactive({
|
||||
# if (!is.null(data_rv$data)){
|
||||
# data_rv$data <- shiny::reactive(data_rv$data() |> REDCapCAST::parse_data() |>
|
||||
# REDCapCAST::as_factor() |>
|
||||
# REDCapCAST::numchar2fct())
|
||||
# }
|
||||
# })
|
||||
|
||||
output$table <-
|
||||
DT::renderDT(
|
||||
{
|
||||
DT::datatable(
|
||||
ds())
|
||||
},
|
||||
server = FALSE
|
||||
)
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Data modification section
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
######### Modifications
|
||||
|
||||
rv <- shiny::reactiveValues(data = reactive(ds() ))
|
||||
|
||||
observeEvent(ds(), rv$data <- ds())
|
||||
observeEvent(input$data_reset, rv$data <- ds())
|
||||
|
||||
## Using modified version of the datamods::cut_variable_server function
|
||||
## Further modifications are needed to have cut/bin options based on class of variable
|
||||
## Could be defined server-side
|
||||
observeEvent(input$modal_cut, modal_cut_variable("modal_cut"))
|
||||
data_modal_cut <- cut_variable_server(
|
||||
id = "modal_cut",
|
||||
data_r = reactive(rv$data)
|
||||
)
|
||||
observeEvent(data_modal_cut(), rv$data <- data_modal_cut())
|
||||
|
||||
|
||||
observeEvent(input$modal_update, datamods::modal_update_factor("modal_update"))
|
||||
data_modal_update <- datamods::update_factor_server(
|
||||
id = "modal_update",
|
||||
data_r = reactive(rv$data)
|
||||
)
|
||||
observeEvent(data_modal_update(), {
|
||||
shiny::removeModal()
|
||||
rv$data <- data_modal_update()
|
||||
})
|
||||
|
||||
|
||||
|
||||
# Show result
|
||||
output$table_mod <- toastui::renderDatagrid2({
|
||||
req(rv$data)
|
||||
# data <- rv$data
|
||||
toastui::datagrid(
|
||||
data = rv$data#,
|
||||
# bordered = TRUE,
|
||||
# compact = TRUE,
|
||||
# striped = TRUE
|
||||
)
|
||||
})
|
||||
|
||||
output$code <- renderPrint({
|
||||
attr(rv$data, "code")
|
||||
})
|
||||
|
||||
updated_data <- datamods::update_variables_server(
|
||||
id = "vars_update",
|
||||
data = reactive(rv$data),
|
||||
return_data_on_init = FALSE
|
||||
)
|
||||
|
||||
output$original_str <- renderPrint({
|
||||
str(ds())
|
||||
})
|
||||
|
||||
output$modified_str <- renderPrint({
|
||||
str(rv$data)
|
||||
})
|
||||
|
||||
observeEvent(updated_data(), {
|
||||
rv$data <- updated_data()
|
||||
})
|
||||
|
||||
# datamods filtering has the least attractive ui, but it does work well
|
||||
#
|
||||
# output$filter_vars <- shiny::renderUI({
|
||||
# shinyWidgets::virtualSelectInput(
|
||||
# inputId = "filter_vars",
|
||||
# selected = NULL,
|
||||
# label = "Covariables to include",
|
||||
# choices = colnames(ds()),
|
||||
# multiple = TRUE,
|
||||
# updateOn = "change"
|
||||
# )
|
||||
# })
|
||||
# data_filter <- datamods::filter_data_server(
|
||||
# id = "filtering",
|
||||
# data = ds,
|
||||
# widget_num = "slider",
|
||||
# widget_date = "slider",
|
||||
# label_na = "Missing",
|
||||
# vars = shiny::reactive(input$filter_vars)
|
||||
# )
|
||||
#
|
||||
# output$filtered_table <-
|
||||
# DT::renderDT(
|
||||
# {
|
||||
# DT::datatable(data_filter$filtered())
|
||||
# },
|
||||
# server = TRUE
|
||||
# )
|
||||
#
|
||||
# output$filtered_code <- shiny::renderPrint({
|
||||
# data_filter$code()
|
||||
# })
|
||||
|
||||
# IDEAFilter has the least cluttered UI, but might have a License issue
|
||||
data_filter <- IDEAFilter::IDEAFilter("data_filter", data = reactive(rv$data), verbose = TRUE)
|
||||
|
||||
observeEvent(input$save_filter, {
|
||||
rv$data <- data_filter()
|
||||
})
|
||||
|
||||
output$filtered_code <- shiny::renderPrint({
|
||||
gsub("reactive(rv$data)", "data",
|
||||
cat(gsub("%>%", "|> \n ",
|
||||
gsub("\\s{2,}", " ",
|
||||
paste0(
|
||||
capture.output(attr(data_filter(), "code")),
|
||||
collapse = " "))
|
||||
)))
|
||||
})
|
||||
|
||||
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Data analyses section
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
## Keep these "old" selection options as a simple alternative to the modification pane
|
||||
|
||||
output$include_vars <- shiny::renderUI({
|
||||
selectizeInput(
|
||||
shiny::selectizeInput(
|
||||
inputId = "include_vars",
|
||||
selected = NULL,
|
||||
label = "Covariables to include",
|
||||
choices = colnames(ds()),
|
||||
choices = colnames(rv$data),
|
||||
multiple = TRUE
|
||||
)
|
||||
})
|
||||
|
||||
output$outcome_var <- shiny::renderUI({
|
||||
selectInput(
|
||||
shiny::selectInput(
|
||||
inputId = "outcome_var",
|
||||
selected = NULL,
|
||||
label = "Select outcome variable",
|
||||
choices = colnames(ds()),
|
||||
choices = colnames(rv$data),
|
||||
multiple = FALSE
|
||||
)
|
||||
})
|
||||
|
||||
output$strat_var <- shiny::renderUI({
|
||||
selectInput(
|
||||
shiny::selectInput(
|
||||
inputId = "strat_var",
|
||||
selected = "none",
|
||||
label = "Select variable to stratify baseline",
|
||||
choices = c("none", colnames(ds()[base_vars()])),
|
||||
choices = c("none", colnames(rv$data[base_vars()])),
|
||||
multiple = FALSE
|
||||
)
|
||||
})
|
||||
|
||||
output$factor_vars <- shiny::renderUI({
|
||||
selectizeInput(
|
||||
shiny::selectizeInput(
|
||||
inputId = "factor_vars",
|
||||
selected = colnames(ds())[sapply(ds(), is.factor)],
|
||||
selected = colnames(rv$data)[sapply(rv$data, is.factor)],
|
||||
label = "Covariables to format as categorical",
|
||||
choices = colnames(ds()),
|
||||
choices = colnames(rv$data),
|
||||
multiple = TRUE
|
||||
)
|
||||
})
|
||||
|
||||
base_vars <- shiny::reactive({
|
||||
if (is.null(input$include_vars)) {
|
||||
out <- colnames(ds())
|
||||
out <- colnames(rv$data)
|
||||
} else {
|
||||
out <- unique(c(input$include_vars, input$outcome_var))
|
||||
}
|
||||
|
|
@ -171,7 +341,7 @@ server <- function(input, output, session) {
|
|||
})
|
||||
|
||||
shiny::observeEvent(input$act_start, {
|
||||
bslib::nav_select(id = "main_panel", selected = "Data analysis")
|
||||
bslib::nav_select(id = "main_panel", selected = "Overview and modifications")
|
||||
})
|
||||
|
||||
shiny::observeEvent(
|
||||
|
|
@ -180,12 +350,13 @@ server <- function(input, output, session) {
|
|||
},
|
||||
{
|
||||
shiny::req(input$outcome_var)
|
||||
|
||||
# browser()
|
||||
# Assumes all character variables can be formatted as factors
|
||||
data <- ds() |>
|
||||
dplyr::mutate(dplyr::across(dplyr::where(is.character), as.factor))
|
||||
|
||||
data <- data |> factorize(vars = input$factor_vars)
|
||||
# data <- data_filter$filtered() |>
|
||||
data <- rv$data |>
|
||||
dplyr::mutate(dplyr::across(dplyr::where(is.character), as.factor)) |>
|
||||
REDCapCAST::fct_drop.data.frame() |>
|
||||
factorize(vars = input$factor_vars)
|
||||
|
||||
# if (is.factor(data[[input$strat_var]])) {
|
||||
# by.var <- input$strat_var
|
||||
|
|
|
|||
|
|
@ -8,35 +8,17 @@ requireNamespace("gt")
|
|||
# ns <- NS(id)
|
||||
|
||||
ui_elements <- list(
|
||||
# bslib::nav_panel(
|
||||
# title = "Data overview",
|
||||
# # shiny::uiOutput("data.classes"),
|
||||
# # shiny::uiOutput("data.input"),
|
||||
# # shiny::p("Classes of uploaded data"),
|
||||
# # gt::gt_output("data.classes"),
|
||||
# shiny::p("Subset data"),
|
||||
# DT::DTOutput(outputId = "data.input")
|
||||
# ),
|
||||
# bslib::nav_panel(
|
||||
# title = "Baseline characteristics",
|
||||
# gt::gt_output(outputId = "table1")
|
||||
# ),
|
||||
# bslib::nav_panel(
|
||||
# title = "Regression table",
|
||||
# gt::gt_output(outputId = "table2")
|
||||
# ),
|
||||
# bslib::nav_panel(
|
||||
# title = "Regression checks",
|
||||
# shiny::plotOutput(outputId = "check")
|
||||
# ),
|
||||
##############################################################################
|
||||
#########
|
||||
######### Import panel
|
||||
#########
|
||||
##############################################################################
|
||||
"import" = bslib::nav_panel(
|
||||
title = "Data import",
|
||||
shiny::h4("Upload your dataset"),
|
||||
title = "Import",
|
||||
shiny::fluidRow(
|
||||
column(
|
||||
width = 6,
|
||||
shiny::h4("Choose your data source"),
|
||||
shiny::conditionalPanel(
|
||||
condition = "output.has_input=='yes'",
|
||||
# Input: Select a file ----
|
||||
|
|
@ -64,21 +46,120 @@ ui_elements <- list(
|
|||
),
|
||||
shiny::conditionalPanel(
|
||||
condition = "input.source=='redcap'",
|
||||
m_redcap_readUI("redcap_import"),
|
||||
DT::DTOutput(outputId = "redcap_prev")
|
||||
m_redcap_readUI("redcap_import")
|
||||
)
|
||||
)
|
||||
),
|
||||
column(
|
||||
width = 6,
|
||||
shiny::markdown("
|
||||
# Welcome
|
||||
|
||||
This is the ***freesearchR*** web data analysis tool. An opiniotaed tool for easy data analysis at the hands of the clinician.
|
||||
|
||||
By intention, this is a focused app, with only few data modification tools included to keep the workflow streamlined.
|
||||
")
|
||||
)
|
||||
),
|
||||
shiny::conditionalPanel(
|
||||
condition = "input.source=='redcap'",
|
||||
DT::DTOutput(outputId = "redcap_prev")
|
||||
),
|
||||
shiny::br(),
|
||||
shiny::actionButton(inputId = "act_start", label = "Start")
|
||||
),
|
||||
##############################################################################
|
||||
#########
|
||||
######### Data overview panel
|
||||
#########
|
||||
##############################################################################
|
||||
"overview" = bslib::nav_panel(
|
||||
title = "Overview and modifications",
|
||||
bslib::navset_bar(fillable = TRUE,
|
||||
# bslib::nav_panel(
|
||||
# title = "Edit",
|
||||
# datamods::edit_data_ui(id = "edit_data")
|
||||
# ),
|
||||
# bslib::nav_panel(
|
||||
# title = "Overview",
|
||||
# DT::DTOutput(outputId = "table")
|
||||
# ),
|
||||
bslib::nav_panel(
|
||||
title = "Rename and select",
|
||||
tags$h3("Select, rename and convert variables"),
|
||||
fluidRow(
|
||||
column(
|
||||
width = 6,
|
||||
# radioButtons()
|
||||
shiny::actionButton("data_reset", "Restore original data"),
|
||||
datamods::update_variables_ui("vars_update")
|
||||
),
|
||||
column(
|
||||
width = 6,
|
||||
tags$b("Original data:"),
|
||||
# verbatimTextOutput("original"),
|
||||
verbatimTextOutput("original_str"),
|
||||
tags$b("Modified data:"),
|
||||
# verbatimTextOutput("modified"),
|
||||
verbatimTextOutput("modified_str")
|
||||
)
|
||||
)
|
||||
),
|
||||
bslib::nav_panel(
|
||||
title = "Filter and modify",
|
||||
shinyWidgets::html_dependency_winbox(),
|
||||
fluidRow(
|
||||
# column(
|
||||
# width = 3,
|
||||
# shiny::uiOutput("filter_vars"),
|
||||
# shiny::conditionalPanel(
|
||||
# condition = "(typeof input.filter_vars !== 'undefined' && input.filter_vars.length > 0)",
|
||||
# datamods::filter_data_ui("filtering", max_height = "500px")
|
||||
# )
|
||||
# ),
|
||||
# column(
|
||||
# width = 9,
|
||||
# DT::DTOutput(outputId = "filtered_table"),
|
||||
# tags$b("Code dplyr:"),
|
||||
# verbatimTextOutput(outputId = "filtered_code")
|
||||
# ),
|
||||
shiny::column(
|
||||
width = 8,
|
||||
toastui::datagridOutput2(outputId = "table_mod"),
|
||||
shiny::tags$b("Reproducible code:"),
|
||||
shiny::verbatimTextOutput(outputId = "filtered_code")
|
||||
),
|
||||
shiny::column(
|
||||
width = 4,
|
||||
shiny::actionButton("modal_cut", "Cut a variable"),
|
||||
shiny::tags$br(),
|
||||
shiny::tags$br(),
|
||||
shiny::actionButton("modal_update", "Update factor's levels"),
|
||||
shiny::tags$br(),
|
||||
shiny::tags$br(),
|
||||
IDEAFilter::IDEAFilter_ui("data_filter"),
|
||||
shiny::actionButton("save_filter", "Apply the filter")
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
# column(
|
||||
# 8,
|
||||
# shiny::verbatimTextOutput("filtered_code"),
|
||||
# DT::DTOutput("filtered_table")
|
||||
# ),
|
||||
# column(4, IDEAFilter::IDEAFilter_ui("data_filter"))
|
||||
)
|
||||
),
|
||||
##############################################################################
|
||||
#########
|
||||
######### Data analyses panel
|
||||
#########
|
||||
##############################################################################
|
||||
"analyze" = bslib::nav_panel(
|
||||
title = "Data analysis",
|
||||
bslib::page_navbar(
|
||||
title = "Analysis",
|
||||
bslib::navset_bar(
|
||||
title = "",
|
||||
# bslib::layout_sidebar(
|
||||
# fillable = TRUE,
|
||||
|
|
@ -143,11 +224,6 @@ ui_elements <- list(
|
|||
shiny::helpText("If you change the parameters, press 'Analyse' again to update the tables")
|
||||
# )
|
||||
),
|
||||
bslib::nav_spacer(),
|
||||
bslib::nav_panel(
|
||||
title = "Data overview",
|
||||
DT::DTOutput(outputId = "data_table")
|
||||
),
|
||||
bslib::nav_panel(
|
||||
title = "Baseline characteristics",
|
||||
gt::gt_output(outputId = "table1")
|
||||
|
|
@ -168,7 +244,7 @@ ui_elements <- list(
|
|||
#########
|
||||
##############################################################################
|
||||
"docs" = bslib::nav_panel(
|
||||
title = "Intro",
|
||||
title = "Documentation",
|
||||
shiny::markdown(readLines("www/intro.md")),
|
||||
shiny::br()
|
||||
)
|
||||
|
|
@ -210,6 +286,7 @@ ui <- bslib::page(
|
|||
bslib::page_navbar(
|
||||
id = "main_panel",
|
||||
ui_elements$import,
|
||||
ui_elements$overview,
|
||||
ui_elements$analyze,
|
||||
ui_elements$docs
|
||||
)
|
||||
|
|
|
|||
|
|
@ -97,6 +97,8 @@ footer <- tags$p(
|
|||
# redcap_browser_app <- teal_init(data = tdm_data_upload)
|
||||
|
||||
app <- teal::init(
|
||||
# data=tdm_data_read,
|
||||
# data = tdm_data_upload,
|
||||
data = tdm_redcap_read,
|
||||
filter = filters,
|
||||
modules = modules(
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue