mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2026-06-19 12:37:30 +02:00
updated docs + boxplot
This commit is contained in:
parent
04784a7a24
commit
111393c73f
23 changed files with 908 additions and 306 deletions
|
|
@ -1 +1 @@
|
|||
app_version <- function()'250318_0827'
|
||||
app_version <- function()'250319_1306'
|
||||
|
|
|
|||
|
|
@ -102,13 +102,16 @@ library(shiny)
|
|||
#' f <- d_t |> cut(2)
|
||||
#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA)) |> cut(breaks = lubridate::as_datetime(c(hms::as_hms(levels(f)), hms::as_hms(max(d_t, na.rm = TRUE) + 1))), right = FALSE)
|
||||
cut.hms <- function(x, breaks, ...) {
|
||||
## as_hms keeps returning warnings on tz(); ignored
|
||||
suppressWarnings({
|
||||
if (hms::is_hms(breaks)) {
|
||||
breaks <- lubridate::as_datetime(breaks, tz = "UTC")
|
||||
breaks <- lubridate::as_datetime(breaks)
|
||||
}
|
||||
x <- lubridate::as_datetime(x, tz = "UTC")
|
||||
x <- lubridate::as_datetime(x)
|
||||
out <- cut.POSIXt(x, breaks = breaks, ...)
|
||||
attr(out, which = "brks") <- hms::as_hms(lubridate::as_datetime(attr(out, which = "brks")))
|
||||
attr(out, which = "levels") <- as.character(hms::as_hms(lubridate::as_datetime(attr(out, which = "levels"))))
|
||||
})
|
||||
out
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -59,27 +59,7 @@ data_import_server <- function(id) {
|
|||
id = ns("file_import"),
|
||||
show_data_in = "popup",
|
||||
trigger_return = "change",
|
||||
return_class = "data.frame",
|
||||
read_fns = list(
|
||||
ods = import_ods,
|
||||
dta = function(file) {
|
||||
haven::read_dta(
|
||||
file = file,
|
||||
.name_repair = "unique_quiet"
|
||||
)
|
||||
},
|
||||
csv = import_delim,
|
||||
tsv = import_delim,
|
||||
txt = import_delim,
|
||||
xls = import_xls,
|
||||
xlsx = import_xls,
|
||||
rds = function(file) {
|
||||
readr::read_rds(
|
||||
file = file,
|
||||
name_repair = "unique_quiet"
|
||||
)
|
||||
}
|
||||
)
|
||||
return_class = "data.frame"
|
||||
)
|
||||
|
||||
shiny::observeEvent(data_file$data(), {
|
||||
|
|
|
|||
178
R/data_plots.R
178
R/data_plots.R
|
|
@ -112,6 +112,99 @@ data_visuals_server <- function(id,
|
|||
plot = NULL
|
||||
)
|
||||
|
||||
# ## --- New attempt
|
||||
#
|
||||
# rv$plot.params <- shiny::reactive({
|
||||
# get_plot_options(input$type) |> purrr::pluck(1)
|
||||
# })
|
||||
#
|
||||
# c(output,
|
||||
# list(shiny::renderUI({
|
||||
# columnSelectInput(
|
||||
# inputId = ns("primary"),
|
||||
# data = data,
|
||||
# placeholder = "Select variable",
|
||||
# label = "Response variable",
|
||||
# multiple = FALSE
|
||||
# )
|
||||
# }),
|
||||
# shiny::renderUI({
|
||||
# shiny::req(input$primary)
|
||||
# # browser()
|
||||
#
|
||||
# if (!input$primary %in% names(data())) {
|
||||
# plot_data <- data()[1]
|
||||
# } else {
|
||||
# plot_data <- data()[input$primary]
|
||||
# }
|
||||
#
|
||||
# plots <- possible_plots(
|
||||
# data = plot_data
|
||||
# )
|
||||
#
|
||||
# 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 = Reduce(c, plots_named),
|
||||
# multiple = FALSE
|
||||
# )
|
||||
# }),
|
||||
# shiny::renderUI({
|
||||
# shiny::req(input$type)
|
||||
#
|
||||
# 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 = cols[1],
|
||||
# placeholder = "Please select",
|
||||
# label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) "Additional variables" else "Secondary variable",
|
||||
# multiple = rv$plot.params()[["secondary.multi"]],
|
||||
# maxItems = rv$plot.params()[["secondary.max"]],
|
||||
# col_subset = cols,
|
||||
# none_label = "No variable"
|
||||
# )
|
||||
# }),
|
||||
# shiny::renderUI({
|
||||
# shiny::req(input$type)
|
||||
# columnSelectInput(
|
||||
# inputId = ns("tertiary"),
|
||||
# data = data,
|
||||
# placeholder = "Please select",
|
||||
# label = "Grouping variable",
|
||||
# multiple = FALSE,
|
||||
# col_subset = c(
|
||||
# "none",
|
||||
# all_but(
|
||||
# colnames(subset_types(
|
||||
# data(),
|
||||
# rv$plot.params()[["tertiary.type"]]
|
||||
# )),
|
||||
# input$primary,
|
||||
# input$secondary
|
||||
# )
|
||||
# ),
|
||||
# none_label = "No stratification"
|
||||
# )
|
||||
# })
|
||||
# )|> setNames(c("primary","type","secondary","tertiary")),keep.null = TRUE)
|
||||
|
||||
output$primary <- shiny::renderUI({
|
||||
columnSelectInput(
|
||||
inputId = ns("primary"),
|
||||
|
|
@ -364,6 +457,16 @@ supported_plots <- function() {
|
|||
tertiary.type = c("dichotomous", "ordinal"),
|
||||
secondary.extra = NULL
|
||||
),
|
||||
plot_box = list(
|
||||
fun = "plot_box",
|
||||
descr = "Box plot",
|
||||
note = "A classic way to plot data distribution by groups",
|
||||
primary.type = c("continuous", "dichotomous", "ordinal"),
|
||||
secondary.type = c("dichotomous", "ordinal"),
|
||||
secondary.multi = FALSE,
|
||||
tertiary.type = c("dichotomous", "ordinal"),
|
||||
secondary.extra = "none"
|
||||
),
|
||||
plot_euler = list(
|
||||
fun = "plot_euler",
|
||||
descr = "Euler diagram",
|
||||
|
|
@ -535,18 +638,49 @@ line_break <- function(data, lineLength = 20, fixed = FALSE) {
|
|||
}
|
||||
|
||||
|
||||
wrap_plot_list <- function(data) {
|
||||
if (length(data) > 1) {
|
||||
out <- data |>
|
||||
allign_axes() |>
|
||||
patchwork::wrap_plots(guides = "collect", axes = "collect", axis_titles = "collect")
|
||||
#' Wrapping
|
||||
#'
|
||||
#' @param data list of ggplot2 objects
|
||||
#' @param tag_levels passed to patchwork::plot_annotation if given. Default is NULL
|
||||
#'
|
||||
#' @returns list of ggplot2 objects
|
||||
#' @export
|
||||
#'
|
||||
wrap_plot_list <- function(data, tag_levels = NULL) {
|
||||
if (ggplot2::is.ggplot(data[[1]])) {
|
||||
if (length(data) > 1) {
|
||||
out <- data |>
|
||||
(\(.x){
|
||||
if (rlang::is_named(.x)) {
|
||||
purrr::imap(.x, \(.y, .i){
|
||||
.y + ggplot2::ggtitle(.i)
|
||||
})
|
||||
} else {
|
||||
.x
|
||||
}
|
||||
})() |>
|
||||
allign_axes() |>
|
||||
patchwork::wrap_plots(guides = "collect", axes = "collect", axis_titles = "collect")
|
||||
if (!is.null(tag_levels)) {
|
||||
out <- out + patchwork::plot_annotation(tag_levels = tag_levels)
|
||||
}
|
||||
} else {
|
||||
out <- data
|
||||
}
|
||||
} else {
|
||||
out <- data
|
||||
cli::cli_abort("Can only wrap lists of {.cls ggplot} objects")
|
||||
}
|
||||
out
|
||||
}
|
||||
|
||||
|
||||
#' Alligns axes between plots
|
||||
#'
|
||||
#' @param ... ggplot2 objects or list of ggplot2 objects
|
||||
#'
|
||||
#' @returns list of ggplot2 objects
|
||||
#' @export
|
||||
#'
|
||||
allign_axes <- function(...) {
|
||||
# https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object
|
||||
# https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150
|
||||
|
|
@ -558,16 +692,30 @@ allign_axes <- function(...) {
|
|||
cli::cli_abort("Can only align {.cls ggplot} objects or a list of them")
|
||||
}
|
||||
|
||||
# browser()
|
||||
yr <- purrr::map(p, ~ ggplot2::layer_scales(.x)$y$get_limits()) |>
|
||||
unlist() |>
|
||||
range() |>
|
||||
unique()
|
||||
yr <- clean_common_axis(p, "y")
|
||||
|
||||
xr <- purrr::map(p, ~ ggplot2::layer_scales(.x)$x$get_limits()) |>
|
||||
unlist() |>
|
||||
range() |>
|
||||
unique()
|
||||
xr <- clean_common_axis(p, "x")
|
||||
|
||||
p |> purrr::map(~ .x + ggplot2::xlim(xr) + ggplot2::ylim(yr))
|
||||
}
|
||||
|
||||
#' Extract and clean axis ranges
|
||||
#'
|
||||
#' @param p plot
|
||||
#' @param axis axis. x or y.
|
||||
#'
|
||||
#' @returns vector
|
||||
#' @export
|
||||
#'
|
||||
clean_common_axis <- function(p, axis) {
|
||||
purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |>
|
||||
unlist() |>
|
||||
(\(.x){
|
||||
if (is.numeric(.x)) {
|
||||
range(.x)
|
||||
} else {
|
||||
.x
|
||||
}
|
||||
})() |>
|
||||
unique()
|
||||
}
|
||||
|
|
|
|||
|
|
@ -215,7 +215,9 @@ default_parsing <- function(data) {
|
|||
out <- data |>
|
||||
REDCapCAST::parse_data() |>
|
||||
REDCapCAST::as_factor() |>
|
||||
REDCapCAST::numchar2fct()
|
||||
REDCapCAST::numchar2fct(numeric.threshold = 8,character.throshold = 10) |>
|
||||
REDCapCAST::as_logical() |>
|
||||
REDCapCAST::fct_drop()
|
||||
|
||||
purrr::map2(out,name_labels,\(.x,.l){
|
||||
if (!(is.na(.l) | .l=="")) {
|
||||
|
|
@ -275,6 +277,7 @@ remove_empty_cols <- function(data,cutoff=.7){
|
|||
#' @param index index name
|
||||
#'
|
||||
#' @returns list
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' ls_d <- list(test=c(1:20))
|
||||
|
|
|
|||
80
R/plot_box.R
Normal file
80
R/plot_box.R
Normal file
|
|
@ -0,0 +1,80 @@
|
|||
#' Beautiful box plot(s)
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_box(x = "mpg", y = "cyl", z = "gear")
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' plot_box(x = "mpg", y = "cyl", z = "gear")
|
||||
plot_box <- function(data, x, y, z = NULL) {
|
||||
if (!is.null(z)) {
|
||||
ds <- split(data, data[z])
|
||||
} else {
|
||||
ds <- list(data)
|
||||
}
|
||||
|
||||
out <- lapply(ds, \(.ds){
|
||||
plot_box_single(
|
||||
data = .ds,
|
||||
x = x,
|
||||
y = y
|
||||
)
|
||||
})
|
||||
|
||||
wrap_plot_list(out)
|
||||
# patchwork::wrap_plots(out,guides = "collect")
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
#' Create nice box-plots
|
||||
#'
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @returns
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_box_single("mpg","cyl")
|
||||
plot_box_single <- function(data, x, y=NULL, seed = 2103) {
|
||||
set.seed(seed)
|
||||
|
||||
if (is.null(y)) {
|
||||
y <- "All"
|
||||
data[[y]] <- y
|
||||
}
|
||||
|
||||
discrete <- !outcome_type(data[[y]]) %in% "continuous"
|
||||
|
||||
data |>
|
||||
ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y), group = !!dplyr::sym(y))) +
|
||||
ggplot2::geom_boxplot(linewidth = 1.8, outliers = FALSE) +
|
||||
## THis could be optional in future
|
||||
ggplot2::geom_jitter(color = "black", size = 2, alpha = 0.9) +
|
||||
ggplot2::coord_flip() +
|
||||
viridis::scale_fill_viridis(discrete = discrete, option = "D") +
|
||||
# ggplot2::theme_void() +
|
||||
ggplot2::theme_bw(base_size = 24) +
|
||||
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(),
|
||||
# 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(),
|
||||
panel.grid.major = ggplot2::element_blank(),
|
||||
panel.grid.minor = ggplot2::element_blank(),
|
||||
axis.line = ggplot2::element_line(colour = "black"),
|
||||
axis.ticks = ggplot2::element_line(colour = "black")
|
||||
)
|
||||
}
|
||||
|
|
@ -78,9 +78,6 @@ ggeulerr <- function(
|
|||
#' 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 {
|
||||
|
|
@ -93,6 +90,7 @@ plot_euler <- function(data, x, y, z = NULL, seed = 2103) {
|
|||
plot_euler_single()
|
||||
})
|
||||
|
||||
# names(out)
|
||||
wrap_plot_list(out)
|
||||
# patchwork::wrap_plots(out, guides = "collect")
|
||||
}
|
||||
|
|
@ -116,7 +114,7 @@ plot_euler_single <- function(data) {
|
|||
ggeulerr(shape = "circle") +
|
||||
ggplot2::theme_void() +
|
||||
ggplot2::theme(
|
||||
legend.position = "right",
|
||||
legend.position = "none",
|
||||
# panel.grid.major = element_blank(),
|
||||
# panel.grid.minor = element_blank(),
|
||||
# axis.text.y = element_blank(),
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ plot.tbl_regression <- function(x,
|
|||
# gtsummary:::check_scalar_logical(remove_reference_rows)
|
||||
|
||||
df_coefs <- x$table_body
|
||||
browser()
|
||||
|
||||
if (isTRUE(remove_header_rows)) {
|
||||
df_coefs <- df_coefs |> dplyr::filter(!header_row %in% TRUE)
|
||||
}
|
||||
|
|
@ -48,22 +48,16 @@ plot.tbl_regression <- function(x,
|
|||
if (plot_ref == TRUE){
|
||||
df_coefs[df_coefs$var_type == "categorical" & is.na(df_coefs$reference_row),"estimate"] <- if (x$inputs$exponentiate) 1 else 0}
|
||||
|
||||
df_coefs |>
|
||||
p <- df_coefs |>
|
||||
ggstats::ggcoef_plot(exponentiate = x$inputs$exponentiate, ...)
|
||||
|
||||
if (x$inputs$exponentiate){
|
||||
p <- symmetrical_scale_x_log10(p)
|
||||
}
|
||||
p
|
||||
}
|
||||
|
||||
|
||||
# default_parsing(mtcars) |> lapply(class)
|
||||
#
|
||||
# purrr::imap(mtcars,\(.x,.i){
|
||||
# if (.i %in% c("vs","am","gear","carb")){
|
||||
# as.factor(.x)
|
||||
# } else .x
|
||||
# }) |> dplyr::bind_cols()
|
||||
#
|
||||
#
|
||||
|
||||
|
||||
#' Wrapper to pivot gtsummary table data to long for plotting
|
||||
#'
|
||||
#' @param list a custom regression models list
|
||||
|
|
@ -103,3 +97,47 @@ merge_long <- function(list, model.names) {
|
|||
|
||||
l_merged
|
||||
}
|
||||
|
||||
|
||||
#' Easily round log scale limits for nice plots
|
||||
#'
|
||||
#' @param data data
|
||||
#' @param fun rounding function (floor/ceiling)
|
||||
#' @param ... ignored
|
||||
#'
|
||||
#' @returns numeric vector
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' limit_log(-.1,floor)
|
||||
#' limit_log(.1,ceiling)
|
||||
#' limit_log(-2.1,ceiling)
|
||||
#' limit_log(2.1,ceiling)
|
||||
limit_log <- function(data,fun,...){
|
||||
fun(10^-floor(data)*10^data)/10^-floor(data)
|
||||
}
|
||||
|
||||
#' Ensure symmetrical plot around 1 on a logarithmic x scale for ratio plots
|
||||
#'
|
||||
#' @param plot ggplot2 plot
|
||||
#' @param breaks breaks used and mirrored
|
||||
#' @param ... ignored
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
symmetrical_scale_x_log10 <- function(plot,breaks=c(1,2,3,5,10),...){
|
||||
rx <- ggplot2::layer_scales(plot)$x$get_limits()
|
||||
|
||||
x_min <- floor(10*rx[1])/10
|
||||
x_max <- ceiling(10*rx[2])/10
|
||||
|
||||
rx_min <- limit_log(rx[1],floor)
|
||||
rx_max <- limit_log(rx[2],ceiling)
|
||||
|
||||
max_abs_x <- max(abs(c(x_min,x_max)))
|
||||
|
||||
ticks <- log10(breaks)+(ceiling(max_abs_x)-1)
|
||||
browser()
|
||||
plot + ggplot2::scale_x_log10(limits=c(rx_min,rx_max),breaks=create_log_tics(10^ticks[ticks<=max_abs_x]))
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue