andreas/FreesearchR
1
0
Fork 0
mirror of https://github.com/agdamsbo/FreesearchR.git synced 2025-09-12 09:59:39 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

new completeness filter, analyses have been split, correlation plot included.

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2025-02-07 16:24:09 +01:00
parent f728bb1e8e
commit b268b90aae
No known key found for this signature in database
17 changed files with 10563 additions and 2495 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
DESCRIPTION
View file

@ -63,7 +63,8 @@ Imports:
gvlma, gvlma,
psych, psych,
jtools, jtools,
Hmisc Hmisc,
ggstats
Suggests: Suggests:
styler, styler,
devtools, devtools,

2
R/app_version.R
View file

@ -1 +1 @@
app_version <- function()'250130_1152' app_version <- function()'250207_1622'

136
R/correlations-module.R Normal file
View file

@ -0,0 +1,136 @@
#' Data correlations evaluation module
#'
#' @param id Module id. (Use 'ns("id")')
#'
#' @name data-correlations
#' @returns Shiny ui module
#' @export
data_correlations_ui <- function(id, ...) {
ns <- NS(id)
shiny::tagList(
shiny::textOutput(outputId = ns("suggest")),
shiny::plotOutput(outputId = ns("correlation_plot"), ...)
)
}
#'
#' @param data data
#' @param color.main main color
#' @param color.sec secondary color
#' @param ... arguments passed to toastui::datagrid
#'
#' @name data-correlations
#' @returns shiny server module
#' @export
data_correlations_server <- function(id,
data,
include.class = NULL,
cutoff = .7,
...) {
shiny::moduleServer(
id = id,
module = function(input, output, session) {
# ns <- session$ns
rv <- shiny::reactiveValues(
data = NULL
)
rv$data <- shiny::reactive({
shiny::req(data)
if (!is.null(include.class)) {
filter <- sapply(data(), class) %in% include.class
out <- data()[filter]
} else {
out <- data()
}
out
})
# rv <- list()
# rv$data <- mtcars
output$suggest <- shiny::renderPrint({
shiny::req(rv$data)
shiny::req(cutoff)
pairs <- correlation_pairs(rv$data(), threshold = cutoff())
more <- ifelse(nrow(pairs) > 1, "from each pair ", "")
if (nrow(pairs) == 0) {
out <- glue::glue("No variables have a correlation measure above the threshold.")
} else {
out <- pairs |>
apply(1, \(.x){
glue::glue("'{.x[1]}'x'{.x[2]}'({round(as.numeric(.x[3]),2)})")
}) |>
(\(.x){
glue::glue("The following variable pairs are highly correlated: {sentence_paste(.x)}.\nConsider excluding one {more}from the dataset to ensure variables are independent.")
})()
}
out
})
output$correlation_plot <- shiny::renderPlot({
psych::pairs.panels(rv$data())
})
}
)
}
correlation_pairs <- function(data, threshold = .8) {
data <- data[!sapply(data, is.character)]
data <- data |> dplyr::mutate(dplyr::across(dplyr::where(is.factor), as.numeric))
cor <- Hmisc::rcorr(as.matrix(data))
r <- cor$r %>% as.table()
d <- r |>
as.data.frame() |>
dplyr::filter(abs(Freq) > threshold, Freq != 1)
d[1:2] |>
apply(1, \(.x){
sort(unname(.x))
},
simplify = logical(1)
) |>
duplicated() |>
(\(.x){
d[!.x, ]
})() |>
setNames(c("var1", "var2", "cor"))
}
sentence_paste <- function(data, and.str = "and") {
and.str <- gsub(" ", "", and.str)
if (length(data) < 2) {
data
} else if (length(data) == 2) {
paste(data, collapse = glue::glue(" {and.str} "))
} else if (length(data) > 2) {
paste(paste(data[-length(data)], collapse = ", "), data[length(data)], collapse = glue::glue(" {and.str} "))
}
}
cor_app <- function() {
ui <- shiny::fluidPage(
shiny::sliderInput(
inputId = "cor_cutoff",
label = "Correlation cut-off",
min = 0,
max = 1,
step = .1,
value = .7,
ticks = FALSE
),
data_correlations_ui("data", height = 600)
)
server <- function(input, output, session) {
data_correlations_server("data", data = shiny::reactive(mtcars), cutoff = shiny::reactive(input$cor_cutoff))
}
shiny::shinyApp(ui, server)
}
cor_app()

17
R/helpers.R
View file

@ -249,3 +249,20 @@ remove_na_attr <- function(data,attr="label"){
dplyr::bind_cols(out) dplyr::bind_cols(out)
} }
#' Removes columns with completenes below cutoff
#'
#' @param data data frame
#' @param cutoff numeric
#'
#' @returns data frame
#' @export
#'
#' @examples
#'data.frame(a=1:10,b=NA, c=c(2,NA)) |> remove_empty_cols(cutoff=.5)
remove_empty_cols <- function(data,cutoff=.7){
filter <- apply(X = data,MARGIN = 2,FUN = \(.x){
sum(as.numeric(!is.na(.x)))/length(.x)
}) >= cutoff
data[filter]
}

1
R/report.R
View file

@ -79,3 +79,4 @@ modify_qmd <- function(file, format) {
specify_qmd_format(fileformat = "all") |> specify_qmd_format(fileformat = "all") |>
writeLines(paste0(tools::file_path_sans_ext(file), "_format.", tools::file_ext(file))) writeLines(paste0(tools::file_path_sans_ext(file), "_format.", tools::file_ext(file)))
} }

1
R/theme.R
View file

@ -25,6 +25,7 @@ custom_theme <- function(...,
){ ){
bslib::bs_theme( bslib::bs_theme(
..., ...,
"navbar-bg" = primary,
version = version, version = version,
primary = primary, primary = primary,
secondary = secondary, secondary = secondary,

50
R/update-variables-ext.R
View file

@ -461,6 +461,15 @@ update_variables_datagrid <- function(data, height = NULL, selectionId = NULL, b
fontStyle = "italic" fontStyle = "italic"
) )
grid <- toastui::grid_filters(
grid = grid,
column = "name",
# columns = unname(std_names[std_names!="vals"]),
showApplyBtn = FALSE,
showClearBtn = TRUE,
type = "text"
)
# grid <- toastui::grid_columns( # grid <- toastui::grid_columns(
# grid = grid, # grid = grid,
# columns = "name_toset", # columns = "name_toset",
@ -571,6 +580,7 @@ convert_to <- function(data,
new_class <- match.arg(new_class, several.ok = TRUE) new_class <- match.arg(new_class, several.ok = TRUE)
stopifnot(length(new_class) == length(variable)) stopifnot(length(new_class) == length(variable))
args <- list(...) args <- list(...)
args$format <- clean_sep(args$format)
if (length(variable) > 1) { if (length(variable) > 1) {
for (i in seq_along(variable)) { for (i in seq_along(variable)) {
data <- convert_to(data, variable[i], new_class[i], ...) data <- convert_to(data, variable[i], new_class[i], ...)
@ -602,10 +612,10 @@ convert_to <- function(data,
setNames(list(expr(as.integer(!!sym(variable)))), variable) setNames(list(expr(as.integer(!!sym(variable)))), variable)
) )
} else if (identical(new_class, "date")) { } else if (identical(new_class, "date")) {
data[[variable]] <- as.Date(x = data[[variable]], ...) data[[variable]] <- as.Date(x = clean_date(data[[variable]]), ...)
attr(data, "code_03_convert") <- c( attr(data, "code_03_convert") <- c(
attr(data, "code_03_convert"), attr(data, "code_03_convert"),
setNames(list(expr(as.Date(!!sym(variable), origin = !!args$origin))), variable) setNames(list(expr(as.Date(clean_date(!!sym(variable)), origin = !!args$origin, format=clean_sep(!!args$format)))), variable)
) )
} else if (identical(new_class, "datetime")) { } else if (identical(new_class, "datetime")) {
data[[variable]] <- as.POSIXct(x = data[[variable]], ...) data[[variable]] <- as.POSIXct(x = data[[variable]], ...)
@ -710,3 +720,39 @@ get_vars_to_convert <- function(vars, classes_input) {
} }
#' gsub wrapper for piping with default values for separator substituting
#'
#' @param data character vector
#' @param old.sep old separator
#' @param new.sep new separator
#'
#' @returns character vector
#' @export
#'
clean_sep <- function(data,old.sep="[-.,/]",new.sep="-"){
gsub(old.sep,new.sep,data)
}
#' Attempts at applying uniform date format
#'
#' @param data character string vector of possible dates
#'
#' @returns character string
#' @export
#'
clean_date <- function(data){
data |>
clean_sep() |>
sapply(\(.x){
if (is.na(.x)){
.x
} else {
strsplit(.x,"-") |>
unlist()|>
lapply(\(.y){
if (nchar(.y)==1) paste0("0",.y) else .y
}) |> paste(collapse="-")
}
}) |>
unname()
}

620
inst/apps/data_analysis_modules/app.R
View file

@ -10,7 +10,7 @@
#### Current file: R//app_version.R #### Current file: R//app_version.R
######## ########
app_version <- function()'250130_1152' app_version <- function()'250207_1622'
######## ########
@ -41,6 +41,148 @@ baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary,
########
#### Current file: R//correlations-module.R
########
#' Data correlations evaluation module
#'
#' @param id Module id. (Use 'ns("id")')
#'
#' @name data-correlations
#' @returns Shiny ui module
#' @export
data_correlations_ui <- function(id, ...) {
ns <- NS(id)
shiny::tagList(
shiny::textOutput(outputId = ns("suggest")),
shiny::plotOutput(outputId = ns("correlation_plot"), ...)
)
}
#'
#' @param data data
#' @param color.main main color
#' @param color.sec secondary color
#' @param ... arguments passed to toastui::datagrid
#'
#' @name data-correlations
#' @returns shiny server module
#' @export
data_correlations_server <- function(id,
data,
include.class = NULL,
cutoff = .7,
...) {
shiny::moduleServer(
id = id,
module = function(input, output, session) {
# ns <- session$ns
rv <- shiny::reactiveValues(
data = NULL
)
rv$data <- shiny::reactive({
shiny::req(data)
if (!is.null(include.class)) {
filter <- sapply(data(), class) %in% include.class
out <- data()[filter]
} else {
out <- data()
}
out
})
# rv <- list()
# rv$data <- mtcars
output$suggest <- shiny::renderPrint({
shiny::req(rv$data)
shiny::req(cutoff)
pairs <- correlation_pairs(rv$data(), threshold = cutoff())
more <- ifelse(nrow(pairs) > 1, "from each pair ", "")
if (nrow(pairs) == 0) {
out <- glue::glue("No variables have a correlation measure above the threshold.")
} else {
out <- pairs |>
apply(1, \(.x){
glue::glue("'{.x[1]}'x'{.x[2]}'({round(as.numeric(.x[3]),2)})")
}) |>
(\(.x){
glue::glue("The following variable pairs are highly correlated: {sentence_paste(.x)}.\nConsider excluding one {more}from the dataset to ensure variables are independent.")
})()
}
out
})
output$correlation_plot <- shiny::renderPlot({
psych::pairs.panels(rv$data())
})
}
)
}
correlation_pairs <- function(data, threshold = .8) {
data <- data[!sapply(data, is.character)]
data <- data |> dplyr::mutate(dplyr::across(dplyr::where(is.factor), as.numeric))
cor <- Hmisc::rcorr(as.matrix(data))
r <- cor$r %>% as.table()
d <- r |>
as.data.frame() |>
dplyr::filter(abs(Freq) > threshold, Freq != 1)
d[1:2] |>
apply(1, \(.x){
sort(unname(.x))
},
simplify = logical(1)
) |>
duplicated() |>
(\(.x){
d[!.x, ]
})() |>
setNames(c("var1", "var2", "cor"))
}
sentence_paste <- function(data, and.str = "and") {
and.str <- gsub(" ", "", and.str)
if (length(data) < 2) {
data
} else if (length(data) == 2) {
paste(data, collapse = glue::glue(" {and.str} "))
} else if (length(data) > 2) {
paste(paste(data[-length(data)], collapse = ", "), data[length(data)], collapse = glue::glue(" {and.str} "))
}
}
cor_app <- function() {
ui <- shiny::fluidPage(
shiny::sliderInput(
inputId = "cor_cutoff",
label = "Correlation cut-off",
min = 0,
max = 1,
step = .1,
value = .7,
ticks = FALSE
),
data_correlations_ui("data", height = 600)
)
server <- function(input, output, session) {
data_correlations_server("data", data = shiny::reactive(mtcars), cutoff = shiny::reactive(input$cor_cutoff))
}
shiny::shinyApp(ui, server)
}
cor_app()
######## ########
#### Current file: R//cut-variable-dates.R #### Current file: R//cut-variable-dates.R
######## ########
@ -1367,6 +1509,23 @@ remove_na_attr <- function(data,attr="label"){
dplyr::bind_cols(out) dplyr::bind_cols(out)
} }
#' Removes columns with completenes below cutoff
#'
#' @param data data frame
#' @param cutoff numeric
#'
#' @returns data frame
#' @export
#'
#' @examples
#'data.frame(a=1:10,b=NA, c=c(2,NA)) |> remove_empty_cols(cutoff=.5)
remove_empty_cols <- function(data,cutoff=.7){
filter <- apply(X = data,MARGIN = 2,FUN = \(.x){
sum(as.numeric(!is.na(.x)))/length(.x)
}) >= cutoff
data[filter]
}
######## ########
#### Current file: R//redcap_read_shiny_module.R #### Current file: R//redcap_read_shiny_module.R
@ -2743,6 +2902,7 @@ modify_qmd <- function(file, format) {
} }
######## ########
#### Current file: R//shiny_freesearcheR.R #### Current file: R//shiny_freesearcheR.R
######## ########
@ -2805,6 +2965,7 @@ custom_theme <- function(...,
){ ){
bslib::bs_theme( bslib::bs_theme(
..., ...,
"navbar-bg" = primary,
version = version, version = version,
primary = primary, primary = primary,
secondary = secondary, secondary = secondary,
@ -3322,6 +3483,15 @@ update_variables_datagrid <- function(data, height = NULL, selectionId = NULL, b
fontStyle = "italic" fontStyle = "italic"
) )
grid <- toastui::grid_filters(
grid = grid,
column = "name",
# columns = unname(std_names[std_names!="vals"]),
showApplyBtn = FALSE,
showClearBtn = TRUE,
type = "text"
)
# grid <- toastui::grid_columns( # grid <- toastui::grid_columns(
# grid = grid, # grid = grid,
# columns = "name_toset", # columns = "name_toset",
@ -3432,6 +3602,7 @@ convert_to <- function(data,
new_class <- match.arg(new_class, several.ok = TRUE) new_class <- match.arg(new_class, several.ok = TRUE)
stopifnot(length(new_class) == length(variable)) stopifnot(length(new_class) == length(variable))
args <- list(...) args <- list(...)
args$format <- clean_sep(args$format)
if (length(variable) > 1) { if (length(variable) > 1) {
for (i in seq_along(variable)) { for (i in seq_along(variable)) {
data <- convert_to(data, variable[i], new_class[i], ...) data <- convert_to(data, variable[i], new_class[i], ...)
@ -3463,10 +3634,10 @@ convert_to <- function(data,
setNames(list(expr(as.integer(!!sym(variable)))), variable) setNames(list(expr(as.integer(!!sym(variable)))), variable)
) )
} else if (identical(new_class, "date")) { } else if (identical(new_class, "date")) {
data[[variable]] <- as.Date(x = data[[variable]], ...) data[[variable]] <- as.Date(x = clean_date(data[[variable]]), ...)
attr(data, "code_03_convert") <- c( attr(data, "code_03_convert") <- c(
attr(data, "code_03_convert"), attr(data, "code_03_convert"),
setNames(list(expr(as.Date(!!sym(variable), origin = !!args$origin))), variable) setNames(list(expr(as.Date(clean_date(!!sym(variable)), origin = !!args$origin, format=clean_sep(!!args$format)))), variable)
) )
} else if (identical(new_class, "datetime")) { } else if (identical(new_class, "datetime")) {
data[[variable]] <- as.POSIXct(x = data[[variable]], ...) data[[variable]] <- as.POSIXct(x = data[[variable]], ...)
@ -3571,6 +3742,42 @@ get_vars_to_convert <- function(vars, classes_input) {
} }
#' gsub wrapper for piping with default values for separator substituting
#'
#' @param data character vector
#' @param old.sep old separator
#' @param new.sep new separator
#'
#' @returns character vector
#' @export
#'
clean_sep <- function(data,old.sep="[-.,/]",new.sep="-"){
gsub(old.sep,new.sep,data)
}
#' Attempts at applying uniform date format
#'
#' @param data character string vector of possible dates
#'
#' @returns character string
#' @export
#'
clean_date <- function(data){
data |>
clean_sep() |>
sapply(\(.x){
if (is.na(.x)){
.x
} else {
strsplit(.x,"-") |>
unlist()|>
lapply(\(.y){
if (nchar(.y)==1) paste0("0",.y) else .y
}) |> paste(collapse="-")
}
}) |>
unname()
}
######## ########
@ -3597,16 +3804,8 @@ ui_elements <- list(
############################################################################## ##############################################################################
"import" = bslib::nav_panel( "import" = bslib::nav_panel(
title = "Import", title = "Import",
shiny::tagList(
shiny::h4("Choose your data source"), shiny::h4("Choose your data source"),
# shiny::conditionalPanel( shiny::br(),
# 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 ----
shinyWidgets::radioGroupButtons( shinyWidgets::radioGroupButtons(
inputId = "source", inputId = "source",
selected = "env", selected = "env",
@ -3622,6 +3821,7 @@ ui_elements <- list(
# ), # ),
width = "100%" width = "100%"
), ),
shiny::helpText("Upload a file from your device, get data directly from REDCap or select a sample data set for testing from the app."),
shiny::conditionalPanel( shiny::conditionalPanel(
condition = "input.source=='file'", condition = "input.source=='file'",
datamods::import_file_ui("file_import", datamods::import_file_ui("file_import",
@ -3642,6 +3842,22 @@ ui_elements <- list(
DT::DTOutput(outputId = "redcap_prev") DT::DTOutput(outputId = "redcap_prev")
), ),
shiny::br(), shiny::br(),
shiny::br(),
shiny::h5("Exclude in-complete variables"),
shiny::p("Before going further, you can exclude variables with a low degree of completeness."),
shiny::br(),
shiny::sliderInput(
inputId = "complete_cutoff",
label = "Choose completeness threshold (%)",
min = 0,
max = 100,
step = 10,
value = 70,
ticks = FALSE
),
shiny::helpText("Only include variables with completeness above a specified percentage."),
shiny::br(),
shiny::br(),
shiny::actionButton( shiny::actionButton(
inputId = "act_start", inputId = "act_start",
label = "Start", label = "Start",
@ -3651,7 +3867,6 @@ ui_elements <- list(
shiny::helpText('After importing, hit "Start" or navigate to the desired tab.'), shiny::helpText('After importing, hit "Start" or navigate to the desired tab.'),
shiny::br(), shiny::br(),
shiny::br() shiny::br()
)
), ),
############################################################################## ##############################################################################
######### #########
@ -3731,7 +3946,7 @@ ui_elements <- list(
fluidRow( fluidRow(
shiny::column( shiny::column(
width = 9, width = 9,
shiny::tags$p("Below, you can subset the data (by not selecting the variables to exclude on applying changes), rename variables, set new labels (for nicer tables in the analysis report) and change variable classes. shiny::tags$p("Below, you can subset the data (select variables to include on clicking 'Apply changes'), rename variables, set new labels (for nicer tables in the report) and change variable classes (numeric, factor/categorical etc.).
Italic text can be edited/changed. Italic text can be edited/changed.
On the right, you can create and modify factor/categorical variables as well as resetting the data to the originally imported data.") On the right, you can create and modify factor/categorical variables as well as resetting the data to the originally imported data.")
) )
@ -3851,15 +4066,13 @@ ui_elements <- list(
), ),
############################################################################## ##############################################################################
######### #########
######### Data analyses panel ######### Descriptive analyses panel
######### #########
############################################################################## ##############################################################################
"analyze" = "describe" =
# bslib::nav_panel_hidden(
bslib::nav_panel( bslib::nav_panel(
# value = "analyze", title = "Evaluate",
title = "Analyses", id = "navdescribe",
id = "navanalyses",
bslib::navset_bar( bslib::navset_bar(
title = "", title = "",
# bslib::layout_sidebar( # bslib::layout_sidebar(
@ -3889,6 +4102,47 @@ ui_elements <- list(
shiny::helpText("Option to perform statistical comparisons between strata in baseline table.") shiny::helpText("Option to perform statistical comparisons between strata in baseline table.")
) )
), ),
bslib::accordion_panel(
title = "Correlations",
shiny::sliderInput(
inputId = "cor_cutoff",
label = "Correlation cut-off",
min = 0,
max = 1,
step = .02,
value = .7,
ticks = FALSE
)
)
)
),
bslib::nav_panel(
title = "Baseline characteristics",
gt::gt_output(outputId = "table1")
),
bslib::nav_panel(
title = "Variable correlations",
data_correlations_ui(id = "correlations", height = 600)
)
)
),
##############################################################################
#########
######### Regression analyses panel
#########
##############################################################################
"analyze" =
bslib::nav_panel(
title = "Regression",
id = "navanalyses",
bslib::navset_bar(
title = "",
# bslib::layout_sidebar(
# fillable = TRUE,
sidebar = bslib::sidebar(
bslib::accordion(
open = "acc_reg",
multiple = FALSE,
bslib::accordion_panel( bslib::accordion_panel(
value = "acc_reg", value = "acc_reg",
title = "Regression", title = "Regression",
@ -3927,23 +4181,14 @@ ui_elements <- list(
type = "secondary", type = "secondary",
auto_reset = TRUE auto_reset = TRUE
), ),
shiny::helpText("If you change the parameters, press 'Analyse' again to update the regression analysis"), shiny::helpText("Press 'Analyse' again after changing parameters."),
shiny::tags$br(),
shiny::uiOutput("plot_model") shiny::uiOutput("plot_model")
), ),
bslib::accordion_panel( bslib::accordion_panel(
value = "acc_advanced", value = "acc_advanced",
title = "Advanced", title = "Advanced",
icon = bsicons::bs_icon("gear"), icon = bsicons::bs_icon("gear"),
shiny::sliderInput(
inputId = "complete_cutoff",
label = "Cut-off for column completeness (%)",
min = 0,
max = 100,
step = 10,
value = 70,
ticks = FALSE
),
shiny::helpText("To improve speed, columns are removed before analysing data, if copleteness is below above value."),
shiny::radioButtons( shiny::radioButtons(
inputId = "all", inputId = "all",
label = "Specify covariables", label = "Specify covariables",
@ -3958,52 +4203,6 @@ ui_elements <- list(
condition = "input.all==1", condition = "input.all==1",
shiny::uiOutput("include_vars") shiny::uiOutput("include_vars")
) )
),
bslib::accordion_panel(
value = "acc_down",
title = "Download",
icon = bsicons::bs_icon("download"),
shiny::h4("Report"),
shiny::helpText("Choose your favourite output file format for further work, and download, when the analyses are done."),
shiny::selectInput(
inputId = "output_type",
label = "Output format",
selected = NULL,
choices = list(
"MS Word" = "docx",
"LibreOffice" = "odt"
# ,
# "PDF" = "pdf",
# "All the above" = "all"
)
),
shiny::br(),
# Button
shiny::downloadButton(
outputId = "report",
label = "Download report",
icon = shiny::icon("download")
),
# shiny::helpText("If choosing to output to MS Word, please note, that when opening the document, two errors will pop-up. Choose to repair and choose not to update references. The issue is being worked on. You can always choose LibreOffice instead."),
shiny::tags$hr(),
shiny::h4("Data"),
shiny::helpText("Choose your favourite output data format to download the modified data."),
shiny::selectInput(
inputId = "data_type",
label = "Data format",
selected = NULL,
choices = list(
"R" = "rds",
"stata" = "dta"
)
),
shiny::br(),
# Button
shiny::downloadButton(
outputId = "data_modified",
label = "Download data",
icon = shiny::icon("download")
)
) )
), ),
# shiny::helpText(em("Please specify relevant settings for your data, and press 'Analyse'")), # shiny::helpText(em("Please specify relevant settings for your data, and press 'Analyse'")),
@ -4025,10 +4224,6 @@ ui_elements <- list(
# condition = "output.ready=='yes'", # condition = "output.ready=='yes'",
# shiny::tags$hr(), # shiny::tags$hr(),
), ),
bslib::nav_panel(
title = "Baseline characteristics",
gt::gt_output(outputId = "table1")
),
bslib::nav_panel( bslib::nav_panel(
title = "Regression table", title = "Regression table",
gt::gt_output(outputId = "table2") gt::gt_output(outputId = "table2")
@ -4046,6 +4241,66 @@ ui_elements <- list(
), ),
############################################################################## ##############################################################################
######### #########
######### Download panel
#########
##############################################################################
"download" =
bslib::nav_panel(
title = "Download",
id = "navdownload",
shiny::fluidRow(
shiny::column(
width = 6,
shiny::h4("Report"),
shiny::helpText("Choose your favourite output file format for further work, and download, when the analyses are done."),
shiny::selectInput(
inputId = "output_type",
label = "Output format",
selected = NULL,
choices = list(
"MS Word" = "docx",
"LibreOffice" = "odt"
# ,
# "PDF" = "pdf",
# "All the above" = "all"
)
),
shiny::br(),
# Button
shiny::downloadButton(
outputId = "report",
label = "Download report",
icon = shiny::icon("download")
)
# shiny::helpText("If choosing to output to MS Word, please note, that when opening the document, two errors will pop-up. Choose to repair and choose not to update references. The issue is being worked on. You can always choose LibreOffice instead."),
),
shiny::column(
width = 6,
shiny::h4("Data"),
shiny::helpText("Choose your favourite output data format to download the modified data."),
shiny::selectInput(
inputId = "data_type",
label = "Data format",
selected = NULL,
choices = list(
"R" = "rds",
"stata" = "dta",
"CSV" = "csv"
)
),
shiny::br(),
# Button
shiny::downloadButton(
outputId = "data_modified",
label = "Download data",
icon = shiny::icon("download")
)
)
),
shiny::br()
),
##############################################################################
#########
######### Documentation panel ######### Documentation panel
######### #########
############################################################################## ##############################################################################
@ -4065,7 +4320,6 @@ ui_elements <- list(
# shiny::br() # shiny::br()
# ) # )
) )
# Initial attempt at creating light and dark versions # Initial attempt at creating light and dark versions
light <- custom_theme() light <- custom_theme()
dark <- custom_theme( dark <- custom_theme(
@ -4090,17 +4344,15 @@ ui <- bslib::page_fixed(
theme = light, theme = light,
shiny::useBusyIndicators(), shiny::useBusyIndicators(),
bslib::page_navbar( bslib::page_navbar(
# title = "freesearcheR",
id = "main_panel", id = "main_panel",
# header = shiny::tags$header(shiny::p("Data is only stored temporarily for analysis and deleted immediately afterwards.")),
ui_elements$home, ui_elements$home,
ui_elements$import, ui_elements$import,
ui_elements$overview, ui_elements$overview,
ui_elements$describe,
ui_elements$analyze, ui_elements$analyze,
ui_elements$download,
bslib::nav_spacer(), bslib::nav_spacer(),
ui_elements$docs, ui_elements$docs,
# bslib::nav_spacer(),
# bslib::nav_item(shinyWidgets::circleButton(inputId = "mode", icon = icon("moon"),status = "primary")),
fillable = FALSE, fillable = FALSE,
footer = shiny::tags$footer( footer = shiny::tags$footer(
style = "background-color: #14131326; padding: 4px; text-align: center; bottom: 0; width: 100%;", style = "background-color: #14131326; padding: 4px; text-align: center; bottom: 0; width: 100%;",
@ -4213,7 +4465,7 @@ server <- function(input, output, session) {
######### #########
############################################################################## ##############################################################################
consider.na <- c("NA", "\"\"", "") consider.na <- c("NA", "\"\"", "", "\'\'", "na")
data_file <- datamods::import_file_server( data_file <- datamods::import_file_server(
id = "file_import", id = "file_import",
@ -4228,7 +4480,8 @@ server <- function(input, output, session) {
haven::read_dta(file = file, .name_repair = "unique_quiet") haven::read_dta(file = file, .name_repair = "unique_quiet")
}, },
csv = function(file) { csv = function(file) {
readr::read_csv(file = file, na = consider.na) readr::read_csv(file = file, na = consider.na, name_repair = "unique_quiet") #|>
# janitor::remove_empty(which = "cols", cutoff = 1, quiet = TRUE)
}, },
# xls = function(file){ # xls = function(file){
# openxlsx2::read_xlsx(file = file, na.strings = consider.na,) # openxlsx2::read_xlsx(file = file, na.strings = consider.na,)
@ -4237,7 +4490,7 @@ server <- function(input, output, session) {
# openxlsx2::read_xlsx(file = file, na.strings = consider.na,) # openxlsx2::read_xlsx(file = file, na.strings = consider.na,)
# }, # },
rds = function(file) { rds = function(file) {
readr::read_rds(file = file) readr::read_rds(file = file, name_repair = "unique_quiet")
} }
) )
) )
@ -4284,11 +4537,22 @@ server <- function(input, output, session) {
######### #########
############################################################################## ##############################################################################
shiny::observeEvent(rv$data_original, { shiny::observeEvent(
eventExpr = list(
rv$data_original,
input$reset_confirm,
input$complete_cutoff
),
handlerExpr = {
shiny::req(rv$data_original)
rv$data <- rv$data_original |> rv$data <- rv$data_original |>
# janitor::clean_names() |>
default_parsing() |> default_parsing() |>
janitor::clean_names() remove_empty_cols(
}) cutoff = input$complete_cutoff / 100
)
}
)
shiny::observeEvent(input$data_reset, { shiny::observeEvent(input$data_reset, {
shinyWidgets::ask_confirmation( shinyWidgets::ask_confirmation(
@ -4297,9 +4561,9 @@ server <- function(input, output, session) {
) )
}) })
shiny::observeEvent(input$reset_confirm, { # shiny::observeEvent(input$reset_confirm, {
rv$data <- rv$data_original |> default_parsing() # rv$data <- rv$data_original |> default_parsing()
}) # })
######### Overview ######### Overview
@ -4366,7 +4630,8 @@ server <- function(input, output, session) {
) )
######### Show result ######### Show result
tryCatch(
{
output$table_mod <- toastui::renderDatagrid({ output$table_mod <- toastui::renderDatagrid({
shiny::req(rv$data) shiny::req(rv$data)
# data <- rv$data # data <- rv$data
@ -4379,6 +4644,13 @@ server <- function(input, output, session) {
# striped = TRUE # striped = TRUE
) )
}) })
},
warning = function(warn) {
showNotification(paste0(warn), type = "warning")
},
error = function(err) {
showNotification(paste0(err), type = "err")
})
output$code <- renderPrint({ output$code <- renderPrint({
attr(rv$data, "code") attr(rv$data, "code")
@ -4422,14 +4694,14 @@ server <- function(input, output, session) {
rv$data_filtered <- data_filter() rv$data_filtered <- data_filter()
rv$list$data <- data_filter() |> rv$list$data <- data_filter() |>
REDCapCAST::fct_drop.data.frame() |> REDCapCAST::fct_drop() |>
(\(.x){ (\(.x){
.x[base_vars()] .x[base_vars()]
})() |> })() #|>
janitor::remove_empty( # janitor::remove_empty(
which = "cols", # which = "cols",
cutoff = input$complete_cutoff / 100 # cutoff = input$complete_cutoff / 100
) # )
} }
) )
@ -4488,13 +4760,17 @@ server <- function(input, output, session) {
shiny::req(input$outcome_var) shiny::req(input$outcome_var)
shiny::selectizeInput( shiny::selectizeInput(
inputId = "regression_type", inputId = "regression_type",
# selected = colnames(rv$data_filtered)[sapply(rv$data_filtered, is.factor)],
label = "Choose regression analysis", label = "Choose regression analysis",
choices = possible_functions(data = dplyr::select(rv$data_filtered, ## The below ifelse statement handles the case of loading a new dataset
choices = possible_functions(
data = dplyr::select(
rv$data_filtered,
ifelse(input$outcome_var %in% names(rv$data_filtered), ifelse(input$outcome_var %in% names(rv$data_filtered),
input$outcome_var, input$outcome_var,
names(rv$data_filtered)[1]) names(rv$data_filtered)[1]
), design = "cross-sectional"), )
), design = "cross-sectional"
),
multiple = FALSE multiple = FALSE
) )
}) })
@ -4553,90 +4829,9 @@ server <- function(input, output, session) {
}) })
## 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
# output$data_table <-
# DT::renderDT(
# {
# DT::datatable(ds()[base_vars()])
# },
# server = FALSE
# )
#
# output$data.classes <- gt::render_gt({
# shiny::req(input$file)
# data.frame(matrix(sapply(ds(), \(.x){
# class(.x)[1]
# }), nrow = 1)) |>
# stats::setNames(names(ds())) |>
# gt::gt()
# })
### Outputs
# shiny::observeEvent(data_filter(), {
# rv$data_filtered <- data_filter()
# })
# shiny::observeEvent(
# shiny::reactive(rv$data_filtered),
# {
# rv$list$data <- rv$data_filtered |>
# # dplyr::mutate(dplyr::across(dplyr::where(is.character), as.factor)) |>
# REDCapCAST::fct_drop.data.frame() |>
# # factorize(vars = input$factor_vars) |>
# remove_na_attr()
#
# # rv$list$data <- data
# # rv$list$data <- data[base_vars()]
# }
# )
# shiny::observe({
# if (input$strat_var == "none") {
# by.var <- NULL
# } else {
# by.var <- input$strat_var
# }
#
# rv$list$table1 <- rv$list$data |>
# baseline_table(
# fun.args =
# list(
# by = by.var
# )
# ) |>
# (\(.x){
# if (!is.null(by.var)) {
# .x |> gtsummary::add_overall()
# } else {
# .x
# }
# })() |>
# (\(.x){
# if (input$add_p == "yes") {
# .x |>
# gtsummary::add_p() |>
# gtsummary::bold_p()
# } else {
# .x
# }
# })()
# })
#
# output$table1 <- gt::render_gt(
# rv$list$table1 |>
# gtsummary::as_gt() |>
# gt::tab_header(shiny::md("**Table 1. Patient Characteristics**"))
# )
############################################################################## ##############################################################################
######### #########
######### Data analyses results ######### Descriptive evaluations
######### #########
############################################################################## ##############################################################################
@ -4701,6 +4896,18 @@ server <- function(input, output, session) {
gt::tab_header(gt::md("**Table 1: Baseline Characteristics**")) gt::tab_header(gt::md("**Table 1: Baseline Characteristics**"))
}) })
data_correlations_server(id = "correlations",
data = shiny::reactive(rv$list$data),
cutoff = shiny::reactive(input$cor_cutoff))
##############################################################################
#########
######### Regression model analyses
#########
##############################################################################
shiny::observeEvent( shiny::observeEvent(
input$load, input$load,
{ {
@ -4779,37 +4986,6 @@ server <- function(input, output, session) {
} }
) )
# plot_check_r <- shiny::reactive({plot(rv$check)})
#
# output$check_1 <- shiny::renderUI({
# shiny::req(rv$check)
# list <- lapply(seq_len(length(plot_check_r())),
# function(i) {
# plotname <- paste0("check_plot_", i)
# shiny::htmlOutput(plotname)
# })
#
# do.call(shiny::tagList,list)
# })
#
# # Call renderPlot for each one. Plots are only actually generated when they
# # are visible on the web page.
#
# shiny::observe({
# shiny::req(rv$check)
# # browser()
# for (i in seq_len(length(plot_check_r()))) {
# local({
# my_i <- i
# plotname <- paste0("check_plot_", my_i)
#
# output[[plotname]] <- shiny::renderPlot({
# plot_check_r()[[my_i]] + gg_theme_shiny()
# })
# })
# }
# })
output$check <- shiny::renderPlot( output$check <- shiny::renderPlot(
{ {
shiny::req(rv$check) shiny::req(rv$check)
@ -4932,7 +5108,7 @@ server <- function(input, output, session) {
) )
out + out +
ggplot2::scale_y_discrete(labels = scales::label_wrap(15))+ ggplot2::scale_y_discrete(labels = scales::label_wrap(15)) +
gg_theme_shiny() gg_theme_shiny()
# rv$list$regression$tables$Multivariable |> # rv$list$regression$tables$Multivariable |>
@ -5044,8 +5220,10 @@ server <- function(input, output, session) {
content = function(file, type = input$data_type) { content = function(file, type = input$data_type) {
if (type == "rds") { if (type == "rds") {
readr::write_rds(rv$list$data, file = file) readr::write_rds(rv$list$data, file = file)
} else { } else if (type == "dta") {
haven::write_dta(as.data.frame(rv$list$data), path = file) haven::write_dta(as.data.frame(rv$list$data), path = file)
} else if (type == "csv"){
readr::write_csv(rv$list$data, file = file)
} }
} }
) )

2
inst/apps/data_analysis_modules/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf
View file

@ -5,6 +5,6 @@ account: agdamsbo
server: shinyapps.io server: shinyapps.io
hostUrl: https://api.shinyapps.io/v1 hostUrl: https://api.shinyapps.io/v1
appId: 13611288 appId: 13611288
bundleId: 9693816 bundleId:
url: https://agdamsbo.shinyapps.io/freesearcheR/ url: https://agdamsbo.shinyapps.io/freesearcheR/
version: 1 version: 1

182
inst/apps/data_analysis_modules/server.R
View file

@ -90,7 +90,7 @@ server <- function(input, output, session) {
######### #########
############################################################################## ##############################################################################
consider.na <- c("NA", "\"\"", "") consider.na <- c("NA", "\"\"", "", "\'\'", "na")
data_file <- datamods::import_file_server( data_file <- datamods::import_file_server(
id = "file_import", id = "file_import",
@ -105,7 +105,8 @@ server <- function(input, output, session) {
haven::read_dta(file = file, .name_repair = "unique_quiet") haven::read_dta(file = file, .name_repair = "unique_quiet")
}, },
csv = function(file) { csv = function(file) {
readr::read_csv(file = file, na = consider.na) readr::read_csv(file = file, na = consider.na, name_repair = "unique_quiet") #|>
# janitor::remove_empty(which = "cols", cutoff = 1, quiet = TRUE)
}, },
# xls = function(file){ # xls = function(file){
# openxlsx2::read_xlsx(file = file, na.strings = consider.na,) # openxlsx2::read_xlsx(file = file, na.strings = consider.na,)
@ -114,7 +115,7 @@ server <- function(input, output, session) {
# openxlsx2::read_xlsx(file = file, na.strings = consider.na,) # openxlsx2::read_xlsx(file = file, na.strings = consider.na,)
# }, # },
rds = function(file) { rds = function(file) {
readr::read_rds(file = file) readr::read_rds(file = file, name_repair = "unique_quiet")
} }
) )
) )
@ -161,11 +162,22 @@ server <- function(input, output, session) {
######### #########
############################################################################## ##############################################################################
shiny::observeEvent(rv$data_original, { shiny::observeEvent(
eventExpr = list(
rv$data_original,
input$reset_confirm,
input$complete_cutoff
),
handlerExpr = {
shiny::req(rv$data_original)
rv$data <- rv$data_original |> rv$data <- rv$data_original |>
# janitor::clean_names() |>
default_parsing() |> default_parsing() |>
janitor::clean_names() remove_empty_cols(
}) cutoff = input$complete_cutoff / 100
)
}
)
shiny::observeEvent(input$data_reset, { shiny::observeEvent(input$data_reset, {
shinyWidgets::ask_confirmation( shinyWidgets::ask_confirmation(
@ -174,9 +186,9 @@ server <- function(input, output, session) {
) )
}) })
shiny::observeEvent(input$reset_confirm, { # shiny::observeEvent(input$reset_confirm, {
rv$data <- rv$data_original |> default_parsing() # rv$data <- rv$data_original |> default_parsing()
}) # })
######### Overview ######### Overview
@ -243,7 +255,8 @@ server <- function(input, output, session) {
) )
######### Show result ######### Show result
tryCatch(
{
output$table_mod <- toastui::renderDatagrid({ output$table_mod <- toastui::renderDatagrid({
shiny::req(rv$data) shiny::req(rv$data)
# data <- rv$data # data <- rv$data
@ -256,6 +269,13 @@ server <- function(input, output, session) {
# striped = TRUE # striped = TRUE
) )
}) })
},
warning = function(warn) {
showNotification(paste0(warn), type = "warning")
},
error = function(err) {
showNotification(paste0(err), type = "err")
})
output$code <- renderPrint({ output$code <- renderPrint({
attr(rv$data, "code") attr(rv$data, "code")
@ -299,14 +319,14 @@ server <- function(input, output, session) {
rv$data_filtered <- data_filter() rv$data_filtered <- data_filter()
rv$list$data <- data_filter() |> rv$list$data <- data_filter() |>
REDCapCAST::fct_drop.data.frame() |> REDCapCAST::fct_drop() |>
(\(.x){ (\(.x){
.x[base_vars()] .x[base_vars()]
})() |> })() #|>
janitor::remove_empty( # janitor::remove_empty(
which = "cols", # which = "cols",
cutoff = input$complete_cutoff / 100 # cutoff = input$complete_cutoff / 100
) # )
} }
) )
@ -434,90 +454,9 @@ server <- function(input, output, session) {
}) })
## 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
# output$data_table <-
# DT::renderDT(
# {
# DT::datatable(ds()[base_vars()])
# },
# server = FALSE
# )
#
# output$data.classes <- gt::render_gt({
# shiny::req(input$file)
# data.frame(matrix(sapply(ds(), \(.x){
# class(.x)[1]
# }), nrow = 1)) |>
# stats::setNames(names(ds())) |>
# gt::gt()
# })
### Outputs
# shiny::observeEvent(data_filter(), {
# rv$data_filtered <- data_filter()
# })
# shiny::observeEvent(
# shiny::reactive(rv$data_filtered),
# {
# rv$list$data <- rv$data_filtered |>
# # dplyr::mutate(dplyr::across(dplyr::where(is.character), as.factor)) |>
# REDCapCAST::fct_drop.data.frame() |>
# # factorize(vars = input$factor_vars) |>
# remove_na_attr()
#
# # rv$list$data <- data
# # rv$list$data <- data[base_vars()]
# }
# )
# shiny::observe({
# if (input$strat_var == "none") {
# by.var <- NULL
# } else {
# by.var <- input$strat_var
# }
#
# rv$list$table1 <- rv$list$data |>
# baseline_table(
# fun.args =
# list(
# by = by.var
# )
# ) |>
# (\(.x){
# if (!is.null(by.var)) {
# .x |> gtsummary::add_overall()
# } else {
# .x
# }
# })() |>
# (\(.x){
# if (input$add_p == "yes") {
# .x |>
# gtsummary::add_p() |>
# gtsummary::bold_p()
# } else {
# .x
# }
# })()
# })
#
# output$table1 <- gt::render_gt(
# rv$list$table1 |>
# gtsummary::as_gt() |>
# gt::tab_header(shiny::md("**Table 1. Patient Characteristics**"))
# )
############################################################################## ##############################################################################
######### #########
######### Data analyses results ######### Descriptive evaluations
######### #########
############################################################################## ##############################################################################
@ -582,6 +521,18 @@ server <- function(input, output, session) {
gt::tab_header(gt::md("**Table 1: Baseline Characteristics**")) gt::tab_header(gt::md("**Table 1: Baseline Characteristics**"))
}) })
data_correlations_server(id = "correlations",
data = shiny::reactive(rv$list$data),
cutoff = shiny::reactive(input$cor_cutoff))
##############################################################################
#########
######### Regression model analyses
#########
##############################################################################
shiny::observeEvent( shiny::observeEvent(
input$load, input$load,
{ {
@ -660,37 +611,6 @@ server <- function(input, output, session) {
} }
) )
# plot_check_r <- shiny::reactive({plot(rv$check)})
#
# output$check_1 <- shiny::renderUI({
# shiny::req(rv$check)
# list <- lapply(seq_len(length(plot_check_r())),
# function(i) {
# plotname <- paste0("check_plot_", i)
# shiny::htmlOutput(plotname)
# })
#
# do.call(shiny::tagList,list)
# })
#
# # Call renderPlot for each one. Plots are only actually generated when they
# # are visible on the web page.
#
# shiny::observe({
# shiny::req(rv$check)
# # browser()
# for (i in seq_len(length(plot_check_r()))) {
# local({
# my_i <- i
# plotname <- paste0("check_plot_", my_i)
#
# output[[plotname]] <- shiny::renderPlot({
# plot_check_r()[[my_i]] + gg_theme_shiny()
# })
# })
# }
# })
output$check <- shiny::renderPlot( output$check <- shiny::renderPlot(
{ {
shiny::req(rv$check) shiny::req(rv$check)
@ -925,8 +845,10 @@ server <- function(input, output, session) {
content = function(file, type = input$data_type) { content = function(file, type = input$data_type) {
if (type == "rds") { if (type == "rds") {
readr::write_rds(rv$list$data, file = file) readr::write_rds(rv$list$data, file = file)
} else { } else if (type == "dta") {
haven::write_dta(as.data.frame(rv$list$data), path = file) haven::write_dta(as.data.frame(rv$list$data), path = file)
} else if (type == "csv"){
readr::write_csv(rv$list$data, file = file)
} }
} }
) )

211
inst/apps/data_analysis_modules/ui.R
View file

@ -18,16 +18,8 @@ ui_elements <- list(
############################################################################## ##############################################################################
"import" = bslib::nav_panel( "import" = bslib::nav_panel(
title = "Import", title = "Import",
shiny::tagList(
shiny::h4("Choose your data source"), shiny::h4("Choose your data source"),
# shiny::conditionalPanel( shiny::br(),
# 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 ----
shinyWidgets::radioGroupButtons( shinyWidgets::radioGroupButtons(
inputId = "source", inputId = "source",
selected = "env", selected = "env",
@ -43,6 +35,7 @@ ui_elements <- list(
# ), # ),
width = "100%" width = "100%"
), ),
shiny::helpText("Upload a file from your device, get data directly from REDCap or select a sample data set for testing from the app."),
shiny::conditionalPanel( shiny::conditionalPanel(
condition = "input.source=='file'", condition = "input.source=='file'",
datamods::import_file_ui("file_import", datamods::import_file_ui("file_import",
@ -63,6 +56,22 @@ ui_elements <- list(
DT::DTOutput(outputId = "redcap_prev") DT::DTOutput(outputId = "redcap_prev")
), ),
shiny::br(), shiny::br(),
shiny::br(),
shiny::h5("Exclude in-complete variables"),
shiny::p("Before going further, you can exclude variables with a low degree of completeness."),
shiny::br(),
shiny::sliderInput(
inputId = "complete_cutoff",
label = "Choose completeness threshold (%)",
min = 0,
max = 100,
step = 10,
value = 70,
ticks = FALSE
),
shiny::helpText("Only include variables with completeness above a specified percentage."),
shiny::br(),
shiny::br(),
shiny::actionButton( shiny::actionButton(
inputId = "act_start", inputId = "act_start",
label = "Start", label = "Start",
@ -72,7 +81,6 @@ ui_elements <- list(
shiny::helpText('After importing, hit "Start" or navigate to the desired tab.'), shiny::helpText('After importing, hit "Start" or navigate to the desired tab.'),
shiny::br(), shiny::br(),
shiny::br() shiny::br()
)
), ),
############################################################################## ##############################################################################
######### #########
@ -152,7 +160,7 @@ ui_elements <- list(
fluidRow( fluidRow(
shiny::column( shiny::column(
width = 9, width = 9,
shiny::tags$p("Below, you can subset the data (by not selecting the variables to exclude on applying changes), rename variables, set new labels (for nicer tables in the analysis report) and change variable classes. shiny::tags$p("Below, you can subset the data (select variables to include on clicking 'Apply changes'), rename variables, set new labels (for nicer tables in the report) and change variable classes (numeric, factor/categorical etc.).
Italic text can be edited/changed. Italic text can be edited/changed.
On the right, you can create and modify factor/categorical variables as well as resetting the data to the originally imported data.") On the right, you can create and modify factor/categorical variables as well as resetting the data to the originally imported data.")
) )
@ -272,15 +280,13 @@ ui_elements <- list(
), ),
############################################################################## ##############################################################################
######### #########
######### Data analyses panel ######### Descriptive analyses panel
######### #########
############################################################################## ##############################################################################
"analyze" = "describe" =
# bslib::nav_panel_hidden(
bslib::nav_panel( bslib::nav_panel(
# value = "analyze", title = "Evaluate",
title = "Analyses", id = "navdescribe",
id = "navanalyses",
bslib::navset_bar( bslib::navset_bar(
title = "", title = "",
# bslib::layout_sidebar( # bslib::layout_sidebar(
@ -310,6 +316,47 @@ ui_elements <- list(
shiny::helpText("Option to perform statistical comparisons between strata in baseline table.") shiny::helpText("Option to perform statistical comparisons between strata in baseline table.")
) )
), ),
bslib::accordion_panel(
title = "Correlations",
shiny::sliderInput(
inputId = "cor_cutoff",
label = "Correlation cut-off",
min = 0,
max = 1,
step = .02,
value = .7,
ticks = FALSE
)
)
)
),
bslib::nav_panel(
title = "Baseline characteristics",
gt::gt_output(outputId = "table1")
),
bslib::nav_panel(
title = "Variable correlations",
data_correlations_ui(id = "correlations", height = 600)
)
)
),
##############################################################################
#########
######### Regression analyses panel
#########
##############################################################################
"analyze" =
bslib::nav_panel(
title = "Regression",
id = "navanalyses",
bslib::navset_bar(
title = "",
# bslib::layout_sidebar(
# fillable = TRUE,
sidebar = bslib::sidebar(
bslib::accordion(
open = "acc_reg",
multiple = FALSE,
bslib::accordion_panel( bslib::accordion_panel(
value = "acc_reg", value = "acc_reg",
title = "Regression", title = "Regression",
@ -348,23 +395,14 @@ ui_elements <- list(
type = "secondary", type = "secondary",
auto_reset = TRUE auto_reset = TRUE
), ),
shiny::helpText("If you change the parameters, press 'Analyse' again to update the regression analysis"), shiny::helpText("Press 'Analyse' again after changing parameters."),
shiny::tags$br(),
shiny::uiOutput("plot_model") shiny::uiOutput("plot_model")
), ),
bslib::accordion_panel( bslib::accordion_panel(
value = "acc_advanced", value = "acc_advanced",
title = "Advanced", title = "Advanced",
icon = bsicons::bs_icon("gear"), icon = bsicons::bs_icon("gear"),
shiny::sliderInput(
inputId = "complete_cutoff",
label = "Cut-off for column completeness (%)",
min = 0,
max = 100,
step = 10,
value = 70,
ticks = FALSE
),
shiny::helpText("To improve speed, columns are removed before analysing data, if copleteness is below above value."),
shiny::radioButtons( shiny::radioButtons(
inputId = "all", inputId = "all",
label = "Specify covariables", label = "Specify covariables",
@ -379,52 +417,6 @@ ui_elements <- list(
condition = "input.all==1", condition = "input.all==1",
shiny::uiOutput("include_vars") shiny::uiOutput("include_vars")
) )
),
bslib::accordion_panel(
value = "acc_down",
title = "Download",
icon = bsicons::bs_icon("download"),
shiny::h4("Report"),
shiny::helpText("Choose your favourite output file format for further work, and download, when the analyses are done."),
shiny::selectInput(
inputId = "output_type",
label = "Output format",
selected = NULL,
choices = list(
"MS Word" = "docx",
"LibreOffice" = "odt"
# ,
# "PDF" = "pdf",
# "All the above" = "all"
)
),
shiny::br(),
# Button
shiny::downloadButton(
outputId = "report",
label = "Download report",
icon = shiny::icon("download")
),
# shiny::helpText("If choosing to output to MS Word, please note, that when opening the document, two errors will pop-up. Choose to repair and choose not to update references. The issue is being worked on. You can always choose LibreOffice instead."),
shiny::tags$hr(),
shiny::h4("Data"),
shiny::helpText("Choose your favourite output data format to download the modified data."),
shiny::selectInput(
inputId = "data_type",
label = "Data format",
selected = NULL,
choices = list(
"R" = "rds",
"stata" = "dta"
)
),
shiny::br(),
# Button
shiny::downloadButton(
outputId = "data_modified",
label = "Download data",
icon = shiny::icon("download")
)
) )
), ),
# shiny::helpText(em("Please specify relevant settings for your data, and press 'Analyse'")), # shiny::helpText(em("Please specify relevant settings for your data, and press 'Analyse'")),
@ -446,10 +438,6 @@ ui_elements <- list(
# condition = "output.ready=='yes'", # condition = "output.ready=='yes'",
# shiny::tags$hr(), # shiny::tags$hr(),
), ),
bslib::nav_panel(
title = "Baseline characteristics",
gt::gt_output(outputId = "table1")
),
bslib::nav_panel( bslib::nav_panel(
title = "Regression table", title = "Regression table",
gt::gt_output(outputId = "table2") gt::gt_output(outputId = "table2")
@ -467,6 +455,66 @@ ui_elements <- list(
), ),
############################################################################## ##############################################################################
######### #########
######### Download panel
#########
##############################################################################
"download" =
bslib::nav_panel(
title = "Download",
id = "navdownload",
shiny::fluidRow(
shiny::column(
width = 6,
shiny::h4("Report"),
shiny::helpText("Choose your favourite output file format for further work, and download, when the analyses are done."),
shiny::selectInput(
inputId = "output_type",
label = "Output format",
selected = NULL,
choices = list(
"MS Word" = "docx",
"LibreOffice" = "odt"
# ,
# "PDF" = "pdf",
# "All the above" = "all"
)
),
shiny::br(),
# Button
shiny::downloadButton(
outputId = "report",
label = "Download report",
icon = shiny::icon("download")
)
# shiny::helpText("If choosing to output to MS Word, please note, that when opening the document, two errors will pop-up. Choose to repair and choose not to update references. The issue is being worked on. You can always choose LibreOffice instead."),
),
shiny::column(
width = 6,
shiny::h4("Data"),
shiny::helpText("Choose your favourite output data format to download the modified data."),
shiny::selectInput(
inputId = "data_type",
label = "Data format",
selected = NULL,
choices = list(
"R" = "rds",
"stata" = "dta",
"CSV" = "csv"
)
),
shiny::br(),
# Button
shiny::downloadButton(
outputId = "data_modified",
label = "Download data",
icon = shiny::icon("download")
)
)
),
shiny::br()
),
##############################################################################
#########
######### Documentation panel ######### Documentation panel
######### #########
############################################################################## ##############################################################################
@ -486,7 +534,6 @@ ui_elements <- list(
# shiny::br() # shiny::br()
# ) # )
) )
# Initial attempt at creating light and dark versions # Initial attempt at creating light and dark versions
light <- custom_theme() light <- custom_theme()
dark <- custom_theme( dark <- custom_theme(
@ -511,17 +558,15 @@ ui <- bslib::page_fixed(
theme = light, theme = light,
shiny::useBusyIndicators(), shiny::useBusyIndicators(),
bslib::page_navbar( bslib::page_navbar(
# title = "freesearcheR",
id = "main_panel", id = "main_panel",
# header = shiny::tags$header(shiny::p("Data is only stored temporarily for analysis and deleted immediately afterwards.")),
ui_elements$home, ui_elements$home,
ui_elements$import, ui_elements$import,
ui_elements$overview, ui_elements$overview,
ui_elements$describe,
ui_elements$analyze, ui_elements$analyze,
ui_elements$download,
bslib::nav_spacer(), bslib::nav_spacer(),
ui_elements$docs, ui_elements$docs,
# bslib::nav_spacer(),
# bslib::nav_item(shinyWidgets::circleButton(inputId = "mode", icon = icon("moon"),status = "primary")),
fillable = FALSE, fillable = FALSE,
footer = shiny::tags$footer( footer = shiny::tags$footer(
style = "background-color: #14131326; padding: 4px; text-align: center; bottom: 0; width: 100%;", style = "background-color: #14131326; padding: 4px; text-align: center; bottom: 0; width: 100%;",

16
inst/apps/data_analysis_modules/www/intro.html
View file

@ -354,22 +354,21 @@ display: none;
<div id="welcome" class="section level1"> <div id="welcome" class="section level1">
<h1>Welcome</h1> <h1>Welcome</h1>
<p>This is the <strong><em>freesearcheR</em></strong> web data analysis <p>This is the <strong><em>freesearcheR</em></strong> data analysis
tool. We intend the <strong><em>freesearcheR</em></strong> to be a tool. We intend the <strong><em>freesearcheR</em></strong> to be a
powerful and free tool for easy data evaluation and analysis at the powerful and free tool for easy data evaluation and analysis at the
hands of the clinician.</p> hands of the clinician.</p>
<p>By intention, this tool has been designed to be simple to use with a <p>By intention, this tool has been designed to be simple to use with a
minimum of mandatory options to keep the workflow streamlined, while minimum of mandatory options to keep the workflow streamlined, while
also including a few options to go even further.</p> also including a few options to go even further.</p>
<p>There are four simple steps to go through (see corresponding tabs in <p>There are some simple steps to go through (see corresponding tabs in
the top):</p> the top):</p>
<ol style="list-style-type: decimal"> <ol style="list-style-type: decimal">
<li><p>Import data (a spreadsheet/file on your machine, direct export <li><p>Import data (a spreadsheet/file on your machine, direct export
from a REDCap server, or a local file provided with a package) to get from a REDCap server, or a local file provided with a package) to get
started.</p></li> started.</p></li>
<li><p>An <em>optional</em> step of data modification (change variable <li><p>Inspec of data modification (change variable classes and creating
classes and creating categorical variables (factors) from numeric or categorical variables (factors) from numeric or time data)</p></li>
time data)</p></li>
<li><p>Data analysis of cross-sectionally designed studies (more study <li><p>Data analysis of cross-sectionally designed studies (more study
designs are planned to be included)</p> designs are planned to be included)</p>
<ul> <ul>
@ -382,10 +381,9 @@ depending on specified outcome variable</p></li>
<li><p>Export the the analyses results for MS Word or <a href="https://www.libreoffice.org/">LibreOffice</a> as well as the data <li><p>Export the the analyses results for MS Word or <a href="https://www.libreoffice.org/">LibreOffice</a> as well as the data
with preserved metadata.</p></li> with preserved metadata.</p></li>
</ol> </ol>
<p>Have a look at the <a href>documentations page</a> for further <p>Have a look at the <a href="https://agdamsbo.github.io/freesearcheR/">documentations page</a>
project description. If you’re interested in the source code, then go for further project description. If you’re interested in the source
on, <a href="https://github.com/agdamsbo/freesearcheR">have a code, then go on, <a href="https://github.com/agdamsbo/freesearcheR">have a look</a>!</p>
look</a>!</p>
<p>If you encounter anything strange or the app doesn’t act as expected. <p>If you encounter anything strange or the app doesn’t act as expected.
Please <a href="https://github.com/agdamsbo/freesearcheR/issues">report Please <a href="https://github.com/agdamsbo/freesearcheR/issues">report
on Github</a>.</p> on Github</a>.</p>

14
inst/apps/data_analysis_modules/www/intro.md
View file

@ -1,24 +1,26 @@
# Welcome # Welcome
This is the ***freesearcheR*** web data analysis tool. We intend the ***freesearcheR*** to be a powerful and free tool for easy data evaluation and analysis at the hands of the clinician. This is the ***freesearcheR*** data analysis tool. We intend the ***freesearcheR*** to be a powerful and free tool for easy data evaluation and analysis at the hands of the clinician.
By intention, this tool has been designed to be simple to use with a minimum of mandatory options to keep the workflow streamlined, while also including a few options to go even further. By intention, this tool has been designed to be simple to use with a minimum of mandatory options to keep the workflow streamlined, while also including a few options to go even further.
There are four simple steps to go through (see corresponding tabs in the top): There are some simple steps to go through (see corresponding tabs in the top):
1. Import data (a spreadsheet/file on your machine, direct export from a REDCap server, or a local file provided with a package) to get started. 1. Import data (a spreadsheet/file on your machine, direct export from a REDCap server, or a local file provided with a package) to get started.
2. An *optional* step of data modification (change variable classes and creating categorical variables (factors) from numeric or time data) 1. Data inspection and modification (change variable classes, create new variables (categorical from numeric or time data, or completely new variables from the data)
3. Data analysis of cross-sectionally designed studies (more study designs are planned to be included) 1. Evaluate data using descriptive analyses methods and inspect cross-correlations
- Classic baseline charactieristics (options to stratify and compare variables) 1. Create regression models for even more advanced data analyses
- Linear, dichotomous or ordinal logistic regression will be used depending on specified outcome variable - Linear, dichotomous or ordinal logistic regression will be used depending on specified outcome variable
- Plot regression analysis coefficients
- Evaluation of model assumptions - Evaluation of model assumptions
4. Export the the analyses results for MS Word or [LibreOffice](https://www.libreoffice.org/) as well as the data with preserved metadata. 1. Export the the analyses results for MS Word or [LibreOffice](https://www.libreoffice.org/) as well as the data with preserved metadata.
Have a look at the [documentations page](https://agdamsbo.github.io/freesearcheR/) for further project description. If you're interested in the source code, then go on, [have a look](https://github.com/agdamsbo/freesearcheR)! Have a look at the [documentations page](https://agdamsbo.github.io/freesearcheR/) for further project description. If you're interested in the source code, then go on, [have a look](https://github.com/agdamsbo/freesearcheR)!

55
inst/apps/data_analysis_modules/www/report.qmd
View file

@ -1,55 +0,0 @@
---
title: "freesearcheR analysis results"
date: today
format: docx
author: freesearcheR Tool
toc: false
execute:
echo: false
params:
data.file: NA
---
```{r}
#| message: false
#| warning: false
web_data <- readr::read_rds(file = params$data.file)
library(gtsummary)
library(gt)
tbl_merge <- function(data) {
if (is.null(names(data))) {
data |> gtsummary::tbl_merge()
} else {
data |> gtsummary::tbl_merge(tab_spanner = names(data))
}
}
```
## Introduction
Research should be free and open with easy access for all. The freesearcheR tool attempts to help lower the bar to participate in contributing to science by making guided data analysis easily accessible in the web-browser.
## Methods
Analyses were conducted in the *freesearcheR* data analysis web-tool based on R version 4.4.1.
## Results
Below are the baseline characteristics.
```{r, results = 'asis'}
tbl <- gtsummary::as_gt(web_data$table1)
knitr::knit_print(tbl)
```
Below are the results from the
```{r, results = 'asis'}
reg_tbl <- web_data$regression$tables
knitr::knit_print(tbl_merge(reg_tbl))
```
## Discussion
Good luck on your further work!

14
inst/apps/data_analysis_modules/www/report.rmd
View file

@ -1,8 +1,8 @@
--- ---
title: "freesearcheR analysis results" title: "freesearcheR data report"
date: today date: "Report generated `r gsub('(\\D)0', '\\1', format(Sys.time(), '%A, %d.%m.%Y'))`"
format: docx format: docx
author: freesearcheR Tool author: freesearcheR data analysis tool
toc: false toc: false
params: params:
data.file: NA data.file: NA
@ -10,6 +10,7 @@ params:
```{r setup, echo = FALSE} ```{r setup, echo = FALSE}
knitr::opts_chunk$set(echo = FALSE, message = FALSE, warning = FALSE) knitr::opts_chunk$set(echo = FALSE, message = FALSE, warning = FALSE)
# glue::glue("{format(lubridate::today(),'%A')}, {lubridate::day(lubridate::today())}.{lubridate::month(lubridate::today())}.{lubridate::year(lubridate::today())}")
``` ```
@ -52,15 +53,18 @@ Analyses were conducted in the *freesearcheR* data analysis web-tool based on R
Below are the baseline characteristics. Below are the baseline characteristics.
```{r, results = 'asis'} ```{r, results = 'asis'}
if ("table1" %in% names(web_data)){
tbl <- gtsummary::as_gt(web_data$table1) tbl <- gtsummary::as_gt(web_data$table1)
knitr::knit_print(tbl) knitr::knit_print(tbl)}
``` ```
Below are the results from the `r tolower(vec2sentence(names(web_data$regression$tables)))` `r web_data$regression$params$descr`. `r if ("regression" %in% names(web_data)) glue::glue("Below are the results from the { tolower(vec2sentence(names(web_data$regression$tables)))} {web_data$regression$params$descr}.")`
```{r, results = 'asis'} ```{r, results = 'asis'}
if ("regression" %in% names(web_data)){
reg_tbl <- web_data$regression$tables reg_tbl <- web_data$regression$tables
knitr::knit_print(tbl_merge(reg_tbl)) knitr::knit_print(tbl_merge(reg_tbl))
}
``` ```
## Discussion ## Discussion

11350
renv.lock
View file

File diff suppressed because one or more lines are too long

190
renv/activate.R
View file

@ -2,7 +2,7 @@
local({ local({
# the requested version of renv # the requested version of renv
version <- "1.0.11" version <- "1.1.0"
attr(version, "sha") <- NULL attr(version, "sha") <- NULL
# the project directory # the project directory
@ -42,7 +42,7 @@ local({
return(FALSE) return(FALSE)
# next, check environment variables # next, check environment variables
# TODO: prefer using the configuration one in the future # prefer using the configuration one in the future
envvars <- c( envvars <- c(
"RENV_CONFIG_AUTOLOADER_ENABLED", "RENV_CONFIG_AUTOLOADER_ENABLED",
"RENV_AUTOLOADER_ENABLED", "RENV_AUTOLOADER_ENABLED",
@ -209,10 +209,6 @@ local({
} }
startswith <- function(string, prefix) {
substring(string, 1, nchar(prefix)) == prefix
}
bootstrap <- function(version, library) { bootstrap <- function(version, library) {
friendly <- renv_bootstrap_version_friendly(version) friendly <- renv_bootstrap_version_friendly(version)
@ -563,6 +559,9 @@ local({
# prepare download options # prepare download options
token <- renv_bootstrap_github_token() token <- renv_bootstrap_github_token()
if (is.null(token))
token <- ""
if (nzchar(Sys.which("curl")) && nzchar(token)) { if (nzchar(Sys.which("curl")) && nzchar(token)) {
fmt <- "--location --fail --header \"Authorization: token %s\"" fmt <- "--location --fail --header \"Authorization: token %s\""
extra <- sprintf(fmt, token) extra <- sprintf(fmt, token)
@ -951,8 +950,14 @@ local({
} }
renv_bootstrap_validate_version_dev <- function(version, description) { renv_bootstrap_validate_version_dev <- function(version, description) {
expected <- description[["RemoteSha"]] expected <- description[["RemoteSha"]]
is.character(expected) && startswith(expected, version) if (!is.character(expected))
return(FALSE)
pattern <- sprintf("^\\Q%s\\E", version)
grepl(pattern, expected, perl = TRUE)
} }
renv_bootstrap_validate_version_release <- function(version, description) { renv_bootstrap_validate_version_release <- function(version, description) {
@ -1132,10 +1137,10 @@ local({
renv_bootstrap_exec <- function(project, libpath, version) { renv_bootstrap_exec <- function(project, libpath, version) {
if (!renv_bootstrap_load(project, libpath, version)) if (!renv_bootstrap_load(project, libpath, version))
renv_bootstrap_run(version, libpath) renv_bootstrap_run(project, libpath, version)
} }
renv_bootstrap_run <- function(version, libpath) { renv_bootstrap_run <- function(project, libpath, version) {
# perform bootstrap # perform bootstrap
bootstrap(version, libpath) bootstrap(version, libpath)
@ -1146,7 +1151,7 @@ local({
# try again to load # try again to load
if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) { if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) {
return(renv::load(project = getwd())) return(renv::load(project = project))
} }
# failed to download or load renv; warn the user # failed to download or load renv; warn the user
@ -1192,98 +1197,101 @@ local({
jsonlite::fromJSON(txt = text, simplifyVector = FALSE) jsonlite::fromJSON(txt = text, simplifyVector = FALSE)
} }
renv_json_read_patterns <- function() {
list(
# objects
list("{", "\t\n\tobject(\t\n\t"),
list("}", "\t\n\t)\t\n\t"),
# arrays
list("[", "\t\n\tarray(\t\n\t"),
list("]", "\n\t\n)\n\t\n"),
# maps
list(":", "\t\n\t=\t\n\t")
)
}
renv_json_read_envir <- function() {
envir <- new.env(parent = emptyenv())
envir[["+"]] <- `+`
envir[["-"]] <- `-`
envir[["object"]] <- function(...) {
result <- list(...)
names(result) <- as.character(names(result))
result
}
envir[["array"]] <- list
envir[["true"]] <- TRUE
envir[["false"]] <- FALSE
envir[["null"]] <- NULL
envir
}
renv_json_read_remap <- function(object, patterns) {
# repair names if necessary
if (!is.null(names(object))) {
nms <- names(object)
for (pattern in patterns)
nms <- gsub(pattern[[2L]], pattern[[1L]], nms, fixed = TRUE)
names(object) <- nms
}
# repair strings if necessary
if (is.character(object)) {
for (pattern in patterns)
object <- gsub(pattern[[2L]], pattern[[1L]], object, fixed = TRUE)
}
# recurse for other objects
if (is.recursive(object))
for (i in seq_along(object))
object[i] <- list(renv_json_read_remap(object[[i]], patterns))
# return remapped object
object
}
renv_json_read_default <- function(file = NULL, text = NULL) { renv_json_read_default <- function(file = NULL, text = NULL) {
# find strings in the JSON # read json text
text <- paste(text %||% readLines(file, warn = FALSE), collapse = "\n") text <- paste(text %||% readLines(file, warn = FALSE), collapse = "\n")
pattern <- '["](?:(?:\\\\.)|(?:[^"\\\\]))*?["]'
locs <- gregexpr(pattern, text, perl = TRUE)[[1]]
# if any are found, replace them with placeholders # convert into something the R parser will understand
replaced <- text patterns <- renv_json_read_patterns()
strings <- character() transformed <- text
replacements <- character() for (pattern in patterns)
transformed <- gsub(pattern[[1L]], pattern[[2L]], transformed, fixed = TRUE)
if (!identical(c(locs), -1L)) {
# get the string values
starts <- locs
ends <- locs + attr(locs, "match.length") - 1L
strings <- substring(text, starts, ends)
# only keep those requiring escaping
strings <- grep("[[\\]{}:]", strings, perl = TRUE, value = TRUE)
# compute replacements
replacements <- sprintf('"\032%i\032"', seq_along(strings))
# replace the strings
mapply(function(string, replacement) {
replaced <<- sub(string, replacement, replaced, fixed = TRUE)
}, strings, replacements)
}
# transform the JSON into something the R parser understands
transformed <- replaced
transformed <- gsub("{}", "`names<-`(list(), character())", transformed, fixed = TRUE)
transformed <- gsub("[[{]", "list(", transformed, perl = TRUE)
transformed <- gsub("[]}]", ")", transformed, perl = TRUE)
transformed <- gsub(":", "=", transformed, fixed = TRUE)
text <- paste(transformed, collapse = "\n")
# parse it # parse it
json <- parse(text = text, keep.source = FALSE, srcfile = NULL)[[1L]] rfile <- tempfile("renv-json-", fileext = ".R")
on.exit(unlink(rfile), add = TRUE)
writeLines(transformed, con = rfile)
json <- parse(rfile, keep.source = FALSE, srcfile = NULL)[[1L]]
# construct map between source strings, replaced strings # evaluate in safe environment
map <- as.character(parse(text = strings)) result <- eval(json, envir = renv_json_read_envir())
names(map) <- as.character(parse(text = replacements))
# convert to list # fix up strings if necessary
map <- as.list(map) renv_json_read_remap(result, patterns)
# remap strings in object
remapped <- renv_json_read_remap(json, map)
# evaluate
eval(remapped, envir = baseenv())
} }
renv_json_read_remap <- function(json, map) {
# fix names
if (!is.null(names(json))) {
lhs <- match(names(json), names(map), nomatch = 0L)
rhs <- match(names(map), names(json), nomatch = 0L)
names(json)[rhs] <- map[lhs]
}
# fix values
if (is.character(json))
return(map[[json]] %||% json)
# handle true, false, null
if (is.name(json)) {
text <- as.character(json)
if (text == "true")
return(TRUE)
else if (text == "false")
return(FALSE)
else if (text == "null")
return(NULL)
}
# recurse
if (is.recursive(json)) {
for (i in seq_along(json)) {
json[i] <- list(renv_json_read_remap(json[[i]], map))
}
}
json
}
# load the renv profile, if any # load the renv profile, if any
renv_bootstrap_profile_load(project) renv_bootstrap_profile_load(project)