mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2025-09-12 09:59:39 +02:00
regression improvements
This commit is contained in:
parent
703daaec4b
commit
2dbc78310e
10 changed files with 2637 additions and 472 deletions
2
NEWS.md
2
NEWS.md
|
|
@ -6,6 +6,8 @@
|
|||
|
||||
* NEW: summary grid with sparklines.
|
||||
|
||||
* Speed improvements and better regression analysis handling. Preparations for extending analysis options and study designs.
|
||||
|
||||
|
||||
# freesearcheR 24.12.1
|
||||
|
||||
|
|
|
|||
|
|
@ -39,6 +39,8 @@ data_summary_server <- function(id,
|
|||
|
||||
output$tbl_summary <-
|
||||
toastui::renderDatagrid(
|
||||
{
|
||||
shiny::req(data())
|
||||
data() |>
|
||||
overview_vars() |>
|
||||
create_overview_datagrid() |>
|
||||
|
|
@ -47,6 +49,7 @@ data_summary_server <- function(id,
|
|||
color.main = color.main,
|
||||
color.sec = color.sec
|
||||
)
|
||||
}
|
||||
)
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -31,9 +31,20 @@
|
|||
#' fun = "stats::glm",
|
||||
#' args.list = list(family = binomial(link = "logit"))
|
||||
#' )
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' regression_model(
|
||||
#' outcome.str = "mpg",
|
||||
#' auto.mode = FALSE,
|
||||
#' fun = "stats::lm",
|
||||
#' formula.str = "{outcome.str}~{paste(vars,collapse='+')}",
|
||||
#' args.list = NULL,
|
||||
#' vars = c("mpg", "cyl")
|
||||
#' ) |>
|
||||
#' summary()
|
||||
regression_model <- function(data,
|
||||
outcome.str,
|
||||
auto.mode = TRUE,
|
||||
auto.mode = FALSE,
|
||||
formula.str = NULL,
|
||||
args.list = NULL,
|
||||
fun = NULL,
|
||||
|
|
@ -45,20 +56,22 @@ regression_model <- function(data,
|
|||
}
|
||||
}
|
||||
|
||||
if (is.null(vars)) {
|
||||
vars <- names(data)[!names(data) %in% outcome.str]
|
||||
} else {
|
||||
if (outcome.str %in% vars) {
|
||||
vars <- vars[!vars %in% outcome.str]
|
||||
}
|
||||
data <- data |> dplyr::select(dplyr::all_of(c(vars, outcome.str)))
|
||||
}
|
||||
|
||||
if (!is.null(formula.str)) {
|
||||
formula.str <- glue::glue(formula.str)
|
||||
formula.glue <- glue::glue(formula.str)
|
||||
} else {
|
||||
assertthat::assert_that(outcome.str %in% names(data),
|
||||
msg = "Outcome variable is not present in the provided dataset"
|
||||
)
|
||||
formula.str <- glue::glue("{outcome.str}~.")
|
||||
|
||||
if (!is.null(vars)) {
|
||||
if (outcome.str %in% vars) {
|
||||
vars <- vars[vars %in% outcome.str]
|
||||
}
|
||||
data <- data |> dplyr::select(dplyr::all_of(c(vars, outcome.str)))
|
||||
}
|
||||
formula.glue <- glue::glue("{outcome.str}~{paste(vars,collapse='+')}")
|
||||
}
|
||||
|
||||
# Formatting character variables as factor
|
||||
|
|
@ -104,7 +117,7 @@ regression_model <- function(data,
|
|||
getfun(fun),
|
||||
c(
|
||||
list(data = data),
|
||||
list(formula = as.formula(formula.str)),
|
||||
list(formula = as.formula(formula.glue)),
|
||||
args.list
|
||||
)
|
||||
)
|
||||
|
|
@ -202,3 +215,384 @@ regression_model_uv <- function(data,
|
|||
return(out)
|
||||
}
|
||||
|
||||
|
||||
### HELPERS
|
||||
|
||||
#' Outcome data type assessment
|
||||
#'
|
||||
#' @param data data
|
||||
#'
|
||||
#' @returns outcome type
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' lapply(outcome_type)
|
||||
outcome_type <- function(data) {
|
||||
cl_d <- class(data)
|
||||
if (any(c("numeric", "integer") %in% cl_d)) {
|
||||
out <- "continuous"
|
||||
} else if (identical("factor", cl_d)) {
|
||||
if (length(levels(data)) == 2) {
|
||||
out <- "dichotomous"
|
||||
} else if (length(levels(data)) > 2) {
|
||||
out <- "ordinal"
|
||||
}
|
||||
} else {
|
||||
out <- "unknown"
|
||||
}
|
||||
|
||||
out
|
||||
}
|
||||
|
||||
|
||||
#' Implemented functions
|
||||
#'
|
||||
#' @description
|
||||
#' Library of supported functions. The list name and "descr" element should be
|
||||
#' unique for each element on list.
|
||||
#'
|
||||
#'
|
||||
#' @returns list
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' supported_functions()
|
||||
supported_functions <- function() {
|
||||
list(
|
||||
lm = list(
|
||||
descr = "Linear regression model",
|
||||
design = "cross-sectional",
|
||||
out.type = "continuous",
|
||||
fun = "stats::lm",
|
||||
args.list = NULL,
|
||||
formula.str = "{outcome.str}~{paste(vars,collapse='+')}"
|
||||
),
|
||||
glm = list(
|
||||
descr = "Logistic regression model",
|
||||
design = "cross-sectional",
|
||||
out.type = "dichotomous",
|
||||
fun = "stats::glm",
|
||||
args.list = list(family = stats::binomial(link = "logit")),
|
||||
formula.str = "{outcome.str}~{paste(vars,collapse='+')}"
|
||||
),
|
||||
polr = list(
|
||||
descr = "Ordinal logistic regression model",
|
||||
design = "cross-sectional",
|
||||
out.type = "ordinal",
|
||||
fun = "MASS::polr",
|
||||
args.list = list(
|
||||
Hess = TRUE,
|
||||
method = "logistic"
|
||||
),
|
||||
formula.str = "{outcome.str}~{paste(vars,collapse='+')}"
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
#' Get possible regression models
|
||||
#'
|
||||
#' @param data data
|
||||
#'
|
||||
#' @returns
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' dplyr::pull("cyl") |>
|
||||
#' possible_functions(design = "cross-sectional")
|
||||
#'
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' dplyr::select("cyl") |>
|
||||
#' possible_functions(design = "cross-sectional")
|
||||
possible_functions <- function(data, design = c("cross-sectional")) {
|
||||
# browser()
|
||||
if (is.data.frame(data)) {
|
||||
data <- data[[1]]
|
||||
}
|
||||
|
||||
design <- match.arg(design)
|
||||
type <- outcome_type(data)
|
||||
|
||||
design_ls <- supported_functions() |>
|
||||
lapply(\(.x){
|
||||
if (design %in% .x$design) {
|
||||
.x
|
||||
}
|
||||
})
|
||||
|
||||
if (type == "unknown") {
|
||||
out <- type
|
||||
} else {
|
||||
out <- design_ls |>
|
||||
lapply(\(.x){
|
||||
if (type %in% .x$out.type) {
|
||||
.x$descr
|
||||
}
|
||||
}) |>
|
||||
unlist()
|
||||
}
|
||||
unname(out)
|
||||
}
|
||||
|
||||
|
||||
#' Get the function options based on the selected function description
|
||||
#'
|
||||
#' @param data vector
|
||||
#'
|
||||
#' @returns list
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' dplyr::pull(mpg) |>
|
||||
#' possible_functions(design = "cross-sectional") |>
|
||||
#' (\(.x){
|
||||
#' .x[[1]]
|
||||
#' })() |>
|
||||
#' get_fun_options()
|
||||
get_fun_options <- function(data) {
|
||||
descrs <- supported_functions() |>
|
||||
lapply(\(.x){
|
||||
.x$descr
|
||||
}) |>
|
||||
unlist()
|
||||
supported_functions() |>
|
||||
(\(.x){
|
||||
.x[match(data, descrs)]
|
||||
})()
|
||||
}
|
||||
|
||||
|
||||
#' Wrapper to create regression model based on supported models
|
||||
#'
|
||||
#' @description
|
||||
#' Output is a concatenated list of model information and model
|
||||
#'
|
||||
#'
|
||||
#' @param data data
|
||||
#' @param outcome.str name of outcome variable
|
||||
#' @param fun.descr Description of chosen function matching description in
|
||||
#' "supported_functions()"
|
||||
#' @param fun name of custom function. Default is NULL.
|
||||
#' @param formula.str custom formula glue string. Default is NULL.
|
||||
#' @param args.list custom character string to be converted using
|
||||
#' argsstring2list() or list of arguments. Default is NULL.
|
||||
#' @param ... ignored
|
||||
#'
|
||||
#' @returns
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' gtsummary::trial |>
|
||||
#' regression_model(
|
||||
#' outcome.str = "age",
|
||||
#' fun = "stats::lm",
|
||||
#' formula.str = "{outcome.str}~.",
|
||||
#' args.list = NULL
|
||||
#' )
|
||||
#' ls <- regression_model_list(data = default_parsing(mtcars), outcome.str = "cyl", fun.descr = "Ordinal logistic regression model")
|
||||
#' summary(ls$model)
|
||||
regression_model_list <- function(data,
|
||||
outcome.str,
|
||||
fun.descr,
|
||||
fun = NULL,
|
||||
formula.str = NULL,
|
||||
args.list = NULL,
|
||||
vars = NULL,
|
||||
...) {
|
||||
options <- get_fun_options(fun.descr) |>
|
||||
(\(.x){
|
||||
.x[[1]]
|
||||
})()
|
||||
|
||||
## Custom, specific fun, args and formula options
|
||||
|
||||
if (is.null(formula.str)) {
|
||||
formula.str.c <- options$formula.str
|
||||
} else {
|
||||
formula.str.c <- formula.str
|
||||
}
|
||||
|
||||
if (is.null(fun)) {
|
||||
fun.c <- options$fun
|
||||
} else {
|
||||
fun.c <- fun
|
||||
}
|
||||
|
||||
if (is.null(args.list)) {
|
||||
args.list.c <- options$args.list
|
||||
} else {
|
||||
args.list.c <- args.list
|
||||
}
|
||||
|
||||
if (is.character(args.list.c)) args.list.c <- argsstring2list(args.list.c)
|
||||
|
||||
## Handling vars to print code
|
||||
|
||||
if (is.null(vars)) {
|
||||
vars <- names(data)[!names(data) %in% outcome.str]
|
||||
} else {
|
||||
if (outcome.str %in% vars) {
|
||||
vars <- vars[!vars %in% outcome.str]
|
||||
}
|
||||
}
|
||||
|
||||
model <- do.call(
|
||||
regression_model,
|
||||
c(
|
||||
list(data = data),
|
||||
list(outcome.str = outcome.str),
|
||||
list(fun = fun.c),
|
||||
list(formula.str = formula.str.c),
|
||||
args.list.c
|
||||
)
|
||||
)
|
||||
|
||||
code <- glue::glue(
|
||||
"{fun.c}({paste(Filter(length,list(glue::glue(formula.str.c),'data = data',list2str(args.list.c))),collapse=', ')})"
|
||||
)
|
||||
|
||||
list(
|
||||
options = options,
|
||||
model = model,
|
||||
code = code
|
||||
)
|
||||
}
|
||||
|
||||
list2str <- function(data) {
|
||||
out <- purrr::imap(data, \(.x, .i){
|
||||
if (is.logical(.x)) {
|
||||
arg <- .x
|
||||
} else {
|
||||
arg <- glue::glue("'{.x}'")
|
||||
}
|
||||
glue::glue("{.i} = {arg}")
|
||||
}) |>
|
||||
unlist() |>
|
||||
paste(collapse = (", "))
|
||||
|
||||
if (out==""){
|
||||
return(NULL)
|
||||
} else {
|
||||
out
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#' Title
|
||||
#'
|
||||
#' @param data
|
||||
#' @param outcome.str
|
||||
#' @param fun.descr
|
||||
#' @param fun
|
||||
#' @param formula.str
|
||||
#' @param args.list
|
||||
#' @param vars
|
||||
#' @param ...
|
||||
#'
|
||||
#' @returns
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' gtsummary::trial |> regression_model_uv(
|
||||
#' outcome.str = "trt",
|
||||
#' fun = "stats::glm",
|
||||
#' args.list = list(family = stats::binomial(link = "logit"))
|
||||
#' )
|
||||
#' ms <- regression_model_uv_list(data = default_parsing(mtcars), outcome.str = "mpg", fun.descr = "Linear regression model")
|
||||
regression_model_uv_list <- function(data,
|
||||
outcome.str,
|
||||
fun.descr,
|
||||
fun = NULL,
|
||||
formula.str = NULL,
|
||||
args.list = NULL,
|
||||
vars = NULL,
|
||||
...) {
|
||||
|
||||
options <- get_fun_options(fun.descr) |>
|
||||
(\(.x){
|
||||
.x[[1]]
|
||||
})()
|
||||
|
||||
## Custom, specific fun, args and formula options
|
||||
|
||||
if (is.null(formula.str)) {
|
||||
formula.str.c <- options$formula.str
|
||||
} else {
|
||||
formula.str.c <- formula.str
|
||||
}
|
||||
|
||||
if (is.null(fun)) {
|
||||
fun.c <- options$fun
|
||||
} else {
|
||||
fun.c <- fun
|
||||
}
|
||||
|
||||
if (is.null(args.list)) {
|
||||
args.list.c <- options$args.list
|
||||
} else {
|
||||
args.list.c <- args.list
|
||||
}
|
||||
|
||||
if (is.character(args.list.c)) args.list.c <- argsstring2list(args.list.c)
|
||||
|
||||
## Handling vars to print code
|
||||
|
||||
if (is.null(vars)) {
|
||||
vars <- names(data)[!names(data) %in% outcome.str]
|
||||
} else {
|
||||
if (outcome.str %in% vars) {
|
||||
vars <- vars[!vars %in% outcome.str]
|
||||
}
|
||||
}
|
||||
|
||||
# assertthat::assert_that("character" %in% class(fun),
|
||||
# msg = "Please provide the function as a character vector."
|
||||
# )
|
||||
|
||||
# model <- do.call(
|
||||
# regression_model,
|
||||
# c(
|
||||
# list(data = data),
|
||||
# list(outcome.str = outcome.str),
|
||||
# list(fun = fun.c),
|
||||
# list(formula.str = formula.str.c),
|
||||
# args.list.c
|
||||
# )
|
||||
# )
|
||||
|
||||
model <- vars |>
|
||||
lapply(\(.var){
|
||||
do.call(
|
||||
regression_model,
|
||||
c(
|
||||
list(data = data[c(outcome.str, .var)]),
|
||||
list(outcome.str = outcome.str),
|
||||
list(fun = fun.c),
|
||||
list(formula.str = formula.str.c),
|
||||
args.list.c
|
||||
)
|
||||
)
|
||||
})
|
||||
|
||||
|
||||
vars <- "."
|
||||
|
||||
code_raw <- glue::glue(
|
||||
"{fun.c}({paste(Filter(length,list(glue::glue(formula.str.c),'data = .d',list2str(args.list.c))),collapse=', ')})"
|
||||
)
|
||||
|
||||
code <- glue::glue("lapply(data,function(.d){code_raw})")
|
||||
|
||||
list(
|
||||
options = options,
|
||||
model = model,
|
||||
code = code
|
||||
)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -721,6 +721,8 @@ data_summary_server <- function(id,
|
|||
|
||||
output$tbl_summary <-
|
||||
toastui::renderDatagrid(
|
||||
{
|
||||
shiny::req(data())
|
||||
data() |>
|
||||
overview_vars() |>
|
||||
create_overview_datagrid() |>
|
||||
|
|
@ -729,6 +731,7 @@ data_summary_server <- function(id,
|
|||
color.main = color.main,
|
||||
color.sec = color.sec
|
||||
)
|
||||
}
|
||||
)
|
||||
|
||||
}
|
||||
|
|
@ -1731,9 +1734,20 @@ redcap_app <- function() {
|
|||
#' fun = "stats::glm",
|
||||
#' args.list = list(family = binomial(link = "logit"))
|
||||
#' )
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' regression_model(
|
||||
#' outcome.str = "mpg",
|
||||
#' auto.mode = FALSE,
|
||||
#' fun = "stats::lm",
|
||||
#' formula.str = "{outcome.str}~{paste(vars,collapse='+')}",
|
||||
#' args.list = NULL,
|
||||
#' vars = c("mpg", "cyl")
|
||||
#' ) |>
|
||||
#' summary()
|
||||
regression_model <- function(data,
|
||||
outcome.str,
|
||||
auto.mode = TRUE,
|
||||
auto.mode = FALSE,
|
||||
formula.str = NULL,
|
||||
args.list = NULL,
|
||||
fun = NULL,
|
||||
|
|
@ -1745,20 +1759,22 @@ regression_model <- function(data,
|
|||
}
|
||||
}
|
||||
|
||||
if (is.null(vars)) {
|
||||
vars <- names(data)[!names(data) %in% outcome.str]
|
||||
} else {
|
||||
if (outcome.str %in% vars) {
|
||||
vars <- vars[!vars %in% outcome.str]
|
||||
}
|
||||
data <- data |> dplyr::select(dplyr::all_of(c(vars, outcome.str)))
|
||||
}
|
||||
|
||||
if (!is.null(formula.str)) {
|
||||
formula.str <- glue::glue(formula.str)
|
||||
formula.glue <- glue::glue(formula.str)
|
||||
} else {
|
||||
assertthat::assert_that(outcome.str %in% names(data),
|
||||
msg = "Outcome variable is not present in the provided dataset"
|
||||
)
|
||||
formula.str <- glue::glue("{outcome.str}~.")
|
||||
|
||||
if (!is.null(vars)) {
|
||||
if (outcome.str %in% vars) {
|
||||
vars <- vars[vars %in% outcome.str]
|
||||
}
|
||||
data <- data |> dplyr::select(dplyr::all_of(c(vars, outcome.str)))
|
||||
}
|
||||
formula.glue <- glue::glue("{outcome.str}~{paste(vars,collapse='+')}")
|
||||
}
|
||||
|
||||
# Formatting character variables as factor
|
||||
|
|
@ -1804,7 +1820,7 @@ regression_model <- function(data,
|
|||
getfun(fun),
|
||||
c(
|
||||
list(data = data),
|
||||
list(formula = as.formula(formula.str)),
|
||||
list(formula = as.formula(formula.glue)),
|
||||
args.list
|
||||
)
|
||||
)
|
||||
|
|
@ -1903,6 +1919,387 @@ regression_model_uv <- function(data,
|
|||
}
|
||||
|
||||
|
||||
### HELPERS
|
||||
|
||||
#' Outcome data type assessment
|
||||
#'
|
||||
#' @param data data
|
||||
#'
|
||||
#' @returns outcome type
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' lapply(outcome_type)
|
||||
outcome_type <- function(data) {
|
||||
cl_d <- class(data)
|
||||
if (any(c("numeric", "integer") %in% cl_d)) {
|
||||
out <- "continuous"
|
||||
} else if (identical("factor", cl_d)) {
|
||||
if (length(levels(data)) == 2) {
|
||||
out <- "dichotomous"
|
||||
} else if (length(levels(data)) > 2) {
|
||||
out <- "ordinal"
|
||||
}
|
||||
} else {
|
||||
out <- "unknown"
|
||||
}
|
||||
|
||||
out
|
||||
}
|
||||
|
||||
|
||||
#' Implemented functions
|
||||
#'
|
||||
#' @description
|
||||
#' Library of supported functions. The list name and "descr" element should be
|
||||
#' unique for each element on list.
|
||||
#'
|
||||
#'
|
||||
#' @returns list
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' supported_functions()
|
||||
supported_functions <- function() {
|
||||
list(
|
||||
lm = list(
|
||||
descr = "Linear regression model",
|
||||
design = "cross-sectional",
|
||||
out.type = "continuous",
|
||||
fun = "stats::lm",
|
||||
args.list = NULL,
|
||||
formula.str = "{outcome.str}~{paste(vars,collapse='+')}"
|
||||
),
|
||||
glm = list(
|
||||
descr = "Logistic regression model",
|
||||
design = "cross-sectional",
|
||||
out.type = "dichotomous",
|
||||
fun = "stats::glm",
|
||||
args.list = list(family = stats::binomial(link = "logit")),
|
||||
formula.str = "{outcome.str}~{paste(vars,collapse='+')}"
|
||||
),
|
||||
polr = list(
|
||||
descr = "Ordinal logistic regression model",
|
||||
design = "cross-sectional",
|
||||
out.type = "ordinal",
|
||||
fun = "MASS::polr",
|
||||
args.list = list(
|
||||
Hess = TRUE,
|
||||
method = "logistic"
|
||||
),
|
||||
formula.str = "{outcome.str}~{paste(vars,collapse='+')}"
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
#' Get possible regression models
|
||||
#'
|
||||
#' @param data data
|
||||
#'
|
||||
#' @returns
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' dplyr::pull("cyl") |>
|
||||
#' possible_functions(design = "cross-sectional")
|
||||
#'
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' dplyr::select("cyl") |>
|
||||
#' possible_functions(design = "cross-sectional")
|
||||
possible_functions <- function(data, design = c("cross-sectional")) {
|
||||
# browser()
|
||||
if (is.data.frame(data)) {
|
||||
data <- data[[1]]
|
||||
}
|
||||
|
||||
design <- match.arg(design)
|
||||
type <- outcome_type(data)
|
||||
|
||||
design_ls <- supported_functions() |>
|
||||
lapply(\(.x){
|
||||
if (design %in% .x$design) {
|
||||
.x
|
||||
}
|
||||
})
|
||||
|
||||
if (type == "unknown") {
|
||||
out <- type
|
||||
} else {
|
||||
out <- design_ls |>
|
||||
lapply(\(.x){
|
||||
if (type %in% .x$out.type) {
|
||||
.x$descr
|
||||
}
|
||||
}) |>
|
||||
unlist()
|
||||
}
|
||||
unname(out)
|
||||
}
|
||||
|
||||
|
||||
#' Get the function options based on the selected function description
|
||||
#'
|
||||
#' @param data vector
|
||||
#'
|
||||
#' @returns list
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' dplyr::pull(mpg) |>
|
||||
#' possible_functions(design = "cross-sectional") |>
|
||||
#' (\(.x){
|
||||
#' .x[[1]]
|
||||
#' })() |>
|
||||
#' get_fun_options()
|
||||
get_fun_options <- function(data) {
|
||||
descrs <- supported_functions() |>
|
||||
lapply(\(.x){
|
||||
.x$descr
|
||||
}) |>
|
||||
unlist()
|
||||
supported_functions() |>
|
||||
(\(.x){
|
||||
.x[match(data, descrs)]
|
||||
})()
|
||||
}
|
||||
|
||||
|
||||
#' Wrapper to create regression model based on supported models
|
||||
#'
|
||||
#' @description
|
||||
#' Output is a concatenated list of model information and model
|
||||
#'
|
||||
#'
|
||||
#' @param data data
|
||||
#' @param outcome.str name of outcome variable
|
||||
#' @param fun.descr Description of chosen function matching description in
|
||||
#' "supported_functions()"
|
||||
#' @param fun name of custom function. Default is NULL.
|
||||
#' @param formula.str custom formula glue string. Default is NULL.
|
||||
#' @param args.list custom character string to be converted using
|
||||
#' argsstring2list() or list of arguments. Default is NULL.
|
||||
#' @param ... ignored
|
||||
#'
|
||||
#' @returns
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' gtsummary::trial |>
|
||||
#' regression_model(
|
||||
#' outcome.str = "age",
|
||||
#' fun = "stats::lm",
|
||||
#' formula.str = "{outcome.str}~.",
|
||||
#' args.list = NULL
|
||||
#' )
|
||||
#' ls <- regression_model_list(data = default_parsing(mtcars), outcome.str = "cyl", fun.descr = "Ordinal logistic regression model")
|
||||
#' summary(ls$model)
|
||||
regression_model_list <- function(data,
|
||||
outcome.str,
|
||||
fun.descr,
|
||||
fun = NULL,
|
||||
formula.str = NULL,
|
||||
args.list = NULL,
|
||||
vars = NULL,
|
||||
...) {
|
||||
options <- get_fun_options(fun.descr) |>
|
||||
(\(.x){
|
||||
.x[[1]]
|
||||
})()
|
||||
|
||||
## Custom, specific fun, args and formula options
|
||||
|
||||
if (is.null(formula.str)) {
|
||||
formula.str.c <- options$formula.str
|
||||
} else {
|
||||
formula.str.c <- formula.str
|
||||
}
|
||||
|
||||
if (is.null(fun)) {
|
||||
fun.c <- options$fun
|
||||
} else {
|
||||
fun.c <- fun
|
||||
}
|
||||
|
||||
if (is.null(args.list)) {
|
||||
args.list.c <- options$args.list
|
||||
} else {
|
||||
args.list.c <- args.list
|
||||
}
|
||||
|
||||
if (is.character(args.list.c)) args.list.c <- argsstring2list(args.list.c)
|
||||
|
||||
## Handling vars to print code
|
||||
|
||||
if (is.null(vars)) {
|
||||
vars <- names(data)[!names(data) %in% outcome.str]
|
||||
} else {
|
||||
if (outcome.str %in% vars) {
|
||||
vars <- vars[!vars %in% outcome.str]
|
||||
}
|
||||
}
|
||||
|
||||
model <- do.call(
|
||||
regression_model,
|
||||
c(
|
||||
list(data = data),
|
||||
list(outcome.str = outcome.str),
|
||||
list(fun = fun.c),
|
||||
list(formula.str = formula.str.c),
|
||||
args.list.c
|
||||
)
|
||||
)
|
||||
|
||||
code <- glue::glue(
|
||||
"{fun.c}({paste(Filter(length,list(glue::glue(formula.str.c),'data = data',list2str(args.list.c))),collapse=', ')})"
|
||||
)
|
||||
|
||||
list(
|
||||
options = options,
|
||||
model = model,
|
||||
code = code
|
||||
)
|
||||
}
|
||||
|
||||
list2str <- function(data) {
|
||||
out <- purrr::imap(data, \(.x, .i){
|
||||
if (is.logical(.x)) {
|
||||
arg <- .x
|
||||
} else {
|
||||
arg <- glue::glue("'{.x}'")
|
||||
}
|
||||
glue::glue("{.i} = {arg}")
|
||||
}) |>
|
||||
unlist() |>
|
||||
paste(collapse = (", "))
|
||||
|
||||
if (out==""){
|
||||
return(NULL)
|
||||
} else {
|
||||
out
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#' Title
|
||||
#'
|
||||
#' @param data
|
||||
#' @param outcome.str
|
||||
#' @param fun.descr
|
||||
#' @param fun
|
||||
#' @param formula.str
|
||||
#' @param args.list
|
||||
#' @param vars
|
||||
#' @param ...
|
||||
#'
|
||||
#' @returns
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' gtsummary::trial |> regression_model_uv(
|
||||
#' outcome.str = "trt",
|
||||
#' fun = "stats::glm",
|
||||
#' args.list = list(family = stats::binomial(link = "logit"))
|
||||
#' )
|
||||
#' ms <- regression_model_uv_list(data = default_parsing(mtcars), outcome.str = "mpg", fun.descr = "Linear regression model")
|
||||
regression_model_uv_list <- function(data,
|
||||
outcome.str,
|
||||
fun.descr,
|
||||
fun = NULL,
|
||||
formula.str = NULL,
|
||||
args.list = NULL,
|
||||
vars = NULL,
|
||||
...) {
|
||||
|
||||
options <- get_fun_options(fun.descr) |>
|
||||
(\(.x){
|
||||
.x[[1]]
|
||||
})()
|
||||
|
||||
## Custom, specific fun, args and formula options
|
||||
|
||||
if (is.null(formula.str)) {
|
||||
formula.str.c <- options$formula.str
|
||||
} else {
|
||||
formula.str.c <- formula.str
|
||||
}
|
||||
|
||||
if (is.null(fun)) {
|
||||
fun.c <- options$fun
|
||||
} else {
|
||||
fun.c <- fun
|
||||
}
|
||||
|
||||
if (is.null(args.list)) {
|
||||
args.list.c <- options$args.list
|
||||
} else {
|
||||
args.list.c <- args.list
|
||||
}
|
||||
|
||||
if (is.character(args.list.c)) args.list.c <- argsstring2list(args.list.c)
|
||||
|
||||
## Handling vars to print code
|
||||
|
||||
if (is.null(vars)) {
|
||||
vars <- names(data)[!names(data) %in% outcome.str]
|
||||
} else {
|
||||
if (outcome.str %in% vars) {
|
||||
vars <- vars[!vars %in% outcome.str]
|
||||
}
|
||||
}
|
||||
|
||||
# assertthat::assert_that("character" %in% class(fun),
|
||||
# msg = "Please provide the function as a character vector."
|
||||
# )
|
||||
|
||||
# model <- do.call(
|
||||
# regression_model,
|
||||
# c(
|
||||
# list(data = data),
|
||||
# list(outcome.str = outcome.str),
|
||||
# list(fun = fun.c),
|
||||
# list(formula.str = formula.str.c),
|
||||
# args.list.c
|
||||
# )
|
||||
# )
|
||||
|
||||
model <- vars |>
|
||||
lapply(\(.var){
|
||||
do.call(
|
||||
regression_model,
|
||||
c(
|
||||
list(data = data[c(outcome.str, .var)]),
|
||||
list(outcome.str = outcome.str),
|
||||
list(fun = fun.c),
|
||||
list(formula.str = formula.str.c),
|
||||
args.list.c
|
||||
)
|
||||
)
|
||||
})
|
||||
|
||||
|
||||
vars <- "."
|
||||
|
||||
code_raw <- glue::glue(
|
||||
"{fun.c}({paste(Filter(length,list(glue::glue(formula.str.c),'data = .d',list2str(args.list.c))),collapse=', ')})"
|
||||
)
|
||||
|
||||
code <- glue::glue("lapply(data,function(.d){code_raw})")
|
||||
|
||||
list(
|
||||
options = options,
|
||||
model = model,
|
||||
code = code
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
########
|
||||
#### Current file: R//regression_table.R
|
||||
|
|
@ -3208,13 +3605,12 @@ ui_elements <- list(
|
|||
bslib::nav_panel(
|
||||
# value = "analyze",
|
||||
title = "Analyses",
|
||||
id = "navanalyses",
|
||||
bslib::navset_bar(
|
||||
title = "",
|
||||
# bslib::layout_sidebar(
|
||||
# fillable = TRUE,
|
||||
sidebar = bslib::sidebar(
|
||||
shiny::helpText(em("Please specify relevant settings for your data, and press 'Analyse'")),
|
||||
shiny::uiOutput("outcome_var"),
|
||||
shiny::radioButtons(
|
||||
inputId = "all",
|
||||
label = "Specify covariables",
|
||||
|
|
@ -3229,6 +3625,13 @@ ui_elements <- list(
|
|||
condition = "input.all==1",
|
||||
shiny::uiOutput("include_vars")
|
||||
),
|
||||
bslib::accordion(
|
||||
open = "acc_chars",
|
||||
multiple = FALSE,
|
||||
bslib::accordion_panel(
|
||||
value = "acc_chars",
|
||||
title = "Characteristics",
|
||||
icon = bsicons::bs_icon("table"),
|
||||
shiny::uiOutput("strat_var"),
|
||||
shiny::helpText("Only factor/categorical variables are available for stratification. Go back to the 'Data' tab to reclass a variable if it's not on the list."),
|
||||
shiny::conditionalPanel(
|
||||
|
|
@ -3244,25 +3647,28 @@ ui_elements <- list(
|
|||
)
|
||||
),
|
||||
shiny::helpText("Option to perform statistical comparisons between strata in baseline table.")
|
||||
),
|
||||
shiny::radioButtons(
|
||||
inputId = "specify_factors",
|
||||
label = "Specify categorical variables?",
|
||||
selected = "no",
|
||||
inline = TRUE,
|
||||
choices = list(
|
||||
"Yes" = "yes",
|
||||
"No" = "no"
|
||||
)
|
||||
),
|
||||
shiny::conditionalPanel(
|
||||
condition = "input.specify_factors=='yes'",
|
||||
shiny::uiOutput("factor_vars")
|
||||
),
|
||||
bslib::accordion_panel(
|
||||
value = "acc_reg",
|
||||
title = "Regression",
|
||||
icon = bsicons::bs_icon("calculator"),
|
||||
shiny::uiOutput("outcome_var"),
|
||||
# shiny::selectInput(
|
||||
# inputId = "design",
|
||||
# label = "Study design",
|
||||
# selected = "no",
|
||||
# inline = TRUE,
|
||||
# choices = list(
|
||||
# "Cross-sectional" = "cross-sectional"
|
||||
# )
|
||||
# ),
|
||||
shiny::uiOutput("regression_type"),
|
||||
bslib::input_task_button(
|
||||
id = "load",
|
||||
label = "Analyse",
|
||||
icon = shiny::icon("pencil", lib = "glyphicon"),
|
||||
# icon = shiny::icon("pencil", lib = "glyphicon"),
|
||||
icon = bsicons::bs_icon("pencil"),
|
||||
label_busy = "Working...",
|
||||
icon_busy = fontawesome::fa_i("arrows-rotate",
|
||||
class = "fa-spin",
|
||||
|
|
@ -3271,11 +3677,13 @@ ui_elements <- list(
|
|||
type = "secondary",
|
||||
auto_reset = TRUE
|
||||
),
|
||||
shiny::helpText("If you change the parameters, press 'Analyse' again to update the tables"),
|
||||
# shiny::conditionalPanel(
|
||||
# condition = "output.ready=='yes'",
|
||||
shiny::tags$hr(),
|
||||
shiny::h4("Download results"),
|
||||
shiny::helpText("If you change the parameters, press 'Analyse' again to update the tables")
|
||||
),
|
||||
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",
|
||||
|
|
@ -3298,7 +3706,7 @@ ui_elements <- list(
|
|||
),
|
||||
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("Download data"),
|
||||
shiny::h4("Data"),
|
||||
shiny::helpText("Choose your favourite output data format to download the modified data."),
|
||||
shiny::selectInput(
|
||||
inputId = "data_type",
|
||||
|
|
@ -3316,6 +3724,26 @@ ui_elements <- list(
|
|||
label = "Download data",
|
||||
icon = shiny::icon("download")
|
||||
)
|
||||
)
|
||||
),
|
||||
# shiny::helpText(em("Please specify relevant settings for your data, and press 'Analyse'")),
|
||||
# shiny::radioButtons(
|
||||
# inputId = "specify_factors",
|
||||
# label = "Specify categorical variables?",
|
||||
# selected = "no",
|
||||
# inline = TRUE,
|
||||
# choices = list(
|
||||
# "Yes" = "yes",
|
||||
# "No" = "no"
|
||||
# )
|
||||
# ),
|
||||
# shiny::conditionalPanel(
|
||||
# condition = "input.specify_factors=='yes'",
|
||||
# shiny::uiOutput("factor_vars")
|
||||
# ),
|
||||
# shiny::conditionalPanel(
|
||||
# condition = "output.ready=='yes'",
|
||||
# shiny::tags$hr(),
|
||||
),
|
||||
bslib::nav_panel(
|
||||
title = "Baseline characteristics",
|
||||
|
|
@ -3489,7 +3917,9 @@ server <- function(input, output, session) {
|
|||
test = "no",
|
||||
data_original = NULL,
|
||||
data = NULL,
|
||||
data_filtered = NULL
|
||||
data_filtered = NULL,
|
||||
models = NULL,
|
||||
check = NULL
|
||||
)
|
||||
|
||||
##############################################################################
|
||||
|
|
@ -3672,8 +4102,20 @@ server <- function(input, output, session) {
|
|||
# IDEAFilter has the least cluttered UI, but might have a License issue
|
||||
data_filter <- IDEAFilter::IDEAFilter("data_filter", data = reactive(rv$data), verbose = TRUE)
|
||||
|
||||
shiny::observeEvent(data_filter(), {
|
||||
shiny::observeEvent(
|
||||
list(
|
||||
shiny::reactive(rv$data),
|
||||
shiny::reactive(rv$data_original),
|
||||
data_filter(),
|
||||
base_vars()
|
||||
), {
|
||||
rv$data_filtered <- data_filter()
|
||||
|
||||
rv$list$data <- data_filter() |>
|
||||
REDCapCAST::fct_drop.data.frame() |>
|
||||
(\(.x){
|
||||
.x[base_vars()]
|
||||
})()
|
||||
})
|
||||
|
||||
output$filtered_code <- shiny::renderPrint({
|
||||
|
|
@ -3727,6 +4169,16 @@ server <- function(input, output, session) {
|
|||
)
|
||||
})
|
||||
|
||||
output$regression_type <- shiny::renderUI({
|
||||
shiny::req(input$outcome_var)
|
||||
shiny::selectizeInput(
|
||||
inputId = "regression_type",
|
||||
# selected = colnames(rv$data_filtered)[sapply(rv$data_filtered, is.factor)],
|
||||
label = "Choose regression analysis",
|
||||
choices = possible_functions(data = dplyr::select(rv$data_filtered, input$outcome_var), design = "cross-sectional"),
|
||||
multiple = FALSE
|
||||
)
|
||||
})
|
||||
|
||||
output$factor_vars <- shiny::renderUI({
|
||||
shiny::selectizeInput(
|
||||
|
|
@ -3789,22 +4241,77 @@ server <- function(input, output, session) {
|
|||
# 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**"))
|
||||
# )
|
||||
|
||||
shiny::observeEvent(
|
||||
# ignoreInit = TRUE,
|
||||
list(
|
||||
shiny::reactive(rv$list$data),
|
||||
shiny::reactive(rv$data),
|
||||
input$strat_var,
|
||||
input$include_vars,
|
||||
input$add_p
|
||||
),
|
||||
{
|
||||
input$load
|
||||
},
|
||||
{
|
||||
shiny::req(input$outcome_var)
|
||||
# browser()
|
||||
# Assumes all character variables can be formatted as factors
|
||||
# data <- data_filter$filtered() |>
|
||||
tryCatch(
|
||||
{
|
||||
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()
|
||||
shiny::req(input$strat_var)
|
||||
shiny::req(rv$list$data)
|
||||
|
||||
if (input$strat_var == "none") {
|
||||
by.var <- NULL
|
||||
|
|
@ -3812,42 +4319,8 @@ server <- function(input, output, session) {
|
|||
by.var <- input$strat_var
|
||||
}
|
||||
|
||||
data <- data[base_vars()]
|
||||
|
||||
# model <- data |>
|
||||
# regression_model(
|
||||
# outcome.str = input$outcome_var,
|
||||
# auto.mode = input$regression_auto == 1,
|
||||
# formula.str = input$regression_formula,
|
||||
# fun = input$regression_fun,
|
||||
# args.list = eval(parse(text = paste0("list(", input$regression_args, ")")))
|
||||
# )
|
||||
|
||||
models <- list(
|
||||
"Univariable" = regression_model_uv,
|
||||
"Multivariable" = regression_model
|
||||
) |>
|
||||
lapply(\(.fun){
|
||||
do.call(
|
||||
.fun,
|
||||
c(
|
||||
list(data = data),
|
||||
list(outcome.str = input$outcome_var),
|
||||
list(formula.str = input$regression_formula),
|
||||
list(fun = input$regression_fun),
|
||||
list(args.list = eval(parse(text = paste0("list(", input$regression_args, ")"))))
|
||||
)
|
||||
)
|
||||
})
|
||||
|
||||
rv$list$data <- data
|
||||
|
||||
|
||||
|
||||
rv$list$check <- purrr::pluck(models, "Multivariable") |>
|
||||
performance::check_model()
|
||||
|
||||
rv$list$table1 <- data |>
|
||||
rv$list$table1 <-
|
||||
rv$list$data |>
|
||||
baseline_table(
|
||||
fun.args =
|
||||
list(
|
||||
|
|
@ -3870,59 +4343,86 @@ server <- function(input, output, session) {
|
|||
.x
|
||||
}
|
||||
})()
|
||||
|
||||
rv$list$table2 <- models |>
|
||||
purrr::map(regression_table) |>
|
||||
tbl_merge()
|
||||
|
||||
|
||||
rv$list$input <- input
|
||||
|
||||
|
||||
# rv$list <- list(
|
||||
# data = data,
|
||||
# check = check,
|
||||
# table1 = 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
|
||||
# }
|
||||
# })(),
|
||||
# table2 = models |>
|
||||
# purrr::map(regression_table) |>
|
||||
# tbl_merge(),
|
||||
# input = input
|
||||
# )
|
||||
|
||||
output$table1 <- gt::render_gt(
|
||||
rv$list$table1 |>
|
||||
gtsummary::as_gt()
|
||||
}
|
||||
)
|
||||
|
||||
output$table2 <- gt::render_gt(
|
||||
rv$list$table2 |>
|
||||
gtsummary::as_gt()
|
||||
|
||||
output$table1 <- gt::render_gt({
|
||||
shiny::req(rv$list$table1)
|
||||
|
||||
rv$list$table1 |>
|
||||
gtsummary::as_gt() |>
|
||||
gt::tab_header(gt::md("**Table 1: Baseline Characteristics**"))
|
||||
})
|
||||
|
||||
shiny::observeEvent(
|
||||
input$load,
|
||||
{
|
||||
shiny::req(input$outcome_var)
|
||||
# browser()
|
||||
# Assumes all character variables can be formatted as factors
|
||||
# data <- data_filter$filtered() |>
|
||||
tryCatch(
|
||||
{
|
||||
model_lists <- list(
|
||||
"Univariable" = regression_model_uv_list,
|
||||
"Multivariable" = regression_model_list
|
||||
) |>
|
||||
lapply(\(.fun){
|
||||
ls <- do.call(
|
||||
.fun,
|
||||
c(
|
||||
list(data = rv$list$data),
|
||||
list(outcome.str = input$outcome_var),
|
||||
list(fun.descr = input$regression_type)
|
||||
)
|
||||
)
|
||||
})
|
||||
|
||||
rv$models <- model_lists
|
||||
|
||||
# rv$models <- lapply(model_lists, \(.x){
|
||||
# .x$model
|
||||
# })
|
||||
},
|
||||
warning = function(warn) {
|
||||
showNotification(paste0(warn), type = "warning")
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0("Creating regression models failed with the following error: ", err), type = "err")
|
||||
}
|
||||
)
|
||||
}
|
||||
)
|
||||
|
||||
shiny::observeEvent(
|
||||
ignoreInit = TRUE,
|
||||
list(
|
||||
rv$models
|
||||
),
|
||||
{
|
||||
shiny::req(rv$models)
|
||||
tryCatch(
|
||||
{
|
||||
rv$check <- lapply(rv$models, \(.x){
|
||||
.x$model
|
||||
}) |>
|
||||
purrr::pluck("Multivariable") |>
|
||||
performance::check_model()
|
||||
},
|
||||
warning = function(warn) {
|
||||
showNotification(paste0(warn), type = "warning")
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0("Running model assumptions checks failed with the following error: ", err), type = "err")
|
||||
}
|
||||
)
|
||||
}
|
||||
)
|
||||
|
||||
output$check <- shiny::renderPlot({
|
||||
p <- plot(rv$list$check) +
|
||||
shiny::req(rv$check)
|
||||
p <- plot(rv$check) +
|
||||
patchwork::plot_annotation(title = "Multivariable regression model checks")
|
||||
p
|
||||
# Generate checks in one column
|
||||
|
|
@ -3935,18 +4435,48 @@ server <- function(input, output, session) {
|
|||
# patchwork::wrap_plots(ncol=1) +
|
||||
# patchwork::plot_annotation(title = 'Multivariable regression model checks')
|
||||
})
|
||||
|
||||
|
||||
shiny::observeEvent(
|
||||
input$load,
|
||||
{
|
||||
shiny::req(rv$models)
|
||||
# browser()
|
||||
# Assumes all character variables can be formatted as factors
|
||||
# data <- data_filter$filtered() |>
|
||||
tryCatch(
|
||||
{
|
||||
tbl <- lapply(rv$models, \(.x){
|
||||
.x$model
|
||||
}) |>
|
||||
purrr::map(regression_table) |>
|
||||
tbl_merge()
|
||||
|
||||
rv$list$regression <- c(
|
||||
rv$models,
|
||||
list(Table = tbl)
|
||||
)
|
||||
|
||||
rv$list$input <- input
|
||||
},
|
||||
warning = function(warn) {
|
||||
showNotification(paste0(warn), type = "warning")
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0("There was the following error. Inspect your data and adjust settings. Error: ", err), type = "err")
|
||||
showNotification(paste0("Creating a regression table failed with the following error: ", err), type = "err")
|
||||
}
|
||||
)
|
||||
rv$ready <- "ready"
|
||||
}
|
||||
)
|
||||
|
||||
output$table2 <- gt::render_gt({
|
||||
shiny::req(rv$list$regression$Table)
|
||||
rv$list$regression$Table |>
|
||||
gtsummary::as_gt() |>
|
||||
gt::tab_header(gt::md(glue::glue("**Table 2: {rv$list$regression$Multivariable$options$descr}**")))
|
||||
})
|
||||
|
||||
|
||||
shiny::conditionalPanel(
|
||||
condition = "output.uploaded == 'yes'",
|
||||
|
|
@ -4019,6 +4549,7 @@ server <- function(input, output, session) {
|
|||
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
|
||||
shiny::withProgress(message = "Generating the report. Hold on for a moment..", {
|
||||
|
|
|
|||
|
|
@ -5,6 +5,6 @@ account: agdamsbo
|
|||
server: shinyapps.io
|
||||
hostUrl: https://api.shinyapps.io/v1
|
||||
appId: 13611288
|
||||
bundleId: 9656811
|
||||
bundleId: 9662237
|
||||
url: https://agdamsbo.shinyapps.io/freesearcheR/
|
||||
version: 1
|
||||
|
|
|
|||
|
|
@ -79,7 +79,9 @@ server <- function(input, output, session) {
|
|||
test = "no",
|
||||
data_original = NULL,
|
||||
data = NULL,
|
||||
data_filtered = NULL
|
||||
data_filtered = NULL,
|
||||
models = NULL,
|
||||
check = NULL
|
||||
)
|
||||
|
||||
##############################################################################
|
||||
|
|
@ -262,8 +264,20 @@ server <- function(input, output, session) {
|
|||
# IDEAFilter has the least cluttered UI, but might have a License issue
|
||||
data_filter <- IDEAFilter::IDEAFilter("data_filter", data = reactive(rv$data), verbose = TRUE)
|
||||
|
||||
shiny::observeEvent(data_filter(), {
|
||||
shiny::observeEvent(
|
||||
list(
|
||||
shiny::reactive(rv$data),
|
||||
shiny::reactive(rv$data_original),
|
||||
data_filter(),
|
||||
base_vars()
|
||||
), {
|
||||
rv$data_filtered <- data_filter()
|
||||
|
||||
rv$list$data <- data_filter() |>
|
||||
REDCapCAST::fct_drop.data.frame() |>
|
||||
(\(.x){
|
||||
.x[base_vars()]
|
||||
})()
|
||||
})
|
||||
|
||||
output$filtered_code <- shiny::renderPrint({
|
||||
|
|
@ -317,6 +331,16 @@ server <- function(input, output, session) {
|
|||
)
|
||||
})
|
||||
|
||||
output$regression_type <- shiny::renderUI({
|
||||
shiny::req(input$outcome_var)
|
||||
shiny::selectizeInput(
|
||||
inputId = "regression_type",
|
||||
# selected = colnames(rv$data_filtered)[sapply(rv$data_filtered, is.factor)],
|
||||
label = "Choose regression analysis",
|
||||
choices = possible_functions(data = dplyr::select(rv$data_filtered, input$outcome_var), design = "cross-sectional"),
|
||||
multiple = FALSE
|
||||
)
|
||||
})
|
||||
|
||||
output$factor_vars <- shiny::renderUI({
|
||||
shiny::selectizeInput(
|
||||
|
|
@ -379,22 +403,77 @@ server <- function(input, output, session) {
|
|||
# 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**"))
|
||||
# )
|
||||
|
||||
shiny::observeEvent(
|
||||
# ignoreInit = TRUE,
|
||||
list(
|
||||
shiny::reactive(rv$list$data),
|
||||
shiny::reactive(rv$data),
|
||||
input$strat_var,
|
||||
input$include_vars,
|
||||
input$add_p
|
||||
),
|
||||
{
|
||||
input$load
|
||||
},
|
||||
{
|
||||
shiny::req(input$outcome_var)
|
||||
# browser()
|
||||
# Assumes all character variables can be formatted as factors
|
||||
# data <- data_filter$filtered() |>
|
||||
tryCatch(
|
||||
{
|
||||
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()
|
||||
shiny::req(input$strat_var)
|
||||
shiny::req(rv$list$data)
|
||||
|
||||
if (input$strat_var == "none") {
|
||||
by.var <- NULL
|
||||
|
|
@ -402,42 +481,8 @@ server <- function(input, output, session) {
|
|||
by.var <- input$strat_var
|
||||
}
|
||||
|
||||
data <- data[base_vars()]
|
||||
|
||||
# model <- data |>
|
||||
# regression_model(
|
||||
# outcome.str = input$outcome_var,
|
||||
# auto.mode = input$regression_auto == 1,
|
||||
# formula.str = input$regression_formula,
|
||||
# fun = input$regression_fun,
|
||||
# args.list = eval(parse(text = paste0("list(", input$regression_args, ")")))
|
||||
# )
|
||||
|
||||
models <- list(
|
||||
"Univariable" = regression_model_uv,
|
||||
"Multivariable" = regression_model
|
||||
) |>
|
||||
lapply(\(.fun){
|
||||
do.call(
|
||||
.fun,
|
||||
c(
|
||||
list(data = data),
|
||||
list(outcome.str = input$outcome_var),
|
||||
list(formula.str = input$regression_formula),
|
||||
list(fun = input$regression_fun),
|
||||
list(args.list = eval(parse(text = paste0("list(", input$regression_args, ")"))))
|
||||
)
|
||||
)
|
||||
})
|
||||
|
||||
rv$list$data <- data
|
||||
|
||||
|
||||
|
||||
rv$list$check <- purrr::pluck(models, "Multivariable") |>
|
||||
performance::check_model()
|
||||
|
||||
rv$list$table1 <- data |>
|
||||
rv$list$table1 <-
|
||||
rv$list$data |>
|
||||
baseline_table(
|
||||
fun.args =
|
||||
list(
|
||||
|
|
@ -460,59 +505,86 @@ server <- function(input, output, session) {
|
|||
.x
|
||||
}
|
||||
})()
|
||||
|
||||
rv$list$table2 <- models |>
|
||||
purrr::map(regression_table) |>
|
||||
tbl_merge()
|
||||
|
||||
|
||||
rv$list$input <- input
|
||||
|
||||
|
||||
# rv$list <- list(
|
||||
# data = data,
|
||||
# check = check,
|
||||
# table1 = 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
|
||||
# }
|
||||
# })(),
|
||||
# table2 = models |>
|
||||
# purrr::map(regression_table) |>
|
||||
# tbl_merge(),
|
||||
# input = input
|
||||
# )
|
||||
|
||||
output$table1 <- gt::render_gt(
|
||||
rv$list$table1 |>
|
||||
gtsummary::as_gt()
|
||||
}
|
||||
)
|
||||
|
||||
output$table2 <- gt::render_gt(
|
||||
rv$list$table2 |>
|
||||
gtsummary::as_gt()
|
||||
|
||||
output$table1 <- gt::render_gt({
|
||||
shiny::req(rv$list$table1)
|
||||
|
||||
rv$list$table1 |>
|
||||
gtsummary::as_gt() |>
|
||||
gt::tab_header(gt::md("**Table 1: Baseline Characteristics**"))
|
||||
})
|
||||
|
||||
shiny::observeEvent(
|
||||
input$load,
|
||||
{
|
||||
shiny::req(input$outcome_var)
|
||||
# browser()
|
||||
# Assumes all character variables can be formatted as factors
|
||||
# data <- data_filter$filtered() |>
|
||||
tryCatch(
|
||||
{
|
||||
model_lists <- list(
|
||||
"Univariable" = regression_model_uv_list,
|
||||
"Multivariable" = regression_model_list
|
||||
) |>
|
||||
lapply(\(.fun){
|
||||
ls <- do.call(
|
||||
.fun,
|
||||
c(
|
||||
list(data = rv$list$data),
|
||||
list(outcome.str = input$outcome_var),
|
||||
list(fun.descr = input$regression_type)
|
||||
)
|
||||
)
|
||||
})
|
||||
|
||||
rv$models <- model_lists
|
||||
|
||||
# rv$models <- lapply(model_lists, \(.x){
|
||||
# .x$model
|
||||
# })
|
||||
},
|
||||
warning = function(warn) {
|
||||
showNotification(paste0(warn), type = "warning")
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0("Creating regression models failed with the following error: ", err), type = "err")
|
||||
}
|
||||
)
|
||||
}
|
||||
)
|
||||
|
||||
shiny::observeEvent(
|
||||
ignoreInit = TRUE,
|
||||
list(
|
||||
rv$models
|
||||
),
|
||||
{
|
||||
shiny::req(rv$models)
|
||||
tryCatch(
|
||||
{
|
||||
rv$check <- lapply(rv$models, \(.x){
|
||||
.x$model
|
||||
}) |>
|
||||
purrr::pluck("Multivariable") |>
|
||||
performance::check_model()
|
||||
},
|
||||
warning = function(warn) {
|
||||
showNotification(paste0(warn), type = "warning")
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0("Running model assumptions checks failed with the following error: ", err), type = "err")
|
||||
}
|
||||
)
|
||||
}
|
||||
)
|
||||
|
||||
output$check <- shiny::renderPlot({
|
||||
p <- plot(rv$list$check) +
|
||||
shiny::req(rv$check)
|
||||
p <- plot(rv$check) +
|
||||
patchwork::plot_annotation(title = "Multivariable regression model checks")
|
||||
p
|
||||
# Generate checks in one column
|
||||
|
|
@ -525,18 +597,48 @@ server <- function(input, output, session) {
|
|||
# patchwork::wrap_plots(ncol=1) +
|
||||
# patchwork::plot_annotation(title = 'Multivariable regression model checks')
|
||||
})
|
||||
|
||||
|
||||
shiny::observeEvent(
|
||||
input$load,
|
||||
{
|
||||
shiny::req(rv$models)
|
||||
# browser()
|
||||
# Assumes all character variables can be formatted as factors
|
||||
# data <- data_filter$filtered() |>
|
||||
tryCatch(
|
||||
{
|
||||
tbl <- lapply(rv$models, \(.x){
|
||||
.x$model
|
||||
}) |>
|
||||
purrr::map(regression_table) |>
|
||||
tbl_merge()
|
||||
|
||||
rv$list$regression <- c(
|
||||
rv$models,
|
||||
list(Table = tbl)
|
||||
)
|
||||
|
||||
rv$list$input <- input
|
||||
},
|
||||
warning = function(warn) {
|
||||
showNotification(paste0(warn), type = "warning")
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0("There was the following error. Inspect your data and adjust settings. Error: ", err), type = "err")
|
||||
showNotification(paste0("Creating a regression table failed with the following error: ", err), type = "err")
|
||||
}
|
||||
)
|
||||
rv$ready <- "ready"
|
||||
}
|
||||
)
|
||||
|
||||
output$table2 <- gt::render_gt({
|
||||
shiny::req(rv$list$regression$Table)
|
||||
rv$list$regression$Table |>
|
||||
gtsummary::as_gt() |>
|
||||
gt::tab_header(gt::md(glue::glue("**Table 2: {rv$list$regression$Multivariable$options$descr}**")))
|
||||
})
|
||||
|
||||
|
||||
shiny::conditionalPanel(
|
||||
condition = "output.uploaded == 'yes'",
|
||||
|
|
@ -609,6 +711,7 @@ server <- function(input, output, session) {
|
|||
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
|
||||
shiny::withProgress(message = "Generating the report. Hold on for a moment..", {
|
||||
|
|
|
|||
652
inst/apps/data_analysis_modules/server_bkp.R
Normal file
652
inst/apps/data_analysis_modules/server_bkp.R
Normal file
|
|
@ -0,0 +1,652 @@
|
|||
library(readr)
|
||||
library(MASS)
|
||||
library(stats)
|
||||
library(gtsummary)
|
||||
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(patchwork)
|
||||
library(DHARMa)
|
||||
library(apexcharter)
|
||||
library(toastui)
|
||||
library(datamods)
|
||||
library(data.table)
|
||||
library(IDEAFilter)
|
||||
library(shinyWidgets)
|
||||
library(DT)
|
||||
# library(freesearcheR)
|
||||
|
||||
# source("functions.R")
|
||||
|
||||
|
||||
|
||||
# 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(),
|
||||
ds = NULL,
|
||||
local_temp = NULL,
|
||||
ready = NULL,
|
||||
test = "no",
|
||||
data_original = NULL,
|
||||
data = NULL,
|
||||
data_filtered = NULL
|
||||
)
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Data import section
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
data_file <- datamods::import_file_server(
|
||||
id = "file_import",
|
||||
show_data_in = "popup",
|
||||
trigger_return = "change",
|
||||
return_class = "data.frame",
|
||||
read_fns = list(
|
||||
ods = function(file) {
|
||||
readODS::read_ods(path = file)
|
||||
},
|
||||
dta = function(file) {
|
||||
haven::read_dta(file = file)
|
||||
}
|
||||
)
|
||||
)
|
||||
|
||||
shiny::observeEvent(data_file$data(), {
|
||||
shiny::req(data_file$data())
|
||||
rv$data_original <- data_file$data()
|
||||
})
|
||||
|
||||
data_redcap <- m_redcap_readServer(
|
||||
id = "redcap_import",
|
||||
output.format = "list"
|
||||
)
|
||||
|
||||
shiny::observeEvent(data_redcap(), {
|
||||
rv$data_original <- purrr::pluck(data_redcap(), "data")()
|
||||
})
|
||||
|
||||
output$redcap_prev <- DT::renderDT(
|
||||
{
|
||||
DT::datatable(head(purrr::pluck(data_redcap(), "data")(), 5),
|
||||
caption = "First 5 observations"
|
||||
)
|
||||
},
|
||||
server = TRUE
|
||||
)
|
||||
|
||||
from_env <- import_globalenv_server(
|
||||
id = "env",
|
||||
trigger_return = "change",
|
||||
btn_show_data = FALSE,
|
||||
reset = reactive(input$hidden)
|
||||
)
|
||||
|
||||
shiny::observeEvent(from_env$data(), {
|
||||
shiny::req(from_env$data())
|
||||
rv$data_original <- from_env$data()
|
||||
})
|
||||
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Data modification section
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
shiny::observeEvent(rv$data_original, {
|
||||
rv$data <- rv$data_original |> default_parsing()
|
||||
})
|
||||
|
||||
shiny::observeEvent(input$data_reset, {
|
||||
shinyWidgets::ask_confirmation(
|
||||
inputId = "reset_confirm",
|
||||
title = "Please confirm data reset?"
|
||||
)
|
||||
})
|
||||
|
||||
shiny::observeEvent(input$reset_confirm, {
|
||||
rv$data <- rv$data_original |> default_parsing()
|
||||
})
|
||||
|
||||
######### Overview
|
||||
|
||||
data_summary_server(
|
||||
id = "data_summary",
|
||||
data = shiny::reactive({
|
||||
rv$data_filtered
|
||||
}),
|
||||
color.main = "#2A004E",
|
||||
color.sec = "#C62300"
|
||||
)
|
||||
|
||||
#########
|
||||
######### 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
|
||||
|
||||
######### Create factor
|
||||
|
||||
shiny::observeEvent(
|
||||
input$modal_cut,
|
||||
modal_cut_variable("modal_cut")
|
||||
)
|
||||
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())
|
||||
|
||||
######### Modify factor
|
||||
|
||||
shiny::observeEvent(
|
||||
input$modal_update,
|
||||
datamods::modal_update_factor(id = "modal_update")
|
||||
)
|
||||
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()
|
||||
})
|
||||
|
||||
######### Create column
|
||||
|
||||
shiny::observeEvent(
|
||||
input$modal_column,
|
||||
datamods::modal_create_column(id = "modal_column")
|
||||
)
|
||||
data_modal_r <- datamods::create_column_server(
|
||||
id = "modal_column",
|
||||
data_r = reactive(rv$data)
|
||||
)
|
||||
shiny::observeEvent(data_modal_r(), rv$data <- data_modal_r())
|
||||
|
||||
######### Show result
|
||||
|
||||
output$table_mod <- toastui::renderDatagrid({
|
||||
shiny::req(rv$data)
|
||||
# data <- rv$data
|
||||
toastui::datagrid(
|
||||
# data = rv$data # ,
|
||||
data = data_filter()
|
||||
# bordered = TRUE,
|
||||
# compact = TRUE,
|
||||
# striped = TRUE
|
||||
)
|
||||
})
|
||||
|
||||
output$code <- renderPrint({
|
||||
attr(rv$data, "code")
|
||||
})
|
||||
|
||||
# updated_data <- datamods::update_variables_server(
|
||||
updated_data <- update_variables_server(
|
||||
id = "vars_update",
|
||||
data = reactive(rv$data),
|
||||
return_data_on_init = FALSE
|
||||
)
|
||||
|
||||
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"
|
||||
))
|
||||
})
|
||||
|
||||
shiny::observeEvent(updated_data(), {
|
||||
rv$data <- updated_data()
|
||||
})
|
||||
|
||||
# IDEAFilter has the least cluttered UI, but might have a License issue
|
||||
data_filter <- IDEAFilter::IDEAFilter("data_filter", data = reactive(rv$data), verbose = TRUE)
|
||||
|
||||
shiny::observeEvent(data_filter(), {
|
||||
rv$data_filtered <- data_filter()
|
||||
})
|
||||
|
||||
output$filtered_code <- shiny::renderPrint({
|
||||
out <- gsub(
|
||||
"filter", "dplyr::filter",
|
||||
gsub(
|
||||
"\\s{2,}", " ",
|
||||
paste0(
|
||||
capture.output(attr(rv$data_filtered, "code")),
|
||||
collapse = " "
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
out <- strsplit(out, "%>%") |>
|
||||
unlist() |>
|
||||
(\(.x){
|
||||
paste(c("data", .x[-1]), collapse = "|> \n ")
|
||||
})()
|
||||
|
||||
cat(out)
|
||||
})
|
||||
|
||||
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Data analyses section
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
## Keep these "old" selection options as a simple alternative to the modification pane
|
||||
|
||||
output$include_vars <- shiny::renderUI({
|
||||
shiny::selectizeInput(
|
||||
inputId = "include_vars",
|
||||
selected = NULL,
|
||||
label = "Covariables to include",
|
||||
choices = colnames(rv$data_filtered),
|
||||
multiple = TRUE
|
||||
)
|
||||
})
|
||||
|
||||
output$outcome_var <- shiny::renderUI({
|
||||
shiny::selectInput(
|
||||
inputId = "outcome_var",
|
||||
selected = NULL,
|
||||
label = "Select outcome variable",
|
||||
choices = colnames(rv$data_filtered),
|
||||
multiple = FALSE
|
||||
)
|
||||
})
|
||||
|
||||
|
||||
output$factor_vars <- shiny::renderUI({
|
||||
shiny::selectizeInput(
|
||||
inputId = "factor_vars",
|
||||
selected = colnames(rv$data_filtered)[sapply(rv$data_filtered, is.factor)],
|
||||
label = "Covariables to format as categorical",
|
||||
choices = colnames(rv$data_filtered),
|
||||
multiple = TRUE
|
||||
)
|
||||
})
|
||||
|
||||
base_vars <- shiny::reactive({
|
||||
if (is.null(input$include_vars)) {
|
||||
out <- colnames(rv$data_filtered)
|
||||
} else {
|
||||
out <- unique(c(input$include_vars, input$outcome_var))
|
||||
}
|
||||
return(out)
|
||||
})
|
||||
|
||||
output$strat_var <- shiny::renderUI({
|
||||
shiny::selectInput(
|
||||
inputId = "strat_var",
|
||||
selected = "none",
|
||||
label = "Select variable to stratify baseline",
|
||||
choices = c(
|
||||
"none",
|
||||
rv$data_filtered[base_vars()] |>
|
||||
(\(.x){
|
||||
lapply(.x, \(.c){
|
||||
if (identical("factor", class(.c))) {
|
||||
.c
|
||||
}
|
||||
}) |>
|
||||
dplyr::bind_cols()
|
||||
})() |>
|
||||
colnames()
|
||||
),
|
||||
multiple = FALSE
|
||||
)
|
||||
})
|
||||
|
||||
## 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()
|
||||
# })
|
||||
|
||||
shiny::observeEvent(
|
||||
{
|
||||
input$load
|
||||
},
|
||||
{
|
||||
shiny::req(input$outcome_var)
|
||||
# browser()
|
||||
# Assumes all character variables can be formatted as factors
|
||||
# data <- data_filter$filtered() |>
|
||||
tryCatch(
|
||||
{
|
||||
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()
|
||||
|
||||
if (input$strat_var == "none") {
|
||||
by.var <- NULL
|
||||
} else {
|
||||
by.var <- input$strat_var
|
||||
}
|
||||
|
||||
data <- data[base_vars()]
|
||||
|
||||
# model <- data |>
|
||||
# regression_model(
|
||||
# outcome.str = input$outcome_var,
|
||||
# auto.mode = input$regression_auto == 1,
|
||||
# formula.str = input$regression_formula,
|
||||
# fun = input$regression_fun,
|
||||
# args.list = eval(parse(text = paste0("list(", input$regression_args, ")")))
|
||||
# )
|
||||
|
||||
models <- list(
|
||||
"Univariable" = regression_model_uv,
|
||||
"Multivariable" = regression_model
|
||||
) |>
|
||||
lapply(\(.fun){
|
||||
do.call(
|
||||
.fun,
|
||||
c(
|
||||
list(data = data),
|
||||
list(outcome.str = input$outcome_var),
|
||||
list(formula.str = input$regression_formula),
|
||||
list(fun = input$regression_fun),
|
||||
list(args.list = eval(parse(text = paste0("list(", input$regression_args, ")"))))
|
||||
)
|
||||
)
|
||||
})
|
||||
|
||||
rv$list$data <- data
|
||||
|
||||
|
||||
|
||||
rv$list$check <- purrr::pluck(models, "Multivariable") |>
|
||||
performance::check_model()
|
||||
|
||||
rv$list$table1 <- 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
|
||||
}
|
||||
})()
|
||||
|
||||
rv$list$table2 <- models |>
|
||||
purrr::map(regression_table) |>
|
||||
tbl_merge()
|
||||
|
||||
|
||||
rv$list$input <- input
|
||||
|
||||
|
||||
# rv$list <- list(
|
||||
# data = data,
|
||||
# check = check,
|
||||
# table1 = 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
|
||||
# }
|
||||
# })(),
|
||||
# table2 = models |>
|
||||
# purrr::map(regression_table) |>
|
||||
# tbl_merge(),
|
||||
# input = input
|
||||
# )
|
||||
|
||||
output$table1 <- gt::render_gt(
|
||||
rv$list$table1 |>
|
||||
gtsummary::as_gt()
|
||||
)
|
||||
|
||||
output$table2 <- gt::render_gt(
|
||||
rv$list$table2 |>
|
||||
gtsummary::as_gt()
|
||||
)
|
||||
|
||||
output$check <- shiny::renderPlot({
|
||||
p <- plot(rv$list$check) +
|
||||
patchwork::plot_annotation(title = "Multivariable regression model checks")
|
||||
p
|
||||
# Generate checks in one column
|
||||
# layout <- sapply(seq_len(length(p)), \(.x){
|
||||
# patchwork::area(.x, 1)
|
||||
# })
|
||||
#
|
||||
# p + patchwork::plot_layout(design = Reduce(c, layout))
|
||||
|
||||
# patchwork::wrap_plots(ncol=1) +
|
||||
# patchwork::plot_annotation(title = 'Multivariable regression model checks')
|
||||
})
|
||||
},
|
||||
warning = function(warn) {
|
||||
showNotification(paste0(warn), type = "warning")
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0("There was the following error. Inspect your data and adjust settings. Error: ", err), type = "err")
|
||||
}
|
||||
)
|
||||
rv$ready <- "ready"
|
||||
}
|
||||
)
|
||||
|
||||
|
||||
shiny::conditionalPanel(
|
||||
condition = "output.uploaded == 'yes'",
|
||||
)
|
||||
|
||||
# observeEvent(input$act_start, {
|
||||
# nav_show(id = "overview",target = "Import"
|
||||
# )
|
||||
# })
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### 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)
|
||||
|
||||
# Reimplement from environment at later time
|
||||
# output$has_input <- shiny::reactive({
|
||||
# if (rv$input) {
|
||||
# "yes"
|
||||
# } else {
|
||||
# "no"
|
||||
# }
|
||||
# })
|
||||
|
||||
# shiny::outputOptions(output, "has_input", 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) {
|
||||
## Notification is not progressing
|
||||
## Presumably due to missing
|
||||
shiny::withProgress(message = "Generating the report. Hold on for a moment..", {
|
||||
rv$list |>
|
||||
write_quarto(
|
||||
output_format = type,
|
||||
input = file.path(getwd(), "www/report.qmd")
|
||||
)
|
||||
})
|
||||
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 {
|
||||
haven::write_dta(as.data.frame(rv$list$data), path = 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"))
|
||||
})
|
||||
})
|
||||
}
|
||||
|
|
@ -272,13 +272,12 @@ ui_elements <- list(
|
|||
bslib::nav_panel(
|
||||
# value = "analyze",
|
||||
title = "Analyses",
|
||||
id = "navanalyses",
|
||||
bslib::navset_bar(
|
||||
title = "",
|
||||
# bslib::layout_sidebar(
|
||||
# fillable = TRUE,
|
||||
sidebar = bslib::sidebar(
|
||||
shiny::helpText(em("Please specify relevant settings for your data, and press 'Analyse'")),
|
||||
shiny::uiOutput("outcome_var"),
|
||||
shiny::radioButtons(
|
||||
inputId = "all",
|
||||
label = "Specify covariables",
|
||||
|
|
@ -293,6 +292,13 @@ ui_elements <- list(
|
|||
condition = "input.all==1",
|
||||
shiny::uiOutput("include_vars")
|
||||
),
|
||||
bslib::accordion(
|
||||
open = "acc_chars",
|
||||
multiple = FALSE,
|
||||
bslib::accordion_panel(
|
||||
value = "acc_chars",
|
||||
title = "Characteristics",
|
||||
icon = bsicons::bs_icon("table"),
|
||||
shiny::uiOutput("strat_var"),
|
||||
shiny::helpText("Only factor/categorical variables are available for stratification. Go back to the 'Data' tab to reclass a variable if it's not on the list."),
|
||||
shiny::conditionalPanel(
|
||||
|
|
@ -308,25 +314,28 @@ ui_elements <- list(
|
|||
)
|
||||
),
|
||||
shiny::helpText("Option to perform statistical comparisons between strata in baseline table.")
|
||||
),
|
||||
shiny::radioButtons(
|
||||
inputId = "specify_factors",
|
||||
label = "Specify categorical variables?",
|
||||
selected = "no",
|
||||
inline = TRUE,
|
||||
choices = list(
|
||||
"Yes" = "yes",
|
||||
"No" = "no"
|
||||
)
|
||||
),
|
||||
shiny::conditionalPanel(
|
||||
condition = "input.specify_factors=='yes'",
|
||||
shiny::uiOutput("factor_vars")
|
||||
),
|
||||
bslib::accordion_panel(
|
||||
value = "acc_reg",
|
||||
title = "Regression",
|
||||
icon = bsicons::bs_icon("calculator"),
|
||||
shiny::uiOutput("outcome_var"),
|
||||
# shiny::selectInput(
|
||||
# inputId = "design",
|
||||
# label = "Study design",
|
||||
# selected = "no",
|
||||
# inline = TRUE,
|
||||
# choices = list(
|
||||
# "Cross-sectional" = "cross-sectional"
|
||||
# )
|
||||
# ),
|
||||
shiny::uiOutput("regression_type"),
|
||||
bslib::input_task_button(
|
||||
id = "load",
|
||||
label = "Analyse",
|
||||
icon = shiny::icon("pencil", lib = "glyphicon"),
|
||||
# icon = shiny::icon("pencil", lib = "glyphicon"),
|
||||
icon = bsicons::bs_icon("pencil"),
|
||||
label_busy = "Working...",
|
||||
icon_busy = fontawesome::fa_i("arrows-rotate",
|
||||
class = "fa-spin",
|
||||
|
|
@ -335,11 +344,13 @@ ui_elements <- list(
|
|||
type = "secondary",
|
||||
auto_reset = TRUE
|
||||
),
|
||||
shiny::helpText("If you change the parameters, press 'Analyse' again to update the tables"),
|
||||
# shiny::conditionalPanel(
|
||||
# condition = "output.ready=='yes'",
|
||||
shiny::tags$hr(),
|
||||
shiny::h4("Download results"),
|
||||
shiny::helpText("If you change the parameters, press 'Analyse' again to update the tables")
|
||||
),
|
||||
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",
|
||||
|
|
@ -362,7 +373,7 @@ ui_elements <- list(
|
|||
),
|
||||
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("Download data"),
|
||||
shiny::h4("Data"),
|
||||
shiny::helpText("Choose your favourite output data format to download the modified data."),
|
||||
shiny::selectInput(
|
||||
inputId = "data_type",
|
||||
|
|
@ -380,6 +391,26 @@ ui_elements <- list(
|
|||
label = "Download data",
|
||||
icon = shiny::icon("download")
|
||||
)
|
||||
)
|
||||
),
|
||||
# shiny::helpText(em("Please specify relevant settings for your data, and press 'Analyse'")),
|
||||
# shiny::radioButtons(
|
||||
# inputId = "specify_factors",
|
||||
# label = "Specify categorical variables?",
|
||||
# selected = "no",
|
||||
# inline = TRUE,
|
||||
# choices = list(
|
||||
# "Yes" = "yes",
|
||||
# "No" = "no"
|
||||
# )
|
||||
# ),
|
||||
# shiny::conditionalPanel(
|
||||
# condition = "input.specify_factors=='yes'",
|
||||
# shiny::uiOutput("factor_vars")
|
||||
# ),
|
||||
# shiny::conditionalPanel(
|
||||
# condition = "output.ready=='yes'",
|
||||
# shiny::tags$hr(),
|
||||
),
|
||||
bslib::nav_panel(
|
||||
title = "Baseline characteristics",
|
||||
|
|
|
|||
468
inst/apps/data_analysis_modules/ui_bkp.R
Normal file
468
inst/apps/data_analysis_modules/ui_bkp.R
Normal file
|
|
@ -0,0 +1,468 @@
|
|||
# ns <- NS(id)
|
||||
|
||||
ui_elements <- list(
|
||||
##############################################################################
|
||||
#########
|
||||
######### Home panel
|
||||
#########
|
||||
##############################################################################
|
||||
"home" = bslib::nav_panel(
|
||||
title = "freesearcheR",
|
||||
shiny::markdown(readLines("www/intro.md")),
|
||||
icon = shiny::icon("home")
|
||||
),
|
||||
##############################################################################
|
||||
#########
|
||||
######### Import panel
|
||||
#########
|
||||
##############################################################################
|
||||
"import" = bslib::nav_panel(
|
||||
title = "Import",
|
||||
shiny::tagList(
|
||||
shiny::h4("Choose your data source"),
|
||||
# shiny::conditionalPanel(
|
||||
# condition = "output.has_input=='yes'",
|
||||
# # Input: Select a file ----
|
||||
# shiny::helpText("Analyses are performed on provided data")
|
||||
# ),
|
||||
# shiny::conditionalPanel(
|
||||
# condition = "output.has_input=='no'",
|
||||
# Input: Select a file ----
|
||||
shinyWidgets::radioGroupButtons(
|
||||
inputId = "source",
|
||||
selected = "env",
|
||||
# label = "Choice: ",
|
||||
choices = c(
|
||||
"File upload" = "file",
|
||||
"REDCap server" = "redcap",
|
||||
"Local data" = "env"
|
||||
),
|
||||
# checkIcon = list(
|
||||
# yes = icon("square-check"),
|
||||
# no = icon("square")
|
||||
# ),
|
||||
width = "100%"
|
||||
),
|
||||
shiny::conditionalPanel(
|
||||
condition = "input.source=='file'",
|
||||
datamods::import_file_ui("file_import",
|
||||
title = "Choose a datafile to upload",
|
||||
file_extensions = c(".csv", ".txt", ".xls", ".xlsx", ".rds", ".fst", ".sas7bdat", ".sav", ".ods", ".dta")
|
||||
)
|
||||
),
|
||||
shiny::conditionalPanel(
|
||||
condition = "input.source=='redcap'",
|
||||
m_redcap_readUI("redcap_import")
|
||||
),
|
||||
shiny::conditionalPanel(
|
||||
condition = "input.source=='env'",
|
||||
import_globalenv_ui(id = "env", title = NULL)
|
||||
),
|
||||
shiny::conditionalPanel(
|
||||
condition = "input.source=='redcap'",
|
||||
DT::DTOutput(outputId = "redcap_prev")
|
||||
),
|
||||
shiny::br(),
|
||||
shiny::actionButton(
|
||||
inputId = "act_start",
|
||||
label = "Start",
|
||||
width = "100%",
|
||||
icon = shiny::icon("play")
|
||||
),
|
||||
shiny::helpText('After importing, hit "Start" or navigate to the desired tab.'),
|
||||
shiny::br(),
|
||||
shiny::br()
|
||||
)
|
||||
),
|
||||
##############################################################################
|
||||
#########
|
||||
######### Data overview panel
|
||||
#########
|
||||
##############################################################################
|
||||
"overview" =
|
||||
# bslib::nav_panel_hidden(
|
||||
bslib::nav_panel(
|
||||
# value = "overview",
|
||||
title = "Data",
|
||||
bslib::navset_bar(
|
||||
fillable = TRUE,
|
||||
bslib::nav_panel(
|
||||
title = "Summary & filter",
|
||||
tags$h3("Data summary and filtering"),
|
||||
fluidRow(
|
||||
shiny::column(
|
||||
width = 9,
|
||||
shiny::tags$p(
|
||||
"Below is a short summary table of the provided data.
|
||||
On the right hand side you have the option to create filters.
|
||||
At the bottom you'll find a raw overview of the original vs the modified data."
|
||||
)
|
||||
)
|
||||
),
|
||||
fluidRow(
|
||||
# column(
|
||||
# width = 3,
|
||||
# shiny::uiOutput("filter_vars"),
|
||||
# shiny::conditionalPanel(
|
||||
# condition = "(typeof input.filter_vars !== 'undefined' && input.filter_vars.length > 0)",
|
||||
# datamods::filter_data_ui("filtering", max_height = "500px")
|
||||
# )
|
||||
# ),
|
||||
# column(
|
||||
# width = 9,
|
||||
# DT::DTOutput(outputId = "filtered_table"),
|
||||
# tags$b("Code dplyr:"),
|
||||
# verbatimTextOutput(outputId = "filtered_code")
|
||||
# ),
|
||||
shiny::column(
|
||||
width = 9,
|
||||
data_summary_ui(id = "data_summary")
|
||||
),
|
||||
shiny::column(
|
||||
width = 3,
|
||||
IDEAFilter::IDEAFilter_ui("data_filter"),
|
||||
shiny::tags$br(),
|
||||
shiny::tags$b("Filter code:"),
|
||||
shiny::verbatimTextOutput(outputId = "filtered_code"),
|
||||
shiny::tags$br()
|
||||
)
|
||||
),
|
||||
fluidRow(
|
||||
column(
|
||||
width = 6,
|
||||
tags$b("Original data:"),
|
||||
# verbatimTextOutput("original"),
|
||||
verbatimTextOutput("original_str")
|
||||
),
|
||||
column(
|
||||
width = 6,
|
||||
tags$b("Modified data:"),
|
||||
# verbatimTextOutput("modified"),
|
||||
verbatimTextOutput("modified_str")
|
||||
)
|
||||
)
|
||||
),
|
||||
# bslib::nav_panel(
|
||||
# title = "Overview",
|
||||
# DT::DTOutput(outputId = "table")
|
||||
# ),
|
||||
bslib::nav_panel(
|
||||
title = "Modify",
|
||||
tags$h3("Subset, rename and convert variables"),
|
||||
fluidRow(
|
||||
shiny::column(
|
||||
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.
|
||||
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.")
|
||||
)
|
||||
),
|
||||
fluidRow(
|
||||
shiny::column(
|
||||
width = 9,
|
||||
update_variables_ui("vars_update"),
|
||||
shiny::tags$br()
|
||||
),
|
||||
shiny::column(
|
||||
width = 3,
|
||||
tags$h4("Create new variables"),
|
||||
shiny::tags$br(),
|
||||
shiny::actionButton(
|
||||
inputId = "modal_cut",
|
||||
label = "Create factor variable",
|
||||
width = "100%"
|
||||
),
|
||||
shiny::tags$br(),
|
||||
shiny::helpText("Create factor/categorical variable from an other value."),
|
||||
shiny::tags$br(),
|
||||
shiny::tags$br(),
|
||||
shiny::actionButton(
|
||||
inputId = "modal_update",
|
||||
label = "Reorder factor levels",
|
||||
width = "100%"
|
||||
),
|
||||
shiny::tags$br(),
|
||||
shiny::helpText("Reorder the levels of factor/categorical variables."),
|
||||
shiny::tags$br(),
|
||||
shiny::tags$br(),
|
||||
shiny::actionButton(
|
||||
inputId = "modal_column",
|
||||
label = "New variable",
|
||||
width = "100%"
|
||||
),
|
||||
shiny::tags$br(),
|
||||
shiny::helpText("Create a new variable/column based on an R-expression."),
|
||||
shiny::tags$br(),
|
||||
shiny::tags$br(),
|
||||
tags$h4("Restore"),
|
||||
shiny::actionButton(
|
||||
inputId = "data_reset",
|
||||
label = "Restore original data",
|
||||
width = "100%"
|
||||
),
|
||||
shiny::tags$br(),
|
||||
shiny::helpText("Reset to original imported dataset. Careful! There is no un-doing."),
|
||||
shiny::tags$br() # ,
|
||||
# shiny::tags$br(),
|
||||
# shiny::tags$br(),
|
||||
# IDEAFilter::IDEAFilter_ui("data_filter") # ,
|
||||
# shiny::actionButton("save_filter", "Apply the filter")
|
||||
)
|
||||
# datamods::update_variables_ui("vars_update")
|
||||
)
|
||||
),
|
||||
bslib::nav_panel(
|
||||
title = "Browser",
|
||||
tags$h3("Browse the provided data"),
|
||||
shiny::tags$p(
|
||||
"Below is a data table with all the modified data provided to browse and understand data."
|
||||
),
|
||||
shinyWidgets::html_dependency_winbox(),
|
||||
# fluidRow(
|
||||
# column(
|
||||
# width = 3,
|
||||
# shiny::uiOutput("filter_vars"),
|
||||
# shiny::conditionalPanel(
|
||||
# condition = "(typeof input.filter_vars !== 'undefined' && input.filter_vars.length > 0)",
|
||||
# datamods::filter_data_ui("filtering", max_height = "500px")
|
||||
# )
|
||||
# ),
|
||||
# column(
|
||||
# width = 9,
|
||||
# DT::DTOutput(outputId = "filtered_table"),
|
||||
# tags$b("Code dplyr:"),
|
||||
# verbatimTextOutput(outputId = "filtered_code")
|
||||
# ),
|
||||
# shiny::column(
|
||||
# width = 8,
|
||||
toastui::datagridOutput(outputId = "table_mod") # ,
|
||||
# shiny::tags$b("Reproducible code:"),
|
||||
# shiny::verbatimTextOutput(outputId = "filtered_code")
|
||||
# ),
|
||||
# shiny::column(
|
||||
# width = 4,
|
||||
# shiny::actionButton("modal_cut", "Create factor from a variable"),
|
||||
# shiny::tags$br(),
|
||||
# shiny::tags$br(),
|
||||
# shiny::actionButton("modal_update", "Reorder factor levels")#,
|
||||
# # shiny::tags$br(),
|
||||
# # shiny::tags$br(),
|
||||
# # IDEAFilter::IDEAFilter_ui("data_filter") # ,
|
||||
# # shiny::actionButton("save_filter", "Apply the filter")
|
||||
# )
|
||||
# )
|
||||
)
|
||||
|
||||
|
||||
# column(
|
||||
# 8,
|
||||
# shiny::verbatimTextOutput("filtered_code"),
|
||||
# DT::DTOutput("filtered_table")
|
||||
# ),
|
||||
# column(4, IDEAFilter::IDEAFilter_ui("data_filter"))
|
||||
)
|
||||
),
|
||||
##############################################################################
|
||||
#########
|
||||
######### Data analyses panel
|
||||
#########
|
||||
##############################################################################
|
||||
"analyze" =
|
||||
# bslib::nav_panel_hidden(
|
||||
bslib::nav_panel(
|
||||
# value = "analyze",
|
||||
title = "Analyses",
|
||||
bslib::navset_bar(
|
||||
title = "",
|
||||
# bslib::layout_sidebar(
|
||||
# fillable = TRUE,
|
||||
sidebar = bslib::sidebar(
|
||||
shiny::helpText(em("Please specify relevant settings for your data, and press 'Analyse'")),
|
||||
shiny::uiOutput("outcome_var"),
|
||||
shiny::radioButtons(
|
||||
inputId = "all",
|
||||
label = "Specify covariables",
|
||||
inline = TRUE, selected = 2,
|
||||
choiceNames = c(
|
||||
"Yes",
|
||||
"No"
|
||||
),
|
||||
choiceValues = c(1, 2)
|
||||
),
|
||||
shiny::conditionalPanel(
|
||||
condition = "input.all==1",
|
||||
shiny::uiOutput("include_vars")
|
||||
),
|
||||
shiny::uiOutput("strat_var"),
|
||||
shiny::helpText("Only factor/categorical variables are available for stratification. Go back to the 'Data' tab to reclass a variable if it's not on the list."),
|
||||
shiny::conditionalPanel(
|
||||
condition = "input.strat_var!='none'",
|
||||
shiny::radioButtons(
|
||||
inputId = "add_p",
|
||||
label = "Compare strata?",
|
||||
selected = "no",
|
||||
inline = TRUE,
|
||||
choices = list(
|
||||
"No" = "no",
|
||||
"Yes" = "yes"
|
||||
)
|
||||
),
|
||||
shiny::helpText("Option to perform statistical comparisons between strata in baseline table.")
|
||||
),
|
||||
shiny::radioButtons(
|
||||
inputId = "specify_factors",
|
||||
label = "Specify categorical variables?",
|
||||
selected = "no",
|
||||
inline = TRUE,
|
||||
choices = list(
|
||||
"Yes" = "yes",
|
||||
"No" = "no"
|
||||
)
|
||||
),
|
||||
shiny::conditionalPanel(
|
||||
condition = "input.specify_factors=='yes'",
|
||||
shiny::uiOutput("factor_vars")
|
||||
),
|
||||
bslib::input_task_button(
|
||||
id = "load",
|
||||
label = "Analyse",
|
||||
icon = shiny::icon("pencil", lib = "glyphicon"),
|
||||
label_busy = "Working...",
|
||||
icon_busy = fontawesome::fa_i("arrows-rotate",
|
||||
class = "fa-spin",
|
||||
"aria-hidden" = "true"
|
||||
),
|
||||
type = "secondary",
|
||||
auto_reset = TRUE
|
||||
),
|
||||
shiny::helpText("If you change the parameters, press 'Analyse' again to update the tables"),
|
||||
# shiny::conditionalPanel(
|
||||
# condition = "output.ready=='yes'",
|
||||
shiny::tags$hr(),
|
||||
shiny::h4("Download results"),
|
||||
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("Download 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")
|
||||
)
|
||||
),
|
||||
bslib::nav_panel(
|
||||
title = "Baseline characteristics",
|
||||
gt::gt_output(outputId = "table1")
|
||||
),
|
||||
bslib::nav_panel(
|
||||
title = "Regression table",
|
||||
gt::gt_output(outputId = "table2")
|
||||
),
|
||||
bslib::nav_panel(
|
||||
title = "Regression checks",
|
||||
shiny::plotOutput(outputId = "check")
|
||||
)
|
||||
)
|
||||
),
|
||||
##############################################################################
|
||||
#########
|
||||
######### Documentation panel
|
||||
#########
|
||||
##############################################################################
|
||||
"docs" = bslib::nav_item(
|
||||
# shiny::img(shiny::icon("book")),
|
||||
shiny::tags$a(
|
||||
href = "https://agdamsbo.github.io/freesearcheR/",
|
||||
"Docs (external)",
|
||||
target = "_blank",
|
||||
rel = "noopener noreferrer"
|
||||
)
|
||||
)
|
||||
# bslib::nav_panel(
|
||||
# title = "Documentation",
|
||||
# # shiny::tags$iframe("www/docs.html", height=600, width=535),
|
||||
# shiny::htmlOutput("docs_file"),
|
||||
# shiny::br()
|
||||
# )
|
||||
)
|
||||
|
||||
# Initial attempt at creating light and dark versions
|
||||
light <- custom_theme()
|
||||
dark <- custom_theme(
|
||||
bg = "#000",
|
||||
fg = "#fff"
|
||||
)
|
||||
|
||||
# Fonts to consider:
|
||||
# https://webdesignerdepot.com/17-open-source-fonts-youll-actually-love/
|
||||
|
||||
ui <- bslib::page_fixed(
|
||||
shiny::tags$head(includeHTML(("www/umami-app.html"))),
|
||||
shiny::tags$style(
|
||||
type = "text/css",
|
||||
# add the name of the tab you want to use as title in data-value
|
||||
shiny::HTML(
|
||||
".container-fluid > .nav > li >
|
||||
a[data-value='freesearcheR'] {font-size: 28px}"
|
||||
)
|
||||
),
|
||||
title = "freesearcheR",
|
||||
theme = light,
|
||||
shiny::useBusyIndicators(),
|
||||
bslib::page_navbar(
|
||||
# title = "freesearcheR",
|
||||
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$import,
|
||||
ui_elements$overview,
|
||||
ui_elements$analyze,
|
||||
bslib::nav_spacer(),
|
||||
ui_elements$docs,
|
||||
# bslib::nav_spacer(),
|
||||
# bslib::nav_item(shinyWidgets::circleButton(inputId = "mode", icon = icon("moon"),status = "primary")),
|
||||
fillable = FALSE,
|
||||
footer = shiny::tags$footer(
|
||||
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 immediately afterwards."
|
||||
),
|
||||
shiny::p(
|
||||
style = "margin: 1; color: #888;",
|
||||
"Andreas G Damsbo | AGPLv3 license | ", shiny::tags$a("Source on Github", href = "https://github.com/agdamsbo/freesearcheR/", target = "_blank", rel = "noopener noreferrer")
|
||||
),
|
||||
)
|
||||
)
|
||||
)
|
||||
|
|
@ -17,8 +17,6 @@ web_data <- readr::read_rds(file = params$data.file)
|
|||
library(gtsummary)
|
||||
library(gt)
|
||||
library(flextable)
|
||||
library(easystats)
|
||||
library(patchwork)
|
||||
# library(webResearch)
|
||||
```
|
||||
|
||||
|
|
@ -42,33 +40,16 @@ web_data$table1 |>
|
|||
flextable::set_table_properties(width = 1, layout = "autofit")
|
||||
```
|
||||
|
||||
Here are the regression results.
|
||||
Here are the results from the `r web_data$regression$Multivariable$options$descr`.
|
||||
|
||||
```{r}
|
||||
#| label: tbl-regression
|
||||
#| tbl-cap: Regression analysis results
|
||||
web_data$table2|>
|
||||
web_data$regression$Table|>
|
||||
gtsummary::as_flex_table() |>
|
||||
flextable::set_table_properties(width = 1, layout = "autofit")
|
||||
```
|
||||
|
||||
|
||||
## Discussion
|
||||
|
||||
Good luck on your further work!
|
||||
|
||||
## Sensitivity
|
||||
|
||||
Here are the results from testing the regression model:
|
||||
|
||||
|
||||
```{r}
|
||||
#| label: tbl-checks
|
||||
#| fig-cap: Regression analysis checks
|
||||
#| fig-height: 8
|
||||
#| fig-width: 6
|
||||
#| fig-dpi: 600
|
||||
|
||||
plot(web_data$check)
|
||||
|
||||
```
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue