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

updating docs

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2025-04-23 14:25:38 +02:00
parent 2d0508220e
commit 7489793032
No known key found for this signature in database
9 changed files with 171 additions and 1246 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.Rbuildignore
View file

@ -12,3 +12,4 @@
^docs$ ^docs$
^pkgdown$ ^pkgdown$
^dev$ ^dev$
^data-raw$

2
R/app_version.R
View file

@ -1 +1 @@
app_version <- function()'Version: 25.4.3.250422' app_version <- function()'v25.4.3.250423'

1
_pkgdown.yml
View file

@ -8,6 +8,7 @@ template:
base_font: {google: "Montserrat"} base_font: {google: "Montserrat"}
heading_font: {google: "Public Sans"} heading_font: {google: "Public Sans"}
# code_font: {google: "Open Sans"} # code_font: {google: "Open Sans"}
# Adding the switch destroys the theme colors
light-switch: false light-switch: false
navbar: navbar:

120
inst/apps/FreesearchR/app.R
View file

@ -10,7 +10,7 @@
#### Current file: /Users/au301842/FreesearchR/R//app_version.R #### Current file: /Users/au301842/FreesearchR/R//app_version.R
######## ########
app_version <- function()'Version: 25.4.3.250422' app_version <- function()'v25.4.3.250423'
######## ########
@ -1801,7 +1801,7 @@ line_break <- function(data, lineLength = 20, force = FALSE) {
#' @export #' @export
#' #'
wrap_plot_list <- function(data, tag_levels = NULL) { wrap_plot_list <- function(data, tag_levels = NULL) {
if (ggplot2::is.ggplot(data[[1]])) { if (ggplot2::is_ggplot(data[[1]])) {
if (length(data) > 1) { if (length(data) > 1) {
out <- data |> out <- data |>
(\(.x){ (\(.x){
@ -1838,7 +1838,7 @@ wrap_plot_list <- function(data, tag_levels = NULL) {
align_axes <- function(...) { align_axes <- function(...) {
# https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object
# https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150
if (ggplot2::is.ggplot(..1)) { if (ggplot2::is_ggplot(..1)) {
## Assumes list of ggplots ## Assumes list of ggplots
p <- list(...) p <- list(...)
} else if (is.list(..1)) { } else if (is.list(..1)) {
@ -2497,7 +2497,7 @@ read_input <- function(file, consider.na = c("NA", '""', "")) {
if (ext == "csv") { if (ext == "csv") {
df <- readr::read_csv(file = file, na = consider.na) df <- readr::read_csv(file = file, na = consider.na)
} else if (ext %in% c("xls", "xlsx")) { } else if (ext %in% c("xls", "xlsx")) {
df <- openxlsx2::read_xlsx(file = file, na.strings = consider.na) df <- readxl::read_excel(file = file, na.strings = consider.na)
} else if (ext == "dta") { } else if (ext == "dta") {
df <- haven::read_dta(file = file) df <- haven::read_dta(file = file)
} else if (ext == "ods") { } else if (ext == "ods") {
@ -2838,7 +2838,7 @@ sort_by <- function(x, y, na.rm = FALSE, ...) {
get_ggplot_label <- function(data, label) { get_ggplot_label <- function(data, label) {
assertthat::assert_that(ggplot2::is.ggplot(data)) assertthat::assert_that(ggplot2::is_ggplot(data))
data$labels[[label]] data$labels[[label]]
} }
@ -3368,7 +3368,8 @@ import_file_server <- function(id,
) )
observeEvent(input$see_data, { observeEvent(input$see_data, {
tryCatch({ tryCatch(
{
datamods:::show_data(default_parsing(temporary_rv$data), title = datamods:::i18n("Imported data"), type = show_data_in) datamods:::show_data(default_parsing(temporary_rv$data), title = datamods:::i18n("Imported data"), type = show_data_in)
}, },
# warning = function(warn) { # warning = function(warn) {
@ -3382,9 +3383,10 @@ import_file_server <- function(id,
output$table <- toastui::renderDatagrid2({ output$table <- toastui::renderDatagrid2({
req(temporary_rv$data) req(temporary_rv$data)
tryCatch({ tryCatch(
{
toastui::datagrid( toastui::datagrid(
data = setNames(head(temporary_rv$data, 5),make.names(names(temporary_rv$data),unique = TRUE)), data = setNames(head(temporary_rv$data, 5), make.names(names(temporary_rv$data), unique = TRUE)),
theme = "striped", theme = "striped",
colwidths = "guess", colwidths = "guess",
minBodyHeight = 250 minBodyHeight = 250
@ -3488,13 +3490,22 @@ import_xls <- function(file, sheet, skip, na.strings) {
sheet |> sheet |>
purrr::map(\(.x){ purrr::map(\(.x){
openxlsx2::read_xlsx( readxl::read_excel(
file = file, path = file,
sheet = .x, sheet = .x,
skip_empty_rows = TRUE, na = na.strings,
start_row = skip - 1, skip = skip,
na.strings = na.strings .name_repair = "unique_quiet",
trim_ws = TRUE
) )
# openxlsx2::read_xlsx(
# file = file,
# sheet = .x,
# skip_empty_rows = TRUE,
# start_row = skip - 1,
# na.strings = na.strings
# )
}) |> }) |>
purrr::reduce(dplyr::full_join) purrr::reduce(dplyr::full_join)
}, },
@ -3738,13 +3749,14 @@ plot_box <- function(data, pri, sec, ter = NULL) {
#' @export #' @export
#' #'
#' @examples #' @examples
#' mtcars |> plot_box_single("mpg")
#' mtcars |> plot_box_single("mpg","cyl") #' mtcars |> plot_box_single("mpg","cyl")
plot_box_single <- function(data, pri, sec=NULL, seed = 2103) { plot_box_single <- function(data, pri, sec=NULL, seed = 2103) {
set.seed(seed) set.seed(seed)
if (is.null(sec)) { if (is.null(sec)) {
sec <- "All" sec <- "All"
data[[y]] <- sec data[[sec]] <- sec
} }
discrete <- !data_type(data[[sec]]) %in% "continuous" discrete <- !data_type(data[[sec]]) %in% "continuous"
@ -4075,7 +4087,7 @@ sankey_ready <- function(data, pri, sec, numbers = "count", ...) {
data[c(pri, sec)] <- data[c(pri, sec)] |> data[c(pri, sec)] <- data[c(pri, sec)] |>
dplyr::mutate(dplyr::across(!dplyr::where(is.factor), forcats::as_factor)) dplyr::mutate(dplyr::across(!dplyr::where(is.factor), forcats::as_factor))
out <- dplyr::count(data, !!dplyr::sym(pri), !!dplyr::sym(sec)) out <- dplyr::count(data, !!dplyr::sym(pri), !!dplyr::sym(sec), .drop = FALSE)
out <- out |> out <- out |>
dplyr::group_by(!!dplyr::sym(pri)) |> dplyr::group_by(!!dplyr::sym(pri)) |>
@ -4126,9 +4138,17 @@ str_remove_last <- function(data, pattern = "\n") {
#' @examples #' @examples
#' ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE))) #' ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)))
#' ds |> plot_sankey("first", "last") #' ds |> plot_sankey("first", "last")
#' ds |> plot_sankey("first", "last", color.group = "y") #' ds |> plot_sankey("first", "last", color.group = "sec")
#' ds |> plot_sankey("first", "last", z = "g", color.group = "y") #' ds |> plot_sankey("first", "last", ter = "g", color.group = "sec")
plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "x", colors = NULL) { #' mtcars |>
#' default_parsing() |>
#' plot_sankey("cyl", "gear", "am", color.group = "pri")
#' ## In this case, the last plot as the secondary variable in wrong order
#' ## Dont know why...
#' mtcars |>
#' default_parsing() |>
#' plot_sankey("cyl", "gear", "vs", color.group = "pri")
plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors = NULL) {
if (!is.null(ter)) { if (!is.null(ter)) {
ds <- split(data, data[ter]) ds <- split(data, data[ter])
} else { } else {
@ -4136,16 +4156,12 @@ plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "x", colors =
} }
out <- lapply(ds, \(.ds){ out <- lapply(ds, \(.ds){
plot_sankey_single(.ds, x = pri, y = sec, color.group = color.group, colors = colors) plot_sankey_single(.ds, pri = pri, sec = sec, color.group = color.group, colors = colors)
}) })
patchwork::wrap_plots(out) patchwork::wrap_plots(out)
} }
default_theme <- function() {
theme_void()
}
#' 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".
@ -4159,15 +4175,26 @@ default_theme <- function() {
#' @examples #' @examples
#' ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE))) #' ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)))
#' ds |> plot_sankey_single("first", "last") #' ds |> plot_sankey_single("first", "last")
#' ds |> plot_sankey_single("first", "last", color.group = "y") #' ds |> plot_sankey_single("first", "last", color.group = "sec")
#' data.frame( #' data.frame(
#' g = sample(LETTERS[1:2], 100, TRUE), #' g = sample(LETTERS[1:2], 100, TRUE),
#' first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), #' first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)),
#' last = sample(c(TRUE, FALSE, FALSE), 100, TRUE) #' last = sample(c(TRUE, FALSE, FALSE), 100, TRUE)
#' ) |> #' ) |>
#' plot_sankey_single("first", "last", color.group = "pri") #' plot_sankey_single("first", "last", color.group = "pri")
#' mtcars |>
#' default_parsing() |>
#' str()
#' plot_sankey_single("cyl", "vs", color.group = "pri")
plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL, ...) { plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL, ...) {
color.group <- match.arg(color.group) color.group <- match.arg(color.group)
data_orig <- data
data[c(pri, sec)] <- data[c(pri, sec)] |>
dplyr::mutate(dplyr::across(dplyr::where(is.factor), forcats::fct_drop))
# browser()
data <- data |> sankey_ready(pri = pri, sec = sec, ...) data <- data |> sankey_ready(pri = pri, sec = sec, ...)
library(ggalluvial) library(ggalluvial)
@ -4177,11 +4204,17 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
if (is.null(colors)) { if (is.null(colors)) {
if (color.group == "sec") { if (color.group == "sec") {
main.colors <- viridisLite::viridis(n = length(levels(data[[sec]]))) main.colors <- viridisLite::viridis(n = length(levels(data_orig[[sec]])))
## Only keep colors for included levels
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[[pri]]))) main.colors <- viridisLite::viridis(n = length(levels(data_orig[[pri]])))
## Only keep colors for included levels
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))
} }
@ -4199,7 +4232,11 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
if (color.group == "sec") { if (color.group == "sec") {
p <- p + p <- p +
ggalluvial::geom_alluvium( ggalluvial::geom_alluvium(
ggplot2::aes(fill = !!dplyr::sym(sec), color = !!dplyr::sym(sec)), ggplot2::aes(
fill = !!dplyr::sym(sec) # ,
## Including will print strings when levels are empty
# color = !!dplyr::sym(sec)
),
width = 1 / 16, width = 1 / 16,
alpha = .8, alpha = .8,
knot.pos = 0.4, knot.pos = 0.4,
@ -4211,7 +4248,10 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
} else { } else {
p <- p + p <- p +
ggalluvial::geom_alluvium( ggalluvial::geom_alluvium(
ggplot2::aes(fill = !!dplyr::sym(pri), color = !!dplyr::sym(pri)), ggplot2::aes(
fill = !!dplyr::sym(pri) # ,
# color = !!dplyr::sym(pri)
),
width = 1 / 16, width = 1 / 16,
alpha = .8, alpha = .8,
knot.pos = 0.4, knot.pos = 0.4,
@ -4235,7 +4275,7 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
labels = group_labels 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() +
ggplot2::theme( ggplot2::theme(
legend.position = "none", legend.position = "none",
@ -8399,7 +8439,7 @@ ui_elements <- list(
shiny::uiOutput(outputId = "column_filter"), shiny::uiOutput(outputId = "column_filter"),
shiny::helpText("Variable ", tags$a( shiny::helpText("Variable ", tags$a(
"data type", "data type",
href = "https://agdamsbo.github.io/FreesearchR/articles/FreesearchR.html", href = "https://agdamsbo.github.io/FreesearchR/articles/data-types.html",
target = "_blank", target = "_blank",
rel = "noopener noreferrer" rel = "noopener noreferrer"
), " filtering."), ), " filtering."),
@ -8596,15 +8636,13 @@ ui_elements <- list(
data_visuals_ui("visuals"), data_visuals_ui("visuals"),
shiny::tagList( shiny::tagList(
bslib::nav_spacer(), bslib::nav_spacer(),
bslib::nav_panel( bslib::nav_item(
title = "Notes", # shiny::img(shiny::icon("book")),
shiny::fluidRow( shiny::tags$a(
shiny::column(width = 2), href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html",
shiny::column( "Notes (external)",
width = 8, target = "_blank",
shiny::markdown(readLines("www/notes_visuals.md")), rel = "noopener noreferrer"
shiny::column(width = 2)
)
) )
) )
) )
@ -8774,11 +8812,11 @@ ui <- bslib::page_fixed(
style = "background-color: #14131326; padding: 4px; text-align: center; bottom: 0; width: 100%;", style = "background-color: #14131326; padding: 4px; text-align: center; bottom: 0; width: 100%;",
shiny::p( shiny::p(
style = "margin: 1", style = "margin: 1",
"Data is only stored for analyses and deleted immediately afterwards." "Data is only stored for analyses and deleted when the app is closed."
), ),
shiny::p( shiny::p(
style = "margin: 1; color: #888;", style = "margin: 1; color: #888;",
"AG Damsbo | v", app_version(), " | ", shiny::tags$a("AGPLv3 license", href = "https://github.com/agdamsbo/FreesearchR/blob/main/LICENSE.md", target = "_blank", rel = "noopener noreferrer"), " | ", shiny::tags$a("Source on Github", href = "https://github.com/agdamsbo/FreesearchR/", target = "_blank", rel = "noopener noreferrer") shiny::tags$a("AG Damsbo", href = "https://andreas.gdamsbo.dk/", target = "_blank", rel = "noopener noreferrer")," | ", app_version(), " | ", shiny::tags$a("License: AGPLv3", href = "https://github.com/agdamsbo/FreesearchR/blob/main/LICENSE.md", target = "_blank", rel = "noopener noreferrer"), " | ", shiny::tags$a("Source", href = "https://github.com/agdamsbo/FreesearchR/", target = "_blank", rel = "noopener noreferrer")
), ),
) )
) )

20
inst/apps/FreesearchR/ui.R
View file

@ -359,15 +359,13 @@ ui_elements <- list(
data_visuals_ui("visuals"), data_visuals_ui("visuals"),
shiny::tagList( shiny::tagList(
bslib::nav_spacer(), bslib::nav_spacer(),
bslib::nav_panel( bslib::nav_item(
title = "Notes", # shiny::img(shiny::icon("book")),
shiny::fluidRow( shiny::tags$a(
shiny::column(width = 2), href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html",
shiny::column( "Notes (external)",
width = 8, target = "_blank",
shiny::markdown(readLines("www/notes_visuals.md")), rel = "noopener noreferrer"
shiny::column(width = 2)
)
) )
) )
) )
@ -537,11 +535,11 @@ ui <- bslib::page_fixed(
style = "background-color: #14131326; padding: 4px; text-align: center; bottom: 0; width: 100%;", style = "background-color: #14131326; padding: 4px; text-align: center; bottom: 0; width: 100%;",
shiny::p( shiny::p(
style = "margin: 1", style = "margin: 1",
"Data is only stored for analyses and deleted immediately afterwards." "Data is only stored for analyses and deleted when the app is closed."
), ),
shiny::p( shiny::p(
style = "margin: 1; color: #888;", style = "margin: 1; color: #888;",
"AG Damsbo | v", app_version(), " | ", shiny::tags$a("AGPLv3 license", href = "https://github.com/agdamsbo/FreesearchR/blob/main/LICENSE.md", target = "_blank", rel = "noopener noreferrer"), " | ", shiny::tags$a("Source on Github", href = "https://github.com/agdamsbo/FreesearchR/", target = "_blank", rel = "noopener noreferrer") shiny::tags$a("AG Damsbo", href = "https://andreas.gdamsbo.dk/", target = "_blank", rel = "noopener noreferrer")," | ", app_version(), " | ", shiny::tags$a("License: AGPLv3", href = "https://github.com/agdamsbo/FreesearchR/blob/main/LICENSE.md", target = "_blank", rel = "noopener noreferrer"), " | ", shiny::tags$a("Source", href = "https://github.com/agdamsbo/FreesearchR/", target = "_blank", rel = "noopener noreferrer")
), ),
) )
) )

15
man/data-plots.Rd
View file

@ -32,7 +32,7 @@ plot_ridge(data, x, y, z = NULL, ...)
sankey_ready(data, pri, sec, numbers = "count", ...) sankey_ready(data, pri, sec, numbers = "count", ...)
plot_sankey(data, pri, sec, ter = NULL, color.group = "x", colors = NULL) plot_sankey(data, pri, sec, ter = NULL, color.group = "pri", colors = NULL)
plot_scatter(data, pri, sec, ter = NULL) plot_scatter(data, pri, sec, ter = NULL)
@ -103,6 +103,7 @@ mtcars |> plot_box(pri = "mpg", sec = "cyl", ter = "gear")
mtcars |> mtcars |>
default_parsing() |> default_parsing() |>
plot_box(pri = "mpg", sec = "cyl", ter = "gear") plot_box(pri = "mpg", sec = "cyl", ter = "gear")
mtcars |> plot_box_single("mpg")
mtcars |> plot_box_single("mpg","cyl") mtcars |> plot_box_single("mpg","cyl")
mtcars |> plot_hbars(pri = "carb", sec = "cyl") mtcars |> plot_hbars(pri = "carb", sec = "cyl")
mtcars |> plot_hbars(pri = "carb", sec = NULL) mtcars |> plot_hbars(pri = "carb", sec = NULL)
@ -121,8 +122,16 @@ data.frame(
sankey_ready("first", "last") sankey_ready("first", "last")
ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE))) ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)))
ds |> plot_sankey("first", "last") ds |> plot_sankey("first", "last")
ds |> plot_sankey("first", "last", color.group = "y") ds |> plot_sankey("first", "last", color.group = "sec")
ds |> plot_sankey("first", "last", z = "g", color.group = "y") ds |> plot_sankey("first", "last", ter = "g", color.group = "sec")
mtcars |>
default_parsing() |>
plot_sankey("cyl", "gear", "am", color.group = "pri")
## In this case, the last plot as the secondary variable in wrong order
## Dont know why...
mtcars |>
default_parsing() |>
plot_sankey("cyl", "gear", "vs", color.group = "pri")
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")
} }

1215
renv.lock
View file

File diff suppressed because it is too large Load diff

4
tests/testthat/test-data_plots.R
View file

@ -46,7 +46,7 @@ test_that("create_plot works", {
p <- p_list[[1]] + ggplot2::labs(title = "Test plot") p <- p_list[[1]] + ggplot2::labs(title = "Test plot")
expect_equal(length(p_list), 2) expect_equal(length(p_list), 2)
expect_true(ggplot2::is.ggplot(p)) expect_true(ggplot2::is_ggplot(p))
# Includes helper functions # Includes helper functions
# wrap_plot_list # wrap_plot_list
@ -60,7 +60,7 @@ test_that("create_plot works", {
) )
lapply(p_list, \(.x){ lapply(p_list, \(.x){
expect_true(ggplot2::is.ggplot(.x)) expect_true(ggplot2::is_ggplot(.x))
}) })
purrr::map2(p_list, list(11, 11), \(.x, .y){ purrr::map2(p_list, list(11, 11), \(.x, .y){

1
vignettes/data-types.Rmd
View file

@ -12,6 +12,7 @@ knitr::opts_chunk$set(
collapse = TRUE, collapse = TRUE,
comment = "#>" comment = "#>"
) )
options(rmarkdown.html_vignette.check_title = FALSE)
``` ```
```{r setup} ```{r setup}