mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2026-06-19 04:27:30 +02:00
version bump - regression - data overview
This commit is contained in:
parent
f73af16ae1
commit
f249aaa9ab
29 changed files with 2888 additions and 1239 deletions
|
|
@ -1 +1 @@
|
|||
app_version <- function()'250331_1248'
|
||||
app_version <- function()'250402_1126'
|
||||
|
|
|
|||
|
|
@ -34,21 +34,25 @@ baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary,
|
|||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> create_baseline(by.var = "gear", add.p="yes"=="yes")
|
||||
create_baseline <- function(data,...,by.var,add.p=FALSE,add.overall=FALSE){
|
||||
#' mtcars |> create_baseline(by.var = "gear", add.p = "yes" == "yes")
|
||||
create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALSE, theme=c("jama", "lancet", "nejm", "qjecon")) {
|
||||
theme <- match.arg(theme)
|
||||
|
||||
if (by.var == "none" | !by.var %in% names(data)) {
|
||||
by.var <- NULL
|
||||
}
|
||||
|
||||
## These steps are to handle logicals/booleans, that messes up the order of columns
|
||||
## Has been reported
|
||||
## Has been reported and should be fixed soon (02042025)
|
||||
|
||||
if (!is.null(by.var)) {
|
||||
if (identical("logical",class(data[[by.var]]))){
|
||||
if (identical("logical", class(data[[by.var]]))) {
|
||||
data[by.var] <- as.character(data[[by.var]])
|
||||
}
|
||||
}
|
||||
|
||||
gtsummary::theme_gtsummary_journal(journal = theme)
|
||||
|
||||
out <- data |>
|
||||
baseline_table(
|
||||
fun.args =
|
||||
|
|
@ -59,16 +63,15 @@ create_baseline <- function(data,...,by.var,add.p=FALSE,add.overall=FALSE){
|
|||
)
|
||||
|
||||
if (!is.null(by.var)) {
|
||||
if (isTRUE(add.overall)){
|
||||
out <- out |> gtsummary::add_overall()
|
||||
if (isTRUE(add.overall)) {
|
||||
out <- out |> gtsummary::add_overall()
|
||||
}
|
||||
if (isTRUE(add.p)) {
|
||||
out <- out |>
|
||||
gtsummary::add_p() |>
|
||||
gtsummary::bold_p()
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
out
|
||||
}
|
||||
|
|
|
|||
|
|
@ -133,31 +133,5 @@ sentence_paste <- function(data, and.str = "and") {
|
|||
}
|
||||
|
||||
|
||||
#' Correlations plot demo app
|
||||
#'
|
||||
#' @returns
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' \dontrun{
|
||||
#' cor_demo_app()
|
||||
#' }
|
||||
cor_demo_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(default_parsing(mtcars)), cutoff = shiny::reactive(input$cor_cutoff))
|
||||
}
|
||||
shiny::shinyApp(ui, server)
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -350,7 +350,7 @@ data_description <- function(data) {
|
|||
#' @param na.rm remove NAs
|
||||
#' @param ... passed to base_sort_by
|
||||
#'
|
||||
#' @returns
|
||||
#' @returns vector
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
|
|
@ -363,3 +363,9 @@ sort_by <- function(x,y,na.rm=FALSE,...){
|
|||
out
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
get_ggplot_label <- function(data,label){
|
||||
assertthat::assert_that(ggplot2::is.ggplot(data))
|
||||
data$labels[[label]]
|
||||
}
|
||||
|
|
|
|||
|
|
@ -461,8 +461,7 @@ import_dta <- function(file) {
|
|||
#'
|
||||
import_rds <- function(file) {
|
||||
readr::read_rds(
|
||||
file = file,
|
||||
name_repair = "unique_quiet"
|
||||
file = file
|
||||
)
|
||||
}
|
||||
|
||||
|
|
|
|||
75
R/plot-download-module.R
Normal file
75
R/plot-download-module.R
Normal file
|
|
@ -0,0 +1,75 @@
|
|||
plot_download_ui <- regression_ui <- function(id, ...) {
|
||||
ns <- shiny::NS(id)
|
||||
|
||||
shiny::tagList(
|
||||
shinyWidgets::noUiSliderInput(
|
||||
inputId = ns("plot_height"),
|
||||
label = "Plot height (mm)",
|
||||
min = 50,
|
||||
max = 300,
|
||||
value = 100,
|
||||
step = 1,
|
||||
format = shinyWidgets::wNumbFormat(decimals = 0),
|
||||
color = datamods:::get_primary_color()
|
||||
),
|
||||
shinyWidgets::noUiSliderInput(
|
||||
inputId = ns("plot_width"),
|
||||
label = "Plot width (mm)",
|
||||
min = 50,
|
||||
max = 300,
|
||||
value = 100,
|
||||
step = 1,
|
||||
format = shinyWidgets::wNumbFormat(decimals = 0),
|
||||
color = datamods:::get_primary_color()
|
||||
),
|
||||
shiny::selectInput(
|
||||
inputId = ns("plot_type"),
|
||||
label = "File format",
|
||||
choices = list(
|
||||
"png",
|
||||
"tiff",
|
||||
"eps",
|
||||
"pdf",
|
||||
"jpeg",
|
||||
"svg"
|
||||
)
|
||||
),
|
||||
shiny::br(),
|
||||
# Button
|
||||
shiny::downloadButton(
|
||||
outputId = ns("download_plot"),
|
||||
label = "Download plot",
|
||||
icon = shiny::icon("download")
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
plot_download_server <- function(id,
|
||||
data,
|
||||
file_name = "reg_plot",
|
||||
...) {
|
||||
shiny::moduleServer(
|
||||
id = id,
|
||||
module = function(input, output, session) {
|
||||
# ns <- session$ns
|
||||
|
||||
|
||||
|
||||
output$download_plot <- shiny::downloadHandler(
|
||||
filename = paste0(file_name, ".", input$plot_type),
|
||||
content = function(file) {
|
||||
shiny::withProgress(message = "Saving the plot. Hold on for a moment..", {
|
||||
ggplot2::ggsave(
|
||||
filename = file,
|
||||
plot = data,
|
||||
width = input$plot_width,
|
||||
height = input$plot_height,
|
||||
dpi = 300,
|
||||
units = "mm", scale = 2
|
||||
)
|
||||
})
|
||||
}
|
||||
)
|
||||
}
|
||||
)
|
||||
}
|
||||
568
R/regression-module.R
Normal file
568
R/regression-module.R
Normal file
|
|
@ -0,0 +1,568 @@
|
|||
regression_ui <- function(id, ...) {
|
||||
ns <- shiny::NS(id)
|
||||
|
||||
shiny::tagList(
|
||||
title = "",
|
||||
sidebar = bslib::sidebar(
|
||||
shiny::uiOutput(outputId = ns("data_info"), inline = TRUE),
|
||||
bslib::accordion(
|
||||
open = "acc_reg",
|
||||
multiple = FALSE,
|
||||
bslib::accordion_panel(
|
||||
value = "acc_reg",
|
||||
title = "Regression",
|
||||
icon = bsicons::bs_icon("calculator"),
|
||||
shiny::uiOutput(outputId = ns("outcome_var")),
|
||||
# shiny::selectInput(
|
||||
# inputId = "design",
|
||||
# label = "Study design",
|
||||
# selected = "no",
|
||||
# inline = TRUE,
|
||||
# choices = list(
|
||||
# "Cross-sectional" = "cross-sectional"
|
||||
# )
|
||||
# ),
|
||||
shiny::uiOutput(outputId = ns("regression_type")),
|
||||
shiny::radioButtons(
|
||||
inputId = ns("add_regression_p"),
|
||||
label = "Add p-value",
|
||||
inline = TRUE,
|
||||
selected = "yes",
|
||||
choices = list(
|
||||
"Yes" = "yes",
|
||||
"No" = "no"
|
||||
)
|
||||
),
|
||||
shiny::radioButtons(
|
||||
inputId = ns("all"),
|
||||
label = "Specify covariables",
|
||||
inline = TRUE, selected = 2,
|
||||
choiceNames = c(
|
||||
"Yes",
|
||||
"No"
|
||||
),
|
||||
choiceValues = c(1, 2)
|
||||
),
|
||||
shiny::conditionalPanel(
|
||||
condition = "input.all==1",
|
||||
shiny::uiOutput(outputId = ns("regression_vars")),
|
||||
shiny::helpText("If none are selected, all are included."),
|
||||
shiny::tags$br(),
|
||||
ns = ns
|
||||
),
|
||||
bslib::input_task_button(
|
||||
id = ns("load"),
|
||||
label = "Analyse",
|
||||
icon = bsicons::bs_icon("pencil"),
|
||||
label_busy = "Working...",
|
||||
icon_busy = fontawesome::fa_i("arrows-rotate",
|
||||
class = "fa-spin",
|
||||
"aria-hidden" = "true"
|
||||
),
|
||||
type = "secondary",
|
||||
auto_reset = TRUE
|
||||
),
|
||||
shiny::helpText("Press 'Analyse' again after changing parameters."),
|
||||
shiny::tags$br()
|
||||
),
|
||||
do.call(
|
||||
bslib::accordion_panel,
|
||||
c(
|
||||
list(
|
||||
value = "acc_plot",
|
||||
title = "Coefficient plot",
|
||||
icon = bsicons::bs_icon("bar-chart-steps"),
|
||||
shiny::tags$br(),
|
||||
shiny::uiOutput(outputId = ns("plot_model"))
|
||||
),
|
||||
# plot_download_ui(ns("reg_plot_download"))
|
||||
shiny::tagList(
|
||||
shinyWidgets::noUiSliderInput(
|
||||
inputId = ns("plot_height"),
|
||||
label = "Plot height (mm)",
|
||||
min = 50,
|
||||
max = 300,
|
||||
value = 100,
|
||||
step = 1,
|
||||
format = shinyWidgets::wNumbFormat(decimals = 0),
|
||||
color = datamods:::get_primary_color()
|
||||
),
|
||||
shinyWidgets::noUiSliderInput(
|
||||
inputId = ns("plot_width"),
|
||||
label = "Plot width (mm)",
|
||||
min = 50,
|
||||
max = 300,
|
||||
value = 100,
|
||||
step = 1,
|
||||
format = shinyWidgets::wNumbFormat(decimals = 0),
|
||||
color = datamods:::get_primary_color()
|
||||
),
|
||||
shiny::selectInput(
|
||||
inputId = ns("plot_type"),
|
||||
label = "File format",
|
||||
choices = list(
|
||||
"png",
|
||||
"tiff",
|
||||
"eps",
|
||||
"pdf",
|
||||
"jpeg",
|
||||
"svg"
|
||||
)
|
||||
),
|
||||
shiny::br(),
|
||||
# Button
|
||||
shiny::downloadButton(
|
||||
outputId = ns("download_plot"),
|
||||
label = "Download plot",
|
||||
icon = shiny::icon("download")
|
||||
)
|
||||
)
|
||||
)
|
||||
),
|
||||
bslib::accordion_panel(
|
||||
value = "acc_checks",
|
||||
title = "Checks",
|
||||
icon = bsicons::bs_icon("clipboard-check"),
|
||||
shiny::uiOutput(outputId = ns("plot_checks"))
|
||||
)
|
||||
)
|
||||
),
|
||||
bslib::nav_panel(
|
||||
title = "Regression table",
|
||||
gt::gt_output(outputId = ns("table2"))
|
||||
),
|
||||
bslib::nav_panel(
|
||||
title = "Coefficient plot",
|
||||
shiny::plotOutput(outputId = ns("regression_plot"), height = "80vh")
|
||||
),
|
||||
bslib::nav_panel(
|
||||
title = "Model checks",
|
||||
shiny::plotOutput(outputId = ns("check"), height = "90vh")
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
regression_server <- function(id,
|
||||
data,
|
||||
...) {
|
||||
shiny::moduleServer(
|
||||
id = id,
|
||||
module = function(input, output, session) {
|
||||
ns <- session$ns
|
||||
|
||||
rv <- shiny::reactiveValues(
|
||||
data = NULL,
|
||||
plot = NULL,
|
||||
check = NULL,
|
||||
list = list()
|
||||
)
|
||||
|
||||
data_r <- shiny::reactive({
|
||||
if (shiny::is.reactive(data)) {
|
||||
data()
|
||||
} else {
|
||||
data
|
||||
}
|
||||
})
|
||||
|
||||
output$data_info <- shiny::renderUI({
|
||||
shiny::req(regression_vars())
|
||||
shiny::req(data_r())
|
||||
data_description(data_r()[regression_vars()])
|
||||
})
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Input fields
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
## Keep these "old" selection options as a simple alternative to the modification pane
|
||||
|
||||
|
||||
output$regression_vars <- shiny::renderUI({
|
||||
columnSelectInput(
|
||||
inputId = ns("regression_vars"),
|
||||
selected = NULL,
|
||||
label = "Covariables to include",
|
||||
data = data_r(),
|
||||
multiple = TRUE
|
||||
)
|
||||
})
|
||||
|
||||
output$outcome_var <- shiny::renderUI({
|
||||
columnSelectInput(
|
||||
inputId = ns("outcome_var"),
|
||||
selected = NULL,
|
||||
label = "Select outcome variable",
|
||||
data = data_r(),
|
||||
multiple = FALSE
|
||||
)
|
||||
})
|
||||
|
||||
output$regression_type <- shiny::renderUI({
|
||||
shiny::req(input$outcome_var)
|
||||
shiny::selectizeInput(
|
||||
inputId = ns("regression_type"),
|
||||
label = "Choose regression analysis",
|
||||
## The below ifelse statement handles the case of loading a new dataset
|
||||
choices = possible_functions(
|
||||
data = dplyr::select(
|
||||
data_r(),
|
||||
ifelse(input$outcome_var %in% names(data_r()),
|
||||
input$outcome_var,
|
||||
names(data_r())[1]
|
||||
)
|
||||
), design = "cross-sectional"
|
||||
),
|
||||
multiple = FALSE
|
||||
)
|
||||
})
|
||||
|
||||
output$factor_vars <- shiny::renderUI({
|
||||
shiny::selectizeInput(
|
||||
inputId = ns("factor_vars"),
|
||||
selected = colnames(data_r())[sapply(data_r(), is.factor)],
|
||||
label = "Covariables to format as categorical",
|
||||
choices = colnames(data_r()),
|
||||
multiple = TRUE
|
||||
)
|
||||
})
|
||||
|
||||
## Collected regression variables
|
||||
regression_vars <- shiny::reactive({
|
||||
if (is.null(input$regression_vars)) {
|
||||
out <- colnames(data_r())
|
||||
} else {
|
||||
out <- unique(c(input$regression_vars, input$outcome_var))
|
||||
}
|
||||
return(out)
|
||||
})
|
||||
|
||||
output$strat_var <- shiny::renderUI({
|
||||
columnSelectInput(
|
||||
inputId = ns("strat_var"),
|
||||
selected = "none",
|
||||
label = "Select variable to stratify baseline",
|
||||
data = data_r(),
|
||||
col_subset = c(
|
||||
"none",
|
||||
names(data_r())[unlist(lapply(data_r(), data_type)) %in% c("dichotomous", "categorical", "ordinal")]
|
||||
)
|
||||
)
|
||||
})
|
||||
|
||||
|
||||
output$plot_model <- shiny::renderUI({
|
||||
shiny::req(rv$list$regression$tables)
|
||||
shiny::selectInput(
|
||||
inputId = ns("plot_model"),
|
||||
selected = 1,
|
||||
label = "Select models to plot",
|
||||
choices = names(rv$list$regression$tables),
|
||||
multiple = TRUE
|
||||
)
|
||||
})
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Regression analysis
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
shiny::observeEvent(
|
||||
input$load,
|
||||
{
|
||||
shiny::req(input$outcome_var)
|
||||
|
||||
rv$list$regression$models <- NULL
|
||||
|
||||
tryCatch(
|
||||
{
|
||||
## Which models to create should be decided by input
|
||||
## Could also include
|
||||
## imputed or
|
||||
## minimally adjusted
|
||||
model_lists <- list(
|
||||
"Univariable" = regression_model_uv_list,
|
||||
"Multivariable" = regression_model_list
|
||||
) |>
|
||||
lapply(\(.fun){
|
||||
ls <- do.call(
|
||||
.fun,
|
||||
c(
|
||||
list(data = data_r() |>
|
||||
(\(.x){
|
||||
.x[regression_vars()]
|
||||
})()),
|
||||
list(outcome.str = input$outcome_var),
|
||||
list(fun.descr = input$regression_type)
|
||||
)
|
||||
)
|
||||
})
|
||||
|
||||
|
||||
rv$list$regression$params <- get_fun_options(input$regression_type) |>
|
||||
(\(.x){
|
||||
.x[[1]]
|
||||
})()
|
||||
|
||||
rv$list$regression$models <- model_lists
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0("Creating regression models failed with the following error: ", err), type = "err")
|
||||
}
|
||||
)
|
||||
}
|
||||
)
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Model checks
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
shiny::observeEvent(
|
||||
list(
|
||||
rv$list$regression$models
|
||||
),
|
||||
{
|
||||
shiny::req(rv$list$regression$models)
|
||||
tryCatch(
|
||||
{
|
||||
rv$check <- lapply(rv$list$regression$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")
|
||||
}
|
||||
)
|
||||
}
|
||||
)
|
||||
|
||||
rv$check_plot <- shiny::reactive(plot(rv$check))
|
||||
|
||||
output$plot_checks <- shiny::renderUI({
|
||||
shiny::req(rv$list$regression$models)
|
||||
shiny::req(rv$check_plot)
|
||||
|
||||
## Implement correct plotting
|
||||
names <- sapply(rv$check_plot(), \(.i){
|
||||
# .i$labels$title
|
||||
get_ggplot_label(.i, "title")
|
||||
})
|
||||
|
||||
vectorSelectInput(
|
||||
inputId = ns("plot_checks"),
|
||||
selected = 1,
|
||||
label = "Select checks to plot",
|
||||
choices = names,
|
||||
multiple = TRUE
|
||||
)
|
||||
})
|
||||
|
||||
output$check <- shiny::renderPlot(
|
||||
{
|
||||
shiny::req(rv$check_plot)
|
||||
shiny::req(input$plot_checks)
|
||||
|
||||
p <- rv$check_plot() +
|
||||
# patchwork::wrap_plots() +
|
||||
patchwork::plot_annotation(title = "Multivariable regression model checks")
|
||||
|
||||
|
||||
layout <- sapply(seq_len(length(p)), \(.x){
|
||||
patchwork::area(.x, 1)
|
||||
})
|
||||
|
||||
out <- p + patchwork::plot_layout(design = Reduce(c, layout))
|
||||
|
||||
index <- match(
|
||||
input$plot_checks,
|
||||
sapply(rv$check_plot(), \(.i){
|
||||
get_ggplot_label(.i, "title")
|
||||
})
|
||||
)
|
||||
|
||||
ls <- list()
|
||||
|
||||
for (i in index) {
|
||||
p <- out[[i]] +
|
||||
ggplot2::theme(axis.text = ggplot2::element_text(size = 10),
|
||||
axis.title = ggplot2::element_text(size = 12),
|
||||
legend.text = ggplot2::element_text(size = 12),
|
||||
plot.subtitle = ggplot2::element_text(size = 12),
|
||||
plot.title = ggplot2::element_text(size = 18))
|
||||
ls <- c(ls, list(p))
|
||||
}
|
||||
# browser()
|
||||
tryCatch(
|
||||
{
|
||||
patchwork::wrap_plots(ls, ncol = if (length(ls) == 1) 1 else 2)
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(err, type = "err")
|
||||
}
|
||||
)
|
||||
},
|
||||
alt = "Assumptions testing of the multivariable regression model"
|
||||
)
|
||||
|
||||
|
||||
shiny::observeEvent(
|
||||
input$load,
|
||||
{
|
||||
shiny::req(rv$list$regression$models)
|
||||
## To avoid plotting old models on fail/error
|
||||
rv$list$regression$tables <- NULL
|
||||
|
||||
tryCatch(
|
||||
{
|
||||
out <- lapply(rv$list$regression$models, \(.x){
|
||||
.x$model
|
||||
}) |>
|
||||
purrr::map(regression_table)
|
||||
|
||||
if (input$add_regression_p == "no") {
|
||||
out <- out |>
|
||||
lapply(\(.x){
|
||||
.x |>
|
||||
gtsummary::modify_column_hide(
|
||||
column = "p.value"
|
||||
)
|
||||
})
|
||||
}
|
||||
|
||||
rv$list$regression$tables <- out
|
||||
|
||||
rv$list$input <- input
|
||||
},
|
||||
warning = function(warn) {
|
||||
showNotification(paste0(warn), type = "warning")
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0("Creating a regression table failed with the following error: ", err), type = "err")
|
||||
}
|
||||
)
|
||||
}
|
||||
)
|
||||
|
||||
output$table2 <- gt::render_gt({
|
||||
shiny::req(rv$list$regression$tables)
|
||||
rv$list$regression$tables |>
|
||||
tbl_merge() |>
|
||||
gtsummary::as_gt() |>
|
||||
gt::tab_header(gt::md(glue::glue("**Table 2: {rv$list$regression$params$descr}**")))
|
||||
})
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Coefficients plot
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
shiny::observeEvent(list(
|
||||
input$plot_model,
|
||||
rv$list$regression
|
||||
), {
|
||||
shiny::req(input$plot_model)
|
||||
|
||||
tryCatch(
|
||||
{
|
||||
p <- merge_long(
|
||||
rv$list$regression,
|
||||
sort_by(
|
||||
input$plot_model,
|
||||
c("Univariable", "Minimal", "Multivariable"),
|
||||
na.rm = TRUE
|
||||
)
|
||||
) |>
|
||||
(\(.x){
|
||||
if (length(input$plot_model) > 1) {
|
||||
plot.tbl_regression(
|
||||
x = .x,
|
||||
colour = "model",
|
||||
dodged = TRUE
|
||||
) +
|
||||
ggplot2::theme(legend.position = "bottom") +
|
||||
ggplot2::guides(color = ggplot2::guide_legend(reverse = TRUE))
|
||||
} else {
|
||||
plot.tbl_regression(
|
||||
x = .x,
|
||||
colour = "variable"
|
||||
) +
|
||||
ggplot2::theme(legend.position = "none")
|
||||
}
|
||||
})()
|
||||
|
||||
rv$plot <- p +
|
||||
ggplot2::scale_y_discrete(labels = scales::label_wrap(15)) +
|
||||
gg_theme_shiny()
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0(err), type = "err")
|
||||
}
|
||||
)
|
||||
})
|
||||
|
||||
|
||||
output$regression_plot <- shiny::renderPlot(
|
||||
{
|
||||
shiny::req(input$plot_model)
|
||||
|
||||
rv$plot
|
||||
},
|
||||
alt = "Regression coefficient plot"
|
||||
)
|
||||
|
||||
# plot_download_server(
|
||||
# id = ns("reg_plot_download"),
|
||||
# data = shiny::reactive(rv$plot)
|
||||
# )
|
||||
|
||||
output$download_plot <- shiny::downloadHandler(
|
||||
filename = paste0("regression_plot.", input$plot_type),
|
||||
content = function(file) {
|
||||
shiny::withProgress(message = "Saving the plot. Hold on for a moment..", {
|
||||
ggplot2::ggsave(
|
||||
filename = file,
|
||||
plot = rv$plot,
|
||||
width = input$plot_width,
|
||||
height = input$plot_height,
|
||||
dpi = 300,
|
||||
units = "mm", scale = 2
|
||||
)
|
||||
})
|
||||
}
|
||||
)
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Output
|
||||
#########
|
||||
##############################################################################
|
||||
|
||||
return(shiny::reactive({
|
||||
data <- rv$list
|
||||
# code <- list()
|
||||
#
|
||||
# if (length(code) > 0) {
|
||||
# attr(data, "code") <- Reduce(
|
||||
# f = function(x, y) rlang::expr(!!x %>% !!y),
|
||||
# x = code
|
||||
# )
|
||||
# }
|
||||
return(data)
|
||||
}))
|
||||
}
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -134,6 +134,8 @@ regression_model <- function(data,
|
|||
)
|
||||
)
|
||||
|
||||
# out <- REDCapCAST::set_attr(out,label = fun,attr = "fun.call")
|
||||
|
||||
# Recreating the call
|
||||
# out$call <- match.call(definition=eval(parse(text=fun)), call(fun, data = 'data',formula = as.formula(formula.str),args.list))
|
||||
|
||||
|
|
|
|||
|
|
@ -24,7 +24,8 @@
|
|||
#' formula.str = "{outcome.str}~.",
|
||||
#' args.list = NULL
|
||||
#' ) |>
|
||||
#' regression_table() |> plot()
|
||||
#' regression_table() |>
|
||||
#' plot()
|
||||
#' gtsummary::trial |>
|
||||
#' regression_model(
|
||||
#' outcome.str = "trt",
|
||||
|
|
@ -61,7 +62,7 @@
|
|||
#' }) |>
|
||||
#' purrr::map(regression_table) |>
|
||||
#' tbl_merge()
|
||||
#' }
|
||||
#' }
|
||||
#' regression_table <- function(x, ...) {
|
||||
#' UseMethod("regression_table")
|
||||
#' }
|
||||
|
|
@ -94,9 +95,8 @@
|
|||
#' gtsummary::add_glance_source_note() # |>
|
||||
#' # gtsummary::bold_p()
|
||||
#' }
|
||||
|
||||
regression_table <- function(x, ...) {
|
||||
if ("list" %in% class(x)){
|
||||
if ("list" %in% class(x)) {
|
||||
x |>
|
||||
purrr::map(\(.m){
|
||||
regression_table_create(x = .m, ...) |>
|
||||
|
|
@ -104,24 +104,42 @@ regression_table <- function(x, ...) {
|
|||
}) |>
|
||||
gtsummary::tbl_stack()
|
||||
} else {
|
||||
regression_table_create(x,...)
|
||||
regression_table_create(x, ...)
|
||||
}
|
||||
}
|
||||
|
||||
regression_table_create <- function(x, ..., args.list = NULL, fun = "gtsummary::tbl_regression") {
|
||||
regression_table_create <- function(x, ..., args.list = NULL, fun = "gtsummary::tbl_regression", theme = c("jama", "lancet", "nejm", "qjecon")) {
|
||||
# Stripping custom class
|
||||
class(x) <- class(x)[class(x) != "freesearchr_model"]
|
||||
|
||||
theme <- match.arg(theme)
|
||||
|
||||
if (any(c(length(class(x)) != 1, class(x) != "lm"))) {
|
||||
if (!"exponentiate" %in% names(args.list)) {
|
||||
args.list <- c(args.list, list(exponentiate = TRUE, p.values = TRUE))
|
||||
}
|
||||
}
|
||||
|
||||
out <- do.call(getfun(fun), c(list(x = x), args.list))
|
||||
out #|>
|
||||
# gtsummary::add_glance_source_note() # |>
|
||||
# gtsummary::bold_p()
|
||||
gtsummary::theme_gtsummary_journal(journal = theme)
|
||||
if (inherits(x, "polr")) {
|
||||
# browser()
|
||||
out <- do.call(getfun(fun), c(list(x = x), args.list))
|
||||
# out <- do.call(getfun(fun), c(list(x = x, tidy_fun = list(residual_type = "normal")), args.list))
|
||||
# out <- do.call(what = getfun(fun),
|
||||
# args = c(
|
||||
# list(
|
||||
# x = x,
|
||||
# tidy_fun = list(
|
||||
# conf.int = TRUE,
|
||||
# conf.level = 0.95,
|
||||
# residual_type = "normal")),
|
||||
# args.list)
|
||||
# )
|
||||
} else {
|
||||
out <- do.call(getfun(fun), c(list(x = x), args.list))
|
||||
}
|
||||
|
||||
out
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -79,7 +79,7 @@ update_variables_ui <- function(id, title = "") {
|
|||
shiny::actionButton(
|
||||
inputId = ns("validate"),
|
||||
label = htmltools::tagList(
|
||||
phosphoricons::ph("arrow-circle-right", title = i18n("Apply changes")),
|
||||
phosphoricons::ph("arrow-circle-right", title = datamods::i18n("Apply changes")),
|
||||
datamods::i18n("Apply changes")
|
||||
),
|
||||
width = "100%"
|
||||
|
|
@ -137,15 +137,9 @@ update_variables_server <- function(id,
|
|||
|
||||
output$table <- toastui::renderDatagrid({
|
||||
shiny::req(variables_r())
|
||||
# browser()
|
||||
|
||||
variables <- variables_r()
|
||||
|
||||
# variables <- variables |>
|
||||
# dplyr::mutate(vals=as.list(dplyr::as_tibble(data_r())))
|
||||
|
||||
# variables <- variables |>
|
||||
# dplyr::mutate(n_id=seq_len(nrow(variables)))
|
||||
|
||||
update_variables_datagrid(
|
||||
variables,
|
||||
height = height,
|
||||
|
|
@ -165,7 +159,7 @@ update_variables_server <- function(id,
|
|||
if (length(new_selections) < 1) {
|
||||
new_selections <- seq_along(data)
|
||||
}
|
||||
# browser()
|
||||
|
||||
data_inputs <- data.table::as.data.table(input$table_data)
|
||||
data.table::setorderv(data_inputs, "rowKey")
|
||||
|
||||
|
|
@ -184,7 +178,6 @@ update_variables_server <- function(id,
|
|||
new_classes <- data_inputs$class_toset
|
||||
new_classes[new_classes == "Select"] <- NA
|
||||
|
||||
# browser()
|
||||
data_sv <- variables_r()
|
||||
vars_to_change <- get_vars_to_convert(data_sv, setNames(as.list(new_classes), old_names))
|
||||
|
||||
|
|
@ -251,6 +244,8 @@ update_variables_server <- function(id,
|
|||
ignoreInit = TRUE
|
||||
)
|
||||
|
||||
# shiny::observeEvent(input$close,
|
||||
# {
|
||||
return(shiny::reactive({
|
||||
data <- updated_data$x
|
||||
code <- list()
|
||||
|
|
@ -277,24 +272,62 @@ update_variables_server <- function(id,
|
|||
}
|
||||
return(data)
|
||||
}))
|
||||
# })
|
||||
|
||||
# shiny::reactive({
|
||||
# data <- updated_data$x
|
||||
# code <- list()
|
||||
# if (!is.null(data) && shiny::isTruthy(updated_data$list_mutate) && length(updated_data$list_mutate) > 0) {
|
||||
# code <- c(code, list(rlang::call2("mutate", !!!updated_data$list_mutate)))
|
||||
# }
|
||||
# if (!is.null(data) && shiny::isTruthy(updated_data$list_rename) && length(updated_data$list_rename) > 0) {
|
||||
# code <- c(code, list(rlang::call2("rename", !!!updated_data$list_rename)))
|
||||
# }
|
||||
# if (!is.null(data) && shiny::isTruthy(updated_data$list_select) && length(updated_data$list_select) > 0) {
|
||||
# code <- c(code, list(rlang::expr(select(-any_of(c(!!!updated_data$list_select))))))
|
||||
# }
|
||||
# if (!is.null(data) && shiny::isTruthy(updated_data$list_relabel) && length(updated_data$list_relabel) > 0) {
|
||||
# code <- c(code, list(rlang::call2("purrr::map2(list_relabel,
|
||||
# function(.data,.label){
|
||||
# REDCapCAST::set_attr(.data,.label,attr = 'label')
|
||||
# }) |> dplyr::bind_cols(.name_repair = 'unique_quiet')")))
|
||||
# }
|
||||
# if (length(code) > 0) {
|
||||
# attr(data, "code") <- Reduce(
|
||||
# f = function(x, y) rlang::expr(!!x %>% !!y),
|
||||
# x = code
|
||||
# )
|
||||
# }
|
||||
# updated_data$return_data <- data
|
||||
# })
|
||||
|
||||
# shiny::observeEvent(input$close,
|
||||
# {
|
||||
# shiny::req(input$close)
|
||||
# return(shiny::reactive({
|
||||
# data <- updated_data$return_data
|
||||
# return(data)
|
||||
# }))
|
||||
# })
|
||||
|
||||
}
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
modal_update_variables <- function(id,
|
||||
title = "Select, rename and reclass variables",
|
||||
easyClose = TRUE,
|
||||
size = "xl",
|
||||
footer = NULL) {
|
||||
title = "Select, rename and reclass variables",
|
||||
easyClose = TRUE,
|
||||
size = "xl",
|
||||
footer = NULL) {
|
||||
ns <- NS(id)
|
||||
showModal(modalDialog(
|
||||
title = tagList(title, datamods:::button_close_modal()),
|
||||
update_variables_ui(id),
|
||||
tags$div(
|
||||
style = "display: none;",
|
||||
textInput(inputId = ns("hidden"), label = NULL, value = datamods:::genId())
|
||||
),
|
||||
# tags$div(
|
||||
# style = "display: none;",
|
||||
# textInput(inputId = ns("hidden"), label = NULL, value = datamods:::genId())
|
||||
# ),
|
||||
easyClose = easyClose,
|
||||
size = size,
|
||||
footer = footer
|
||||
|
|
@ -618,7 +651,11 @@ convert_to <- function(data,
|
|||
setNames(list(expr(as.factor(!!sym(variable)))), variable)
|
||||
)
|
||||
} else if (identical(new_class, "numeric")) {
|
||||
data[[variable]] <- as.numeric(type.convert(data[[variable]], as.is = TRUE, ...))
|
||||
data[[variable]] <- as.numeric(data[[variable]], ...)
|
||||
# This is the original, that would convert to character and then to numeric
|
||||
# resulting in all NAs, setting as.is = FALSE would result in a numeric
|
||||
# vector in order of appearance. Now it is acting like integer conversion
|
||||
# data[[variable]] <- as.numeric(type.convert(data[[variable]], as.is = TRUE, ...))
|
||||
attr(data, "code_03_convert") <- c(
|
||||
attr(data, "code_03_convert"),
|
||||
setNames(list(expr(as.numeric(!!sym(variable)))), variable)
|
||||
|
|
@ -633,7 +670,7 @@ convert_to <- function(data,
|
|||
data[[variable]] <- as.Date(x = clean_date(data[[variable]]), ...)
|
||||
attr(data, "code_03_convert") <- c(
|
||||
attr(data, "code_03_convert"),
|
||||
setNames(list(expr(as.Date(clean_date(!!sym(variable)), origin = !!args$origin, format=clean_sep(!!args$format)))), 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")) {
|
||||
data[[variable]] <- as.POSIXct(x = data[[variable]], ...)
|
||||
|
|
@ -747,8 +784,8 @@ get_vars_to_convert <- function(vars, classes_input) {
|
|||
#' @returns character vector
|
||||
#' @export
|
||||
#'
|
||||
clean_sep <- function(data,old.sep="[-.,/]",new.sep="-"){
|
||||
gsub(old.sep,new.sep,data)
|
||||
clean_sep <- function(data, old.sep = "[-.,/]", new.sep = "-") {
|
||||
gsub(old.sep, new.sep, data)
|
||||
}
|
||||
|
||||
#' Attempts at applying uniform date format
|
||||
|
|
@ -758,18 +795,19 @@ clean_sep <- function(data,old.sep="[-.,/]",new.sep="-"){
|
|||
#' @returns character string
|
||||
#' @export
|
||||
#'
|
||||
clean_date <- function(data){
|
||||
clean_date <- function(data) {
|
||||
data |>
|
||||
clean_sep() |>
|
||||
sapply(\(.x){
|
||||
if (is.na(.x)){
|
||||
if (is.na(.x)) {
|
||||
.x
|
||||
} else {
|
||||
strsplit(.x,"-") |>
|
||||
unlist()|>
|
||||
strsplit(.x, "-") |>
|
||||
unlist() |>
|
||||
lapply(\(.y){
|
||||
if (nchar(.y)==1) paste0("0",.y) else .y
|
||||
}) |> paste(collapse="-")
|
||||
if (nchar(.y) == 1) paste0("0", .y) else .y
|
||||
}) |>
|
||||
paste(collapse = "-")
|
||||
}
|
||||
}) |>
|
||||
unname()
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue