mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2025-12-16 17:42:10 +01:00
Compare commits
6 commits
15c7392a17
...
498ce52565
| Author | SHA1 | Date | |
|---|---|---|---|
| 498ce52565 | |||
| 02fd53a352 | |||
| 0e0df73744 | |||
| adcd404813 | |||
| 9c1d6ed630 | |||
| 2c39313ffb |
33 changed files with 2057 additions and 511 deletions
15
CITATION.cff
15
CITATION.cff
|
|
@ -8,7 +8,7 @@ message: 'To cite package "FreesearchR" in publications use:'
|
|||
type: software
|
||||
license: AGPL-3.0-or-later
|
||||
title: 'FreesearchR: Easy data analysis for clinicians'
|
||||
version: 25.9.2
|
||||
version: 25.10.1
|
||||
doi: 10.5281/zenodo.14527429
|
||||
identifiers:
|
||||
- type: url
|
||||
|
|
@ -1050,6 +1050,19 @@ references:
|
|||
email: jakub.sobolewski@appsilon.com
|
||||
year: '2025'
|
||||
doi: 10.32614/CRAN.package.shiny.i18n
|
||||
- type: software
|
||||
title: stRoke
|
||||
abstract: 'stRoke: Clinical Stroke Research'
|
||||
notes: Imports
|
||||
url: https://agdamsbo.github.io/stRoke/
|
||||
repository: https://CRAN.R-project.org/package=stRoke
|
||||
authors:
|
||||
- family-names: Damsbo
|
||||
given-names: Andreas Gammelgaard
|
||||
email: agdamsbo@clin.au.dk
|
||||
orcid: https://orcid.org/0000-0002-7559-1154
|
||||
year: '2025'
|
||||
doi: 10.32614/CRAN.package.stRoke
|
||||
- type: software
|
||||
title: styler
|
||||
abstract: 'styler: Non-Invasive Pretty Printing of R Code'
|
||||
|
|
|
|||
46
DESCRIPTION
46
DESCRIPTION
|
|
@ -1,6 +1,6 @@
|
|||
Package: FreesearchR
|
||||
Title: Easy data analysis for clinicians
|
||||
Version: 25.9.2
|
||||
Version: 25.10.1
|
||||
Authors@R: c(
|
||||
person("Andreas Gammelgaard", "Damsbo",email="agdamsbo@clin.au.dk", role = c("aut", "cre"),
|
||||
comment = c(ORCID = "0000-0002-7559-1154")),
|
||||
|
|
@ -67,7 +67,8 @@ Imports:
|
|||
emmeans,
|
||||
readxl,
|
||||
NHANES,
|
||||
shiny.i18n
|
||||
shiny.i18n,
|
||||
stRoke
|
||||
Suggests:
|
||||
styler,
|
||||
devtools,
|
||||
|
|
@ -91,3 +92,44 @@ Config/testthat/edition: 3
|
|||
Depends:
|
||||
R (>= 3.5)
|
||||
LazyData: true
|
||||
Collate:
|
||||
'app_version.R'
|
||||
'baseline_table.R'
|
||||
'contrast_text.R'
|
||||
'correlations-module.R'
|
||||
'create-column-mod.R'
|
||||
'custom_SelectInput.R'
|
||||
'cut-variable-dates.R'
|
||||
'data-summary.R'
|
||||
'data_plots.R'
|
||||
'datagrid-infos-mod.R'
|
||||
'helpers.R'
|
||||
'hosted_version.R'
|
||||
'html_dependency_freesearchr.R'
|
||||
'import-file-ext.R'
|
||||
'import_globalenv-ext.R'
|
||||
'launch_FreesearchR.R'
|
||||
'missings-module.R'
|
||||
'plot-download-module.R'
|
||||
'plot_box.R'
|
||||
'plot_euler.R'
|
||||
'plot_hbar.R'
|
||||
'plot_ridge.R'
|
||||
'plot_sankey.R'
|
||||
'plot_scatter.R'
|
||||
'plot_violin.R'
|
||||
'redcap_read_shiny_module.R'
|
||||
'regression-module.R'
|
||||
'regression_model.R'
|
||||
'regression_plot.R'
|
||||
'regression_table.R'
|
||||
'report.R'
|
||||
'syntax_highlight.R'
|
||||
'theme.R'
|
||||
'translate.R'
|
||||
'ui_elements.R'
|
||||
'update-factor-ext.R'
|
||||
'update-variables-ext.R'
|
||||
'validation.R'
|
||||
'visual_summary.R'
|
||||
'wide2long.R'
|
||||
|
|
|
|||
|
|
@ -51,6 +51,7 @@ export(expression_string)
|
|||
export(factorize)
|
||||
export(file_export)
|
||||
export(format_writer)
|
||||
export(get_data_packages)
|
||||
export(get_fun_options)
|
||||
export(get_label)
|
||||
export(get_plot_options)
|
||||
|
|
@ -64,6 +65,8 @@ export(import_delim)
|
|||
export(import_dta)
|
||||
export(import_file_server)
|
||||
export(import_file_ui)
|
||||
export(import_globalenv_server)
|
||||
export(import_globalenv_ui)
|
||||
export(import_ods)
|
||||
export(import_rds)
|
||||
export(import_xls)
|
||||
|
|
@ -78,6 +81,7 @@ export(launch_FreesearchR)
|
|||
export(limit_log)
|
||||
export(line_break)
|
||||
export(list_allowed_operations)
|
||||
export(list_pkg_data)
|
||||
export(m_redcap_readServer)
|
||||
export(m_redcap_readUI)
|
||||
export(make_validation)
|
||||
|
|
@ -170,12 +174,14 @@ importFrom(rlang,sym)
|
|||
importFrom(rlang,syms)
|
||||
importFrom(shiny,NS)
|
||||
importFrom(shiny,actionButton)
|
||||
importFrom(shiny,actionLink)
|
||||
importFrom(shiny,bindEvent)
|
||||
importFrom(shiny,checkboxInput)
|
||||
importFrom(shiny,column)
|
||||
importFrom(shiny,fluidRow)
|
||||
importFrom(shiny,getDefaultReactiveDomain)
|
||||
importFrom(shiny,icon)
|
||||
importFrom(shiny,is.reactive)
|
||||
importFrom(shiny,isTruthy)
|
||||
importFrom(shiny,modalDialog)
|
||||
importFrom(shiny,moduleServer)
|
||||
|
|
@ -184,6 +190,7 @@ importFrom(shiny,observeEvent)
|
|||
importFrom(shiny,plotOutput)
|
||||
importFrom(shiny,reactive)
|
||||
importFrom(shiny,reactiveValues)
|
||||
importFrom(shiny,removeUI)
|
||||
importFrom(shiny,renderPlot)
|
||||
importFrom(shiny,req)
|
||||
importFrom(shiny,restoreInput)
|
||||
|
|
@ -196,6 +203,7 @@ importFrom(shiny,updateActionButton)
|
|||
importFrom(shinyWidgets,WinBox)
|
||||
importFrom(shinyWidgets,noUiSliderInput)
|
||||
importFrom(shinyWidgets,prettyCheckbox)
|
||||
importFrom(shinyWidgets,updatePickerInput)
|
||||
importFrom(shinyWidgets,updateVirtualSelect)
|
||||
importFrom(shinyWidgets,virtualSelectInput)
|
||||
importFrom(shinyWidgets,wbControls)
|
||||
|
|
@ -208,4 +216,5 @@ importFrom(toastui,grid_colorbar)
|
|||
importFrom(toastui,grid_columns)
|
||||
importFrom(toastui,renderDatagrid)
|
||||
importFrom(toastui,renderDatagrid2)
|
||||
importFrom(utils,data)
|
||||
importFrom(utils,type.convert)
|
||||
|
|
|
|||
8
NEWS.md
8
NEWS.md
|
|
@ -1,3 +1,11 @@
|
|||
# FreesearchR 25.10.1
|
||||
|
||||
*NEW* Improvements to translations with more strings having been translated.
|
||||
|
||||
*NEW* Sample data has been filtered to only include a few select packages (NHANES and stRoke).
|
||||
|
||||
*NEW* Missings evaluations slightly tweaked to include bold significant p-values for easier overview.
|
||||
|
||||
# FreesearchR 25.9.2
|
||||
|
||||
*NEW* Improvements to translations with more strings having been translated.
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
app_version <- function()'25.9.2'
|
||||
app_version <- function()'25.10.1'
|
||||
|
|
|
|||
84
R/helpers.R
84
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")
|
||||
)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
hosted_version <- function()'v25.9.2-250925'
|
||||
hosted_version <- function()'v25.10.1-251002'
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@ html_dependency_FreesearchR <- function() {
|
|||
version = packageVersion("FreesearchR"),
|
||||
src = list(href = "FreesearchR", file = "assets"),
|
||||
package = "FreesearchR",
|
||||
script = "js/FreesearchR.js",
|
||||
stylesheet = "css/FreesearchR.css"
|
||||
)
|
||||
}
|
||||
|
|
|
|||
357
R/import_globalenv-ext.R
Normal file
357
R/import_globalenv-ext.R
Normal file
|
|
@ -0,0 +1,357 @@
|
|||
|
||||
#' @title Import data from an Environment
|
||||
#'
|
||||
#' @description Let the user select a dataset from its own environment or from a package's environment.
|
||||
#' Modified from datamods
|
||||
#'
|
||||
#' @param id Module's ID.
|
||||
#' @param globalenv Search for data in Global environment.
|
||||
#' @param packages Name of packages in which to search data.
|
||||
#' @param title Module's title, if `TRUE` use the default title,
|
||||
#' use `NULL` for no title or a `shiny.tag` for a custom one.
|
||||
#'
|
||||
#' @export
|
||||
#'
|
||||
#' @name import-globalenv
|
||||
#'
|
||||
import_globalenv_ui <- function(id,
|
||||
globalenv = TRUE,
|
||||
packages = datamods::get_data_packages(),
|
||||
title = TRUE) {
|
||||
|
||||
ns <- NS(id)
|
||||
|
||||
choices <- list()
|
||||
if (isTRUE(globalenv)) {
|
||||
choices <- append(choices, "Global Environment")
|
||||
}
|
||||
if (!is.null(packages)) {
|
||||
choices <- append(choices, list(Packages = as.character(packages)))
|
||||
}
|
||||
|
||||
if (isTRUE(globalenv)) {
|
||||
selected <- "Global Environment"
|
||||
} else {
|
||||
selected <- packages[1]
|
||||
}
|
||||
|
||||
if (isTRUE(title)) {
|
||||
title <- tags$h4(
|
||||
i18n$t("Import a dataset from an environment"),
|
||||
class = "datamods-title"
|
||||
)
|
||||
}
|
||||
|
||||
tags$div(
|
||||
class = "datamods-import",
|
||||
datamods:::html_dependency_datamods(),
|
||||
title,
|
||||
shinyWidgets::pickerInput(
|
||||
inputId = ns("env"),
|
||||
label = i18n$t("Select a data source:"),
|
||||
choices = choices,
|
||||
selected = selected,
|
||||
width = "100%",
|
||||
options = list(
|
||||
"title" = i18n$t("Select source"),
|
||||
"live-search" = TRUE,
|
||||
"size" = 10
|
||||
)
|
||||
),
|
||||
shinyWidgets::pickerInput(
|
||||
inputId = ns("data"),
|
||||
label = i18n$t("Select a dataset:"),
|
||||
# selected = character(0),
|
||||
choices = NULL,
|
||||
# options = list(title = i18n$t("List of datasets...")),
|
||||
width = "100%"
|
||||
),
|
||||
|
||||
tags$div(
|
||||
id = ns("import-placeholder"),
|
||||
shinyWidgets::alert(
|
||||
id = ns("import-result"),
|
||||
status = "info",
|
||||
tags$b(i18n$t("No data selected!")),
|
||||
i18n$t("Use a datasat from your environment or from the environment of a package."),
|
||||
dismissible = TRUE
|
||||
)
|
||||
),
|
||||
uiOutput(
|
||||
outputId = ns("container_valid_btn"),
|
||||
style = "margin-top: 20px;"
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
|
||||
#' @param btn_show_data Display or not a button to display data in a modal window if import is successful.
|
||||
#' @param show_data_in Where to display data: in a `"popup"` or in a `"modal"` window.
|
||||
#' @param trigger_return When to update selected data:
|
||||
#' `"button"` (when user click on button) or
|
||||
#' `"change"` (each time user select a dataset in the list).
|
||||
#' @param return_class Class of returned data: `data.frame`, `data.table`, `tbl_df` (tibble) or `raw`.
|
||||
#' @param reset A `reactive` function that when triggered resets the data.
|
||||
#'
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shiny moduleServer reactiveValues observeEvent reactive removeUI is.reactive icon actionLink isTruthy
|
||||
#' @importFrom htmltools tags tagList
|
||||
#' @importFrom shinyWidgets updatePickerInput
|
||||
#'
|
||||
#' @rdname import-globalenv
|
||||
import_globalenv_server <- function(id,
|
||||
btn_show_data = TRUE,
|
||||
show_data_in = c("popup", "modal"),
|
||||
trigger_return = c("button", "change"),
|
||||
return_class = c("data.frame", "data.table", "tbl_df", "raw"),
|
||||
reset = reactive(NULL)) {
|
||||
|
||||
trigger_return <- match.arg(trigger_return)
|
||||
return_class <- match.arg(return_class)
|
||||
|
||||
module <- function(input, output, session) {
|
||||
|
||||
ns <- session$ns
|
||||
imported_rv <- reactiveValues(data = NULL, name = NULL)
|
||||
temporary_rv <- reactiveValues(data = NULL, name = NULL, status = NULL)
|
||||
|
||||
observeEvent(reset(), {
|
||||
temporary_rv$data <- NULL
|
||||
temporary_rv$name <- NULL
|
||||
temporary_rv$status <- NULL
|
||||
})
|
||||
|
||||
output$container_valid_btn <- renderUI({
|
||||
if (identical(trigger_return, "button")) {
|
||||
button_import()
|
||||
}
|
||||
})
|
||||
|
||||
observeEvent(input$env, {
|
||||
if (identical(input$env, "Global Environment")) {
|
||||
choices <- datamods:::search_obj("data.frame")
|
||||
} else {
|
||||
choices <- datamods:::list_pkg_data(input$env)
|
||||
}
|
||||
if (is.null(choices)) {
|
||||
choices <- i18n$t("No dataset here...")
|
||||
choicesOpt <- list(disabled = TRUE)
|
||||
} else {
|
||||
choicesOpt <- list(
|
||||
subtext = datamods:::get_dimensions(choices)
|
||||
)
|
||||
}
|
||||
temporary_rv$package <- attr(choices, "package")
|
||||
shinyWidgets::updatePickerInput(
|
||||
session = session,
|
||||
inputId = "data",
|
||||
selected = character(0),
|
||||
choices = choices,
|
||||
choicesOpt = choicesOpt,
|
||||
options = list(title = i18n$t("List of datasets..."))
|
||||
)
|
||||
})
|
||||
|
||||
observe(
|
||||
shinyWidgets::alert(
|
||||
id = "import-result",
|
||||
status = "info",
|
||||
tags$b(i18n$t("No data selected!")),
|
||||
i18n$t("Use a datasat from your environment or from the environment of a package."),
|
||||
dismissible = TRUE
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
observeEvent(input$trigger, {
|
||||
if (identical(trigger_return, "change")) {
|
||||
datamods:::hideUI(selector = paste0("#", ns("container_valid_btn")))
|
||||
}
|
||||
})
|
||||
|
||||
|
||||
|
||||
observeEvent(input$data, {
|
||||
if (!isTruthy(input$data)) {
|
||||
datamods:::toggle_widget(inputId = "confirm", enable = FALSE)
|
||||
datamods:::insert_alert(
|
||||
selector = ns("import"),
|
||||
status = "info",
|
||||
tags$b(i18n$t("No data selected!")),
|
||||
i18n$t("Use a dataset from your environment or from the environment of a package.")
|
||||
)
|
||||
} else {
|
||||
name_df <- input$data
|
||||
|
||||
if (!is.null(temporary_rv$package)) {
|
||||
attr(name_df, "package") <- temporary_rv$package
|
||||
}
|
||||
|
||||
imported <- try(get_env_data(name_df), silent = TRUE)
|
||||
|
||||
if (inherits(imported, "try-error") || NROW(imported) < 1) {
|
||||
datamods:::toggle_widget(inputId = "confirm", enable = FALSE)
|
||||
datamods:::insert_error(mssg = i18n$t(attr(imported, "condition")$message))
|
||||
temporary_rv$status <- "error"
|
||||
temporary_rv$data <- NULL
|
||||
temporary_rv$name <- NULL
|
||||
} else {
|
||||
datamods:::toggle_widget(inputId = "confirm", enable = TRUE)
|
||||
datamods:::insert_alert(
|
||||
selector = ns("import"),
|
||||
status = "success",
|
||||
datamods:::make_success_alert(
|
||||
imported,
|
||||
trigger_return = trigger_return,
|
||||
btn_show_data = btn_show_data
|
||||
)
|
||||
)
|
||||
pkg <- attr(name_df, "package")
|
||||
if (!is.null(pkg)) {
|
||||
name <- paste(pkg, input$data, sep = "::")
|
||||
} else {
|
||||
name <- input$data
|
||||
}
|
||||
name <- trimws(sub("\\(([^\\)]+)\\)", "", name))
|
||||
temporary_rv$status <- "success"
|
||||
temporary_rv$data <- imported
|
||||
temporary_rv$name <- name
|
||||
}
|
||||
}
|
||||
}, ignoreInit = TRUE, ignoreNULL = FALSE)
|
||||
|
||||
|
||||
observeEvent(input$see_data, {
|
||||
show_data(temporary_rv$data, title = i18n$t("Imported data"), type = show_data_in)
|
||||
})
|
||||
|
||||
observeEvent(input$confirm, {
|
||||
imported_rv$data <- temporary_rv$data
|
||||
imported_rv$name <- temporary_rv$name
|
||||
})
|
||||
|
||||
|
||||
if (identical(trigger_return, "button")) {
|
||||
return(list(
|
||||
status = reactive(temporary_rv$status),
|
||||
name = reactive(imported_rv$name),
|
||||
data = reactive(datamods:::as_out(imported_rv$data, return_class))
|
||||
))
|
||||
} else {
|
||||
return(list(
|
||||
status = reactive(temporary_rv$status),
|
||||
name = reactive(temporary_rv$name),
|
||||
data = reactive(datamods:::as_out(temporary_rv$data, return_class))
|
||||
))
|
||||
}
|
||||
}
|
||||
|
||||
moduleServer(
|
||||
id = id,
|
||||
module = module
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# utils -------------------------------------------------------------------
|
||||
|
||||
|
||||
#' Get packages containing datasets
|
||||
#'
|
||||
#' @return a character vector of packages names
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom utils data
|
||||
#'
|
||||
#' @examples
|
||||
#' if (interactive()) {
|
||||
#'
|
||||
#' get_data_packages()
|
||||
#'
|
||||
#' }
|
||||
get_data_packages <- function() {
|
||||
suppressWarnings({
|
||||
pkgs <- data(package = .packages(all.available = TRUE))
|
||||
})
|
||||
unique(pkgs$results[, 1])
|
||||
}
|
||||
|
||||
|
||||
#' List dataset contained in a package
|
||||
#'
|
||||
#' @param pkg Name of the package, must be installed.
|
||||
#'
|
||||
#' @return a \code{character} vector or \code{NULL}.
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom utils data
|
||||
#'
|
||||
#' @examples
|
||||
#'
|
||||
#' list_pkg_data("ggplot2")
|
||||
list_pkg_data <- function(pkg) {
|
||||
if (isTRUE(requireNamespace(pkg, quietly = TRUE))) {
|
||||
list_data <- data(package = pkg, envir = environment())$results[, "Item"]
|
||||
list_data <- sort(list_data)
|
||||
attr(list_data, "package") <- pkg
|
||||
if (length(list_data) < 1) {
|
||||
NULL
|
||||
} else {
|
||||
unname(list_data)
|
||||
}
|
||||
} else {
|
||||
NULL
|
||||
}
|
||||
}
|
||||
|
||||
#' @importFrom utils data
|
||||
get_env_data <- function(obj, env = globalenv()) {
|
||||
pkg <- attr(obj, "package")
|
||||
re <- regexpr(pattern = "\\(([^\\)]+)\\)", text = obj)
|
||||
obj_ <- substr(x = obj, start = re + 1, stop = re + attr(re, "match.length") - 2)
|
||||
obj <- gsub(pattern = "\\s.*", replacement = "", x = obj)
|
||||
if (obj %in% ls(name = env)) {
|
||||
get(x = obj, envir = env)
|
||||
} else if (!is.null(pkg) && !identical(pkg, "")) {
|
||||
res <- suppressWarnings(try(
|
||||
get(utils::data(list = obj, package = pkg, envir = environment())), silent = TRUE
|
||||
))
|
||||
if (!inherits(res, "try-error"))
|
||||
return(res)
|
||||
data(list = obj_, package = pkg, envir = environment())
|
||||
get(obj, envir = environment())
|
||||
} else {
|
||||
NULL
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
get_dimensions <- function(objs) {
|
||||
if (is.null(objs))
|
||||
return(NULL)
|
||||
dataframes_dims <- Map(
|
||||
f = function(name, pkg) {
|
||||
attr(name, "package") <- pkg
|
||||
tmp <- suppressWarnings(get_env_data(name))
|
||||
if (is.data.frame(tmp)) {
|
||||
sprintf("%d obs. of %d variables", nrow(tmp), ncol(tmp))
|
||||
} else {
|
||||
i18n$t("Not a data.frame")
|
||||
}
|
||||
},
|
||||
name = objs,
|
||||
pkg = if (!is.null(attr(objs, "package"))) {
|
||||
attr(objs, "package")
|
||||
} else {
|
||||
character(1)
|
||||
}
|
||||
)
|
||||
unlist(dataframes_dims)
|
||||
}
|
||||
|
|
@ -59,16 +59,19 @@ data_missings_server <- function(id,
|
|||
shiny::req(variabler)
|
||||
|
||||
if (is.null(variabler()) || variabler() == "" || !variabler() %in% names(datar())) {
|
||||
tbl <- rv$data()
|
||||
if (anyNA(datar())){
|
||||
title <- i18n$t("No variable chosen for analysis")
|
||||
} else {
|
||||
title <- i18n$t("No missing observations")
|
||||
}
|
||||
} else {
|
||||
tbl <- rv$data()|>
|
||||
gtsummary::bold_p()
|
||||
title <- glue::glue(i18n$t("Missing vs non-missing observations in the variable **'{variabler()}'**"))
|
||||
}
|
||||
|
||||
out <- rv$data() |>
|
||||
out <- tbl |>
|
||||
gtsummary::as_gt() |>
|
||||
gt::tab_header(title = gt::md(title))
|
||||
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
...) {
|
||||
|
||||
## 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
|
||||
|
|
|
|||
|
|
@ -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){
|
||||
|
|
|
|||
|
|
@ -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
|
||||
#'
|
||||
|
|
|
|||
|
|
@ -70,38 +70,6 @@
|
|||
#' purrr::map(regression_table) |>
|
||||
#' tbl_merge()
|
||||
#' }
|
||||
#' regression_table <- function(x, ...) {
|
||||
#' UseMethod("regression_table")
|
||||
#' }
|
||||
#'
|
||||
#' #' @rdname regression_table
|
||||
#' #' @export
|
||||
#' regression_table.list <- function(x, ...) {
|
||||
#' x |>
|
||||
#' purrr::map(\(.m){
|
||||
#' regression_table(x = .m, ...) |>
|
||||
#' gtsummary::add_n()
|
||||
#' }) |>
|
||||
#' gtsummary::tbl_stack()
|
||||
#' }
|
||||
#'
|
||||
#' #' @rdname regression_table
|
||||
#' #' @export
|
||||
#' regression_table.default <- function(x, ..., args.list = NULL, fun = "gtsummary::tbl_regression") {
|
||||
#' # Stripping custom class
|
||||
#' class(x) <- class(x)[class(x) != "freesearchr_model"]
|
||||
#'
|
||||
#' if (any(c(length(class(x)) != 1, class(x) != "lm"))) {
|
||||
#' if (!"exponentiate" %in% names(args.list)) {
|
||||
#' args.list <- c(args.list, list(exponentiate = TRUE))
|
||||
#' }
|
||||
#' }
|
||||
#'
|
||||
#' out <- do.call(getfun(fun), c(list(x = x), args.list))
|
||||
#' out |>
|
||||
#' gtsummary::add_glance_source_note() # |>
|
||||
#' # gtsummary::bold_p()
|
||||
#' }
|
||||
regression_table <- function(x, ...) {
|
||||
args <- list(...)
|
||||
|
||||
|
|
@ -179,5 +147,3 @@ tbl_merge <- function(data) {
|
|||
}
|
||||
}
|
||||
|
||||
# as_kable(tbl) |> write_lines(file=here::here("inst/apps/data_analysis_modules/www/_table1.md"))
|
||||
# as_kable_extra(tbl)|> write_lines(file=here::here("inst/apps/data_analysis_modules/www/table1.md"))
|
||||
|
|
|
|||
BIN
R/sysdata.rda
BIN
R/sysdata.rda
Binary file not shown.
|
|
@ -60,7 +60,7 @@ ui_elements <- function(selection) {
|
|||
# ),
|
||||
shiny::selectInput(
|
||||
inputId = "source",
|
||||
label="",
|
||||
label = "",
|
||||
selected = "file",
|
||||
choices = "file",
|
||||
width = "100%"
|
||||
|
|
@ -96,7 +96,11 @@ ui_elements <- function(selection) {
|
|||
),
|
||||
shiny::conditionalPanel(
|
||||
condition = "input.source=='env'",
|
||||
import_globalenv_ui(id = "env", title = NULL)
|
||||
import_globalenv_ui(
|
||||
id = "env",
|
||||
title = NULL,
|
||||
packages = c("NHANES", "stRoke")
|
||||
)
|
||||
),
|
||||
# shiny::conditionalPanel(
|
||||
# condition = "input.source=='redcap'",
|
||||
|
|
@ -350,7 +354,7 @@ ui_elements <- function(selection) {
|
|||
sidebar = bslib::sidebar(
|
||||
shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE),
|
||||
bslib::accordion(
|
||||
id="acc_chars",
|
||||
id = "acc_chars",
|
||||
open = "acc_chars",
|
||||
multiple = FALSE,
|
||||
bslib::accordion_panel(
|
||||
|
|
@ -396,7 +400,7 @@ ui_elements <- function(selection) {
|
|||
sidebar = bslib::sidebar(
|
||||
# shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE),
|
||||
bslib::accordion(
|
||||
id="acc_cor",
|
||||
id = "acc_cor",
|
||||
open = "acc_chars",
|
||||
multiple = FALSE,
|
||||
bslib::accordion_panel(
|
||||
|
|
|
|||
29
SESSION.md
29
SESSION.md
|
|
@ -4,18 +4,18 @@
|
|||
|setting |value |
|
||||
|:-----------|:------------------------------------------|
|
||||
|version |R version 4.4.1 (2024-06-14) |
|
||||
|os |macOS 15.6.1 |
|
||||
|os |macOS 15.7 |
|
||||
|system |aarch64, darwin20 |
|
||||
|ui |RStudio |
|
||||
|language |(EN) |
|
||||
|collate |en_US.UTF-8 |
|
||||
|ctype |en_US.UTF-8 |
|
||||
|tz |Europe/Copenhagen |
|
||||
|date |2025-09-25 |
|
||||
|date |2025-10-02 |
|
||||
|rstudio |2025.05.0+496 Mariposa Orchid (desktop) |
|
||||
|pandoc |3.6.4 @ /opt/homebrew/bin/ (via rmarkdown) |
|
||||
|quarto |1.7.30 @ /usr/local/bin/quarto |
|
||||
|FreesearchR |25.9.2.250925 |
|
||||
|FreesearchR |25.10.1.251002 |
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -26,8 +26,6 @@
|
|||
|apexcharter |0.4.4 |2024-09-06 |CRAN (R 4.4.1) |
|
||||
|askpass |1.2.1 |2024-10-04 |CRAN (R 4.4.1) |
|
||||
|assertthat |0.2.1 |2019-03-21 |CRAN (R 4.4.1) |
|
||||
|attachment |0.4.5 |2025-03-14 |CRAN (R 4.4.1) |
|
||||
|attempt |0.3.1 |2020-05-03 |CRAN (R 4.4.1) |
|
||||
|backports |1.5.0 |2024-05-23 |CRAN (R 4.4.1) |
|
||||
|base64enc |0.1-3 |2015-07-28 |CRAN (R 4.4.1) |
|
||||
|bayestestR |0.16.1 |2025-07-01 |CRAN (R 4.4.1) |
|
||||
|
|
@ -41,10 +39,12 @@
|
|||
|bsicons |0.1.2 |2023-11-04 |CRAN (R 4.4.0) |
|
||||
|bslib |0.9.0 |2025-01-30 |CRAN (R 4.4.1) |
|
||||
|cachem |1.1.0 |2024-05-16 |CRAN (R 4.4.1) |
|
||||
|calendar |0.2.0 |2024-08-20 |CRAN (R 4.4.1) |
|
||||
|cards |0.6.1 |2025-07-03 |CRAN (R 4.4.1) |
|
||||
|cardx |0.2.5 |2025-07-03 |CRAN (R 4.4.1) |
|
||||
|caTools |1.18.3 |2024-09-04 |CRAN (R 4.4.1) |
|
||||
|cellranger |1.1.0 |2016-07-27 |CRAN (R 4.4.0) |
|
||||
|cffr |1.2.0 |2025-01-25 |CRAN (R 4.4.1) |
|
||||
|checkmate |2.3.2 |2024-07-29 |CRAN (R 4.4.0) |
|
||||
|class |7.3-23 |2025-01-01 |CRAN (R 4.4.1) |
|
||||
|classInt |0.4-11 |2025-01-08 |CRAN (R 4.4.1) |
|
||||
|
|
@ -54,6 +54,7 @@
|
|||
|colorspace |2.1-1 |2024-07-26 |CRAN (R 4.4.1) |
|
||||
|commonmark |2.0.0 |2025-07-07 |CRAN (R 4.4.1) |
|
||||
|crayon |1.5.3 |2024-06-20 |CRAN (R 4.4.1) |
|
||||
|curl |6.4.0 |2025-06-22 |CRAN (R 4.4.1) |
|
||||
|data.table |1.17.8 |2025-07-10 |CRAN (R 4.4.1) |
|
||||
|datamods |1.5.3 |2024-10-02 |CRAN (R 4.4.1) |
|
||||
|datawizard |1.2.0 |2025-07-17 |CRAN (R 4.4.1) |
|
||||
|
|
@ -62,7 +63,6 @@
|
|||
|devtools |2.4.5 |2022-10-11 |CRAN (R 4.4.0) |
|
||||
|DHARMa |0.4.7 |2024-10-18 |CRAN (R 4.4.1) |
|
||||
|digest |0.6.37 |2024-08-19 |CRAN (R 4.4.1) |
|
||||
|dockerfiler |0.2.5 |2025-05-07 |CRAN (R 4.4.1) |
|
||||
|doParallel |1.0.17 |2022-02-07 |CRAN (R 4.4.0) |
|
||||
|dplyr |1.1.4 |2023-11-17 |CRAN (R 4.4.0) |
|
||||
|DT |0.33 |2024-04-04 |CRAN (R 4.4.0) |
|
||||
|
|
@ -85,7 +85,7 @@
|
|||
|foreach |1.5.2 |2022-02-02 |CRAN (R 4.4.0) |
|
||||
|foreign |0.8-90 |2025-03-31 |CRAN (R 4.4.1) |
|
||||
|Formula |1.2-5 |2023-02-24 |CRAN (R 4.4.1) |
|
||||
|FreesearchR |25.9.2 |NA |NA |
|
||||
|FreesearchR |25.10.1 |NA |NA |
|
||||
|fs |1.6.6 |2025-04-12 |CRAN (R 4.4.1) |
|
||||
|gdtools |0.4.2 |2025-03-27 |CRAN (R 4.4.1) |
|
||||
|generics |0.1.4 |2025-05-09 |CRAN (R 4.4.1) |
|
||||
|
|
@ -113,6 +113,7 @@
|
|||
|iterators |1.0.14 |2022-02-05 |CRAN (R 4.4.1) |
|
||||
|jquerylib |0.1.4 |2021-04-26 |CRAN (R 4.4.0) |
|
||||
|jsonlite |2.0.0 |2025-03-27 |CRAN (R 4.4.1) |
|
||||
|jsonvalidate |1.5.0 |2025-02-07 |CRAN (R 4.4.1) |
|
||||
|KernSmooth |2.23-26 |2025-01-01 |CRAN (R 4.4.1) |
|
||||
|keyring |1.4.1 |2025-06-15 |CRAN (R 4.4.1) |
|
||||
|knitr |1.50 |2025-03-16 |CRAN (R 4.4.1) |
|
||||
|
|
@ -120,9 +121,11 @@
|
|||
|later |1.4.2 |2025-04-08 |CRAN (R 4.4.1) |
|
||||
|lattice |0.22-7 |2025-04-02 |CRAN (R 4.4.1) |
|
||||
|lifecycle |1.0.4 |2023-11-07 |CRAN (R 4.4.1) |
|
||||
|litedown |0.7 |2025-04-08 |CRAN (R 4.4.1) |
|
||||
|lme4 |1.1-37 |2025-03-26 |CRAN (R 4.4.1) |
|
||||
|lubridate |1.9.4 |2024-12-08 |CRAN (R 4.4.1) |
|
||||
|magrittr |2.0.3 |2022-03-30 |CRAN (R 4.4.1) |
|
||||
|markdown |2.0 |2025-03-23 |CRAN (R 4.4.1) |
|
||||
|MASS |7.3-65 |2025-02-28 |CRAN (R 4.4.1) |
|
||||
|Matrix |1.7-3 |2025-03-11 |CRAN (R 4.4.1) |
|
||||
|memoise |2.0.1 |2021-11-26 |CRAN (R 4.4.0) |
|
||||
|
|
@ -138,7 +141,6 @@
|
|||
|opdisDownsampling |1.0.1 |2024-04-15 |CRAN (R 4.4.0) |
|
||||
|openssl |2.3.3 |2025-05-26 |CRAN (R 4.4.1) |
|
||||
|openxlsx2 |1.18 |2025-07-29 |CRAN (R 4.4.1) |
|
||||
|pak |0.9.0 |2025-05-27 |CRAN (R 4.4.1) |
|
||||
|parameters |0.27.0 |2025-07-09 |CRAN (R 4.4.1) |
|
||||
|patchwork |1.3.1 |2025-06-21 |CRAN (R 4.4.1) |
|
||||
|pbmcapply |1.5.1 |2022-04-28 |CRAN (R 4.4.1) |
|
||||
|
|
@ -161,9 +163,14 @@
|
|||
|qqconf |1.3.2 |2023-04-14 |CRAN (R 4.4.0) |
|
||||
|qqplotr |0.0.6 |2023-01-25 |CRAN (R 4.4.0) |
|
||||
|quarto |1.5.0 |2025-07-28 |RSPM (R 4.4.0) |
|
||||
|R.cache |0.17.0 |2025-05-02 |CRAN (R 4.4.1) |
|
||||
|R.methodsS3 |1.8.2 |2022-06-13 |CRAN (R 4.4.1) |
|
||||
|R.oo |1.27.1 |2025-05-02 |CRAN (R 4.4.1) |
|
||||
|R.utils |2.13.0 |2025-02-24 |CRAN (R 4.4.1) |
|
||||
|R6 |2.6.1 |2025-02-15 |CRAN (R 4.4.1) |
|
||||
|ragg |1.4.0 |2025-04-10 |CRAN (R 4.4.1) |
|
||||
|rankinPlot |1.1.0 |2023-01-30 |CRAN (R 4.4.0) |
|
||||
|rappdirs |0.3.3 |2021-01-31 |CRAN (R 4.4.1) |
|
||||
|rbibutils |2.3 |2024-10-04 |CRAN (R 4.4.1) |
|
||||
|RColorBrewer |1.1-3 |2022-04-03 |CRAN (R 4.4.1) |
|
||||
|Rcpp |1.1.0 |2025-07-02 |CRAN (R 4.4.1) |
|
||||
|
|
@ -195,13 +202,14 @@
|
|||
|sessioninfo |1.2.3 |2025-02-05 |CRAN (R 4.4.1) |
|
||||
|shiny |1.11.1 |2025-07-03 |CRAN (R 4.4.1) |
|
||||
|shiny.i18n |0.3.0 |2023-01-16 |CRAN (R 4.4.0) |
|
||||
|shiny2docker |0.0.3 |2025-06-28 |CRAN (R 4.4.1) |
|
||||
|shinybusy |0.3.3 |2024-03-09 |CRAN (R 4.4.0) |
|
||||
|shinyjs |2.1.0 |2021-12-23 |CRAN (R 4.4.0) |
|
||||
|shinyTime |1.0.3 |2022-08-19 |CRAN (R 4.4.0) |
|
||||
|shinyWidgets |0.9.0 |2025-02-21 |CRAN (R 4.4.1) |
|
||||
|stringi |1.8.7 |2025-03-27 |CRAN (R 4.4.1) |
|
||||
|stringr |1.5.1 |2023-11-14 |CRAN (R 4.4.0) |
|
||||
|stRoke |25.9.2 |2025-09-30 |CRAN (R 4.4.1) |
|
||||
|styler |1.10.3 |2024-04-07 |CRAN (R 4.4.0) |
|
||||
|systemfonts |1.2.3 |2025-04-30 |CRAN (R 4.4.1) |
|
||||
|testthat |3.2.3 |2025-01-13 |CRAN (R 4.4.1) |
|
||||
|textshaping |1.0.1 |2025-05-01 |CRAN (R 4.4.1) |
|
||||
|
|
@ -216,7 +224,9 @@
|
|||
|tzdb |0.5.0 |2025-03-15 |CRAN (R 4.4.1) |
|
||||
|urlchecker |1.0.1 |2021-11-30 |CRAN (R 4.4.1) |
|
||||
|usethis |3.1.0 |2024-11-26 |CRAN (R 4.4.1) |
|
||||
|utf8 |1.2.6 |2025-06-08 |CRAN (R 4.4.1) |
|
||||
|uuid |1.2-1 |2024-07-29 |CRAN (R 4.4.1) |
|
||||
|V8 |6.0.6 |2025-08-18 |CRAN (R 4.4.1) |
|
||||
|vctrs |0.6.5 |2023-12-01 |CRAN (R 4.4.0) |
|
||||
|vroom |1.6.5 |2023-12-05 |CRAN (R 4.4.0) |
|
||||
|withr |3.0.2 |2024-10-28 |CRAN (R 4.4.1) |
|
||||
|
|
@ -225,5 +235,4 @@
|
|||
|xml2 |1.3.8 |2025-03-14 |CRAN (R 4.4.1) |
|
||||
|xtable |1.8-4 |2019-04-21 |CRAN (R 4.4.1) |
|
||||
|yaml |2.3.10 |2024-07-26 |CRAN (R 4.4.1) |
|
||||
|yesno |0.1.3 |2024-07-26 |CRAN (R 4.4.1) |
|
||||
|zip |2.3.3 |2025-05-13 |CRAN (R 4.4.1) |
|
||||
|
|
|
|||
688
app_docker/app.R
688
app_docker/app.R
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
|
||||
########
|
||||
#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//Rtmpo2rU34/file15cb36d55cf55.R
|
||||
#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpWiu9wh/file1e9944acd364.R
|
||||
########
|
||||
|
||||
i18n_path <- here::here("translations")
|
||||
|
|
@ -62,7 +62,7 @@ i18n$set_translation_language("en")
|
|||
#### Current file: /Users/au301842/FreesearchR/R//app_version.R
|
||||
########
|
||||
|
||||
app_version <- function()'25.9.2'
|
||||
app_version <- function()'25.10.1'
|
||||
|
||||
|
||||
########
|
||||
|
|
@ -3433,7 +3433,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
|
||||
}
|
||||
|
|
@ -3948,12 +3949,93 @@ 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")
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
########
|
||||
#### Current file: /Users/au301842/FreesearchR/R//hosted_version.R
|
||||
########
|
||||
|
||||
hosted_version <- function()'v25.9.2-250925'
|
||||
hosted_version <- function()'v25.10.1-251002'
|
||||
|
||||
|
||||
########
|
||||
|
|
@ -3966,11 +4048,375 @@ html_dependency_FreesearchR <- function() {
|
|||
version = packageVersion("FreesearchR"),
|
||||
src = list(href = "FreesearchR", file = "assets"),
|
||||
package = "FreesearchR",
|
||||
script = "js/FreesearchR.js",
|
||||
stylesheet = "css/FreesearchR.css"
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
########
|
||||
#### Current file: /Users/au301842/FreesearchR/R//import_globalenv-ext.R
|
||||
########
|
||||
|
||||
|
||||
#' @title Import data from an Environment
|
||||
#'
|
||||
#' @description Let the user select a dataset from its own environment or from a package's environment.
|
||||
#' Modified from datamods
|
||||
#'
|
||||
#' @param id Module's ID.
|
||||
#' @param globalenv Search for data in Global environment.
|
||||
#' @param packages Name of packages in which to search data.
|
||||
#' @param title Module's title, if `TRUE` use the default title,
|
||||
#' use `NULL` for no title or a `shiny.tag` for a custom one.
|
||||
#'
|
||||
#' @export
|
||||
#'
|
||||
#' @name import-globalenv
|
||||
#'
|
||||
import_globalenv_ui <- function(id,
|
||||
globalenv = TRUE,
|
||||
packages = datamods::get_data_packages(),
|
||||
title = TRUE) {
|
||||
|
||||
ns <- NS(id)
|
||||
|
||||
choices <- list()
|
||||
if (isTRUE(globalenv)) {
|
||||
choices <- append(choices, "Global Environment")
|
||||
}
|
||||
if (!is.null(packages)) {
|
||||
choices <- append(choices, list(Packages = as.character(packages)))
|
||||
}
|
||||
|
||||
if (isTRUE(globalenv)) {
|
||||
selected <- "Global Environment"
|
||||
} else {
|
||||
selected <- packages[1]
|
||||
}
|
||||
|
||||
if (isTRUE(title)) {
|
||||
title <- tags$h4(
|
||||
i18n$t("Import a dataset from an environment"),
|
||||
class = "datamods-title"
|
||||
)
|
||||
}
|
||||
|
||||
tags$div(
|
||||
class = "datamods-import",
|
||||
datamods:::html_dependency_datamods(),
|
||||
title,
|
||||
shinyWidgets::pickerInput(
|
||||
inputId = ns("env"),
|
||||
label = i18n$t("Select a data source:"),
|
||||
choices = choices,
|
||||
selected = selected,
|
||||
width = "100%",
|
||||
options = list(
|
||||
"title" = i18n$t("Select source"),
|
||||
"live-search" = TRUE,
|
||||
"size" = 10
|
||||
)
|
||||
),
|
||||
shinyWidgets::pickerInput(
|
||||
inputId = ns("data"),
|
||||
label = i18n$t("Select a dataset:"),
|
||||
# selected = character(0),
|
||||
choices = NULL,
|
||||
# options = list(title = i18n$t("List of datasets...")),
|
||||
width = "100%"
|
||||
),
|
||||
|
||||
tags$div(
|
||||
id = ns("import-placeholder"),
|
||||
shinyWidgets::alert(
|
||||
id = ns("import-result"),
|
||||
status = "info",
|
||||
tags$b(i18n$t("No data selected!")),
|
||||
i18n$t("Use a datasat from your environment or from the environment of a package."),
|
||||
dismissible = TRUE
|
||||
)
|
||||
),
|
||||
uiOutput(
|
||||
outputId = ns("container_valid_btn"),
|
||||
style = "margin-top: 20px;"
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
|
||||
#' @param btn_show_data Display or not a button to display data in a modal window if import is successful.
|
||||
#' @param show_data_in Where to display data: in a `"popup"` or in a `"modal"` window.
|
||||
#' @param trigger_return When to update selected data:
|
||||
#' `"button"` (when user click on button) or
|
||||
#' `"change"` (each time user select a dataset in the list).
|
||||
#' @param return_class Class of returned data: `data.frame`, `data.table`, `tbl_df` (tibble) or `raw`.
|
||||
#' @param reset A `reactive` function that when triggered resets the data.
|
||||
#'
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shiny moduleServer reactiveValues observeEvent reactive removeUI is.reactive icon actionLink isTruthy
|
||||
#' @importFrom htmltools tags tagList
|
||||
#' @importFrom shinyWidgets updatePickerInput
|
||||
#'
|
||||
#' @rdname import-globalenv
|
||||
import_globalenv_server <- function(id,
|
||||
btn_show_data = TRUE,
|
||||
show_data_in = c("popup", "modal"),
|
||||
trigger_return = c("button", "change"),
|
||||
return_class = c("data.frame", "data.table", "tbl_df", "raw"),
|
||||
reset = reactive(NULL)) {
|
||||
|
||||
trigger_return <- match.arg(trigger_return)
|
||||
return_class <- match.arg(return_class)
|
||||
|
||||
module <- function(input, output, session) {
|
||||
|
||||
ns <- session$ns
|
||||
imported_rv <- reactiveValues(data = NULL, name = NULL)
|
||||
temporary_rv <- reactiveValues(data = NULL, name = NULL, status = NULL)
|
||||
|
||||
observeEvent(reset(), {
|
||||
temporary_rv$data <- NULL
|
||||
temporary_rv$name <- NULL
|
||||
temporary_rv$status <- NULL
|
||||
})
|
||||
|
||||
output$container_valid_btn <- renderUI({
|
||||
if (identical(trigger_return, "button")) {
|
||||
button_import()
|
||||
}
|
||||
})
|
||||
|
||||
observeEvent(input$env, {
|
||||
if (identical(input$env, "Global Environment")) {
|
||||
choices <- datamods:::search_obj("data.frame")
|
||||
} else {
|
||||
choices <- datamods:::list_pkg_data(input$env)
|
||||
}
|
||||
if (is.null(choices)) {
|
||||
choices <- i18n$t("No dataset here...")
|
||||
choicesOpt <- list(disabled = TRUE)
|
||||
} else {
|
||||
choicesOpt <- list(
|
||||
subtext = datamods:::get_dimensions(choices)
|
||||
)
|
||||
}
|
||||
temporary_rv$package <- attr(choices, "package")
|
||||
shinyWidgets::updatePickerInput(
|
||||
session = session,
|
||||
inputId = "data",
|
||||
selected = character(0),
|
||||
choices = choices,
|
||||
choicesOpt = choicesOpt,
|
||||
options = list(title = i18n$t("List of datasets..."))
|
||||
)
|
||||
})
|
||||
|
||||
observe(
|
||||
shinyWidgets::alert(
|
||||
id = "import-result",
|
||||
status = "info",
|
||||
tags$b(i18n$t("No data selected!")),
|
||||
i18n$t("Use a datasat from your environment or from the environment of a package."),
|
||||
dismissible = TRUE
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
observeEvent(input$trigger, {
|
||||
if (identical(trigger_return, "change")) {
|
||||
datamods:::hideUI(selector = paste0("#", ns("container_valid_btn")))
|
||||
}
|
||||
})
|
||||
|
||||
|
||||
|
||||
observeEvent(input$data, {
|
||||
if (!isTruthy(input$data)) {
|
||||
datamods:::toggle_widget(inputId = "confirm", enable = FALSE)
|
||||
datamods:::insert_alert(
|
||||
selector = ns("import"),
|
||||
status = "info",
|
||||
tags$b(i18n$t("No data selected!")),
|
||||
i18n$t("Use a dataset from your environment or from the environment of a package.")
|
||||
)
|
||||
} else {
|
||||
name_df <- input$data
|
||||
|
||||
if (!is.null(temporary_rv$package)) {
|
||||
attr(name_df, "package") <- temporary_rv$package
|
||||
}
|
||||
|
||||
imported <- try(get_env_data(name_df), silent = TRUE)
|
||||
|
||||
if (inherits(imported, "try-error") || NROW(imported) < 1) {
|
||||
datamods:::toggle_widget(inputId = "confirm", enable = FALSE)
|
||||
datamods:::insert_error(mssg = i18n$t(attr(imported, "condition")$message))
|
||||
temporary_rv$status <- "error"
|
||||
temporary_rv$data <- NULL
|
||||
temporary_rv$name <- NULL
|
||||
} else {
|
||||
datamods:::toggle_widget(inputId = "confirm", enable = TRUE)
|
||||
datamods:::insert_alert(
|
||||
selector = ns("import"),
|
||||
status = "success",
|
||||
datamods:::make_success_alert(
|
||||
imported,
|
||||
trigger_return = trigger_return,
|
||||
btn_show_data = btn_show_data
|
||||
)
|
||||
)
|
||||
pkg <- attr(name_df, "package")
|
||||
if (!is.null(pkg)) {
|
||||
name <- paste(pkg, input$data, sep = "::")
|
||||
} else {
|
||||
name <- input$data
|
||||
}
|
||||
name <- trimws(sub("\\(([^\\)]+)\\)", "", name))
|
||||
temporary_rv$status <- "success"
|
||||
temporary_rv$data <- imported
|
||||
temporary_rv$name <- name
|
||||
}
|
||||
}
|
||||
}, ignoreInit = TRUE, ignoreNULL = FALSE)
|
||||
|
||||
|
||||
observeEvent(input$see_data, {
|
||||
show_data(temporary_rv$data, title = i18n$t("Imported data"), type = show_data_in)
|
||||
})
|
||||
|
||||
observeEvent(input$confirm, {
|
||||
imported_rv$data <- temporary_rv$data
|
||||
imported_rv$name <- temporary_rv$name
|
||||
})
|
||||
|
||||
|
||||
if (identical(trigger_return, "button")) {
|
||||
return(list(
|
||||
status = reactive(temporary_rv$status),
|
||||
name = reactive(imported_rv$name),
|
||||
data = reactive(datamods:::as_out(imported_rv$data, return_class))
|
||||
))
|
||||
} else {
|
||||
return(list(
|
||||
status = reactive(temporary_rv$status),
|
||||
name = reactive(temporary_rv$name),
|
||||
data = reactive(datamods:::as_out(temporary_rv$data, return_class))
|
||||
))
|
||||
}
|
||||
}
|
||||
|
||||
moduleServer(
|
||||
id = id,
|
||||
module = module
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# utils -------------------------------------------------------------------
|
||||
|
||||
|
||||
#' Get packages containing datasets
|
||||
#'
|
||||
#' @return a character vector of packages names
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom utils data
|
||||
#'
|
||||
#' @examples
|
||||
#' if (interactive()) {
|
||||
#'
|
||||
#' get_data_packages()
|
||||
#'
|
||||
#' }
|
||||
get_data_packages <- function() {
|
||||
suppressWarnings({
|
||||
pkgs <- data(package = .packages(all.available = TRUE))
|
||||
})
|
||||
unique(pkgs$results[, 1])
|
||||
}
|
||||
|
||||
|
||||
#' List dataset contained in a package
|
||||
#'
|
||||
#' @param pkg Name of the package, must be installed.
|
||||
#'
|
||||
#' @return a \code{character} vector or \code{NULL}.
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom utils data
|
||||
#'
|
||||
#' @examples
|
||||
#'
|
||||
#' list_pkg_data("ggplot2")
|
||||
list_pkg_data <- function(pkg) {
|
||||
if (isTRUE(requireNamespace(pkg, quietly = TRUE))) {
|
||||
list_data <- data(package = pkg, envir = environment())$results[, "Item"]
|
||||
list_data <- sort(list_data)
|
||||
attr(list_data, "package") <- pkg
|
||||
if (length(list_data) < 1) {
|
||||
NULL
|
||||
} else {
|
||||
unname(list_data)
|
||||
}
|
||||
} else {
|
||||
NULL
|
||||
}
|
||||
}
|
||||
|
||||
#' @importFrom utils data
|
||||
get_env_data <- function(obj, env = globalenv()) {
|
||||
pkg <- attr(obj, "package")
|
||||
re <- regexpr(pattern = "\\(([^\\)]+)\\)", text = obj)
|
||||
obj_ <- substr(x = obj, start = re + 1, stop = re + attr(re, "match.length") - 2)
|
||||
obj <- gsub(pattern = "\\s.*", replacement = "", x = obj)
|
||||
if (obj %in% ls(name = env)) {
|
||||
get(x = obj, envir = env)
|
||||
} else if (!is.null(pkg) && !identical(pkg, "")) {
|
||||
res <- suppressWarnings(try(
|
||||
get(utils::data(list = obj, package = pkg, envir = environment())), silent = TRUE
|
||||
))
|
||||
if (!inherits(res, "try-error"))
|
||||
return(res)
|
||||
data(list = obj_, package = pkg, envir = environment())
|
||||
get(obj, envir = environment())
|
||||
} else {
|
||||
NULL
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
get_dimensions <- function(objs) {
|
||||
if (is.null(objs))
|
||||
return(NULL)
|
||||
dataframes_dims <- Map(
|
||||
f = function(name, pkg) {
|
||||
attr(name, "package") <- pkg
|
||||
tmp <- suppressWarnings(get_env_data(name))
|
||||
if (is.data.frame(tmp)) {
|
||||
sprintf("%d obs. of %d variables", nrow(tmp), ncol(tmp))
|
||||
} else {
|
||||
i18n$t("Not a data.frame")
|
||||
}
|
||||
},
|
||||
name = objs,
|
||||
pkg = if (!is.null(attr(objs, "package"))) {
|
||||
attr(objs, "package")
|
||||
} else {
|
||||
character(1)
|
||||
}
|
||||
)
|
||||
unlist(dataframes_dims)
|
||||
}
|
||||
|
||||
|
||||
########
|
||||
#### Current file: /Users/au301842/FreesearchR/R//import-file-ext.R
|
||||
########
|
||||
|
|
@ -4685,16 +5131,19 @@ data_missings_server <- function(id,
|
|||
shiny::req(variabler)
|
||||
|
||||
if (is.null(variabler()) || variabler() == "" || !variabler() %in% names(datar())) {
|
||||
tbl <- rv$data()
|
||||
if (anyNA(datar())){
|
||||
title <- i18n$t("No variable chosen for analysis")
|
||||
} else {
|
||||
title <- i18n$t("No missing observations")
|
||||
}
|
||||
} else {
|
||||
tbl <- rv$data()|>
|
||||
gtsummary::bold_p()
|
||||
title <- glue::glue(i18n$t("Missing vs non-missing observations in the variable **'{variabler()}'**"))
|
||||
}
|
||||
|
||||
out <- rv$data() |>
|
||||
out <- tbl |>
|
||||
gtsummary::as_gt() |>
|
||||
gt::tab_header(title = gt::md(title))
|
||||
|
||||
|
|
@ -4875,7 +5324,7 @@ plot_box_single <- function(data, pri, sec=NULL, seed = 2103) {
|
|||
#' 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
|
||||
|
|
@ -4885,18 +5334,27 @@ plot_box_single <- function(data, pri, sec=NULL, seed = 2103) {
|
|||
#' @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,
|
||||
...) {
|
||||
|
||||
## 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(
|
||||
|
|
@ -4912,7 +5370,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)) {
|
||||
|
|
@ -4951,6 +5410,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)) {
|
||||
|
|
@ -4958,16 +5432,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
|
||||
|
|
@ -6475,87 +6946,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
|
||||
#'
|
||||
|
|
@ -7196,38 +7586,6 @@ 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")
|
||||
#' }
|
||||
#'
|
||||
#' #' @rdname regression_table
|
||||
#' #' @export
|
||||
#' regression_table.list <- function(x, ...) {
|
||||
#' x |>
|
||||
#' purrr::map(\(.m){
|
||||
#' regression_table(x = .m, ...) |>
|
||||
#' gtsummary::add_n()
|
||||
#' }) |>
|
||||
#' gtsummary::tbl_stack()
|
||||
#' }
|
||||
#'
|
||||
#' #' @rdname regression_table
|
||||
#' #' @export
|
||||
#' regression_table.default <- function(x, ..., args.list = NULL, fun = "gtsummary::tbl_regression") {
|
||||
#' # Stripping custom class
|
||||
#' class(x) <- class(x)[class(x) != "freesearchr_model"]
|
||||
#'
|
||||
#' if (any(c(length(class(x)) != 1, class(x) != "lm"))) {
|
||||
#' if (!"exponentiate" %in% names(args.list)) {
|
||||
#' args.list <- c(args.list, list(exponentiate = TRUE))
|
||||
#' }
|
||||
#' }
|
||||
#'
|
||||
#' out <- do.call(getfun(fun), c(list(x = x), args.list))
|
||||
#' out |>
|
||||
#' gtsummary::add_glance_source_note() # |>
|
||||
#' # gtsummary::bold_p()
|
||||
#' }
|
||||
regression_table <- function(x, ...) {
|
||||
args <- list(...)
|
||||
|
||||
|
|
@ -7305,8 +7663,6 @@ tbl_merge <- function(data) {
|
|||
}
|
||||
}
|
||||
|
||||
# as_kable(tbl) |> write_lines(file=here::here("inst/apps/data_analysis_modules/www/_table1.md"))
|
||||
# as_kable_extra(tbl)|> write_lines(file=here::here("inst/apps/data_analysis_modules/www/table1.md"))
|
||||
|
||||
|
||||
########
|
||||
|
|
@ -7387,13 +7743,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")),
|
||||
|
|
@ -7446,7 +7804,7 @@ regression_ui <- function(id, ...) {
|
|||
)
|
||||
),
|
||||
bslib::nav_panel(
|
||||
title = "Coefficient plot",
|
||||
title = i18n$t("Coefficient plot"),
|
||||
bslib::layout_sidebar(
|
||||
sidebar = bslib::sidebar(
|
||||
bslib::accordion(
|
||||
|
|
@ -7558,11 +7916,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())
|
||||
|
|
@ -7570,6 +7923,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
|
||||
|
|
@ -7593,7 +7971,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
|
||||
)
|
||||
|
|
@ -7603,7 +7981,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(
|
||||
|
|
@ -7622,7 +8000,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
|
||||
)
|
||||
|
|
@ -7642,7 +8020,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",
|
||||
|
|
@ -7657,7 +8035,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
|
||||
)
|
||||
|
|
@ -7707,7 +8085,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")
|
||||
}
|
||||
)
|
||||
}
|
||||
|
|
@ -7772,7 +8150,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")
|
||||
}
|
||||
)
|
||||
}
|
||||
|
|
@ -7873,7 +8251,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,
|
||||
|
|
@ -7910,7 +8288,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")
|
||||
}
|
||||
)
|
||||
}
|
||||
|
|
@ -7931,7 +8309,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
|
||||
)
|
||||
|
|
@ -7946,7 +8324,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){
|
||||
|
|
@ -8325,7 +8703,7 @@ ui_elements <- function(selection) {
|
|||
# ),
|
||||
shiny::selectInput(
|
||||
inputId = "source",
|
||||
label="",
|
||||
label = "",
|
||||
selected = "file",
|
||||
choices = "file",
|
||||
width = "100%"
|
||||
|
|
@ -8361,7 +8739,11 @@ ui_elements <- function(selection) {
|
|||
),
|
||||
shiny::conditionalPanel(
|
||||
condition = "input.source=='env'",
|
||||
import_globalenv_ui(id = "env", title = NULL)
|
||||
import_globalenv_ui(
|
||||
id = "env",
|
||||
title = NULL,
|
||||
packages = c("NHANES", "stRoke")
|
||||
)
|
||||
),
|
||||
# shiny::conditionalPanel(
|
||||
# condition = "input.source=='redcap'",
|
||||
|
|
@ -8615,7 +8997,7 @@ ui_elements <- function(selection) {
|
|||
sidebar = bslib::sidebar(
|
||||
shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE),
|
||||
bslib::accordion(
|
||||
id="acc_chars",
|
||||
id = "acc_chars",
|
||||
open = "acc_chars",
|
||||
multiple = FALSE,
|
||||
bslib::accordion_panel(
|
||||
|
|
@ -8661,7 +9043,7 @@ ui_elements <- function(selection) {
|
|||
sidebar = bslib::sidebar(
|
||||
# shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE),
|
||||
bslib::accordion(
|
||||
id="acc_cor",
|
||||
id = "acc_cor",
|
||||
open = "acc_chars",
|
||||
multiple = FALSE,
|
||||
bslib::accordion_panel(
|
||||
|
|
@ -10979,6 +11361,7 @@ ui <- bslib::page_fixed(
|
|||
## Code formatting dependencies
|
||||
prismDependencies,
|
||||
prismRDependency,
|
||||
# html_dependency_FreesearchR(),
|
||||
## Version dependent header
|
||||
header_include(),
|
||||
## This adds the actual favicon
|
||||
|
|
@ -11264,7 +11647,8 @@ server <- function(input, output, session) {
|
|||
rv$code <- modifyList(x = rv$code, list(import = from_redcap$code()))
|
||||
})
|
||||
|
||||
from_env <- datamods::import_globalenv_server(
|
||||
# from_env <- datamods::import_globalenv_server(
|
||||
from_env <- import_globalenv_server(
|
||||
id = "env",
|
||||
trigger_return = "change",
|
||||
btn_show_data = FALSE,
|
||||
|
|
|
|||
|
|
@ -1588,6 +1588,39 @@
|
|||
"Maintainer": "Winston Chang <winston@posit.co>",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"calendar": {
|
||||
"Package": "calendar",
|
||||
"Version": "0.2.0",
|
||||
"Source": "Repository",
|
||||
"Title": "Create, Read, Write, and Work with 'iCalendar' Files, Calendars and Scheduling Data",
|
||||
"Authors@R": "c(person(given = \"Robin\", family = \"Lovelace\", role = c(\"aut\", \"cre\"), email = \"rob00x@gmail.com\", comment = c(ORCID = \"0000-0001-5679-6536\")), person(given = \"Layik\", family = \"Hama\", role = \"aut\", email = \"layik.hama@gmail.com\", comment = c(ORCID = \"0000-0003-1912-4890\")), person(given = \"Ollie\", family = \"Lloyd\", role = \"ctb\", email = \"o.lloyd@doctors.org.uk\", comment = c(ORCID = \"0000-0002-9385-1634\")), person(given = \"Franco\", family = \"Scarafia\", role = \"ctb\", email = \"franco.scarafia@hotmail.com\", comment = c(ORCID = \"0009-0005-9822-169X\")), person(given = \"Serkan\", family = \"Korkmaz\", email = \"serkor1@duck.com\", role = c(\"ctb\"), comment = c(ORCID = \"0000-0002-5052-0982\")) )",
|
||||
"Description": "Provides function to create, read, write, and work with 'iCalendar' files (which typically have '.ics' or '.ical' extensions), and the scheduling data, calendars and timelines of people, organisations and other entities that they represent. 'iCalendar' is an open standard for exchanging calendar and scheduling information between users and computers, described at <https://icalendar.org/>.",
|
||||
"License": "Apache License (>= 2.0)",
|
||||
"URL": "https://github.com/atfutures/calendar, https://atfutures.github.io/calendar/, https://github.com/ATFutures/calendar",
|
||||
"BugReports": "https://github.com/ATFutures/calendar/issues",
|
||||
"Depends": [
|
||||
"R (>= 3.4.0)"
|
||||
],
|
||||
"Imports": [
|
||||
"cli",
|
||||
"lubridate",
|
||||
"tibble"
|
||||
],
|
||||
"Suggests": [
|
||||
"covr",
|
||||
"knitr",
|
||||
"rmarkdown",
|
||||
"testthat"
|
||||
],
|
||||
"VignetteBuilder": "knitr",
|
||||
"Encoding": "UTF-8",
|
||||
"LazyData": "true",
|
||||
"RoxygenNote": "7.3.2",
|
||||
"NeedsCompilation": "no",
|
||||
"Author": "Robin Lovelace [aut, cre] (<https://orcid.org/0000-0001-5679-6536>), Layik Hama [aut] (<https://orcid.org/0000-0003-1912-4890>), Ollie Lloyd [ctb] (<https://orcid.org/0000-0002-9385-1634>), Franco Scarafia [ctb] (<https://orcid.org/0009-0005-9822-169X>), Serkan Korkmaz [ctb] (<https://orcid.org/0000-0002-5052-0982>)",
|
||||
"Maintainer": "Robin Lovelace <rob00x@gmail.com>",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"cards": {
|
||||
"Package": "cards",
|
||||
"Version": "0.6.1",
|
||||
|
|
@ -8257,6 +8290,56 @@
|
|||
"NeedsCompilation": "yes",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"stRoke": {
|
||||
"Package": "stRoke",
|
||||
"Version": "25.9.2",
|
||||
"Source": "Repository",
|
||||
"Title": "Clinical Stroke Research",
|
||||
"Authors@R": "person(\"Andreas Gammelgaard\", \"Damsbo\", , \"agdamsbo@clin.au.dk\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-7559-1154\"))",
|
||||
"Description": "A collection of tools for clinical trial data management and analysis in research and teaching. The package is mainly collected for personal use, but any use beyond that is encouraged. This package has migrated functions from 'agdamsbo/daDoctoR', and new functions has been added. Version follows months and year. See NEWS/Changelog for release notes. This package includes sampled data from the TALOS trial (Kraglund et al (2018) <doi:10.1161/STROKEAHA.117.020067>). The win_prob() function is based on work by Zou et al (2022) <doi:10.1161/STROKEAHA.121.037744>. The age_calc() function is based on work by Becker (2020) <doi:10.18637/jss.v093.i02>.",
|
||||
"URL": "https://agdamsbo.github.io/stRoke/, https://github.com/agdamsbo/stRoke",
|
||||
"BugReports": "https://github.com/agdamsbo/stRoke/issues",
|
||||
"License": "GPL-3",
|
||||
"Encoding": "UTF-8",
|
||||
"RoxygenNote": "7.3.2",
|
||||
"LazyData": "true",
|
||||
"Suggests": [
|
||||
"knitr",
|
||||
"rmarkdown",
|
||||
"testthat",
|
||||
"here",
|
||||
"spelling",
|
||||
"usethis",
|
||||
"pak",
|
||||
"roxygen2",
|
||||
"devtools"
|
||||
],
|
||||
"Config/testthat/edition": "3",
|
||||
"Imports": [
|
||||
"calendar",
|
||||
"dplyr",
|
||||
"ggplot2",
|
||||
"grDevices",
|
||||
"gtsummary",
|
||||
"lubridate",
|
||||
"MASS",
|
||||
"rankinPlot",
|
||||
"stats",
|
||||
"tidyr",
|
||||
"utils",
|
||||
"tibble",
|
||||
"tidyselect"
|
||||
],
|
||||
"Depends": [
|
||||
"R (>= 4.1.0)"
|
||||
],
|
||||
"VignetteBuilder": "knitr",
|
||||
"Language": "en-US",
|
||||
"NeedsCompilation": "no",
|
||||
"Author": "Andreas Gammelgaard Damsbo [aut, cre] (ORCID: <https://orcid.org/0000-0002-7559-1154>)",
|
||||
"Maintainer": "Andreas Gammelgaard Damsbo <agdamsbo@clin.au.dk>",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"stringi": {
|
||||
"Package": "stringi",
|
||||
"Version": "1.8.7",
|
||||
|
|
|
|||
|
|
@ -219,3 +219,28 @@
|
|||
"Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.","Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access."
|
||||
"Click to see the imported data","Click to see the imported data"
|
||||
"Regression table","Regression table"
|
||||
"Import a dataset from an environment","Import a dataset from an environment"
|
||||
"Select a dataset:","Vælg datasæt:"
|
||||
"List of datasets...","List of datasets..."
|
||||
"No data selected!","Ingen data valgt!"
|
||||
"Use a datasat from your environment or from the environment of a package.","Use a datasat from your environment or from the environment of a package."
|
||||
"No dataset here...","Ingen datasæt her..."
|
||||
"Use a dataset from your environment or from the environment of a package.","Use a dataset from your environment or from the environment of a package."
|
||||
"Not a data.frame","Ikke en data.frame"
|
||||
"Select source","Vælg datakilde"
|
||||
"Select a data source:","Vælg datakilde:"
|
||||
"Yes","Ja"
|
||||
"No","Nej"
|
||||
"Coefficient plot","Coefficient plot"
|
||||
"Select outcome variable","Select outcome variable"
|
||||
"Choose regression analysis","Choose regression analysis"
|
||||
"Covariables to format as categorical","Covariables to format as categorical"
|
||||
"Select variable to stratify baseline","Select variable to stratify baseline"
|
||||
"Select models to plot","Select models to plot"
|
||||
"Creating regression models failed with the following error:","Creating regression models failed with the following error:"
|
||||
"Creating a regression table failed with the following error:","Creating a regression table failed with the following error:"
|
||||
"Saving the plot. Hold on for a moment..","Saving the plot. Hold on for a moment.."
|
||||
"Running model assumptions checks failed with the following error:","Running model assumptions checks failed with the following error:"
|
||||
"Select checks to plot","Select checks to plot"
|
||||
"Multivariable regression model checks","Multivariable regression model checks"
|
||||
"Grouped by {get_label(data,ter)}","Grouped by {get_label(data,ter)}"
|
||||
|
|
|
|||
|
|
|
@ -219,3 +219,28 @@
|
|||
"Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.","Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access."
|
||||
"Click to see the imported data","Click to see the imported data"
|
||||
"Regression table","Regression table"
|
||||
"Import a dataset from an environment","Import a dataset from an environment"
|
||||
"Select a dataset:","Select a dataset:"
|
||||
"List of datasets...","List of datasets..."
|
||||
"No data selected!","No data selected!"
|
||||
"Use a datasat from your environment or from the environment of a package.","Use a datasat from your environment or from the environment of a package."
|
||||
"No dataset here...","No dataset here..."
|
||||
"Use a dataset from your environment or from the environment of a package.","Use a dataset from your environment or from the environment of a package."
|
||||
"Not a data.frame","Not a data.frame"
|
||||
"Select source","Select source"
|
||||
"Select a data source:","Select a data source:"
|
||||
"Yes","Yes"
|
||||
"No","No"
|
||||
"Coefficient plot","Coefficient plot"
|
||||
"Select outcome variable","Select outcome variable"
|
||||
"Choose regression analysis","Choose regression analysis"
|
||||
"Covariables to format as categorical","Covariables to format as categorical"
|
||||
"Select variable to stratify baseline","Select variable to stratify baseline"
|
||||
"Select models to plot","Select models to plot"
|
||||
"Creating regression models failed with the following error:","Creating regression models failed with the following error:"
|
||||
"Creating a regression table failed with the following error:","Creating a regression table failed with the following error:"
|
||||
"Saving the plot. Hold on for a moment..","Saving the plot. Hold on for a moment.."
|
||||
"Running model assumptions checks failed with the following error:","Running model assumptions checks failed with the following error:"
|
||||
"Select checks to plot","Select checks to plot"
|
||||
"Multivariable regression model checks","Multivariable regression model checks"
|
||||
"Grouped by {get_label(data,ter)}","Grouped by {get_label(data,ter)}"
|
||||
|
|
|
|||
|
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
|
||||
########
|
||||
#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//Rtmpo2rU34/file15cb31846160a.R
|
||||
#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpWiu9wh/file1e99785ae783.R
|
||||
########
|
||||
|
||||
i18n_path <- system.file("translations", package = "FreesearchR")
|
||||
|
|
@ -62,7 +62,7 @@ i18n$set_translation_language("en")
|
|||
#### Current file: /Users/au301842/FreesearchR/R//app_version.R
|
||||
########
|
||||
|
||||
app_version <- function()'25.9.2'
|
||||
app_version <- function()'25.10.1'
|
||||
|
||||
|
||||
########
|
||||
|
|
@ -3433,7 +3433,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
|
||||
}
|
||||
|
|
@ -3948,12 +3949,93 @@ 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")
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
########
|
||||
#### Current file: /Users/au301842/FreesearchR/R//hosted_version.R
|
||||
########
|
||||
|
||||
hosted_version <- function()'v25.9.2-250925'
|
||||
hosted_version <- function()'v25.10.1-251002'
|
||||
|
||||
|
||||
########
|
||||
|
|
@ -3966,11 +4048,375 @@ html_dependency_FreesearchR <- function() {
|
|||
version = packageVersion("FreesearchR"),
|
||||
src = list(href = "FreesearchR", file = "assets"),
|
||||
package = "FreesearchR",
|
||||
script = "js/FreesearchR.js",
|
||||
stylesheet = "css/FreesearchR.css"
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
########
|
||||
#### Current file: /Users/au301842/FreesearchR/R//import_globalenv-ext.R
|
||||
########
|
||||
|
||||
|
||||
#' @title Import data from an Environment
|
||||
#'
|
||||
#' @description Let the user select a dataset from its own environment or from a package's environment.
|
||||
#' Modified from datamods
|
||||
#'
|
||||
#' @param id Module's ID.
|
||||
#' @param globalenv Search for data in Global environment.
|
||||
#' @param packages Name of packages in which to search data.
|
||||
#' @param title Module's title, if `TRUE` use the default title,
|
||||
#' use `NULL` for no title or a `shiny.tag` for a custom one.
|
||||
#'
|
||||
#' @export
|
||||
#'
|
||||
#' @name import-globalenv
|
||||
#'
|
||||
import_globalenv_ui <- function(id,
|
||||
globalenv = TRUE,
|
||||
packages = datamods::get_data_packages(),
|
||||
title = TRUE) {
|
||||
|
||||
ns <- NS(id)
|
||||
|
||||
choices <- list()
|
||||
if (isTRUE(globalenv)) {
|
||||
choices <- append(choices, "Global Environment")
|
||||
}
|
||||
if (!is.null(packages)) {
|
||||
choices <- append(choices, list(Packages = as.character(packages)))
|
||||
}
|
||||
|
||||
if (isTRUE(globalenv)) {
|
||||
selected <- "Global Environment"
|
||||
} else {
|
||||
selected <- packages[1]
|
||||
}
|
||||
|
||||
if (isTRUE(title)) {
|
||||
title <- tags$h4(
|
||||
i18n$t("Import a dataset from an environment"),
|
||||
class = "datamods-title"
|
||||
)
|
||||
}
|
||||
|
||||
tags$div(
|
||||
class = "datamods-import",
|
||||
datamods:::html_dependency_datamods(),
|
||||
title,
|
||||
shinyWidgets::pickerInput(
|
||||
inputId = ns("env"),
|
||||
label = i18n$t("Select a data source:"),
|
||||
choices = choices,
|
||||
selected = selected,
|
||||
width = "100%",
|
||||
options = list(
|
||||
"title" = i18n$t("Select source"),
|
||||
"live-search" = TRUE,
|
||||
"size" = 10
|
||||
)
|
||||
),
|
||||
shinyWidgets::pickerInput(
|
||||
inputId = ns("data"),
|
||||
label = i18n$t("Select a dataset:"),
|
||||
# selected = character(0),
|
||||
choices = NULL,
|
||||
# options = list(title = i18n$t("List of datasets...")),
|
||||
width = "100%"
|
||||
),
|
||||
|
||||
tags$div(
|
||||
id = ns("import-placeholder"),
|
||||
shinyWidgets::alert(
|
||||
id = ns("import-result"),
|
||||
status = "info",
|
||||
tags$b(i18n$t("No data selected!")),
|
||||
i18n$t("Use a datasat from your environment or from the environment of a package."),
|
||||
dismissible = TRUE
|
||||
)
|
||||
),
|
||||
uiOutput(
|
||||
outputId = ns("container_valid_btn"),
|
||||
style = "margin-top: 20px;"
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
|
||||
#' @param btn_show_data Display or not a button to display data in a modal window if import is successful.
|
||||
#' @param show_data_in Where to display data: in a `"popup"` or in a `"modal"` window.
|
||||
#' @param trigger_return When to update selected data:
|
||||
#' `"button"` (when user click on button) or
|
||||
#' `"change"` (each time user select a dataset in the list).
|
||||
#' @param return_class Class of returned data: `data.frame`, `data.table`, `tbl_df` (tibble) or `raw`.
|
||||
#' @param reset A `reactive` function that when triggered resets the data.
|
||||
#'
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shiny moduleServer reactiveValues observeEvent reactive removeUI is.reactive icon actionLink isTruthy
|
||||
#' @importFrom htmltools tags tagList
|
||||
#' @importFrom shinyWidgets updatePickerInput
|
||||
#'
|
||||
#' @rdname import-globalenv
|
||||
import_globalenv_server <- function(id,
|
||||
btn_show_data = TRUE,
|
||||
show_data_in = c("popup", "modal"),
|
||||
trigger_return = c("button", "change"),
|
||||
return_class = c("data.frame", "data.table", "tbl_df", "raw"),
|
||||
reset = reactive(NULL)) {
|
||||
|
||||
trigger_return <- match.arg(trigger_return)
|
||||
return_class <- match.arg(return_class)
|
||||
|
||||
module <- function(input, output, session) {
|
||||
|
||||
ns <- session$ns
|
||||
imported_rv <- reactiveValues(data = NULL, name = NULL)
|
||||
temporary_rv <- reactiveValues(data = NULL, name = NULL, status = NULL)
|
||||
|
||||
observeEvent(reset(), {
|
||||
temporary_rv$data <- NULL
|
||||
temporary_rv$name <- NULL
|
||||
temporary_rv$status <- NULL
|
||||
})
|
||||
|
||||
output$container_valid_btn <- renderUI({
|
||||
if (identical(trigger_return, "button")) {
|
||||
button_import()
|
||||
}
|
||||
})
|
||||
|
||||
observeEvent(input$env, {
|
||||
if (identical(input$env, "Global Environment")) {
|
||||
choices <- datamods:::search_obj("data.frame")
|
||||
} else {
|
||||
choices <- datamods:::list_pkg_data(input$env)
|
||||
}
|
||||
if (is.null(choices)) {
|
||||
choices <- i18n$t("No dataset here...")
|
||||
choicesOpt <- list(disabled = TRUE)
|
||||
} else {
|
||||
choicesOpt <- list(
|
||||
subtext = datamods:::get_dimensions(choices)
|
||||
)
|
||||
}
|
||||
temporary_rv$package <- attr(choices, "package")
|
||||
shinyWidgets::updatePickerInput(
|
||||
session = session,
|
||||
inputId = "data",
|
||||
selected = character(0),
|
||||
choices = choices,
|
||||
choicesOpt = choicesOpt,
|
||||
options = list(title = i18n$t("List of datasets..."))
|
||||
)
|
||||
})
|
||||
|
||||
observe(
|
||||
shinyWidgets::alert(
|
||||
id = "import-result",
|
||||
status = "info",
|
||||
tags$b(i18n$t("No data selected!")),
|
||||
i18n$t("Use a datasat from your environment or from the environment of a package."),
|
||||
dismissible = TRUE
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
observeEvent(input$trigger, {
|
||||
if (identical(trigger_return, "change")) {
|
||||
datamods:::hideUI(selector = paste0("#", ns("container_valid_btn")))
|
||||
}
|
||||
})
|
||||
|
||||
|
||||
|
||||
observeEvent(input$data, {
|
||||
if (!isTruthy(input$data)) {
|
||||
datamods:::toggle_widget(inputId = "confirm", enable = FALSE)
|
||||
datamods:::insert_alert(
|
||||
selector = ns("import"),
|
||||
status = "info",
|
||||
tags$b(i18n$t("No data selected!")),
|
||||
i18n$t("Use a dataset from your environment or from the environment of a package.")
|
||||
)
|
||||
} else {
|
||||
name_df <- input$data
|
||||
|
||||
if (!is.null(temporary_rv$package)) {
|
||||
attr(name_df, "package") <- temporary_rv$package
|
||||
}
|
||||
|
||||
imported <- try(get_env_data(name_df), silent = TRUE)
|
||||
|
||||
if (inherits(imported, "try-error") || NROW(imported) < 1) {
|
||||
datamods:::toggle_widget(inputId = "confirm", enable = FALSE)
|
||||
datamods:::insert_error(mssg = i18n$t(attr(imported, "condition")$message))
|
||||
temporary_rv$status <- "error"
|
||||
temporary_rv$data <- NULL
|
||||
temporary_rv$name <- NULL
|
||||
} else {
|
||||
datamods:::toggle_widget(inputId = "confirm", enable = TRUE)
|
||||
datamods:::insert_alert(
|
||||
selector = ns("import"),
|
||||
status = "success",
|
||||
datamods:::make_success_alert(
|
||||
imported,
|
||||
trigger_return = trigger_return,
|
||||
btn_show_data = btn_show_data
|
||||
)
|
||||
)
|
||||
pkg <- attr(name_df, "package")
|
||||
if (!is.null(pkg)) {
|
||||
name <- paste(pkg, input$data, sep = "::")
|
||||
} else {
|
||||
name <- input$data
|
||||
}
|
||||
name <- trimws(sub("\\(([^\\)]+)\\)", "", name))
|
||||
temporary_rv$status <- "success"
|
||||
temporary_rv$data <- imported
|
||||
temporary_rv$name <- name
|
||||
}
|
||||
}
|
||||
}, ignoreInit = TRUE, ignoreNULL = FALSE)
|
||||
|
||||
|
||||
observeEvent(input$see_data, {
|
||||
show_data(temporary_rv$data, title = i18n$t("Imported data"), type = show_data_in)
|
||||
})
|
||||
|
||||
observeEvent(input$confirm, {
|
||||
imported_rv$data <- temporary_rv$data
|
||||
imported_rv$name <- temporary_rv$name
|
||||
})
|
||||
|
||||
|
||||
if (identical(trigger_return, "button")) {
|
||||
return(list(
|
||||
status = reactive(temporary_rv$status),
|
||||
name = reactive(imported_rv$name),
|
||||
data = reactive(datamods:::as_out(imported_rv$data, return_class))
|
||||
))
|
||||
} else {
|
||||
return(list(
|
||||
status = reactive(temporary_rv$status),
|
||||
name = reactive(temporary_rv$name),
|
||||
data = reactive(datamods:::as_out(temporary_rv$data, return_class))
|
||||
))
|
||||
}
|
||||
}
|
||||
|
||||
moduleServer(
|
||||
id = id,
|
||||
module = module
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# utils -------------------------------------------------------------------
|
||||
|
||||
|
||||
#' Get packages containing datasets
|
||||
#'
|
||||
#' @return a character vector of packages names
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom utils data
|
||||
#'
|
||||
#' @examples
|
||||
#' if (interactive()) {
|
||||
#'
|
||||
#' get_data_packages()
|
||||
#'
|
||||
#' }
|
||||
get_data_packages <- function() {
|
||||
suppressWarnings({
|
||||
pkgs <- data(package = .packages(all.available = TRUE))
|
||||
})
|
||||
unique(pkgs$results[, 1])
|
||||
}
|
||||
|
||||
|
||||
#' List dataset contained in a package
|
||||
#'
|
||||
#' @param pkg Name of the package, must be installed.
|
||||
#'
|
||||
#' @return a \code{character} vector or \code{NULL}.
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom utils data
|
||||
#'
|
||||
#' @examples
|
||||
#'
|
||||
#' list_pkg_data("ggplot2")
|
||||
list_pkg_data <- function(pkg) {
|
||||
if (isTRUE(requireNamespace(pkg, quietly = TRUE))) {
|
||||
list_data <- data(package = pkg, envir = environment())$results[, "Item"]
|
||||
list_data <- sort(list_data)
|
||||
attr(list_data, "package") <- pkg
|
||||
if (length(list_data) < 1) {
|
||||
NULL
|
||||
} else {
|
||||
unname(list_data)
|
||||
}
|
||||
} else {
|
||||
NULL
|
||||
}
|
||||
}
|
||||
|
||||
#' @importFrom utils data
|
||||
get_env_data <- function(obj, env = globalenv()) {
|
||||
pkg <- attr(obj, "package")
|
||||
re <- regexpr(pattern = "\\(([^\\)]+)\\)", text = obj)
|
||||
obj_ <- substr(x = obj, start = re + 1, stop = re + attr(re, "match.length") - 2)
|
||||
obj <- gsub(pattern = "\\s.*", replacement = "", x = obj)
|
||||
if (obj %in% ls(name = env)) {
|
||||
get(x = obj, envir = env)
|
||||
} else if (!is.null(pkg) && !identical(pkg, "")) {
|
||||
res <- suppressWarnings(try(
|
||||
get(utils::data(list = obj, package = pkg, envir = environment())), silent = TRUE
|
||||
))
|
||||
if (!inherits(res, "try-error"))
|
||||
return(res)
|
||||
data(list = obj_, package = pkg, envir = environment())
|
||||
get(obj, envir = environment())
|
||||
} else {
|
||||
NULL
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
get_dimensions <- function(objs) {
|
||||
if (is.null(objs))
|
||||
return(NULL)
|
||||
dataframes_dims <- Map(
|
||||
f = function(name, pkg) {
|
||||
attr(name, "package") <- pkg
|
||||
tmp <- suppressWarnings(get_env_data(name))
|
||||
if (is.data.frame(tmp)) {
|
||||
sprintf("%d obs. of %d variables", nrow(tmp), ncol(tmp))
|
||||
} else {
|
||||
i18n$t("Not a data.frame")
|
||||
}
|
||||
},
|
||||
name = objs,
|
||||
pkg = if (!is.null(attr(objs, "package"))) {
|
||||
attr(objs, "package")
|
||||
} else {
|
||||
character(1)
|
||||
}
|
||||
)
|
||||
unlist(dataframes_dims)
|
||||
}
|
||||
|
||||
|
||||
########
|
||||
#### Current file: /Users/au301842/FreesearchR/R//import-file-ext.R
|
||||
########
|
||||
|
|
@ -4685,16 +5131,19 @@ data_missings_server <- function(id,
|
|||
shiny::req(variabler)
|
||||
|
||||
if (is.null(variabler()) || variabler() == "" || !variabler() %in% names(datar())) {
|
||||
tbl <- rv$data()
|
||||
if (anyNA(datar())){
|
||||
title <- i18n$t("No variable chosen for analysis")
|
||||
} else {
|
||||
title <- i18n$t("No missing observations")
|
||||
}
|
||||
} else {
|
||||
tbl <- rv$data()|>
|
||||
gtsummary::bold_p()
|
||||
title <- glue::glue(i18n$t("Missing vs non-missing observations in the variable **'{variabler()}'**"))
|
||||
}
|
||||
|
||||
out <- rv$data() |>
|
||||
out <- tbl |>
|
||||
gtsummary::as_gt() |>
|
||||
gt::tab_header(title = gt::md(title))
|
||||
|
||||
|
|
@ -4875,7 +5324,7 @@ plot_box_single <- function(data, pri, sec=NULL, seed = 2103) {
|
|||
#' 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
|
||||
|
|
@ -4885,18 +5334,27 @@ plot_box_single <- function(data, pri, sec=NULL, seed = 2103) {
|
|||
#' @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,
|
||||
...) {
|
||||
|
||||
## 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(
|
||||
|
|
@ -4912,7 +5370,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)) {
|
||||
|
|
@ -4951,6 +5410,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)) {
|
||||
|
|
@ -4958,16 +5432,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
|
||||
|
|
@ -6475,87 +6946,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
|
||||
#'
|
||||
|
|
@ -7196,38 +7586,6 @@ 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")
|
||||
#' }
|
||||
#'
|
||||
#' #' @rdname regression_table
|
||||
#' #' @export
|
||||
#' regression_table.list <- function(x, ...) {
|
||||
#' x |>
|
||||
#' purrr::map(\(.m){
|
||||
#' regression_table(x = .m, ...) |>
|
||||
#' gtsummary::add_n()
|
||||
#' }) |>
|
||||
#' gtsummary::tbl_stack()
|
||||
#' }
|
||||
#'
|
||||
#' #' @rdname regression_table
|
||||
#' #' @export
|
||||
#' regression_table.default <- function(x, ..., args.list = NULL, fun = "gtsummary::tbl_regression") {
|
||||
#' # Stripping custom class
|
||||
#' class(x) <- class(x)[class(x) != "freesearchr_model"]
|
||||
#'
|
||||
#' if (any(c(length(class(x)) != 1, class(x) != "lm"))) {
|
||||
#' if (!"exponentiate" %in% names(args.list)) {
|
||||
#' args.list <- c(args.list, list(exponentiate = TRUE))
|
||||
#' }
|
||||
#' }
|
||||
#'
|
||||
#' out <- do.call(getfun(fun), c(list(x = x), args.list))
|
||||
#' out |>
|
||||
#' gtsummary::add_glance_source_note() # |>
|
||||
#' # gtsummary::bold_p()
|
||||
#' }
|
||||
regression_table <- function(x, ...) {
|
||||
args <- list(...)
|
||||
|
||||
|
|
@ -7305,8 +7663,6 @@ tbl_merge <- function(data) {
|
|||
}
|
||||
}
|
||||
|
||||
# as_kable(tbl) |> write_lines(file=here::here("inst/apps/data_analysis_modules/www/_table1.md"))
|
||||
# as_kable_extra(tbl)|> write_lines(file=here::here("inst/apps/data_analysis_modules/www/table1.md"))
|
||||
|
||||
|
||||
########
|
||||
|
|
@ -7387,13 +7743,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")),
|
||||
|
|
@ -7446,7 +7804,7 @@ regression_ui <- function(id, ...) {
|
|||
)
|
||||
),
|
||||
bslib::nav_panel(
|
||||
title = "Coefficient plot",
|
||||
title = i18n$t("Coefficient plot"),
|
||||
bslib::layout_sidebar(
|
||||
sidebar = bslib::sidebar(
|
||||
bslib::accordion(
|
||||
|
|
@ -7558,11 +7916,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())
|
||||
|
|
@ -7570,6 +7923,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
|
||||
|
|
@ -7593,7 +7971,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
|
||||
)
|
||||
|
|
@ -7603,7 +7981,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(
|
||||
|
|
@ -7622,7 +8000,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
|
||||
)
|
||||
|
|
@ -7642,7 +8020,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",
|
||||
|
|
@ -7657,7 +8035,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
|
||||
)
|
||||
|
|
@ -7707,7 +8085,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")
|
||||
}
|
||||
)
|
||||
}
|
||||
|
|
@ -7772,7 +8150,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")
|
||||
}
|
||||
)
|
||||
}
|
||||
|
|
@ -7873,7 +8251,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,
|
||||
|
|
@ -7910,7 +8288,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")
|
||||
}
|
||||
)
|
||||
}
|
||||
|
|
@ -7931,7 +8309,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
|
||||
)
|
||||
|
|
@ -7946,7 +8324,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){
|
||||
|
|
@ -8325,7 +8703,7 @@ ui_elements <- function(selection) {
|
|||
# ),
|
||||
shiny::selectInput(
|
||||
inputId = "source",
|
||||
label="",
|
||||
label = "",
|
||||
selected = "file",
|
||||
choices = "file",
|
||||
width = "100%"
|
||||
|
|
@ -8361,7 +8739,11 @@ ui_elements <- function(selection) {
|
|||
),
|
||||
shiny::conditionalPanel(
|
||||
condition = "input.source=='env'",
|
||||
import_globalenv_ui(id = "env", title = NULL)
|
||||
import_globalenv_ui(
|
||||
id = "env",
|
||||
title = NULL,
|
||||
packages = c("NHANES", "stRoke")
|
||||
)
|
||||
),
|
||||
# shiny::conditionalPanel(
|
||||
# condition = "input.source=='redcap'",
|
||||
|
|
@ -8615,7 +8997,7 @@ ui_elements <- function(selection) {
|
|||
sidebar = bslib::sidebar(
|
||||
shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE),
|
||||
bslib::accordion(
|
||||
id="acc_chars",
|
||||
id = "acc_chars",
|
||||
open = "acc_chars",
|
||||
multiple = FALSE,
|
||||
bslib::accordion_panel(
|
||||
|
|
@ -8661,7 +9043,7 @@ ui_elements <- function(selection) {
|
|||
sidebar = bslib::sidebar(
|
||||
# shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE),
|
||||
bslib::accordion(
|
||||
id="acc_cor",
|
||||
id = "acc_cor",
|
||||
open = "acc_chars",
|
||||
multiple = FALSE,
|
||||
bslib::accordion_panel(
|
||||
|
|
@ -10979,6 +11361,7 @@ ui <- bslib::page_fixed(
|
|||
## Code formatting dependencies
|
||||
prismDependencies,
|
||||
prismRDependency,
|
||||
html_dependency_FreesearchR(),
|
||||
## Version dependent header
|
||||
header_include(),
|
||||
## This adds the actual favicon
|
||||
|
|
@ -11264,7 +11647,8 @@ server <- function(input, output, session) {
|
|||
rv$code <- modifyList(x = rv$code, list(import = from_redcap$code()))
|
||||
})
|
||||
|
||||
from_env <- datamods::import_globalenv_server(
|
||||
# from_env <- datamods::import_globalenv_server(
|
||||
from_env <- import_globalenv_server(
|
||||
id = "env",
|
||||
trigger_return = "change",
|
||||
btn_show_data = FALSE,
|
||||
|
|
|
|||
|
|
@ -220,12 +220,27 @@
|
|||
"Click to see the imported data","Click to see the imported data"
|
||||
"Regression table","Regression table"
|
||||
"Import a dataset from an environment","Import a dataset from an environment"
|
||||
"Select a dataset:","Select a dataset:"
|
||||
"Select a dataset:","Vælg datasæt:"
|
||||
"List of datasets...","List of datasets..."
|
||||
"No data selected!","No data selected!"
|
||||
"No data selected!","Ingen data valgt!"
|
||||
"Use a datasat from your environment or from the environment of a package.","Use a datasat from your environment or from the environment of a package."
|
||||
"No dataset here...","No dataset here..."
|
||||
"No dataset here...","Ingen datasæt her..."
|
||||
"Use a dataset from your environment or from the environment of a package.","Use a dataset from your environment or from the environment of a package."
|
||||
"Not a data.frame","Not a data.frame"
|
||||
"Select source","Select source"
|
||||
"Select a data source:","Select a data source:"
|
||||
"Not a data.frame","Ikke en data.frame"
|
||||
"Select source","Vælg datakilde"
|
||||
"Select a data source:","Vælg datakilde:"
|
||||
"Yes","Ja"
|
||||
"No","Nej"
|
||||
"Coefficient plot","Coefficient plot"
|
||||
"Select outcome variable","Select outcome variable"
|
||||
"Choose regression analysis","Choose regression analysis"
|
||||
"Covariables to format as categorical","Covariables to format as categorical"
|
||||
"Select variable to stratify baseline","Select variable to stratify baseline"
|
||||
"Select models to plot","Select models to plot"
|
||||
"Creating regression models failed with the following error:","Creating regression models failed with the following error:"
|
||||
"Creating a regression table failed with the following error:","Creating a regression table failed with the following error:"
|
||||
"Saving the plot. Hold on for a moment..","Saving the plot. Hold on for a moment.."
|
||||
"Running model assumptions checks failed with the following error:","Running model assumptions checks failed with the following error:"
|
||||
"Select checks to plot","Select checks to plot"
|
||||
"Multivariable regression model checks","Multivariable regression model checks"
|
||||
"Grouped by {get_label(data,ter)}","Grouped by {get_label(data,ter)}"
|
||||
|
|
|
|||
|
|
|
@ -229,3 +229,18 @@
|
|||
"Not a data.frame","Not a data.frame"
|
||||
"Select source","Select source"
|
||||
"Select a data source:","Select a data source:"
|
||||
"Yes","Yes"
|
||||
"No","No"
|
||||
"Coefficient plot","Coefficient plot"
|
||||
"Select outcome variable","Select outcome variable"
|
||||
"Choose regression analysis","Choose regression analysis"
|
||||
"Covariables to format as categorical","Covariables to format as categorical"
|
||||
"Select variable to stratify baseline","Select variable to stratify baseline"
|
||||
"Select models to plot","Select models to plot"
|
||||
"Creating regression models failed with the following error:","Creating regression models failed with the following error:"
|
||||
"Creating a regression table failed with the following error:","Creating a regression table failed with the following error:"
|
||||
"Saving the plot. Hold on for a moment..","Saving the plot. Hold on for a moment.."
|
||||
"Running model assumptions checks failed with the following error:","Running model assumptions checks failed with the following error:"
|
||||
"Select checks to plot","Select checks to plot"
|
||||
"Multivariable regression model checks","Multivariable regression model checks"
|
||||
"Grouped by {get_label(data,ter)}","Grouped by {get_label(data,ter)}"
|
||||
|
|
|
|||
|
|
|
@ -1,5 +1,5 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/regression_model.R
|
||||
% Please edit documentation in R/helpers.R
|
||||
\name{data_type}
|
||||
\alias{data_type}
|
||||
\title{Data type assessment.}
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/regression_model.R
|
||||
% Please edit documentation in R/helpers.R
|
||||
\name{data_types}
|
||||
\alias{data_types}
|
||||
\title{Recognised data types from data_type}
|
||||
|
|
|
|||
21
man/get_data_packages.Rd
Normal file
21
man/get_data_packages.Rd
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/import_globalenv-ext.R
|
||||
\name{get_data_packages}
|
||||
\alias{get_data_packages}
|
||||
\title{Get packages containing datasets}
|
||||
\usage{
|
||||
get_data_packages()
|
||||
}
|
||||
\value{
|
||||
a character vector of packages names
|
||||
}
|
||||
\description{
|
||||
Get packages containing datasets
|
||||
}
|
||||
\examples{
|
||||
if (interactive()) {
|
||||
|
||||
get_data_packages()
|
||||
|
||||
}
|
||||
}
|
||||
|
|
@ -17,7 +17,7 @@ data.frame(See \code{eulerr::euler})}
|
|||
\item{...}{further arguments passed to eulerr::euler}
|
||||
}
|
||||
\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
|
||||
|
|
|
|||
50
man/import-globalenv.Rd
Normal file
50
man/import-globalenv.Rd
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/import_globalenv-ext.R
|
||||
\name{import-globalenv}
|
||||
\alias{import-globalenv}
|
||||
\alias{import_globalenv_ui}
|
||||
\alias{import_globalenv_server}
|
||||
\title{Import data from an Environment}
|
||||
\usage{
|
||||
import_globalenv_ui(
|
||||
id,
|
||||
globalenv = TRUE,
|
||||
packages = datamods::get_data_packages(),
|
||||
title = TRUE
|
||||
)
|
||||
|
||||
import_globalenv_server(
|
||||
id,
|
||||
btn_show_data = TRUE,
|
||||
show_data_in = c("popup", "modal"),
|
||||
trigger_return = c("button", "change"),
|
||||
return_class = c("data.frame", "data.table", "tbl_df", "raw"),
|
||||
reset = reactive(NULL)
|
||||
)
|
||||
}
|
||||
\arguments{
|
||||
\item{id}{Module's ID.}
|
||||
|
||||
\item{globalenv}{Search for data in Global environment.}
|
||||
|
||||
\item{packages}{Name of packages in which to search data.}
|
||||
|
||||
\item{title}{Module's title, if \code{TRUE} use the default title,
|
||||
use \code{NULL} for no title or a \code{shiny.tag} for a custom one.}
|
||||
|
||||
\item{btn_show_data}{Display or not a button to display data in a modal window if import is successful.}
|
||||
|
||||
\item{show_data_in}{Where to display data: in a \code{"popup"} or in a \code{"modal"} window.}
|
||||
|
||||
\item{trigger_return}{When to update selected data:
|
||||
\code{"button"} (when user click on button) or
|
||||
\code{"change"} (each time user select a dataset in the list).}
|
||||
|
||||
\item{return_class}{Class of returned data: \code{data.frame}, \code{data.table}, \code{tbl_df} (tibble) or \code{raw}.}
|
||||
|
||||
\item{reset}{A \code{reactive} function that when triggered resets the data.}
|
||||
}
|
||||
\description{
|
||||
Let the user select a dataset from its own environment or from a package's environment.
|
||||
Modified from datamods
|
||||
}
|
||||
21
man/list_pkg_data.Rd
Normal file
21
man/list_pkg_data.Rd
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/import_globalenv-ext.R
|
||||
\name{list_pkg_data}
|
||||
\alias{list_pkg_data}
|
||||
\title{List dataset contained in a package}
|
||||
\usage{
|
||||
list_pkg_data(pkg)
|
||||
}
|
||||
\arguments{
|
||||
\item{pkg}{Name of the package, must be installed.}
|
||||
}
|
||||
\value{
|
||||
a \code{character} vector or \code{NULL}.
|
||||
}
|
||||
\description{
|
||||
List dataset contained in a package
|
||||
}
|
||||
\examples{
|
||||
|
||||
list_pkg_data("ggplot2")
|
||||
}
|
||||
|
|
@ -32,4 +32,19 @@ data.frame(
|
|||
) |> 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"))
|
||||
}
|
||||
|
|
|
|||
|
|
@ -82,36 +82,4 @@ list(
|
|||
purrr::map(regression_table) |>
|
||||
tbl_merge()
|
||||
}
|
||||
regression_table <- function(x, ...) {
|
||||
UseMethod("regression_table")
|
||||
}
|
||||
|
||||
#' @rdname regression_table
|
||||
#' @export
|
||||
regression_table.list <- function(x, ...) {
|
||||
x |>
|
||||
purrr::map(\(.m){
|
||||
regression_table(x = .m, ...) |>
|
||||
gtsummary::add_n()
|
||||
}) |>
|
||||
gtsummary::tbl_stack()
|
||||
}
|
||||
|
||||
#' @rdname regression_table
|
||||
#' @export
|
||||
regression_table.default <- function(x, ..., args.list = NULL, fun = "gtsummary::tbl_regression") {
|
||||
# Stripping custom class
|
||||
class(x) <- class(x)[class(x) != "freesearchr_model"]
|
||||
|
||||
if (any(c(length(class(x)) != 1, class(x) != "lm"))) {
|
||||
if (!"exponentiate" \%in\% names(args.list)) {
|
||||
args.list <- c(args.list, list(exponentiate = TRUE))
|
||||
}
|
||||
}
|
||||
|
||||
out <- do.call(getfun(fun), c(list(x = x), args.list))
|
||||
out |>
|
||||
gtsummary::add_glance_source_note() # |>
|
||||
# gtsummary::bold_p()
|
||||
}
|
||||
}
|
||||
|
|
|
|||
83
renv.lock
83
renv.lock
|
|
@ -1588,6 +1588,39 @@
|
|||
"Maintainer": "Winston Chang <winston@posit.co>",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"calendar": {
|
||||
"Package": "calendar",
|
||||
"Version": "0.2.0",
|
||||
"Source": "Repository",
|
||||
"Title": "Create, Read, Write, and Work with 'iCalendar' Files, Calendars and Scheduling Data",
|
||||
"Authors@R": "c(person(given = \"Robin\", family = \"Lovelace\", role = c(\"aut\", \"cre\"), email = \"rob00x@gmail.com\", comment = c(ORCID = \"0000-0001-5679-6536\")), person(given = \"Layik\", family = \"Hama\", role = \"aut\", email = \"layik.hama@gmail.com\", comment = c(ORCID = \"0000-0003-1912-4890\")), person(given = \"Ollie\", family = \"Lloyd\", role = \"ctb\", email = \"o.lloyd@doctors.org.uk\", comment = c(ORCID = \"0000-0002-9385-1634\")), person(given = \"Franco\", family = \"Scarafia\", role = \"ctb\", email = \"franco.scarafia@hotmail.com\", comment = c(ORCID = \"0009-0005-9822-169X\")), person(given = \"Serkan\", family = \"Korkmaz\", email = \"serkor1@duck.com\", role = c(\"ctb\"), comment = c(ORCID = \"0000-0002-5052-0982\")) )",
|
||||
"Description": "Provides function to create, read, write, and work with 'iCalendar' files (which typically have '.ics' or '.ical' extensions), and the scheduling data, calendars and timelines of people, organisations and other entities that they represent. 'iCalendar' is an open standard for exchanging calendar and scheduling information between users and computers, described at <https://icalendar.org/>.",
|
||||
"License": "Apache License (>= 2.0)",
|
||||
"URL": "https://github.com/atfutures/calendar, https://atfutures.github.io/calendar/, https://github.com/ATFutures/calendar",
|
||||
"BugReports": "https://github.com/ATFutures/calendar/issues",
|
||||
"Depends": [
|
||||
"R (>= 3.4.0)"
|
||||
],
|
||||
"Imports": [
|
||||
"cli",
|
||||
"lubridate",
|
||||
"tibble"
|
||||
],
|
||||
"Suggests": [
|
||||
"covr",
|
||||
"knitr",
|
||||
"rmarkdown",
|
||||
"testthat"
|
||||
],
|
||||
"VignetteBuilder": "knitr",
|
||||
"Encoding": "UTF-8",
|
||||
"LazyData": "true",
|
||||
"RoxygenNote": "7.3.2",
|
||||
"NeedsCompilation": "no",
|
||||
"Author": "Robin Lovelace [aut, cre] (<https://orcid.org/0000-0001-5679-6536>), Layik Hama [aut] (<https://orcid.org/0000-0003-1912-4890>), Ollie Lloyd [ctb] (<https://orcid.org/0000-0002-9385-1634>), Franco Scarafia [ctb] (<https://orcid.org/0009-0005-9822-169X>), Serkan Korkmaz [ctb] (<https://orcid.org/0000-0002-5052-0982>)",
|
||||
"Maintainer": "Robin Lovelace <rob00x@gmail.com>",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"cards": {
|
||||
"Package": "cards",
|
||||
"Version": "0.6.1",
|
||||
|
|
@ -8257,6 +8290,56 @@
|
|||
"NeedsCompilation": "yes",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"stRoke": {
|
||||
"Package": "stRoke",
|
||||
"Version": "25.9.2",
|
||||
"Source": "Repository",
|
||||
"Title": "Clinical Stroke Research",
|
||||
"Authors@R": "person(\"Andreas Gammelgaard\", \"Damsbo\", , \"agdamsbo@clin.au.dk\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-7559-1154\"))",
|
||||
"Description": "A collection of tools for clinical trial data management and analysis in research and teaching. The package is mainly collected for personal use, but any use beyond that is encouraged. This package has migrated functions from 'agdamsbo/daDoctoR', and new functions has been added. Version follows months and year. See NEWS/Changelog for release notes. This package includes sampled data from the TALOS trial (Kraglund et al (2018) <doi:10.1161/STROKEAHA.117.020067>). The win_prob() function is based on work by Zou et al (2022) <doi:10.1161/STROKEAHA.121.037744>. The age_calc() function is based on work by Becker (2020) <doi:10.18637/jss.v093.i02>.",
|
||||
"URL": "https://agdamsbo.github.io/stRoke/, https://github.com/agdamsbo/stRoke",
|
||||
"BugReports": "https://github.com/agdamsbo/stRoke/issues",
|
||||
"License": "GPL-3",
|
||||
"Encoding": "UTF-8",
|
||||
"RoxygenNote": "7.3.2",
|
||||
"LazyData": "true",
|
||||
"Suggests": [
|
||||
"knitr",
|
||||
"rmarkdown",
|
||||
"testthat",
|
||||
"here",
|
||||
"spelling",
|
||||
"usethis",
|
||||
"pak",
|
||||
"roxygen2",
|
||||
"devtools"
|
||||
],
|
||||
"Config/testthat/edition": "3",
|
||||
"Imports": [
|
||||
"calendar",
|
||||
"dplyr",
|
||||
"ggplot2",
|
||||
"grDevices",
|
||||
"gtsummary",
|
||||
"lubridate",
|
||||
"MASS",
|
||||
"rankinPlot",
|
||||
"stats",
|
||||
"tidyr",
|
||||
"utils",
|
||||
"tibble",
|
||||
"tidyselect"
|
||||
],
|
||||
"Depends": [
|
||||
"R (>= 4.1.0)"
|
||||
],
|
||||
"VignetteBuilder": "knitr",
|
||||
"Language": "en-US",
|
||||
"NeedsCompilation": "no",
|
||||
"Author": "Andreas Gammelgaard Damsbo [aut, cre] (ORCID: <https://orcid.org/0000-0002-7559-1154>)",
|
||||
"Maintainer": "Andreas Gammelgaard Damsbo <agdamsbo@clin.au.dk>",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"stringi": {
|
||||
"Package": "stringi",
|
||||
"Version": "1.8.7",
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue