mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2025-09-12 01:49:39 +02:00
docs
This commit is contained in:
parent
c7a9467b47
commit
4c42636faa
8 changed files with 371 additions and 201 deletions
|
|
@ -64,8 +64,7 @@ Imports:
|
|||
RcppArmadillo,
|
||||
ggcorrplot,
|
||||
shinyjs,
|
||||
emmeans,
|
||||
visdat
|
||||
emmeans
|
||||
Suggests:
|
||||
styler,
|
||||
devtools,
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
S3method(cut_var,default)
|
||||
S3method(cut_var,hms)
|
||||
S3method(plot,tbl_regression)
|
||||
export(FreesearchR_palette)
|
||||
export(add_class_icon)
|
||||
export(add_sparkline)
|
||||
export(align_axes)
|
||||
|
|
@ -32,6 +33,7 @@ export(data_correlations_ui)
|
|||
export(data_description)
|
||||
export(data_missings_server)
|
||||
export(data_missings_ui)
|
||||
export(data_summary_gather)
|
||||
export(data_summary_server)
|
||||
export(data_summary_ui)
|
||||
export(data_type)
|
||||
|
|
@ -121,12 +123,15 @@ export(supported_plots)
|
|||
export(symmetrical_scale_x_log10)
|
||||
export(tbl_merge)
|
||||
export(type_icons)
|
||||
export(unique_short)
|
||||
export(update_factor_server)
|
||||
export(update_factor_ui)
|
||||
export(update_variables_server)
|
||||
export(update_variables_ui)
|
||||
export(vectorSelectInput)
|
||||
export(vertical_stacked_bars)
|
||||
export(visual_summary)
|
||||
export(visual_summary_ui)
|
||||
export(wide2long)
|
||||
export(winbox_create_column)
|
||||
export(winbox_update_factor)
|
||||
|
|
|
|||
2
NEWS.md
2
NEWS.md
|
|
@ -1,6 +1,6 @@
|
|||
# FreesearchR 25.6.3
|
||||
|
||||
- *NEW* First go at introducing more options to evaluate missings. This has introduced a new dependency to use the visdat package and visualisation. The solution includes the option to visualise data classes and missingness as well as comparisons of variables by missing outcome variable or not to determine the nature of missingness.
|
||||
- *NEW* Introducing more options to evaluate missing observations. Inspired by the [visdat()] function from the {visdat} package, a specialised function has been introduced to easily visualise data classes and missing observations in the data set. This highly increases the options to visually get an overview of the data and to assess the pattern of missing data. Also under Evaluate, a comparison module has been introduced to compare the distribution of observations across variables depending on the missing vs non-missing in a specified variable.
|
||||
|
||||
- *FIX* The REDCap import module has been updated visually and the PAI token is now hidden as a password. This module should still only be used when running locally if you are accessing sensitive data.
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
hosted_version <- function()'v25.6.3-250625'
|
||||
hosted_version <- function()'v25.6.3-250626'
|
||||
|
|
|
|||
BIN
R/sysdata.rda
BIN
R/sysdata.rda
Binary file not shown.
|
|
@ -43,6 +43,7 @@
|
|||
|cardx |0.2.4 |2025-04-12 |CRAN (R 4.4.1) |
|
||||
|caTools |1.18.3 |2024-09-04 |CRAN (R 4.4.1) |
|
||||
|cellranger |1.1.0 |2016-07-27 |CRAN (R 4.4.0) |
|
||||
|cffr |1.2.0 |2025-01-25 |CRAN (R 4.4.1) |
|
||||
|checkmate |2.3.2 |2024-07-29 |CRAN (R 4.4.0) |
|
||||
|class |7.3-23 |2025-01-01 |CRAN (R 4.4.1) |
|
||||
|classInt |0.4-11 |2025-01-08 |CRAN (R 4.4.1) |
|
||||
|
|
@ -112,6 +113,7 @@
|
|||
|iterators |1.0.14 |2022-02-05 |CRAN (R 4.4.1) |
|
||||
|jquerylib |0.1.4 |2021-04-26 |CRAN (R 4.4.0) |
|
||||
|jsonlite |2.0.0 |2025-03-27 |CRAN (R 4.4.1) |
|
||||
|jsonvalidate |1.5.0 |2025-02-07 |CRAN (R 4.4.1) |
|
||||
|KernSmooth |2.23-26 |2025-01-01 |CRAN (R 4.4.1) |
|
||||
|keyring |1.3.2 |2023-12-11 |CRAN (R 4.4.0) |
|
||||
|knitr |1.50 |2025-03-16 |CRAN (R 4.4.1) |
|
||||
|
|
@ -167,6 +169,7 @@
|
|||
|R6 |2.6.1 |2025-02-15 |CRAN (R 4.4.1) |
|
||||
|ragg |1.4.0 |2025-04-10 |CRAN (R 4.4.1) |
|
||||
|rankinPlot |1.1.0 |2023-01-30 |CRAN (R 4.4.0) |
|
||||
|rappdirs |0.3.3 |2021-01-31 |CRAN (R 4.4.1) |
|
||||
|rbibutils |2.3 |2024-10-04 |CRAN (R 4.4.1) |
|
||||
|RColorBrewer |1.1-3 |2022-04-03 |CRAN (R 4.4.1) |
|
||||
|Rcpp |1.0.14 |2025-01-12 |CRAN (R 4.4.1) |
|
||||
|
|
@ -220,6 +223,7 @@
|
|||
|urlchecker |1.0.1 |2021-11-30 |CRAN (R 4.4.1) |
|
||||
|usethis |3.1.0 |2024-11-26 |CRAN (R 4.4.1) |
|
||||
|uuid |1.2-1 |2024-07-29 |CRAN (R 4.4.1) |
|
||||
|V8 |6.0.3 |2025-03-26 |CRAN (R 4.4.1) |
|
||||
|vctrs |0.6.5 |2023-12-01 |CRAN (R 4.4.0) |
|
||||
|visdat |0.6.0 |2023-02-02 |CRAN (R 4.4.0) |
|
||||
|vroom |1.6.5 |2023-12-05 |CRAN (R 4.4.0) |
|
||||
|
|
|
|||
|
|
@ -3996,7 +3996,7 @@ simple_snake <- function(data){
|
|||
#### Current file: /Users/au301842/FreesearchR/R//hosted_version.R
|
||||
########
|
||||
|
||||
hosted_version <- function()'v25.6.3-250625'
|
||||
hosted_version <- function()'v25.6.3-250626'
|
||||
|
||||
|
||||
########
|
||||
|
|
@ -4695,7 +4695,8 @@ data_missings_server <- function(id,
|
|||
variabler <- if (is.reactive(variable)) variable else reactive(variable)
|
||||
|
||||
rv <- shiny::reactiveValues(
|
||||
data = NULL
|
||||
data = NULL,
|
||||
table = NULL
|
||||
)
|
||||
|
||||
rv$data <- shiny::reactive({
|
||||
|
|
@ -4726,15 +4727,25 @@ data_missings_server <- function(id,
|
|||
shiny::req(variabler)
|
||||
|
||||
if (is.null(variabler()) || variabler() == "" || !variabler() %in% names(datar())) {
|
||||
title <- "No missing observations"
|
||||
if (anyNA(datar())){
|
||||
title <- "No variable chosen for analysis"
|
||||
} else {
|
||||
title <- paste("Missing vs non-missing observations in", variabler())
|
||||
title <- "No missing observations"
|
||||
}
|
||||
} else {
|
||||
title <- glue::glue("Missing vs non-missing observations in the variable **'{variabler()}'**")
|
||||
}
|
||||
|
||||
rv$data() |>
|
||||
out <- rv$data() |>
|
||||
gtsummary::as_gt() |>
|
||||
gt::tab_header(title = gt::md(title))
|
||||
|
||||
rv$table <- out
|
||||
|
||||
out
|
||||
})
|
||||
|
||||
return(reactive(rv$table))
|
||||
}
|
||||
)
|
||||
}
|
||||
|
|
@ -4761,10 +4772,12 @@ missing_demo_app <- function() {
|
|||
|
||||
data_missings_server(id = "data", data = data_demo, variable = shiny::reactive(input$missings_var))
|
||||
|
||||
visual_summary_server(id = "visual", data = data_demo)
|
||||
|
||||
observeEvent(input$modal_missings, {
|
||||
tryCatch(
|
||||
{
|
||||
modal_visual_missings(data = data_demo, id = "modal_missings")
|
||||
modal_visual_summary(id = "visual")
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0("We encountered the following error browsing your data: ", err), type = "err")
|
||||
|
|
@ -4778,140 +4791,12 @@ missing_demo_app <- function() {
|
|||
missing_demo_app()
|
||||
|
||||
|
||||
modal_visual_missings <- function(data,
|
||||
title = "Visual overview of data classes and missing observations",
|
||||
easyClose = TRUE,
|
||||
size = "xl",
|
||||
footer = NULL,
|
||||
...) {
|
||||
datar <- if (is.reactive(data)) data else reactive(data)
|
||||
|
||||
showModal(modalDialog(
|
||||
title = tagList(title, datamods:::button_close_modal()),
|
||||
tags$div(
|
||||
# apexcharter::renderApexchart({
|
||||
# missings_apex_plot(datar(), ...)
|
||||
# })
|
||||
shiny::renderPlot({
|
||||
visdat::vis_dat(datar(),sort_type = FALSE) +
|
||||
ggplot2::guides(fill = ggplot2::guide_legend(title = "Data class")) +
|
||||
# ggplot2::theme_void() +
|
||||
ggplot2::theme(
|
||||
# legend.position = "none",
|
||||
panel.grid.major = ggplot2::element_blank(),
|
||||
panel.grid.minor = ggplot2::element_blank(),
|
||||
# axis.text.y = element_blank(),
|
||||
# axis.title.y = element_blank(),
|
||||
text = ggplot2::element_text(size = 18),
|
||||
# axis.text = ggplot2::element_blank(),
|
||||
# panel.background = ggplot2::element_rect(fill = "white"),
|
||||
# plot.background = ggplot2::element_rect(fill = "white"),
|
||||
# panel.border = ggplot2::element_blank()
|
||||
plot.title = ggplot2::element_blank()
|
||||
)
|
||||
})
|
||||
),
|
||||
easyClose = easyClose,
|
||||
size = size,
|
||||
footer = footer
|
||||
))
|
||||
}
|
||||
|
||||
|
||||
## Slow with many observations...
|
||||
|
||||
#' Plot missings and class with apexcharter
|
||||
#'
|
||||
#' @param data data frame
|
||||
#'
|
||||
#' @returns An [apexchart()] `htmlwidget` object.
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' data_demo <- mtcars
|
||||
#' data_demo[2:4, "cyl"] <- NA
|
||||
#' rbind(data_demo, data_demo, data_demo, data_demo) |> missings_apex_plot()
|
||||
#' data_demo |> missings_apex_plot()
|
||||
#' mtcars |> missings_apex_plot(animation = TRUE)
|
||||
#' # dplyr::storms |> missings_apex_plot()
|
||||
#' visdat::vis_dat(dplyr::storms)
|
||||
missings_apex_plot <- function(data, animation = FALSE, ...) {
|
||||
browser()
|
||||
|
||||
df_plot <- purrr::map_df(data, \(x){
|
||||
ifelse(is.na(x),
|
||||
yes = NA,
|
||||
no = glue::glue_collapse(class(x),
|
||||
sep = "\n"
|
||||
)
|
||||
)
|
||||
}) %>%
|
||||
dplyr::mutate(rows = dplyr::row_number()) %>%
|
||||
tidyr::pivot_longer(
|
||||
cols = -rows,
|
||||
names_to = "variable", values_to = "valueType", values_transform = list(valueType = as.character)
|
||||
) %>%
|
||||
dplyr::arrange(rows, variable, valueType)
|
||||
|
||||
|
||||
df_plot$valueType_num <- df_plot$valueType |>
|
||||
forcats::as_factor() |>
|
||||
as.numeric()
|
||||
|
||||
|
||||
df_plot$valueType[is.na(df_plot$valueType)] <- "NA"
|
||||
df_plot$valueType_num[is.na(df_plot$valueType_num)] <- max(df_plot$valueType_num, na.rm = TRUE) + 1
|
||||
|
||||
labels <- setNames(unique(df_plot$valueType_num), unique(df_plot$valueType))
|
||||
|
||||
if (any(df_plot$valueType == "NA")) {
|
||||
colors <- setNames(c(viridisLite::viridis(n = length(labels) - 1), "#999999"), names(labels))
|
||||
} else {
|
||||
colors <- setNames(viridisLite::viridis(n = length(labels)), names(labels))
|
||||
}
|
||||
|
||||
|
||||
label_list <- labels |>
|
||||
purrr::imap(\(.x, .i){
|
||||
list(
|
||||
from = .x,
|
||||
to = .x,
|
||||
color = colors[[.i]],
|
||||
name = .i
|
||||
)
|
||||
}) |>
|
||||
setNames(NULL)
|
||||
|
||||
out <- apexcharter::apex(
|
||||
data = df_plot,
|
||||
type = "heatmap",
|
||||
mapping = apexcharter::aes(x = variable, y = rows, fill = valueType_num),
|
||||
...
|
||||
) %>%
|
||||
apexcharter::ax_stroke(width = NULL) |>
|
||||
apexcharter::ax_plotOptions(
|
||||
heatmap = apexcharter::heatmap_opts(
|
||||
radius = 0,
|
||||
enableShades = FALSE,
|
||||
colorScale = list(
|
||||
ranges = label_list
|
||||
),
|
||||
useFillColorAsStroke = TRUE
|
||||
)
|
||||
) %>%
|
||||
apexcharter::ax_dataLabels(enabled = FALSE) |>
|
||||
apexcharter::ax_tooltip(
|
||||
enabled = FALSE,
|
||||
intersect = FALSE
|
||||
)
|
||||
|
||||
if (!isTRUE(animation)) {
|
||||
out <- out |>
|
||||
apexcharter::ax_chart(animations = list(enabled = FALSE))
|
||||
}
|
||||
|
||||
out
|
||||
}
|
||||
|
||||
|
||||
########
|
||||
|
|
@ -8278,7 +8163,7 @@ FreesearchR_colors <- function(choose = NULL) {
|
|||
secondary = "#FF6F61",
|
||||
success = "#00C896",
|
||||
warning = "#FFB100",
|
||||
danger = "#FF3A2F",
|
||||
danger = "#CC2E25",
|
||||
extra = "#8A4FFF",
|
||||
info = "#11A0EC",
|
||||
bg = "#FFFFFF",
|
||||
|
|
@ -8292,7 +8177,18 @@ FreesearchR_colors <- function(choose = NULL) {
|
|||
}
|
||||
}
|
||||
|
||||
|
||||
#' Use the FreesearchR colors
|
||||
#'
|
||||
#' @param n number of colors
|
||||
#'
|
||||
#' @returns character vector
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' FreesearchR_palette(n=7)
|
||||
FreesearchR_palette <- function(n){
|
||||
rep_len(FreesearchR_colors(),n)
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
|
@ -9443,6 +9339,303 @@ clean_date <- function(data) {
|
|||
}
|
||||
|
||||
|
||||
########
|
||||
#### Current file: /Users/au301842/FreesearchR/R//visual_summary.R
|
||||
########
|
||||
|
||||
#' Data correlations evaluation module
|
||||
#'
|
||||
#' @param id Module id
|
||||
#'
|
||||
#' @name data-missings
|
||||
#' @returns Shiny ui module
|
||||
#' @export
|
||||
visual_summary_ui <- function(id) {
|
||||
ns <- shiny::NS(id)
|
||||
|
||||
shiny::tagList(
|
||||
shiny::plotOutput(outputId = ns("visual_plot"), height = "70vh")
|
||||
)
|
||||
}
|
||||
|
||||
visual_summary_server <- function(id,
|
||||
data_r=shiny::reactive(NULL),
|
||||
...) {
|
||||
shiny::moduleServer(
|
||||
id = id,
|
||||
module = function(input, output, session) {
|
||||
# ns <- session$ns
|
||||
rv <- shiny::reactiveValues(data = NULL)
|
||||
|
||||
shiny::bindEvent(shiny::observe({
|
||||
data <- data_r()
|
||||
rv$data <- data
|
||||
# vars_num <- vapply(data, \(.x){
|
||||
# is.numeric(.x) || is_datetime(.x)
|
||||
# }, logical(1))
|
||||
# vars_num <- names(vars_num)[vars_num]
|
||||
# shinyWidgets::updateVirtualSelect(
|
||||
# inputId = "variable",
|
||||
# choices = vars_num,
|
||||
# selected = if (isTruthy(input$variable)) input$variable else vars_num[1]
|
||||
# )
|
||||
}), data_r(), input$hidden)
|
||||
|
||||
# datar <- if (is.reactive(data)) data else reactive(data)
|
||||
|
||||
|
||||
# apexcharter::renderApexchart({
|
||||
# missings_apex_plot(datar(), ...)
|
||||
# })
|
||||
output$visual_plot <- shiny::renderPlot(expr = {
|
||||
visual_summary(data = rv$data,...)
|
||||
})
|
||||
}
|
||||
)
|
||||
}
|
||||
|
||||
visual_summary_demo_app <- function() {
|
||||
ui <- shiny::fluidPage(
|
||||
shiny::actionButton(
|
||||
inputId = "modal_missings",
|
||||
label = "Visual summary",
|
||||
width = "100%",
|
||||
disabled = FALSE
|
||||
)
|
||||
)
|
||||
server <- function(input, output, session) {
|
||||
data_demo <- mtcars
|
||||
data_demo[sample(1:32, 10), "cyl"] <- NA
|
||||
data_demo[sample(1:32, 8), "vs"] <- NA
|
||||
|
||||
visual_summary_server(id = "data", data = shiny::reactive(data_demo))
|
||||
|
||||
observeEvent(input$modal_missings, {
|
||||
tryCatch(
|
||||
{
|
||||
modal_visual_summary(id = "data")
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0("We encountered the following error browsing your data: ", err), type = "err")
|
||||
}
|
||||
)
|
||||
})
|
||||
}
|
||||
shiny::shinyApp(ui, server)
|
||||
}
|
||||
|
||||
visual_summary_demo_app()
|
||||
|
||||
|
||||
modal_visual_summary <- function(id,
|
||||
title = "Visual overview of data classes and missing observations",
|
||||
easyClose = TRUE,
|
||||
size = "xl",
|
||||
footer = NULL,
|
||||
...) {
|
||||
showModal(modalDialog(
|
||||
title = tagList(title, datamods:::button_close_modal()),
|
||||
visual_summary_ui(id = id),
|
||||
easyClose = easyClose,
|
||||
size = size,
|
||||
footer = footer
|
||||
))
|
||||
}
|
||||
|
||||
|
||||
## Slow with many observations...
|
||||
|
||||
#' Plot missings and class with apexcharter
|
||||
#'
|
||||
#' @param data data frame
|
||||
#'
|
||||
#' @returns An [apexchart()] `htmlwidget` object.
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' data_demo <- mtcars
|
||||
#' data_demo[2:4, "cyl"] <- NA
|
||||
#' rbind(data_demo, data_demo, data_demo, data_demo) |> missings_apex_plot()
|
||||
#' data_demo |> missings_apex_plot()
|
||||
#' mtcars |> missings_apex_plot(animation = TRUE)
|
||||
#' # dplyr::storms |> missings_apex_plot()
|
||||
#' visdat::vis_dat(dplyr::storms)
|
||||
missings_apex_plot <- function(data, animation = FALSE, ...) {
|
||||
l <- data_summary_gather(data, ...)
|
||||
|
||||
df_plot <- l$data
|
||||
|
||||
out <- apexcharter::apex(
|
||||
data = df_plot,
|
||||
type = "heatmap",
|
||||
mapping = apexcharter::aes(x = variable, y = rows, fill = valueType_num),
|
||||
...
|
||||
) |>
|
||||
apexcharter::ax_stroke(width = NULL) |>
|
||||
apexcharter::ax_plotOptions(
|
||||
heatmap = apexcharter::heatmap_opts(
|
||||
radius = 0,
|
||||
enableShades = FALSE,
|
||||
colorScale = list(
|
||||
ranges = l$labels
|
||||
),
|
||||
useFillColorAsStroke = TRUE
|
||||
)
|
||||
) |>
|
||||
apexcharter::ax_dataLabels(enabled = FALSE) |>
|
||||
apexcharter::ax_tooltip(
|
||||
enabled = FALSE,
|
||||
intersect = FALSE
|
||||
)
|
||||
|
||||
if (!isTRUE(animation)) {
|
||||
out <- out |>
|
||||
apexcharter::ax_chart(animations = list(enabled = FALSE))
|
||||
}
|
||||
|
||||
out
|
||||
}
|
||||
|
||||
|
||||
|
||||
#' Ggplot2 data summary visualisation based on visdat::vis_dat.
|
||||
#'
|
||||
#' @param data data
|
||||
#' @param ... optional arguments passed to data_summary_gather()
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' data_demo <- mtcars
|
||||
#' data_demo[sample(1:32, 10), "cyl"] <- NA
|
||||
#' data_demo[sample(1:32, 8), "vs"] <- NA
|
||||
#' visual_summary(data_demo)
|
||||
#' visual_summary(data_demo, palette.fun = scales::hue_pal())
|
||||
#' visual_summary(dplyr::storms)
|
||||
#' visual_summary(dplyr::storms, summary.fun = data_type)
|
||||
visual_summary <- function(data, legend.title = "Data class", ...) {
|
||||
l <- data_summary_gather(data, ...)
|
||||
|
||||
df <- l$data
|
||||
|
||||
df$valueType <- factor(df$valueType, levels = names(l$colors))
|
||||
df$variable <- factor(df$variable, levels = unique_short(names(data)))
|
||||
|
||||
ggplot2::ggplot(data = df, ggplot2::aes(x = variable, y = rows)) +
|
||||
ggplot2::geom_raster(ggplot2::aes(fill = valueType)) +
|
||||
ggplot2::theme_minimal() +
|
||||
ggplot2::theme(axis.text.x = ggplot2::element_text(
|
||||
angle = 45,
|
||||
vjust = 1, hjust = 1
|
||||
)) +
|
||||
ggplot2::scale_fill_manual(values = l$colors) +
|
||||
ggplot2::labs(x = "", y = "Observations") +
|
||||
ggplot2::scale_y_reverse() +
|
||||
ggplot2::theme(axis.text.x = ggplot2::element_text(hjust = 0.5)) +
|
||||
ggplot2::guides(colour = "none") +
|
||||
ggplot2::guides(fill = ggplot2::guide_legend(title = legend.title)) +
|
||||
# change the limits etc.
|
||||
ggplot2::guides(fill = ggplot2::guide_legend(title = "Type")) +
|
||||
# add info about the axes
|
||||
ggplot2::scale_x_discrete(position = "top") +
|
||||
ggplot2::theme(axis.text.x = ggplot2::element_text(hjust = 0)) +
|
||||
ggplot2::theme(
|
||||
panel.grid.major = ggplot2::element_blank(),
|
||||
panel.grid.minor = ggplot2::element_blank(),
|
||||
text = ggplot2::element_text(size = 18),
|
||||
plot.title = ggplot2::element_blank()
|
||||
)
|
||||
}
|
||||
|
||||
#' Data summary for printing visual summary
|
||||
#'
|
||||
#' @param data data.frame
|
||||
#' @param fun summary function. Default is "class"
|
||||
#' @param palette.fun optionally use specific palette functions. First argument
|
||||
#' has to be the length.
|
||||
#'
|
||||
#' @returns data.frame
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> data_summary_gather()
|
||||
data_summary_gather <- function(data, summary.fun = class, palette.fun = viridisLite::viridis) {
|
||||
df_plot <- setNames(data, unique_short(names(data))) |>
|
||||
purrr::map_df(\(x){
|
||||
ifelse(is.na(x),
|
||||
yes = NA,
|
||||
no = glue::glue_collapse(summary.fun(x),
|
||||
sep = "\n"
|
||||
)
|
||||
)
|
||||
}) |>
|
||||
dplyr::mutate(rows = dplyr::row_number()) |>
|
||||
tidyr::pivot_longer(
|
||||
cols = -rows,
|
||||
names_to = "variable", values_to = "valueType", values_transform = list(valueType = as.character)
|
||||
) |>
|
||||
dplyr::arrange(rows, variable, valueType)
|
||||
|
||||
|
||||
df_plot$valueType_num <- df_plot$valueType |>
|
||||
forcats::as_factor() |>
|
||||
as.numeric()
|
||||
|
||||
df_plot$valueType[is.na(df_plot$valueType)] <- "NA"
|
||||
df_plot$valueType_num[is.na(df_plot$valueType_num)] <- max(df_plot$valueType_num, na.rm = TRUE) + 1
|
||||
|
||||
labels <- setNames(unique(df_plot$valueType_num), unique(df_plot$valueType)) |> sort()
|
||||
|
||||
if (any(df_plot$valueType == "NA")) {
|
||||
colors <- setNames(c(palette.fun(length(labels) - 1), "#999999"), names(labels))
|
||||
} else {
|
||||
colors <- setNames(palette.fun(length(labels)), names(labels))
|
||||
}
|
||||
|
||||
|
||||
label_list <- labels |>
|
||||
purrr::imap(\(.x, .i){
|
||||
list(
|
||||
from = .x,
|
||||
to = .x,
|
||||
color = colors[[.i]],
|
||||
name = .i
|
||||
)
|
||||
}) |>
|
||||
setNames(NULL)
|
||||
|
||||
list(data = df_plot, colors = colors, labels = label_list)
|
||||
}
|
||||
|
||||
|
||||
|
||||
#' Create unique short names of character vector items based on index
|
||||
#'
|
||||
#' @description
|
||||
#' The function will prefer original names, and only append index to long
|
||||
#' strings.
|
||||
#'
|
||||
#'
|
||||
#' @param data character vector
|
||||
#' @param max maximum final name length
|
||||
#'
|
||||
#' @returns character vector
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' c("kahdleidnsallskdj", "hej") |> unique_short()
|
||||
unique_short <- function(data, max = 15) {
|
||||
purrr::imap(data, \(.x, .i){
|
||||
if (nchar(.x) > max) {
|
||||
glue::glue("{substr(.x,1,(max-(nchar(.i)+1)))}_{.i}")
|
||||
} else {
|
||||
.x
|
||||
}
|
||||
}) |> unlist()
|
||||
}
|
||||
|
||||
|
||||
########
|
||||
#### Current file: /Users/au301842/FreesearchR/R//wide2long.R
|
||||
########
|
||||
|
|
@ -9796,7 +9989,7 @@ ui_elements <- list(
|
|||
shiny::column(
|
||||
width = 3,
|
||||
shiny::actionButton(
|
||||
inputId = "modal_missings",
|
||||
inputId = "modal_visual_overview",
|
||||
label = "Visual overview",
|
||||
width = "100%",
|
||||
disabled = TRUE
|
||||
|
|
@ -10323,6 +10516,7 @@ server <- function(input, output, session) {
|
|||
rv <- shiny::reactiveValues(
|
||||
list = list(),
|
||||
regression = NULL,
|
||||
missings = NULL,
|
||||
ds = NULL,
|
||||
local_temp = NULL,
|
||||
ready = NULL,
|
||||
|
|
@ -10342,28 +10536,6 @@ server <- function(input, output, session) {
|
|||
#########
|
||||
##############################################################################
|
||||
|
||||
## This does not render correctly apparently due to css and load order
|
||||
# output$source <- shiny::renderUI({
|
||||
#
|
||||
# choices <- c(
|
||||
# "File upload" = "file",
|
||||
# "REDCap server export" = "redcap",
|
||||
# "Local or sample data" = "env"
|
||||
# )
|
||||
#
|
||||
# if (isTRUE(is_local)){
|
||||
# choices <- choices[c(1,3)]
|
||||
# }
|
||||
#
|
||||
# shinyWidgets::radioGroupButtons(
|
||||
# inputId = "source",
|
||||
# selected = "file",
|
||||
# choices = choices,
|
||||
# size = "lg"
|
||||
# )
|
||||
# })
|
||||
|
||||
|
||||
data_file <- import_file_server(
|
||||
id = "file_import",
|
||||
show_data_in = "popup",
|
||||
|
|
@ -10386,16 +10558,6 @@ server <- function(input, output, session) {
|
|||
rv$code <- modifyList(x = rv$code, list(import = from_redcap$code()))
|
||||
})
|
||||
|
||||
## This is used to ensure the reactive data is retrieved
|
||||
# output$redcap_prev <- DT::renderDT(
|
||||
# {
|
||||
# DT::datatable(head(from_redcap$data(), 5),
|
||||
# caption = "First 5 observations"
|
||||
# )
|
||||
# },
|
||||
# server = TRUE
|
||||
# )
|
||||
|
||||
from_env <- datamods::import_globalenv_server(
|
||||
id = "env",
|
||||
trigger_return = "change",
|
||||
|
|
@ -10410,11 +10572,20 @@ server <- function(input, output, session) {
|
|||
rv$code <- modifyList(x = rv$code, list(import = from_env$name()))
|
||||
})
|
||||
|
||||
visual_summary_server(
|
||||
id = "initial_summary",
|
||||
data_r = shiny::reactive({
|
||||
shiny::req(rv$data_temp)
|
||||
default_parsing(rv$data_temp)
|
||||
}),
|
||||
palette.fun = FreesearchR_palette
|
||||
)
|
||||
|
||||
observeEvent(input$modal_initial_view, {
|
||||
tryCatch(
|
||||
{
|
||||
modal_visual_missings(
|
||||
data = default_parsing(rv$data_temp),
|
||||
modal_visual_summary(
|
||||
id = "initial_summary",
|
||||
footer = NULL,
|
||||
size = "xl"
|
||||
)
|
||||
|
|
@ -10497,12 +10668,12 @@ server <- function(input, output, session) {
|
|||
if (is.null(rv$data_original) | NROW(rv$data_original) == 0) {
|
||||
shiny::updateActionButton(inputId = "act_start", disabled = TRUE)
|
||||
shiny::updateActionButton(inputId = "modal_browse", disabled = TRUE)
|
||||
shiny::updateActionButton(inputId = "modal_missings", disabled = TRUE)
|
||||
shiny::updateActionButton(inputId = "modal_visual_overview", disabled = TRUE)
|
||||
shiny::updateActionButton(inputId = "act_eval", disabled = TRUE)
|
||||
} else {
|
||||
shiny::updateActionButton(inputId = "act_start", disabled = FALSE)
|
||||
shiny::updateActionButton(inputId = "modal_browse", disabled = FALSE)
|
||||
shiny::updateActionButton(inputId = "modal_missings", disabled = FALSE)
|
||||
shiny::updateActionButton(inputId = "modal_visual_overview", disabled = FALSE)
|
||||
shiny::updateActionButton(inputId = "act_eval", disabled = FALSE)
|
||||
}
|
||||
})
|
||||
|
|
@ -10548,7 +10719,6 @@ server <- function(input, output, session) {
|
|||
)
|
||||
})
|
||||
|
||||
|
||||
#########
|
||||
######### Modifications
|
||||
#########
|
||||
|
|
@ -10741,11 +10911,20 @@ server <- function(input, output, session) {
|
|||
)
|
||||
})
|
||||
|
||||
observeEvent(input$modal_missings, {
|
||||
visual_summary_server(
|
||||
id = "visual_overview",
|
||||
data_r = shiny::reactive({
|
||||
shiny::req(rv$data_filtered)
|
||||
REDCapCAST::fct_drop(rv$data_filtered)
|
||||
}),
|
||||
palette.fun = FreesearchR_palette
|
||||
)
|
||||
|
||||
observeEvent(input$modal_visual_overview, {
|
||||
tryCatch(
|
||||
{
|
||||
modal_visual_missings(
|
||||
data = REDCapCAST::fct_drop(rv$data_filtered),
|
||||
modal_visual_summary(
|
||||
id = "visual_overview",
|
||||
footer = "Here is an overview of how your data is interpreted, and where data is missing. Use this information to consider if data is missing at random or if some observations are missing systematically wich may be caused by an observation bias.",
|
||||
size = "xl"
|
||||
)
|
||||
|
|
@ -10756,7 +10935,6 @@ server <- function(input, output, session) {
|
|||
)
|
||||
})
|
||||
|
||||
|
||||
output$original_str <- renderPrint({
|
||||
str(rv$data_original)
|
||||
})
|
||||
|
|
@ -10779,7 +10957,6 @@ server <- function(input, output, session) {
|
|||
shiny::req(rv$data_filtered)
|
||||
|
||||
rv$list$table1 <- NULL
|
||||
# rv$regression <- NULL
|
||||
}
|
||||
)
|
||||
|
||||
|
|
@ -10904,7 +11081,7 @@ server <- function(input, output, session) {
|
|||
rv$list$table1 <- rlang::exec(create_baseline, !!!append_list(rv$list$data, parameters, "data"))
|
||||
})
|
||||
|
||||
rv$code$table1 <- glue::glue("FreesearchR::create_baseline(data,{list2str(parameters)})")
|
||||
rv$code$table1 <- glue::glue("FreesearchR::create_baseline(df,{list2str(parameters)})")
|
||||
}
|
||||
)
|
||||
|
||||
|
|
@ -10956,7 +11133,7 @@ server <- function(input, output, session) {
|
|||
)
|
||||
})
|
||||
|
||||
data_missings_server(
|
||||
rv$missings <- data_missings_server(
|
||||
id = "missingness",
|
||||
data = shiny::reactive(rv$data_filtered),
|
||||
variable = shiny::reactive(input$missings_var)
|
||||
|
|
@ -10979,22 +11156,6 @@ server <- function(input, output, session) {
|
|||
|
||||
rv$regression <- regression_server("regression", data = shiny::reactive(rv$list$data))
|
||||
|
||||
# shiny::observeEvent(rv$regression, {
|
||||
# browser()
|
||||
# if (shiny::is.reactive(rv$regression)) {
|
||||
# rv$list$regression <- rv$regression()
|
||||
# } else {
|
||||
# rv$list$regression <- rv$regression
|
||||
# }
|
||||
# # rv$list$regression <- rv$regression()
|
||||
# })
|
||||
|
||||
# output$regression_models <- renderText({
|
||||
# req(rv$list$regression)
|
||||
# browser()
|
||||
# names(rv$list$regression)
|
||||
# })
|
||||
|
||||
##############################################################################
|
||||
#########
|
||||
######### Page navigation
|
||||
|
|
@ -11051,6 +11212,7 @@ server <- function(input, output, session) {
|
|||
format <- ifelse(type == "docx", "word_document", "odt_document")
|
||||
|
||||
rv$list$regression <- rv$regression()
|
||||
rv$list$missings <- rv$missings()
|
||||
|
||||
shiny::withProgress(message = "Generating the report. Hold on for a moment..", {
|
||||
tryCatch(
|
||||
|
|
|
|||
Binary file not shown.
Loading…
Add table
Reference in a new issue