mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2026-06-19 04:27:30 +02:00
bumped to 25.2.1 - new visuals tab - all functions in place - code cleanup has started
This commit is contained in:
parent
c4b5a7ba79
commit
14edce9912
36 changed files with 3564 additions and 2976 deletions
|
|
@ -1 +1 @@
|
|||
app_version <- function()'250207_1709'
|
||||
app_version <- function()'250225_0948'
|
||||
|
|
|
|||
82
R/columnSelectInput.R
Normal file
82
R/columnSelectInput.R
Normal file
|
|
@ -0,0 +1,82 @@
|
|||
#' A selectizeInput customized for data frames with column labels
|
||||
#'
|
||||
#' @description
|
||||
#' Copied and modified from the IDEAFilter package
|
||||
#' Adds the option to select "none" which is handled later
|
||||
#'
|
||||
#' @param inputId passed to \code{\link[shiny]{selectizeInput}}
|
||||
#' @param label passed to \code{\link[shiny]{selectizeInput}}
|
||||
#' @param data \code{data.frame} object from which fields should be populated
|
||||
#' @param selected default selection
|
||||
#' @param ... passed to \code{\link[shiny]{selectizeInput}}
|
||||
#' @param col_subset a \code{vector} containing the list of allowable columns to select
|
||||
#' @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
|
||||
#'
|
||||
#' @return a \code{\link[shiny]{selectizeInput}} dropdown element
|
||||
#'
|
||||
#' @importFrom shiny selectizeInput
|
||||
#' @keywords internal
|
||||
#'
|
||||
columnSelectInput <- function(inputId, label, data, selected = "", ...,
|
||||
col_subset = NULL, placeholder = "", onInitialize, none_label="No variable selected") {
|
||||
datar <- if (is.reactive(data)) data else reactive(data)
|
||||
col_subsetr <- if (is.reactive(col_subset)) col_subset else reactive(col_subset)
|
||||
|
||||
labels <- Map(function(col) {
|
||||
json <- sprintf(
|
||||
IDEAFilter:::strip_leading_ws('
|
||||
{
|
||||
"name": "%s",
|
||||
"label": "%s",
|
||||
"datatype": "%s"
|
||||
}'),
|
||||
col,
|
||||
attr(datar()[[col]], "label") %||% "",
|
||||
IDEAFilter:::get_dataFilter_class(datar()[[col]])
|
||||
)
|
||||
}, col = names(datar()))
|
||||
|
||||
if (!"none" %in% names(datar())){
|
||||
labels <- c("none"=list(sprintf('\n {\n \"name\": \"none\",\n \"label\": \"%s\",\n \"datatype\": \"\"\n }',none_label)),labels)
|
||||
choices <- setNames(names(labels), labels)
|
||||
choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) names(datar()) else col_subsetr(), choices)]
|
||||
} else {
|
||||
choices <- setNames(names(datar()), labels)
|
||||
choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) choices else col_subsetr(), choices)]
|
||||
}
|
||||
|
||||
shiny::selectizeInput(
|
||||
inputId = inputId,
|
||||
label = label,
|
||||
choices = choices,
|
||||
selected = selected,
|
||||
...,
|
||||
options = c(
|
||||
list(render = I("{
|
||||
// format the way that options are rendered
|
||||
option: function(item, escape) {
|
||||
item.data = JSON.parse(item.label);
|
||||
return '<div style=\"padding: 3px 12px\">' +
|
||||
'<div><strong>' +
|
||||
escape(item.data.name) + ' ' +
|
||||
'<span style=\"opacity: 0.3;\"><code style=\"color: black;\"> ' +
|
||||
item.data.datatype +
|
||||
'</code></span>' +
|
||||
'</strong></div>' +
|
||||
(item.data.label != '' ? '<div style=\"line-height: 1em;\"><small>' + escape(item.data.label) + '</small></div>' : '') +
|
||||
'</div>';
|
||||
},
|
||||
|
||||
// avoid data vomit splashing on screen when an option is selected
|
||||
item: function(item, escape) {
|
||||
item.data = JSON.parse(item.label);
|
||||
return '<div>' +
|
||||
escape(item.data.name) +
|
||||
'</div>';
|
||||
}
|
||||
}"))
|
||||
)
|
||||
)
|
||||
}
|
||||
51
R/contrast_text.R
Normal file
51
R/contrast_text.R
Normal file
|
|
@ -0,0 +1,51 @@
|
|||
#' @title Contrast Text Color
|
||||
#' @description Calculates the best contrast text color for a given
|
||||
#' background color.
|
||||
#' @param background A hex/named color value that represents the background.
|
||||
#' @param light_text A hex/named color value that represents the light text
|
||||
#' color.
|
||||
#' @param dark_text A hex/named color value that represents the dark text color.
|
||||
#' @param threshold A numeric value between 0 and 1 that is used to determine
|
||||
#' the luminance threshold of the background color for text color.
|
||||
#' @param method A character string that specifies the method for calculating
|
||||
#' the luminance. Three different methods are available:
|
||||
#' c("relative","perceived","perceived_2")
|
||||
#' @param ... parameter overflow. Ignored.
|
||||
#' @details
|
||||
#' This function aids in deciding the font color to print on a given background.
|
||||
#' The function is based on the example provided by teppo:
|
||||
#' https://stackoverflow.com/a/66669838/21019325.
|
||||
#' The different methods provided are based on the methods outlined in the
|
||||
#' StackOverflow thread:
|
||||
#' https://stackoverflow.com/questions/596216/formula-to-determine-perceived-brightness-of-rgb-color
|
||||
#' @return A character string that contains the best contrast text color.
|
||||
#' @examples
|
||||
#' contrast_text(c("#F2F2F2", "blue"))
|
||||
#'
|
||||
#' contrast_text(c("#F2F2F2", "blue"), method="relative")
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom grDevices col2rgb
|
||||
#'
|
||||
contrast_text <- function(background,
|
||||
light_text = 'white',
|
||||
dark_text = 'black',
|
||||
threshold = 0.5,
|
||||
method = "perceived_2",
|
||||
...) {
|
||||
if (method == "relative") {
|
||||
luminance <-
|
||||
c(c(.2126, .7152, .0722) %*% grDevices::col2rgb(background) / 255)
|
||||
} else if (method == "perceived") {
|
||||
luminance <-
|
||||
c(c(.299, .587, .114) %*% grDevices::col2rgb(background) / 255)
|
||||
} else if (method == "perceived_2") {
|
||||
luminance <- c(sqrt(colSums((
|
||||
c(.299, .587, .114) * grDevices::col2rgb(background)
|
||||
) ^ 2)) / 255)
|
||||
}
|
||||
|
||||
ifelse(luminance < threshold,
|
||||
light_text,
|
||||
dark_text)
|
||||
}
|
||||
619
R/data_plots.R
Normal file
619
R/data_plots.R
Normal file
|
|
@ -0,0 +1,619 @@
|
|||
# source(here::here("functions.R"))
|
||||
|
||||
#' Data correlations evaluation module
|
||||
#'
|
||||
#' @param id Module id. (Use 'ns("id")')
|
||||
#'
|
||||
#' @name data-correlations
|
||||
#' @returns Shiny ui module
|
||||
#' @export
|
||||
#'
|
||||
data_visuals_ui <- function(id, tab_title="Plots", ...) {
|
||||
ns <- shiny::NS(id)
|
||||
|
||||
# bslib::navset_bar(
|
||||
list(
|
||||
|
||||
# Sidebar with a slider input
|
||||
sidebar = bslib::sidebar(
|
||||
bslib::accordion(
|
||||
multiple = FALSE,
|
||||
bslib::accordion_panel(
|
||||
title = "Creating plot",
|
||||
icon = bsicons::bs_icon("graph-up"),
|
||||
shiny::uiOutput(outputId = ns("primary")),
|
||||
shiny::uiOutput(outputId = ns("type")),
|
||||
shiny::uiOutput(outputId = ns("secondary")),
|
||||
shiny::uiOutput(outputId = ns("tertiary"))
|
||||
),
|
||||
bslib::accordion_panel(
|
||||
title = "Advanced",
|
||||
icon = bsicons::bs_icon("gear")
|
||||
),
|
||||
bslib::accordion_panel(
|
||||
title = "Download",
|
||||
icon = bsicons::bs_icon("download"),
|
||||
shinyWidgets::noUiSliderInput(
|
||||
inputId = ns("height"),
|
||||
label = "Plot height (mm)",
|
||||
min = 50,
|
||||
max = 300,
|
||||
value = 100,
|
||||
step = 1,
|
||||
format = shinyWidgets::wNumbFormat(decimals=0),
|
||||
color = datamods:::get_primary_color()
|
||||
),
|
||||
shinyWidgets::noUiSliderInput(
|
||||
inputId = ns("width"),
|
||||
label = "Plot width (mm)",
|
||||
min = 50,
|
||||
max = 300,
|
||||
value = 100,
|
||||
step = 1,
|
||||
format = shinyWidgets::wNumbFormat(decimals=0),
|
||||
color = datamods:::get_primary_color()
|
||||
),
|
||||
shiny::selectInput(
|
||||
inputId = ns("plot_type"),
|
||||
label = "File format",
|
||||
choices = list(
|
||||
"png",
|
||||
"tiff",
|
||||
"eps",
|
||||
"pdf",
|
||||
"jpeg",
|
||||
"svg"
|
||||
)
|
||||
),
|
||||
shiny::br(),
|
||||
# Button
|
||||
shiny::downloadButton(
|
||||
outputId = ns("download_plot"),
|
||||
label = "Download plot",
|
||||
icon = shiny::icon("download")
|
||||
)
|
||||
)
|
||||
)
|
||||
),
|
||||
bslib::nav_panel(
|
||||
title = tab_title,
|
||||
shiny::plotOutput(ns("plot"))
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
#'
|
||||
#' @param data data
|
||||
#' @param ... ignored
|
||||
#'
|
||||
#' @name data-correlations
|
||||
#' @returns shiny server module
|
||||
#' @export
|
||||
data_visuals_server <- function(id,
|
||||
data,
|
||||
...) {
|
||||
shiny::moduleServer(
|
||||
id = id,
|
||||
module = function(input, output, session) {
|
||||
ns <- session$ns
|
||||
|
||||
rv <- shiny::reactiveValues(
|
||||
plot.params = NULL,
|
||||
plot = NULL
|
||||
)
|
||||
|
||||
output$primary <- shiny::renderUI({
|
||||
columnSelectInput(
|
||||
inputId = ns("primary"),
|
||||
data = data,
|
||||
placeholder = "Select variable",
|
||||
label = "Response variable",
|
||||
multiple = FALSE
|
||||
)
|
||||
})
|
||||
|
||||
|
||||
output$type <- 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
|
||||
)
|
||||
|
||||
shiny::selectizeInput(
|
||||
inputId = ns("type"),
|
||||
selected = NULL,
|
||||
label = shiny::h4("Plot type"),
|
||||
choices = plots,
|
||||
multiple = FALSE
|
||||
)
|
||||
})
|
||||
|
||||
rv$plot.params <- shiny::reactive({
|
||||
get_plot_options(input$type)
|
||||
})
|
||||
|
||||
output$secondary <- shiny::renderUI({
|
||||
shiny::req(input$type)
|
||||
# browser()
|
||||
|
||||
columnSelectInput(
|
||||
inputId = ns("secondary"),
|
||||
data = data,
|
||||
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
|
||||
)
|
||||
),
|
||||
none_label = "No variable"
|
||||
)
|
||||
|
||||
})
|
||||
|
||||
output$tertiary <- shiny::renderUI({
|
||||
shiny::req(input$type)
|
||||
columnSelectInput(
|
||||
inputId = ns("tertiary"),
|
||||
data = data,
|
||||
placeholder = "Select variable",
|
||||
label = "Strata variable",
|
||||
multiple = FALSE,
|
||||
col_subset = c(
|
||||
"none",
|
||||
all_but(
|
||||
colnames(subset_types(
|
||||
data(),
|
||||
purrr::pluck(rv$plot.params(), 1)[["tertiary.type"]]
|
||||
)),
|
||||
input$primary,
|
||||
input$secondary
|
||||
)
|
||||
),
|
||||
none_label = "No stratification"
|
||||
)
|
||||
})
|
||||
|
||||
rv$plot <- shiny::reactive({
|
||||
shiny::req(input$primary)
|
||||
shiny::req(input$type)
|
||||
shiny::req(input$secondary)
|
||||
shiny::req(input$tertiary)
|
||||
create_plot(
|
||||
data = data(),
|
||||
type = names(rv$plot.params()),
|
||||
x = input$primary,
|
||||
y = input$secondary,
|
||||
z = input$tertiary
|
||||
)
|
||||
})
|
||||
|
||||
output$plot <- shiny::renderPlot({
|
||||
rv$plot()
|
||||
})
|
||||
|
||||
output$download_plot <- shiny::downloadHandler(
|
||||
filename = shiny::reactive({
|
||||
paste0("plot.", input$plot_type)
|
||||
}),
|
||||
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)
|
||||
})
|
||||
}
|
||||
)
|
||||
|
||||
|
||||
shiny::observe(
|
||||
return(rv$plot)
|
||||
)
|
||||
}
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
|
||||
#' Select all from vector but
|
||||
#'
|
||||
#' @param data vector
|
||||
#' @param ... exclude
|
||||
#'
|
||||
#' @returns
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' all_but(1:10, c(2, 3), 11, 5)
|
||||
all_but <- function(data, ...) {
|
||||
data[!data %in% c(...)]
|
||||
}
|
||||
|
||||
#' Easily subset by data type function
|
||||
#'
|
||||
#' @param data data
|
||||
#' @param types desired types
|
||||
#' @param type.fun function to get type. Default is outcome_type
|
||||
#'
|
||||
#' @returns
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' default_parsing(mtcars) |> subset_types("ordinal")
|
||||
#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal"))
|
||||
#' #' default_parsing(mtcars) |> subset_types("factor",class)
|
||||
subset_types <- function(data, types, type.fun = outcome_type) {
|
||||
data[sapply(data, type.fun) %in% types]
|
||||
}
|
||||
|
||||
|
||||
#' Implemented functions
|
||||
#'
|
||||
#' @description
|
||||
#' Library of supported functions. The list name and "descr" element should be
|
||||
#' unique for each element on list.
|
||||
#'
|
||||
#' - descr: Plot description
|
||||
#'
|
||||
#' - primary.type: Primary variable data type (continuous, dichotomous or ordinal)
|
||||
#'
|
||||
#' - secondary.type: Secondary variable data type (continuous, dichotomous or ordinal)
|
||||
#'
|
||||
#' - secondary.extra: "none" or NULL to have option to choose none.
|
||||
#'
|
||||
#' - tertiary.type: Tertiary variable data type (continuous, dichotomous or ordinal)
|
||||
#'
|
||||
#'
|
||||
#' @returns list
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' supported_plots() |> str()
|
||||
supported_plots <- function() {
|
||||
list(
|
||||
plot_hbars = list(
|
||||
descr = "Stacked horizontal bars (Grotta bars)",
|
||||
primary.type = c("dichotomous", "ordinal"),
|
||||
secondary.type = c("dichotomous", "ordinal"),
|
||||
tertiary.type = c("dichotomous", "ordinal"),
|
||||
secondary.extra = "none"
|
||||
),
|
||||
plot_violin = list(
|
||||
descr = "Violin plot",
|
||||
primary.type = c("continuous", "dichotomous", "ordinal"),
|
||||
secondary.type = c("dichotomous", "ordinal"),
|
||||
tertiary.type = c("dichotomous", "ordinal"),
|
||||
secondary.extra = "none"
|
||||
),
|
||||
plot_ridge = list(
|
||||
descr = "Ridge plot",
|
||||
primary.type = "continuous",
|
||||
secondary.type = c("dichotomous", "ordinal"),
|
||||
tertiary.type = c("dichotomous", "ordinal"),
|
||||
secondary.extra = NULL
|
||||
),
|
||||
plot_scatter = list(
|
||||
descr = "Scatter plot",
|
||||
primary.type = "continuous",
|
||||
secondary.type = c("continuous", "ordinal"),
|
||||
tertiary.type = c("dichotomous", "ordinal"),
|
||||
secondary.extra = NULL
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
#' Title
|
||||
#'
|
||||
#' @returns
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' plot_ridge(x = "mpg", y = "cyl")
|
||||
#' mtcars |> plot_ridge(x = "mpg", y = "cyl", z = "gear")
|
||||
plot_ridge <- function(data, x, y, z = NULL, ...) {
|
||||
if (!is.null(z)) {
|
||||
ds <- split(data, data[z])
|
||||
} else {
|
||||
ds <- list(data)
|
||||
}
|
||||
|
||||
out <- lapply(ds, \(.ds){
|
||||
ggplot2::ggplot(.ds, ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y))) +
|
||||
ggridges::geom_density_ridges() +
|
||||
ggridges::theme_ridges() +
|
||||
ggplot2::theme(legend.position = "none") |> rempsyc:::theme_apa()
|
||||
})
|
||||
|
||||
patchwork::wrap_plots(out)
|
||||
}
|
||||
|
||||
|
||||
#' Get possible regression models
|
||||
#'
|
||||
#' @param data data
|
||||
#'
|
||||
#' @returns character vector
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' dplyr::pull("cyl") |>
|
||||
#' possible_plots()
|
||||
#'
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' dplyr::select("mpg") |>
|
||||
#' possible_plots()
|
||||
possible_plots <- function(data) {
|
||||
# browser()
|
||||
if (is.data.frame(data)) {
|
||||
data <- data[[1]]
|
||||
}
|
||||
|
||||
type <- outcome_type(data)
|
||||
|
||||
if (type == "unknown") {
|
||||
out <- type
|
||||
} else {
|
||||
out <- supported_plots() |>
|
||||
lapply(\(.x){
|
||||
if (type %in% .x$primary.type) {
|
||||
.x$descr
|
||||
}
|
||||
}) |>
|
||||
unlist()
|
||||
}
|
||||
unname(out)
|
||||
}
|
||||
|
||||
#' Get the function options based on the selected function description
|
||||
#'
|
||||
#' @param data vector
|
||||
#'
|
||||
#' @returns list
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' ls <- mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' dplyr::pull(mpg) |>
|
||||
#' possible_plots() |>
|
||||
#' (\(.x){
|
||||
#' .x[[1]]
|
||||
#' })() |>
|
||||
#' get_plot_options()
|
||||
get_plot_options <- function(data) {
|
||||
descrs <- supported_plots() |>
|
||||
lapply(\(.x){
|
||||
.x$descr
|
||||
}) |>
|
||||
unlist()
|
||||
supported_plots() |>
|
||||
(\(.x){
|
||||
.x[match(data, descrs)]
|
||||
})()
|
||||
}
|
||||
|
||||
|
||||
|
||||
#' Wrapper to create plot based on provided type
|
||||
#'
|
||||
#' @param type plot type (derived from possible_plots() and matches custom function)
|
||||
#' @param ... ignored for now
|
||||
#'
|
||||
#' @returns
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' create_plot(mtcars, "plot_violin", "mpg", "cyl")
|
||||
create_plot <- function(data, type, x, y, z = NULL, ...) {
|
||||
if (!y %in% names(data)) {
|
||||
y <- NULL
|
||||
}
|
||||
|
||||
if (!z %in% names(data)) {
|
||||
z <- NULL
|
||||
}
|
||||
|
||||
do.call(
|
||||
type,
|
||||
list(data, x, y, z, ...)
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
#' Nice horizontal stacked bars (Grotta bars)
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_hbars(x = "carb", y = "cyl")
|
||||
#' mtcars |> plot_hbars(x = "carb", y = NULL)
|
||||
plot_hbars <- function(data, x, y, z = NULL) {
|
||||
out <- vertical_stacked_bars(data = data, score = x, group = y, strata = z)
|
||||
|
||||
out
|
||||
}
|
||||
|
||||
|
||||
#' Vertical stacked bar plot wrapper
|
||||
#'
|
||||
#' @param data
|
||||
#' @param score
|
||||
#' @param group
|
||||
#' @param strata
|
||||
#' @param t.size
|
||||
#'
|
||||
#' @return
|
||||
#' @export
|
||||
#'
|
||||
vertical_stacked_bars <- function(data,
|
||||
score = "full_score",
|
||||
group = "pase_0_q",
|
||||
strata = NULL,
|
||||
t.size = 10,
|
||||
l.color = "black",
|
||||
l.size = .5,
|
||||
draw.lines = TRUE) {
|
||||
if (is.null(group)) {
|
||||
df.table <- data[c(score, group, strata)] |>
|
||||
dplyr::mutate("All" = 1) |>
|
||||
table()
|
||||
group <- "All"
|
||||
draw.lines <- FALSE
|
||||
} else {
|
||||
df.table <- data[c(score, group, strata)] |>
|
||||
table()
|
||||
}
|
||||
|
||||
p <- df.table |>
|
||||
rankinPlot::grottaBar(
|
||||
scoreName = score,
|
||||
groupName = group,
|
||||
textColor = c("black", "white"),
|
||||
strataName = strata,
|
||||
textCut = 6,
|
||||
textSize = 20,
|
||||
printNumbers = "none",
|
||||
lineSize = l.size,
|
||||
returnData = TRUE
|
||||
)
|
||||
|
||||
colors <- viridisLite::viridis(nrow(df.table))
|
||||
contrast_cut <-
|
||||
sum(contrast_text(colors, threshold = .3) == "white")
|
||||
|
||||
score_label <- ifelse(is.na(REDCapCAST::get_attr(data$score, "label")), score, REDCapCAST::get_attr(data$score, "label"))
|
||||
group_label <- ifelse(is.na(REDCapCAST::get_attr(data$group, "label")), group, REDCapCAST::get_attr(data$group, "label"))
|
||||
|
||||
|
||||
p |>
|
||||
(\(.x){
|
||||
.x$plot +
|
||||
ggplot2::geom_text(
|
||||
data = .x$rectData[which(.x$rectData$n >
|
||||
0), ],
|
||||
size = t.size,
|
||||
fontface = "plain",
|
||||
ggplot2::aes(
|
||||
x = group,
|
||||
y = p_prev + 0.49 * p,
|
||||
color = as.numeric(score) > contrast_cut,
|
||||
# label = paste0(sprintf("%2.0f", 100 * p),"%"),
|
||||
label = sprintf("%2.0f", 100 * p)
|
||||
)
|
||||
) +
|
||||
ggplot2::labs(fill = score_label) +
|
||||
ggplot2::scale_fill_manual(values = rev(colors)) +
|
||||
ggplot2::theme(
|
||||
legend.position = "bottom",
|
||||
axis.title = ggplot2::element_text(),
|
||||
) +
|
||||
ggplot2::xlab(group_label) +
|
||||
ggplot2::ylab(NULL)
|
||||
# viridis::scale_fill_viridis(discrete = TRUE, direction = -1, option = "D")
|
||||
})()
|
||||
}
|
||||
|
||||
|
||||
#' Print label, and if missing print variable name
|
||||
#'
|
||||
#' @param data vector or data frame
|
||||
#'
|
||||
#' @returns character string
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> get_label(var = "mpg")
|
||||
#' mtcars$mpg |> get_label()
|
||||
#' gtsummary::trial |> get_label(var = "trt")
|
||||
#' 1:10 |> get_label()
|
||||
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)))
|
||||
}
|
||||
}
|
||||
out
|
||||
}
|
||||
|
||||
|
||||
#' Beatiful violin plot
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear")
|
||||
plot_violin <- function(data, x, y, z = NULL) {
|
||||
if (!is.null(z)) {
|
||||
ds <- split(data, data[z])
|
||||
} else {
|
||||
ds <- list(data)
|
||||
}
|
||||
|
||||
out <- lapply(ds, \(.ds){
|
||||
rempsyc::nice_violin(
|
||||
data = .ds,
|
||||
group = y,
|
||||
response = x, xtitle = get_label(data, var = x), ytitle = get_label(data, var = y)
|
||||
)
|
||||
})
|
||||
|
||||
patchwork::wrap_plots(out)
|
||||
}
|
||||
|
||||
|
||||
#' Beatiful violin plot
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_scatter(x = "mpg", y = "wt")
|
||||
plot_scatter <- function(data, x, y, z = NULL) {
|
||||
if (is.null(z)) {
|
||||
rempsyc::nice_scatter(
|
||||
data = data,
|
||||
predictor = y,
|
||||
response = x, xtitle = get_label(data, var = x), ytitle = get_label(data, var = y)
|
||||
)
|
||||
} else {
|
||||
rempsyc::nice_scatter(
|
||||
data = data,
|
||||
predictor = y,
|
||||
response = x,
|
||||
group = z
|
||||
)
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -95,31 +95,31 @@ file_app <- function() {
|
|||
|
||||
file_app()
|
||||
|
||||
tdm_data_upload <- teal::teal_data_module(
|
||||
ui <- function(id) {
|
||||
shiny::fluidPage(
|
||||
m_datafileUI(id)
|
||||
)
|
||||
},
|
||||
server = function(id) {
|
||||
m_datafileServer(id, output.format = "teal")
|
||||
}
|
||||
)
|
||||
|
||||
tdm_data_read <- teal::teal_data_module(
|
||||
ui <- function(id) {
|
||||
shiny::fluidPage(
|
||||
m_redcap_readUI(id = "redcap")
|
||||
)
|
||||
},
|
||||
server = function(id) {
|
||||
moduleServer(
|
||||
id,
|
||||
function(input, output, session) {
|
||||
ns <- session$ns
|
||||
|
||||
m_redcap_readServer(id = "redcap", output.format = "teal")
|
||||
}
|
||||
)
|
||||
}
|
||||
)
|
||||
# tdm_data_upload <- teal::teal_data_module(
|
||||
# ui <- function(id) {
|
||||
# shiny::fluidPage(
|
||||
# m_datafileUI(id)
|
||||
# )
|
||||
# },
|
||||
# server = function(id) {
|
||||
# m_datafileServer(id, output.format = "teal")
|
||||
# }
|
||||
# )
|
||||
#
|
||||
# tdm_data_read <- teal::teal_data_module(
|
||||
# ui <- function(id) {
|
||||
# shiny::fluidPage(
|
||||
# m_redcap_readUI(id = "redcap")
|
||||
# )
|
||||
# },
|
||||
# server = function(id) {
|
||||
# moduleServer(
|
||||
# id,
|
||||
# function(input, output, session) {
|
||||
# ns <- session$ns
|
||||
#
|
||||
# m_redcap_readServer(id = "redcap", output.format = "teal")
|
||||
# }
|
||||
# )
|
||||
# }
|
||||
# )
|
||||
|
|
|
|||
26
R/helpers.R
26
R/helpers.R
|
|
@ -266,3 +266,29 @@ remove_empty_cols <- function(data,cutoff=.7){
|
|||
}) >= cutoff
|
||||
data[filter]
|
||||
}
|
||||
|
||||
|
||||
#' Append list with named index
|
||||
#'
|
||||
#' @param data data to add to list
|
||||
#' @param list list
|
||||
#' @param index index name
|
||||
#'
|
||||
#' @returns list
|
||||
#'
|
||||
#' @examples
|
||||
#' ls_d <- list(test=c(1:20))
|
||||
#' ls_d <- list()
|
||||
#' data.frame(letters[1:20],1:20) |> append_list(ls_d,"letters")
|
||||
#' letters[1:20]|> append_list(ls_d,"letters")
|
||||
append_list <- function(data,list,index){
|
||||
## This will overwrite and not warn
|
||||
## Not very safe, but convenient to append code to list
|
||||
if (index %in% names(list)){
|
||||
list[[index]] <- data
|
||||
out <- list
|
||||
} else {
|
||||
out <- setNames(c(list,list(data)),c(names(list),index))
|
||||
}
|
||||
out
|
||||
}
|
||||
|
|
|
|||
|
|
@ -271,19 +271,19 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) {
|
|||
)
|
||||
}
|
||||
|
||||
#' REDCap import teal data module
|
||||
#'
|
||||
#' @rdname redcap_read_shiny_module
|
||||
tdm_redcap_read <- teal::teal_data_module(
|
||||
ui <- function(id) {
|
||||
shiny::fluidPage(
|
||||
m_redcap_readUI(id)
|
||||
)
|
||||
},
|
||||
server = function(id) {
|
||||
m_redcap_readServer(id, output.format = "teal")
|
||||
}
|
||||
)
|
||||
# #' REDCap import teal data module
|
||||
# #'
|
||||
# #' @rdname redcap_read_shiny_module
|
||||
# tdm_redcap_read <- teal::teal_data_module(
|
||||
# ui <- function(id) {
|
||||
# shiny::fluidPage(
|
||||
# m_redcap_readUI(id)
|
||||
# )
|
||||
# },
|
||||
# server = function(id) {
|
||||
# m_redcap_readServer(id, output.format = "teal")
|
||||
# }
|
||||
# )
|
||||
|
||||
|
||||
#' Test app for the redcap_read_shiny_module
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@
|
|||
#' shiny_freesearcheR(launch.browser = TRUE)
|
||||
#' }
|
||||
shiny_freesearcheR <- function(...) {
|
||||
appDir <- system.file("apps", "data_analysis_modules", package = "freesearcheR")
|
||||
appDir <- system.file("apps", "freesearcheR", package = "freesearcheR")
|
||||
if (appDir == "") {
|
||||
stop("Could not find the app directory. Try re-installing `freesearcheR`.", call. = FALSE)
|
||||
}
|
||||
|
|
|
|||
292
R/update-factor-ext.R
Normal file
292
R/update-factor-ext.R
Normal file
|
|
@ -0,0 +1,292 @@
|
|||
|
||||
## Works, but not implemented
|
||||
##
|
||||
## These edits mainly allows for
|
||||
|
||||
|
||||
#' @title Module to Reorder the Levels of a Factor Variable
|
||||
#'
|
||||
#' @description
|
||||
#' This module contain an interface to reorder the levels of a factor variable.
|
||||
#'
|
||||
#'
|
||||
#' @param id Module ID.
|
||||
#'
|
||||
#' @return A [shiny::reactive()] function returning the data.
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shiny NS fluidRow tagList column actionButton
|
||||
#' @importFrom shinyWidgets virtualSelectInput prettyCheckbox
|
||||
#' @importFrom toastui datagridOutput
|
||||
#' @importFrom htmltools tags
|
||||
#'
|
||||
#' @name update-factor
|
||||
#'
|
||||
#' @example examples/update_factor.R
|
||||
update_factor_ui <- function(id) {
|
||||
ns <- NS(id)
|
||||
tagList(
|
||||
tags$style(
|
||||
".tui-grid-row-header-draggable span {width: 3px !important; height: 3px !important;}"
|
||||
),
|
||||
fluidRow(
|
||||
column(
|
||||
width = 6,
|
||||
virtualSelectInput(
|
||||
inputId = ns("variable"),
|
||||
label = i18n("Factor variable to reorder:"),
|
||||
choices = NULL,
|
||||
width = "100%",
|
||||
zIndex = 50
|
||||
)
|
||||
),
|
||||
column(
|
||||
width = 3,
|
||||
class = "d-flex align-items-end",
|
||||
actionButton(
|
||||
inputId = ns("sort_levels"),
|
||||
label = tagList(
|
||||
ph("sort-ascending"),
|
||||
i18n("Sort by levels")
|
||||
),
|
||||
class = "btn-outline-primary mb-3",
|
||||
width = "100%"
|
||||
)
|
||||
),
|
||||
column(
|
||||
width = 3,
|
||||
class = "d-flex align-items-end",
|
||||
actionButton(
|
||||
inputId = ns("sort_occurrences"),
|
||||
label = tagList(
|
||||
ph("sort-ascending"),
|
||||
i18n("Sort by count")
|
||||
),
|
||||
class = "btn-outline-primary mb-3",
|
||||
width = "100%"
|
||||
)
|
||||
)
|
||||
),
|
||||
datagridOutput(ns("grid")),
|
||||
tags$div(
|
||||
class = "float-end",
|
||||
prettyCheckbox(
|
||||
inputId = ns("new_var"),
|
||||
label = i18n("Create a new variable (otherwise replaces the one selected)"),
|
||||
value = FALSE,
|
||||
status = "primary",
|
||||
outline = TRUE,
|
||||
inline = TRUE
|
||||
),
|
||||
actionButton(
|
||||
inputId = ns("create"),
|
||||
label = tagList(ph("arrow-clockwise"), i18n("Update factor variable")),
|
||||
class = "btn-outline-primary"
|
||||
)
|
||||
),
|
||||
tags$div(class = "clearfix")
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
#' @param data_r A [shiny::reactive()] function returning a `data.frame`.
|
||||
#'
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shiny moduleServer observeEvent reactive reactiveValues req bindEvent isTruthy updateActionButton
|
||||
#' @importFrom shinyWidgets updateVirtualSelect
|
||||
#' @importFrom toastui renderDatagrid datagrid grid_columns grid_colorbar
|
||||
#'
|
||||
#' @rdname update-factor
|
||||
update_factor_server <- function(id, data_r = reactive(NULL)) {
|
||||
moduleServer(
|
||||
id,
|
||||
function(input, output, session) {
|
||||
|
||||
rv <- reactiveValues(data = NULL, data_grid = NULL)
|
||||
|
||||
bindEvent(observe({
|
||||
data <- data_r()
|
||||
rv$data <- data
|
||||
vars_factor <- vapply(data, is.factor, logical(1))
|
||||
vars_factor <- names(vars_factor)[vars_factor]
|
||||
updateVirtualSelect(
|
||||
inputId = "variable",
|
||||
choices = vars_factor,
|
||||
selected = if (isTruthy(input$variable)) input$variable else vars_factor[1]
|
||||
)
|
||||
}), data_r(), input$hidden)
|
||||
|
||||
observeEvent(input$variable, {
|
||||
data <- req(data_r())
|
||||
variable <- req(input$variable)
|
||||
grid <- as.data.frame(table(data[[variable]]))
|
||||
rv$data_grid <- grid
|
||||
})
|
||||
|
||||
observeEvent(input$sort_levels, {
|
||||
if (input$sort_levels %% 2 == 1) {
|
||||
decreasing <- FALSE
|
||||
label <- tagList(
|
||||
ph("sort-descending"),
|
||||
"Sort Levels"
|
||||
)
|
||||
} else {
|
||||
decreasing <- TRUE
|
||||
label <- tagList(
|
||||
ph("sort-ascending"),
|
||||
"Sort Levels"
|
||||
)
|
||||
}
|
||||
updateActionButton(inputId = "sort_levels", label = as.character(label))
|
||||
rv$data_grid <- rv$data_grid[order(rv$data_grid[[1]], decreasing = decreasing), ]
|
||||
})
|
||||
|
||||
observeEvent(input$sort_occurrences, {
|
||||
if (input$sort_occurrences %% 2 == 1) {
|
||||
decreasing <- FALSE
|
||||
label <- tagList(
|
||||
ph("sort-descending"),
|
||||
i18n("Sort count")
|
||||
)
|
||||
} else {
|
||||
decreasing <- TRUE
|
||||
label <- tagList(
|
||||
ph("sort-ascending"),
|
||||
i18n("Sort count")
|
||||
)
|
||||
}
|
||||
updateActionButton(inputId = "sort_occurrences", label = as.character(label))
|
||||
rv$data_grid <- rv$data_grid[order(rv$data_grid[[2]], decreasing = decreasing), ]
|
||||
})
|
||||
|
||||
|
||||
output$grid <- renderDatagrid({
|
||||
req(rv$data_grid)
|
||||
gridTheme <- getOption("datagrid.theme")
|
||||
if (length(gridTheme) < 1) {
|
||||
datamods:::apply_grid_theme()
|
||||
}
|
||||
on.exit(toastui::reset_grid_theme())
|
||||
data <- rv$data_grid
|
||||
data <- add_var_toset(data, "Var1", "New label")
|
||||
|
||||
grid <- datagrid(
|
||||
data = data,
|
||||
draggable = TRUE,
|
||||
sortable = FALSE,
|
||||
data_as_input = TRUE
|
||||
)
|
||||
grid <- grid_columns(
|
||||
grid,
|
||||
columns = c("Var1", "Var1_toset", "Freq"),
|
||||
header = c(i18n("Levels"), "New label", i18n("Count"))
|
||||
)
|
||||
grid <- grid_colorbar(
|
||||
grid,
|
||||
column = "Freq",
|
||||
label_outside = TRUE,
|
||||
label_width = "30px",
|
||||
background = "#D8DEE9",
|
||||
bar_bg = datamods:::get_primary_color(),
|
||||
from = c(0, max(rv$data_grid$Freq) + 1)
|
||||
)
|
||||
grid <- toastui::grid_style_column(
|
||||
grid = grid,
|
||||
column = "Var1_toset",
|
||||
fontStyle = "italic"
|
||||
)
|
||||
grid <- toastui::grid_editor(
|
||||
grid = grid,
|
||||
column = "Var1_toset",
|
||||
type = "text"
|
||||
)
|
||||
grid
|
||||
})
|
||||
|
||||
data_updated_r <- reactive({
|
||||
data <- req(data_r())
|
||||
variable <- req(input$variable)
|
||||
grid <- req(input$grid_data)
|
||||
name_var <- if (isTRUE(input$new_var)) {
|
||||
paste0(variable, "_updated")
|
||||
} else {
|
||||
variable
|
||||
}
|
||||
data[[name_var]] <- factor(
|
||||
as.character(data[[variable]]),
|
||||
levels = grid[["Var1"]]
|
||||
)
|
||||
data[[name_var]] <- factor(
|
||||
data[[variable]],
|
||||
labels = ifelse(grid[["Var1_toset"]]=="New label",grid[["Var1"]],grid[["Var1_toset"]])
|
||||
)
|
||||
data
|
||||
})
|
||||
|
||||
data_returned_r <- observeEvent(input$create, {
|
||||
rv$data <- data_updated_r()
|
||||
})
|
||||
return(reactive(rv$data))
|
||||
}
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
|
||||
#' @inheritParams shiny::modalDialog
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shiny showModal modalDialog textInput
|
||||
#' @importFrom htmltools tagList
|
||||
#'
|
||||
#' @rdname update-factor
|
||||
modal_update_factor <- function(id,
|
||||
title = i18n("Update levels of a factor"),
|
||||
easyClose = TRUE,
|
||||
size = "l",
|
||||
footer = NULL) {
|
||||
ns <- NS(id)
|
||||
showModal(modalDialog(
|
||||
title = tagList(title, datamods:::button_close_modal()),
|
||||
update_factor_ui(id),
|
||||
tags$div(
|
||||
style = "display: none;",
|
||||
textInput(inputId = ns("hidden"), label = NULL, value = datamods:::genId())
|
||||
),
|
||||
easyClose = easyClose,
|
||||
size = size,
|
||||
footer = footer
|
||||
))
|
||||
}
|
||||
|
||||
|
||||
#' @inheritParams shinyWidgets::WinBox
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shinyWidgets WinBox wbOptions wbControls
|
||||
#' @importFrom htmltools tagList
|
||||
#' @rdname create-column
|
||||
winbox_update_factor <- function(id,
|
||||
title = i18n("Update levels of a factor"),
|
||||
options = shinyWidgets::wbOptions(),
|
||||
controls = shinyWidgets::wbControls()) {
|
||||
ns <- NS(id)
|
||||
WinBox(
|
||||
title = title,
|
||||
ui = tagList(
|
||||
update_factor_ui(id),
|
||||
tags$div(
|
||||
style = "display: none;",
|
||||
textInput(inputId = ns("hidden"), label = NULL, value = genId())
|
||||
)
|
||||
),
|
||||
options = modifyList(
|
||||
shinyWidgets::wbOptions(height = "615px", modal = TRUE),
|
||||
options
|
||||
),
|
||||
controls = controls,
|
||||
auto_height = FALSE
|
||||
)
|
||||
}
|
||||
|
||||
|
|
@ -367,8 +367,8 @@ summary_vars <- function(data) {
|
|||
name = names(data),
|
||||
label = lapply(data, \(.x) REDCapCAST::get_attr(.x, "label")) |> unlist(),
|
||||
class = get_classes(data),
|
||||
# n_missing = unname(colSums(is.na(data))),
|
||||
# p_complete = 1 - n_missing / nrow(data),
|
||||
n_missing = unname(colSums(is.na(data))),
|
||||
p_complete = 1 - n_missing / nrow(data),
|
||||
n_unique = get_n_unique(data)
|
||||
)
|
||||
|
||||
|
|
@ -440,11 +440,11 @@ update_variables_datagrid <- function(data, height = NULL, selectionId = NULL, b
|
|||
minWidth = 100
|
||||
)
|
||||
|
||||
# grid <- toastui::grid_format(
|
||||
# grid = grid,
|
||||
# "p_complete",
|
||||
# formatter = toastui::JS("function(obj) {return (obj.value*100).toFixed(0) + '%';}")
|
||||
# )
|
||||
grid <- toastui::grid_format(
|
||||
grid = grid,
|
||||
"p_complete",
|
||||
formatter = toastui::JS("function(obj) {return (obj.value*100).toFixed(0) + '%';}")
|
||||
)
|
||||
grid <- toastui::grid_style_column(
|
||||
grid = grid,
|
||||
column = "name_toset",
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue