From efc3f8acc37a541ea3d123c0d0fa186c7b7401f2 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Wed, 12 Mar 2025 18:27:46 +0100 Subject: [PATCH] minor steps --- DESCRIPTION | 5 +- NAMESPACE | 3 + R/app_version.R | 2 +- R/custom_SelectInput.R | 6 +- R/data_plots.R | 261 ++---- R/helpers.R | 14 + R/import-file-ext.R | 1 - R/plot_euler.R | 130 +++ R/plot_sankey.R | 200 +++++ R/regression_model.R | 4 +- inst/apps/freesearcheR/app.R | 834 +++++++++++------- .../shinyapps.io/agdamsbo/freesearcheR.dcf | 2 +- inst/apps/freesearcheR/server.R | 97 +- inst/apps/freesearcheR/ui.R | 9 +- man/columnSelectInput.Rd | 5 +- man/data-plots.Rd | 14 +- man/ggeulerr.Rd | 24 + man/line_break.Rd | 2 +- man/missing_fraction.Rd | 20 + man/plot_euler.Rd | 34 + man/plot_euler_single.Rd | 23 + man/plot_sankey_single.Rd | 8 +- renv.lock | 249 ++++++ 23 files changed, 1385 insertions(+), 562 deletions(-) create mode 100644 R/plot_euler.R create mode 100644 R/plot_sankey.R create mode 100644 man/ggeulerr.Rd create mode 100644 man/missing_fraction.Rd create mode 100644 man/plot_euler.Rd create mode 100644 man/plot_euler_single.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 85fbc0e..f3e23b8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -65,7 +65,10 @@ Imports: rempsyc, ggridges, ggalluvial, - REDCapCAST + REDCapCAST, + eulerr, + ggforce, + RcppArmadillo Suggests: styler, devtools, diff --git a/NAMESPACE b/NAMESPACE index 45b6352..a541a54 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -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) diff --git a/R/app_version.R b/R/app_version.R index 9f9d51f..b2aec8d 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'250311_1338' +app_version <- function()'250312_1817' diff --git a/R/custom_SelectInput.R b/R/custom_SelectInput.R index 65198c2..7a72fc4 100644 --- a/R/custom_SelectInput.R +++ b/R/custom_SelectInput.R @@ -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) + ''; } - }")) + }")), + if (!is.null(maxItems)) list(maxItems=maxItems) ) ) } diff --git a/R/data_plots.R b/R/data_plots.R index 73a2c95..6287f30 100644 --- a/R/data_plots.R +++ b/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() + cols <- c( + rv$plot.params()[["secondary.extra"]], + all_but( + colnames(subset_types( + data(), + rv$plot.params()[["secondary.type"]] + )), + input$primary + ) + ) + columnSelectInput( inputId = ns("secondary"), data = data, + selected = 1, placeholder = "Select variable", label = "Secondary/group variable", - multiple = FALSE, - col_subset = c( - purrr::pluck(rv$plot.params(), 1)[["secondary.extra"]], - all_but( - colnames(subset_types( - data(), - purrr::pluck(rv$plot.params(), 1)[["secondary.type"]] - )), - input$primary - ) - ), + 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 #' @@ -719,7 +694,7 @@ str_remove_last <- function(data, pattern = "\n") { #' #' @examples #' "Lorem ipsum... you know the routine" |> line_break() -#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(fixed=TRUE) +#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(fixed = TRUE) line_break <- function(data, lineLength = 20, fixed = FALSE) { if (isTRUE(force)) { gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), "\\1\n", data) @@ -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() - ) -} diff --git a/R/helpers.R b/R/helpers.R index 8b8340b..166fef0 100644 --- a/R/helpers.R +++ b/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) +} diff --git a/R/import-file-ext.R b/R/import-file-ext.R index 0d0d9da..e9f0c28 100644 --- a/R/import-file-ext.R +++ b/R/import-file-ext.R @@ -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, diff --git a/R/plot_euler.R b/R/plot_euler.R new file mode 100644 index 0000000..9a8d935 --- /dev/null +++ b/R/plot_euler.R @@ -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() + ) +} diff --git a/R/plot_sankey.R b/R/plot_sankey.R new file mode 100644 index 0000000..baddb7f --- /dev/null +++ b/R/plot_sankey.R @@ -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() + ) +} diff --git a/R/regression_model.R b/R/regression_model.R index eda2bf4..6d51e33 100644 --- a/R/regression_model.R +++ b/R/regression_model.R @@ -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" diff --git a/inst/apps/freesearcheR/app.R b/inst/apps/freesearcheR/app.R index a65ffcc..67b02b8 100644 --- a/inst/apps/freesearcheR/app.R +++ b/inst/apps/freesearcheR/app.R @@ -10,7 +10,7 @@ #### Current file: R//app_version.R ######## -app_version <- function()'250311_1338' +app_version <- function()'250312_1817' ######## @@ -259,6 +259,7 @@ cor_app() #' @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 #' @@ -266,7 +267,7 @@ cor_app() #' @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) @@ -322,7 +323,8 @@ columnSelectInput <- function(inputId, label, data, selected = "", ..., escape(item.data.name) + ''; } - }")) + }")), + if (!is.null(maxItems)) list(maxItems=maxItems) ) ) } @@ -1201,39 +1203,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() + cols <- c( + rv$plot.params()[["secondary.extra"]], + all_but( + colnames(subset_types( + data(), + rv$plot.params()[["secondary.type"]] + )), + input$primary + ) + ) + columnSelectInput( inputId = ns("secondary"), data = data, + selected = 1, placeholder = "Select variable", label = "Secondary/group variable", - multiple = FALSE, - col_subset = c( - purrr::pluck(rv$plot.params(), 1)[["secondary.extra"]], - all_but( - colnames(subset_types( - data(), - purrr::pluck(rv$plot.params(), 1)[["secondary.type"]] - )), - input$primary - ) - ), + multiple = rv$plot.params()[["secondary.multi"]], + maxItems = rv$plot.params()[["secondary.max"]], + col_subset = cols, none_label = "No variable" ) }) @@ -1251,7 +1262,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 @@ -1266,9 +1277,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 @@ -1364,20 +1378,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", @@ -1388,25 +1406,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 @@ -1522,7 +1555,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 } @@ -1722,63 +1755,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 #' @@ -1792,7 +1769,7 @@ str_remove_last <- function(data, pattern = "\n") { #' #' @examples #' "Lorem ipsum... you know the routine" |> line_break() -#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(fixed=TRUE) +#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(fixed = TRUE) line_break <- function(data, lineLength = 20, fixed = FALSE) { if (isTRUE(force)) { gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), "\\1\n", data) @@ -1802,135 +1779,7 @@ 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() - ) -} ######## @@ -2681,6 +2530,20 @@ append_list <- function(data,list,index){ } +#' 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) +} + + ######## #### Current file: R//import-file-ext.R ######## @@ -2690,13 +2553,10 @@ append_list <- function(data,list,index){ #' #' @description Let user upload a file and import data #' -#' @inheritParams import-globalenv #' @param preview_data Show or not a preview of the data under the file input. #' @param file_extensions File extensions accepted by [shiny::fileInput()], can also be MIME type. #' @param layout_params How to display import parameters : in a dropdown button or inline below file input. #' -#' @template module-import -#' #' @export #' #' @name import-file @@ -2707,7 +2567,6 @@ append_list <- function(data,list,index){ #' @importFrom phosphoricons ph #' @importFrom toastui datagridOutput2 #' -#' @example examples/from-file.R import_file_ui <- function(id, title = TRUE, preview_data = TRUE, @@ -2858,7 +2717,6 @@ import_file_ui <- function(id, } -#' @inheritParams import_globalenv_server #' @param read_fns Named list with custom function(s) to read data: #' * the name must be the extension of the files to which the function will be applied #' * the value must be a function that can have 5 arguments (you can ignore some of them, but you have to use the same names), @@ -2882,7 +2740,6 @@ import_file_ui <- function(id, #' @importFrom tools file_ext #' @importFrom utils head #' @importFrom toastui renderDatagrid2 datagrid -#' @importFrom datamods split_char #' #' @rdname import-file import_file_server <- function(id, @@ -3107,6 +2964,47 @@ import_delim <- function(file, skip, encoding, na.strings) { ) } +#' @title Create a select input control with icon(s) +#' +#' @description Extend form controls by adding text or icons before, +#' after, or on both sides of a classic `selectInput`. +#' +#' @inheritParams shiny::selectInput +#' +#' @return A numeric input control that can be added to a UI definition. +#' @export +#' +#' @importFrom shiny restoreInput +#' @importFrom htmltools tags validateCssUnit css +#' +selectInputIcon <- function(inputId, + label, + choices, + selected = NULL, + multiple = FALSE, + selectize = TRUE, + size = NULL, + width = NULL, + icon = NULL) { + selected <- shiny::restoreInput(id = inputId, default = selected) + tags$div( + class = "form-group shiny-input-container", + shinyWidgets:::label_input(inputId, label), + style = htmltools:::css(width = htmltools:::validateCssUnit(width)), + tags$div( + class = "input-group", + class = shinyWidgets:::validate_size(size), + shinyWidgets:::markup_input_group(icon, "left", theme_func = shiny::getCurrentTheme), + shiny::tags$select( + id = inputId, + class = "form-control select-input-icon", + shiny:::selectOptions(choices, selected, inputId, selectize) + ), + shinyWidgets:::markup_input_group(icon, "right", theme_func = shiny::getCurrentTheme) + ), + shinyWidgets:::html_dependency_input_icons() + ) +} @@ -3177,6 +3075,350 @@ if (interactive()) shinyApp(ui, server) + + +######## +#### Current file: R//plot_euler.R +######## + +#' 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() + ) +} + + +######## +#### Current file: R//plot_sankey.R +######## + +#' 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() + ) +} + + ######## #### Current file: R//redcap_read_shiny_module.R ######## @@ -4005,8 +4247,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" @@ -4730,56 +4972,6 @@ modify_qmd <- function(file, format) { -######## -#### Current file: R//selectInputIcon.R -######## - -#' @title Create a select input control with icon(s) -#' -#' @description Extend form controls by adding text or icons before, -#' after, or on both sides of a classic `selectInput`. -#' -#' @inheritParams shiny::selectInput -#' @inheritParams textInputIcon -#' -#' @return A numeric input control that can be added to a UI definition. -#' @seealso See [updateNumericInputIcon()] to update server-side, and [textInputIcon()] for using text value. -#' @export -#' -#' @importFrom shiny restoreInput -#' @importFrom htmltools tags validateCssUnit css -#' -#' @example examples/numericInputIcon.R -selectInputIcon <- function(inputId, - label, - choices, - selected = NULL, - multiple = FALSE, - selectize = TRUE, - size = NULL, - width = NULL, - icon = NULL) { - selected <- shiny::restoreInput(id = inputId, default = selected) - tags$div( - class = "form-group shiny-input-container", - shinyWidgets:::label_input(inputId, label), - style = htmltools:::css(width = htmltools:::validateCssUnit(width)), - tags$div( - class = "input-group", - class = shinyWidgets:::validate_size(size), - shinyWidgets:::markup_input_group(icon, "left", theme_func = shiny::getCurrentTheme), - shiny::tags$select( - id = inputId, - class = "form-control numeric-input-icon", - shiny:::selectOptions(choices, selected, inputId, selectize) - ), - shinyWidgets:::markup_input_group(icon, "right", theme_func = shiny::getCurrentTheme) - ), - shinyWidgets:::html_dependency_input_icons() - ) -} - - ######## #### Current file: R//shiny_freesearcheR.R ######## @@ -6216,13 +6408,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( @@ -6237,7 +6429,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(), @@ -6860,6 +7055,7 @@ server <- function(input, output, session) { ready = NULL, test = "no", data_original = NULL, + data_temp = NULL, data = NULL, data_filtered = NULL, models = NULL, @@ -6893,7 +7089,7 @@ server <- function(input, output, session) { haven::read_dta( file = file, .name_repair = "unique_quiet" - ) + ) }, # csv = function(file) { # readr::read_csv( @@ -6912,7 +7108,7 @@ server <- function(input, output, session) { skip_empty_rows = TRUE, start_row = skip - 1, na.strings = na - ) + ) }, xlsx = function(file, which, skip, na) { openxlsx2::read_xlsx( @@ -6920,36 +7116,38 @@ 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") }) data_redcap <- m_redcap_readServer( - id = "redcap_import"#, + id = "redcap_import" # , # output.format = "list" ) 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( { DT::datatable(head(data_redcap(), 5), - # DT::datatable(head(purrr::pluck(data_redcap(), "data")(), 5), + # DT::datatable(head(purrr::pluck(data_redcap(), "data")(), 5), caption = "First 5 observations" ) }, @@ -6965,10 +7163,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) @@ -6991,26 +7223,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, { - 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 - ) - } - }, ignoreNULL = TRUE) + shiny::observeEvent(input$reset_confirm, + { + if (isTRUE(input$reset_confirm)) { + shiny::req(rv$data_original) + rv$data <- rv$data_original + } + }, + ignoreNULL = TRUE + ) shiny::observeEvent(input$data_reset, { @@ -7048,7 +7274,7 @@ server <- function(input, output, session) { shiny::observeEvent( input$modal_variables, - modal_update_variables("modal_variables",title = "Modify factor levels") + modal_update_variables("modal_variables", title = "Modify factor levels") ) @@ -7056,7 +7282,7 @@ server <- function(input, output, session) { shiny::observeEvent( input$modal_cut, - modal_cut_variable("modal_cut",title = "Modify factor levels") + modal_cut_variable("modal_cut", title = "Modify factor levels") ) data_modal_cut <- cut_variable_server( @@ -7087,7 +7313,7 @@ server <- function(input, output, session) { shiny::observeEvent( input$modal_column, - datamods::modal_create_column(id = "modal_column",footer = "This is only for advanced users!") + datamods::modal_create_column(id = "modal_column", footer = "This is only for advanced users!") ) data_modal_r <- datamods::create_column_server( id = "modal_column", @@ -7222,7 +7448,7 @@ server <- function(input, output, session) { output$code_import <- shiny::renderPrint({ cat(rv$code$import) - }) + }) output$code_data <- shiny::renderPrint({ attr(rv$data, "code") @@ -7461,10 +7687,10 @@ server <- function(input, output, session) { ls <- do.call( .fun, c( - list(data = rv$list$data|> - (\(.x){ - .x[regression_vars()] - })()), + list(data = rv$list$data |> + (\(.x){ + .x[regression_vars()] + })()), list(outcome.str = input$outcome_var), list(fun.descr = input$regression_type) ) diff --git a/inst/apps/freesearcheR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf b/inst/apps/freesearcheR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf index bb8a0aa..8ea77b5 100644 --- a/inst/apps/freesearcheR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf +++ b/inst/apps/freesearcheR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf @@ -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 diff --git a/inst/apps/freesearcheR/server.R b/inst/apps/freesearcheR/server.R index 9b9ada2..d8c72c3 100644 --- a/inst/apps/freesearcheR/server.R +++ b/inst/apps/freesearcheR/server.R @@ -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, @@ -113,7 +114,7 @@ server <- function(input, output, session) { haven::read_dta( file = file, .name_repair = "unique_quiet" - ) + ) }, # csv = function(file) { # readr::read_csv( @@ -132,7 +133,7 @@ server <- function(input, output, session) { skip_empty_rows = TRUE, start_row = skip - 1, na.strings = na - ) + ) }, xlsx = function(file, which, skip, na) { openxlsx2::read_xlsx( @@ -140,36 +141,38 @@ 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") }) data_redcap <- m_redcap_readServer( - id = "redcap_import"#, + id = "redcap_import" # , # output.format = "list" ) 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( { DT::datatable(head(data_redcap(), 5), - # DT::datatable(head(purrr::pluck(data_redcap(), "data")(), 5), + # DT::datatable(head(purrr::pluck(data_redcap(), "data")(), 5), caption = "First 5 observations" ) }, @@ -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, { - 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 - ) - } - }, ignoreNULL = TRUE) + shiny::observeEvent(input$reset_confirm, + { + if (isTRUE(input$reset_confirm)) { + shiny::req(rv$data_original) + rv$data <- rv$data_original + } + }, + ignoreNULL = TRUE + ) shiny::observeEvent(input$data_reset, { @@ -268,7 +299,7 @@ server <- function(input, output, session) { shiny::observeEvent( input$modal_variables, - modal_update_variables("modal_variables",title = "Modify factor levels") + modal_update_variables("modal_variables", title = "Modify factor levels") ) @@ -276,7 +307,7 @@ server <- function(input, output, session) { shiny::observeEvent( input$modal_cut, - modal_cut_variable("modal_cut",title = "Modify factor levels") + modal_cut_variable("modal_cut", title = "Modify factor levels") ) data_modal_cut <- cut_variable_server( @@ -307,7 +338,7 @@ server <- function(input, output, session) { shiny::observeEvent( input$modal_column, - datamods::modal_create_column(id = "modal_column",footer = "This is only for advanced users!") + datamods::modal_create_column(id = "modal_column", footer = "This is only for advanced users!") ) data_modal_r <- datamods::create_column_server( id = "modal_column", @@ -442,7 +473,7 @@ server <- function(input, output, session) { output$code_import <- shiny::renderPrint({ cat(rv$code$import) - }) + }) output$code_data <- shiny::renderPrint({ attr(rv$data, "code") @@ -681,10 +712,10 @@ server <- function(input, output, session) { ls <- do.call( .fun, c( - list(data = rv$list$data|> - (\(.x){ - .x[regression_vars()] - })()), + list(data = rv$list$data |> + (\(.x){ + .x[regression_vars()] + })()), list(outcome.str = input$outcome_var), list(fun.descr = input$regression_type) ) diff --git a/inst/apps/freesearcheR/ui.R b/inst/apps/freesearcheR/ui.R index 016b879..ed72b96 100644 --- a/inst/apps/freesearcheR/ui.R +++ b/inst/apps/freesearcheR/ui.R @@ -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(), diff --git a/man/columnSelectInput.Rd b/man/columnSelectInput.Rd index 75065b0..2bd5308 100644 --- a/man/columnSelectInput.Rd +++ b/man/columnSelectInput.Rd @@ -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 diff --git a/man/data-plots.Rd b/man/data-plots.Rd index e28f716..f76d762 100644 --- a/man/data-plots.Rd +++ b/man/data-plots.Rd @@ -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") diff --git a/man/ggeulerr.Rd b/man/ggeulerr.Rd new file mode 100644 index 0000000..78fc313 --- /dev/null +++ b/man/ggeulerr.Rd @@ -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 +} diff --git a/man/line_break.Rd b/man/line_break.Rd index 30e9067..c74ead0 100644 --- a/man/line_break.Rd +++ b/man/line_break.Rd @@ -22,5 +22,5 @@ Line breaking at given number of characters for nicely plotting labels } \examples{ "Lorem ipsum... you know the routine" |> line_break() -paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(fixed=TRUE) +paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(fixed = TRUE) } diff --git a/man/missing_fraction.Rd b/man/missing_fraction.Rd new file mode 100644 index 0000000..6182c2a --- /dev/null +++ b/man/missing_fraction.Rd @@ -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() +} diff --git a/man/plot_euler.Rd b/man/plot_euler.Rd new file mode 100644 index 0000000..78f3333 --- /dev/null +++ b/man/plot_euler.Rd @@ -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) +} diff --git a/man/plot_euler_single.Rd b/man/plot_euler_single.Rd new file mode 100644 index 0000000..c41d116 --- /dev/null +++ b/man/plot_euler_single.Rd @@ -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() +} diff --git a/man/plot_sankey_single.Rd b/man/plot_sankey_single.Rd index 8be31f8..b1410f7 100644 --- a/man/plot_sankey_single.Rd +++ b/man/plot_sankey_single.Rd @@ -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") } diff --git a/renv.lock b/renv.lock index e6f3ff0..904f79e 100644 --- a/renv.lock +++ b/renv.lock @@ -167,6 +167,25 @@ "Maintainer": "Coen Bernaards ", "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 ", + "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 ", "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] (), Romain Francois [aut] (), Doug Bates [aut] (), Binxiang Ni [aut], Conrad Sanderson [aut] ()", + "Maintainer": "Dirk Eddelbuettel ", + "Repository": "CRAN" + }, "RcppEigen": { "Package": "RcppEigen", "Version": "0.3.4.0.2", @@ -2839,6 +2896,54 @@ "Maintainer": "Victor Perrier ", "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] (), 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 ", + "Repository": "CRAN" + }, "evaluate": { "Package": "evaluate", "Version": "1.0.3", @@ -3686,6 +3791,61 @@ "Author": "Daniel Lüdecke [aut, cre] (), Frederik Aust [ctb] (), Sam Crawley [ctb] (), Mattan S. Ben-Shachar [ctb] (), Sean C. Anderson [ctb] ()", "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 ", + "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] (), RStudio [cph]", + "Repository": "CRAN" + }, "ggiraph": { "Package": "ggiraph", "Version": "0.8.12", @@ -6712,6 +6872,61 @@ "Maintainer": "Hadley Wickham ", "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 ", + "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] (), Kent Johnson [ctb], Mapbox [cph] (polylabel, variant, and geometry libraries)", + "Maintainer": "Johan Larsson ", + "Repository": "CRAN" + }, "pracma": { "Package": "pracma", "Version": "2.4.4", @@ -9301,6 +9516,40 @@ "Maintainer": "Victor Perrier ", "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 ", + "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] ()", + "Repository": "CRAN" + }, "twosamples": { "Package": "twosamples", "Version": "2.0.1",