Compare commits

...

4 commits

20 changed files with 1440 additions and 219 deletions

View file

@ -141,5 +141,6 @@ Collate:
'update-variables-ext.R' 'update-variables-ext.R'
'utils-labels.R' 'utils-labels.R'
'validation.R' 'validation.R'
'version_check.R'
'visual_summary.R' 'visual_summary.R'
'wide2long.R' 'wide2long.R'

View file

@ -1,6 +1,8 @@
# FreesearchR 26.3.4 # FreesearchR 26.3.4
*NEW* Added app version check against latest release on GitHub. Only runs if internet connection present. No other polling.
*NEW* Added a "Missing" level to the sankey plot function and adjusted the label font size.
# FreesearchR 26.3.3 # FreesearchR 26.3.3

View file

@ -1 +1 @@
hosted_version <- function()'v26.3.4-260312' hosted_version <- function()'v26.3.4-260323'

View file

@ -8,6 +8,8 @@
#' @param data_limit_default default data set observations limit #' @param data_limit_default default data set observations limit
#' @param data_limit_upper data set observations upper limit #' @param data_limit_upper data set observations upper limit
#' @param data_limit_lower data set observations lower limit #' @param data_limit_lower data set observations lower limit
#' @param check_app_version always attempt to check app version against latest
#' release on GitHub. Default is FALSE
#' @param ... passed on to `shiny::runApp()` #' @param ... passed on to `shiny::runApp()`
#' #'
#' @returns shiny app #' @returns shiny app
@ -22,12 +24,14 @@ launch_FreesearchR <- function(include_globalenv = TRUE,
data_limit_default = 1000, data_limit_default = 1000,
data_limit_upper = 100000, data_limit_upper = 100000,
data_limit_lower = 1, data_limit_lower = 1,
check_app_version = FALSE,
...) { ...) {
Sys.setenv( Sys.setenv(
INCLUDE_GLOBALENV = include_globalenv, INCLUDE_GLOBALENV = include_globalenv,
DATA_LIMIT_DEFAULT = data_limit_default, DATA_LIMIT_DEFAULT = data_limit_default,
DATA_LIMIT_UPPER = data_limit_upper, DATA_LIMIT_UPPER = data_limit_upper,
DATA_LIMIT_LOWER = data_limit_lower DATA_LIMIT_LOWER = data_limit_lower,
CHECK_APP_VERSION = check_app_version
) )
appDir <- system.file("apps", "FreesearchR", package = "FreesearchR") appDir <- system.file("apps", "FreesearchR", package = "FreesearchR")

View file

@ -33,15 +33,17 @@ sankey_ready <- function(data, pri, sec, numbers = "count", ...) {
dplyr::ungroup() dplyr::ungroup()
if (numbers == "count") { if (numbers == "count") {
out <- out |> dplyr::mutate( out <- out |> dplyr::mutate(lx = factor(paste0(
lx = factor(paste0(!!dplyr::sym(pri), "\n(n=", gx.sum, ")")), !!dplyr::sym(pri), "\n(n=", gx.sum, ")"
ly = factor(paste0(!!dplyr::sym(sec), "\n(n=", gy.sum, ")")) )), ly = factor(paste0(
) !!dplyr::sym(sec), "\n(n=", gy.sum, ")"
)))
} else if (numbers == "percentage") { } else if (numbers == "percentage") {
out <- out |> dplyr::mutate( out <- out |> dplyr::mutate(lx = factor(paste0(
lx = factor(paste0(!!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")), !!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)"
ly = factor(paste0(!!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)")) )), ly = factor(paste0(
) !!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)"
)))
} }
if (is.factor(data[[pri]])) { if (is.factor(data[[pri]])) {
@ -83,20 +85,39 @@ str_remove_last <- function(data, pattern = "\n") {
#' mtcars |> #' mtcars |>
#' default_parsing() |> #' default_parsing() |>
#' plot_sankey("cyl", "gear", "vs", color.group = "pri") #' plot_sankey("cyl", "gear", "vs", color.group = "pri")
plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors = NULL,missing.level="Missing") { #'
#' # stRoke::trial |> plot_sankey("mrs_1", "mrs_6")
#' # stRoke::trial |> plot_sankey("active", "male")
plot_sankey <- function(data,
pri,
sec,
ter = NULL,
color.group = "pri",
colors = NULL,
missing.level = "Missing") {
if (!is.null(ter)) { if (!is.null(ter)) {
ds <- split(data, data[ter]) ds <- split(data, data[ter])
} else { } else {
ds <- list(data) ds <- list(data)
} }
out <- lapply(ds, \(.ds){
plot_sankey_single(.ds, pri = pri, sec = sec, color.group = color.group, colors = colors,missing.level=missing.level) out <- lapply(ds, \(.ds) {
plot_sankey_single(
.ds,
pri = pri,
sec = sec,
color.group = color.group,
colors = colors,
missing.level = missing.level
)
}) })
patchwork::wrap_plots(out) patchwork::wrap_plots(out)
} }
#' Beautiful sankey plot #' Beautiful sankey plot
#' #'
#' @param color.group set group to colour by. "x" or "y". #' @param color.group set group to colour by. "x" or "y".
@ -123,41 +144,66 @@ plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors
#' stRoke::trial |> #' stRoke::trial |>
#' default_parsing() |> #' default_parsing() |>
#' plot_sankey_single("diabetes", "hypertension") #' plot_sankey_single("diabetes", "hypertension")
plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL,missing.level="Missing", ...) { plot_sankey_single <- function(data,
pri,
sec,
color.group = c("pri", "sec"),
colors = NULL,
missing.level = "Missing",
...) {
color.group <- match.arg(color.group) color.group <- match.arg(color.group)
# browser()
data_orig <- data data_orig <- data
data[c(pri, sec)] <- data[c(pri, sec)] |>
dplyr::mutate( data[c(pri, sec)] <- with_labels(data,{
# dplyr::across(dplyr::where(is.logical), as.factor), data[c(pri, sec)] |>
dplyr::across(dplyr::where(is.factor), forcats::fct_drop)#, dplyr::mutate(
# dplyr::across(dplyr::where(is.factor), \(.x){forcats::fct_na_value_to_level(.x,missing.level)}) dplyr::across(dplyr::where(is.logical), as.factor),
) dplyr::across(dplyr::where(is.factor), forcats::fct_drop),
dplyr::across(dplyr::where(is.factor), \(.x) {
if (anyNA(.x)) forcats::fct_na_value_to_level(.x, missing.level) else .x
})
)
})
data <- data |> sankey_ready(pri = pri, sec = sec, ...) ## Aggregate data
data_aggr <- data |> sankey_ready(pri = pri, sec = sec, ...)
na.color <- "#2986cc" na.color <- "#2986cc"
box.color <- "#1E4B66" box.color <- "#1E4B66"
if (is.null(colors)) { if (is.null(colors)) {
if (color.group == "sec") { if (color.group == "sec") {
if (anyNA(data_orig[[sec]])){
main.colors <- viridisLite::viridis(n = length(levels(data_orig[[sec]]))) main.colors <- viridisLite::viridis(n = length(levels(data_orig[[sec]])))
} else {
main.colors <- viridisLite::viridis(n = length(levels(data[[sec]])))
}
## Only keep colors for included levels ## Only keep colors for included levels
main.colors <- main.colors[match(levels(data[[sec]]), levels(data_orig[[sec]]))] main.colors <- main.colors[match(levels(data[[sec]]), levels(data[[sec]]))]
secondary.colors <- rep(na.color, length(levels(data[[pri]]))) secondary.colors <- rep(na.color, length(levels(data[[pri]])))
label.colors <- Reduce(c, lapply(list(secondary.colors, rev(main.colors)), contrast_text)) label.colors <- Reduce(c, lapply(list(
secondary.colors, rev(main.colors)
), contrast_text))
} else { } else {
main.colors <- viridisLite::viridis(n = length(levels(data_orig[[pri]]))) if (anyNA(data_orig[[sec]])){
main.colors <- viridisLite::viridis(n = length(levels(data_orig[[pri]])))
} else {
main.colors <- viridisLite::viridis(n = length(levels(data[[pri]])))
}
# main.colors <- viridisLite::viridis(n = length(levels(data[[pri]])))
## Only keep colors for included levels ## Only keep colors for included levels
main.colors <- main.colors[match(levels(data[[pri]]), levels(data_orig[[pri]]))] main.colors <- main.colors[match(levels(data[[pri]]), levels(data[[pri]]))]
secondary.colors <- rep(na.color, length(levels(data[[sec]]))) secondary.colors <- rep(na.color, length(levels(data[[sec]])))
label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text)) label.colors <- Reduce(c, lapply(list(
rev(main.colors), secondary.colors
), contrast_text))
} }
colors <- c(na.color, main.colors, secondary.colors) colors <- c(na.color, main.colors, secondary.colors)
colors[is.na(colors)] <- "grey80"
} else { } else {
label.colors <- contrast_text(colors) label.colors <- contrast_text(colors)
} }
@ -166,7 +212,9 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
sapply(line_break) |> sapply(line_break) |>
unname() unname()
p <- ggplot2::ggplot(data, ggplot2::aes(y = n, axis1 = lx, axis2 = ly)) # browser()
p <- ggplot2::ggplot(data_aggr, ggplot2::aes(y = n, axis1 = lx, axis2 = ly))
if (color.group == "sec") { if (color.group == "sec") {
p <- p + p <- p +
@ -181,9 +229,8 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
knot.pos = 0.4, knot.pos = 0.4,
curve_type = "sigmoid" curve_type = "sigmoid"
) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(sec)), ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(sec)),
size = 2, size = 2,
width = 1 / 3.4 width = 1 / 3.4)
)
} else { } else {
p <- p + p <- p +
ggalluvial::geom_alluvium( ggalluvial::geom_alluvium(
@ -196,9 +243,8 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
knot.pos = 0.4, knot.pos = 0.4,
curve_type = "sigmoid" curve_type = "sigmoid"
) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(pri)), ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(pri)),
size = 2, size = 2,
width = 1 / 3.4 width = 1 / 3.4)
)
} }
## Will fail to use stat="stratum" if library is not loaded. ## Will fail to use stat="stratum" if library is not loaded.
@ -208,13 +254,10 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
stat = "stratum", stat = "stratum",
ggplot2::aes(label = after_stat(stratum)), ggplot2::aes(label = after_stat(stratum)),
colour = label.colors, colour = label.colors,
size = 8, size = 6,
lineheight = 1 lineheight = 1
) + ) +
ggplot2::scale_x_continuous( ggplot2::scale_x_continuous(breaks = 1:2, labels = group_labels) +
breaks = 1:2,
labels = group_labels
) +
ggplot2::scale_fill_manual(values = colors[-1], na.value = colors[1]) + ggplot2::scale_fill_manual(values = colors[-1], na.value = colors[1]) +
# ggplot2::scale_color_manual(values = main.colors) + # ggplot2::scale_color_manual(values = main.colors) +
ggplot2::theme_void() + ggplot2::theme_void() +

Binary file not shown.

View file

@ -25,6 +25,7 @@ ui_elements <- function(selection) {
## Default just output "NULL" ## Default just output "NULL"
## This could probably be achieved more legantly, but this works. ## This could probably be achieved more legantly, but this works.
dev_banner(), dev_banner(),
version_banner,
landing_page_ui(i18n = i18n), landing_page_ui(i18n = i18n),
# shiny::column(width = 2), # shiny::column(width = 2),
# shiny::column( # shiny::column(

View file

@ -65,33 +65,6 @@ validation_server <- function(id,
data_r <- if (shiny::is.reactive(data)) data else shiny::reactive(data) data_r <- if (shiny::is.reactive(data)) data else shiny::reactive(data)
# observeEvent(data_r(), {
# to_validate <- data()
# valid_dims <- check_data(to_validate, n_row = n_row, n_col = n_col)
#
# if (all(c(valid_dims$nrows, valid_dims$ncols))) {
# valid_status <- "OK"
# } else {
# valid_status <- "Failed"
# }
#
# valid_results <- lapply(
# X = c("nrows", "ncols"),
# FUN = function(x) {
# if (is.null(valid_dims[[x]]))
# return(NULL)
# label <- switch(
# x,
# "nrows" = n_row_label,
# "ncols" = n_col_label
# )
# list(
# status = ifelse(valid_dims[[x]], "OK", "Failed"),
# label = paste0("<b>", label, "</b>")
# )
# }
# )
shiny::observeEvent( shiny::observeEvent(
data_r(), data_r(),
{ {

325
R/version_check.R Normal file
View file

@ -0,0 +1,325 @@
# version_check.R
#
# Runs a one-time version check at app startup and returns a ready-made
# shinyWidgets::alert() UI element that can be placed directly in the UI
# definition -- no server(), no renderUI(), no uiOutput() required.
#
# Because the check runs outside server(), it executes once when the app
# process starts, so the banner is present immediately on first render with
# no loading delay.
#
# Version detection uses two strategies, tried in order:
# 1. utils::packageVersion() -- works when the package is installed locally.
# 2. app_version argument -- explicit fallback for environments where the
# package is not installed (e.g. shinyapps.io). Pass the result of your
# app_version() function here.
#
# Quick start:
#
# # global.R (or top of app.R, before ui / server)
# source("version_check.R")
# version_banner <- check_app_version(
# github_user = "your-github-username",
# github_repo = "your-repo-name",
# app_version = app_version() # fallback for shinyapps.io
# )
#
# # ui.R -- drop the result anywhere in the UI tree
# fluidPage(
# version_banner,
# ...
# )
#
# # Verbose / debug mode -- always show the banner:
# version_banner <- check_app_version(
# github_user = "your-github-username",
# github_repo = "your-repo-name",
# app_version = app_version(),
# verbose = TRUE
# )
# -- Internal helpers ----------------------------------------------------------
#' Check internet connectivity
#'
#' @return Logical; TRUE if an internet connection is available.
.has_internet <- function() {
tryCatch({
con <- url("https://api.github.com", open = "r")
close(con)
TRUE
}, error = function(e) FALSE)
}
#' Fetch the latest release version from a GitHub repository
#'
#' @param github_user GitHub username or organisation.
#' @param github_repo Repository name.
#'
#' @return A character string with the version tag (e.g. "1.2.0"), or NULL on
#' failure.
.get_latest_github_version <- function(github_user, github_repo) {
api_url <- sprintf(
"https://api.github.com/repos/%s/%s/releases/latest",
github_user,
github_repo
)
tryCatch({
response <- readLines(url(api_url), warn = FALSE)
json_text <- paste(response, collapse = "")
tag <- regmatches(
json_text,
regexpr('"tag_name"\\s*:\\s*"([^"]+)"', json_text)
)
if (length(tag) == 0 || nchar(tag) == 0) return(NULL)
# Strip a leading "v" if present (e.g. "v1.2.0" -> "1.2.0")
sub('^"tag_name"\\s*:\\s*"v?([^"]+)"$', "\\1", tag)
}, error = function(e) NULL)
}
#' Resolve the current app version
#'
#' Tries two strategies in order:
#' \enumerate{
#' \item \code{utils::packageVersion(package_name)} -- works when the package
#' is installed locally (development, local \code{runApp()}).
#' \item \code{app_version} argument -- an explicit version string supplied by
#' the caller, e.g. from an \code{app_version()} function bundled with the
#' app. Used on shinyapps.io where the package is not installed.
#' }
#'
#' @param package_name Name of the package / repository.
#' @param app_version Optional fallback version string.
#'
#' @return A character string with the version (e.g. "1.1.0"), or NULL if
#' neither strategy succeeds.
.resolve_app_version <- function(package_name, app_version = NULL) {
# Strategy 1: installed package
v <- tryCatch(
as.character(utils::packageVersion(package_name)),
error = function(e) NULL
)
if (!is.null(v)) {
message("[version_check] Version source: installed package")
return(v)
}
# Strategy 2: explicit fallback supplied by the caller
if (!is.null(app_version)) {
message("[version_check] Version source: app_version() fallback")
return(as.character(app_version))
}
NULL
}
#' Build a shinyWidgets::alert() UI element for the version banner
#'
#' @param current Current installed version string.
#' @param latest Latest GitHub release version string, or NULL when
#' the check could not complete (e.g. no internet).
#' @param update_available Logical; whether latest > current.
#' @param github_user GitHub username / organisation.
#' @param github_repo Repository name.
#'
#' @return A \code{shinyWidgets::alert()} UI element.
.build_version_alert <- function(current,
latest,
update_available,
github_user,
github_repo) {
repo_url <- sprintf(
"https://github.com/%s/%s/releases/latest",
github_user,
github_repo
)
if (is.null(latest)) {
# Version check could not complete (no internet or API failure)
return(
shinyWidgets::alert(
tags$b("Version check failed. "),
sprintf(
"Running version %s. Could not reach GitHub to check for updates.",
current
),
status = "warning",
dismissible = TRUE
)
)
}
if (update_available) {
shinyWidgets::alert(
tags$b("Update available! "),
sprintf(
"You are running version %s. Version %s is available on GitHub.",
current, latest
),
" ",
tags$a(href = repo_url, target = "_blank", "View release"),
status = "warning",
dismissible = TRUE
)
} else {
# Up to date -- only shown in verbose mode
shinyWidgets::alert(
tags$b("Up to date. "),
sprintf(
"You are running version %s, which matches the latest release (%s).",
current, latest
),
status = "success",
dismissible = TRUE
)
}
}
# -- Public API ----------------------------------------------------------------
#' Run a startup version check and return a banner UI element
#'
#' Call this \strong{outside} \code{server()} -- typically in
#' \code{global.R} or at the top of \code{app.R} -- and embed the returned
#' value directly in your UI definition. Because the check runs at startup
#' the banner is present on first render with no loading delay, and no
#' \code{uiOutput()} / \code{renderUI()} wiring is needed.
#'
#' \strong{Normal mode} (\code{verbose = FALSE}): returns a banner only when
#' a newer version is available or when the check fails. Returns \code{NULL}
#' when the app is up to date (Shiny silently ignores \code{NULL} in the UI).
#'
#' \strong{Verbose / debug mode} (\code{verbose = TRUE}): always returns a
#' banner -- including a success banner when up to date -- so you can confirm
#' the check ran and inspect both version strings during development.
#'
#' @param github_user GitHub username or organisation that owns the repository.
#' @param github_repo Repository name. Also used as the package name for
#' \code{utils::packageVersion()}.
#' @param app_version Optional fallback version string for environments where
#' the package is not installed (e.g. shinyapps.io). Pass the result of your
#' \code{app_version()} function here. Ignored when \code{packageVersion()}
#' succeeds.
#' @param verbose Logical; if \code{TRUE} a banner is always returned.
#' Defaults to \code{FALSE}.
#'
#' @return A \code{shinyWidgets::alert()} UI element, or \code{NULL} when there
#' is nothing to show (up to date in non-verbose mode).
#'
#' @examples
#' \dontrun{
#' # global.R or top of app.R
#' source("version_check.R")
#' version_banner <- check_app_version(
#' github_user = "my-org",
#' github_repo = "my-shiny-app",
#' app_version = app_version() # fallback for shinyapps.io
#' )
#'
#' # ui.R
#' fluidPage(
#' version_banner,
#' # ... rest of UI
#' )
#'
#' # Verbose mode for development
#' version_banner <- check_app_version(
#' github_user = "my-org",
#' github_repo = "my-shiny-app",
#' app_version = app_version(),
#' verbose = TRUE
#' )
#' }
check_app_version <- function(github_user,
github_repo,
app_version = NULL,
verbose = FALSE) {
# -- 1. Resolve current version ----------------------------------------------
local_version <- .resolve_app_version(github_repo, app_version)
if (is.null(local_version)) {
message(sprintf(
"[version_check] Could not determine version for '%s' (package not installed and no app_version() fallback supplied).",
github_repo
))
return(NULL)
}
message(sprintf("[version_check] Current version: %s", local_version))
# -- 2. Internet check -------------------------------------------------------
if (!.has_internet()) {
message("[version_check] No internet connection detected -- skipping.")
if (verbose) {
return(.build_version_alert(
current = local_version,
latest = NULL,
update_available = FALSE,
github_user = github_user,
github_repo = github_repo
))
}
return(NULL)
}
# -- 3. Fetch latest GitHub release ------------------------------------------
latest_version <- .get_latest_github_version(github_user, github_repo)
if (is.null(latest_version)) {
message("[version_check] Could not retrieve latest version from GitHub.")
if (verbose) {
return(.build_version_alert(
current = local_version,
latest = NULL,
update_available = FALSE,
github_user = github_user,
github_repo = github_repo
))
}
return(NULL)
}
message(sprintf("[version_check] Latest GitHub release: %s", latest_version))
# -- 4. Compare versions -----------------------------------------------------
update_available <- numeric_version(latest_version) > numeric_version(local_version)
if (update_available) {
message(sprintf(
"[version_check] Update available: %s -> %s",
local_version, latest_version
))
} else {
message(sprintf("[version_check] App is up to date (%s).", local_version))
}
# -- 5. Return banner --------------------------------------------------------
# An update was found -> always return a warning banner
# Up to date + verbose -> return a success banner
# Up to date + not verbose -> return NULL (Shiny ignores NULL in the UI)
if (update_available || verbose) {
.build_version_alert(
current = local_version,
latest = latest_version,
update_available = update_available,
github_user = github_user,
github_repo = github_repo
)
} else {
NULL
}
}

View file

@ -1,10 +1,9 @@
# FreesearchR <a href="https://agdamsbo.github.io/FreesearchR/"><img src="man/figures/logo.png" align="right" height="70" alt="FreesearchR website" /></a> # FreesearchR <a href="https://agdamsbo.github.io/FreesearchR/"><img src="man/figures/logo.png" alt="FreesearchR website" align="right" height="70"/></a>
<!-- badges: start --> <!-- badges: start -->
[![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#experimental)
[![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.14527429.svg)](https://doi.org/10.5281/zenodo.14527429) [![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#experimental) [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.14527429.svg)](https://doi.org/10.5281/zenodo.14527429) [![rhub](https://github.com/agdamsbo/FreesearchR/actions/workflows/rhub.yaml/badge.svg)](https://github.com/agdamsbo/FreesearchR/actions/workflows/rhub.yaml) [![FreesearchR](https://img.shields.io/badge/Shiny-shinyapps.io-blue?style=flat&labelColor=white&logo=RStudio&logoColor=blue)](https://agdamsbo.shinyapps.io/FreesearchR/)
[![rhub](https://github.com/agdamsbo/FreesearchR/actions/workflows/rhub.yaml/badge.svg)](https://github.com/agdamsbo/FreesearchR/actions/workflows/rhub.yaml)
[![FreesearchR](https://img.shields.io/badge/Shiny-shinyapps.io-blue?style=flat&labelColor=white&logo=RStudio&logoColor=blue)](https://agdamsbo.shinyapps.io/FreesearchR/)
<!-- badges: end --> <!-- badges: end -->
The [***FreesearchR***](https://app.freesearchr.org) is a simple, clinical health data exploration and analysis tool to democratise clinical research by assisting any researcher to easily evaluate and analyse data and export publication ready results. The [***FreesearchR***](https://app.freesearchr.org) is a simple, clinical health data exploration and analysis tool to democratise clinical research by assisting any researcher to easily evaluate and analyse data and export publication ready results.
@ -19,11 +18,11 @@ All feedback is welcome and can be shared as a GitHub issue. Any suggestions on
This app has the following simple goals: This app has the following simple goals:
1. help the health clinician getting an overview of data in quality improvement projects and clinical research 1. help the health clinician getting an overview of data in quality improvement projects and clinical research
1. help learners get a good start analysing data and coding in *R* 2. help learners get a good start analysing data and coding in *R*
1. ease quick data overview and basic visualisations for any clinical researcher 3. ease quick data overview and basic visualisations for any clinical researcher
Heres a polished and restructured version of your README section for clarity, conciseness, and user-friendliness: Heres a polished and restructured version of your README section for clarity, conciseness, and user-friendliness:
@ -35,32 +34,32 @@ The **FreesearchR** app can be run locally on your machine, ensuring no data is
The app can be configured either by passing a named list to `run_app()` or by setting environment variables in a **Docker Compose** file. The following variables control data access and display behavior. If no values are provided, the app will use the defaults listed below. The app can be configured either by passing a named list to `run_app()` or by setting environment variables in a **Docker Compose** file. The following variables control data access and display behavior. If no values are provided, the app will use the defaults listed below.
**Configuration Variables** **Configuration Variables**
| Variable | Description | Default | | Variable | Description | Default |
|-------------------------|-----------------------------------------------------------------------------|-----------| |--------------|--------------------------------------------|--------------|
| `INCLUDE_GLOBALENV` | Load datasets already present in the global R environment into the app | `FALSE` | | `INCLUDE_GLOBALENV` | Load datasets already present in the global R environment into the app | `FALSE` |
| `DATA_LIMIT_DEFAULT` | Default number of observations for previewing or working with a dataset | `10,000` | | `DATA_LIMIT_DEFAULT` | Default number of observations for previewing or working with a dataset | `10,000` |
| `DATA_LIMIT_UPPER` | Maximum number of observations a user can set for the upper limit. If set to 0, no uppper limit is applied. | `100,000` | | `DATA_LIMIT_UPPER` | Maximum number of observations a user can set for the upper limit. If set to 0, no uppper limit is applied. | `100,000` |
| `DATA_LIMIT_LOWER` | Minimum number of observations a user can set for the lower limit | `1` | | `DATA_LIMIT_LOWER` | Minimum number of observations a user can set for the lower limit | `1` |
| `CHECK_APP_VERSION` | Always print version check results. Checks app version against latest release on GitHub. | `FALSE` |
### Run from R (or RStudio) ### Run from R (or RStudio)
If you're working with data in R, **FreesearchR** is a quick and easy tool for exploratory analysis. If you're working with data in R, **FreesearchR** is a quick and easy tool for exploratory analysis.
1. **Requirement:** Ensure you have [R](https://www.r-project.org/) installed, and optionally an editor like [RStudio](https://posit.co/download/rstudio-desktop/). 1. **Requirement:** Ensure you have [R](https://www.r-project.org/) installed, and optionally an editor like [RStudio](https://posit.co/download/rstudio-desktop/).
2. Open the **R console** and run the following code to install the `{FreesearchR}` package and launch the app: 2. Open the **R console** and run the following code to install the `{FreesearchR}` package and launch the app:
```r ``` r
if (!require("devtools")) install.packages("devtools") if (!require("devtools")) install.packages("devtools")
devtools::install_github("agdamsbo/FreesearchR") devtools::install_github("agdamsbo/FreesearchR")
library(FreesearchR) library(FreesearchR)
# Load sample data (e.g., mtcars) to make it available in the app # Load sample data (e.g., mtcars) to make it available in the app
data(mtcars) data(mtcars)
launch_FreesearchR(INCLUDE_GLOBALENV=TRUE) launch_FreesearchR(INCLUDE_GLOBALENV=TRUE,CHECK_APP_VERSION=TRUE)
``` ```
All the variables specified above can also be passed to the app on launch from R. Set DATA_LIMIT_UPPER=0 to remove upper data limit. This limit is set to protect the online app version from choking and crashing on large data sets. All the variables specified above can also be passed to the app on launch from R. Set DATA_LIMIT_UPPER=0 to remove upper data limit. This limit is set to protect the online app version from choking and crashing on large data sets.
@ -70,7 +69,7 @@ For advanced users, you can deploy **FreesearchR** using Docker. A data folder c
To mount a local data folder, add a `volumes` entry to your `docker-compose.yml` file: To mount a local data folder, add a `volumes` entry to your `docker-compose.yml` file:
```yaml ``` yaml
services: services:
shiny: shiny:
image: ghcr.io/agdamsbo/freesearchr:latest image: ghcr.io/agdamsbo/freesearchr:latest
@ -86,9 +85,9 @@ services:
restart: on-failure restart: on-failure
``` ```
- The `:ro` flag mounts the folder as **read-only**, preventing the app from modifying your original data files. - The `:ro` flag mounts the folder as **read-only**, preventing the app from modifying your original data files.
- If no volume is mounted, the app will start without any preloaded datasets. - If no volume is mounted, the app will start without any preloaded datasets.
## Code of Conduct ## Code of Conduct

View file

@ -11,11 +11,11 @@
|collate |en_US.UTF-8 | |collate |en_US.UTF-8 |
|ctype |en_US.UTF-8 | |ctype |en_US.UTF-8 |
|tz |Europe/Copenhagen | |tz |Europe/Copenhagen |
|date |2026-03-12 | |date |2026-03-23 |
|rstudio |2026.01.1+403 Apple Blossom (desktop) | |rstudio |2026.01.1+403 Apple Blossom (desktop) |
|pandoc |3.6.4 @ /opt/homebrew/bin/ (via rmarkdown) | |pandoc |3.6.4 @ /opt/homebrew/bin/ (via rmarkdown) |
|quarto |1.7.30 @ /usr/local/bin/quarto | |quarto |1.7.30 @ /usr/local/bin/quarto |
|FreesearchR |26.3.4.260312 | |FreesearchR |26.3.4.260323 |
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -33,6 +33,7 @@
|bit64 |4.6.0-1 |2025-01-16 |CRAN (R 4.5.0) | |bit64 |4.6.0-1 |2025-01-16 |CRAN (R 4.5.0) |
|bitops |1.0-9 |2024-10-03 |CRAN (R 4.5.0) | |bitops |1.0-9 |2024-10-03 |CRAN (R 4.5.0) |
|boot |1.3-32 |2025-08-29 |CRAN (R 4.5.0) | |boot |1.3-32 |2025-08-29 |CRAN (R 4.5.0) |
|brio |1.1.5 |2024-04-24 |CRAN (R 4.5.0) |
|broom |1.0.12 |2026-01-27 |CRAN (R 4.5.2) | |broom |1.0.12 |2026-01-27 |CRAN (R 4.5.2) |
|broom.helpers |1.22.0 |2025-09-17 |CRAN (R 4.5.0) | |broom.helpers |1.22.0 |2025-09-17 |CRAN (R 4.5.0) |
|bsicons |0.1.2 |2023-11-04 |CRAN (R 4.5.0) | |bsicons |0.1.2 |2023-11-04 |CRAN (R 4.5.0) |
@ -43,6 +44,7 @@
|cardx |0.3.2 |2026-02-05 |CRAN (R 4.5.2) | |cardx |0.3.2 |2026-02-05 |CRAN (R 4.5.2) |
|caTools |1.18.3 |2024-09-04 |CRAN (R 4.5.0) | |caTools |1.18.3 |2024-09-04 |CRAN (R 4.5.0) |
|cellranger |1.1.0 |2016-07-27 |CRAN (R 4.5.0) | |cellranger |1.1.0 |2016-07-27 |CRAN (R 4.5.0) |
|cffr |1.2.1 |2026-01-12 |CRAN (R 4.5.2) |
|checkmate |2.3.4 |2026-02-03 |CRAN (R 4.5.2) | |checkmate |2.3.4 |2026-02-03 |CRAN (R 4.5.2) |
|class |7.3-23 |2025-01-01 |CRAN (R 4.5.0) | |class |7.3-23 |2025-01-01 |CRAN (R 4.5.0) |
|classInt |0.4-11 |2025-01-08 |CRAN (R 4.5.0) | |classInt |0.4-11 |2025-01-08 |CRAN (R 4.5.0) |
@ -52,6 +54,7 @@
|colorspace |2.1-2 |2025-09-22 |CRAN (R 4.5.0) | |colorspace |2.1-2 |2025-09-22 |CRAN (R 4.5.0) |
|commonmark |2.0.0 |2025-07-07 |CRAN (R 4.5.0) | |commonmark |2.0.0 |2025-07-07 |CRAN (R 4.5.0) |
|crayon |1.5.3 |2024-06-20 |CRAN (R 4.5.0) | |crayon |1.5.3 |2024-06-20 |CRAN (R 4.5.0) |
|curl |7.0.0 |2025-08-19 |CRAN (R 4.5.0) |
|data.table |1.18.2.1 |2026-01-27 |CRAN (R 4.5.2) | |data.table |1.18.2.1 |2026-01-27 |CRAN (R 4.5.2) |
|datamods |1.5.3 |2024-10-02 |CRAN (R 4.5.0) | |datamods |1.5.3 |2024-10-02 |CRAN (R 4.5.0) |
|datawizard |1.3.0 |2025-10-11 |CRAN (R 4.5.0) | |datawizard |1.3.0 |2025-10-11 |CRAN (R 4.5.0) |
@ -66,7 +69,7 @@
|e1071 |1.7-17 |2025-12-18 |CRAN (R 4.5.2) | |e1071 |1.7-17 |2025-12-18 |CRAN (R 4.5.2) |
|easystats |0.7.5 |2025-07-11 |CRAN (R 4.5.0) | |easystats |0.7.5 |2025-07-11 |CRAN (R 4.5.0) |
|ellipsis |0.3.2 |2021-04-29 |CRAN (R 4.5.0) | |ellipsis |0.3.2 |2021-04-29 |CRAN (R 4.5.0) |
|emmeans |2.0.2 |2026-03-05 |CRAN (R 4.5.2) | |emmeans |2.0.1 |2025-12-16 |CRAN (R 4.5.2) |
|esquisse |2.1.0 |2025-02-21 |CRAN (R 4.5.0) | |esquisse |2.1.0 |2025-02-21 |CRAN (R 4.5.0) |
|estimability |1.5.1 |2024-05-12 |CRAN (R 4.5.0) | |estimability |1.5.1 |2024-05-12 |CRAN (R 4.5.0) |
|eulerr |7.0.4 |2025-09-24 |CRAN (R 4.5.0) | |eulerr |7.0.4 |2025-09-24 |CRAN (R 4.5.0) |
@ -74,6 +77,7 @@
|farver |2.1.2 |2024-05-13 |CRAN (R 4.5.0) | |farver |2.1.2 |2024-05-13 |CRAN (R 4.5.0) |
|fastmap |1.2.0 |2024-05-15 |CRAN (R 4.5.0) | |fastmap |1.2.0 |2024-05-15 |CRAN (R 4.5.0) |
|flextable |0.9.11 |2026-02-13 |CRAN (R 4.5.2) | |flextable |0.9.11 |2026-02-13 |CRAN (R 4.5.2) |
|fontawesome |0.5.3 |2024-11-16 |CRAN (R 4.5.0) |
|fontBitstreamVera |0.1.1 |2017-02-01 |CRAN (R 4.5.0) | |fontBitstreamVera |0.1.1 |2017-02-01 |CRAN (R 4.5.0) |
|fontLiberation |0.1.0 |2016-10-15 |CRAN (R 4.5.0) | |fontLiberation |0.1.0 |2016-10-15 |CRAN (R 4.5.0) |
|fontquiver |0.2.1 |2017-02-01 |CRAN (R 4.5.0) | |fontquiver |0.2.1 |2017-02-01 |CRAN (R 4.5.0) |
@ -109,9 +113,11 @@
|iterators |1.0.14 |2022-02-05 |CRAN (R 4.5.0) | |iterators |1.0.14 |2022-02-05 |CRAN (R 4.5.0) |
|jquerylib |0.1.4 |2021-04-26 |CRAN (R 4.5.0) | |jquerylib |0.1.4 |2021-04-26 |CRAN (R 4.5.0) |
|jsonlite |2.0.0 |2025-03-27 |CRAN (R 4.5.0) | |jsonlite |2.0.0 |2025-03-27 |CRAN (R 4.5.0) |
|jsonvalidate |1.5.0 |2025-02-07 |CRAN (R 4.5.0) |
|KernSmooth |2.23-26 |2025-01-01 |CRAN (R 4.5.0) | |KernSmooth |2.23-26 |2025-01-01 |CRAN (R 4.5.0) |
|keyring |1.4.1 |2025-06-15 |CRAN (R 4.5.0) | |keyring |1.4.1 |2025-06-15 |CRAN (R 4.5.0) |
|knitr |1.51 |2025-12-20 |CRAN (R 4.5.2) | |knitr |1.51 |2025-12-20 |CRAN (R 4.5.2) |
|labeling |0.4.3 |2023-08-29 |CRAN (R 4.5.0) |
|later |1.4.8 |2026-03-05 |CRAN (R 4.5.2) | |later |1.4.8 |2026-03-05 |CRAN (R 4.5.2) |
|lattice |0.22-7 |2025-04-02 |CRAN (R 4.5.2) | |lattice |0.22-7 |2025-04-02 |CRAN (R 4.5.2) |
|lifecycle |1.0.5 |2026-01-08 |CRAN (R 4.5.2) | |lifecycle |1.0.5 |2026-01-08 |CRAN (R 4.5.2) |
@ -123,7 +129,7 @@
|memoise |2.0.1 |2021-11-26 |CRAN (R 4.5.0) | |memoise |2.0.1 |2021-11-26 |CRAN (R 4.5.0) |
|mime |0.13 |2025-03-17 |CRAN (R 4.5.0) | |mime |0.13 |2025-03-17 |CRAN (R 4.5.0) |
|minqa |1.2.8 |2024-08-17 |CRAN (R 4.5.0) | |minqa |1.2.8 |2024-08-17 |CRAN (R 4.5.0) |
|mvtnorm |1.3-5 |2026-03-11 |CRAN (R 4.5.2) | |mvtnorm |1.3-2 |2024-11-04 |CRAN (R 4.5.2) |
|NHANES |2.1.0 |2015-07-02 |CRAN (R 4.5.0) | |NHANES |2.1.0 |2015-07-02 |CRAN (R 4.5.0) |
|nlme |3.1-168 |2025-03-31 |CRAN (R 4.5.0) | |nlme |3.1-168 |2025-03-31 |CRAN (R 4.5.0) |
|nloptr |2.2.1 |2025-03-17 |CRAN (R 4.5.0) | |nloptr |2.2.1 |2025-03-17 |CRAN (R 4.5.0) |
@ -156,6 +162,7 @@
|R6 |2.6.1 |2025-02-15 |CRAN (R 4.5.0) | |R6 |2.6.1 |2025-02-15 |CRAN (R 4.5.0) |
|ragg |1.5.1 |2026-03-06 |CRAN (R 4.5.2) | |ragg |1.5.1 |2026-03-06 |CRAN (R 4.5.2) |
|rankinPlot |1.1.0 |2023-01-30 |CRAN (R 4.5.0) | |rankinPlot |1.1.0 |2023-01-30 |CRAN (R 4.5.0) |
|rappdirs |0.3.4 |2026-01-17 |CRAN (R 4.5.2) |
|rbibutils |2.4.1 |2026-01-21 |CRAN (R 4.5.2) | |rbibutils |2.4.1 |2026-01-21 |CRAN (R 4.5.2) |
|RColorBrewer |1.1-3 |2022-04-03 |CRAN (R 4.5.0) | |RColorBrewer |1.1-3 |2022-04-03 |CRAN (R 4.5.0) |
|Rcpp |1.1.1 |2026-01-10 |CRAN (R 4.5.2) | |Rcpp |1.1.1 |2026-01-10 |CRAN (R 4.5.2) |
@ -197,6 +204,7 @@
|stringr |1.6.0 |2025-11-04 |CRAN (R 4.5.0) | |stringr |1.6.0 |2025-11-04 |CRAN (R 4.5.0) |
|stRoke |25.9.2 |2025-09-30 |CRAN (R 4.5.0) | |stRoke |25.9.2 |2025-09-30 |CRAN (R 4.5.0) |
|systemfonts |1.3.2 |2026-03-05 |CRAN (R 4.5.2) | |systemfonts |1.3.2 |2026-03-05 |CRAN (R 4.5.2) |
|testthat |3.3.2 |2026-01-11 |CRAN (R 4.5.2) |
|textshaping |1.0.5 |2026-03-06 |CRAN (R 4.5.2) | |textshaping |1.0.5 |2026-03-06 |CRAN (R 4.5.2) |
|thematic |0.1.8 |2025-09-29 |CRAN (R 4.5.0) | |thematic |0.1.8 |2025-09-29 |CRAN (R 4.5.0) |
|tibble |3.3.1 |2026-01-11 |CRAN (R 4.5.2) | |tibble |3.3.1 |2026-01-11 |CRAN (R 4.5.2) |
@ -208,7 +216,9 @@
|twosamples |2.0.1 |2023-06-23 |CRAN (R 4.5.0) | |twosamples |2.0.1 |2023-06-23 |CRAN (R 4.5.0) |
|tzdb |0.5.0 |2025-03-15 |CRAN (R 4.5.0) | |tzdb |0.5.0 |2025-03-15 |CRAN (R 4.5.0) |
|usethis |3.2.1 |2025-09-06 |CRAN (R 4.5.0) | |usethis |3.2.1 |2025-09-06 |CRAN (R 4.5.0) |
|utf8 |1.2.6 |2025-06-08 |CRAN (R 4.5.0) |
|uuid |1.2-2 |2026-01-23 |CRAN (R 4.5.2) | |uuid |1.2-2 |2026-01-23 |CRAN (R 4.5.2) |
|V8 |8.0.1 |2025-10-10 |CRAN (R 4.5.0) |
|vctrs |0.7.1 |2026-01-23 |CRAN (R 4.5.2) | |vctrs |0.7.1 |2026-01-23 |CRAN (R 4.5.2) |
|viridis |0.6.5 |2024-01-29 |CRAN (R 4.5.0) | |viridis |0.6.5 |2024-01-29 |CRAN (R 4.5.0) |
|viridisLite |0.4.3 |2026-02-04 |CRAN (R 4.5.2) | |viridisLite |0.4.3 |2026-02-04 |CRAN (R 4.5.2) |

View file

@ -1,7 +1,7 @@
######## ########
#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpZZ6Yua/file58174f49b1bf.R #### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmprPVhaz/file70562aff8e9e.R
######## ########
i18n_path <- here::here("translations") i18n_path <- here::here("translations")
@ -4514,7 +4514,7 @@ data_types <- function() {
#### Current file: /Users/au301842/FreesearchR/R//hosted_version.R #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R
######## ########
hosted_version <- function()'v26.3.4-260312' hosted_version <- function()'v26.3.4-260323'
######## ########
@ -5964,6 +5964,8 @@ landing_page_ui <- function(i18n) {
#' @param data_limit_default default data set observations limit #' @param data_limit_default default data set observations limit
#' @param data_limit_upper data set observations upper limit #' @param data_limit_upper data set observations upper limit
#' @param data_limit_lower data set observations lower limit #' @param data_limit_lower data set observations lower limit
#' @param check_app_version always attempt to check app version against latest
#' release on GitHub. Default is FALSE
#' @param ... passed on to `shiny::runApp()` #' @param ... passed on to `shiny::runApp()`
#' #'
#' @returns shiny app #' @returns shiny app
@ -5978,12 +5980,14 @@ launch_FreesearchR <- function(include_globalenv = TRUE,
data_limit_default = 1000, data_limit_default = 1000,
data_limit_upper = 100000, data_limit_upper = 100000,
data_limit_lower = 1, data_limit_lower = 1,
check_app_version = FALSE,
...) { ...) {
Sys.setenv( Sys.setenv(
INCLUDE_GLOBALENV = include_globalenv, INCLUDE_GLOBALENV = include_globalenv,
DATA_LIMIT_DEFAULT = data_limit_default, DATA_LIMIT_DEFAULT = data_limit_default,
DATA_LIMIT_UPPER = data_limit_upper, DATA_LIMIT_UPPER = data_limit_upper,
DATA_LIMIT_LOWER = data_limit_lower DATA_LIMIT_LOWER = data_limit_lower,
CHECK_APP_VERSION = check_app_version
) )
appDir <- system.file("apps", "FreesearchR", package = "FreesearchR") appDir <- system.file("apps", "FreesearchR", package = "FreesearchR")
@ -7054,15 +7058,17 @@ sankey_ready <- function(data, pri, sec, numbers = "count", ...) {
dplyr::ungroup() dplyr::ungroup()
if (numbers == "count") { if (numbers == "count") {
out <- out |> dplyr::mutate( out <- out |> dplyr::mutate(lx = factor(paste0(
lx = factor(paste0(!!dplyr::sym(pri), "\n(n=", gx.sum, ")")), !!dplyr::sym(pri), "\n(n=", gx.sum, ")"
ly = factor(paste0(!!dplyr::sym(sec), "\n(n=", gy.sum, ")")) )), ly = factor(paste0(
) !!dplyr::sym(sec), "\n(n=", gy.sum, ")"
)))
} else if (numbers == "percentage") { } else if (numbers == "percentage") {
out <- out |> dplyr::mutate( out <- out |> dplyr::mutate(lx = factor(paste0(
lx = factor(paste0(!!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")), !!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)"
ly = factor(paste0(!!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)")) )), ly = factor(paste0(
) !!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)"
)))
} }
if (is.factor(data[[pri]])) { if (is.factor(data[[pri]])) {
@ -7104,20 +7110,38 @@ str_remove_last <- function(data, pattern = "\n") {
#' mtcars |> #' mtcars |>
#' default_parsing() |> #' default_parsing() |>
#' plot_sankey("cyl", "gear", "vs", color.group = "pri") #' plot_sankey("cyl", "gear", "vs", color.group = "pri")
plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors = NULL,missing.level="Missing") { #'
#' # stRoke::trial |> plot_sankey("mrs_1", "mrs_6")
plot_sankey <- function(data,
pri,
sec,
ter = NULL,
color.group = "pri",
colors = NULL,
missing.level = "Missing") {
if (!is.null(ter)) { if (!is.null(ter)) {
ds <- split(data, data[ter]) ds <- split(data, data[ter])
} else { } else {
ds <- list(data) ds <- list(data)
} }
out <- lapply(ds, \(.ds){
plot_sankey_single(.ds, pri = pri, sec = sec, color.group = color.group, colors = colors,missing.level=missing.level) out <- lapply(ds, \(.ds) {
plot_sankey_single(
.ds,
pri = pri,
sec = sec,
color.group = color.group,
colors = colors,
missing.level = missing.level
)
}) })
patchwork::wrap_plots(out) patchwork::wrap_plots(out)
} }
#' Beautiful sankey plot #' Beautiful sankey plot
#' #'
#' @param color.group set group to colour by. "x" or "y". #' @param color.group set group to colour by. "x" or "y".
@ -7144,19 +7168,31 @@ plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors
#' stRoke::trial |> #' stRoke::trial |>
#' default_parsing() |> #' default_parsing() |>
#' plot_sankey_single("diabetes", "hypertension") #' plot_sankey_single("diabetes", "hypertension")
plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL,missing.level="Missing", ...) { plot_sankey_single <- function(data,
pri,
sec,
color.group = c("pri", "sec"),
colors = NULL,
missing.level = "Missing",
...) {
color.group <- match.arg(color.group) color.group <- match.arg(color.group)
# browser()
# if (is.na(ds[c(pri,sec)]))
# browser() # browser()
data_orig <- data data_orig <- data
data[c(pri, sec)] <- data[c(pri, sec)] |> data[c(pri, sec)] <- data[c(pri, sec)] |>
dplyr::mutate( dplyr::mutate(
# dplyr::across(dplyr::where(is.logical), as.factor), dplyr::across(dplyr::where(is.logical), as.factor),
dplyr::across(dplyr::where(is.factor), forcats::fct_drop)#, dplyr::across(dplyr::where(is.factor), forcats::fct_drop),
# dplyr::across(dplyr::where(is.factor), \(.x){forcats::fct_na_value_to_level(.x,missing.level)}) dplyr::across(dplyr::where(is.factor), \(.x) {
forcats::fct_na_value_to_level(.x, missing.level)
})
) )
data <- data |> sankey_ready(pri = pri, sec = sec, ...) data <- data |> sankey_ready(pri = pri, sec = sec, ...)
na.color <- "#2986cc" na.color <- "#2986cc"
@ -7169,21 +7205,26 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
main.colors <- main.colors[match(levels(data[[sec]]), levels(data_orig[[sec]]))] main.colors <- main.colors[match(levels(data[[sec]]), levels(data_orig[[sec]]))]
secondary.colors <- rep(na.color, length(levels(data[[pri]]))) secondary.colors <- rep(na.color, length(levels(data[[pri]])))
label.colors <- Reduce(c, lapply(list(secondary.colors, rev(main.colors)), contrast_text)) label.colors <- Reduce(c, lapply(list(
secondary.colors, rev(main.colors)
), contrast_text))
} else { } else {
main.colors <- viridisLite::viridis(n = length(levels(data_orig[[pri]]))) main.colors <- viridisLite::viridis(n = length(levels(data_orig[[pri]])))
## Only keep colors for included levels ## Only keep colors for included levels
main.colors <- main.colors[match(levels(data[[pri]]), levels(data_orig[[pri]]))] main.colors <- main.colors[match(levels(data[[pri]]), levels(data_orig[[pri]]))]
secondary.colors <- rep(na.color, length(levels(data[[sec]]))) secondary.colors <- rep(na.color, length(levels(data[[sec]])))
label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text)) label.colors <- Reduce(c, lapply(list(
rev(main.colors), secondary.colors
), contrast_text))
} }
colors <- c(na.color, main.colors, secondary.colors) colors <- c(na.color, main.colors, secondary.colors)
colors[is.na(colors)] <- "grey80"
} else { } else {
label.colors <- contrast_text(colors) label.colors <- contrast_text(colors)
} }
group_labels <- c(get_label(data, pri), get_label(data, sec)) |> group_labels <- c(get_label(data_orig, pri), get_label(data_orig, sec)) |>
sapply(line_break) |> sapply(line_break) |>
unname() unname()
@ -7202,9 +7243,8 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
knot.pos = 0.4, knot.pos = 0.4,
curve_type = "sigmoid" curve_type = "sigmoid"
) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(sec)), ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(sec)),
size = 2, size = 2,
width = 1 / 3.4 width = 1 / 3.4)
)
} else { } else {
p <- p + p <- p +
ggalluvial::geom_alluvium( ggalluvial::geom_alluvium(
@ -7217,9 +7257,8 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
knot.pos = 0.4, knot.pos = 0.4,
curve_type = "sigmoid" curve_type = "sigmoid"
) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(pri)), ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(pri)),
size = 2, size = 2,
width = 1 / 3.4 width = 1 / 3.4)
)
} }
## Will fail to use stat="stratum" if library is not loaded. ## Will fail to use stat="stratum" if library is not loaded.
@ -7229,13 +7268,10 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
stat = "stratum", stat = "stratum",
ggplot2::aes(label = after_stat(stratum)), ggplot2::aes(label = after_stat(stratum)),
colour = label.colors, colour = label.colors,
size = 8, size = 6,
lineheight = 1 lineheight = 1
) + ) +
ggplot2::scale_x_continuous( ggplot2::scale_x_continuous(breaks = 1:2, labels = group_labels) +
breaks = 1:2,
labels = group_labels
) +
ggplot2::scale_fill_manual(values = colors[-1], na.value = colors[1]) + ggplot2::scale_fill_manual(values = colors[-1], na.value = colors[1]) +
# ggplot2::scale_color_manual(values = main.colors) + # ggplot2::scale_color_manual(values = main.colors) +
ggplot2::theme_void() + ggplot2::theme_void() +
@ -10772,6 +10808,7 @@ ui_elements <- function(selection) {
## Default just output "NULL" ## Default just output "NULL"
## This could probably be achieved more legantly, but this works. ## This could probably be achieved more legantly, but this works.
dev_banner(), dev_banner(),
version_banner,
landing_page_ui(i18n = i18n), landing_page_ui(i18n = i18n),
# shiny::column(width = 2), # shiny::column(width = 2),
# shiny::column( # shiny::column(
@ -12832,33 +12869,6 @@ validation_server <- function(id,
data_r <- if (shiny::is.reactive(data)) data else shiny::reactive(data) data_r <- if (shiny::is.reactive(data)) data else shiny::reactive(data)
# observeEvent(data_r(), {
# to_validate <- data()
# valid_dims <- check_data(to_validate, n_row = n_row, n_col = n_col)
#
# if (all(c(valid_dims$nrows, valid_dims$ncols))) {
# valid_status <- "OK"
# } else {
# valid_status <- "Failed"
# }
#
# valid_results <- lapply(
# X = c("nrows", "ncols"),
# FUN = function(x) {
# if (is.null(valid_dims[[x]]))
# return(NULL)
# label <- switch(
# x,
# "nrows" = n_row_label,
# "ncols" = n_col_label
# )
# list(
# status = ifelse(valid_dims[[x]], "OK", "Failed"),
# label = paste0("<b>", label, "</b>")
# )
# }
# )
shiny::observeEvent( shiny::observeEvent(
data_r(), data_r(),
{ {
@ -13242,6 +13252,337 @@ make_validation_alerts <- function(data) {
} }
########
#### Current file: /Users/au301842/FreesearchR/R//version_check.R
########
# version_check.R
#
# Runs a one-time version check at app startup and returns a ready-made
# shinyWidgets::alert() UI element that can be placed directly in the UI
# definition -- no server(), no renderUI(), no uiOutput() required.
#
# Because the check runs outside server(), it executes once when the app
# process starts, so the banner is present immediately on first render with
# no loading delay.
#
# Version detection uses two strategies, tried in order:
# 1. utils::packageVersion() -- works when the package is installed locally.
# 2. app_version argument -- explicit fallback for environments where the
# package is not installed (e.g. shinyapps.io). Pass the result of your
# app_version() function here.
#
# Quick start:
#
# # global.R (or top of app.R, before ui / server)
# source("version_check.R")
# version_banner <- check_app_version(
# github_user = "your-github-username",
# github_repo = "your-repo-name",
# app_version = app_version() # fallback for shinyapps.io
# )
#
# # ui.R -- drop the result anywhere in the UI tree
# fluidPage(
# version_banner,
# ...
# )
#
# # Verbose / debug mode -- always show the banner:
# version_banner <- check_app_version(
# github_user = "your-github-username",
# github_repo = "your-repo-name",
# app_version = app_version(),
# verbose = TRUE
# )
# -- Internal helpers ----------------------------------------------------------
#' Check internet connectivity
#'
#' @return Logical; TRUE if an internet connection is available.
.has_internet <- function() {
tryCatch({
con <- url("https://api.github.com", open = "r")
close(con)
TRUE
}, error = function(e) FALSE)
}
#' Fetch the latest release version from a GitHub repository
#'
#' @param github_user GitHub username or organisation.
#' @param github_repo Repository name.
#'
#' @return A character string with the version tag (e.g. "1.2.0"), or NULL on
#' failure.
.get_latest_github_version <- function(github_user, github_repo) {
api_url <- sprintf(
"https://api.github.com/repos/%s/%s/releases/latest",
github_user,
github_repo
)
tryCatch({
response <- readLines(url(api_url), warn = FALSE)
json_text <- paste(response, collapse = "")
tag <- regmatches(
json_text,
regexpr('"tag_name"\\s*:\\s*"([^"]+)"', json_text)
)
if (length(tag) == 0 || nchar(tag) == 0) return(NULL)
# Strip a leading "v" if present (e.g. "v1.2.0" -> "1.2.0")
sub('^"tag_name"\\s*:\\s*"v?([^"]+)"$', "\\1", tag)
}, error = function(e) NULL)
}
#' Resolve the current app version
#'
#' Tries two strategies in order:
#' \enumerate{
#' \item \code{utils::packageVersion(package_name)} -- works when the package
#' is installed locally (development, local \code{runApp()}).
#' \item \code{app_version} argument -- an explicit version string supplied by
#' the caller, e.g. from an \code{app_version()} function bundled with the
#' app. Used on shinyapps.io where the package is not installed.
#' }
#'
#' @param package_name Name of the package / repository.
#' @param app_version Optional fallback version string.
#'
#' @return A character string with the version (e.g. "1.1.0"), or NULL if
#' neither strategy succeeds.
.resolve_app_version <- function(package_name, app_version = NULL) {
# Strategy 1: installed package
v <- tryCatch(
as.character(utils::packageVersion(package_name)),
error = function(e) NULL
)
if (!is.null(v)) {
message("[version_check] Version source: installed package")
return(v)
}
# Strategy 2: explicit fallback supplied by the caller
if (!is.null(app_version)) {
message("[version_check] Version source: app_version() fallback")
return(as.character(app_version))
}
NULL
}
#' Build a shinyWidgets::alert() UI element for the version banner
#'
#' @param current Current installed version string.
#' @param latest Latest GitHub release version string, or NULL when
#' the check could not complete (e.g. no internet).
#' @param update_available Logical; whether latest > current.
#' @param github_user GitHub username / organisation.
#' @param github_repo Repository name.
#'
#' @return A \code{shinyWidgets::alert()} UI element.
.build_version_alert <- function(current,
latest,
update_available,
github_user,
github_repo) {
repo_url <- sprintf(
"https://github.com/%s/%s/releases/latest",
github_user,
github_repo
)
if (is.null(latest)) {
# Version check could not complete (no internet or API failure)
return(
shinyWidgets::alert(
tags$b("Version check failed. "),
sprintf(
"Running version %s. Could not reach GitHub to check for updates.",
current
),
status = "warning",
dismissible = TRUE
)
)
}
if (update_available) {
shinyWidgets::alert(
tags$b("Update available! "),
sprintf(
"You are running version %s. Version %s is available on GitHub.",
current, latest
),
" ",
tags$a(href = repo_url, target = "_blank", "View release"),
status = "warning",
dismissible = TRUE
)
} else {
# Up to date -- only shown in verbose mode
shinyWidgets::alert(
tags$b("Up to date. "),
sprintf(
"You are running version %s, which matches the latest release (%s).",
current, latest
),
status = "success",
dismissible = TRUE
)
}
}
# -- Public API ----------------------------------------------------------------
#' Run a startup version check and return a banner UI element
#'
#' Call this \strong{outside} \code{server()} -- typically in
#' \code{global.R} or at the top of \code{app.R} -- and embed the returned
#' value directly in your UI definition. Because the check runs at startup
#' the banner is present on first render with no loading delay, and no
#' \code{uiOutput()} / \code{renderUI()} wiring is needed.
#'
#' \strong{Normal mode} (\code{verbose = FALSE}): returns a banner only when
#' a newer version is available or when the check fails. Returns \code{NULL}
#' when the app is up to date (Shiny silently ignores \code{NULL} in the UI).
#'
#' \strong{Verbose / debug mode} (\code{verbose = TRUE}): always returns a
#' banner -- including a success banner when up to date -- so you can confirm
#' the check ran and inspect both version strings during development.
#'
#' @param github_user GitHub username or organisation that owns the repository.
#' @param github_repo Repository name. Also used as the package name for
#' \code{utils::packageVersion()}.
#' @param app_version Optional fallback version string for environments where
#' the package is not installed (e.g. shinyapps.io). Pass the result of your
#' \code{app_version()} function here. Ignored when \code{packageVersion()}
#' succeeds.
#' @param verbose Logical; if \code{TRUE} a banner is always returned.
#' Defaults to \code{FALSE}.
#'
#' @return A \code{shinyWidgets::alert()} UI element, or \code{NULL} when there
#' is nothing to show (up to date in non-verbose mode).
#'
#' @examples
#' \dontrun{
#' # global.R or top of app.R
#' source("version_check.R")
#' version_banner <- check_app_version(
#' github_user = "my-org",
#' github_repo = "my-shiny-app",
#' app_version = app_version() # fallback for shinyapps.io
#' )
#'
#' # ui.R
#' fluidPage(
#' version_banner,
#' # ... rest of UI
#' )
#'
#' # Verbose mode for development
#' version_banner <- check_app_version(
#' github_user = "my-org",
#' github_repo = "my-shiny-app",
#' app_version = app_version(),
#' verbose = TRUE
#' )
#' }
check_app_version <- function(github_user,
github_repo,
app_version = NULL,
verbose = FALSE) {
# -- 1. Resolve current version ----------------------------------------------
local_version <- .resolve_app_version(github_repo, app_version)
if (is.null(local_version)) {
message(sprintf(
"[version_check] Could not determine version for '%s' (package not installed and no app_version() fallback supplied).",
github_repo
))
return(NULL)
}
message(sprintf("[version_check] Current version: %s", local_version))
# -- 2. Internet check -------------------------------------------------------
if (!.has_internet()) {
message("[version_check] No internet connection detected -- skipping.")
if (verbose) {
return(.build_version_alert(
current = local_version,
latest = NULL,
update_available = FALSE,
github_user = github_user,
github_repo = github_repo
))
}
return(NULL)
}
# -- 3. Fetch latest GitHub release ------------------------------------------
latest_version <- .get_latest_github_version(github_user, github_repo)
if (is.null(latest_version)) {
message("[version_check] Could not retrieve latest version from GitHub.")
if (verbose) {
return(.build_version_alert(
current = local_version,
latest = NULL,
update_available = FALSE,
github_user = github_user,
github_repo = github_repo
))
}
return(NULL)
}
message(sprintf("[version_check] Latest GitHub release: %s", latest_version))
# -- 4. Compare versions -----------------------------------------------------
update_available <- numeric_version(latest_version) > numeric_version(local_version)
if (update_available) {
message(sprintf(
"[version_check] Update available: %s -> %s",
local_version, latest_version
))
} else {
message(sprintf("[version_check] App is up to date (%s).", local_version))
}
# -- 5. Return banner --------------------------------------------------------
# An update was found -> always return a warning banner
# Up to date + verbose -> return a success banner
# Up to date + not verbose -> return NULL (Shiny ignores NULL in the UI)
if (update_available || verbose) {
.build_version_alert(
current = local_version,
latest = latest_version,
update_available = update_available,
github_user = github_user,
github_repo = github_repo
)
} else {
NULL
}
}
######## ########
#### Current file: /Users/au301842/FreesearchR/R//visual_summary.R #### Current file: /Users/au301842/FreesearchR/R//visual_summary.R
######## ########
@ -13714,6 +14055,7 @@ INCLUDE_GLOBALENV <- get_config("INCLUDE_GLOBALENV", default = FALSE)
DATA_LIMIT_DEFAULT <- get_config("DATA_LIMIT_DEFAULT", default = 10000) DATA_LIMIT_DEFAULT <- get_config("DATA_LIMIT_DEFAULT", default = 10000)
DATA_LIMIT_UPPER <- get_config("DATA_LIMIT_UPPER", default = 100000) DATA_LIMIT_UPPER <- get_config("DATA_LIMIT_UPPER", default = 100000)
DATA_LIMIT_LOWER <- get_config("DATA_LIMIT_LOWER", default = 1) DATA_LIMIT_LOWER <- get_config("DATA_LIMIT_LOWER", default = 1)
CHECK_APP_VERSION <- get_config("CHECK_APP_VERSION", default = FALSE)
## Loads folder passed to the docker container and mounted as below: ## Loads folder passed to the docker container and mounted as below:
## ##
@ -13726,6 +14068,10 @@ DATA_LIMIT_LOWER <- get_config("DATA_LIMIT_LOWER", default = 1)
## All files in the ./data/ folder is attempted loaded ## All files in the ./data/ folder is attempted loaded
load_folder() load_folder()
## App version check
version_banner <- check_app_version("agdamsbo", "FreesearchR",app_version = app_version(),verbose=CHECK_APP_VERSION)
######## ########
#### Current file: /Users/au301842/FreesearchR/app/ui.R #### Current file: /Users/au301842/FreesearchR/app/ui.R

View file

@ -1,7 +1,7 @@
######## ########
#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpmhqokQ/file1a147dcf977e.R #### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmprPVhaz/file70565b30c8af.R
######## ########
i18n_path <- system.file("translations", package = "FreesearchR") i18n_path <- system.file("translations", package = "FreesearchR")
@ -64,7 +64,7 @@ i18n$set_translation_language("en")
#### Current file: /Users/au301842/FreesearchR/R//app_version.R #### Current file: /Users/au301842/FreesearchR/R//app_version.R
######## ########
app_version <- function()'26.3.3' app_version <- function()'26.3.4'
######## ########
@ -4514,7 +4514,7 @@ data_types <- function() {
#### Current file: /Users/au301842/FreesearchR/R//hosted_version.R #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R
######## ########
hosted_version <- function()'v26.3.3-260312' hosted_version <- function()'v26.3.4-260323'
######## ########
@ -5964,6 +5964,8 @@ landing_page_ui <- function(i18n) {
#' @param data_limit_default default data set observations limit #' @param data_limit_default default data set observations limit
#' @param data_limit_upper data set observations upper limit #' @param data_limit_upper data set observations upper limit
#' @param data_limit_lower data set observations lower limit #' @param data_limit_lower data set observations lower limit
#' @param check_app_version always attempt to check app version against latest
#' release on GitHub. Default is FALSE
#' @param ... passed on to `shiny::runApp()` #' @param ... passed on to `shiny::runApp()`
#' #'
#' @returns shiny app #' @returns shiny app
@ -5978,12 +5980,14 @@ launch_FreesearchR <- function(include_globalenv = TRUE,
data_limit_default = 1000, data_limit_default = 1000,
data_limit_upper = 100000, data_limit_upper = 100000,
data_limit_lower = 1, data_limit_lower = 1,
check_app_version = FALSE,
...) { ...) {
Sys.setenv( Sys.setenv(
INCLUDE_GLOBALENV = include_globalenv, INCLUDE_GLOBALENV = include_globalenv,
DATA_LIMIT_DEFAULT = data_limit_default, DATA_LIMIT_DEFAULT = data_limit_default,
DATA_LIMIT_UPPER = data_limit_upper, DATA_LIMIT_UPPER = data_limit_upper,
DATA_LIMIT_LOWER = data_limit_lower DATA_LIMIT_LOWER = data_limit_lower,
CHECK_APP_VERSION = check_app_version
) )
appDir <- system.file("apps", "FreesearchR", package = "FreesearchR") appDir <- system.file("apps", "FreesearchR", package = "FreesearchR")
@ -7054,15 +7058,17 @@ sankey_ready <- function(data, pri, sec, numbers = "count", ...) {
dplyr::ungroup() dplyr::ungroup()
if (numbers == "count") { if (numbers == "count") {
out <- out |> dplyr::mutate( out <- out |> dplyr::mutate(lx = factor(paste0(
lx = factor(paste0(!!dplyr::sym(pri), "\n(n=", gx.sum, ")")), !!dplyr::sym(pri), "\n(n=", gx.sum, ")"
ly = factor(paste0(!!dplyr::sym(sec), "\n(n=", gy.sum, ")")) )), ly = factor(paste0(
) !!dplyr::sym(sec), "\n(n=", gy.sum, ")"
)))
} else if (numbers == "percentage") { } else if (numbers == "percentage") {
out <- out |> dplyr::mutate( out <- out |> dplyr::mutate(lx = factor(paste0(
lx = factor(paste0(!!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")), !!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)"
ly = factor(paste0(!!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)")) )), ly = factor(paste0(
) !!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)"
)))
} }
if (is.factor(data[[pri]])) { if (is.factor(data[[pri]])) {
@ -7104,20 +7110,38 @@ str_remove_last <- function(data, pattern = "\n") {
#' mtcars |> #' mtcars |>
#' default_parsing() |> #' default_parsing() |>
#' plot_sankey("cyl", "gear", "vs", color.group = "pri") #' plot_sankey("cyl", "gear", "vs", color.group = "pri")
plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors = NULL,missing.level="Missing") { #'
#' # stRoke::trial |> plot_sankey("mrs_1", "mrs_6")
plot_sankey <- function(data,
pri,
sec,
ter = NULL,
color.group = "pri",
colors = NULL,
missing.level = "Missing") {
if (!is.null(ter)) { if (!is.null(ter)) {
ds <- split(data, data[ter]) ds <- split(data, data[ter])
} else { } else {
ds <- list(data) ds <- list(data)
} }
out <- lapply(ds, \(.ds){
plot_sankey_single(.ds, pri = pri, sec = sec, color.group = color.group, colors = colors,missing.level=missing.level) out <- lapply(ds, \(.ds) {
plot_sankey_single(
.ds,
pri = pri,
sec = sec,
color.group = color.group,
colors = colors,
missing.level = missing.level
)
}) })
patchwork::wrap_plots(out) patchwork::wrap_plots(out)
} }
#' Beautiful sankey plot #' Beautiful sankey plot
#' #'
#' @param color.group set group to colour by. "x" or "y". #' @param color.group set group to colour by. "x" or "y".
@ -7144,19 +7168,31 @@ plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors
#' stRoke::trial |> #' stRoke::trial |>
#' default_parsing() |> #' default_parsing() |>
#' plot_sankey_single("diabetes", "hypertension") #' plot_sankey_single("diabetes", "hypertension")
plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL,missing.level="Missing", ...) { plot_sankey_single <- function(data,
pri,
sec,
color.group = c("pri", "sec"),
colors = NULL,
missing.level = "Missing",
...) {
color.group <- match.arg(color.group) color.group <- match.arg(color.group)
# browser()
# if (is.na(ds[c(pri,sec)]))
# browser() # browser()
data_orig <- data data_orig <- data
data[c(pri, sec)] <- data[c(pri, sec)] |> data[c(pri, sec)] <- data[c(pri, sec)] |>
dplyr::mutate( dplyr::mutate(
# dplyr::across(dplyr::where(is.logical), as.factor), dplyr::across(dplyr::where(is.logical), as.factor),
dplyr::across(dplyr::where(is.factor), forcats::fct_drop)#, dplyr::across(dplyr::where(is.factor), forcats::fct_drop),
# dplyr::across(dplyr::where(is.factor), \(.x){forcats::fct_na_value_to_level(.x,missing.level)}) dplyr::across(dplyr::where(is.factor), \(.x) {
forcats::fct_na_value_to_level(.x, missing.level)
})
) )
data <- data |> sankey_ready(pri = pri, sec = sec, ...) data <- data |> sankey_ready(pri = pri, sec = sec, ...)
na.color <- "#2986cc" na.color <- "#2986cc"
@ -7169,21 +7205,26 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
main.colors <- main.colors[match(levels(data[[sec]]), levels(data_orig[[sec]]))] main.colors <- main.colors[match(levels(data[[sec]]), levels(data_orig[[sec]]))]
secondary.colors <- rep(na.color, length(levels(data[[pri]]))) secondary.colors <- rep(na.color, length(levels(data[[pri]])))
label.colors <- Reduce(c, lapply(list(secondary.colors, rev(main.colors)), contrast_text)) label.colors <- Reduce(c, lapply(list(
secondary.colors, rev(main.colors)
), contrast_text))
} else { } else {
main.colors <- viridisLite::viridis(n = length(levels(data_orig[[pri]]))) main.colors <- viridisLite::viridis(n = length(levels(data_orig[[pri]])))
## Only keep colors for included levels ## Only keep colors for included levels
main.colors <- main.colors[match(levels(data[[pri]]), levels(data_orig[[pri]]))] main.colors <- main.colors[match(levels(data[[pri]]), levels(data_orig[[pri]]))]
secondary.colors <- rep(na.color, length(levels(data[[sec]]))) secondary.colors <- rep(na.color, length(levels(data[[sec]])))
label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text)) label.colors <- Reduce(c, lapply(list(
rev(main.colors), secondary.colors
), contrast_text))
} }
colors <- c(na.color, main.colors, secondary.colors) colors <- c(na.color, main.colors, secondary.colors)
colors[is.na(colors)] <- "grey80"
} else { } else {
label.colors <- contrast_text(colors) label.colors <- contrast_text(colors)
} }
group_labels <- c(get_label(data, pri), get_label(data, sec)) |> group_labels <- c(get_label(data_orig, pri), get_label(data_orig, sec)) |>
sapply(line_break) |> sapply(line_break) |>
unname() unname()
@ -7202,9 +7243,8 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
knot.pos = 0.4, knot.pos = 0.4,
curve_type = "sigmoid" curve_type = "sigmoid"
) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(sec)), ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(sec)),
size = 2, size = 2,
width = 1 / 3.4 width = 1 / 3.4)
)
} else { } else {
p <- p + p <- p +
ggalluvial::geom_alluvium( ggalluvial::geom_alluvium(
@ -7217,9 +7257,8 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
knot.pos = 0.4, knot.pos = 0.4,
curve_type = "sigmoid" curve_type = "sigmoid"
) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(pri)), ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(pri)),
size = 2, size = 2,
width = 1 / 3.4 width = 1 / 3.4)
)
} }
## Will fail to use stat="stratum" if library is not loaded. ## Will fail to use stat="stratum" if library is not loaded.
@ -7229,13 +7268,10 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
stat = "stratum", stat = "stratum",
ggplot2::aes(label = after_stat(stratum)), ggplot2::aes(label = after_stat(stratum)),
colour = label.colors, colour = label.colors,
size = 8, size = 6,
lineheight = 1 lineheight = 1
) + ) +
ggplot2::scale_x_continuous( ggplot2::scale_x_continuous(breaks = 1:2, labels = group_labels) +
breaks = 1:2,
labels = group_labels
) +
ggplot2::scale_fill_manual(values = colors[-1], na.value = colors[1]) + ggplot2::scale_fill_manual(values = colors[-1], na.value = colors[1]) +
# ggplot2::scale_color_manual(values = main.colors) + # ggplot2::scale_color_manual(values = main.colors) +
ggplot2::theme_void() + ggplot2::theme_void() +
@ -10772,6 +10808,7 @@ ui_elements <- function(selection) {
## Default just output "NULL" ## Default just output "NULL"
## This could probably be achieved more legantly, but this works. ## This could probably be achieved more legantly, but this works.
dev_banner(), dev_banner(),
version_banner,
landing_page_ui(i18n = i18n), landing_page_ui(i18n = i18n),
# shiny::column(width = 2), # shiny::column(width = 2),
# shiny::column( # shiny::column(
@ -12832,33 +12869,6 @@ validation_server <- function(id,
data_r <- if (shiny::is.reactive(data)) data else shiny::reactive(data) data_r <- if (shiny::is.reactive(data)) data else shiny::reactive(data)
# observeEvent(data_r(), {
# to_validate <- data()
# valid_dims <- check_data(to_validate, n_row = n_row, n_col = n_col)
#
# if (all(c(valid_dims$nrows, valid_dims$ncols))) {
# valid_status <- "OK"
# } else {
# valid_status <- "Failed"
# }
#
# valid_results <- lapply(
# X = c("nrows", "ncols"),
# FUN = function(x) {
# if (is.null(valid_dims[[x]]))
# return(NULL)
# label <- switch(
# x,
# "nrows" = n_row_label,
# "ncols" = n_col_label
# )
# list(
# status = ifelse(valid_dims[[x]], "OK", "Failed"),
# label = paste0("<b>", label, "</b>")
# )
# }
# )
shiny::observeEvent( shiny::observeEvent(
data_r(), data_r(),
{ {
@ -13242,6 +13252,337 @@ make_validation_alerts <- function(data) {
} }
########
#### Current file: /Users/au301842/FreesearchR/R//version_check.R
########
# version_check.R
#
# Runs a one-time version check at app startup and returns a ready-made
# shinyWidgets::alert() UI element that can be placed directly in the UI
# definition -- no server(), no renderUI(), no uiOutput() required.
#
# Because the check runs outside server(), it executes once when the app
# process starts, so the banner is present immediately on first render with
# no loading delay.
#
# Version detection uses two strategies, tried in order:
# 1. utils::packageVersion() -- works when the package is installed locally.
# 2. app_version argument -- explicit fallback for environments where the
# package is not installed (e.g. shinyapps.io). Pass the result of your
# app_version() function here.
#
# Quick start:
#
# # global.R (or top of app.R, before ui / server)
# source("version_check.R")
# version_banner <- check_app_version(
# github_user = "your-github-username",
# github_repo = "your-repo-name",
# app_version = app_version() # fallback for shinyapps.io
# )
#
# # ui.R -- drop the result anywhere in the UI tree
# fluidPage(
# version_banner,
# ...
# )
#
# # Verbose / debug mode -- always show the banner:
# version_banner <- check_app_version(
# github_user = "your-github-username",
# github_repo = "your-repo-name",
# app_version = app_version(),
# verbose = TRUE
# )
# -- Internal helpers ----------------------------------------------------------
#' Check internet connectivity
#'
#' @return Logical; TRUE if an internet connection is available.
.has_internet <- function() {
tryCatch({
con <- url("https://api.github.com", open = "r")
close(con)
TRUE
}, error = function(e) FALSE)
}
#' Fetch the latest release version from a GitHub repository
#'
#' @param github_user GitHub username or organisation.
#' @param github_repo Repository name.
#'
#' @return A character string with the version tag (e.g. "1.2.0"), or NULL on
#' failure.
.get_latest_github_version <- function(github_user, github_repo) {
api_url <- sprintf(
"https://api.github.com/repos/%s/%s/releases/latest",
github_user,
github_repo
)
tryCatch({
response <- readLines(url(api_url), warn = FALSE)
json_text <- paste(response, collapse = "")
tag <- regmatches(
json_text,
regexpr('"tag_name"\\s*:\\s*"([^"]+)"', json_text)
)
if (length(tag) == 0 || nchar(tag) == 0) return(NULL)
# Strip a leading "v" if present (e.g. "v1.2.0" -> "1.2.0")
sub('^"tag_name"\\s*:\\s*"v?([^"]+)"$', "\\1", tag)
}, error = function(e) NULL)
}
#' Resolve the current app version
#'
#' Tries two strategies in order:
#' \enumerate{
#' \item \code{utils::packageVersion(package_name)} -- works when the package
#' is installed locally (development, local \code{runApp()}).
#' \item \code{app_version} argument -- an explicit version string supplied by
#' the caller, e.g. from an \code{app_version()} function bundled with the
#' app. Used on shinyapps.io where the package is not installed.
#' }
#'
#' @param package_name Name of the package / repository.
#' @param app_version Optional fallback version string.
#'
#' @return A character string with the version (e.g. "1.1.0"), or NULL if
#' neither strategy succeeds.
.resolve_app_version <- function(package_name, app_version = NULL) {
# Strategy 1: installed package
v <- tryCatch(
as.character(utils::packageVersion(package_name)),
error = function(e) NULL
)
if (!is.null(v)) {
message("[version_check] Version source: installed package")
return(v)
}
# Strategy 2: explicit fallback supplied by the caller
if (!is.null(app_version)) {
message("[version_check] Version source: app_version() fallback")
return(as.character(app_version))
}
NULL
}
#' Build a shinyWidgets::alert() UI element for the version banner
#'
#' @param current Current installed version string.
#' @param latest Latest GitHub release version string, or NULL when
#' the check could not complete (e.g. no internet).
#' @param update_available Logical; whether latest > current.
#' @param github_user GitHub username / organisation.
#' @param github_repo Repository name.
#'
#' @return A \code{shinyWidgets::alert()} UI element.
.build_version_alert <- function(current,
latest,
update_available,
github_user,
github_repo) {
repo_url <- sprintf(
"https://github.com/%s/%s/releases/latest",
github_user,
github_repo
)
if (is.null(latest)) {
# Version check could not complete (no internet or API failure)
return(
shinyWidgets::alert(
tags$b("Version check failed. "),
sprintf(
"Running version %s. Could not reach GitHub to check for updates.",
current
),
status = "warning",
dismissible = TRUE
)
)
}
if (update_available) {
shinyWidgets::alert(
tags$b("Update available! "),
sprintf(
"You are running version %s. Version %s is available on GitHub.",
current, latest
),
" ",
tags$a(href = repo_url, target = "_blank", "View release"),
status = "warning",
dismissible = TRUE
)
} else {
# Up to date -- only shown in verbose mode
shinyWidgets::alert(
tags$b("Up to date. "),
sprintf(
"You are running version %s, which matches the latest release (%s).",
current, latest
),
status = "success",
dismissible = TRUE
)
}
}
# -- Public API ----------------------------------------------------------------
#' Run a startup version check and return a banner UI element
#'
#' Call this \strong{outside} \code{server()} -- typically in
#' \code{global.R} or at the top of \code{app.R} -- and embed the returned
#' value directly in your UI definition. Because the check runs at startup
#' the banner is present on first render with no loading delay, and no
#' \code{uiOutput()} / \code{renderUI()} wiring is needed.
#'
#' \strong{Normal mode} (\code{verbose = FALSE}): returns a banner only when
#' a newer version is available or when the check fails. Returns \code{NULL}
#' when the app is up to date (Shiny silently ignores \code{NULL} in the UI).
#'
#' \strong{Verbose / debug mode} (\code{verbose = TRUE}): always returns a
#' banner -- including a success banner when up to date -- so you can confirm
#' the check ran and inspect both version strings during development.
#'
#' @param github_user GitHub username or organisation that owns the repository.
#' @param github_repo Repository name. Also used as the package name for
#' \code{utils::packageVersion()}.
#' @param app_version Optional fallback version string for environments where
#' the package is not installed (e.g. shinyapps.io). Pass the result of your
#' \code{app_version()} function here. Ignored when \code{packageVersion()}
#' succeeds.
#' @param verbose Logical; if \code{TRUE} a banner is always returned.
#' Defaults to \code{FALSE}.
#'
#' @return A \code{shinyWidgets::alert()} UI element, or \code{NULL} when there
#' is nothing to show (up to date in non-verbose mode).
#'
#' @examples
#' \dontrun{
#' # global.R or top of app.R
#' source("version_check.R")
#' version_banner <- check_app_version(
#' github_user = "my-org",
#' github_repo = "my-shiny-app",
#' app_version = app_version() # fallback for shinyapps.io
#' )
#'
#' # ui.R
#' fluidPage(
#' version_banner,
#' # ... rest of UI
#' )
#'
#' # Verbose mode for development
#' version_banner <- check_app_version(
#' github_user = "my-org",
#' github_repo = "my-shiny-app",
#' app_version = app_version(),
#' verbose = TRUE
#' )
#' }
check_app_version <- function(github_user,
github_repo,
app_version = NULL,
verbose = FALSE) {
# -- 1. Resolve current version ----------------------------------------------
local_version <- .resolve_app_version(github_repo, app_version)
if (is.null(local_version)) {
message(sprintf(
"[version_check] Could not determine version for '%s' (package not installed and no app_version() fallback supplied).",
github_repo
))
return(NULL)
}
message(sprintf("[version_check] Current version: %s", local_version))
# -- 2. Internet check -------------------------------------------------------
if (!.has_internet()) {
message("[version_check] No internet connection detected -- skipping.")
if (verbose) {
return(.build_version_alert(
current = local_version,
latest = NULL,
update_available = FALSE,
github_user = github_user,
github_repo = github_repo
))
}
return(NULL)
}
# -- 3. Fetch latest GitHub release ------------------------------------------
latest_version <- .get_latest_github_version(github_user, github_repo)
if (is.null(latest_version)) {
message("[version_check] Could not retrieve latest version from GitHub.")
if (verbose) {
return(.build_version_alert(
current = local_version,
latest = NULL,
update_available = FALSE,
github_user = github_user,
github_repo = github_repo
))
}
return(NULL)
}
message(sprintf("[version_check] Latest GitHub release: %s", latest_version))
# -- 4. Compare versions -----------------------------------------------------
update_available <- numeric_version(latest_version) > numeric_version(local_version)
if (update_available) {
message(sprintf(
"[version_check] Update available: %s -> %s",
local_version, latest_version
))
} else {
message(sprintf("[version_check] App is up to date (%s).", local_version))
}
# -- 5. Return banner --------------------------------------------------------
# An update was found -> always return a warning banner
# Up to date + verbose -> return a success banner
# Up to date + not verbose -> return NULL (Shiny ignores NULL in the UI)
if (update_available || verbose) {
.build_version_alert(
current = local_version,
latest = latest_version,
update_available = update_available,
github_user = github_user,
github_repo = github_repo
)
} else {
NULL
}
}
######## ########
#### Current file: /Users/au301842/FreesearchR/R//visual_summary.R #### Current file: /Users/au301842/FreesearchR/R//visual_summary.R
######## ########
@ -13714,6 +14055,7 @@ INCLUDE_GLOBALENV <- get_config("INCLUDE_GLOBALENV", default = FALSE)
DATA_LIMIT_DEFAULT <- get_config("DATA_LIMIT_DEFAULT", default = 10000) DATA_LIMIT_DEFAULT <- get_config("DATA_LIMIT_DEFAULT", default = 10000)
DATA_LIMIT_UPPER <- get_config("DATA_LIMIT_UPPER", default = 100000) DATA_LIMIT_UPPER <- get_config("DATA_LIMIT_UPPER", default = 100000)
DATA_LIMIT_LOWER <- get_config("DATA_LIMIT_LOWER", default = 1) DATA_LIMIT_LOWER <- get_config("DATA_LIMIT_LOWER", default = 1)
CHECK_APP_VERSION <- get_config("CHECK_APP_VERSION", default = FALSE)
## Loads folder passed to the docker container and mounted as below: ## Loads folder passed to the docker container and mounted as below:
## ##
@ -13726,6 +14068,10 @@ DATA_LIMIT_LOWER <- get_config("DATA_LIMIT_LOWER", default = 1)
## All files in the ./data/ folder is attempted loaded ## All files in the ./data/ folder is attempted loaded
load_folder() load_folder()
## App version check
version_banner <- check_app_version("agdamsbo", "FreesearchR",app_version = app_version(),verbose=CHECK_APP_VERSION)
######## ########
#### Current file: /Users/au301842/FreesearchR/app/ui.R #### Current file: /Users/au301842/FreesearchR/app/ui.R

72
man/check_app_version.Rd Normal file
View file

@ -0,0 +1,72 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/version_check.R
\name{check_app_version}
\alias{check_app_version}
\title{Run a startup version check and return a banner UI element}
\usage{
check_app_version(
github_user,
github_repo,
app_version = NULL,
verbose = FALSE
)
}
\arguments{
\item{github_user}{GitHub username or organisation that owns the repository.}
\item{github_repo}{Repository name. Also used as the package name for
\code{utils::packageVersion()}.}
\item{app_version}{Optional fallback version string for environments where
the package is not installed (e.g. shinyapps.io). Pass the result of your
\code{app_version()} function here. Ignored when \code{packageVersion()}
succeeds.}
\item{verbose}{Logical; if \code{TRUE} a banner is always returned.
Defaults to \code{FALSE}.}
}
\value{
A \code{shinyWidgets::alert()} UI element, or \code{NULL} when there
is nothing to show (up to date in non-verbose mode).
}
\description{
Call this \strong{outside} \code{server()} -- typically in
\code{global.R} or at the top of \code{app.R} -- and embed the returned
value directly in your UI definition. Because the check runs at startup
the banner is present on first render with no loading delay, and no
\code{uiOutput()} / \code{renderUI()} wiring is needed.
}
\details{
\strong{Normal mode} (\code{verbose = FALSE}): returns a banner only when
a newer version is available or when the check fails. Returns \code{NULL}
when the app is up to date (Shiny silently ignores \code{NULL} in the UI).
\strong{Verbose / debug mode} (\code{verbose = TRUE}): always returns a
banner -- including a success banner when up to date -- so you can confirm
the check ran and inspect both version strings during development.
}
\examples{
\dontrun{
# global.R or top of app.R
source("version_check.R")
version_banner <- check_app_version(
github_user = "my-org",
github_repo = "my-shiny-app",
app_version = app_version() # fallback for shinyapps.io
)
# ui.R
fluidPage(
version_banner,
# ... rest of UI
)
# Verbose mode for development
version_banner <- check_app_version(
github_user = "my-org",
github_repo = "my-shiny-app",
app_version = app_version(),
verbose = TRUE
)
}
}

View file

@ -170,6 +170,8 @@ mtcars |>
mtcars |> mtcars |>
default_parsing() |> default_parsing() |>
plot_sankey("cyl", "gear", "vs", color.group = "pri") plot_sankey("cyl", "gear", "vs", color.group = "pri")
# stRoke::trial |> plot_sankey("mrs_1", "mrs_6")
mtcars |> plot_scatter(pri = "mpg", sec = "wt") mtcars |> plot_scatter(pri = "mpg", sec = "wt")
mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear") mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear")
} }

View file

@ -0,0 +1,32 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/version_check.R
\name{.build_version_alert}
\alias{.build_version_alert}
\title{Build a shinyWidgets::alert() UI element for the version banner}
\usage{
.build_version_alert(
current,
latest,
update_available,
github_user,
github_repo
)
}
\arguments{
\item{current}{Current installed version string.}
\item{latest}{Latest GitHub release version string, or NULL when
the check could not complete (e.g. no internet).}
\item{update_available}{Logical; whether latest > current.}
\item{github_user}{GitHub username / organisation.}
\item{github_repo}{Repository name.}
}
\value{
A \code{shinyWidgets::alert()} UI element.
}
\description{
Build a shinyWidgets::alert() UI element for the version banner
}

View file

@ -0,0 +1,20 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/version_check.R
\name{.get_latest_github_version}
\alias{.get_latest_github_version}
\title{Fetch the latest release version from a GitHub repository}
\usage{
.get_latest_github_version(github_user, github_repo)
}
\arguments{
\item{github_user}{GitHub username or organisation.}
\item{github_repo}{Repository name.}
}
\value{
A character string with the version tag (e.g. "1.2.0"), or NULL on
failure.
}
\description{
Fetch the latest release version from a GitHub repository
}

14
man/dot-has_internet.Rd Normal file
View file

@ -0,0 +1,14 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/version_check.R
\name{.has_internet}
\alias{.has_internet}
\title{Check internet connectivity}
\usage{
.has_internet()
}
\value{
Logical; TRUE if an internet connection is available.
}
\description{
Check internet connectivity
}

View file

@ -0,0 +1,27 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/version_check.R
\name{.resolve_app_version}
\alias{.resolve_app_version}
\title{Resolve the current app version}
\usage{
.resolve_app_version(package_name, app_version = NULL)
}
\arguments{
\item{package_name}{Name of the package / repository.}
\item{app_version}{Optional fallback version string.}
}
\value{
A character string with the version (e.g. "1.1.0"), or NULL if
neither strategy succeeds.
}
\description{
Tries two strategies in order:
\enumerate{
\item \code{utils::packageVersion(package_name)} -- works when the package
is installed locally (development, local \code{runApp()}).
\item \code{app_version} argument -- an explicit version string supplied by
the caller, e.g. from an \code{app_version()} function bundled with the
app. Used on shinyapps.io where the package is not installed.
}
}

View file

@ -9,6 +9,7 @@ launch_FreesearchR(
data_limit_default = 1000, data_limit_default = 1000,
data_limit_upper = 1e+05, data_limit_upper = 1e+05,
data_limit_lower = 1, data_limit_lower = 1,
check_app_version = FALSE,
... ...
) )
} }
@ -22,6 +23,9 @@ when loading data}
\item{data_limit_lower}{data set observations lower limit} \item{data_limit_lower}{data set observations lower limit}
\item{check_app_version}{always attempt to check app version against latest
release on GitHub. Default is FALSE}
\item{...}{passed on to \code{shiny::runApp()}} \item{...}{passed on to \code{shiny::runApp()}}
} }
\value{ \value{