mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2025-09-12 01:49:39 +02:00
This commit is contained in:
parent
912fff7474
commit
efc3f8acc3
23 changed files with 1385 additions and 562 deletions
|
|
@ -65,7 +65,10 @@ Imports:
|
|||
rempsyc,
|
||||
ggridges,
|
||||
ggalluvial,
|
||||
REDCapCAST
|
||||
REDCapCAST,
|
||||
eulerr,
|
||||
ggforce,
|
||||
RcppArmadillo
|
||||
Suggests:
|
||||
styler,
|
||||
devtools,
|
||||
|
|
|
|||
|
|
@ -50,11 +50,14 @@ export(m_datafileUI)
|
|||
export(m_redcap_readServer)
|
||||
export(m_redcap_readUI)
|
||||
export(merge_long)
|
||||
export(missing_fraction)
|
||||
export(modal_cut_variable)
|
||||
export(modal_update_factor)
|
||||
export(modify_qmd)
|
||||
export(outcome_type)
|
||||
export(overview_vars)
|
||||
export(plot_euler)
|
||||
export(plot_euler_single)
|
||||
export(plot_hbars)
|
||||
export(plot_ridge)
|
||||
export(plot_sankey)
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
app_version <- function()'250311_1338'
|
||||
app_version <- function()'250312_1817'
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@
|
|||
#' @param placeholder passed to \code{\link[shiny]{selectizeInput}} options
|
||||
#' @param onInitialize passed to \code{\link[shiny]{selectizeInput}} options
|
||||
#' @param none_label label for "none" item
|
||||
#' @param maxItems max number of items
|
||||
#'
|
||||
#' @return a \code{\link[shiny]{selectizeInput}} dropdown element
|
||||
#'
|
||||
|
|
@ -20,7 +21,7 @@
|
|||
#' @export
|
||||
#'
|
||||
columnSelectInput <- function(inputId, label, data, selected = "", ...,
|
||||
col_subset = NULL, placeholder = "", onInitialize, none_label="No variable selected") {
|
||||
col_subset = NULL, placeholder = "", onInitialize, none_label="No variable selected",maxItems=NULL) {
|
||||
datar <- if (is.reactive(data)) data else reactive(data)
|
||||
col_subsetr <- if (is.reactive(col_subset)) col_subset else reactive(col_subset)
|
||||
|
||||
|
|
@ -76,7 +77,8 @@ columnSelectInput <- function(inputId, label, data, selected = "", ...,
|
|||
escape(item.data.name) +
|
||||
'</div>';
|
||||
}
|
||||
}"))
|
||||
}")),
|
||||
if (!is.null(maxItems)) list(maxItems=maxItems)
|
||||
)
|
||||
)
|
||||
}
|
||||
|
|
|
|||
257
R/data_plots.R
257
R/data_plots.R
|
|
@ -128,39 +128,48 @@ data_visuals_server <- function(id,
|
|||
data = plot_data
|
||||
)
|
||||
|
||||
shiny::selectizeInput(
|
||||
plots_named <- get_plot_options(plots) |>
|
||||
lapply(\(.x){
|
||||
stats::setNames(.x$descr,.x$note)
|
||||
})
|
||||
|
||||
vectorSelectInput(
|
||||
inputId = ns("type"),
|
||||
selected = NULL,
|
||||
label = shiny::h4("Plot type"),
|
||||
choices = plots,
|
||||
choices = Reduce(c,plots_named),
|
||||
multiple = FALSE
|
||||
)
|
||||
})
|
||||
|
||||
rv$plot.params <- shiny::reactive({
|
||||
get_plot_options(input$type)
|
||||
get_plot_options(input$type) |> purrr::pluck(1)
|
||||
})
|
||||
|
||||
output$secondary <- shiny::renderUI({
|
||||
shiny::req(input$type)
|
||||
# browser()
|
||||
|
||||
columnSelectInput(
|
||||
inputId = ns("secondary"),
|
||||
data = data,
|
||||
placeholder = "Select variable",
|
||||
label = "Secondary/group variable",
|
||||
multiple = FALSE,
|
||||
col_subset = c(
|
||||
purrr::pluck(rv$plot.params(), 1)[["secondary.extra"]],
|
||||
cols <- c(
|
||||
rv$plot.params()[["secondary.extra"]],
|
||||
all_but(
|
||||
colnames(subset_types(
|
||||
data(),
|
||||
purrr::pluck(rv$plot.params(), 1)[["secondary.type"]]
|
||||
rv$plot.params()[["secondary.type"]]
|
||||
)),
|
||||
input$primary
|
||||
)
|
||||
),
|
||||
)
|
||||
|
||||
columnSelectInput(
|
||||
inputId = ns("secondary"),
|
||||
data = data,
|
||||
selected = 1,
|
||||
placeholder = "Select variable",
|
||||
label = "Secondary/group variable",
|
||||
multiple = rv$plot.params()[["secondary.multi"]],
|
||||
maxItems = rv$plot.params()[["secondary.max"]],
|
||||
col_subset = cols,
|
||||
none_label = "No variable"
|
||||
)
|
||||
})
|
||||
|
|
@ -178,7 +187,7 @@ data_visuals_server <- function(id,
|
|||
all_but(
|
||||
colnames(subset_types(
|
||||
data(),
|
||||
purrr::pluck(rv$plot.params(), 1)[["tertiary.type"]]
|
||||
rv$plot.params()[["tertiary.type"]]
|
||||
)),
|
||||
input$primary,
|
||||
input$secondary
|
||||
|
|
@ -193,9 +202,12 @@ data_visuals_server <- function(id,
|
|||
shiny::req(input$type)
|
||||
shiny::req(input$secondary)
|
||||
shiny::req(input$tertiary)
|
||||
# if (length(input$secondary)>1){
|
||||
# browser()
|
||||
# }
|
||||
create_plot(
|
||||
data = data(),
|
||||
type = names(rv$plot.params()),
|
||||
type = rv$plot.params()[["fun"]],
|
||||
x = input$primary,
|
||||
y = input$secondary,
|
||||
z = input$tertiary
|
||||
|
|
@ -291,20 +303,24 @@ subset_types <- function(data, types, type.fun = outcome_type) {
|
|||
supported_plots <- function() {
|
||||
list(
|
||||
plot_hbars = list(
|
||||
fun = "plot_hbars",
|
||||
descr = "Stacked horizontal bars",
|
||||
note = "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars",
|
||||
primary.type = c("dichotomous", "ordinal"),
|
||||
secondary.type = c("dichotomous", "ordinal"),
|
||||
secondary.multi = FALSE,
|
||||
tertiary.type = c("dichotomous", "ordinal"),
|
||||
secondary.extra = "none"
|
||||
),
|
||||
plot_violin = list(
|
||||
fun = "plot_violin",
|
||||
descr = "Violin plot",
|
||||
note = "A modern alternative to the classic boxplot to visualise data distribution",
|
||||
primary.type = c("continuous", "dichotomous", "ordinal"),
|
||||
secondary.type = c("dichotomous", "ordinal"),
|
||||
tertiary.type = c("dichotomous", "ordinal"),
|
||||
secondary.extra = "none"
|
||||
secondary.multi = FALSE,
|
||||
secondary.extra = "none",
|
||||
tertiary.type = c("dichotomous", "ordinal")
|
||||
),
|
||||
# plot_ridge = list(
|
||||
# descr = "Ridge plot",
|
||||
|
|
@ -315,25 +331,40 @@ supported_plots <- function() {
|
|||
# secondary.extra = NULL
|
||||
# ),
|
||||
plot_sankey = list(
|
||||
fun = "plot_sankey",
|
||||
descr = "Sankey plot",
|
||||
note = "A way of visualising change between groups",
|
||||
primary.type = c("dichotomous", "ordinal"),
|
||||
secondary.type = c("dichotomous", "ordinal"),
|
||||
tertiary.type = c("dichotomous", "ordinal"),
|
||||
secondary.extra = NULL
|
||||
secondary.multi = FALSE,
|
||||
secondary.extra = NULL,
|
||||
tertiary.type = c("dichotomous", "ordinal")
|
||||
),
|
||||
plot_scatter = list(
|
||||
fun = "plot_scatter",
|
||||
descr = "Scatter plot",
|
||||
note = "A classic way of showing the association between to variables",
|
||||
primary.type = "continuous",
|
||||
secondary.type = c("continuous", "ordinal"),
|
||||
secondary.multi = FALSE,
|
||||
tertiary.type = c("dichotomous", "ordinal"),
|
||||
secondary.extra = NULL
|
||||
),
|
||||
plot_euler = list(
|
||||
fun = "plot_euler",
|
||||
descr = "Euler diagram",
|
||||
note = "Generate area-proportional Euler diagrams to display set relationships",
|
||||
primary.type = "dichotomous",
|
||||
secondary.type = "dichotomous",
|
||||
secondary.multi = TRUE,
|
||||
secondary.max = 4,
|
||||
tertiary.type = c("dichotomous", "ordinal"),
|
||||
secondary.extra = NULL
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
#' Title
|
||||
#' Plot nice ridge plot
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
|
|
@ -449,7 +480,7 @@ get_plot_options <- function(data) {
|
|||
#' @examples
|
||||
#' create_plot(mtcars, "plot_violin", "mpg", "cyl")
|
||||
create_plot <- function(data, type, x, y, z = NULL, ...) {
|
||||
if (!y %in% names(data)) {
|
||||
if (!any(y %in% names(data))) {
|
||||
y <- NULL
|
||||
}
|
||||
|
||||
|
|
@ -649,63 +680,7 @@ plot_scatter <- function(data, x, y, z = NULL) {
|
|||
}
|
||||
}
|
||||
|
||||
#' Readying data for sankey plot
|
||||
#'
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @returns data.frame
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = sample(c(letters[1:4], NA), 100, TRUE, prob = c(rep(.23, 4), .08)))
|
||||
#' ds |> sankey_ready("first", "last")
|
||||
#' ds |> sankey_ready("first", "last", numbers = "percentage")
|
||||
sankey_ready <- function(data, x, y, z = NULL, numbers = "count") {
|
||||
## TODO: Ensure ordering x and y
|
||||
|
||||
if (is.null(z)) {
|
||||
out <- dplyr::count(data, !!dplyr::sym(x), !!dplyr::sym(y))
|
||||
} else {
|
||||
out <- dplyr::count(data, !!dplyr::sym(x), !!dplyr::sym(y), !!dplyr::sym(z))
|
||||
}
|
||||
out <- out |>
|
||||
dplyr::group_by(!!dplyr::sym(x)) |>
|
||||
dplyr::mutate(gx.sum = sum(n)) |>
|
||||
dplyr::ungroup() |>
|
||||
dplyr::group_by(!!dplyr::sym(y)) |>
|
||||
dplyr::mutate(gy.sum = sum(n)) |>
|
||||
dplyr::ungroup()
|
||||
|
||||
if (numbers == "count") {
|
||||
out <- out |> dplyr::mutate(
|
||||
lx = factor(paste0(!!dplyr::sym(x), "\n(n=", gx.sum, ")")),
|
||||
ly = factor(paste0(!!dplyr::sym(y), "\n(n=", gy.sum, ")"))
|
||||
)
|
||||
} else if (numbers == "percentage") {
|
||||
out <- out |> dplyr::mutate(
|
||||
lx = factor(paste0(!!dplyr::sym(x), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")),
|
||||
ly = factor(paste0(!!dplyr::sym(y), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)"))
|
||||
)
|
||||
}
|
||||
|
||||
if (is.factor(data[[x]])) {
|
||||
index <- match(levels(data[[x]]), str_remove_last(levels(out$lx), "\n"))
|
||||
out$lx <- factor(out$lx, levels = levels(out$lx)[index])
|
||||
}
|
||||
|
||||
if (is.factor(data[[y]])) {
|
||||
index <- match(levels(data[[y]]), str_remove_last(levels(out$ly), "\n"))
|
||||
out$ly <- factor(out$ly, levels = levels(out$ly)[index])
|
||||
}
|
||||
|
||||
out
|
||||
}
|
||||
|
||||
str_remove_last <- function(data, pattern = "\n") {
|
||||
strsplit(data, split = pattern) |>
|
||||
lapply(\(.x)paste(unlist(.x[[-length(.x)]]), collapse = pattern)) |>
|
||||
unlist()
|
||||
}
|
||||
|
||||
#' Line breaking at given number of characters for nicely plotting labels
|
||||
#'
|
||||
|
|
@ -729,132 +704,4 @@ line_break <- function(data, lineLength = 20, fixed = FALSE) {
|
|||
## https://stackoverflow.com/a/29847221
|
||||
}
|
||||
|
||||
#' Beautiful sankey plot with option to split by a tertiary group
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @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 |> plot_sankey("first", "last")
|
||||
#' ds |> plot_sankey("first", "last", color.group = "y")
|
||||
#' ds |> plot_sankey("first", "last", z = "g", color.group = "y")
|
||||
plot_sankey <- function(data, x, y, z = NULL, color.group = "x", colors = NULL) {
|
||||
if (!is.null(z)) {
|
||||
ds <- split(data, data[z])
|
||||
} else {
|
||||
ds <- list(data)
|
||||
}
|
||||
|
||||
out <- lapply(ds, \(.ds){
|
||||
plot_sankey_single(.ds, x = x, y = y, color.group = color.group, colors = colors)
|
||||
})
|
||||
|
||||
patchwork::wrap_plots(out)
|
||||
}
|
||||
|
||||
default_theme <- function() {
|
||||
theme_void()
|
||||
}
|
||||
|
||||
#' Beautiful sankey plot
|
||||
#'
|
||||
#' @param color.group set group to colour by. "x" or "y".
|
||||
#' @param colors optinally specify colors. Give NA color, color for each level
|
||||
#' in primary group and color for each level in secondary group.
|
||||
#' @param ... passed to sankey_ready()
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @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 |> plot_sankey_single("first", "last")
|
||||
#' ds |> plot_sankey_single("first", "last", color.group = "y")
|
||||
plot_sankey_single <- function(data, x, y, color.group = c("x","y"), colors = NULL, ...) {
|
||||
color.group <- match.arg(color.group)
|
||||
data <- data |> sankey_ready(x = x, y = y, ...)
|
||||
# browser()
|
||||
library(ggalluvial)
|
||||
|
||||
na.color <- "#2986cc"
|
||||
box.color <- "#1E4B66"
|
||||
|
||||
if (is.null(colors)) {
|
||||
if (color.group == "y") {
|
||||
main.colors <- viridisLite::viridis(n = length(levels(data[[y]])))
|
||||
secondary.colors <- rep(na.color, length(levels(data[[x]])))
|
||||
label.colors <- Reduce(c, lapply(list(secondary.colors, rev(main.colors)), contrast_text))
|
||||
} else {
|
||||
main.colors <- viridisLite::viridis(n = length(levels(data[[x]])))
|
||||
secondary.colors <- rep(na.color, length(levels(data[[y]])))
|
||||
label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text))
|
||||
}
|
||||
colors <- c(na.color, main.colors, secondary.colors)
|
||||
} else {
|
||||
label.colors <- contrast_text(colors)
|
||||
}
|
||||
|
||||
group_labels <- c(get_label(data, x), get_label(data, y)) |>
|
||||
sapply(line_break) |>
|
||||
unname()
|
||||
|
||||
p <- ggplot2::ggplot(data, ggplot2::aes(y = n, axis1 = lx, axis2 = ly))
|
||||
|
||||
if (color.group == "y") {
|
||||
p <- p +
|
||||
ggalluvial::geom_alluvium(
|
||||
ggplot2::aes(fill = !!dplyr::sym(y), color = !!dplyr::sym(y)),
|
||||
width = 1 / 16,
|
||||
alpha = .8,
|
||||
knot.pos = 0.4,
|
||||
curve_type = "sigmoid"
|
||||
) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(y)),
|
||||
size = 2,
|
||||
width = 1 / 3.4
|
||||
)
|
||||
} else {
|
||||
p <- p +
|
||||
ggalluvial::geom_alluvium(
|
||||
ggplot2::aes(fill = !!dplyr::sym(x), color = !!dplyr::sym(x)),
|
||||
width = 1 / 16,
|
||||
alpha = .8,
|
||||
knot.pos = 0.4,
|
||||
curve_type = "sigmoid"
|
||||
) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(x)),
|
||||
size = 2,
|
||||
width = 1 / 3.4
|
||||
)
|
||||
}
|
||||
|
||||
p +
|
||||
ggplot2::geom_text(
|
||||
stat = "stratum",
|
||||
ggplot2::aes(label = after_stat(stratum)),
|
||||
colour = label.colors,
|
||||
size = 8,
|
||||
lineheight = 1
|
||||
) +
|
||||
ggplot2::scale_x_continuous(
|
||||
breaks = 1:2,
|
||||
labels = group_labels
|
||||
) +
|
||||
ggplot2::scale_fill_manual(values = colors[-1], na.value = colors[1]) +
|
||||
ggplot2::scale_color_manual(values = main.colors) +
|
||||
ggplot2::theme_void() +
|
||||
ggplot2::theme(
|
||||
legend.position = "none",
|
||||
# panel.grid.major = element_blank(),
|
||||
# panel.grid.minor = element_blank(),
|
||||
# axis.text.y = element_blank(),
|
||||
# axis.title.y = element_blank(),
|
||||
axis.text.x = ggplot2::element_text(size = 20),
|
||||
# text = element_text(size = 5),
|
||||
# plot.title = element_blank(),
|
||||
# panel.background = ggplot2::element_rect(fill = "white"),
|
||||
plot.background = ggplot2::element_rect(fill = "white"),
|
||||
panel.border = ggplot2::element_blank()
|
||||
)
|
||||
}
|
||||
|
|
|
|||
14
R/helpers.R
14
R/helpers.R
|
|
@ -292,3 +292,17 @@ append_list <- function(data,list,index){
|
|||
}
|
||||
out
|
||||
}
|
||||
|
||||
|
||||
#' Get missingsness fraction
|
||||
#'
|
||||
#' @param data data
|
||||
#'
|
||||
#' @returns numeric vector
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' c(NA,1:10,rep(NA,3)) |> missing_fraction()
|
||||
missing_fraction <- function(data){
|
||||
NROW(data[is.na(data)])/NROW(data)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -17,7 +17,6 @@
|
|||
#' @importFrom phosphoricons ph
|
||||
#' @importFrom toastui datagridOutput2
|
||||
#'
|
||||
#' @example examples/from-file.R
|
||||
import_file_ui <- function(id,
|
||||
title = TRUE,
|
||||
preview_data = TRUE,
|
||||
|
|
|
|||
130
R/plot_euler.R
Normal file
130
R/plot_euler.R
Normal file
|
|
@ -0,0 +1,130 @@
|
|||
#' Area proportional venn diagrams
|
||||
#'
|
||||
#' @description
|
||||
#' THis is slightly modified from https://gist.github.com/danlooo/d23d8bcf8856c7dd8e86266097404ded
|
||||
#'
|
||||
#' This functions uses eulerr::euler to plot area proportional venn diagramms
|
||||
#' but plots it using ggplot2
|
||||
#'
|
||||
#' @param combinations set relationships as a named numeric vector, matrix, or
|
||||
#' data.frame(See `eulerr::euler`)
|
||||
#' @param show_quantities whether to show number of intersecting elements
|
||||
#' @param show_labels whether to show set names
|
||||
#' @param ... further arguments passed to eulerr::euler
|
||||
ggeulerr <- function(
|
||||
combinations,
|
||||
show_quantities = TRUE,
|
||||
show_labels = TRUE,
|
||||
...) {
|
||||
# browser()
|
||||
data <-
|
||||
eulerr::euler(combinations = combinations, ...) |>
|
||||
plot(quantities = show_quantities) |>
|
||||
purrr::pluck("data")
|
||||
|
||||
|
||||
tibble::as_tibble(data$ellipses, rownames = "Variables") |>
|
||||
ggplot2::ggplot() +
|
||||
ggforce::geom_ellipse(
|
||||
mapping = ggplot2::aes(
|
||||
x0 = h, y0 = k, a = a, b = b, angle = 0, fill = Variables
|
||||
),
|
||||
alpha = 0.5,
|
||||
linewidth = 1.5
|
||||
) +
|
||||
ggplot2::geom_text(
|
||||
data = {
|
||||
data$centers |>
|
||||
dplyr::mutate(
|
||||
label = labels |> purrr::map2(quantities, ~ {
|
||||
if (!is.na(.x) && !is.na(.y) && show_labels) {
|
||||
paste0(.x, "\n", sprintf(.y, fmt = "%.2g"))
|
||||
} else if (!is.na(.x) && show_labels) {
|
||||
.x
|
||||
} else if (!is.na(.y)) {
|
||||
.y
|
||||
} else {
|
||||
""
|
||||
}
|
||||
})
|
||||
)
|
||||
},
|
||||
mapping = ggplot2::aes(x = x, y = y, label = label),
|
||||
size = 8
|
||||
) +
|
||||
ggplot2::theme(panel.grid = ggplot2::element_blank()) +
|
||||
ggplot2::coord_fixed() +
|
||||
ggplot2::scale_fill_hue()
|
||||
}
|
||||
|
||||
#' Easily plot euler diagrams
|
||||
#'
|
||||
#' @param data data
|
||||
#' @param x name of main variable
|
||||
#' @param y name of secondary variables
|
||||
#' @param z grouping variable
|
||||
#' @param seed seed
|
||||
#'
|
||||
#' @returns patchwork object
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' data.frame(
|
||||
#' A = sample(c(TRUE, TRUE, FALSE), 50, TRUE),
|
||||
#' B = sample(c("A", "C"), 50, TRUE),
|
||||
#' C = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE),
|
||||
#' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE)
|
||||
#' ) |> plot_euler("A", c("B", "C"), "D", seed = 4)
|
||||
#' mtcars |> plot_euler("vs", "am", seed = 1)
|
||||
plot_euler <- function(data, x, y, z = NULL, seed = 2103) {
|
||||
set.seed(seed = seed)
|
||||
|
||||
# data <- data[c(...,z)]
|
||||
|
||||
if (!is.null(z)) {
|
||||
ds <- split(data, data[z])
|
||||
} else {
|
||||
ds <- list(data)
|
||||
}
|
||||
|
||||
out <- lapply(ds, \(.x){
|
||||
.x[c(x, y)] |>
|
||||
as.data.frame() |>
|
||||
plot_euler_single()
|
||||
})
|
||||
|
||||
patchwork::wrap_plots(out, guides = "collect")
|
||||
}
|
||||
|
||||
|
||||
#' Easily plot single euler diagrams
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' data.frame(
|
||||
#' A = sample(c(TRUE, TRUE, FALSE), 50, TRUE),
|
||||
#' B = sample(c("A", "C"), 50, TRUE),
|
||||
#' C = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE),
|
||||
#' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE)
|
||||
#' ) |> plot_euler_single()
|
||||
#' mtcars[c("vs", "am")] |> plot_euler_single()
|
||||
plot_euler_single <- function(data) {
|
||||
data |>
|
||||
ggeulerr(shape = "circle") +
|
||||
ggplot2::theme_void() +
|
||||
ggplot2::theme(
|
||||
legend.position = "right",
|
||||
# panel.grid.major = element_blank(),
|
||||
# panel.grid.minor = element_blank(),
|
||||
# axis.text.y = element_blank(),
|
||||
# axis.title.y = element_blank(),
|
||||
text = ggplot2::element_text(size = 20),
|
||||
axis.text = ggplot2::element_blank(),
|
||||
# plot.title = element_blank(),
|
||||
# panel.background = ggplot2::element_rect(fill = "white"),
|
||||
plot.background = ggplot2::element_rect(fill = "white"),
|
||||
panel.border = ggplot2::element_blank()
|
||||
)
|
||||
}
|
||||
200
R/plot_sankey.R
Normal file
200
R/plot_sankey.R
Normal file
|
|
@ -0,0 +1,200 @@
|
|||
#' Readying data for sankey plot
|
||||
#'
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @returns data.frame
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = sample(c(letters[1:4], NA), 100, TRUE, prob = c(rep(.23, 4), .08)))
|
||||
#' ds |> sankey_ready("first", "last")
|
||||
#' ds |> sankey_ready("first", "last", numbers = "percentage")
|
||||
#' data.frame(
|
||||
#' g = sample(LETTERS[1:2], 100, TRUE),
|
||||
#' first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)),
|
||||
#' last = sample(c(TRUE, FALSE, FALSE), 100, TRUE)
|
||||
#' ) |>
|
||||
#' sankey_ready("first", "last")
|
||||
sankey_ready <- function(data, x, y, numbers = "count", ...) {
|
||||
## TODO: Ensure ordering x and y
|
||||
|
||||
## Ensure all are factors
|
||||
data[c(x, y)] <- data[c(x, y)] |>
|
||||
dplyr::mutate(dplyr::across(!dplyr::where(is.factor), forcats::as_factor))
|
||||
|
||||
out <- dplyr::count(data, !!dplyr::sym(x), !!dplyr::sym(y))
|
||||
|
||||
out <- out |>
|
||||
dplyr::group_by(!!dplyr::sym(x)) |>
|
||||
dplyr::mutate(gx.sum = sum(n)) |>
|
||||
dplyr::ungroup() |>
|
||||
dplyr::group_by(!!dplyr::sym(y)) |>
|
||||
dplyr::mutate(gy.sum = sum(n)) |>
|
||||
dplyr::ungroup()
|
||||
|
||||
if (numbers == "count") {
|
||||
out <- out |> dplyr::mutate(
|
||||
lx = factor(paste0(!!dplyr::sym(x), "\n(n=", gx.sum, ")")),
|
||||
ly = factor(paste0(!!dplyr::sym(y), "\n(n=", gy.sum, ")"))
|
||||
)
|
||||
} else if (numbers == "percentage") {
|
||||
out <- out |> dplyr::mutate(
|
||||
lx = factor(paste0(!!dplyr::sym(x), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")),
|
||||
ly = factor(paste0(!!dplyr::sym(y), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)"))
|
||||
)
|
||||
}
|
||||
|
||||
if (is.factor(data[[x]])) {
|
||||
index <- match(levels(data[[x]]), str_remove_last(levels(out$lx), "\n"))
|
||||
out$lx <- factor(out$lx, levels = levels(out$lx)[index])
|
||||
}
|
||||
|
||||
if (is.factor(data[[y]])) {
|
||||
index <- match(levels(data[[y]]), str_remove_last(levels(out$ly), "\n"))
|
||||
out$ly <- factor(out$ly, levels = levels(out$ly)[index])
|
||||
}
|
||||
|
||||
out
|
||||
}
|
||||
|
||||
str_remove_last <- function(data, pattern = "\n") {
|
||||
strsplit(data, split = pattern) |>
|
||||
lapply(\(.x)paste(unlist(.x[[-length(.x)]]), collapse = pattern)) |>
|
||||
unlist()
|
||||
}
|
||||
|
||||
#' Beautiful sankey plot with option to split by a tertiary group
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @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 |> plot_sankey("first", "last")
|
||||
#' ds |> plot_sankey("first", "last", color.group = "y")
|
||||
#' ds |> plot_sankey("first", "last", z = "g", color.group = "y")
|
||||
plot_sankey <- function(data, x, y, z = NULL, color.group = "x", colors = NULL) {
|
||||
if (!is.null(z)) {
|
||||
ds <- split(data, data[z])
|
||||
} else {
|
||||
ds <- list(data)
|
||||
}
|
||||
|
||||
out <- lapply(ds, \(.ds){
|
||||
plot_sankey_single(.ds, x = x, y = y, color.group = color.group, colors = colors)
|
||||
})
|
||||
|
||||
patchwork::wrap_plots(out)
|
||||
}
|
||||
|
||||
default_theme <- function() {
|
||||
theme_void()
|
||||
}
|
||||
|
||||
#' Beautiful sankey plot
|
||||
#'
|
||||
#' @param color.group set group to colour by. "x" or "y".
|
||||
#' @param colors optinally specify colors. Give NA color, color for each level
|
||||
#' in primary group and color for each level in secondary group.
|
||||
#' @param ... passed to sankey_ready()
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @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 |> plot_sankey_single("first", "last")
|
||||
#' ds |> plot_sankey_single("first", "last", color.group = "y")
|
||||
#' data.frame(
|
||||
#' g = sample(LETTERS[1:2], 100, TRUE),
|
||||
#' first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)),
|
||||
#' last = sample(c(TRUE, FALSE, FALSE), 100, TRUE)
|
||||
#' ) |>
|
||||
#' plot_sankey_single("first", "last", color.group = "x")
|
||||
plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = NULL, ...) {
|
||||
color.group <- match.arg(color.group)
|
||||
data <- data |> sankey_ready(x = x, y = y, ...)
|
||||
|
||||
library(ggalluvial)
|
||||
|
||||
na.color <- "#2986cc"
|
||||
box.color <- "#1E4B66"
|
||||
|
||||
if (is.null(colors)) {
|
||||
if (color.group == "y") {
|
||||
main.colors <- viridisLite::viridis(n = length(levels(data[[y]])))
|
||||
secondary.colors <- rep(na.color, length(levels(data[[x]])))
|
||||
label.colors <- Reduce(c, lapply(list(secondary.colors, rev(main.colors)), contrast_text))
|
||||
} else {
|
||||
main.colors <- viridisLite::viridis(n = length(levels(data[[x]])))
|
||||
secondary.colors <- rep(na.color, length(levels(data[[y]])))
|
||||
label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text))
|
||||
}
|
||||
colors <- c(na.color, main.colors, secondary.colors)
|
||||
} else {
|
||||
label.colors <- contrast_text(colors)
|
||||
}
|
||||
|
||||
group_labels <- c(get_label(data, x), get_label(data, y)) |>
|
||||
sapply(line_break) |>
|
||||
unname()
|
||||
|
||||
p <- ggplot2::ggplot(data, ggplot2::aes(y = n, axis1 = lx, axis2 = ly))
|
||||
|
||||
if (color.group == "y") {
|
||||
p <- p +
|
||||
ggalluvial::geom_alluvium(
|
||||
ggplot2::aes(fill = !!dplyr::sym(y), color = !!dplyr::sym(y)),
|
||||
width = 1 / 16,
|
||||
alpha = .8,
|
||||
knot.pos = 0.4,
|
||||
curve_type = "sigmoid"
|
||||
) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(y)),
|
||||
size = 2,
|
||||
width = 1 / 3.4
|
||||
)
|
||||
} else {
|
||||
p <- p +
|
||||
ggalluvial::geom_alluvium(
|
||||
ggplot2::aes(fill = !!dplyr::sym(x), color = !!dplyr::sym(x)),
|
||||
width = 1 / 16,
|
||||
alpha = .8,
|
||||
knot.pos = 0.4,
|
||||
curve_type = "sigmoid"
|
||||
) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(x)),
|
||||
size = 2,
|
||||
width = 1 / 3.4
|
||||
)
|
||||
}
|
||||
|
||||
p +
|
||||
ggplot2::geom_text(
|
||||
stat = "stratum",
|
||||
ggplot2::aes(label = after_stat(stratum)),
|
||||
colour = label.colors,
|
||||
size = 8,
|
||||
lineheight = 1
|
||||
) +
|
||||
ggplot2::scale_x_continuous(
|
||||
breaks = 1:2,
|
||||
labels = group_labels
|
||||
) +
|
||||
ggplot2::scale_fill_manual(values = colors[-1], na.value = colors[1]) +
|
||||
ggplot2::scale_color_manual(values = main.colors) +
|
||||
ggplot2::theme_void() +
|
||||
ggplot2::theme(
|
||||
legend.position = "none",
|
||||
# panel.grid.major = element_blank(),
|
||||
# panel.grid.minor = element_blank(),
|
||||
# axis.text.y = element_blank(),
|
||||
# axis.title.y = element_blank(),
|
||||
axis.text.x = ggplot2::element_text(size = 20),
|
||||
# text = element_text(size = 5),
|
||||
# plot.title = element_blank(),
|
||||
# panel.background = ggplot2::element_rect(fill = "white"),
|
||||
plot.background = ggplot2::element_rect(fill = "white"),
|
||||
panel.border = ggplot2::element_blank()
|
||||
)
|
||||
}
|
||||
|
|
@ -256,8 +256,8 @@ outcome_type <- function(data) {
|
|||
cl_d <- class(data)
|
||||
if (any(c("numeric", "integer") %in% cl_d)) {
|
||||
out <- "continuous"
|
||||
} else if (identical("factor", cl_d)) {
|
||||
if (length(levels(data)) == 2) {
|
||||
} else if (any(c("factor", "logical") %in% cl_d)) {
|
||||
if (length(levels(data)) == 2 | identical("logical",cl_d)) {
|
||||
out <- "dichotomous"
|
||||
} else if (length(levels(data)) > 2) {
|
||||
out <- "ordinal"
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -5,6 +5,6 @@ account: agdamsbo
|
|||
server: shinyapps.io
|
||||
hostUrl: https://api.shinyapps.io/v1
|
||||
appId: 13611288
|
||||
bundleId: 9925506
|
||||
bundleId: 9932726
|
||||
url: https://agdamsbo.shinyapps.io/freesearcheR/
|
||||
version: 1
|
||||
|
|
|
|||
|
|
@ -80,6 +80,7 @@ server <- function(input, output, session) {
|
|||
ready = NULL,
|
||||
test = "no",
|
||||
data_original = NULL,
|
||||
data_temp = NULL,
|
||||
data = NULL,
|
||||
data_filtered = NULL,
|
||||
models = NULL,
|
||||
|
|
@ -140,19 +141,21 @@ server <- function(input, output, session) {
|
|||
sheet = sheet,
|
||||
skip_empty_rows = TRUE,
|
||||
start_row = skip - 1,
|
||||
na.strings = na)
|
||||
na.strings = na
|
||||
)
|
||||
},
|
||||
rds = function(file) {
|
||||
readr::read_rds(
|
||||
file = file,
|
||||
name_repair = "unique_quiet")
|
||||
name_repair = "unique_quiet"
|
||||
)
|
||||
}
|
||||
)
|
||||
)
|
||||
|
||||
shiny::observeEvent(data_file$data(), {
|
||||
shiny::req(data_file$data())
|
||||
rv$data_original <- data_file$data()
|
||||
rv$data_temp <- data_file$data()
|
||||
rv$code <- append_list(data = data_file$code(), list = rv$code, index = "import")
|
||||
})
|
||||
|
||||
|
|
@ -163,7 +166,7 @@ server <- function(input, output, session) {
|
|||
|
||||
shiny::observeEvent(data_redcap(), {
|
||||
# rv$data_original <- purrr::pluck(data_redcap(), "data")()
|
||||
rv$data_original <- data_redcap()
|
||||
rv$data_temp <- data_redcap()
|
||||
})
|
||||
|
||||
output$redcap_prev <- DT::renderDT(
|
||||
|
|
@ -185,10 +188,44 @@ server <- function(input, output, session) {
|
|||
|
||||
shiny::observeEvent(from_env$data(), {
|
||||
shiny::req(from_env$data())
|
||||
rv$data_original <- from_env$data()
|
||||
|
||||
rv$data_temp <- from_env$data()
|
||||
# rv$code <- append_list(data = from_env$code(),list = rv$code,index = "import")
|
||||
})
|
||||
|
||||
output$import_var <- shiny::renderUI({
|
||||
shiny::req(rv$data_temp)
|
||||
|
||||
preselect <- names(rv$data_temp)[sapply(rv$data_temp, missing_fraction) <= input$complete_cutoff / 100]
|
||||
|
||||
shinyWidgets::virtualSelectInput(
|
||||
inputId = "import_var",
|
||||
label = "Select variables to include",
|
||||
selected = preselect,
|
||||
choices = names(rv$data_temp),
|
||||
updateOn = "close",
|
||||
multiple = TRUE,
|
||||
search = TRUE,
|
||||
showValueAsTags = TRUE
|
||||
)
|
||||
})
|
||||
|
||||
|
||||
shiny::observeEvent(
|
||||
eventExpr = list(
|
||||
input$import_var
|
||||
),
|
||||
handlerExpr = {
|
||||
shiny::req(rv$data_temp)
|
||||
|
||||
rv$data_original <- rv$data_temp |>
|
||||
dplyr::select(input$import_var) |>
|
||||
# janitor::clean_names() |>
|
||||
default_parsing()
|
||||
}
|
||||
)
|
||||
|
||||
|
||||
shiny::observeEvent(rv$data_original, {
|
||||
if (is.null(rv$data_original) | NROW(rv$data_original) == 0) {
|
||||
shiny::updateActionButton(inputId = "act_start", disabled = TRUE)
|
||||
|
|
@ -211,26 +248,20 @@ server <- function(input, output, session) {
|
|||
handlerExpr = {
|
||||
shiny::req(rv$data_original)
|
||||
|
||||
rv$data <- rv$data_original |>
|
||||
# janitor::clean_names() |>
|
||||
default_parsing() |>
|
||||
remove_empty_cols(
|
||||
cutoff = input$complete_cutoff / 100
|
||||
)
|
||||
rv$data <- rv$data_original
|
||||
}
|
||||
)
|
||||
|
||||
## For now this solution work, but I would prefer to solve this with the above
|
||||
shiny::observeEvent(input$reset_confirm, {
|
||||
shiny::observeEvent(input$reset_confirm,
|
||||
{
|
||||
if (isTRUE(input$reset_confirm)) {
|
||||
shiny::req(rv$data_original)
|
||||
rv$data <- rv$data_original |>
|
||||
default_parsing() |>
|
||||
remove_empty_cols(
|
||||
cutoff = input$complete_cutoff / 100
|
||||
)
|
||||
rv$data <- rv$data_original
|
||||
}
|
||||
}, ignoreNULL = TRUE)
|
||||
},
|
||||
ignoreNULL = TRUE
|
||||
)
|
||||
|
||||
|
||||
shiny::observeEvent(input$data_reset, {
|
||||
|
|
|
|||
|
|
@ -67,13 +67,13 @@ ui_elements <- list(
|
|||
),
|
||||
shiny::br(),
|
||||
shiny::br(),
|
||||
shiny::h5("Exclude in-complete variables"),
|
||||
shiny::h5("Specify variables to include"),
|
||||
shiny::fluidRow(
|
||||
shiny::column(
|
||||
width = 6,
|
||||
shiny::br(),
|
||||
shiny::p("Filter by completeness threshold and manual selection:"),
|
||||
shiny::br(),
|
||||
shiny::p("Filter incomplete variables, by setting a completeness threshold:"),
|
||||
shiny::br()
|
||||
),
|
||||
shiny::column(
|
||||
|
|
@ -88,7 +88,10 @@ ui_elements <- list(
|
|||
format = shinyWidgets::wNumbFormat(decimals = 0),
|
||||
color = datamods:::get_primary_color()
|
||||
),
|
||||
shiny::helpText("Include variables with completeness above the specified percentage.")
|
||||
shiny::helpText("Filter variables with completeness above the specified percentage."),
|
||||
shiny::br(),
|
||||
shiny::br(),
|
||||
shiny::uiOutput(outputId = "import_var")
|
||||
)
|
||||
),
|
||||
shiny::br(),
|
||||
|
|
|
|||
|
|
@ -13,7 +13,8 @@ columnSelectInput(
|
|||
col_subset = NULL,
|
||||
placeholder = "",
|
||||
onInitialize,
|
||||
none_label = "No variable selected"
|
||||
none_label = "No variable selected",
|
||||
maxItems = NULL
|
||||
)
|
||||
}
|
||||
\arguments{
|
||||
|
|
@ -34,6 +35,8 @@ columnSelectInput(
|
|||
\item{onInitialize}{passed to \code{\link[shiny]{selectizeInput}} options}
|
||||
|
||||
\item{none_label}{label for "none" item}
|
||||
|
||||
\item{maxItems}{max number of items}
|
||||
}
|
||||
\value{
|
||||
a \code{\link[shiny]{selectizeInput}} dropdown element
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/data_plots.R
|
||||
% Please edit documentation in R/data_plots.R, R/plot_sankey.R
|
||||
\name{data-plots}
|
||||
\alias{data-plots}
|
||||
\alias{plot_ridge}
|
||||
|
|
@ -9,7 +9,7 @@
|
|||
\alias{plot_scatter}
|
||||
\alias{sankey_ready}
|
||||
\alias{plot_sankey}
|
||||
\title{Title}
|
||||
\title{Plot nice ridge plot}
|
||||
\usage{
|
||||
plot_ridge(data, x, y, z = NULL, ...)
|
||||
|
||||
|
|
@ -21,7 +21,7 @@ plot_violin(data, x, y, z = NULL)
|
|||
|
||||
plot_scatter(data, x, y, z = NULL)
|
||||
|
||||
sankey_ready(data, x, y, z = NULL, numbers = "count")
|
||||
sankey_ready(data, x, y, numbers = "count", ...)
|
||||
|
||||
plot_sankey(data, x, y, z = NULL, color.group = "x", colors = NULL)
|
||||
}
|
||||
|
|
@ -54,7 +54,7 @@ data.frame
|
|||
ggplot2 object
|
||||
}
|
||||
\description{
|
||||
Title
|
||||
Plot nice ridge plot
|
||||
|
||||
Wrapper to create plot based on provided type
|
||||
|
||||
|
|
@ -81,6 +81,12 @@ mtcars |> plot_scatter(x = "mpg", y = "wt")
|
|||
ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = sample(c(letters[1:4], NA), 100, TRUE, prob = c(rep(.23, 4), .08)))
|
||||
ds |> sankey_ready("first", "last")
|
||||
ds |> sankey_ready("first", "last", numbers = "percentage")
|
||||
data.frame(
|
||||
g = sample(LETTERS[1:2], 100, TRUE),
|
||||
first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)),
|
||||
last = sample(c(TRUE, FALSE, FALSE), 100, TRUE)
|
||||
) |>
|
||||
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 |> plot_sankey("first", "last")
|
||||
ds |> plot_sankey("first", "last", color.group = "y")
|
||||
|
|
|
|||
24
man/ggeulerr.Rd
Normal file
24
man/ggeulerr.Rd
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/plot_euler.R
|
||||
\name{ggeulerr}
|
||||
\alias{ggeulerr}
|
||||
\title{Area proportional venn diagrams}
|
||||
\usage{
|
||||
ggeulerr(combinations, show_quantities = TRUE, show_labels = TRUE, ...)
|
||||
}
|
||||
\arguments{
|
||||
\item{combinations}{set relationships as a named numeric vector, matrix, or
|
||||
data.frame(See \code{eulerr::euler})}
|
||||
|
||||
\item{show_quantities}{whether to show number of intersecting elements}
|
||||
|
||||
\item{show_labels}{whether to show set names}
|
||||
|
||||
\item{...}{further arguments passed to eulerr::euler}
|
||||
}
|
||||
\description{
|
||||
THis is slightly modified from https://gist.github.com/danlooo/d23d8bcf8856c7dd8e86266097404ded
|
||||
|
||||
This functions uses eulerr::euler to plot area proportional venn diagramms
|
||||
but plots it using ggplot2
|
||||
}
|
||||
20
man/missing_fraction.Rd
Normal file
20
man/missing_fraction.Rd
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/helpers.R
|
||||
\name{missing_fraction}
|
||||
\alias{missing_fraction}
|
||||
\title{Get missingsness fraction}
|
||||
\usage{
|
||||
missing_fraction(data)
|
||||
}
|
||||
\arguments{
|
||||
\item{data}{data}
|
||||
}
|
||||
\value{
|
||||
numeric vector
|
||||
}
|
||||
\description{
|
||||
Get missingsness fraction
|
||||
}
|
||||
\examples{
|
||||
c(NA,1:10,rep(NA,3)) |> missing_fraction()
|
||||
}
|
||||
34
man/plot_euler.Rd
Normal file
34
man/plot_euler.Rd
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/plot_euler.R
|
||||
\name{plot_euler}
|
||||
\alias{plot_euler}
|
||||
\title{Easily plot euler diagrams}
|
||||
\usage{
|
||||
plot_euler(data, x, y, z = NULL, seed = 2103)
|
||||
}
|
||||
\arguments{
|
||||
\item{data}{data}
|
||||
|
||||
\item{x}{name of main variable}
|
||||
|
||||
\item{y}{name of secondary variables}
|
||||
|
||||
\item{z}{grouping variable}
|
||||
|
||||
\item{seed}{seed}
|
||||
}
|
||||
\value{
|
||||
patchwork object
|
||||
}
|
||||
\description{
|
||||
Easily plot euler diagrams
|
||||
}
|
||||
\examples{
|
||||
data.frame(
|
||||
A = sample(c(TRUE, TRUE, FALSE), 50, TRUE),
|
||||
B = sample(c("A", "C"), 50, TRUE),
|
||||
C = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE),
|
||||
D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE)
|
||||
) |> plot_euler("A", c("B", "C"), "D", seed = 4)
|
||||
mtcars |> plot_euler("vs", "am", seed = 1)
|
||||
}
|
||||
23
man/plot_euler_single.Rd
Normal file
23
man/plot_euler_single.Rd
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/plot_euler.R
|
||||
\name{plot_euler_single}
|
||||
\alias{plot_euler_single}
|
||||
\title{Easily plot single euler diagrams}
|
||||
\usage{
|
||||
plot_euler_single(data)
|
||||
}
|
||||
\value{
|
||||
ggplot2 object
|
||||
}
|
||||
\description{
|
||||
Easily plot single euler diagrams
|
||||
}
|
||||
\examples{
|
||||
data.frame(
|
||||
A = sample(c(TRUE, TRUE, FALSE), 50, TRUE),
|
||||
B = sample(c("A", "C"), 50, TRUE),
|
||||
C = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE),
|
||||
D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE)
|
||||
) |> plot_euler_single()
|
||||
mtcars[c("vs", "am")] |> plot_euler_single()
|
||||
}
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/data_plots.R
|
||||
% Please edit documentation in R/plot_sankey.R
|
||||
\name{plot_sankey_single}
|
||||
\alias{plot_sankey_single}
|
||||
\title{Beautiful sankey plot}
|
||||
|
|
@ -24,4 +24,10 @@ Beautiful sankey plot
|
|||
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", color.group = "y")
|
||||
data.frame(
|
||||
g = sample(LETTERS[1:2], 100, TRUE),
|
||||
first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)),
|
||||
last = sample(c(TRUE, FALSE, FALSE), 100, TRUE)
|
||||
) |>
|
||||
plot_sankey_single("first", "last", color.group = "x")
|
||||
}
|
||||
|
|
|
|||
249
renv.lock
249
renv.lock
|
|
@ -167,6 +167,25 @@
|
|||
"Maintainer": "Coen Bernaards <cab.gparotation@gmail.com>",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"GenSA": {
|
||||
"Package": "GenSA",
|
||||
"Version": "1.1.14.1",
|
||||
"Source": "Repository",
|
||||
"Type": "Package",
|
||||
"Title": "R Functions for Generalized Simulated Annealing",
|
||||
"Date": "2024-01-22",
|
||||
"Author": "Sylvain Gubian, Yang Xiang, Brian Suomela, Julia Hoeng, PMP SA.",
|
||||
"Maintainer": "Sylvain Gubian <DL.RSupport@pmi.com>",
|
||||
"Depends": [
|
||||
"R (>= 2.12.0)"
|
||||
],
|
||||
"Description": "Performs search for global minimum of a very complex non-linear objective function with a very large number of optima.",
|
||||
"License": "GPL-2",
|
||||
"LazyLoad": "yes",
|
||||
"NeedsCompilation": "yes",
|
||||
"Repository": "CRAN",
|
||||
"RoxygenNote": "7.2.3"
|
||||
},
|
||||
"Hmisc": {
|
||||
"Package": "Hmisc",
|
||||
"Version": "5.2-2",
|
||||
|
|
@ -653,6 +672,44 @@
|
|||
"Maintainer": "Dirk Eddelbuettel <edd@debian.org>",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"RcppArmadillo": {
|
||||
"Package": "RcppArmadillo",
|
||||
"Version": "14.2.3-1",
|
||||
"Source": "Repository",
|
||||
"Type": "Package",
|
||||
"Title": "'Rcpp' Integration for the 'Armadillo' Templated Linear Algebra Library",
|
||||
"Date": "2025-02-05",
|
||||
"Authors@R": "c(person(\"Dirk\", \"Eddelbuettel\", role = c(\"aut\", \"cre\"), email = \"edd@debian.org\", comment = c(ORCID = \"0000-0001-6419-907X\")), person(\"Romain\", \"Francois\", role = \"aut\", comment = c(ORCID = \"0000-0002-2444-4226\")), person(\"Doug\", \"Bates\", role = \"aut\", comment = c(ORCID = \"0000-0001-8316-9503\")), person(\"Binxiang\", \"Ni\", role = \"aut\"), person(\"Conrad\", \"Sanderson\", role = \"aut\", comment = c(ORCID = \"0000-0002-0049-4501\")))",
|
||||
"Description": "'Armadillo' is a templated C++ linear algebra library (by Conrad Sanderson) that aims towards a good balance between speed and ease of use. Integer, floating point and complex numbers are supported, as well as a subset of trigonometric and statistics functions. Various matrix decompositions are provided through optional integration with LAPACK and ATLAS libraries. The 'RcppArmadillo' package includes the header files from the templated 'Armadillo' library. Thus users do not need to install 'Armadillo' itself in order to use 'RcppArmadillo'. From release 7.800.0 on, 'Armadillo' is licensed under Apache License 2; previous releases were under licensed as MPL 2.0 from version 3.800.0 onwards and LGPL-3 prior to that; 'RcppArmadillo' (the 'Rcpp' bindings/bridge to Armadillo) is licensed under the GNU GPL version 2 or later, as is the rest of 'Rcpp'.",
|
||||
"License": "GPL (>= 2)",
|
||||
"LazyLoad": "yes",
|
||||
"Depends": [
|
||||
"R (>= 3.3.0)"
|
||||
],
|
||||
"LinkingTo": [
|
||||
"Rcpp"
|
||||
],
|
||||
"Imports": [
|
||||
"Rcpp (>= 1.0.12)",
|
||||
"stats",
|
||||
"utils",
|
||||
"methods"
|
||||
],
|
||||
"Suggests": [
|
||||
"tinytest",
|
||||
"Matrix (>= 1.3.0)",
|
||||
"pkgKitten",
|
||||
"reticulate",
|
||||
"slam"
|
||||
],
|
||||
"URL": "https://github.com/RcppCore/RcppArmadillo, https://dirk.eddelbuettel.com/code/rcpp.armadillo.html",
|
||||
"BugReports": "https://github.com/RcppCore/RcppArmadillo/issues",
|
||||
"RoxygenNote": "6.0.1",
|
||||
"NeedsCompilation": "yes",
|
||||
"Author": "Dirk Eddelbuettel [aut, cre] (<https://orcid.org/0000-0001-6419-907X>), Romain Francois [aut] (<https://orcid.org/0000-0002-2444-4226>), Doug Bates [aut] (<https://orcid.org/0000-0001-8316-9503>), Binxiang Ni [aut], Conrad Sanderson [aut] (<https://orcid.org/0000-0002-0049-4501>)",
|
||||
"Maintainer": "Dirk Eddelbuettel <edd@debian.org>",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"RcppEigen": {
|
||||
"Package": "RcppEigen",
|
||||
"Version": "0.3.4.0.2",
|
||||
|
|
@ -2839,6 +2896,54 @@
|
|||
"Maintainer": "Victor Perrier <victor.perrier@dreamrs.fr>",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"eulerr": {
|
||||
"Package": "eulerr",
|
||||
"Version": "7.0.2",
|
||||
"Source": "Repository",
|
||||
"Title": "Area-Proportional Euler and Venn Diagrams with Ellipses",
|
||||
"Authors@R": "c(person(\"Johan\", \"Larsson\", email = \"johanlarsson@outlook.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-4029-5945\")), person(\"A. Jonathan R.\", \"Godfrey\", role = \"ctb\"), person(\"Peter\", \"Gustafsson\", role = \"ctb\"), person(\"David H.\", \"Eberly\", role = \"ctb\", comment = \"geometric algorithms\"), person(\"Emanuel\", \"Huber\", role = \"ctb\", comment = \"root solver code\"), person(\"Florian\", \"Privé\", role = \"ctb\"))",
|
||||
"Description": "Generate area-proportional Euler diagrams using numerical optimization. An Euler diagram is a generalization of a Venn diagram, relaxing the criterion that all interactions need to be represented. Diagrams may be fit with ellipses and circles via a wide range of inputs and can be visualized in numerous ways.",
|
||||
"Depends": [
|
||||
"R (>= 3.3.0)"
|
||||
],
|
||||
"Imports": [
|
||||
"GenSA",
|
||||
"graphics",
|
||||
"grDevices",
|
||||
"grid",
|
||||
"polyclip",
|
||||
"polylabelr",
|
||||
"Rcpp",
|
||||
"stats",
|
||||
"utils"
|
||||
],
|
||||
"Suggests": [
|
||||
"covr",
|
||||
"knitr",
|
||||
"lattice",
|
||||
"pBrackets",
|
||||
"RConics",
|
||||
"rmarkdown",
|
||||
"testthat",
|
||||
"spelling"
|
||||
],
|
||||
"LinkingTo": [
|
||||
"Rcpp (>= 0.12.12)",
|
||||
"RcppArmadillo (>= 0.7.600.1.0)"
|
||||
],
|
||||
"License": "GPL-3",
|
||||
"Encoding": "UTF-8",
|
||||
"LazyData": "true",
|
||||
"VignetteBuilder": "knitr",
|
||||
"URL": "https://github.com/jolars/eulerr, https://jolars.github.io/eulerr/",
|
||||
"BugReports": "https://github.com/jolars/eulerr/issues",
|
||||
"RoxygenNote": "7.2.3",
|
||||
"Language": "en-US",
|
||||
"NeedsCompilation": "yes",
|
||||
"Author": "Johan Larsson [aut, cre] (<https://orcid.org/0000-0002-4029-5945>), A. Jonathan R. Godfrey [ctb], Peter Gustafsson [ctb], David H. Eberly [ctb] (geometric algorithms), Emanuel Huber [ctb] (root solver code), Florian Privé [ctb]",
|
||||
"Maintainer": "Johan Larsson <johanlarsson@outlook.com>",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"evaluate": {
|
||||
"Package": "evaluate",
|
||||
"Version": "1.0.3",
|
||||
|
|
@ -3686,6 +3791,61 @@
|
|||
"Author": "Daniel Lüdecke [aut, cre] (<https://orcid.org/0000-0002-8895-3206>), Frederik Aust [ctb] (<https://orcid.org/0000-0003-4900-788X>), Sam Crawley [ctb] (<https://orcid.org/0000-0002-7847-0411>), Mattan S. Ben-Shachar [ctb] (<https://orcid.org/0000-0002-4287-4801>), Sean C. Anderson [ctb] (<https://orcid.org/0000-0001-9563-1937>)",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"ggforce": {
|
||||
"Package": "ggforce",
|
||||
"Version": "0.4.2",
|
||||
"Source": "Repository",
|
||||
"Type": "Package",
|
||||
"Title": "Accelerating 'ggplot2'",
|
||||
"Authors@R": "c(person(given = \"Thomas Lin\", family = \"Pedersen\", role = c(\"cre\", \"aut\"), email = \"thomasp85@gmail.com\", comment = c(ORCID = \"0000-0002-5147-4711\")), person(\"RStudio\", role = \"cph\"))",
|
||||
"Maintainer": "Thomas Lin Pedersen <thomasp85@gmail.com>",
|
||||
"Description": "The aim of 'ggplot2' is to aid in visual data investigations. This focus has led to a lack of facilities for composing specialised plots. 'ggforce' aims to be a collection of mainly new stats and geoms that fills this gap. All additional functionality is aimed to come through the official extension system so using 'ggforce' should be a stable experience.",
|
||||
"URL": "https://ggforce.data-imaginist.com, https://github.com/thomasp85/ggforce",
|
||||
"BugReports": "https://github.com/thomasp85/ggforce/issues",
|
||||
"License": "MIT + file LICENSE",
|
||||
"Encoding": "UTF-8",
|
||||
"Depends": [
|
||||
"ggplot2 (>= 3.3.6)",
|
||||
"R (>= 3.3.0)"
|
||||
],
|
||||
"Imports": [
|
||||
"Rcpp (>= 0.12.2)",
|
||||
"grid",
|
||||
"scales",
|
||||
"MASS",
|
||||
"tweenr (>= 0.1.5)",
|
||||
"gtable",
|
||||
"rlang",
|
||||
"polyclip",
|
||||
"stats",
|
||||
"grDevices",
|
||||
"tidyselect",
|
||||
"withr",
|
||||
"utils",
|
||||
"lifecycle",
|
||||
"cli",
|
||||
"vctrs",
|
||||
"systemfonts"
|
||||
],
|
||||
"LinkingTo": [
|
||||
"Rcpp",
|
||||
"RcppEigen"
|
||||
],
|
||||
"RoxygenNote": "7.3.1",
|
||||
"Suggests": [
|
||||
"sessioninfo",
|
||||
"concaveman",
|
||||
"deldir",
|
||||
"latex2exp",
|
||||
"reshape2",
|
||||
"units (>= 0.4-6)",
|
||||
"covr"
|
||||
],
|
||||
"Collate": "'RcppExports.R' 'aaa.R' 'shape.R' 'arc_bar.R' 'arc.R' 'autodensity.R' 'autohistogram.R' 'autopoint.R' 'bezier.R' 'bspline.R' 'bspline_closed.R' 'circle.R' 'diagonal.R' 'diagonal_wide.R' 'ellipse.R' 'errorbar.R' 'facet_grid_paginate.R' 'facet_matrix.R' 'facet_row.R' 'facet_stereo.R' 'facet_wrap_paginate.R' 'facet_zoom.R' 'ggforce-package.R' 'ggproto-classes.R' 'interpolate.R' 'labeller.R' 'link.R' 'mark_circle.R' 'mark_ellipse.R' 'mark_hull.R' 'mark_label.R' 'mark_rect.R' 'parallel_sets.R' 'position-jitternormal.R' 'position_auto.R' 'position_floatstack.R' 'regon.R' 'scale-depth.R' 'scale-unit.R' 'sina.R' 'spiro.R' 'themes.R' 'trans.R' 'trans_linear.R' 'utilities.R' 'voronoi.R' 'zzz.R'",
|
||||
"NeedsCompilation": "yes",
|
||||
"Author": "Thomas Lin Pedersen [cre, aut] (<https://orcid.org/0000-0002-5147-4711>), RStudio [cph]",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"ggiraph": {
|
||||
"Package": "ggiraph",
|
||||
"Version": "0.8.12",
|
||||
|
|
@ -6712,6 +6872,61 @@
|
|||
"Maintainer": "Hadley Wickham <hadley@rstudio.com>",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"polyclip": {
|
||||
"Package": "polyclip",
|
||||
"Version": "1.10-7",
|
||||
"Source": "Repository",
|
||||
"Date": "2024-07-23",
|
||||
"Title": "Polygon Clipping",
|
||||
"Authors@R": "c(person(\"Angus\", \"Johnson\", role = \"aut\", comment=\"C++ original, http://www.angusj.com/delphi/clipper.php\"), person(\"Adrian\", \"Baddeley\", role = c(\"aut\", \"trl\", \"cre\"), email = \"Adrian.Baddeley@curtin.edu.au\"), person(\"Kurt\", \"Hornik\", role = \"ctb\"), person(c(\"Brian\", \"D.\"), \"Ripley\", role = \"ctb\"), person(\"Elliott\", \"Sales de Andrade\", role=\"ctb\"), person(\"Paul\", \"Murrell\", role = \"ctb\"), person(\"Ege\", \"Rubak\", role=\"ctb\"), person(\"Mark\", \"Padgham\", role=\"ctb\"))",
|
||||
"Maintainer": "Adrian Baddeley <Adrian.Baddeley@curtin.edu.au>",
|
||||
"Depends": [
|
||||
"R (>= 3.5.0)"
|
||||
],
|
||||
"Description": "R port of Angus Johnson's open source library 'Clipper'. Performs polygon clipping operations (intersection, union, set minus, set difference) for polygonal regions of arbitrary complexity, including holes. Computes offset polygons (spatial buffer zones, morphological dilations, Minkowski dilations) for polygonal regions and polygonal lines. Computes Minkowski Sum of general polygons. There is a function for removing self-intersections from polygon data.",
|
||||
"License": "BSL",
|
||||
"URL": "https://www.angusj.com, https://sourceforge.net/projects/polyclipping, https://github.com/baddstats/polyclip",
|
||||
"BugReports": "https://github.com/baddstats/polyclip/issues",
|
||||
"ByteCompile": "true",
|
||||
"Note": "built from Clipper C++ version 6.4.0",
|
||||
"NeedsCompilation": "yes",
|
||||
"Author": "Angus Johnson [aut] (C++ original, http://www.angusj.com/delphi/clipper.php), Adrian Baddeley [aut, trl, cre], Kurt Hornik [ctb], Brian D. Ripley [ctb], Elliott Sales de Andrade [ctb], Paul Murrell [ctb], Ege Rubak [ctb], Mark Padgham [ctb]",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"polylabelr": {
|
||||
"Package": "polylabelr",
|
||||
"Version": "0.3.0",
|
||||
"Source": "Repository",
|
||||
"Title": "Find the Pole of Inaccessibility (Visual Center) of a Polygon",
|
||||
"Authors@R": "c(person(given = \"Johan\", family = \"Larsson\", role = c(\"aut\", \"cre\"), email = \"johanlarsson@outlook.com\", comment = c(ORCID = \"0000-0002-4029-5945\")), person(given = \"Kent\", family = \"Johnson\", role = \"ctb\", email = \"kent@kentsjohnson.com\"), person(\"Mapbox\", role = \"cph\", comment = \"polylabel, variant, and geometry libraries\"))",
|
||||
"Description": "A wrapper around the C++ library 'polylabel' from 'Mapbox', providing an efficient routine for finding the approximate pole of inaccessibility of a polygon, which usually serves as an excellent candidate for labeling of a polygon.",
|
||||
"License": "MIT + file LICENSE",
|
||||
"Copyright": "see file COPYRIGHTS",
|
||||
"Encoding": "UTF-8",
|
||||
"URL": "https://github.com/jolars/polylabelr, https://jolars.github.io/polylabelr/",
|
||||
"BugReports": "https://github.com/jolars/polylabelr/issues",
|
||||
"Depends": [
|
||||
"R (>= 3.3.0)"
|
||||
],
|
||||
"LinkingTo": [
|
||||
"Rcpp"
|
||||
],
|
||||
"Imports": [
|
||||
"Rcpp"
|
||||
],
|
||||
"RoxygenNote": "7.3.2",
|
||||
"Suggests": [
|
||||
"covr",
|
||||
"testthat",
|
||||
"spelling",
|
||||
"sf"
|
||||
],
|
||||
"Language": "en-US",
|
||||
"NeedsCompilation": "yes",
|
||||
"Author": "Johan Larsson [aut, cre] (<https://orcid.org/0000-0002-4029-5945>), Kent Johnson [ctb], Mapbox [cph] (polylabel, variant, and geometry libraries)",
|
||||
"Maintainer": "Johan Larsson <johanlarsson@outlook.com>",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"pracma": {
|
||||
"Package": "pracma",
|
||||
"Version": "2.4.4",
|
||||
|
|
@ -9301,6 +9516,40 @@
|
|||
"Maintainer": "Victor Perrier <victor.perrier@dreamrs.fr>",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"tweenr": {
|
||||
"Package": "tweenr",
|
||||
"Version": "2.0.3",
|
||||
"Source": "Repository",
|
||||
"Type": "Package",
|
||||
"Title": "Interpolate Data for Smooth Animations",
|
||||
"Authors@R": "c(person(given = \"Thomas Lin\", family = \"Pedersen\", role = c(\"aut\", \"cre\"), email = \"thomasp85@gmail.com\", comment = c(ORCID = \"0000-0002-5147-4711\")))",
|
||||
"Maintainer": "Thomas Lin Pedersen <thomasp85@gmail.com>",
|
||||
"Description": "In order to create smooth animation between states of data, tweening is necessary. This package provides a range of functions for creating tweened data that can be used as basis for animation. Furthermore it adds a number of vectorized interpolaters for common R data types such as numeric, date and colour.",
|
||||
"URL": "https://github.com/thomasp85/tweenr",
|
||||
"BugReports": "https://github.com/thomasp85/tweenr/issues",
|
||||
"License": "MIT + file LICENSE",
|
||||
"Encoding": "UTF-8",
|
||||
"Depends": [
|
||||
"R (>= 3.2.0)"
|
||||
],
|
||||
"Imports": [
|
||||
"farver",
|
||||
"magrittr",
|
||||
"rlang",
|
||||
"vctrs"
|
||||
],
|
||||
"LinkingTo": [
|
||||
"cpp11 (>= 0.4.2)"
|
||||
],
|
||||
"RoxygenNote": "7.2.3",
|
||||
"Suggests": [
|
||||
"testthat",
|
||||
"covr"
|
||||
],
|
||||
"NeedsCompilation": "yes",
|
||||
"Author": "Thomas Lin Pedersen [aut, cre] (<https://orcid.org/0000-0002-5147-4711>)",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"twosamples": {
|
||||
"Package": "twosamples",
|
||||
"Version": "2.0.1",
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue