mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2026-06-19 12:37:30 +02:00
too much..
This commit is contained in:
parent
e5b702a183
commit
bc8aa7b583
28 changed files with 1064 additions and 95 deletions
|
|
@ -10,7 +10,7 @@
|
|||
#### Current file: R//app_version.R
|
||||
########
|
||||
|
||||
app_version <- function()'250227_1342'
|
||||
app_version <- function()'250305_1101'
|
||||
|
||||
|
||||
########
|
||||
|
|
@ -984,7 +984,7 @@ plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112
|
|||
#' @returns Shiny ui module
|
||||
#' @export
|
||||
#'
|
||||
data_visuals_ui <- function(id, tab_title="Plots", ...) {
|
||||
data_visuals_ui <- function(id, tab_title = "Plots", ...) {
|
||||
ns <- shiny::NS(id)
|
||||
|
||||
# bslib::navset_bar(
|
||||
|
|
@ -1005,7 +1005,7 @@ data_visuals_ui <- function(id, tab_title="Plots", ...) {
|
|||
bslib::accordion_panel(
|
||||
title = "Advanced",
|
||||
icon = bsicons::bs_icon("gear")
|
||||
),
|
||||
),
|
||||
bslib::accordion_panel(
|
||||
title = "Download",
|
||||
icon = bsicons::bs_icon("download"),
|
||||
|
|
@ -1016,7 +1016,7 @@ data_visuals_ui <- function(id, tab_title="Plots", ...) {
|
|||
max = 300,
|
||||
value = 100,
|
||||
step = 1,
|
||||
format = shinyWidgets::wNumbFormat(decimals=0),
|
||||
format = shinyWidgets::wNumbFormat(decimals = 0),
|
||||
color = datamods:::get_primary_color()
|
||||
),
|
||||
shinyWidgets::noUiSliderInput(
|
||||
|
|
@ -1026,7 +1026,7 @@ data_visuals_ui <- function(id, tab_title="Plots", ...) {
|
|||
max = 300,
|
||||
value = 100,
|
||||
step = 1,
|
||||
format = shinyWidgets::wNumbFormat(decimals=0),
|
||||
format = shinyWidgets::wNumbFormat(decimals = 0),
|
||||
color = datamods:::get_primary_color()
|
||||
),
|
||||
shiny::selectInput(
|
||||
|
|
@ -1139,7 +1139,6 @@ data_visuals_server <- function(id,
|
|||
),
|
||||
none_label = "No variable"
|
||||
)
|
||||
|
||||
})
|
||||
|
||||
output$tertiary <- shiny::renderUI({
|
||||
|
|
@ -1189,12 +1188,14 @@ data_visuals_server <- function(id,
|
|||
}),
|
||||
content = function(file) {
|
||||
shiny::withProgress(message = "Drawing the plot. Hold on for a moment..", {
|
||||
ggplot2::ggsave(filename = file,
|
||||
plot = rv$plot(),
|
||||
width = input$width,
|
||||
height = input$height,
|
||||
dpi = 300,
|
||||
units = "mm",scale = 2)
|
||||
ggplot2::ggsave(
|
||||
filename = file,
|
||||
plot = rv$plot(),
|
||||
width = input$width,
|
||||
height = input$height,
|
||||
dpi = 300,
|
||||
units = "mm", scale = 2
|
||||
)
|
||||
})
|
||||
}
|
||||
)
|
||||
|
|
@ -1214,7 +1215,7 @@ data_visuals_server <- function(id,
|
|||
#' @param data vector
|
||||
#' @param ... exclude
|
||||
#'
|
||||
#' @returns
|
||||
#' @returns vector
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
|
|
@ -1229,7 +1230,7 @@ all_but <- function(data, ...) {
|
|||
#' @param types desired types
|
||||
#' @param type.fun function to get type. Default is outcome_type
|
||||
#'
|
||||
#' @returns
|
||||
#' @returns vector
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
|
|
@ -1266,7 +1267,8 @@ subset_types <- function(data, types, type.fun = outcome_type) {
|
|||
supported_plots <- function() {
|
||||
list(
|
||||
plot_hbars = list(
|
||||
descr = "Stacked horizontal bars (Grotta bars)",
|
||||
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"),
|
||||
tertiary.type = c("dichotomous", "ordinal"),
|
||||
|
|
@ -1274,6 +1276,7 @@ supported_plots <- function() {
|
|||
),
|
||||
plot_violin = list(
|
||||
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"),
|
||||
|
|
@ -1281,13 +1284,23 @@ supported_plots <- function() {
|
|||
),
|
||||
plot_ridge = list(
|
||||
descr = "Ridge plot",
|
||||
note = "An alternative option to visualise data distribution",
|
||||
primary.type = "continuous",
|
||||
secondary.type = c("dichotomous", "ordinal"),
|
||||
tertiary.type = c("dichotomous", "ordinal"),
|
||||
secondary.extra = NULL
|
||||
),
|
||||
plot_sankey = list(
|
||||
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
|
||||
),
|
||||
plot_scatter = list(
|
||||
descr = "Scatter plot",
|
||||
note = "A classic way of showing the association between to variables",
|
||||
primary.type = "continuous",
|
||||
secondary.type = c("continuous", "ordinal"),
|
||||
tertiary.type = c("dichotomous", "ordinal"),
|
||||
|
|
@ -1298,9 +1311,11 @@ supported_plots <- function() {
|
|||
|
||||
#' Title
|
||||
#'
|
||||
#' @returns
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
|
|
@ -1398,7 +1413,9 @@ get_plot_options <- function(data) {
|
|||
#' @param type plot type (derived from possible_plots() and matches custom function)
|
||||
#' @param ... ignored for now
|
||||
#'
|
||||
#' @returns
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
|
|
@ -1424,6 +1441,8 @@ create_plot <- function(data, type, x, y, z = NULL, ...) {
|
|||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_hbars(x = "carb", y = "cyl")
|
||||
#' mtcars |> plot_hbars(x = "carb", y = NULL)
|
||||
|
|
@ -1523,6 +1542,7 @@ vertical_stacked_bars <- function(data,
|
|||
#'
|
||||
#' @examples
|
||||
#' mtcars |> get_label(var = "mpg")
|
||||
#' mtcars |> get_label()
|
||||
#' mtcars$mpg |> get_label()
|
||||
#' gtsummary::trial |> get_label(var = "trt")
|
||||
#' 1:10 |> get_label()
|
||||
|
|
@ -1530,13 +1550,16 @@ get_label <- function(data, var = NULL) {
|
|||
if (!is.null(var)) {
|
||||
data <- data[[var]]
|
||||
}
|
||||
|
||||
out <- REDCapCAST::get_attr(data = data, attr = "label")
|
||||
if (is.na(out)) {
|
||||
if (is.null(var)) {
|
||||
out <- deparse(substitute(data))
|
||||
} else {
|
||||
out <- gsub('\"', "", deparse(substitute(var)))
|
||||
if (is.symbol(var)) {
|
||||
out <- gsub('\"', "", deparse(substitute(var)))
|
||||
} else {
|
||||
out <- var
|
||||
}
|
||||
}
|
||||
}
|
||||
out
|
||||
|
|
@ -1548,6 +1571,8 @@ get_label <- function(data, var = NULL) {
|
|||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear")
|
||||
plot_violin <- function(data, x, y, z = NULL) {
|
||||
|
|
@ -1569,11 +1594,13 @@ plot_violin <- function(data, x, y, z = NULL) {
|
|||
}
|
||||
|
||||
|
||||
#' Beatiful violin plot
|
||||
#' Beautiful violin plot
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_scatter(x = "mpg", y = "wt")
|
||||
plot_scatter <- function(data, x, y, z = NULL) {
|
||||
|
|
@ -1593,6 +1620,194 @@ plot_scatter <- function(data, x, y, z = NULL) {
|
|||
}
|
||||
}
|
||||
|
||||
#' Readying data for sankey plot
|
||||
#'
|
||||
#' @param data
|
||||
#' @param x
|
||||
#' @param y
|
||||
#' @param z
|
||||
#'
|
||||
#' @returns
|
||||
#' @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), "%)"))
|
||||
)
|
||||
}
|
||||
out
|
||||
}
|
||||
|
||||
#' Line breaking at given number of characters for nicely plotting labels
|
||||
#'
|
||||
#' @param data
|
||||
#' @param lineLength
|
||||
#'
|
||||
#' @returns
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
line_break <- function(data, lineLength = 20) {
|
||||
# gsub(paste0('(.{1,',lineLength,'})(\\s)'), '\\1\n', data)
|
||||
paste(strwrap(data, lineLength), collapse = "\n")
|
||||
## 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
|
||||
#' @param colors
|
||||
#'
|
||||
#' @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 = "x", colors = NULL){
|
||||
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()
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
########
|
||||
|
|
@ -3811,7 +4026,7 @@ shiny_freesearcheR <- function(...) {
|
|||
#' @returns shiny app
|
||||
#' @export
|
||||
#'
|
||||
launch <- function(...){
|
||||
launch_freesearcheR <- function(...){
|
||||
shiny_freesearcheR(...)
|
||||
}
|
||||
|
||||
|
|
@ -3926,7 +4141,6 @@ gg_theme_export <- function(){
|
|||
#'
|
||||
#' @name update-factor
|
||||
#'
|
||||
#' @example examples/update_factor.R
|
||||
update_factor_ui <- function(id) {
|
||||
ns <- NS(id)
|
||||
tagList(
|
||||
|
|
@ -6430,33 +6644,6 @@ server <- function(input, output, session) {
|
|||
gt::tab_header(gt::md(glue::glue("**Table 2: {rv$list$regression$params$descr}**")))
|
||||
})
|
||||
|
||||
# shiny::observe(
|
||||
# # list(
|
||||
# # input$plot_model
|
||||
# # ),
|
||||
# {
|
||||
# shiny::req(rv$list$regression$tables)
|
||||
# shiny::req(input$plot_model)
|
||||
# tryCatch(
|
||||
# {
|
||||
# out <- merge_long(rv$list$regression, input$plot_model) |>
|
||||
# plot.tbl_regression(
|
||||
# colour = "variable",
|
||||
# facet_col = "model"
|
||||
# )
|
||||
#
|
||||
# rv$list$regression$plot <- out
|
||||
# },
|
||||
# warning = function(warn) {
|
||||
# showNotification(paste0(warn), type = "warning")
|
||||
# },
|
||||
# error = function(err) {
|
||||
# showNotification(paste0("Plotting failed with the following error: ", err), type = "err")
|
||||
# }
|
||||
# )
|
||||
# }
|
||||
# )
|
||||
|
||||
output$regression_plot <- shiny::renderPlot(
|
||||
{
|
||||
# shiny::req(rv$list$regression$plot)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue