diff --git a/.png b/.png new file mode 100644 index 0000000..597b4b6 Binary files /dev/null and b/.png differ diff --git a/DESCRIPTION b/DESCRIPTION index 38476ff..bd424ce 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: Browser Based Data Analysis -Version: 25.3.2 +Version: 25.4.1 Authors@R: person("Andreas Gammelgaard", "Damsbo", , "agdamsbo@clin.au.dk", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-7559-1154")) diff --git a/NAMESPACE b/NAMESPACE index 0a03a18..e10fcef 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -14,7 +14,6 @@ export(clean_date) export(clean_sep) export(columnSelectInput) export(contrast_text) -export(cor_demo_app) export(create_baseline) export(create_log_tics) export(create_overview_datagrid) @@ -91,6 +90,7 @@ export(remove_na_attr) export(repeated_instruments) export(sankey_ready) export(selectInputIcon) +export(sort_by) export(specify_qmd_format) export(subset_types) export(supported_functions) diff --git a/NEWS.md b/NEWS.md index 3352982..35e474b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,12 +1,16 @@ -# FreesearchR 25.3.2 +# FreesearchR 25.4.1 Focus is on polish and improved ui/ux. -Updating name (will be FreesearchR), with renamed repository and some graphics are comng. This may introduce some breaking chances for others calling or installing the package. No future changes are planned. A complete transition is planned before attending and presenting a poster at the European Stroke Organisation Conference 2025 in May. +Updating name (will be FreesearchR), with renamed repository and some graphics are coming. This may introduce some breaking chances for others calling or installing the package. No future changes are planned. A complete transition is planned before attending and presenting a poster at the European Stroke Organisation Conference 2025 in May. Testing file upload conducted and improved. -Working on improving code export. +Working on improving code export. This is very difficult to get perfect. Initial focus is on extracting enough to be able to learn from it. + +Regression calculations, plots, and checks have been improved and moved to standalone module. + +Data overview/modifications has been simplified slightly. # freesearcheR 25.3.1 diff --git a/R/app_version.R b/R/app_version.R index 0408af9..b066bed 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'250331_1248' +app_version <- function()'250402_1126' diff --git a/R/baseline_table.R b/R/baseline_table.R index ad90eef..bc3bec5 100644 --- a/R/baseline_table.R +++ b/R/baseline_table.R @@ -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 } diff --git a/R/correlations-module.R b/R/correlations-module.R index 6b2476a..fd7c282 100644 --- a/R/correlations-module.R +++ b/R/correlations-module.R @@ -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) -} + diff --git a/R/helpers.R b/R/helpers.R index 2571fad..f09528b 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -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]] +} diff --git a/R/import-file-ext.R b/R/import-file-ext.R index e93809a..855c704 100644 --- a/R/import-file-ext.R +++ b/R/import-file-ext.R @@ -461,8 +461,7 @@ import_dta <- function(file) { #' import_rds <- function(file) { readr::read_rds( - file = file, - name_repair = "unique_quiet" + file = file ) } diff --git a/R/plot-download-module.R b/R/plot-download-module.R new file mode 100644 index 0000000..3ab1dc7 --- /dev/null +++ b/R/plot-download-module.R @@ -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 + ) + }) + } + ) + } + ) +} diff --git a/R/regression-module.R b/R/regression-module.R new file mode 100644 index 0000000..d01478c --- /dev/null +++ b/R/regression-module.R @@ -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) + })) + } + ) +} + + diff --git a/R/regression_model.R b/R/regression_model.R index 1ed69e7..3185536 100644 --- a/R/regression_model.R +++ b/R/regression_model.R @@ -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)) diff --git a/R/regression_table.R b/R/regression_table.R index 5e90a27..3dea4a5 100644 --- a/R/regression_table.R +++ b/R/regression_table.R @@ -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 } diff --git a/R/update-variables-ext.R b/R/update-variables-ext.R index 65a7568..7f48480 100644 --- a/R/update-variables-ext.R +++ b/R/update-variables-ext.R @@ -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() diff --git a/examples/correlations_module_demo.R b/examples/correlations_module_demo.R new file mode 100644 index 0000000..2bb20de --- /dev/null +++ b/examples/correlations_module_demo.R @@ -0,0 +1,27 @@ +#' Correlations plot demo app +#' +#' @returns shiny app +#' @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) +} diff --git a/examples/download_module_demo.R b/examples/download_module_demo.R new file mode 100644 index 0000000..a2e2282 --- /dev/null +++ b/examples/download_module_demo.R @@ -0,0 +1,44 @@ +#' Download demo +#' +#' @returns +#' @export +#' +#' @examples +#' \dontrun{ +#' download_demo_app() +#' } +download_demo_app <- function() { + ui <- bslib::page_fixed( + bslib::nav_panel( + title = "test", + bslib::navset_bar( + sidebar = bslib::sidebar( + bslib::accordion( + do.call( + bslib::accordion_panel, + c( + list( + value = "acc_download", + title = "Download", + icon = bsicons::bs_icon("download") + ), + plot_download_ui("regression") + ) + ) + ) + ) + ) + ) + ) + server <- function(input, output, session) { + plot_download_server( + id = "regression", + data = { + lm(mpg ~ ., default_parsing(mtcars)) |> + gtsummary::tbl_regression() |> + plot(colour = "variable") + } + ) + } + shiny::shinyApp(ui, server) +} diff --git a/examples/regression_module_demo.R b/examples/regression_module_demo.R new file mode 100644 index 0000000..66a98d2 --- /dev/null +++ b/examples/regression_module_demo.R @@ -0,0 +1,21 @@ +#' Regression module +#' +#' @returns +#' @export +#' +#' @examples +#' \dontrun{ +#' regression_demo_app() +#' } +regression_demo_app <- function() { + ui <- bslib::page_fixed( + do.call( + bslib::navset_bar, + regression_ui("regression") + ) + ) + server <- function(input, output, session) { + regression_server("regression", data = default_parsing(mtcars[1:3])) + } + shiny::shinyApp(ui, server) +} diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index c7c02f9..75d249a 100644 --- a/inst/apps/FreesearchR/app.R +++ b/inst/apps/FreesearchR/app.R @@ -7,14 +7,14 @@ ######## -#### Current file: R//app_version.R +#### Current file: /Users/au301842/FreesearchR/R//app_version.R ######## -app_version <- function()'250331_1248' +app_version <- function()'250402_1126' ######## -#### Current file: R//baseline_table.R +#### Current file: /Users/au301842/FreesearchR/R//baseline_table.R ######## #' Print a flexible baseline characteristics table @@ -53,21 +53,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 = @@ -78,23 +82,22 @@ 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 } ######## -#### Current file: R//contrast_text.R +#### Current file: /Users/au301842/FreesearchR/R//contrast_text.R ######## #' @title Contrast Text Color @@ -151,7 +154,7 @@ contrast_text <- function(background, ######## -#### Current file: R//correlations-module.R +#### Current file: /Users/au301842/FreesearchR/R//correlations-module.R ######## #' Data correlations evaluation module @@ -289,38 +292,12 @@ 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) -} + ######## -#### Current file: R//custom_SelectInput.R +#### Current file: /Users/au301842/FreesearchR/R//custom_SelectInput.R ######## #' A selectizeInput customized for data frames with column labels @@ -514,7 +491,7 @@ vectorSelectInput <- function(inputId, ######## -#### Current file: R//cut-variable-dates.R +#### Current file: /Users/au301842/FreesearchR/R//cut-variable-dates.R ######## library(datamods) @@ -1159,7 +1136,7 @@ plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112 ######## -#### Current file: R//data_plots.R +#### Current file: /Users/au301842/FreesearchR/R//data_plots.R ######## # source(here::here("functions.R")) @@ -1892,7 +1869,7 @@ clean_common_axis <- function(p, axis) { ######## -#### Current file: R//data-import.R +#### Current file: /Users/au301842/FreesearchR/R//data-import.R ######## data_import_ui <- function(id) { @@ -2049,7 +2026,7 @@ data_import_demo_app <- function() { ######## -#### Current file: R//data-summary.R +#### Current file: /Users/au301842/FreesearchR/R//data-summary.R ######## #' Data summary module @@ -2360,7 +2337,7 @@ add_class_icon <- function(grid, column = "class") { ######## -#### Current file: R//file-import-module.R +#### Current file: /Users/au301842/FreesearchR/R//file-import-module.R ######## #' Shiny UI module to load a data file @@ -2491,7 +2468,7 @@ file_app() ######## -#### Current file: R//helpers.R +#### Current file: /Users/au301842/FreesearchR/R//helpers.R ######## #' Wrapper function to get function from character vector referring to function from namespace. Passed to 'do.call()' @@ -2839,9 +2816,36 @@ data_description <- function(data) { ) } +#' Drop-in replacement for the base::sort_by with option to remove NAs +#' +#' @param x x +#' @param y y +#' @param na.rm remove NAs +#' @param ... passed to base_sort_by +#' +#' @returns vector +#' @export +#' +#' @examples +#' sort_by(c("Multivariable", "Univariable"),c("Univariable","Minimal","Multivariable")) +sort_by <- function(x,y,na.rm=FALSE,...){ + out <- base::sort_by(x,y,...) + if (na.rm==TRUE){ + out[!is.na(out)] + } else { + out + } +} + + +get_ggplot_label <- function(data,label){ + assertthat::assert_that(ggplot2::is.ggplot(data)) + data$labels[[label]] +} + ######## -#### Current file: R//import-file-ext.R +#### Current file: /Users/au301842/FreesearchR/R//import-file-ext.R ######## #' @title Import data from a file @@ -3307,8 +3311,7 @@ import_dta <- function(file) { #' import_rds <- function(file) { readr::read_rds( - file = file, - name_repair = "unique_quiet" + file = file ) } @@ -3416,7 +3419,7 @@ import_file_demo_app <- function() { ######## -#### Current file: R//launch_FreesearchR.R +#### Current file: /Users/au301842/FreesearchR/R//launch_FreesearchR.R ######## #' Easily launch the FreesearchR app @@ -3446,7 +3449,7 @@ launch_FreesearchR <- function(...){ ######## -#### Current file: R//plot_box.R +#### Current file: /Users/au301842/FreesearchR/R//plot_box.R ######## #' Beautiful box plot(s) @@ -3532,7 +3535,7 @@ plot_box_single <- function(data, x, y=NULL, seed = 2103) { ######## -#### Current file: R//plot_euler.R +#### Current file: /Users/au301842/FreesearchR/R//plot_euler.R ######## #' Area proportional venn diagrams @@ -3667,7 +3670,7 @@ plot_euler_single <- function(data) { ######## -#### Current file: R//plot_hbar.R +#### Current file: /Users/au301842/FreesearchR/R//plot_hbar.R ######## #' Nice horizontal stacked bars (Grotta bars) @@ -3768,7 +3771,7 @@ vertical_stacked_bars <- function(data, ######## -#### Current file: R//plot_ridge.R +#### Current file: /Users/au301842/FreesearchR/R//plot_ridge.R ######## #' Plot nice ridge plot @@ -3802,7 +3805,7 @@ plot_ridge <- function(data, x, y, z = NULL, ...) { ######## -#### Current file: R//plot_sankey.R +#### Current file: /Users/au301842/FreesearchR/R//plot_sankey.R ######## #' Readying data for sankey plot @@ -4008,7 +4011,7 @@ plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = N ######## -#### Current file: R//plot_scatter.R +#### Current file: /Users/au301842/FreesearchR/R//plot_scatter.R ######## #' Beautiful violin plot @@ -4039,7 +4042,7 @@ plot_scatter <- function(data, x, y, z = NULL) { ######## -#### Current file: R//plot_violin.R +#### Current file: /Users/au301842/FreesearchR/R//plot_violin.R ######## #' Beatiful violin plot @@ -4072,7 +4075,88 @@ plot_violin <- function(data, x, y, z = NULL) { ######## -#### Current file: R//redcap_read_shiny_module.R +#### Current file: /Users/au301842/FreesearchR/R//plot-download-module.R +######## + +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 + ) + }) + } + ) + } + ) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//redcap_read_shiny_module.R ######## #' Shiny module to browser and export REDCap data @@ -4659,14 +4743,14 @@ redcap_demo_app <- function() { ######## -#### Current file: R//redcap.R +#### Current file: /Users/au301842/FreesearchR/R//redcap.R ######## ######## -#### Current file: R//regression_model.R +#### Current file: /Users/au301842/FreesearchR/R//regression_model.R ######## #' Create a regression model programatically @@ -4805,6 +4889,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)) @@ -5329,7 +5415,7 @@ regression_model_uv_list <- function(data, ######## -#### Current file: R//regression_plot.R +#### Current file: /Users/au301842/FreesearchR/R//regression_plot.R ######## #' Regression coef plot from gtsummary. Slightly modified to pass on arguments @@ -5493,7 +5579,7 @@ symmetrical_scale_x_log10 <- function(plot, breaks = c(1, 2, 3, 5, 10), ...) { ######## -#### Current file: R//regression_table.R +#### Current file: /Users/au301842/FreesearchR/R//regression_table.R ######## #' Create table of regression model @@ -5522,7 +5608,8 @@ symmetrical_scale_x_log10 <- function(plot, breaks = c(1, 2, 3, 5, 10), ...) { #' formula.str = "{outcome.str}~.", #' args.list = NULL #' ) |> -#' regression_table() |> plot() +#' regression_table() |> +#' plot() #' gtsummary::trial |> #' regression_model( #' outcome.str = "trt", @@ -5559,7 +5646,7 @@ symmetrical_scale_x_log10 <- function(plot, breaks = c(1, 2, 3, 5, 10), ...) { #' }) |> #' purrr::map(regression_table) |> #' tbl_merge() -#' } +#' } #' regression_table <- function(x, ...) { #' UseMethod("regression_table") #' } @@ -5592,9 +5679,8 @@ symmetrical_scale_x_log10 <- function(plot, breaks = c(1, 2, 3, 5, 10), ...) { #' 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, ...) |> @@ -5602,24 +5688,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 } @@ -5644,7 +5748,603 @@ tbl_merge <- function(data) { ######## -#### Current file: R//report.R +#### Current file: /Users/au301842/FreesearchR/R//regression-module.R +######## + +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) + })) + } + ) +} + + + +#' Title +#' +#' @returns +#' @export +#' +#' @examples +#' \dontrun{ +#' regression_demo_app() +#' } +regression_demo_app <- function() { + ui <- bslib::page_fixed( + do.call( + bslib::navset_bar, + regression_ui("regression") + ) + ) + server <- function(input, output, session) { + regression_server("regression", data = default_parsing(mtcars[1:3])) + } + shiny::shinyApp(ui, server) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//report.R ######## #' Split vector by an index and embed addition @@ -5732,7 +6432,7 @@ modify_qmd <- function(file, format) { ######## -#### Current file: R//theme.R +#### Current file: /Users/au301842/FreesearchR/R//theme.R ######## #' Custom theme based on unity @@ -5813,7 +6513,7 @@ gg_theme_export <- function(){ ######## -#### Current file: R//update-factor-ext.R +#### Current file: /Users/au301842/FreesearchR/R//update-factor-ext.R ######## @@ -6110,7 +6810,7 @@ winbox_update_factor <- function(id, ######## -#### Current file: R//update-variables-ext.R +#### Current file: /Users/au301842/FreesearchR/R//update-variables-ext.R ######## library(data.table) @@ -6194,7 +6894,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%" @@ -6252,15 +6952,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, @@ -6280,7 +6974,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") @@ -6299,7 +6993,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)) @@ -6366,6 +7059,8 @@ update_variables_server <- function(id, ignoreInit = TRUE ) + # shiny::observeEvent(input$close, + # { return(shiny::reactive({ data <- updated_data$x code <- list() @@ -6392,24 +7087,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 @@ -6733,7 +7466,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) @@ -6748,7 +7485,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]], ...) @@ -6862,8 +7599,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 @@ -6873,18 +7610,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() @@ -6892,7 +7630,7 @@ clean_date <- function(data){ ######## -#### Current file: R//wide2long.R +#### Current file: /Users/au301842/FreesearchR/R//wide2long.R ######## #' Alternative pivoting method for easily pivoting based on name pattern @@ -7202,27 +7940,34 @@ ui_elements <- list( ), shiny::column( width = 3, + shiny::actionButton( + inputId = "modal_browse", + label = "Browse data", + width = "100%" + ), + shiny::tags$br(), + shiny::tags$br(), IDEAFilter::IDEAFilter_ui("data_filter"), shiny::tags$br() ) ) ), - bslib::nav_panel( - title = "Browse", - tags$h3("Browse the provided data"), - shiny::tags$p( - "Below is a table with all the modified data provided to browse and understand data." - ), - shinyWidgets::html_dependency_winbox(), - fluidRow( - toastui::datagridOutput(outputId = "table_mod") - ), - shiny::tags$br(), - shiny::tags$br(), - shiny::tags$br(), - shiny::tags$br(), - shiny::tags$br() - ), + # bslib::nav_panel( + # title = "Browse", + # tags$h3("Browse the provided data"), + # shiny::tags$p( + # "Below is a table with all the modified data provided to browse and understand data." + # ), + # shinyWidgets::html_dependency_winbox(), + # fluidRow( + # toastui::datagridOutput(outputId = "table_mod") + # ), + # shiny::tags$br(), + # shiny::tags$br(), + # shiny::tags$br(), + # shiny::tags$br(), + # shiny::tags$br() + # ), bslib::nav_panel( title = "Modify", tags$h3("Subset, rename and convert variables"), @@ -7234,26 +7979,31 @@ ui_elements <- list( ), shiny::tags$br(), shiny::tags$br(), + update_variables_ui("modal_variables"), + shiny::tags$br(), + shiny::tags$br(), fluidRow( shiny::column( width = 2 ), shiny::column( width = 8, + tags$h4("Advanced data manipulation"), + shiny::tags$br(), fluidRow( shiny::column( width = 6, - tags$h4("Update or modify variables"), - shiny::tags$br(), - shiny::actionButton( - inputId = "modal_variables", - label = "Subset, rename and change class/type", - width = "100%" - ), - shiny::tags$br(), - shiny::helpText("Subset variables, rename variables and labels, and apply new class to variables"), - shiny::tags$br(), - shiny::tags$br(), + # tags$h4("Update or modify variables"), + # shiny::tags$br(), + # shiny::actionButton( + # inputId = "modal_variables", + # label = "Subset, rename and change class/type", + # width = "100%" + # ), + # shiny::tags$br(), + # shiny::helpText("Subset variables, rename variables and labels, and apply new class to variables"), + # shiny::tags$br(), + # shiny::tags$br(), shiny::actionButton( inputId = "modal_update", label = "Reorder factor levels", @@ -7262,12 +8012,21 @@ ui_elements <- list( shiny::tags$br(), shiny::helpText("Reorder the levels of factor/categorical variables."), shiny::tags$br(), + shiny::tags$br(), + 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::column( width = 6, - tags$h4("Create new variables"), - shiny::tags$br(), + # tags$h4("Create new variables"), + # shiny::tags$br(), shiny::actionButton( inputId = "modal_cut", label = "New factor", @@ -7287,15 +8046,15 @@ ui_elements <- list( 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.") + ) # , + # 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::column( width = 2 @@ -7303,10 +8062,10 @@ ui_elements <- list( ), shiny::tags$br(), shiny::tags$br(), - tags$h4("Restore"), + tags$h4("Compare modified data to original"), shiny::tags$br(), shiny::tags$p( - "Below, you'll find a raw overview of the original vs the modified data." + "Here is a overview of the original vs the modified data." ), shiny::tags$br(), shiny::tags$br(), @@ -7441,110 +8200,114 @@ ui_elements <- list( bslib::nav_panel( title = "Regression", id = "navanalyses", - bslib::navset_bar( - title = "", - # bslib::layout_sidebar( - # fillable = TRUE, - sidebar = bslib::sidebar( - shiny::uiOutput(outputId = "data_info_regression", inline = TRUE), - bslib::accordion( - open = "acc_reg", - multiple = FALSE, - 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"), - shiny::radioButtons( - inputId = "add_regression_p", - label = "Add p-value", - inline = TRUE, - selected = "yes", - choices = list( - "Yes" = "yes", - "No" = "no" - ) - ), - bslib::input_task_button( - id = "load", - label = "Analyse", - # icon = shiny::icon("pencil", lib = "glyphicon"), - 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(), - shiny::uiOutput("plot_model") - ), - bslib::accordion_panel( - value = "acc_advanced", - title = "Advanced", - icon = bsicons::bs_icon("gear"), - 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("regression_vars") - ) - ) - ), - # 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 = "Regression table", - gt::gt_output(outputId = "table2") - ), - bslib::nav_panel( - title = "Coefficient plot", - shiny::plotOutput(outputId = "regression_plot") - ), - bslib::nav_panel( - title = "Model checks", - shiny::plotOutput(outputId = "check") - # shiny::uiOutput(outputId = "check_1") - ) + do.call( + bslib::navset_bar, + regression_ui("regression") ) + # bslib::navset_bar( + # title = "", + # # bslib::layout_sidebar( + # # fillable = TRUE, + # sidebar = bslib::sidebar( + # shiny::uiOutput(outputId = "data_info_regression", inline = TRUE), + # bslib::accordion( + # open = "acc_reg", + # multiple = FALSE, + # 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"), + # shiny::radioButtons( + # inputId = "add_regression_p", + # label = "Add p-value", + # inline = TRUE, + # selected = "yes", + # choices = list( + # "Yes" = "yes", + # "No" = "no" + # ) + # ), + # bslib::input_task_button( + # id = "load", + # label = "Analyse", + # # icon = shiny::icon("pencil", lib = "glyphicon"), + # 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(), + # shiny::uiOutput("plot_model") + # ), + # bslib::accordion_panel( + # value = "acc_advanced", + # title = "Advanced", + # icon = bsicons::bs_icon("gear"), + # 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("regression_vars") + # ) + # ) + # ), + # # 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 = "Regression table", + # gt::gt_output(outputId = "table2") + # ), + # bslib::nav_panel( + # title = "Coefficient plot", + # shiny::plotOutput(outputId = "regression_plot") + # ), + # bslib::nav_panel( + # title = "Model checks", + # shiny::plotOutput(outputId = "check") + # # shiny::uiOutput(outputId = "check_1") + # ) + # ) ), ############################################################################## ######### @@ -7691,7 +8454,7 @@ ui <- bslib::page_fixed( ), shiny::p( style = "margin: 1; color: #888;", - "AG Damsbo | v", app_version(), " | ",shiny::tags$a("AGPLv3 license", href = "https://github.com/agdamsbo/FreesearchR/blob/main/LICENSE.md", target = "_blank", rel = "noopener noreferrer")," | ", shiny::tags$a("Source on Github", href = "https://github.com/agdamsbo/FreesearchR/", target = "_blank", rel = "noopener noreferrer") + "AG Damsbo | v", app_version(), " | ", shiny::tags$a("AGPLv3 license", href = "https://github.com/agdamsbo/FreesearchR/blob/main/LICENSE.md", target = "_blank", rel = "noopener noreferrer"), " | ", shiny::tags$a("Source on Github", href = "https://github.com/agdamsbo/FreesearchR/", target = "_blank", rel = "noopener noreferrer") ), ) ) @@ -7779,6 +8542,7 @@ server <- function(input, output, session) { rv <- shiny::reactiveValues( list = list(), + regression = list(), ds = NULL, local_temp = NULL, ready = NULL, @@ -7869,7 +8633,7 @@ server <- function(input, output, session) { ), handlerExpr = { shiny::req(rv$data_temp) -# browser() + # browser() rv$data_original <- rv$data_temp |> dplyr::select(input$import_var) |> default_parsing() @@ -7955,7 +8719,12 @@ server <- function(input, output, session) { shiny::observeEvent( input$modal_variables, - modal_update_variables("modal_variables", title = "Update and select variables") + modal_update_variables( + id = "modal_variables", + title = "Update and select variables", + footer = tagList( + actionButton("ok", "OK") + )) ) output$data_info <- shiny::renderUI({ @@ -7963,12 +8732,6 @@ server <- function(input, output, session) { data_description(data_filter()) }) - output$data_info_regression <- shiny::renderUI({ - shiny::req(regression_vars()) - shiny::req(rv$list$data) - data_description(rv$list$data[regression_vars()]) - }) - ######### Create factor @@ -8052,7 +8815,7 @@ server <- function(input, output, session) { shiny::reactive(rv$data), shiny::reactive(rv$data_original), data_filter(), - regression_vars(), + # regression_vars(), input$complete_cutoff ), { @@ -8113,28 +8876,32 @@ server <- function(input, output, session) { pagination = 20 ) - tryCatch( - { - output$table_mod <- toastui::renderDatagrid({ - shiny::req(rv$data) - # data <- rv$data - toastui::datagrid( - # data = rv$data # , - data = data_filter(), - pagination = 10 - # bordered = TRUE, - # compact = TRUE, - # striped = TRUE - ) - }) - }, - warning = function(warn) { - showNotification(paste0(warn), type = "warning") - }, - error = function(err) { - showNotification(paste0(err), type = "err") - } - ) + observeEvent(input$modal_browse, { + datamods::show_data(REDCapCAST::fct_drop(rv$data_filtered), title = "Uploaded data overview", type = "modal") + }) + + # tryCatch( + # { + # output$table_mod <- toastui::renderDatagrid({ + # shiny::req(rv$data) + # # data <- rv$data + # toastui::datagrid( + # # data = rv$data # , + # data = data_filter(), + # pagination = 10 + # # bordered = TRUE, + # # compact = TRUE, + # # striped = TRUE + # ) + # }) + # }, + # warning = function(warn) { + # showNotification(paste0(warn), type = "warning") + # }, + # error = function(err) { + # showNotification(paste0(err), type = "err") + # } + # ) output$original_str <- renderPrint({ str(rv$data_original) @@ -8190,65 +8957,65 @@ server <- function(input, output, session) { ## Keep these "old" selection options as a simple alternative to the modification pane - output$regression_vars <- shiny::renderUI({ - columnSelectInput( - inputId = "regression_vars", - selected = NULL, - label = "Covariables to include", - data = rv$data_filtered, - multiple = TRUE, - ) - }) - - output$outcome_var <- shiny::renderUI({ - columnSelectInput( - inputId = "outcome_var", - selected = NULL, - label = "Select outcome variable", - data = rv$data_filtered, - multiple = FALSE - ) - }) - - output$regression_type <- shiny::renderUI({ - shiny::req(input$outcome_var) - shiny::selectizeInput( - inputId = "regression_type", - label = "Choose regression analysis", - ## The below ifelse statement handles the case of loading a new dataset - choices = possible_functions( - data = dplyr::select( - rv$data_filtered, - ifelse(input$outcome_var %in% names(rv$data_filtered), - input$outcome_var, - names(rv$data_filtered)[1] - ) - ), design = "cross-sectional" - ), - 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 - ) - }) - - ## Collected regression variables - regression_vars <- shiny::reactive({ - if (is.null(input$regression_vars)) { - out <- colnames(rv$data_filtered) - } else { - out <- unique(c(input$regression_vars, input$outcome_var)) - } - return(out) - }) - + # output$regression_vars <- shiny::renderUI({ + # columnSelectInput( + # inputId = "regression_vars", + # selected = NULL, + # label = "Covariables to include", + # data = rv$data_filtered, + # multiple = TRUE, + # ) + # }) + # + # output$outcome_var <- shiny::renderUI({ + # columnSelectInput( + # inputId = "outcome_var", + # selected = NULL, + # label = "Select outcome variable", + # data = rv$data_filtered, + # multiple = FALSE + # ) + # }) + # + # output$regression_type <- shiny::renderUI({ + # shiny::req(input$outcome_var) + # shiny::selectizeInput( + # inputId = "regression_type", + # label = "Choose regression analysis", + # ## The below ifelse statement handles the case of loading a new dataset + # choices = possible_functions( + # data = dplyr::select( + # rv$data_filtered, + # ifelse(input$outcome_var %in% names(rv$data_filtered), + # input$outcome_var, + # names(rv$data_filtered)[1] + # ) + # ), design = "cross-sectional" + # ), + # 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 + # ) + # }) + # + # ## Collected regression variables + # regression_vars <- shiny::reactive({ + # if (is.null(input$regression_vars)) { + # out <- colnames(rv$data_filtered) + # } else { + # out <- unique(c(input$regression_vars, input$outcome_var)) + # } + # return(out) + # }) + # output$strat_var <- shiny::renderUI({ columnSelectInput( inputId = "strat_var", @@ -8261,18 +9028,18 @@ server <- function(input, output, session) { ) ) }) - - - output$plot_model <- shiny::renderUI({ - shiny::req(rv$list$regression$tables) - shiny::selectInput( - inputId = "plot_model", - selected = "none", - label = "Select models to plot", - choices = names(rv$list$regression$tables), - multiple = TRUE - ) - }) + # + # + # output$plot_model <- shiny::renderUI({ + # shiny::req(rv$list$regression$tables) + # shiny::selectInput( + # inputId = "plot_model", + # selected = "none", + # label = "Select models to plot", + # choices = names(rv$list$regression$tables), + # multiple = TRUE + # ) + # }) ############################################################################## @@ -8360,193 +9127,197 @@ server <- function(input, output, session) { ######### ############################################################################## - shiny::observeEvent( - input$load, - { - shiny::req(input$outcome_var) - # browser() - # Assumes all character variables can be formatted as factors - # data <- data_filter$filtered() |> - 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 = rv$list$data |> - (\(.x){ - .x[regression_vars()] - })()), - list(outcome.str = input$outcome_var), - list(fun.descr = input$regression_type) - ) - ) - }) + rv$regression <- regression_server("regression", data = shiny::reactive(rv$data_filtered)) - # browser() + # rv$list$regression <- regression_server("regression", data = shiny::reactive(rv$data_filtered)) - rv$list$regression$params <- get_fun_options(input$regression_type) |> - (\(.x){ - .x[[1]] - })() - - rv$list$regression$models <- model_lists - - # names(rv$list$regression) - - # 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$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") - } - ) - } - ) - - output$check <- shiny::renderPlot( - { - shiny::req(rv$check) - # browser() - # p <- plot(rv$check) + - # patchwork::plot_annotation(title = "Multivariable regression model checks") - - p <- plot(rv$check) + - patchwork::plot_annotation(title = "Multivariable regression model checks") - - for (i in seq_len(length(p))) { - p[[i]] <- p[[i]] + gg_theme_shiny() - } - - p - - # p + patchwork::plot_layout(ncol = 1, design = ggplot2::waiver()) - - # 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') - }, - height = 600, - alt = "Assumptions testing of the multivariable regression model" - ) - - - shiny::observeEvent( - input$load, - { - shiny::req(rv$list$regression$models) - 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$regression$table <- out |> - # tbl_merge() - - # gtsummary::as_kable(rv$list$regression$table) |> - # readr::write_lines(file="./www/_regression_table.md") - - 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") - } - ) - rv$ready <- "ready" - } - ) - - 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}**"))) - }) - - output$regression_plot <- shiny::renderPlot( - { - # shiny::req(rv$list$regression$plot) - shiny::req(input$plot_model) - - out <- merge_long(rv$list$regression, input$plot_model) |> - plot.tbl_regression( - colour = "variable", - facet_col = "model" - ) - - out + - ggplot2::scale_y_discrete(labels = scales::label_wrap(15)) + - gg_theme_shiny() - - # rv$list$regression$tables$Multivariable |> - # plot(colour = "variable") + - # ggplot2::scale_y_discrete(labels = scales::label_wrap(15)) + - # gg_theme_shiny() - }, - height = 500, - alt = "Regression coefficient plot" - ) + # shiny::observeEvent( + # input$load, + # { + # shiny::req(input$outcome_var) + # # browser() + # # Assumes all character variables can be formatted as factors + # # data <- data_filter$filtered() |> + # 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 = rv$list$data |> + # (\(.x){ + # .x[regression_vars()] + # })()), + # list(outcome.str = input$outcome_var), + # list(fun.descr = input$regression_type) + # ) + # ) + # }) + # + # # browser() + # + # rv$list$regression$params <- get_fun_options(input$regression_type) |> + # (\(.x){ + # .x[[1]] + # })() + # + # rv$list$regression$models <- model_lists + # + # # names(rv$list$regression) + # + # # 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$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") + # } + # ) + # } + # ) + # + # output$check <- shiny::renderPlot( + # { + # shiny::req(rv$check) + # # browser() + # # p <- plot(rv$check) + + # # patchwork::plot_annotation(title = "Multivariable regression model checks") + # + # p <- plot(rv$check) + + # patchwork::plot_annotation(title = "Multivariable regression model checks") + # + # for (i in seq_len(length(p))) { + # p[[i]] <- p[[i]] + gg_theme_shiny() + # } + # + # p + # + # # p + patchwork::plot_layout(ncol = 1, design = ggplot2::waiver()) + # + # # 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') + # }, + # height = 600, + # alt = "Assumptions testing of the multivariable regression model" + # ) + # + # + # shiny::observeEvent( + # input$load, + # { + # shiny::req(rv$list$regression$models) + # 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$regression$table <- out |> + # # tbl_merge() + # + # # gtsummary::as_kable(rv$list$regression$table) |> + # # readr::write_lines(file="./www/_regression_table.md") + # + # 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") + # } + # ) + # rv$ready <- "ready" + # } + # ) + # + # 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}**"))) + # }) + # + # output$regression_plot <- shiny::renderPlot( + # { + # # shiny::req(rv$list$regression$plot) + # shiny::req(input$plot_model) + # + # out <- merge_long(rv$list$regression, input$plot_model) |> + # plot.tbl_regression( + # colour = "variable", + # facet_col = "model" + # ) + # + # out + + # ggplot2::scale_y_discrete(labels = scales::label_wrap(15)) + + # gg_theme_shiny() + # + # # rv$list$regression$tables$Multivariable |> + # # plot(colour = "variable") + + # # ggplot2::scale_y_discrete(labels = scales::label_wrap(15)) + + # # gg_theme_shiny() + # }, + # height = 500, + # alt = "Regression coefficient plot" + # ) # shiny::conditionalPanel( # condition = "output.uploaded == 'yes'", @@ -8616,21 +9387,26 @@ server <- function(input, output, session) { # shiny::req(rv$list$regression) ## Notification is not progressing ## Presumably due to missing - + # browser() # Simplified for .rmd output attempt format <- ifelse(type == "docx", "word_document", "odt_document") - shiny::withProgress(message = "Generating the report. Hold on for a moment..", { - rv$list |> - write_rmd( - output_format = format, - input = file.path(getwd(), "www/report.rmd") - ) + # browser() + rv$list$regression <- rv$regression() - # write_quarto( - # output_format = type, - # input = file.path(getwd(), "www/report.qmd") - # ) + shiny::withProgress(message = "Generating the report. Hold on for a moment..", { + tryCatch( + { + rv$list |> + write_rmd( + output_format = format, + input = file.path(getwd(), "www/report.rmd") + ) + }, + error = function(err) { + showNotification(paste0("We encountered the following error creating your report: ", err), type = "err") + } + ) }) file.rename(paste0("www/report.", type), file) } diff --git a/inst/apps/FreesearchR/server.R b/inst/apps/FreesearchR/server.R index 1a61ad0..6e66330 100644 --- a/inst/apps/FreesearchR/server.R +++ b/inst/apps/FreesearchR/server.R @@ -75,6 +75,7 @@ server <- function(input, output, session) { rv <- shiny::reactiveValues( list = list(), + regression = list(), ds = NULL, local_temp = NULL, ready = NULL, @@ -165,7 +166,7 @@ server <- function(input, output, session) { ), handlerExpr = { shiny::req(rv$data_temp) -# browser() + # browser() rv$data_original <- rv$data_temp |> dplyr::select(input$import_var) |> default_parsing() @@ -251,7 +252,12 @@ server <- function(input, output, session) { shiny::observeEvent( input$modal_variables, - modal_update_variables("modal_variables", title = "Update and select variables") + modal_update_variables( + id = "modal_variables", + title = "Update and select variables", + footer = tagList( + actionButton("ok", "OK") + )) ) output$data_info <- shiny::renderUI({ @@ -259,12 +265,6 @@ server <- function(input, output, session) { data_description(data_filter()) }) - output$data_info_regression <- shiny::renderUI({ - shiny::req(regression_vars()) - shiny::req(rv$list$data) - data_description(rv$list$data[regression_vars()]) - }) - ######### Create factor @@ -348,7 +348,7 @@ server <- function(input, output, session) { shiny::reactive(rv$data), shiny::reactive(rv$data_original), data_filter(), - regression_vars(), + # regression_vars(), input$complete_cutoff ), { @@ -409,28 +409,32 @@ server <- function(input, output, session) { pagination = 20 ) - tryCatch( - { - output$table_mod <- toastui::renderDatagrid({ - shiny::req(rv$data) - # data <- rv$data - toastui::datagrid( - # data = rv$data # , - data = data_filter(), - pagination = 10 - # bordered = TRUE, - # compact = TRUE, - # striped = TRUE - ) - }) - }, - warning = function(warn) { - showNotification(paste0(warn), type = "warning") - }, - error = function(err) { - showNotification(paste0(err), type = "err") - } - ) + observeEvent(input$modal_browse, { + datamods::show_data(REDCapCAST::fct_drop(rv$data_filtered), title = "Uploaded data overview", type = "modal") + }) + + # tryCatch( + # { + # output$table_mod <- toastui::renderDatagrid({ + # shiny::req(rv$data) + # # data <- rv$data + # toastui::datagrid( + # # data = rv$data # , + # data = data_filter(), + # pagination = 10 + # # bordered = TRUE, + # # compact = TRUE, + # # striped = TRUE + # ) + # }) + # }, + # warning = function(warn) { + # showNotification(paste0(warn), type = "warning") + # }, + # error = function(err) { + # showNotification(paste0(err), type = "err") + # } + # ) output$original_str <- renderPrint({ str(rv$data_original) @@ -486,65 +490,65 @@ server <- function(input, output, session) { ## Keep these "old" selection options as a simple alternative to the modification pane - output$regression_vars <- shiny::renderUI({ - columnSelectInput( - inputId = "regression_vars", - selected = NULL, - label = "Covariables to include", - data = rv$data_filtered, - multiple = TRUE, - ) - }) - - output$outcome_var <- shiny::renderUI({ - columnSelectInput( - inputId = "outcome_var", - selected = NULL, - label = "Select outcome variable", - data = rv$data_filtered, - multiple = FALSE - ) - }) - - output$regression_type <- shiny::renderUI({ - shiny::req(input$outcome_var) - shiny::selectizeInput( - inputId = "regression_type", - label = "Choose regression analysis", - ## The below ifelse statement handles the case of loading a new dataset - choices = possible_functions( - data = dplyr::select( - rv$data_filtered, - ifelse(input$outcome_var %in% names(rv$data_filtered), - input$outcome_var, - names(rv$data_filtered)[1] - ) - ), design = "cross-sectional" - ), - 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 - ) - }) - - ## Collected regression variables - regression_vars <- shiny::reactive({ - if (is.null(input$regression_vars)) { - out <- colnames(rv$data_filtered) - } else { - out <- unique(c(input$regression_vars, input$outcome_var)) - } - return(out) - }) - + # output$regression_vars <- shiny::renderUI({ + # columnSelectInput( + # inputId = "regression_vars", + # selected = NULL, + # label = "Covariables to include", + # data = rv$data_filtered, + # multiple = TRUE, + # ) + # }) + # + # output$outcome_var <- shiny::renderUI({ + # columnSelectInput( + # inputId = "outcome_var", + # selected = NULL, + # label = "Select outcome variable", + # data = rv$data_filtered, + # multiple = FALSE + # ) + # }) + # + # output$regression_type <- shiny::renderUI({ + # shiny::req(input$outcome_var) + # shiny::selectizeInput( + # inputId = "regression_type", + # label = "Choose regression analysis", + # ## The below ifelse statement handles the case of loading a new dataset + # choices = possible_functions( + # data = dplyr::select( + # rv$data_filtered, + # ifelse(input$outcome_var %in% names(rv$data_filtered), + # input$outcome_var, + # names(rv$data_filtered)[1] + # ) + # ), design = "cross-sectional" + # ), + # 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 + # ) + # }) + # + # ## Collected regression variables + # regression_vars <- shiny::reactive({ + # if (is.null(input$regression_vars)) { + # out <- colnames(rv$data_filtered) + # } else { + # out <- unique(c(input$regression_vars, input$outcome_var)) + # } + # return(out) + # }) + # output$strat_var <- shiny::renderUI({ columnSelectInput( inputId = "strat_var", @@ -557,18 +561,18 @@ server <- function(input, output, session) { ) ) }) - - - output$plot_model <- shiny::renderUI({ - shiny::req(rv$list$regression$tables) - shiny::selectInput( - inputId = "plot_model", - selected = "none", - label = "Select models to plot", - choices = names(rv$list$regression$tables), - multiple = TRUE - ) - }) + # + # + # output$plot_model <- shiny::renderUI({ + # shiny::req(rv$list$regression$tables) + # shiny::selectInput( + # inputId = "plot_model", + # selected = "none", + # label = "Select models to plot", + # choices = names(rv$list$regression$tables), + # multiple = TRUE + # ) + # }) ############################################################################## @@ -656,193 +660,197 @@ server <- function(input, output, session) { ######### ############################################################################## - shiny::observeEvent( - input$load, - { - shiny::req(input$outcome_var) - # browser() - # Assumes all character variables can be formatted as factors - # data <- data_filter$filtered() |> - 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 = rv$list$data |> - (\(.x){ - .x[regression_vars()] - })()), - list(outcome.str = input$outcome_var), - list(fun.descr = input$regression_type) - ) - ) - }) + rv$regression <- regression_server("regression", data = shiny::reactive(rv$data_filtered)) - # browser() + # rv$list$regression <- regression_server("regression", data = shiny::reactive(rv$data_filtered)) - rv$list$regression$params <- get_fun_options(input$regression_type) |> - (\(.x){ - .x[[1]] - })() - - rv$list$regression$models <- model_lists - - # names(rv$list$regression) - - # 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$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") - } - ) - } - ) - - output$check <- shiny::renderPlot( - { - shiny::req(rv$check) - # browser() - # p <- plot(rv$check) + - # patchwork::plot_annotation(title = "Multivariable regression model checks") - - p <- plot(rv$check) + - patchwork::plot_annotation(title = "Multivariable regression model checks") - - for (i in seq_len(length(p))) { - p[[i]] <- p[[i]] + gg_theme_shiny() - } - - p - - # p + patchwork::plot_layout(ncol = 1, design = ggplot2::waiver()) - - # 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') - }, - height = 600, - alt = "Assumptions testing of the multivariable regression model" - ) - - - shiny::observeEvent( - input$load, - { - shiny::req(rv$list$regression$models) - 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$regression$table <- out |> - # tbl_merge() - - # gtsummary::as_kable(rv$list$regression$table) |> - # readr::write_lines(file="./www/_regression_table.md") - - 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") - } - ) - rv$ready <- "ready" - } - ) - - 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}**"))) - }) - - output$regression_plot <- shiny::renderPlot( - { - # shiny::req(rv$list$regression$plot) - shiny::req(input$plot_model) - - out <- merge_long(rv$list$regression, input$plot_model) |> - plot.tbl_regression( - colour = "variable", - facet_col = "model" - ) - - out + - ggplot2::scale_y_discrete(labels = scales::label_wrap(15)) + - gg_theme_shiny() - - # rv$list$regression$tables$Multivariable |> - # plot(colour = "variable") + - # ggplot2::scale_y_discrete(labels = scales::label_wrap(15)) + - # gg_theme_shiny() - }, - height = 500, - alt = "Regression coefficient plot" - ) + # shiny::observeEvent( + # input$load, + # { + # shiny::req(input$outcome_var) + # # browser() + # # Assumes all character variables can be formatted as factors + # # data <- data_filter$filtered() |> + # 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 = rv$list$data |> + # (\(.x){ + # .x[regression_vars()] + # })()), + # list(outcome.str = input$outcome_var), + # list(fun.descr = input$regression_type) + # ) + # ) + # }) + # + # # browser() + # + # rv$list$regression$params <- get_fun_options(input$regression_type) |> + # (\(.x){ + # .x[[1]] + # })() + # + # rv$list$regression$models <- model_lists + # + # # names(rv$list$regression) + # + # # 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$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") + # } + # ) + # } + # ) + # + # output$check <- shiny::renderPlot( + # { + # shiny::req(rv$check) + # # browser() + # # p <- plot(rv$check) + + # # patchwork::plot_annotation(title = "Multivariable regression model checks") + # + # p <- plot(rv$check) + + # patchwork::plot_annotation(title = "Multivariable regression model checks") + # + # for (i in seq_len(length(p))) { + # p[[i]] <- p[[i]] + gg_theme_shiny() + # } + # + # p + # + # # p + patchwork::plot_layout(ncol = 1, design = ggplot2::waiver()) + # + # # 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') + # }, + # height = 600, + # alt = "Assumptions testing of the multivariable regression model" + # ) + # + # + # shiny::observeEvent( + # input$load, + # { + # shiny::req(rv$list$regression$models) + # 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$regression$table <- out |> + # # tbl_merge() + # + # # gtsummary::as_kable(rv$list$regression$table) |> + # # readr::write_lines(file="./www/_regression_table.md") + # + # 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") + # } + # ) + # rv$ready <- "ready" + # } + # ) + # + # 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}**"))) + # }) + # + # output$regression_plot <- shiny::renderPlot( + # { + # # shiny::req(rv$list$regression$plot) + # shiny::req(input$plot_model) + # + # out <- merge_long(rv$list$regression, input$plot_model) |> + # plot.tbl_regression( + # colour = "variable", + # facet_col = "model" + # ) + # + # out + + # ggplot2::scale_y_discrete(labels = scales::label_wrap(15)) + + # gg_theme_shiny() + # + # # rv$list$regression$tables$Multivariable |> + # # plot(colour = "variable") + + # # ggplot2::scale_y_discrete(labels = scales::label_wrap(15)) + + # # gg_theme_shiny() + # }, + # height = 500, + # alt = "Regression coefficient plot" + # ) # shiny::conditionalPanel( # condition = "output.uploaded == 'yes'", @@ -912,21 +920,26 @@ server <- function(input, output, session) { # shiny::req(rv$list$regression) ## Notification is not progressing ## Presumably due to missing - + # browser() # Simplified for .rmd output attempt format <- ifelse(type == "docx", "word_document", "odt_document") - shiny::withProgress(message = "Generating the report. Hold on for a moment..", { - rv$list |> - write_rmd( - output_format = format, - input = file.path(getwd(), "www/report.rmd") - ) + # browser() + rv$list$regression <- rv$regression() - # write_quarto( - # output_format = type, - # input = file.path(getwd(), "www/report.qmd") - # ) + shiny::withProgress(message = "Generating the report. Hold on for a moment..", { + tryCatch( + { + rv$list |> + write_rmd( + output_format = format, + input = file.path(getwd(), "www/report.rmd") + ) + }, + error = function(err) { + showNotification(paste0("We encountered the following error creating your report: ", err), type = "err") + } + ) }) file.rename(paste0("www/report.", type), file) } diff --git a/inst/apps/FreesearchR/ui.R b/inst/apps/FreesearchR/ui.R index 1683c79..81c0fa8 100644 --- a/inst/apps/FreesearchR/ui.R +++ b/inst/apps/FreesearchR/ui.R @@ -146,27 +146,34 @@ ui_elements <- list( ), shiny::column( width = 3, + shiny::actionButton( + inputId = "modal_browse", + label = "Browse data", + width = "100%" + ), + shiny::tags$br(), + shiny::tags$br(), IDEAFilter::IDEAFilter_ui("data_filter"), shiny::tags$br() ) ) ), - bslib::nav_panel( - title = "Browse", - tags$h3("Browse the provided data"), - shiny::tags$p( - "Below is a table with all the modified data provided to browse and understand data." - ), - shinyWidgets::html_dependency_winbox(), - fluidRow( - toastui::datagridOutput(outputId = "table_mod") - ), - shiny::tags$br(), - shiny::tags$br(), - shiny::tags$br(), - shiny::tags$br(), - shiny::tags$br() - ), + # bslib::nav_panel( + # title = "Browse", + # tags$h3("Browse the provided data"), + # shiny::tags$p( + # "Below is a table with all the modified data provided to browse and understand data." + # ), + # shinyWidgets::html_dependency_winbox(), + # fluidRow( + # toastui::datagridOutput(outputId = "table_mod") + # ), + # shiny::tags$br(), + # shiny::tags$br(), + # shiny::tags$br(), + # shiny::tags$br(), + # shiny::tags$br() + # ), bslib::nav_panel( title = "Modify", tags$h3("Subset, rename and convert variables"), @@ -178,26 +185,31 @@ ui_elements <- list( ), shiny::tags$br(), shiny::tags$br(), + update_variables_ui("modal_variables"), + shiny::tags$br(), + shiny::tags$br(), fluidRow( shiny::column( width = 2 ), shiny::column( width = 8, + tags$h4("Advanced data manipulation"), + shiny::tags$br(), fluidRow( shiny::column( width = 6, - tags$h4("Update or modify variables"), - shiny::tags$br(), - shiny::actionButton( - inputId = "modal_variables", - label = "Subset, rename and change class/type", - width = "100%" - ), - shiny::tags$br(), - shiny::helpText("Subset variables, rename variables and labels, and apply new class to variables"), - shiny::tags$br(), - shiny::tags$br(), + # tags$h4("Update or modify variables"), + # shiny::tags$br(), + # shiny::actionButton( + # inputId = "modal_variables", + # label = "Subset, rename and change class/type", + # width = "100%" + # ), + # shiny::tags$br(), + # shiny::helpText("Subset variables, rename variables and labels, and apply new class to variables"), + # shiny::tags$br(), + # shiny::tags$br(), shiny::actionButton( inputId = "modal_update", label = "Reorder factor levels", @@ -206,12 +218,21 @@ ui_elements <- list( shiny::tags$br(), shiny::helpText("Reorder the levels of factor/categorical variables."), shiny::tags$br(), + shiny::tags$br(), + 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::column( width = 6, - tags$h4("Create new variables"), - shiny::tags$br(), + # tags$h4("Create new variables"), + # shiny::tags$br(), shiny::actionButton( inputId = "modal_cut", label = "New factor", @@ -231,15 +252,15 @@ ui_elements <- list( 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.") + ) # , + # 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::column( width = 2 @@ -247,10 +268,10 @@ ui_elements <- list( ), shiny::tags$br(), shiny::tags$br(), - tags$h4("Restore"), + tags$h4("Compare modified data to original"), shiny::tags$br(), shiny::tags$p( - "Below, you'll find a raw overview of the original vs the modified data." + "Here is a overview of the original vs the modified data." ), shiny::tags$br(), shiny::tags$br(), @@ -385,110 +406,114 @@ ui_elements <- list( bslib::nav_panel( title = "Regression", id = "navanalyses", - bslib::navset_bar( - title = "", - # bslib::layout_sidebar( - # fillable = TRUE, - sidebar = bslib::sidebar( - shiny::uiOutput(outputId = "data_info_regression", inline = TRUE), - bslib::accordion( - open = "acc_reg", - multiple = FALSE, - 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"), - shiny::radioButtons( - inputId = "add_regression_p", - label = "Add p-value", - inline = TRUE, - selected = "yes", - choices = list( - "Yes" = "yes", - "No" = "no" - ) - ), - bslib::input_task_button( - id = "load", - label = "Analyse", - # icon = shiny::icon("pencil", lib = "glyphicon"), - 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(), - shiny::uiOutput("plot_model") - ), - bslib::accordion_panel( - value = "acc_advanced", - title = "Advanced", - icon = bsicons::bs_icon("gear"), - 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("regression_vars") - ) - ) - ), - # 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 = "Regression table", - gt::gt_output(outputId = "table2") - ), - bslib::nav_panel( - title = "Coefficient plot", - shiny::plotOutput(outputId = "regression_plot") - ), - bslib::nav_panel( - title = "Model checks", - shiny::plotOutput(outputId = "check") - # shiny::uiOutput(outputId = "check_1") - ) + do.call( + bslib::navset_bar, + regression_ui("regression") ) + # bslib::navset_bar( + # title = "", + # # bslib::layout_sidebar( + # # fillable = TRUE, + # sidebar = bslib::sidebar( + # shiny::uiOutput(outputId = "data_info_regression", inline = TRUE), + # bslib::accordion( + # open = "acc_reg", + # multiple = FALSE, + # 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"), + # shiny::radioButtons( + # inputId = "add_regression_p", + # label = "Add p-value", + # inline = TRUE, + # selected = "yes", + # choices = list( + # "Yes" = "yes", + # "No" = "no" + # ) + # ), + # bslib::input_task_button( + # id = "load", + # label = "Analyse", + # # icon = shiny::icon("pencil", lib = "glyphicon"), + # 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(), + # shiny::uiOutput("plot_model") + # ), + # bslib::accordion_panel( + # value = "acc_advanced", + # title = "Advanced", + # icon = bsicons::bs_icon("gear"), + # 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("regression_vars") + # ) + # ) + # ), + # # 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 = "Regression table", + # gt::gt_output(outputId = "table2") + # ), + # bslib::nav_panel( + # title = "Coefficient plot", + # shiny::plotOutput(outputId = "regression_plot") + # ), + # bslib::nav_panel( + # title = "Model checks", + # shiny::plotOutput(outputId = "check") + # # shiny::uiOutput(outputId = "check_1") + # ) + # ) ), ############################################################################## ######### @@ -635,7 +660,7 @@ ui <- bslib::page_fixed( ), shiny::p( style = "margin: 1; color: #888;", - "AG Damsbo | v", app_version(), " | ",shiny::tags$a("AGPLv3 license", href = "https://github.com/agdamsbo/FreesearchR/blob/main/LICENSE.md", target = "_blank", rel = "noopener noreferrer")," | ", shiny::tags$a("Source on Github", href = "https://github.com/agdamsbo/FreesearchR/", target = "_blank", rel = "noopener noreferrer") + "AG Damsbo | v", app_version(), " | ", shiny::tags$a("AGPLv3 license", href = "https://github.com/agdamsbo/FreesearchR/blob/main/LICENSE.md", target = "_blank", rel = "noopener noreferrer"), " | ", shiny::tags$a("Source on Github", href = "https://github.com/agdamsbo/FreesearchR/", target = "_blank", rel = "noopener noreferrer") ), ) ) diff --git a/inst/apps/FreesearchR/www/favicon.ico b/inst/apps/FreesearchR/www/favicon.ico new file mode 100644 index 0000000..569ed92 Binary files /dev/null and b/inst/apps/FreesearchR/www/favicon.ico differ diff --git a/inst/apps/FreesearchR/www/favicon.png b/inst/apps/FreesearchR/www/favicon.png index e284d2d..569ed92 100644 Binary files a/inst/apps/FreesearchR/www/favicon.png and b/inst/apps/FreesearchR/www/favicon.png differ diff --git a/inst/apps/FreesearchR/www/report.rmd b/inst/apps/FreesearchR/www/report.rmd index 803c520..b93d47e 100644 --- a/inst/apps/FreesearchR/www/report.rmd +++ b/inst/apps/FreesearchR/www/report.rmd @@ -15,6 +15,7 @@ knitr::opts_chunk$set(echo = FALSE, message = FALSE, warning = FALSE) ```{r} web_data <- readr::read_rds(file = params$data.file) +# web_data <- readr::read_rds(file = "~/FreesearchR/inst/apps/FreesearchR/www/web_data.rds") library(gtsummary) library(gt) @@ -52,21 +53,21 @@ Analyses were conducted in the *FreesearchR* data analysis web-tool based on R v Below are the baseline characteristics. ```{r, results = 'asis'} -if ("table1" %in% names(web_data)){ -tbl <- gtsummary::as_gt(web_data$table1) -knitr::knit_print(tbl)} +if ("table1" %in% names(web_data)) { + tbl <- gtsummary::as_gt(web_data$table1) + knitr::knit_print(tbl) +} ``` -`r if ("regression" %in% names(web_data)) glue::glue("Below are the results from the { tolower(vec2sentence(names(web_data$regression$tables)))} {web_data$regression$params$descr}.")` +`r if (length(web_data$regression) > 0) glue::glue("Below are the results from the { tolower(vec2sentence(names(web_data$regression$regression$tables)))} {web_data$regression$regression$params$descr}.")` ```{r, results = 'asis'} -if ("regression" %in% names(web_data)){ -reg_tbl <- web_data$regression$tables -knitr::knit_print(tbl_merge(reg_tbl)) +if ("regression" %in% names(web_data) && length(web_data$regression) > 0) { + reg_tbl <- web_data$regression$regression$tables + knitr::knit_print(tbl_merge(reg_tbl)) } ``` ## Discussion Good luck on your further work! - diff --git a/man/cor_demo_app.Rd b/man/cor_demo_app.Rd deleted file mode 100644 index fe1fe3c..0000000 --- a/man/cor_demo_app.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/correlations-module.R -\name{cor_demo_app} -\alias{cor_demo_app} -\title{Correlations plot demo app} -\usage{ -cor_demo_app() -} -\description{ -Correlations plot demo app -} -\examples{ -\dontrun{ -cor_demo_app() -} -} diff --git a/man/create_baseline.Rd b/man/create_baseline.Rd index 82e6fe1..1178917 100644 --- a/man/create_baseline.Rd +++ b/man/create_baseline.Rd @@ -4,7 +4,14 @@ \alias{create_baseline} \title{Create a baseline table} \usage{ -create_baseline(data, ..., by.var, add.p = FALSE, add.overall = FALSE) +create_baseline( + data, + ..., + by.var, + add.p = FALSE, + add.overall = FALSE, + theme = c("jama", "lancet", "nejm", "qjecon") +) } \arguments{ \item{data}{data} @@ -24,5 +31,5 @@ gtsummary table list object Create a baseline table } \examples{ -mtcars |> create_baseline(by.var = "gear", add.p="yes"=="yes") +mtcars |> create_baseline(by.var = "gear", add.p = "yes" == "yes") } diff --git a/man/regression_table.Rd b/man/regression_table.Rd index 71d5238..4a47c6f 100644 --- a/man/regression_table.Rd +++ b/man/regression_table.Rd @@ -36,7 +36,8 @@ gtsummary::trial |> formula.str = "{outcome.str}~.", args.list = NULL ) |> - regression_table() |> plot() + regression_table() |> + plot() gtsummary::trial |> regression_model( outcome.str = "trt", @@ -73,7 +74,7 @@ list( }) |> purrr::map(regression_table) |> tbl_merge() - } +} regression_table <- function(x, ...) { UseMethod("regression_table") } diff --git a/man/sort_by.Rd b/man/sort_by.Rd new file mode 100644 index 0000000..53632e8 --- /dev/null +++ b/man/sort_by.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/helpers.R +\name{sort_by} +\alias{sort_by} +\title{Drop-in replacement for the base::sort_by with option to remove NAs} +\usage{ +sort_by(x, y, na.rm = FALSE, ...) +} +\arguments{ +\item{x}{x} + +\item{y}{y} + +\item{na.rm}{remove NAs} + +\item{...}{passed to base_sort_by} +} +\value{ +vector +} +\description{ +Drop-in replacement for the base::sort_by with option to remove NAs +} +\examples{ +sort_by(c("Multivariable", "Univariable"),c("Univariable","Minimal","Multivariable")) +} diff --git a/renv.lock b/renv.lock index 72de09f..f615a69 100644 --- a/renv.lock +++ b/renv.lock @@ -674,11 +674,11 @@ }, "RcppArmadillo": { "Package": "RcppArmadillo", - "Version": "14.4.0-1", + "Version": "14.4.1-1", "Source": "Repository", "Type": "Package", "Title": "'Rcpp' Integration for the 'Armadillo' Templated Linear Algebra Library", - "Date": "2025-02-17", + "Date": "2025-03-27", "Authors@R": "c(person(\"Dirk\", \"Eddelbuettel\", role = c(\"aut\", \"cre\"), email = \"edd@debian.org\", comment = c(ORCID = \"0000-0001-6419-907X\")), person(\"Romain\", \"Francois\", role = \"aut\", comment = c(ORCID = \"0000-0002-2444-4226\")), person(\"Doug\", \"Bates\", role = \"aut\", comment = c(ORCID = \"0000-0001-8316-9503\")), person(\"Binxiang\", \"Ni\", role = \"aut\"), person(\"Conrad\", \"Sanderson\", role = \"aut\", comment = c(ORCID = \"0000-0002-0049-4501\")))", "Description": "'Armadillo' is a templated C++ linear algebra library (by Conrad Sanderson) that aims towards a good balance between speed and ease of use. Integer, floating point and complex numbers are supported, as well as a subset of trigonometric and statistics functions. Various matrix decompositions are provided through optional integration with LAPACK and ATLAS libraries. The 'RcppArmadillo' package includes the header files from the templated 'Armadillo' library. Thus users do not need to install 'Armadillo' itself in order to use 'RcppArmadillo'. From release 7.800.0 on, 'Armadillo' is licensed under Apache License 2; previous releases were under licensed as MPL 2.0 from version 3.800.0 onwards and LGPL-3 prior to that; 'RcppArmadillo' (the 'Rcpp' bindings/bridge to Armadillo) is licensed under the GNU GPL version 2 or later, as is the rest of 'Rcpp'.", "License": "GPL (>= 2)", @@ -783,7 +783,7 @@ }, "V8": { "Package": "V8", - "Version": "6.0.2", + "Version": "6.0.3", "Source": "Repository", "Type": "Package", "Title": "Embedded JavaScript and WebAssembly Engine for R", @@ -1231,7 +1231,7 @@ }, "broom": { "Package": "broom", - "Version": "1.0.7", + "Version": "1.0.8", "Source": "Repository", "Type": "Package", "Title": "Convert Statistical Objects into Tidy Tibbles", @@ -1245,12 +1245,13 @@ ], "Imports": [ "backports", + "cli", "dplyr (>= 1.0.0)", "generics (>= 0.0.2)", "glue", "lifecycle", "purrr", - "rlang", + "rlang (>= 1.1.0)", "stringr", "tibble (>= 3.0.0)", "tidyr (>= 1.0.0)" @@ -1315,7 +1316,6 @@ "multcomp", "network", "nnet", - "orcutt (>= 2.2)", "ordinal", "plm", "poLCA", @@ -1333,7 +1333,7 @@ "survey", "survival (>= 3.6-4)", "systemfit", - "testthat (>= 2.1.0)", + "testthat (>= 3.0.0)", "tseries", "vars", "zoo" @@ -1343,7 +1343,8 @@ "Encoding": "UTF-8", "RoxygenNote": "7.3.2", "Language": "en-US", - "Collate": "'aaa-documentation-helper.R' 'null-and-default-tidiers.R' 'aer-tidiers.R' 'auc-tidiers.R' 'base-tidiers.R' 'bbmle-tidiers.R' 'betareg-tidiers.R' 'biglm-tidiers.R' 'bingroup-tidiers.R' 'boot-tidiers.R' 'broom-package.R' 'broom.R' 'btergm-tidiers.R' 'car-tidiers.R' 'caret-tidiers.R' 'cluster-tidiers.R' 'cmprsk-tidiers.R' 'data-frame-tidiers.R' 'deprecated-0-7-0.R' 'drc-tidiers.R' 'emmeans-tidiers.R' 'epiR-tidiers.R' 'ergm-tidiers.R' 'fixest-tidiers.R' 'gam-tidiers.R' 'geepack-tidiers.R' 'glmnet-cv-glmnet-tidiers.R' 'glmnet-glmnet-tidiers.R' 'gmm-tidiers.R' 'hmisc-tidiers.R' 'joinerml-tidiers.R' 'kendall-tidiers.R' 'ks-tidiers.R' 'lavaan-tidiers.R' 'leaps-tidiers.R' 'lfe-tidiers.R' 'list-irlba.R' 'list-optim-tidiers.R' 'list-svd-tidiers.R' 'list-tidiers.R' 'list-xyz-tidiers.R' 'lm-beta-tidiers.R' 'lmodel2-tidiers.R' 'lmtest-tidiers.R' 'maps-tidiers.R' 'margins-tidiers.R' 'mass-fitdistr-tidiers.R' 'mass-negbin-tidiers.R' 'mass-polr-tidiers.R' 'mass-ridgelm-tidiers.R' 'stats-lm-tidiers.R' 'mass-rlm-tidiers.R' 'mclust-tidiers.R' 'mediation-tidiers.R' 'metafor-tidiers.R' 'mfx-tidiers.R' 'mgcv-tidiers.R' 'mlogit-tidiers.R' 'muhaz-tidiers.R' 'multcomp-tidiers.R' 'nnet-tidiers.R' 'nobs.R' 'orcutt-tidiers.R' 'ordinal-clm-tidiers.R' 'ordinal-clmm-tidiers.R' 'plm-tidiers.R' 'polca-tidiers.R' 'psych-tidiers.R' 'stats-nls-tidiers.R' 'quantreg-nlrq-tidiers.R' 'quantreg-rq-tidiers.R' 'quantreg-rqs-tidiers.R' 'robust-glmrob-tidiers.R' 'robust-lmrob-tidiers.R' 'robustbase-glmrob-tidiers.R' 'robustbase-lmrob-tidiers.R' 'sp-tidiers.R' 'spdep-tidiers.R' 'speedglm-speedglm-tidiers.R' 'speedglm-speedlm-tidiers.R' 'stats-anova-tidiers.R' 'stats-arima-tidiers.R' 'stats-decompose-tidiers.R' 'stats-factanal-tidiers.R' 'stats-glm-tidiers.R' 'stats-htest-tidiers.R' 'stats-kmeans-tidiers.R' 'stats-loess-tidiers.R' 'stats-mlm-tidiers.R' 'stats-prcomp-tidiers.R' 'stats-smooth.spline-tidiers.R' 'stats-summary-lm-tidiers.R' 'stats-time-series-tidiers.R' 'survey-tidiers.R' 'survival-aareg-tidiers.R' 'survival-cch-tidiers.R' 'survival-coxph-tidiers.R' 'survival-pyears-tidiers.R' 'survival-survdiff-tidiers.R' 'survival-survexp-tidiers.R' 'survival-survfit-tidiers.R' 'survival-survreg-tidiers.R' 'systemfit-tidiers.R' 'tseries-tidiers.R' 'utilities.R' 'vars-tidiers.R' 'zoo-tidiers.R' 'zzz.R'", + "Collate": "'aaa-documentation-helper.R' 'null-and-default.R' 'aer.R' 'auc.R' 'base.R' 'bbmle.R' 'betareg.R' 'biglm.R' 'bingroup.R' 'boot.R' 'broom-package.R' 'broom.R' 'btergm.R' 'car.R' 'caret.R' 'cluster.R' 'cmprsk.R' 'data-frame.R' 'deprecated-0-7-0.R' 'drc.R' 'emmeans.R' 'epiR.R' 'ergm.R' 'fixest.R' 'gam.R' 'geepack.R' 'glmnet-cv-glmnet.R' 'glmnet-glmnet.R' 'gmm.R' 'hmisc.R' 'import-standalone-obj-type.R' 'import-standalone-types-check.R' 'joinerml.R' 'kendall.R' 'ks.R' 'lavaan.R' 'leaps.R' 'lfe.R' 'list-irlba.R' 'list-optim.R' 'list-svd.R' 'list-xyz.R' 'list.R' 'lm-beta.R' 'lmodel2.R' 'lmtest.R' 'maps.R' 'margins.R' 'mass-fitdistr.R' 'mass-negbin.R' 'mass-polr.R' 'mass-ridgelm.R' 'stats-lm.R' 'mass-rlm.R' 'mclust.R' 'mediation.R' 'metafor.R' 'mfx.R' 'mgcv.R' 'mlogit.R' 'muhaz.R' 'multcomp.R' 'nnet.R' 'nobs.R' 'ordinal-clm.R' 'ordinal-clmm.R' 'plm.R' 'polca.R' 'psych.R' 'stats-nls.R' 'quantreg-nlrq.R' 'quantreg-rq.R' 'quantreg-rqs.R' 'robust-glmrob.R' 'robust-lmrob.R' 'robustbase-glmrob.R' 'robustbase-lmrob.R' 'sp.R' 'spdep.R' 'speedglm-speedglm.R' 'speedglm-speedlm.R' 'stats-anova.R' 'stats-arima.R' 'stats-decompose.R' 'stats-factanal.R' 'stats-glm.R' 'stats-htest.R' 'stats-kmeans.R' 'stats-loess.R' 'stats-mlm.R' 'stats-prcomp.R' 'stats-smooth.spline.R' 'stats-summary-lm.R' 'stats-time-series.R' 'survey.R' 'survival-aareg.R' 'survival-cch.R' 'survival-coxph.R' 'survival-pyears.R' 'survival-survdiff.R' 'survival-survexp.R' 'survival-survfit.R' 'survival-survreg.R' 'systemfit.R' 'tseries.R' 'utilities.R' 'vars.R' 'zoo.R' 'zzz.R'", + "Config/testthat/edition": "3", "NeedsCompilation": "no", "Author": "David Robinson [aut], Alex Hayes [aut] (), Simon Couch [aut, cre] (), Posit Software, PBC [cph, fnd], Indrajeet Patil [ctb] (), Derek Chiu [ctb], Matthieu Gomez [ctb], Boris Demeshev [ctb], Dieter Menne [ctb], Benjamin Nutter [ctb], Luke Johnston [ctb], Ben Bolker [ctb], Francois Briatte [ctb], Jeffrey Arnold [ctb], Jonah Gabry [ctb], Luciano Selzer [ctb], Gavin Simpson [ctb], Jens Preussner [ctb], Jay Hesselberth [ctb], Hadley Wickham [ctb], Matthew Lincoln [ctb], Alessandro Gasparini [ctb], Lukasz Komsta [ctb], Frederick Novometsky [ctb], Wilson Freitas [ctb], Michelle Evans [ctb], Jason Cory Brunson [ctb], Simon Jackson [ctb], Ben Whalley [ctb], Karissa Whiting [ctb], Yves Rosseel [ctb], Michael Kuehn [ctb], Jorge Cimentada [ctb], Erle Holgersen [ctb], Karl Dunkle Werner [ctb] (), Ethan Christensen [ctb], Steven Pav [ctb], Paul PJ [ctb], Ben Schneider [ctb], Patrick Kennedy [ctb], Lily Medina [ctb], Brian Fannin [ctb], Jason Muhlenkamp [ctb], Matt Lehman [ctb], Bill Denney [ctb] (), Nic Crane [ctb], Andrew Bates [ctb], Vincent Arel-Bundock [ctb] (), Hideaki Hayashi [ctb], Luis Tobalina [ctb], Annie Wang [ctb], Wei Yang Tham [ctb], Clara Wang [ctb], Abby Smith [ctb] (), Jasper Cooper [ctb] (), E Auden Krauska [ctb] (), Alex Wang [ctb], Malcolm Barrett [ctb] (), Charles Gray [ctb] (), Jared Wilber [ctb], Vilmantas Gegzna [ctb] (), Eduard Szoecs [ctb], Frederik Aust [ctb] (), Angus Moore [ctb], Nick Williams [ctb], Marius Barth [ctb] (), Bruna Wundervald [ctb] (), Joyce Cahoon [ctb] (), Grant McDermott [ctb] (), Kevin Zarca [ctb], Shiro Kuriwaki [ctb] (), Lukas Wallrich [ctb] (), James Martherus [ctb] (), Chuliang Xiao [ctb] (), Joseph Larmarange [ctb], Max Kuhn [ctb], Michal Bojanowski [ctb], Hakon Malmedal [ctb], Clara Wang [ctb], Sergio Oller [ctb], Luke Sonnet [ctb], Jim Hester [ctb], Ben Schneider [ctb], Bernie Gray [ctb] (), Mara Averick [ctb], Aaron Jacobs [ctb], Andreas Bender [ctb], Sven Templer [ctb], Paul-Christian Buerkner [ctb], Matthew Kay [ctb], Erwan Le Pennec [ctb], Johan Junkka [ctb], Hao Zhu [ctb], Benjamin Soltoff [ctb], Zoe Wilkinson Saldana [ctb], Tyler Littlefield [ctb], Charles T. Gray [ctb], Shabbh E. Banks [ctb], Serina Robinson [ctb], Roger Bivand [ctb], Riinu Ots [ctb], Nicholas Williams [ctb], Nina Jakobsen [ctb], Michael Weylandt [ctb], Lisa Lendway [ctb], Karl Hailperin [ctb], Josue Rodriguez [ctb], Jenny Bryan [ctb], Chris Jarvis [ctb], Greg Macfarlane [ctb], Brian Mannakee [ctb], Drew Tyre [ctb], Shreyas Singh [ctb], Laurens Geffert [ctb], Hong Ooi [ctb], Henrik Bengtsson [ctb], Eduard Szocs [ctb], David Hugh-Jones [ctb], Matthieu Stigler [ctb], Hugo Tavares [ctb] (), R. Willem Vervoort [ctb], Brenton M. Wiernik [ctb], Josh Yamamoto [ctb], Jasme Lee [ctb], Taren Sanders [ctb] (), Ilaria Prosdocimi [ctb] (), Daniel D. Sjoberg [ctb] (), Alex Reinhart [ctb] ()", "Maintainer": "Simon Couch ", @@ -2313,7 +2314,7 @@ }, "curl": { "Package": "curl", - "Version": "6.2.1", + "Version": "6.2.2", "Source": "Repository", "Type": "Package", "Title": "A Modern and Flexible Web Client for R", @@ -2430,7 +2431,7 @@ }, "datawizard": { "Package": "datawizard", - "Version": "1.0.1", + "Version": "1.0.2", "Source": "Repository", "Type": "Package", "Title": "Easy Data Wrangling and Statistical Transformations", @@ -3324,10 +3325,10 @@ }, "foreign": { "Package": "foreign", - "Version": "0.8-88", + "Version": "0.8-90", "Source": "Repository", "Priority": "recommended", - "Date": "2025-01-10", + "Date": "2025-03-31", "Title": "Read Data Stored by 'Minitab', 'S', 'SAS', 'SPSS', 'Stata', 'Systat', 'Weka', 'dBase', ...", "Depends": [ "R (>= 4.0.0)" @@ -3569,7 +3570,7 @@ }, "gdtools": { "Package": "gdtools", - "Version": "0.4.1", + "Version": "0.4.2", "Source": "Repository", "Title": "Utilities for Graphical Rendering and Fonts Management", "Authors@R": "c( person(\"David\", \"Gohel\", , \"david.gohel@ardata.fr\", role = c(\"aut\", \"cre\")), person(\"Hadley\", \"Wickham\", , \"hadley@rstudio.com\", role = \"aut\"), person(\"Lionel\", \"Henry\", , \"lionel@rstudio.com\", role = \"aut\"), person(\"Jeroen\", \"Ooms\", , \"jeroen@berkeley.edu\", role = \"aut\", comment = c(ORCID = \"0000-0002-4035-0289\")), person(\"Yixuan\", \"Qiu\", role = \"ctb\"), person(\"R Core Team\", role = \"cph\", comment = \"Cairo code from X11 device\"), person(\"ArData\", role = \"cph\"), person(\"RStudio\", role = \"cph\") )", @@ -3882,7 +3883,7 @@ }, "ggiraph": { "Package": "ggiraph", - "Version": "0.8.12", + "Version": "0.8.13", "Source": "Repository", "Type": "Package", "Title": "Make 'ggplot2' Graphics Interactive", @@ -5041,7 +5042,7 @@ }, "jsonlite": { "Package": "jsonlite", - "Version": "1.9.1", + "Version": "2.0.0", "Source": "Repository", "Title": "A Simple and Robust JSON Parser and Generator for R", "License": "MIT + file LICENSE", @@ -5063,7 +5064,7 @@ "R.rsp", "sf" ], - "RoxygenNote": "7.2.3", + "RoxygenNote": "7.3.2", "Encoding": "UTF-8", "NeedsCompilation": "yes", "Author": "Jeroen Ooms [aut, cre] (), Duncan Temple Lang [ctb], Lloyd Hilaiel [cph] (author of bundled libyajl)", @@ -5539,12 +5540,44 @@ "Maintainer": "Henrik Bengtsson ", "Repository": "CRAN" }, + "litedown": { + "Package": "litedown", + "Version": "0.6", + "Source": "Repository", + "Type": "Package", + "Title": "A Lightweight Version of R Markdown", + "Authors@R": "c( person(\"Yihui\", \"Xie\", role = c(\"aut\", \"cre\"), email = \"xie@yihui.name\", comment = c(ORCID = \"0000-0003-0645-5666\", URL = \"https://yihui.org\")), person(\"Tim\", \"Taylor\", role = \"ctb\", comment = c(ORCID = \"0000-0002-8587-7113\")), person() )", + "Description": "Render R Markdown to Markdown (without using 'knitr'), and Markdown to lightweight HTML or 'LaTeX' documents with the 'commonmark' package (instead of 'Pandoc'). Some missing Markdown features in 'commonmark' are also supported, such as raw HTML or 'LaTeX' blocks, 'LaTeX' math, superscripts, subscripts, footnotes, element attributes, and appendices, but not all 'Pandoc' Markdown features are (or will be) supported. With additional JavaScript and CSS, you can also create HTML slides and articles. This package can be viewed as a trimmed-down version of R Markdown and 'knitr'. It does not aim at rich Markdown features or a large variety of output formats (the primary formats are HTML and 'LaTeX'). Book and website projects of multiple input documents are also supported.", + "Depends": [ + "R (>= 3.2.0)" + ], + "Imports": [ + "utils", + "commonmark (>= 1.9.1)", + "xfun (>= 0.51)" + ], + "Suggests": [ + "rbibutils", + "rstudioapi", + "tinytex" + ], + "License": "MIT + file LICENSE", + "URL": "https://github.com/yihui/litedown", + "BugReports": "https://github.com/yihui/litedown/issues", + "VignetteBuilder": "litedown", + "RoxygenNote": "7.3.2", + "Encoding": "UTF-8", + "NeedsCompilation": "no", + "Author": "Yihui Xie [aut, cre] (, https://yihui.org), Tim Taylor [ctb] ()", + "Maintainer": "Yihui Xie ", + "Repository": "CRAN" + }, "lme4": { "Package": "lme4", - "Version": "1.1-36", + "Version": "1.1-37", "Source": "Repository", "Title": "Linear Mixed-Effects Models using 'Eigen' and S4", - "Authors@R": "c( person(\"Douglas\",\"Bates\", role=\"aut\", comment=c(ORCID=\"0000-0001-8316-9503\")), person(\"Martin\",\"Maechler\", role=\"aut\", comment=c(ORCID=\"0000-0002-8685-9910\")), person(\"Ben\",\"Bolker\",email=\"bbolker+lme4@gmail.com\", role=c(\"aut\",\"cre\"), comment=c(ORCID=\"0000-0002-2127-0443\")), person(\"Steven\",\"Walker\",role=\"aut\", comment=c(ORCID=\"0000-0002-4394-9078\")), person(\"Rune Haubo Bojesen\",\"Christensen\", role=\"ctb\", comment=c(ORCID=\"0000-0002-4494-3399\")), person(\"Henrik\",\"Singmann\", role=\"ctb\", comment=c(ORCID=\"0000-0002-4842-3657\")), person(\"Bin\", \"Dai\", role=\"ctb\"), person(\"Fabian\", \"Scheipl\", role=\"ctb\", comment=c(ORCID=\"0000-0001-8172-3603\")), person(\"Gabor\", \"Grothendieck\", role=\"ctb\"), person(\"Peter\", \"Green\", role=\"ctb\", comment=c(ORCID=\"0000-0002-0238-9852\")), person(\"John\", \"Fox\", role=\"ctb\"), person(\"Alexander\", \"Bauer\", role=\"ctb\"), person(\"Pavel N.\", \"Krivitsky\", role=c(\"ctb\",\"cph\"), comment=c(ORCID=\"0000-0002-9101-3362\", \"shared copyright on simulate.formula\")), person(\"Emi\", \"Tanaka\", role = \"ctb\", comment = c(ORCID=\"0000-0002-1455-259X\")), person(\"Mikael\", \"Jagan\", role = \"ctb\", comment = c(ORCID=\"0000-0002-3542-2938\")) )", + "Authors@R": "c( person(\"Douglas\",\"Bates\", role=\"aut\", comment=c(ORCID=\"0000-0001-8316-9503\")), person(\"Martin\",\"Maechler\", role=\"aut\", comment=c(ORCID=\"0000-0002-8685-9910\")), person(\"Ben\",\"Bolker\",email=\"bbolker+lme4@gmail.com\", role=c(\"aut\",\"cre\"), comment=c(ORCID=\"0000-0002-2127-0443\")), person(\"Steven\",\"Walker\",role=\"aut\", comment=c(ORCID=\"0000-0002-4394-9078\")), person(\"Rune Haubo Bojesen\",\"Christensen\", role=\"ctb\", comment=c(ORCID=\"0000-0002-4494-3399\")), person(\"Henrik\",\"Singmann\", role=\"ctb\", comment=c(ORCID=\"0000-0002-4842-3657\")), person(\"Bin\", \"Dai\", role=\"ctb\"), person(\"Fabian\", \"Scheipl\", role=\"ctb\", comment=c(ORCID=\"0000-0001-8172-3603\")), person(\"Gabor\", \"Grothendieck\", role=\"ctb\"), person(\"Peter\", \"Green\", role=\"ctb\", comment=c(ORCID=\"0000-0002-0238-9852\")), person(\"John\", \"Fox\", role=\"ctb\"), person(\"Alexander\", \"Bauer\", role=\"ctb\"), person(\"Pavel N.\", \"Krivitsky\", role=c(\"ctb\",\"cph\"), comment=c(ORCID=\"0000-0002-9101-3362\", \"shared copyright on simulate.formula\")), person(\"Emi\", \"Tanaka\", role = \"ctb\", comment = c(ORCID=\"0000-0002-1455-259X\")), person(\"Mikael\", \"Jagan\", role = \"ctb\", comment = c(ORCID=\"0000-0002-3542-2938\")), person(\"Ross D.\", \"Boylan\", email=\"ross.boylan@ucsf.edu\", role=(\"ctb\"), comment = c(ORCID=\"0009-0003-4123-8090\")) )", "Description": "Fit linear and generalized linear mixed-effects models. The models and their components are represented using S4 classes and methods. The core computational algorithms are implemented using the 'Eigen' C++ library for numerical linear algebra and 'RcppEigen' \"glue\".", "Depends": [ "R (>= 3.6.0)", @@ -5599,7 +5632,7 @@ "BugReports": "https://github.com/lme4/lme4/issues", "Encoding": "UTF-8", "NeedsCompilation": "yes", - "Author": "Douglas Bates [aut] (), Martin Maechler [aut] (), Ben Bolker [aut, cre] (), Steven Walker [aut] (), Rune Haubo Bojesen Christensen [ctb] (), Henrik Singmann [ctb] (), Bin Dai [ctb], Fabian Scheipl [ctb] (), Gabor Grothendieck [ctb], Peter Green [ctb] (), John Fox [ctb], Alexander Bauer [ctb], Pavel N. Krivitsky [ctb, cph] (, shared copyright on simulate.formula), Emi Tanaka [ctb] (), Mikael Jagan [ctb] ()", + "Author": "Douglas Bates [aut] (), Martin Maechler [aut] (), Ben Bolker [aut, cre] (), Steven Walker [aut] (), Rune Haubo Bojesen Christensen [ctb] (), Henrik Singmann [ctb] (), Bin Dai [ctb], Fabian Scheipl [ctb] (), Gabor Grothendieck [ctb], Peter Green [ctb] (), John Fox [ctb], Alexander Bauer [ctb], Pavel N. Krivitsky [ctb, cph] (, shared copyright on simulate.formula), Emi Tanaka [ctb] (), Mikael Jagan [ctb] (), Ross D. Boylan [ctb] ()", "Maintainer": "Ben Bolker ", "Repository": "CRAN" }, @@ -5714,7 +5747,7 @@ }, "markdown": { "Package": "markdown", - "Version": "1.13", + "Version": "2.0", "Source": "Repository", "Type": "Package", "Title": "Render Markdown with 'commonmark'", @@ -5725,8 +5758,8 @@ ], "Imports": [ "utils", - "commonmark (>= 1.9.0)", - "xfun (>= 0.38)" + "xfun", + "litedown (>= 0.6)" ], "Suggests": [ "knitr", @@ -5737,7 +5770,7 @@ "License": "MIT + file LICENSE", "URL": "https://github.com/rstudio/markdown", "BugReports": "https://github.com/rstudio/markdown/issues", - "RoxygenNote": "7.3.1", + "RoxygenNote": "7.3.2", "Encoding": "UTF-8", "NeedsCompilation": "no", "Author": "Yihui Xie [aut, cre] (), JJ Allaire [aut], Jeffrey Horner [aut], Henrik Bengtsson [ctb], Jim Hester [ctb], Yixuan Qiu [ctb], Kohske Takahashi [ctb], Adam November [ctb], Nacho Caballero [ctb], Jeroen Ooms [ctb], Thomas Leeper [ctb], Joe Cheng [ctb], Andrzej Oles [ctb], Posit Software, PBC [cph, fnd]", @@ -6016,9 +6049,9 @@ }, "nlme": { "Package": "nlme", - "Version": "3.1-167", + "Version": "3.1-168", "Source": "Repository", - "Date": "2025-01-27", + "Date": "2025-03-31", "Priority": "recommended", "Title": "Linear and Nonlinear Mixed Effects Models", "Authors@R": "c(person(\"José\", \"Pinheiro\", role = \"aut\", comment = \"S version\"), person(\"Douglas\", \"Bates\", role = \"aut\", comment = \"up to 2007\"), person(\"Saikat\", \"DebRoy\", role = \"ctb\", comment = \"up to 2002\"), person(\"Deepayan\", \"Sarkar\", role = \"ctb\", comment = \"up to 2005\"), person(\"EISPACK authors\", role = \"ctb\", comment = \"src/rs.f\"), person(\"Siem\", \"Heisterkamp\", role = \"ctb\", comment = \"Author fixed sigma\"), person(\"Bert\", \"Van Willigen\",role = \"ctb\", comment = \"Programmer fixed sigma\"), person(\"Johannes\", \"Ranke\", role = \"ctb\", comment = \"varConstProp()\"), person(\"R Core Team\", email = \"R-core@R-project.org\", role = c(\"aut\", \"cre\"), comment = c(ROR = \"02zz1nj61\")))", @@ -6102,7 +6135,7 @@ }, "officer": { "Package": "officer", - "Version": "0.6.7", + "Version": "0.6.8", "Source": "Repository", "Type": "Package", "Title": "Manipulation of Microsoft Word and PowerPoint Documents", @@ -6127,15 +6160,18 @@ "Suggests": [ "devEMF", "doconv (>= 0.3.0)", + "gdtools", "ggplot2", "knitr", "magick", "rmarkdown", "rsvg", - "testthat" + "testthat", + "withr" ], "Encoding": "UTF-8", "RoxygenNote": "7.3.2", + "Collate": "'core_properties.R' 'custom_properties.R' 'defunct.R' 'dev-utils.R' 'docx_add.R' 'docx_comments.R' 'docx_cursor.R' 'docx_part.R' 'docx_replace.R' 'docx_section.R' 'docx_settings.R' 'empty_content.R' 'formatting_properties.R' 'fortify_docx.R' 'fortify_pptx.R' 'knitr_utils.R' 'officer.R' 'ooxml.R' 'ooxml_block_objects.R' 'ooxml_run_objects.R' 'openxml_content_type.R' 'openxml_document.R' 'pack_folder.R' 'ph_location.R' 'post-proc.R' 'ppt_class_dir_collection.R' 'ppt_classes.R' 'ppt_notes.R' 'ppt_ph_dedupe_layout.R' 'ppt_ph_manipulate.R' 'ppt_ph_rename_layout.R' 'ppt_ph_with_methods.R' 'pptx_informations.R' 'pptx_layout_helper.R' 'pptx_matrix.R' 'utils.R' 'pptx_slide_manip.R' 'read_docx.R' 'read_docx_styles.R' 'read_pptx.R' 'read_xlsx.R' 'relationship.R' 'rtf.R' 'shape_properties.R' 'shorcuts.R'", "NeedsCompilation": "no", "Author": "David Gohel [aut, cre], Stefan Moog [aut], Mark Heckmann [aut] (), ArData [cph], Frank Hangler [ctb] (function body_replace_all_text), Liz Sander [ctb] (several documentation fixes), Anton Victorson [ctb] (fixes xml structures), Jon Calder [ctb] (update vignettes), John Harrold [ctb] (function annotate_base), John Muschelli [ctb] (google doc compatibility), Bill Denney [ctb] (, function as.matrix.rpptx), Nikolai Beck [ctb] (set speaker notes for .pptx documents), Greg Leleu [ctb] (fields functionality in ppt), Majid Eismann [ctb], Hongyuan Jia [ctb] ()", "Maintainer": "David Gohel ", @@ -6210,7 +6246,7 @@ }, "openxlsx2": { "Package": "openxlsx2", - "Version": "1.13", + "Version": "1.14", "Source": "Repository", "Type": "Package", "Title": "Read, Write and Edit 'xlsx' Files", @@ -6319,7 +6355,7 @@ }, "parallelly": { "Package": "parallelly", - "Version": "1.42.0", + "Version": "1.43.0", "Source": "Repository", "Title": "Enhancing the 'parallel' Package", "Imports": [ @@ -7198,9 +7234,9 @@ }, "psych": { "Package": "psych", - "Version": "2.4.12", + "Version": "2.5.3", "Source": "Repository", - "Date": "2024-12-05", + "Date": "2025-03-18", "Title": "Procedures for Psychological, Psychometric, and Personality Research", "Authors@R": "person(\"William\", \"Revelle\", role =c(\"aut\",\"cre\"), email=\"revelle@northwestern.edu\", comment=c(ORCID = \"0000-0003-4880-9610\") )", "Description": "A general purpose toolbox developed originally for personality, psychometric theory and experimental psychology. Functions are primarily for multivariate analysis and scale construction using factor analysis, principal component analysis, cluster analysis and reliability analysis, although others provide basic descriptive statistics. Item Response Theory is done using factor analysis of tetrachoric and polychoric correlations. Functions for analyzing data at multiple levels include within and between group statistics, including correlations and factor analysis. Validation and cross validation of scales developed using basic machine learning algorithms are provided, as are functions for simulating and testing particular item and test structures. Several functions serve as a useful front end for structural equation modeling. Graphical displays of path diagrams, including mediation models, factor analysis and structural equation models are created using basic graphics. Some of the functions are written to support a book on psychometric theory as well as publications in personality research. For more information, see the web page.", @@ -7881,7 +7917,7 @@ }, "renv": { "Package": "renv", - "Version": "1.1.3", + "Version": "1.1.4", "Source": "Repository", "Type": "Package", "Title": "Project Environments", @@ -9015,9 +9051,9 @@ }, "stringi": { "Package": "stringi", - "Version": "1.8.4", + "Version": "1.8.7", "Source": "Repository", - "Date": "2024-05-06", + "Date": "2025-03-27", "Title": "Fast and Portable Character String Processing Facilities", "Description": "A collection of character string/text/natural language processing tools for pattern searching (e.g., with 'Java'-like regular expressions or the 'Unicode' collation algorithm), random string generation, case mapping, string transliteration, concatenation, sorting, padding, wrapping, Unicode normalisation, date-time formatting and parsing, and many more. They are fast, consistent, convenient, and - thanks to 'ICU' (International Components for Unicode) - portable across all locales and platforms. Documentation about 'stringi' is provided via its website at and the paper by Gagolewski (2022, ).", "URL": "https://stringi.gagolewski.com/, https://github.com/gagolews/stringi, https://icu.unicode.org/", @@ -9034,11 +9070,12 @@ ], "Biarch": "TRUE", "License": "file LICENSE", - "Author": "Marek Gagolewski [aut, cre, cph] (), Bartek Tartanus [ctb], and others (stringi source code); Unicode, Inc. and others (ICU4C source code, Unicode Character Database)", - "Maintainer": "Marek Gagolewski ", - "RoxygenNote": "7.2.3", + "Authors@R": "c(person(given = \"Marek\", family = \"Gagolewski\", role = c(\"aut\", \"cre\", \"cph\"), email = \"marek@gagolewski.com\", comment = c(ORCID = \"0000-0003-0637-6028\")), person(given = \"Bartek\", family = \"Tartanus\", role = \"ctb\"), person(\"Unicode, Inc. and others\", role=\"ctb\", comment = \"ICU4C source code, Unicode Character Database\") )", + "RoxygenNote": "7.3.2", "Encoding": "UTF-8", "NeedsCompilation": "yes", + "Author": "Marek Gagolewski [aut, cre, cph] (), Bartek Tartanus [ctb], Unicode, Inc. and others [ctb] (ICU4C source code, Unicode Character Database)", + "Maintainer": "Marek Gagolewski ", "License_is_FOSS": "yes", "Repository": "CRAN" }, diff --git a/renv/activate.R b/renv/activate.R index 623cc4e..90b251c 100644 --- a/renv/activate.R +++ b/renv/activate.R @@ -2,7 +2,7 @@ local({ # the requested version of renv - version <- "1.1.3" + version <- "1.1.4" attr(version, "sha") <- NULL # the project directory