This commit is contained in:
Andreas Gammelgaard Damsbo 2025-06-26 09:22:30 +02:00
parent c7a9467b47
commit 4c42636faa
No known key found for this signature in database
8 changed files with 371 additions and 201 deletions

View file

@ -64,8 +64,7 @@ Imports:
RcppArmadillo, RcppArmadillo,
ggcorrplot, ggcorrplot,
shinyjs, shinyjs,
emmeans, emmeans
visdat
Suggests: Suggests:
styler, styler,
devtools, devtools,

View file

@ -3,6 +3,7 @@
S3method(cut_var,default) S3method(cut_var,default)
S3method(cut_var,hms) S3method(cut_var,hms)
S3method(plot,tbl_regression) S3method(plot,tbl_regression)
export(FreesearchR_palette)
export(add_class_icon) export(add_class_icon)
export(add_sparkline) export(add_sparkline)
export(align_axes) export(align_axes)
@ -32,6 +33,7 @@ export(data_correlations_ui)
export(data_description) export(data_description)
export(data_missings_server) export(data_missings_server)
export(data_missings_ui) export(data_missings_ui)
export(data_summary_gather)
export(data_summary_server) export(data_summary_server)
export(data_summary_ui) export(data_summary_ui)
export(data_type) export(data_type)
@ -121,12 +123,15 @@ export(supported_plots)
export(symmetrical_scale_x_log10) export(symmetrical_scale_x_log10)
export(tbl_merge) export(tbl_merge)
export(type_icons) export(type_icons)
export(unique_short)
export(update_factor_server) export(update_factor_server)
export(update_factor_ui) export(update_factor_ui)
export(update_variables_server) export(update_variables_server)
export(update_variables_ui) export(update_variables_ui)
export(vectorSelectInput) export(vectorSelectInput)
export(vertical_stacked_bars) export(vertical_stacked_bars)
export(visual_summary)
export(visual_summary_ui)
export(wide2long) export(wide2long)
export(winbox_create_column) export(winbox_create_column)
export(winbox_update_factor) export(winbox_update_factor)

View file

@ -1,6 +1,6 @@
# FreesearchR 25.6.3 # 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. - *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.

View file

@ -1 +1 @@
hosted_version <- function()'v25.6.3-250625' hosted_version <- function()'v25.6.3-250626'

Binary file not shown.

View file

@ -43,6 +43,7 @@
|cardx |0.2.4 |2025-04-12 |CRAN (R 4.4.1) | |cardx |0.2.4 |2025-04-12 |CRAN (R 4.4.1) |
|caTools |1.18.3 |2024-09-04 |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) | |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) | |checkmate |2.3.2 |2024-07-29 |CRAN (R 4.4.0) |
|class |7.3-23 |2025-01-01 |CRAN (R 4.4.1) | |class |7.3-23 |2025-01-01 |CRAN (R 4.4.1) |
|classInt |0.4-11 |2025-01-08 |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) | |iterators |1.0.14 |2022-02-05 |CRAN (R 4.4.1) |
|jquerylib |0.1.4 |2021-04-26 |CRAN (R 4.4.0) | |jquerylib |0.1.4 |2021-04-26 |CRAN (R 4.4.0) |
|jsonlite |2.0.0 |2025-03-27 |CRAN (R 4.4.1) | |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) | |KernSmooth |2.23-26 |2025-01-01 |CRAN (R 4.4.1) |
|keyring |1.3.2 |2023-12-11 |CRAN (R 4.4.0) | |keyring |1.3.2 |2023-12-11 |CRAN (R 4.4.0) |
|knitr |1.50 |2025-03-16 |CRAN (R 4.4.1) | |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) | |R6 |2.6.1 |2025-02-15 |CRAN (R 4.4.1) |
|ragg |1.4.0 |2025-04-10 |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) | |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) | |rbibutils |2.3 |2024-10-04 |CRAN (R 4.4.1) |
|RColorBrewer |1.1-3 |2022-04-03 |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) | |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) | |urlchecker |1.0.1 |2021-11-30 |CRAN (R 4.4.1) |
|usethis |3.1.0 |2024-11-26 |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) | |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) | |vctrs |0.6.5 |2023-12-01 |CRAN (R 4.4.0) |
|visdat |0.6.0 |2023-02-02 |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) | |vroom |1.6.5 |2023-12-05 |CRAN (R 4.4.0) |

View file

@ -3996,7 +3996,7 @@ simple_snake <- function(data){
#### Current file: /Users/au301842/FreesearchR/R//hosted_version.R #### 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) variabler <- if (is.reactive(variable)) variable else reactive(variable)
rv <- shiny::reactiveValues( rv <- shiny::reactiveValues(
data = NULL data = NULL,
table = NULL
) )
rv$data <- shiny::reactive({ rv$data <- shiny::reactive({
@ -4726,15 +4727,25 @@ data_missings_server <- function(id,
shiny::req(variabler) shiny::req(variabler)
if (is.null(variabler()) || variabler() == "" || !variabler() %in% names(datar())) { if (is.null(variabler()) || variabler() == "" || !variabler() %in% names(datar())) {
if (anyNA(datar())){
title <- "No variable chosen for analysis"
} else {
title <- "No missing observations" title <- "No missing observations"
}
} else { } else {
title <- paste("Missing vs non-missing observations in", variabler()) title <- glue::glue("Missing vs non-missing observations in the variable **'{variabler()}'**")
} }
rv$data() |> out <- rv$data() |>
gtsummary::as_gt() |> gtsummary::as_gt() |>
gt::tab_header(title = gt::md(title)) 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)) 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, { observeEvent(input$modal_missings, {
tryCatch( tryCatch(
{ {
modal_visual_missings(data = data_demo, id = "modal_missings") modal_visual_summary(id = "visual")
}, },
error = function(err) { error = function(err) {
showNotification(paste0("We encountered the following error browsing your data: ", err), type = "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() 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", secondary = "#FF6F61",
success = "#00C896", success = "#00C896",
warning = "#FFB100", warning = "#FFB100",
danger = "#FF3A2F", danger = "#CC2E25",
extra = "#8A4FFF", extra = "#8A4FFF",
info = "#11A0EC", info = "#11A0EC",
bg = "#FFFFFF", 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 #### Current file: /Users/au301842/FreesearchR/R//wide2long.R
######## ########
@ -9796,7 +9989,7 @@ ui_elements <- list(
shiny::column( shiny::column(
width = 3, width = 3,
shiny::actionButton( shiny::actionButton(
inputId = "modal_missings", inputId = "modal_visual_overview",
label = "Visual overview", label = "Visual overview",
width = "100%", width = "100%",
disabled = TRUE disabled = TRUE
@ -10323,6 +10516,7 @@ server <- function(input, output, session) {
rv <- shiny::reactiveValues( rv <- shiny::reactiveValues(
list = list(), list = list(),
regression = NULL, regression = NULL,
missings = NULL,
ds = NULL, ds = NULL,
local_temp = NULL, local_temp = NULL,
ready = 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( data_file <- import_file_server(
id = "file_import", id = "file_import",
show_data_in = "popup", show_data_in = "popup",
@ -10386,16 +10558,6 @@ server <- function(input, output, session) {
rv$code <- modifyList(x = rv$code, list(import = from_redcap$code())) 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( from_env <- datamods::import_globalenv_server(
id = "env", id = "env",
trigger_return = "change", trigger_return = "change",
@ -10410,11 +10572,20 @@ server <- function(input, output, session) {
rv$code <- modifyList(x = rv$code, list(import = from_env$name())) 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, { observeEvent(input$modal_initial_view, {
tryCatch( tryCatch(
{ {
modal_visual_missings( modal_visual_summary(
data = default_parsing(rv$data_temp), id = "initial_summary",
footer = NULL, footer = NULL,
size = "xl" size = "xl"
) )
@ -10497,12 +10668,12 @@ server <- function(input, output, session) {
if (is.null(rv$data_original) | NROW(rv$data_original) == 0) { if (is.null(rv$data_original) | NROW(rv$data_original) == 0) {
shiny::updateActionButton(inputId = "act_start", disabled = TRUE) shiny::updateActionButton(inputId = "act_start", disabled = TRUE)
shiny::updateActionButton(inputId = "modal_browse", 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) shiny::updateActionButton(inputId = "act_eval", disabled = TRUE)
} else { } else {
shiny::updateActionButton(inputId = "act_start", disabled = FALSE) shiny::updateActionButton(inputId = "act_start", disabled = FALSE)
shiny::updateActionButton(inputId = "modal_browse", 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) shiny::updateActionButton(inputId = "act_eval", disabled = FALSE)
} }
}) })
@ -10548,7 +10719,6 @@ server <- function(input, output, session) {
) )
}) })
######### #########
######### Modifications ######### 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( tryCatch(
{ {
modal_visual_missings( modal_visual_summary(
data = REDCapCAST::fct_drop(rv$data_filtered), 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.", 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" size = "xl"
) )
@ -10756,7 +10935,6 @@ server <- function(input, output, session) {
) )
}) })
output$original_str <- renderPrint({ output$original_str <- renderPrint({
str(rv$data_original) str(rv$data_original)
}) })
@ -10779,7 +10957,6 @@ server <- function(input, output, session) {
shiny::req(rv$data_filtered) shiny::req(rv$data_filtered)
rv$list$table1 <- NULL 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$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)})")
} }
) )
@ -10951,12 +11128,12 @@ server <- function(input, output, session) {
label = "Select variable to stratify analysis", label = "Select variable to stratify analysis",
data = shiny::reactive({ data = shiny::reactive({
shiny::req(rv$data_filtered) shiny::req(rv$data_filtered)
rv$data_filtered[apply(rv$data_filtered,2,anyNA)] rv$data_filtered[apply(rv$data_filtered, 2, anyNA)]
})() })()
) )
}) })
data_missings_server( rv$missings <- data_missings_server(
id = "missingness", id = "missingness",
data = shiny::reactive(rv$data_filtered), data = shiny::reactive(rv$data_filtered),
variable = shiny::reactive(input$missings_var) 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)) 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 ######### Page navigation
@ -11051,6 +11212,7 @@ server <- function(input, output, session) {
format <- ifelse(type == "docx", "word_document", "odt_document") format <- ifelse(type == "docx", "word_document", "odt_document")
rv$list$regression <- rv$regression() rv$list$regression <- rv$regression()
rv$list$missings <- rv$missings()
shiny::withProgress(message = "Generating the report. Hold on for a moment..", { shiny::withProgress(message = "Generating the report. Hold on for a moment..", {
tryCatch( tryCatch(