diff --git a/R/helpers.R b/R/helpers.R index def92fa9..c038c5c1 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -154,7 +154,8 @@ dummy_Imports <- function() { parameters::ci(), DT::addRow(), bslib::accordion(), - NHANES::NHANES() + NHANES::NHANES(), + stRoke::add_padding() ) # https://github.com/hadley/r-pkgs/issues/828 } @@ -668,3 +669,84 @@ is_identical_to_previous <- function(data, no.name = TRUE) { simple_snake <- function(data){ gsub("[\\s+]","_",gsub("[^\\w\\s:-]", "", tolower(data), perl=TRUE), perl=TRUE) } + +#' Data type assessment. +#' +#' @description +#' These are more overall than the native typeof. This is used to assess a more +#' meaningful "clinical" data type. +#' +#' @param data vector or data.frame. if data frame, each column is evaluated. +#' +#' @returns outcome type +#' @export +#' +#' @examples +#' mtcars |> +#' default_parsing() |> +#' lapply(data_type) +#' mtcars |> +#' default_parsing() |> +#' data_type() +#' c(1, 2) |> data_type() +#' 1 |> data_type() +#' c(rep(NA, 10)) |> data_type() +#' sample(1:100, 50) |> data_type() +#' factor(letters[1:20]) |> data_type() +#' as.Date(1:20) |> data_type() +data_type <- function(data) { + if (is.data.frame(data)) { + sapply(data, data_type) + } else { + cl_d <- class(data) + l_unique <- length(unique(na.omit(data))) + if (all(is.na(data))) { + out <- "empty" + } else if (l_unique < 2) { + out <- "monotone" + } else if (any(c("factor", "logical") %in% cl_d) | l_unique == 2) { + if (identical("logical", cl_d) | l_unique == 2) { + out <- "dichotomous" + } else { + # if (is.ordered(data)) { + # out <- "ordinal" + # } else { + out <- "categorical" + # } + } + } else if (identical(cl_d, "character")) { + out <- "text" + } else if (any(c("hms", "Date", "POSIXct", "POSIXt") %in% cl_d)) { + out <- "datetime" + } else if (l_unique > 2) { + ## Previously had all thinkable classes + ## Now just assumes the class has not been defined above + ## any(c("numeric", "integer", "hms", "Date", "timediff") %in% cl_d) & + out <- "continuous" + } else { + out <- "unknown" + } + + out + } +} + +#' Recognised data types from data_type +#' +#' @returns vector +#' @export +#' +#' @examples +#' data_types() +data_types <- function() { + list( + "empty" = list(descr="Variable of all NAs",classes="Any class"), + "monotone" = list(descr="Variable with only one unique value",classes="Any class"), + "dichotomous" = list(descr="Variable with only two unique values",classes="Any class"), + "categorical"= list(descr="Factor variable",classes="factor (ordered or unordered)"), + "text"= list(descr="Character variable",classes="character"), + "datetime"= list(descr="Variable of time, date or datetime values",classes="hms, Date, POSIXct and POSIXt"), + "continuous"= list(descr="Numeric variable",classes="numeric, integer or double"), + "unknown"= list(descr="Anything not falling within the previous",classes="Any other class") + ) +} diff --git a/R/plot_euler.R b/R/plot_euler.R index e1e48aa8..17345020 100644 --- a/R/plot_euler.R +++ b/R/plot_euler.R @@ -1,7 +1,7 @@ #' Area proportional venn diagrams #' #' @description -#' THis is slightly modified from https://gist.github.com/danlooo/d23d8bcf8856c7dd8e86266097404ded +#' This is slightly modified from https://gist.github.com/danlooo/d23d8bcf8856c7dd8e86266097404ded #' #' This functions uses eulerr::euler to plot area proportional venn diagramms #' but plots it using ggplot2 @@ -11,18 +11,27 @@ #' @param show_quantities whether to show number of intersecting elements #' @param show_labels whether to show set names #' @param ... further arguments passed to eulerr::euler +#' +#' @include data_plots.R ggeulerr <- function( combinations, show_quantities = TRUE, show_labels = TRUE, ...) { - # browser() + + ## Extracting labels + labs <- sapply(names(combinations),\(.x){ + # browser() + get_label(combinations,.x) + }) + data <- - eulerr::euler(combinations = combinations, ...) |> + ## Set labels as variable names for nicer plotting + setNames(as.data.frame(combinations),labs) |> + eulerr::euler(...) |> plot(quantities = show_quantities) |> purrr::pluck("data") - tibble::as_tibble(data$ellipses, rownames = "Variables") |> ggplot2::ggplot() + ggforce::geom_ellipse( @@ -38,7 +47,8 @@ ggeulerr <- function( dplyr::mutate( label = labels |> purrr::map2(quantities, ~ { if (!is.na(.x) && !is.na(.y) && show_labels) { - paste0(.x, "\n", sprintf(.y, fmt = "%.2g")) + paste0(.x, "\n", sprintf(.y, fmt = "%.4g")) + # glue::glue("{.x}\n{round(.y,0)}") } else if (!is.na(.x) && show_labels) { .x } else if (!is.na(.y)) { @@ -77,6 +87,21 @@ ggeulerr <- function( #' ) |> plot_euler("A", c("B", "C"), "D", seed = 4) #' mtcars |> plot_euler("vs", "am", seed = 1) #' mtcars |> plot_euler("vs", "am", "cyl", seed = 1) +#' stRoke::trial |> +#' dplyr::mutate( +#' mfi_cut = cut(mfi_6, c(0, 12, max(mfi_6, na.rm = TRUE))), +#' mdi_cut = cut(mdi_6, c(0, 20, max(mdi_6, na.rm = TRUE))) +#' ) |> +#' purrr::map2( +#' c(sapply(stRoke::trial, \(.x)REDCapCAST::get_attr(.x, attr = "label")), "Fatigue", "Depression"), +#' \(.x, .y){ +#' REDCapCAST::set_attr(.x, .y, "label") +#' } +#' ) |> +#' dplyr::bind_cols() |> +#' plot_euler("mfi_cut", "mdi_cut") +#' stRoke::trial |> +#' plot_euler(pri="male", sec=c("hypertension")) plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { set.seed(seed = seed) if (!is.null(ter)) { @@ -84,16 +109,13 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { } else { ds <- list(data) } - out <- lapply(ds, \(.x){ .x[c(pri, sec)] |> - as.data.frame() |> na.omit() |> plot_euler_single() }) -# browser() - wrap_plot_list(out,title=glue::glue("Grouped by {get_label(data,ter)}")) - # patchwork::wrap_plots(out) + + wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) } #' Easily plot single euler diagrams diff --git a/R/regression-module.R b/R/regression-module.R index d8ccc996..52898ce5 100644 --- a/R/regression-module.R +++ b/R/regression-module.R @@ -72,13 +72,15 @@ regression_ui <- function(id, ...) { shiny::radioButtons( inputId = ns("all"), label = i18n$t("Specify covariables"), - inline = TRUE, selected = 2, + inline = TRUE, + selected = 2, choiceNames = c( "Yes", "No" ), choiceValues = c(1, 2) ), + # shiny::uiOutput(outputId = ns("all")), shiny::conditionalPanel( condition = "input.all==1", shiny::uiOutput(outputId = ns("regression_vars")), @@ -131,7 +133,7 @@ regression_ui <- function(id, ...) { ) ), bslib::nav_panel( - title = "Coefficient plot", + title = i18n$t("Coefficient plot"), bslib::layout_sidebar( sidebar = bslib::sidebar( bslib::accordion( @@ -243,11 +245,6 @@ regression_server <- function(id, } }) - shiny::observe({ - bslib::accordion_panel_update(id = "acc_reg", target = "acc_pan_reg", title = i18n$t("Regression")) - bslib::accordion_panel_update(id = "acc_coef_plot", target = "acc_pan_coef_plot", title = i18n$t("Coefficients plot")) - bslib::accordion_panel_update(id = "acc_checks", target = "acc_pan_checks", title = i18n$t("Checks")) - }) output$data_info <- shiny::renderUI({ shiny::req(regression_vars()) @@ -255,6 +252,31 @@ regression_server <- function(id, data_description(data_r()[regression_vars()]) }) + ## Update on laguage change + + shiny::observe({ + bslib::accordion_panel_update(id = "acc_reg", target = "acc_pan_reg", title = i18n$t("Regression")) + bslib::accordion_panel_update(id = "acc_coef_plot", target = "acc_pan_coef_plot", title = i18n$t("Coefficients plot")) + bslib::accordion_panel_update(id = "acc_checks", target = "acc_pan_checks", title = i18n$t("Checks")) + }) + + # shiny::observe({ + # shiny::updateRadioButtons( + # session = session, + # inputId = "all", + # label = i18n$t("Specify covariables"), + # # inline = TRUE, + # # selected = 2, + # choiceNames = c( + # i18n$t("Yes"), + # i18n$t("No") + # ), + # choiceValues = c(1, 2) + # ) + # }) + + + ############################################################################## ######### ######### Input fields @@ -278,7 +300,7 @@ regression_server <- function(id, columnSelectInput( inputId = ns("outcome_var"), selected = NULL, - label = "Select outcome variable", + label = i18n$t("Select outcome variable"), data = data_r(), multiple = FALSE ) @@ -288,7 +310,7 @@ regression_server <- function(id, shiny::req(input$outcome_var) shiny::selectizeInput( inputId = ns("regression_type"), - label = "Choose regression analysis", + label = i18n$t("Choose regression analysis"), ## The below ifelse statement handles the case of loading a new dataset choices = possible_functions( data = dplyr::select( @@ -307,7 +329,7 @@ regression_server <- function(id, shiny::selectizeInput( inputId = ns("factor_vars"), selected = colnames(data_r())[sapply(data_r(), is.factor)], - label = "Covariables to format as categorical", + label = i18n$t("Covariables to format as categorical"), choices = colnames(data_r()), multiple = TRUE ) @@ -327,7 +349,7 @@ regression_server <- function(id, columnSelectInput( inputId = ns("strat_var"), selected = "none", - label = "Select variable to stratify baseline", + label = i18n$t("Select variable to stratify baseline"), data = data_r(), col_subset = c( "none", @@ -342,7 +364,7 @@ regression_server <- function(id, shiny::selectInput( inputId = ns("plot_model"), selected = 1, - label = "Select models to plot", + label = i18n$t("Select models to plot"), choices = names(rv$list$regression$tables), multiple = TRUE ) @@ -392,7 +414,7 @@ regression_server <- function(id, rv$list$regression$models <- model_lists }, error = function(err) { - showNotification(paste0("Creating regression models failed with the following error: ", err), type = "err") + showNotification(paste(i18n$t("Creating regression models failed with the following error:"), err), type = "err") } ) } @@ -457,7 +479,7 @@ regression_server <- function(id, showNotification(paste0(warn), type = "warning") }, error = function(err) { - showNotification(paste0("Creating a regression table failed with the following error: ", err), type = "err") + showNotification(paste(i18n$t("Creating a regression table failed with the following error:"), err), type = "err") } ) } @@ -558,7 +580,7 @@ regression_server <- function(id, 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..", { + shiny::withProgress(message = i18n$t("Saving the plot. Hold on for a moment.."), { ggplot2::ggsave( filename = file, plot = rv$plot, @@ -595,7 +617,7 @@ regression_server <- function(id, # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste0("Running model assumptions checks failed with the following error: ", err), type = "err") + showNotification(paste(i18n$t("Running model assumptions checks failed with the following error:"), err), type = "err") } ) } @@ -616,7 +638,7 @@ regression_server <- function(id, vectorSelectInput( inputId = ns("plot_checks"), selected = 1, - label = "Select checks to plot", + label = i18n$t("Select checks to plot"), choices = names, multiple = TRUE ) @@ -631,7 +653,7 @@ regression_server <- function(id, if (!is.null(rv$list$regression$tables)) { p <- rv$check_plot() + # patchwork::wrap_plots() + - patchwork::plot_annotation(title = "Multivariable regression model checks") + patchwork::plot_annotation(title = i18n$t("Multivariable regression model checks")) layout <- sapply(seq_len(length(p)), \(.x){ diff --git a/R/regression_model.R b/R/regression_model.R index df79cc16..f509f7d7 100644 --- a/R/regression_model.R +++ b/R/regression_model.R @@ -242,87 +242,6 @@ regression_model_uv <- function(data, ### HELPERS -#' Data type assessment. -#' -#' @description -#' These are more overall than the native typeof. This is used to assess a more -#' meaningful "clinical" data type. -#' -#' @param data vector or data.frame. if data frame, each column is evaluated. -#' -#' @returns outcome type -#' @export -#' -#' @examples -#' mtcars |> -#' default_parsing() |> -#' lapply(data_type) -#' mtcars |> -#' default_parsing() |> -#' data_type() -#' c(1, 2) |> data_type() -#' 1 |> data_type() -#' c(rep(NA, 10)) |> data_type() -#' sample(1:100, 50) |> data_type() -#' factor(letters[1:20]) |> data_type() -#' as.Date(1:20) |> data_type() -data_type <- function(data) { - if (is.data.frame(data)) { - sapply(data, data_type) - } else { - cl_d <- class(data) - l_unique <- length(unique(na.omit(data))) - if (all(is.na(data))) { - out <- "empty" - } else if (l_unique < 2) { - out <- "monotone" - } else if (any(c("factor", "logical") %in% cl_d) | l_unique == 2) { - if (identical("logical", cl_d) | l_unique == 2) { - out <- "dichotomous" - } else { - # if (is.ordered(data)) { - # out <- "ordinal" - # } else { - out <- "categorical" - # } - } - } else if (identical(cl_d, "character")) { - out <- "text" - } else if (any(c("hms", "Date", "POSIXct", "POSIXt") %in% cl_d)) { - out <- "datetime" - } else if (l_unique > 2) { - ## Previously had all thinkable classes - ## Now just assumes the class has not been defined above - ## any(c("numeric", "integer", "hms", "Date", "timediff") %in% cl_d) & - out <- "continuous" - } else { - out <- "unknown" - } - - out - } -} - -#' Recognised data types from data_type -#' -#' @returns vector -#' @export -#' -#' @examples -#' data_types() -data_types <- function() { - list( - "empty" = list(descr="Variable of all NAs",classes="Any class"), - "monotone" = list(descr="Variable with only one unique value",classes="Any class"), - "dichotomous" = list(descr="Variable with only two unique values",classes="Any class"), - "categorical"= list(descr="Factor variable",classes="factor (ordered or unordered)"), - "text"= list(descr="Character variable",classes="character"), - "datetime"= list(descr="Variable of time, date or datetime values",classes="hms, Date, POSIXct and POSIXt"), - "continuous"= list(descr="Numeric variable",classes="numeric, integer or double"), - "unknown"= list(descr="Anything not falling within the previous",classes="Any other class") - ) -} - #' Implemented functions #'