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

error handling

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2024-12-18 15:46:02 +01:00
parent b0f63ab2a4
commit 96c37219aa
No known key found for this signature in database
4 changed files with 283 additions and 197 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
R/cut-variable-dates.R
View file

@ -256,7 +256,7 @@ cut_variable_ui <- function(id) {
numericInput( numericInput(
inputId = ns("n_breaks"), inputId = ns("n_breaks"),
label = i18n("Number of breaks:"), label = i18n("Number of breaks:"),
value = 5, value = 3,
min = 2, min = 2,
max = 12, max = 12,
width = "100%" width = "100%"

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

@ -296,7 +296,7 @@ cut_variable_ui <- function(id) {
numericInput( numericInput(
inputId = ns("n_breaks"), inputId = ns("n_breaks"),
label = i18n("Number of breaks:"), label = i18n("Number of breaks:"),
value = 5, value = 3,
min = 2, min = 2,
max = 12, max = 12,
width = "100%" width = "100%"
@ -2215,7 +2215,7 @@ server <- function(input, output, session) {
}) })
rv <- shiny::reactiveValues( rv <- shiny::reactiveValues(
list = NULL, list = list(),
ds = NULL, ds = NULL,
input = exists("webResearch_data"), input = exists("webResearch_data"),
local_temp = NULL, local_temp = NULL,
@ -2494,106 +2494,151 @@ server <- function(input, output, session) {
# browser() # browser()
# Assumes all character variables can be formatted as factors # Assumes all character variables can be formatted as factors
# data <- data_filter$filtered() |> # data <- data_filter$filtered() |>
data <- data_filter() |> tryCatch(
dplyr::mutate(dplyr::across(dplyr::where(is.character), as.factor)) |> {
REDCapCAST::fct_drop.data.frame() |> data <- data_filter() |>
factorize(vars = input$factor_vars) dplyr::mutate(dplyr::across(dplyr::where(is.character), as.factor)) |>
REDCapCAST::fct_drop.data.frame() |>
factorize(vars = input$factor_vars)
if (input$strat_var == "none") { if (input$strat_var == "none") {
by.var <- NULL by.var <- NULL
} else { } else {
by.var <- input$strat_var by.var <- input$strat_var
} }
data <- data[base_vars()] data <- data[base_vars()]
# model <- data |> # model <- data |>
# regression_model( # regression_model(
# outcome.str = input$outcome_var, # outcome.str = input$outcome_var,
# auto.mode = input$regression_auto == 1, # auto.mode = input$regression_auto == 1,
# formula.str = input$regression_formula, # formula.str = input$regression_formula,
# fun = input$regression_fun, # fun = input$regression_fun,
# args.list = eval(parse(text = paste0("list(", input$regression_args, ")"))) # args.list = eval(parse(text = paste0("list(", input$regression_args, ")")))
# ) # )
models <- list( models <- list(
"Univariable" = regression_model_uv, "Univariable" = regression_model_uv,
"Multivariable" = regression_model "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, ")"))))
)
)
})
check <- purrr::pluck(models, "Multivariable") |>
performance::check_model()
rv$list <- list(
data = data,
check = check,
table1 = data |>
baseline_table(
fun.args =
list(
by = by.var
)
) |> ) |>
(\(.x){ lapply(\(.fun){
if (!is.null(by.var)) { do.call(
.x |> gtsummary::add_overall() .fun,
} else { c(
.x list(data = data),
} list(outcome.str = input$outcome_var),
})() |> list(formula.str = input$regression_formula),
(\(.x){ list(fun = input$regression_fun),
if (input$add_p == "yes") { list(args.list = eval(parse(text = paste0("list(", input$regression_args, ")"))))
.x |> )
gtsummary::add_p() |> )
gtsummary::bold_p() })
} else {
.x rv$list$data <- data
}
})(),
table2 = models |>
purrr::map(regression_table) |> rv$list$check <- purrr::pluck(models, "Multivariable") |>
tbl_merge(), performance::check_model()
input = input
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"
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(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')
rv$ready <- "ready"
})
} }
) )
@ -2672,8 +2717,6 @@ server <- function(input, output, session) {
} }
######## ########
#### Current file: /Users/au301842/webResearch/inst/apps/data_analysis_modules/launch.R #### Current file: /Users/au301842/webResearch/inst/apps/data_analysis_modules/launch.R
######## ########

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

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

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

@ -60,7 +60,7 @@ server <- function(input, output, session) {
}) })
rv <- shiny::reactiveValues( rv <- shiny::reactiveValues(
list = NULL, list = list(),
ds = NULL, ds = NULL,
input = exists("webResearch_data"), input = exists("webResearch_data"),
local_temp = NULL, local_temp = NULL,
@ -339,106 +339,151 @@ server <- function(input, output, session) {
# browser() # browser()
# Assumes all character variables can be formatted as factors # Assumes all character variables can be formatted as factors
# data <- data_filter$filtered() |> # data <- data_filter$filtered() |>
data <- data_filter() |> tryCatch(
dplyr::mutate(dplyr::across(dplyr::where(is.character), as.factor)) |> {
REDCapCAST::fct_drop.data.frame() |> data <- data_filter() |>
factorize(vars = input$factor_vars) dplyr::mutate(dplyr::across(dplyr::where(is.character), as.factor)) |>
REDCapCAST::fct_drop.data.frame() |>
factorize(vars = input$factor_vars)
if (input$strat_var == "none") { if (input$strat_var == "none") {
by.var <- NULL by.var <- NULL
} else { } else {
by.var <- input$strat_var by.var <- input$strat_var
} }
data <- data[base_vars()] data <- data[base_vars()]
# model <- data |> # model <- data |>
# regression_model( # regression_model(
# outcome.str = input$outcome_var, # outcome.str = input$outcome_var,
# auto.mode = input$regression_auto == 1, # auto.mode = input$regression_auto == 1,
# formula.str = input$regression_formula, # formula.str = input$regression_formula,
# fun = input$regression_fun, # fun = input$regression_fun,
# args.list = eval(parse(text = paste0("list(", input$regression_args, ")"))) # args.list = eval(parse(text = paste0("list(", input$regression_args, ")")))
# ) # )
models <- list( models <- list(
"Univariable" = regression_model_uv, "Univariable" = regression_model_uv,
"Multivariable" = regression_model "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, ")"))))
)
)
})
check <- purrr::pluck(models, "Multivariable") |>
performance::check_model()
rv$list <- list(
data = data,
check = check,
table1 = data |>
baseline_table(
fun.args =
list(
by = by.var
)
) |> ) |>
(\(.x){ lapply(\(.fun){
if (!is.null(by.var)) { do.call(
.x |> gtsummary::add_overall() .fun,
} else { c(
.x list(data = data),
} list(outcome.str = input$outcome_var),
})() |> list(formula.str = input$regression_formula),
(\(.x){ list(fun = input$regression_fun),
if (input$add_p == "yes") { list(args.list = eval(parse(text = paste0("list(", input$regression_args, ")"))))
.x |> )
gtsummary::add_p() |> )
gtsummary::bold_p() })
} else {
.x rv$list$data <- data
}
})(),
table2 = models |>
purrr::map(regression_table) |> rv$list$check <- purrr::pluck(models, "Multivariable") |>
tbl_merge(), performance::check_model()
input = input
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"
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(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')
rv$ready <- "ready"
})
} }
) )
@ -515,5 +560,3 @@ server <- function(input, output, session) {
}) })
}) })
} }