mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2025-09-12 09:59:39 +02:00
resturicturing to remove tracking from local app
This commit is contained in:
parent
e144f9aeb9
commit
2379cecbca
12 changed files with 61 additions and 845 deletions
|
|
@ -13,3 +13,5 @@
|
|||
^pkgdown$
|
||||
^data-raw$
|
||||
^CITATION\.cff$
|
||||
^app_hosted$
|
||||
^app$
|
||||
|
|
|
|||
2
.gitignore
vendored
2
.gitignore
vendored
|
|
@ -10,3 +10,5 @@ inst/shiny-examples/casting/functions.R
|
|||
functions.R
|
||||
docs
|
||||
inst/doc
|
||||
app_hosted
|
||||
app
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
|
||||
########
|
||||
#### Current file: /Users/au301842/FreesearchR/inst/apps/FreesearchR/functions.R
|
||||
#### Current file: /Users/au301842/FreesearchR/app/functions.R
|
||||
########
|
||||
|
||||
|
||||
|
|
@ -7521,8 +7521,7 @@ regression_server <- function(id,
|
|||
|
||||
shiny::observeEvent(
|
||||
list(
|
||||
data_r(),
|
||||
regression_vars()
|
||||
data_r()
|
||||
),
|
||||
{
|
||||
rv$list$regression$tables <- NULL
|
||||
|
|
@ -7537,6 +7536,7 @@ regression_server <- function(id,
|
|||
## To avoid plotting old models on fail/error
|
||||
rv$list$regression$tables <- NULL
|
||||
|
||||
# browser()
|
||||
tryCatch(
|
||||
{
|
||||
parameters <- list(
|
||||
|
|
@ -7572,17 +7572,9 @@ regression_server <- function(id,
|
|||
)
|
||||
})
|
||||
|
||||
list(
|
||||
rv$code$import,
|
||||
rlang::call2(.fn = "select", !!!list(input$import_var), .ns = "dplyr"),
|
||||
rlang::call2(.fn = "default_parsing", .ns = "FreesearchR")
|
||||
) |>
|
||||
merge_expression() |>
|
||||
expression_string()
|
||||
|
||||
rv$list$regression$tables <- out
|
||||
|
||||
rv$list$input <- input
|
||||
|
||||
},
|
||||
warning = function(warn) {
|
||||
showNotification(paste0(warn), type = "warning")
|
||||
|
|
@ -7694,7 +7686,7 @@ regression_server <- function(id,
|
|||
##############################################################################
|
||||
|
||||
return(shiny::reactive({
|
||||
return(rv$list)
|
||||
rv$list
|
||||
}))
|
||||
}
|
||||
)
|
||||
|
|
@ -7880,7 +7872,7 @@ FreesearchR_colors <- function(choose = NULL) {
|
|||
fg = "#000000"
|
||||
)
|
||||
if (!is.null(choose)) {
|
||||
out[choose]
|
||||
unname(out[choose])
|
||||
} else {
|
||||
out
|
||||
}
|
||||
|
|
@ -9201,7 +9193,17 @@ grepl_fix <- function(data, pattern, type = c("prefix", "infix", "suffix")) {
|
|||
|
||||
|
||||
########
|
||||
#### Current file: /Users/au301842/FreesearchR/inst/apps/FreesearchR/ui.R
|
||||
#### Current file: /Users/au301842/FreesearchR/dev/header_include.R
|
||||
########
|
||||
|
||||
header_include <- function(){
|
||||
shiny::tags$head(
|
||||
tags$link(rel = "stylesheet", type = "text/css", href = "style.css"))
|
||||
}
|
||||
|
||||
|
||||
########
|
||||
#### Current file: /Users/au301842/FreesearchR/app/ui.R
|
||||
########
|
||||
|
||||
# ns <- NS(id)
|
||||
|
|
@ -9717,10 +9719,7 @@ dark <- custom_theme(
|
|||
ui <- bslib::page_fixed(
|
||||
prismDependencies,
|
||||
prismRDependency,
|
||||
## Basic Umami page tracking
|
||||
shiny::tags$head(
|
||||
includeHTML(("www/umami-app.html")),
|
||||
tags$link(rel = "stylesheet", type = "text/css", href = "style.css")),
|
||||
header_include(),
|
||||
## This adds the actual favicon
|
||||
## png and ico versions are kept for compatibility
|
||||
shiny::tags$head(tags$link(rel="shortcut icon", href="favicon.svg")),
|
||||
|
|
@ -9743,7 +9742,7 @@ ui <- bslib::page_fixed(
|
|||
style = "background-color: #14131326; padding: 4px; text-align: center; bottom: 0; width: 100%;",
|
||||
shiny::p(
|
||||
style = "margin: 1",
|
||||
"Data is only stored for analyses and deleted when the app is closed."
|
||||
"Data is only stored for analyses and deleted when the app is closed.", shiny::markdown("Consider [running ***FreesearchR*** locally](https://agdamsbo.github.io/FreesearchR/#run-locally-on-your-own-machine) if working with sensitive data.")
|
||||
),
|
||||
shiny::p(
|
||||
style = "margin: 1; color: #888;",
|
||||
|
|
@ -9754,8 +9753,9 @@ ui <- bslib::page_fixed(
|
|||
)
|
||||
|
||||
|
||||
|
||||
########
|
||||
#### Current file: /Users/au301842/FreesearchR/inst/apps/FreesearchR/server.R
|
||||
#### Current file: /Users/au301842/FreesearchR/app/server.R
|
||||
########
|
||||
|
||||
library(readr)
|
||||
|
|
@ -9839,7 +9839,7 @@ server <- function(input, output, session) {
|
|||
|
||||
rv <- shiny::reactiveValues(
|
||||
list = list(),
|
||||
regression = list(),
|
||||
regression = NULL,
|
||||
ds = NULL,
|
||||
local_temp = NULL,
|
||||
ready = NULL,
|
||||
|
|
@ -10234,7 +10234,7 @@ server <- function(input, output, session) {
|
|||
shiny::req(rv$data_filtered)
|
||||
|
||||
rv$list$table1 <- NULL
|
||||
rv$regression <- NULL
|
||||
# rv$regression <- NULL
|
||||
}
|
||||
)
|
||||
|
||||
|
|
@ -10414,6 +10414,22 @@ server <- function(input, output, session) {
|
|||
|
||||
rv$regression <- regression_server("regression", data = shiny::reactive(rv$list$data))
|
||||
|
||||
# shiny::observeEvent(rv$regression, {
|
||||
# browser()
|
||||
# if (shiny::is.reactive(rv$regression)) {
|
||||
# rv$list$regression <- rv$regression()
|
||||
# } else {
|
||||
# rv$list$regression <- rv$regression
|
||||
# }
|
||||
# # rv$list$regression <- rv$regression()
|
||||
# })
|
||||
|
||||
# output$regression_models <- renderText({
|
||||
# req(rv$list$regression)
|
||||
# browser()
|
||||
# names(rv$list$regression)
|
||||
# })
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Page navigation
|
||||
|
|
@ -10464,6 +10480,7 @@ server <- function(input, output, session) {
|
|||
paste0("report.", input$output_type)
|
||||
}),
|
||||
content = function(file, type = input$output_type) {
|
||||
# browser()
|
||||
# shiny::req(rv$list$regression)
|
||||
## Notification is not progressing
|
||||
## Presumably due to missing
|
||||
|
|
@ -10472,6 +10489,11 @@ server <- function(input, output, session) {
|
|||
format <- ifelse(type == "docx", "word_document", "odt_document")
|
||||
|
||||
# browser()
|
||||
# if (shiny::is.reactive(rv$regression)){
|
||||
# rv$list$regression <- rv$regression()
|
||||
# }
|
||||
|
||||
# rv$list$regression <- rv$regression()
|
||||
rv$list$regression <- rv$regression()
|
||||
|
||||
shiny::withProgress(message = "Generating the report. Hold on for a moment..", {
|
||||
|
|
@ -10525,7 +10547,7 @@ server <- function(input, output, session) {
|
|||
|
||||
|
||||
########
|
||||
#### Current file: /Users/au301842/FreesearchR/inst/apps/FreesearchR/launch.R
|
||||
#### Current file: /Users/au301842/FreesearchR/app/launch.R
|
||||
########
|
||||
|
||||
shinyApp(ui, server)
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
shinyApp(ui, server)
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
name: FreesearchR
|
||||
title:
|
||||
username: agdamsbo
|
||||
account: agdamsbo
|
||||
server: shinyapps.io
|
||||
hostUrl: https://api.shinyapps.io/v1
|
||||
appId: 14600805
|
||||
bundleId: 10199884
|
||||
url: https://agdamsbo.shinyapps.io/FreesearchR/
|
||||
version: 1
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
name: freesearcheR
|
||||
title:
|
||||
username: agdamsbo
|
||||
account: agdamsbo
|
||||
server: shinyapps.io
|
||||
hostUrl: https://api.shinyapps.io/v1
|
||||
appId: 13611288
|
||||
bundleId: 10164589
|
||||
url: https://agdamsbo.shinyapps.io/freesearcheR/
|
||||
version: 1
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
name: webResearch
|
||||
title:
|
||||
username: agdamsbo
|
||||
account: agdamsbo
|
||||
server: shinyapps.io
|
||||
hostUrl: https://api.shinyapps.io/v1
|
||||
appId: 13276335
|
||||
bundleId: 9436643
|
||||
url: https://agdamsbo.shinyapps.io/webResearch/
|
||||
version: 1
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
name: freesearcheR_dev
|
||||
title:
|
||||
username: cognitiveindex
|
||||
account: cognitiveindex
|
||||
server: shinyapps.io
|
||||
hostUrl: https://api.shinyapps.io/v1
|
||||
appId: 13786206
|
||||
bundleId: 9688582
|
||||
url: https://cognitiveindex.shinyapps.io/freesearcheR_dev/
|
||||
version: 1
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
name: freesearcheR_extra
|
||||
title:
|
||||
username: cognitiveindex
|
||||
account: cognitiveindex
|
||||
server: shinyapps.io
|
||||
hostUrl: https://api.shinyapps.io/v1
|
||||
appId: 13622743
|
||||
bundleId: 9544828
|
||||
url: https://cognitiveindex.shinyapps.io/freesearcheR_extra/
|
||||
version: 1
|
||||
|
|
@ -1,764 +0,0 @@
|
|||
library(readr)
|
||||
library(MASS)
|
||||
library(stats)
|
||||
library(gt)
|
||||
# library(openxlsx2)
|
||||
library(haven)
|
||||
library(readODS)
|
||||
require(shiny)
|
||||
library(bslib)
|
||||
library(assertthat)
|
||||
library(dplyr)
|
||||
library(quarto)
|
||||
library(here)
|
||||
library(broom)
|
||||
library(broom.helpers)
|
||||
# library(REDCapCAST)
|
||||
library(easystats)
|
||||
# library(esquisse)
|
||||
library(patchwork)
|
||||
library(DHARMa)
|
||||
library(apexcharter)
|
||||
library(toastui)
|
||||
library(datamods)
|
||||
library(IDEAFilter)
|
||||
library(shinyWidgets)
|
||||
library(DT)
|
||||
library(data.table)
|
||||
library(gtsummary)
|
||||
# library(FreesearchR)
|
||||
|
||||
# source("functions.R")
|
||||
|
||||
data(starwars)
|
||||
data(mtcars)
|
||||
mtcars_date <- mtcars |> append_column(as.Date(sample(1:365, nrow(mtcars))), "rand_dates")
|
||||
mtcars_date$date <- as.Date(sample(seq_len(365), nrow(mtcars)))
|
||||
data(trial)
|
||||
|
||||
|
||||
# light <- custom_theme()
|
||||
#
|
||||
# dark <- custom_theme(bg = "#000",fg="#fff")
|
||||
|
||||
|
||||
server <- function(input, output, session) {
|
||||
## Listing files in www in session start to keep when ending and removing
|
||||
## everything else.
|
||||
files.to.keep <- list.files("www/")
|
||||
|
||||
output$docs_file <- shiny::renderUI({
|
||||
# shiny::includeHTML("www/docs.html")
|
||||
shiny::HTML(readLines("www/docs.html"))
|
||||
})
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Night mode (just very popular, not really needed)
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
# observeEvent(input$dark_mode,{
|
||||
# session$setCurrentTheme(
|
||||
# if (isTRUE(input$dark_mode)) dark else light
|
||||
# )})
|
||||
|
||||
# observe({
|
||||
# if(input$dark_mode==TRUE)
|
||||
# session$setCurrentTheme(bs_theme_update(theme = custom_theme(version = 5)))
|
||||
# if(input$dark_mode==FALSE)
|
||||
# session$setCurrentTheme(bs_theme_update(theme = custom_theme(version = 5, bg = "#000",fg="#fff")))
|
||||
# })
|
||||
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Setting reactive values
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
rv <- shiny::reactiveValues(
|
||||
list = list(),
|
||||
regression = list(),
|
||||
ds = NULL,
|
||||
local_temp = NULL,
|
||||
ready = NULL,
|
||||
test = "no",
|
||||
data_original = NULL,
|
||||
data_temp = NULL,
|
||||
data = NULL,
|
||||
data_variables = NULL,
|
||||
data_filtered = NULL,
|
||||
models = NULL,
|
||||
code = list()
|
||||
)
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Data import section
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
data_file <- import_file_server(
|
||||
id = "file_import",
|
||||
show_data_in = "popup",
|
||||
trigger_return = "change",
|
||||
return_class = "data.frame"
|
||||
)
|
||||
|
||||
shiny::observeEvent(data_file$data(), {
|
||||
shiny::req(data_file$data())
|
||||
rv$data_temp <- data_file$data()
|
||||
rv$code <- modifyList(x = rv$code, list(import = data_file$code()))
|
||||
})
|
||||
|
||||
from_redcap <- m_redcap_readServer(
|
||||
id = "redcap_import"
|
||||
)
|
||||
|
||||
shiny::observeEvent(from_redcap$data(), {
|
||||
rv$data_temp <- from_redcap$data()
|
||||
rv$code <- modifyList(x = rv$code, list(import = from_redcap$code()))
|
||||
})
|
||||
|
||||
## This is used to ensure the reactive data is retrieved
|
||||
output$redcap_prev <- DT::renderDT(
|
||||
{
|
||||
DT::datatable(head(from_redcap$data(), 5),
|
||||
caption = "First 5 observations"
|
||||
)
|
||||
},
|
||||
server = TRUE
|
||||
)
|
||||
|
||||
from_env <- datamods::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_temp <- from_env$data()
|
||||
rv$code <- modifyList(x = rv$code, list(import = from_env$name()))
|
||||
})
|
||||
|
||||
output$import_var <- shiny::renderUI({
|
||||
shiny::req(rv$data_temp)
|
||||
|
||||
preselect <- names(rv$data_temp)[sapply(rv$data_temp, missing_fraction) <= input$complete_cutoff / 100]
|
||||
|
||||
shinyWidgets::virtualSelectInput(
|
||||
inputId = "import_var",
|
||||
label = "Select variables to include",
|
||||
selected = preselect,
|
||||
choices = names(rv$data_temp),
|
||||
updateOn = "change",
|
||||
multiple = TRUE,
|
||||
search = TRUE,
|
||||
showValueAsTags = TRUE
|
||||
)
|
||||
})
|
||||
|
||||
output$data_loaded <- shiny::reactive({
|
||||
!is.null(rv$data_temp)
|
||||
})
|
||||
|
||||
shiny::observeEvent(input$source, {
|
||||
rv$data_temp <- NULL
|
||||
})
|
||||
|
||||
shiny::outputOptions(output, "data_loaded", suspendWhenHidden = FALSE)
|
||||
|
||||
shiny::observeEvent(
|
||||
eventExpr = list(
|
||||
input$import_var,
|
||||
input$complete_cutoff,
|
||||
rv$data_temp
|
||||
),
|
||||
handlerExpr = {
|
||||
shiny::req(rv$data_temp)
|
||||
shiny::req(input$import_var)
|
||||
# browser()
|
||||
temp_data <- rv$data_temp
|
||||
if (all(input$import_var %in% names(temp_data))) {
|
||||
temp_data <- temp_data |> dplyr::select(input$import_var)
|
||||
}
|
||||
|
||||
rv$data_original <- temp_data |>
|
||||
default_parsing()
|
||||
|
||||
rv$code$import <- rv$code$import |>
|
||||
expression_string(assign.str = "df <-")
|
||||
|
||||
rv$code$format <- list(
|
||||
"df",
|
||||
rlang::expr(dplyr::select(dplyr::all_of(!!input$import_var))),
|
||||
rlang::call2(.fn = "default_parsing", .ns = "FreesearchR")
|
||||
) |>
|
||||
lapply(expression_string) |>
|
||||
pipe_string() |>
|
||||
expression_string(assign.str = "df <-")
|
||||
|
||||
rv$code$filter <- NULL
|
||||
rv$code$modify <- NULL
|
||||
}, ignoreNULL = FALSE
|
||||
)
|
||||
|
||||
output$data_info_import <- shiny::renderUI({
|
||||
shiny::req(rv$data_original)
|
||||
data_description(rv$data_original)
|
||||
})
|
||||
|
||||
## Activating action buttons on data imported
|
||||
shiny::observeEvent(rv$data_original, {
|
||||
if (is.null(rv$data_original) | NROW(rv$data_original) == 0) {
|
||||
shiny::updateActionButton(inputId = "act_start", disabled = TRUE)
|
||||
shiny::updateActionButton(inputId = "modal_browse", disabled = TRUE)
|
||||
shiny::updateActionButton(inputId = "act_eval", disabled = TRUE)
|
||||
} else {
|
||||
shiny::updateActionButton(inputId = "act_start", disabled = FALSE)
|
||||
shiny::updateActionButton(inputId = "modal_browse", disabled = FALSE)
|
||||
shiny::updateActionButton(inputId = "act_eval", disabled = FALSE)
|
||||
}
|
||||
})
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Data modification section
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
shiny::observeEvent(
|
||||
eventExpr = list(
|
||||
rv$data_original
|
||||
),
|
||||
handlerExpr = {
|
||||
shiny::req(rv$data_original)
|
||||
|
||||
rv$data <- rv$data_original
|
||||
}
|
||||
)
|
||||
|
||||
## For now this solution work, but I would prefer to solve this with the above
|
||||
shiny::observeEvent(input$reset_confirm,
|
||||
{
|
||||
if (isTRUE(input$reset_confirm)) {
|
||||
shiny::req(rv$data_original)
|
||||
rv$data <- rv$data_original
|
||||
rv$code$filter <- NULL
|
||||
rv$code$variables <- NULL
|
||||
rv$code$modify <- NULL
|
||||
}
|
||||
},
|
||||
ignoreNULL = TRUE
|
||||
)
|
||||
|
||||
|
||||
shiny::observeEvent(input$data_reset, {
|
||||
shinyWidgets::ask_confirmation(
|
||||
cancelOnDismiss = TRUE,
|
||||
inputId = "reset_confirm",
|
||||
title = "Please confirm data reset?",
|
||||
type = "warning"
|
||||
)
|
||||
})
|
||||
|
||||
|
||||
#########
|
||||
######### Modifications
|
||||
#########
|
||||
|
||||
## 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
|
||||
|
||||
output$data_info <- shiny::renderUI({
|
||||
shiny::req(data_filter())
|
||||
data_description(data_filter(), "The filtered data")
|
||||
})
|
||||
|
||||
######### Create factor
|
||||
|
||||
shiny::observeEvent(
|
||||
input$modal_cut,
|
||||
modal_cut_variable("modal_cut", title = "Create new factor")
|
||||
)
|
||||
|
||||
data_modal_cut <- cut_variable_server(
|
||||
id = "modal_cut",
|
||||
data_r = shiny::reactive(rv$data)
|
||||
)
|
||||
|
||||
shiny::observeEvent(data_modal_cut(), {
|
||||
rv$data <- data_modal_cut()
|
||||
rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code")
|
||||
})
|
||||
|
||||
######### Modify factor
|
||||
|
||||
shiny::observeEvent(
|
||||
input$modal_update,
|
||||
datamods::modal_update_factor(id = "modal_update", title = "Reorder factor levels")
|
||||
)
|
||||
|
||||
data_modal_update <- datamods::update_factor_server(
|
||||
id = "modal_update",
|
||||
data_r = reactive(rv$data)
|
||||
)
|
||||
|
||||
shiny::observeEvent(data_modal_update(), {
|
||||
shiny::removeModal()
|
||||
rv$data <- data_modal_update()
|
||||
rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code")
|
||||
})
|
||||
|
||||
######### Create column
|
||||
|
||||
shiny::observeEvent(
|
||||
input$modal_column,
|
||||
modal_create_column(
|
||||
id = "modal_column",
|
||||
footer = shiny::markdown("This window is aimed at advanced users and require some *R*-experience!"),
|
||||
title = "Create new variables"
|
||||
)
|
||||
)
|
||||
data_modal_r <- create_column_server(
|
||||
id = "modal_column",
|
||||
data_r = reactive(rv$data)
|
||||
)
|
||||
shiny::observeEvent(
|
||||
data_modal_r(),
|
||||
{
|
||||
rv$data <- data_modal_r()
|
||||
rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code")
|
||||
}
|
||||
)
|
||||
|
||||
######### Subset, rename, reclass
|
||||
|
||||
updated_data <- update_variables_server(
|
||||
id = "modal_variables",
|
||||
data = shiny::reactive(rv$data),
|
||||
return_data_on_init = FALSE
|
||||
)
|
||||
|
||||
shiny::observeEvent(updated_data(), {
|
||||
rv$data <- updated_data()
|
||||
rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code")
|
||||
})
|
||||
|
||||
### Column filter
|
||||
### Completely implemented, but it takes a little considering where in the
|
||||
### data flow to implement, as it will act destructively on previous
|
||||
### manipulations
|
||||
|
||||
output$column_filter <- shiny::renderUI({
|
||||
shiny::req(rv$data)
|
||||
# c("dichotomous", "ordinal", "categorical", "datatime", "continuous")
|
||||
shinyWidgets::virtualSelectInput(
|
||||
inputId = "column_filter",
|
||||
label = "Select variable types to include",
|
||||
selected = unique(data_type(rv$data)),
|
||||
choices = unique(data_type(rv$data)),
|
||||
updateOn = "change",
|
||||
multiple = TRUE,
|
||||
search = FALSE,
|
||||
showValueAsTags = TRUE
|
||||
)
|
||||
})
|
||||
|
||||
shiny::observe({
|
||||
# shiny::req(input$column_filter)
|
||||
out <- data_type_filter(rv$data, input$column_filter)
|
||||
rv$data_variables <- out
|
||||
if (!is.null(input$column_filter)) {
|
||||
rv$code$variables <- attr(out, "code")
|
||||
}
|
||||
# rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code")
|
||||
})
|
||||
|
||||
|
||||
######### Data filter
|
||||
# IDEAFilter has the least cluttered UI, but might have a License issue
|
||||
# Consider using shinyDataFilter, though not on CRAN
|
||||
data_filter <- IDEAFilter::IDEAFilter("data_filter",
|
||||
data = shiny::reactive(rv$data_variables),
|
||||
verbose = TRUE
|
||||
)
|
||||
|
||||
shiny::observeEvent(
|
||||
list(
|
||||
shiny::reactive(rv$data_variables),
|
||||
shiny::reactive(rv$data_original),
|
||||
data_filter(),
|
||||
# regression_vars(),
|
||||
input$complete_cutoff
|
||||
),
|
||||
{
|
||||
### Save filtered data
|
||||
rv$data_filtered <- data_filter()
|
||||
|
||||
### Save filtered data
|
||||
### without empty factor levels
|
||||
rv$list$data <- data_filter() |>
|
||||
REDCapCAST::fct_drop() |>
|
||||
(\(.x){
|
||||
.x[!sapply(.x, is.character)]
|
||||
})()
|
||||
|
||||
## This looks messy!! But it works as intended for now
|
||||
|
||||
out <- gsub(
|
||||
"filter", "dplyr::filter",
|
||||
gsub(
|
||||
"\\s{2,}", " ",
|
||||
paste0(
|
||||
capture.output(attr(rv$data_filtered, "code")),
|
||||
collapse = " "
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
out <- strsplit(out, "%>%") |>
|
||||
unlist() |>
|
||||
(\(.x){
|
||||
paste(c("df <- df", .x[-1], "REDCapCAST::fct_drop()"),
|
||||
collapse = "|> \n "
|
||||
)
|
||||
})()
|
||||
|
||||
rv$code <- append_list(data = out, list = rv$code, index = "filter")
|
||||
}
|
||||
)
|
||||
|
||||
######### Data preview
|
||||
|
||||
### Overview
|
||||
|
||||
data_summary_server(
|
||||
id = "data_summary",
|
||||
data = shiny::reactive({
|
||||
rv$data_filtered
|
||||
}),
|
||||
color.main = "#2A004E",
|
||||
color.sec = "#C62300",
|
||||
pagination = 10
|
||||
)
|
||||
|
||||
observeEvent(input$modal_browse, {
|
||||
show_data(REDCapCAST::fct_drop(rv$data_filtered), title = "Uploaded data overview", type = "modal")
|
||||
})
|
||||
|
||||
output$original_str <- renderPrint({
|
||||
str(rv$data_original)
|
||||
})
|
||||
|
||||
output$modified_str <- renderPrint({
|
||||
str(as.data.frame(rv$data_filtered) |>
|
||||
REDCapCAST::set_attr(
|
||||
label = NULL,
|
||||
attr = "code"
|
||||
))
|
||||
})
|
||||
|
||||
## Evaluation table/plots reset on data change
|
||||
## This does not work (!?)
|
||||
shiny::observeEvent(
|
||||
list(
|
||||
rv$data_filtered
|
||||
),
|
||||
{
|
||||
shiny::req(rv$data_filtered)
|
||||
|
||||
rv$list$table1 <- NULL
|
||||
rv$regression <- NULL
|
||||
}
|
||||
)
|
||||
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Code export
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
## This really should be collapsed to only one call, but I'll leave it for now
|
||||
## as a working example of dynamically defining outputs and rendering.
|
||||
|
||||
# output$code_import <- shiny::renderPrint({
|
||||
# shiny::req(rv$code$import)
|
||||
# cat(c("#Data import\n", rv$code$import))
|
||||
# })
|
||||
|
||||
output$code_import <- shiny::renderUI({
|
||||
prismCodeBlock(paste0("#Data import\n", rv$code$import))
|
||||
})
|
||||
|
||||
output$code_import <- shiny::renderUI({
|
||||
prismCodeBlock(paste0("#Data import formatting\n", rv$code$format))
|
||||
})
|
||||
|
||||
output$code_data <- shiny::renderUI({
|
||||
shiny::req(rv$code$modify)
|
||||
# browser()
|
||||
## This will create three lines for each modification
|
||||
# ls <- rv$code$modify
|
||||
## This will remove all non-unique entries
|
||||
# ls <- rv$code$modify |> unique()
|
||||
## This will only remove all non-repeating entries
|
||||
ls <- rv$code$modify[!is_identical_to_previous(rv$code$modify)]
|
||||
|
||||
out <- ls |>
|
||||
lapply(expression_string) |>
|
||||
pipe_string() |>
|
||||
expression_string(assign.str = "df <- df |>\n")
|
||||
|
||||
prismCodeBlock(paste0("#Data modifications\n", out))
|
||||
})
|
||||
|
||||
output$code_variables <- shiny::renderUI({
|
||||
shiny::req(rv$code$variables)
|
||||
out <- expression_string(rv$code$variables, assign.str = "df <- df |>\n")
|
||||
prismCodeBlock(paste0("#Variables filter\n", out))
|
||||
})
|
||||
|
||||
output$code_filter <- shiny::renderUI({
|
||||
shiny::req(rv$code$filter)
|
||||
prismCodeBlock(paste0("#Data filter\n", rv$code$filter))
|
||||
})
|
||||
|
||||
output$code_table1 <- shiny::renderUI({
|
||||
shiny::req(rv$code$table1)
|
||||
prismCodeBlock(paste0("#Data characteristics table\n", rv$code$table1))
|
||||
})
|
||||
|
||||
|
||||
## Just a note to self
|
||||
## This is a very rewarding couple of lines marking new insights to dynamically rendering code
|
||||
shiny::observe({
|
||||
shiny::req(rv$regression)
|
||||
rv$regression()$regression$models |> purrr::imap(\(.x, .i){
|
||||
output[[paste0("code_", tolower(.i))]] <- shiny::renderUI({
|
||||
prismCodeBlock(paste0(paste("#", .i, "regression model\n"), .x$code_table))
|
||||
})
|
||||
})
|
||||
})
|
||||
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Data analyses Inputs
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
output$strat_var <- shiny::renderUI({
|
||||
columnSelectInput(
|
||||
inputId = "strat_var",
|
||||
selected = "none",
|
||||
label = "Select variable to stratify baseline",
|
||||
data = shiny::reactive(rv$data_filtered)(),
|
||||
col_subset = c(
|
||||
"none",
|
||||
names(rv$data_filtered)[unlist(lapply(rv$data_filtered, data_type)) %in% c("dichotomous", "categorical", "ordinal")]
|
||||
)
|
||||
)
|
||||
})
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Descriptive evaluations
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
|
||||
output$data_info_nochar <- shiny::renderUI({
|
||||
shiny::req(rv$list$data)
|
||||
data_description(rv$list$data, data_text = "The dataset without text variables")
|
||||
})
|
||||
|
||||
shiny::observeEvent(
|
||||
list(
|
||||
input$act_eval
|
||||
),
|
||||
{
|
||||
shiny::req(input$strat_var)
|
||||
shiny::req(rv$list$data)
|
||||
|
||||
parameters <- list(
|
||||
by.var = input$strat_var,
|
||||
add.p = input$add_p == "yes",
|
||||
add.overall = TRUE
|
||||
)
|
||||
|
||||
shiny::withProgress(message = "Creating the table. Hold on for a moment..", {
|
||||
rv$list$table1 <- rlang::exec(create_baseline, !!!append_list(rv$list$data, parameters, "data"))
|
||||
})
|
||||
|
||||
rv$code$table1 <- glue::glue("FreesearchR::create_baseline(data,{list2str(parameters)})")
|
||||
}
|
||||
)
|
||||
|
||||
output$outcome_var_cor <- shiny::renderUI({
|
||||
columnSelectInput(
|
||||
inputId = "outcome_var_cor",
|
||||
selected = "none",
|
||||
data = rv$list$data,
|
||||
label = "Select outcome variable",
|
||||
col_subset = c(
|
||||
"none",
|
||||
colnames(rv$list$data)
|
||||
),
|
||||
multiple = FALSE
|
||||
)
|
||||
})
|
||||
|
||||
output$table1 <- gt::render_gt({
|
||||
if (!is.null(rv$list$table1)) {
|
||||
rv$list$table1 |>
|
||||
gtsummary::as_gt() |>
|
||||
gt::tab_header(gt::md("**Table 1: Baseline Characteristics**"))
|
||||
} else {
|
||||
return(NULL)
|
||||
}
|
||||
})
|
||||
|
||||
data_correlations_server(
|
||||
id = "correlations",
|
||||
data = shiny::reactive({
|
||||
shiny::req(rv$list$data)
|
||||
out <- rv$list$data
|
||||
if (!is.null(input$outcome_var_cor) && input$outcome_var_cor != "none") {
|
||||
out <- out[!names(out) %in% input$outcome_var_cor]
|
||||
}
|
||||
out
|
||||
}),
|
||||
cutoff = shiny::reactive(input$cor_cutoff)
|
||||
)
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Data visuals
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
pl <- data_visuals_server("visuals", data = shiny::reactive(rv$list$data))
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Regression model analyses
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
rv$regression <- regression_server("regression", data = shiny::reactive(rv$list$data))
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Page navigation
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
shiny::observeEvent(input$act_start, {
|
||||
bslib::nav_select(id = "main_panel", selected = "Data")
|
||||
})
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Reactivity
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
output$uploaded <- shiny::reactive({
|
||||
if (is.null(rv$ds)) {
|
||||
"no"
|
||||
} else {
|
||||
"yes"
|
||||
}
|
||||
})
|
||||
|
||||
shiny::outputOptions(output, "uploaded", suspendWhenHidden = FALSE)
|
||||
|
||||
output$ready <- shiny::reactive({
|
||||
if (is.null(rv$ready)) {
|
||||
"no"
|
||||
} else {
|
||||
"yes"
|
||||
}
|
||||
})
|
||||
|
||||
shiny::outputOptions(output, "ready", suspendWhenHidden = FALSE)
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Downloads
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
# Could be rendered with other tables or should show progress
|
||||
# Investigate quarto render problems
|
||||
# On temp file handling: https://github.com/quarto-dev/quarto-cli/issues/3992
|
||||
output$report <- downloadHandler(
|
||||
filename = shiny::reactive({
|
||||
paste0("report.", input$output_type)
|
||||
}),
|
||||
content = function(file, type = input$output_type) {
|
||||
# shiny::req(rv$list$regression)
|
||||
## Notification is not progressing
|
||||
## Presumably due to missing
|
||||
# browser()
|
||||
# Simplified for .rmd output attempt
|
||||
format <- ifelse(type == "docx", "word_document", "odt_document")
|
||||
|
||||
# browser()
|
||||
rv$list$regression <- rv$regression()
|
||||
|
||||
shiny::withProgress(message = "Generating the report. Hold on for a moment..", {
|
||||
tryCatch(
|
||||
{
|
||||
rv$list |>
|
||||
write_rmd(
|
||||
output_format = format,
|
||||
input = file.path(getwd(), "www/report.rmd")
|
||||
)
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0("We encountered the following error creating your report: ", err), type = "err")
|
||||
}
|
||||
)
|
||||
})
|
||||
file.rename(paste0("www/report.", type), file)
|
||||
}
|
||||
)
|
||||
|
||||
output$data_modified <- downloadHandler(
|
||||
filename = shiny::reactive({
|
||||
paste0("modified_data.", input$data_type)
|
||||
}),
|
||||
content = function(file, type = input$data_type) {
|
||||
if (type == "rds") {
|
||||
readr::write_rds(rv$list$data, file = file)
|
||||
} else if (type == "dta") {
|
||||
haven::write_dta(as.data.frame(rv$list$data), path = file)
|
||||
} else if (type == "csv") {
|
||||
readr::write_csv(rv$list$data, file = file)
|
||||
}
|
||||
}
|
||||
)
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Clearing the session on end
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
session$onSessionEnded(function() {
|
||||
cat("Session Ended\n")
|
||||
files <- list.files("www/")
|
||||
lapply(files[!files %in% files.to.keep], \(.x){
|
||||
unlink(paste0("www/", .x), recursive = FALSE)
|
||||
print(paste(.x, "deleted"))
|
||||
})
|
||||
})
|
||||
}
|
||||
|
|
@ -508,13 +508,10 @@ dark <- custom_theme(
|
|||
# Fonts to consider:
|
||||
# https://webdesignerdepot.com/17-open-source-fonts-youll-actually-love/
|
||||
|
||||
ui <- bslib::page_fixed(
|
||||
ui_list <- shiny::tagList(
|
||||
prismDependencies,
|
||||
prismRDependency,
|
||||
## Basic Umami page tracking
|
||||
shiny::tags$head(
|
||||
includeHTML(("www/umami-app.html")),
|
||||
tags$link(rel = "stylesheet", type = "text/css", href = "style.css")),
|
||||
header_include(),
|
||||
## This adds the actual favicon
|
||||
## png and ico versions are kept for compatibility
|
||||
shiny::tags$head(tags$link(rel="shortcut icon", href="favicon.svg")),
|
||||
|
|
@ -546,3 +543,12 @@ ui <- bslib::page_fixed(
|
|||
)
|
||||
)
|
||||
)
|
||||
|
||||
# ui_list <- shiny::tagAppendChild(ui_list,list(
|
||||
# ## Basic Umami page tracking
|
||||
# shiny::tags$head(includeHTML("www/umami-app.html"))
|
||||
# # shiny::tags$head(shiny::tags$script(rel="defer", src="https://analytics.gdamsbo.dk/script.js", "data-website-id"="e7d4e13a-5824-4778-bbc0-8f92fb08303a"))
|
||||
# ))
|
||||
|
||||
ui <- do.call(
|
||||
bslib::page_fixed,ui_list)
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
<script defer src="https://analytics.gdamsbo.dk/script.js" data-website-id="e7d4e13a-5824-4778-bbc0-8f92fb08303a"></script>
|
||||
Loading…
Add table
Reference in a new issue