mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2025-09-12 01:49:39 +02:00
renaming to cut function to cut_var to distinct from the base-version - UI improvements - nice code formatting.
This commit is contained in:
parent
8469a5ca64
commit
361296531e
30 changed files with 1247 additions and 1685 deletions
14
NAMESPACE
14
NAMESPACE
|
|
@ -1,11 +1,13 @@
|
|||
# Generated by roxygen2: do not edit by hand
|
||||
|
||||
S3method(cut,hms)
|
||||
S3method(cut_var,default)
|
||||
S3method(cut_var,hms)
|
||||
S3method(plot,tbl_regression)
|
||||
export(add_class_icon)
|
||||
export(add_sparkline)
|
||||
export(all_but)
|
||||
export(allign_axes)
|
||||
export(append_column)
|
||||
export(append_list)
|
||||
export(argsstring2list)
|
||||
export(baseline_table)
|
||||
|
|
@ -19,6 +21,7 @@ export(create_log_tics)
|
|||
export(create_overview_datagrid)
|
||||
export(create_plot)
|
||||
export(custom_theme)
|
||||
export(cut_var)
|
||||
export(cut_variable_server)
|
||||
export(cut_variable_ui)
|
||||
export(data_correlations_server)
|
||||
|
|
@ -60,7 +63,6 @@ export(is_valid_token)
|
|||
export(launch_FreesearchR)
|
||||
export(limit_log)
|
||||
export(line_break)
|
||||
export(m_datafileUI)
|
||||
export(m_redcap_readServer)
|
||||
export(m_redcap_readUI)
|
||||
export(merge_expression)
|
||||
|
|
@ -70,6 +72,7 @@ export(modal_cut_variable)
|
|||
export(modal_update_factor)
|
||||
export(modify_qmd)
|
||||
export(overview_vars)
|
||||
export(pipe_string)
|
||||
export(plot_box)
|
||||
export(plot_box_single)
|
||||
export(plot_euler)
|
||||
|
|
@ -88,11 +91,14 @@ export(regression_model_list)
|
|||
export(regression_model_uv)
|
||||
export(regression_model_uv_list)
|
||||
export(regression_table)
|
||||
export(remove_empty_attr)
|
||||
export(remove_empty_cols)
|
||||
export(remove_na_attr)
|
||||
export(remove_nested_list)
|
||||
export(repeated_instruments)
|
||||
export(sankey_ready)
|
||||
export(selectInputIcon)
|
||||
export(set_column_label)
|
||||
export(sort_by)
|
||||
export(specify_qmd_format)
|
||||
export(subset_types)
|
||||
|
|
@ -133,14 +139,12 @@ importFrom(rlang,sym)
|
|||
importFrom(rlang,syms)
|
||||
importFrom(shiny,NS)
|
||||
importFrom(shiny,actionButton)
|
||||
importFrom(shiny,actionLink)
|
||||
importFrom(shiny,bindEvent)
|
||||
importFrom(shiny,checkboxInput)
|
||||
importFrom(shiny,column)
|
||||
importFrom(shiny,fluidRow)
|
||||
importFrom(shiny,getDefaultReactiveDomain)
|
||||
importFrom(shiny,icon)
|
||||
importFrom(shiny,is.reactive)
|
||||
importFrom(shiny,isTruthy)
|
||||
importFrom(shiny,modalDialog)
|
||||
importFrom(shiny,moduleServer)
|
||||
|
|
@ -149,7 +153,6 @@ importFrom(shiny,observeEvent)
|
|||
importFrom(shiny,plotOutput)
|
||||
importFrom(shiny,reactive)
|
||||
importFrom(shiny,reactiveValues)
|
||||
importFrom(shiny,removeUI)
|
||||
importFrom(shiny,renderPlot)
|
||||
importFrom(shiny,req)
|
||||
importFrom(shiny,restoreInput)
|
||||
|
|
@ -174,5 +177,4 @@ importFrom(toastui,grid_colorbar)
|
|||
importFrom(toastui,grid_columns)
|
||||
importFrom(toastui,renderDatagrid)
|
||||
importFrom(toastui,renderDatagrid2)
|
||||
importFrom(utils,data)
|
||||
importFrom(utils,type.convert)
|
||||
|
|
|
|||
4
NEWS.md
4
NEWS.md
|
|
@ -4,7 +4,9 @@ Polished and simplified data import module including a much improved REDCap impo
|
|||
|
||||
- *CHANGE* `default_parsing()` now ensure unique variable names.
|
||||
|
||||
- *NEW* Working code output for all major modules including import, modifications, filter, evaluation, plotting and regression.
|
||||
- *NEW* Working code output for all major modules including import, modifications, filter, evaluation, plotting and regression. And it is nicely formatted!
|
||||
|
||||
- *NEW* The basics of a "Getting started"-vignette is done, and can be expanded on later.
|
||||
|
||||
# FreesearchR 25.4.1
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
app_version <- function()'Version: 25.4.1.250410_1545'
|
||||
app_version <- function()'Version: 25.4.1.250411_1313'
|
||||
|
|
|
|||
|
|
@ -4,125 +4,58 @@ library(phosphoricons)
|
|||
library(rlang)
|
||||
library(shiny)
|
||||
|
||||
|
||||
# old_deprecated_cut.hms <- function(x, breaks = "hour", ...) {
|
||||
# # For now, this function will allways try to cut to hours
|
||||
# # This limits time cutting to only do hour-binning, no matter the
|
||||
#
|
||||
# breaks_o <- breaks
|
||||
#
|
||||
# if (identical(breaks, "hour")) {
|
||||
# # splitter <- match(
|
||||
# # num,
|
||||
# # levels(factor(num))
|
||||
# # )
|
||||
# breaks <- hms::as_hms(paste0(1:23, ":00:00"))
|
||||
# }
|
||||
#
|
||||
# # if (identical(breaks, "daynight")) {
|
||||
# # # splitter <- num %in% 8:20 + 1
|
||||
# # breaks <- hms::as_hms(c("08:00:00","20:00:00"))
|
||||
# # }
|
||||
#
|
||||
# if (length(breaks) != 1) {
|
||||
# if ("hms" %in% class(breaks)) {
|
||||
# splitter <- seq_along(breaks) |>
|
||||
# purrr::map(\(.x){
|
||||
# # browser()
|
||||
# out <- x %in% x[x >= breaks[.x] & x < breaks[.x + 1]]
|
||||
# if (.x == length(breaks)) {
|
||||
# out[match(breaks[length(breaks)], x)] <- TRUE
|
||||
# }
|
||||
# ifelse(out, .x, 0)
|
||||
# }) |>
|
||||
# dplyr::bind_cols(.name_repair = "unique_quiet") |>
|
||||
# rowSums()
|
||||
# splitter[splitter == 0] <- NA
|
||||
# } else {
|
||||
# breaks <- "hour"
|
||||
# }
|
||||
# }
|
||||
#
|
||||
# if (is.numeric(breaks)) {
|
||||
# breaks_n <- quantile(x, probs = seq(0, 1, 1 / breaks))
|
||||
# ## Use lapply or similar to go through levels two at a time
|
||||
# splitter <- seq(breaks) |>
|
||||
# purrr::map(\(.x){
|
||||
# # browser()
|
||||
# out <- x %in% x[x >= breaks_n[.x] & x < breaks_n[.x + 1]]
|
||||
# if (.x == breaks) {
|
||||
# out[match(breaks_n[length(breaks_n)], x)] <- TRUE
|
||||
# }
|
||||
# ifelse(out, .x, 0)
|
||||
# }) |>
|
||||
# dplyr::bind_cols(.name_repair = "unique_quiet") |>
|
||||
# rowSums()
|
||||
# }
|
||||
#
|
||||
# # browser()
|
||||
#
|
||||
# num <- strsplit(as.character(x), ":") |>
|
||||
# lapply(\(.x).x[[1]]) |>
|
||||
# unlist() |>
|
||||
# as.numeric()
|
||||
#
|
||||
# # browser()
|
||||
# labs <- split(x, splitter) |>
|
||||
# purrr::imap(\(.x, .i){
|
||||
# # if (identical(breaks_o, "daynight") && .i == 1) {
|
||||
# # h <- hms::as_hms(hms::hms(hours = 24) - abs(.x - hms::hms(hours = 8)))
|
||||
# #
|
||||
# # paste0("[", .x[match(sort(h)[1], h)], ",", .x[match(sort(h)[length(h)], h)], "]")
|
||||
# # } else {
|
||||
# .x <- sort(.x)
|
||||
# paste0("[", .x[1], ",", .x[length(.x)], "]")
|
||||
# # }
|
||||
# }) |>
|
||||
# unlist()
|
||||
#
|
||||
# structure(match(splitter, names(labs)), levels = labs, class = "factor")
|
||||
# }
|
||||
|
||||
#' Extended cutting function
|
||||
#' Extended cutting function with fall-back to the native base::cut
|
||||
#'
|
||||
#' @param x an object inheriting from class "hms"
|
||||
#' @param ... passed on
|
||||
#'
|
||||
#' @rdname cut
|
||||
#' @export
|
||||
#' @name cut_var
|
||||
cut_var <- function(x, ...) {
|
||||
UseMethod("cut_var")
|
||||
}
|
||||
|
||||
#' @export
|
||||
#' @name cut_var
|
||||
cut_var.default <- function(x, ...) {
|
||||
base::cut.default(x, ...)
|
||||
}
|
||||
|
||||
#' @name cut_var
|
||||
#'
|
||||
#' @return factor
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut(2)
|
||||
#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut("min")
|
||||
#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut(breaks = "hour")
|
||||
#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut(breaks = hms::as_hms(c("01:00:00", "03:01:20", "9:20:20")))
|
||||
#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut_var(2)
|
||||
#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut_var("min")
|
||||
#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut_var(breaks = "hour")
|
||||
#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut_var(breaks = hms::as_hms(c("01:00:00", "03:01:20", "9:20:20")))
|
||||
#' d_t <- readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA))
|
||||
#' 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, ...) {
|
||||
#' f <- d_t |> cut_var(2)
|
||||
#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA)) |> cut_var(breaks = lubridate::as_datetime(c(hms::as_hms(levels(f)), hms::as_hms(max(d_t, na.rm = TRUE) + 1))), right = FALSE)
|
||||
cut_var.hms <- function(x, breaks, ...) {
|
||||
## as_hms keeps returning warnings on tz(); ignored
|
||||
suppressWarnings({
|
||||
if (hms::is_hms(breaks)) {
|
||||
breaks <- lubridate::as_datetime(breaks)
|
||||
}
|
||||
x <- lubridate::as_datetime(x)
|
||||
out <- cut.POSIXt(x, breaks = breaks, ...)
|
||||
out <- cut_var.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
|
||||
}
|
||||
|
||||
#' @rdname cut
|
||||
#' @name cut_var
|
||||
#' @param x an object inheriting from class "POSIXt" or "Date"
|
||||
#'
|
||||
#' @examples
|
||||
#' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut(2)
|
||||
#' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut(breaks = "weekday")
|
||||
#' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut(breaks = "month_only")
|
||||
cut.POSIXt <- function(x, breaks, right = FALSE, include.lowest = TRUE, start.on.monday = TRUE, ...) {
|
||||
#' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(2)
|
||||
#' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks = "weekday")
|
||||
#' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks = "month_only")
|
||||
cut_var.POSIXt <- function(x, breaks, right = FALSE, include.lowest = TRUE, start.on.monday = TRUE, ...) {
|
||||
breaks_o <- breaks
|
||||
# browser()
|
||||
if (is.numeric(breaks)) {
|
||||
|
|
@ -174,17 +107,17 @@ cut.POSIXt <- function(x, breaks, right = FALSE, include.lowest = TRUE, start.on
|
|||
out
|
||||
}
|
||||
|
||||
#' @rdname cut
|
||||
#' @name cut_var
|
||||
#' @param x an object inheriting from class "POSIXct"
|
||||
cut.POSIXct <- cut.POSIXt
|
||||
cut_var.POSIXct <- cut_var.POSIXt
|
||||
|
||||
#' @rdname cut
|
||||
#' @name cut_var
|
||||
#' @param x an object inheriting from class "POSIXct"
|
||||
#'
|
||||
#' @examples
|
||||
#' as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut(2)
|
||||
#' as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut(breaks = "weekday")
|
||||
cut.Date <- function(x, breaks, start.on.monday = TRUE, ...) {
|
||||
#' as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(2)
|
||||
#' as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks = "weekday")
|
||||
cut_var.Date <- function(x, breaks, start.on.monday = TRUE, ...) {
|
||||
if (identical(breaks, "weekday")) {
|
||||
days <- c(
|
||||
"Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday",
|
||||
|
|
@ -329,7 +262,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
|||
moduleServer(
|
||||
id,
|
||||
function(input, output, session) {
|
||||
rv <- reactiveValues(data = NULL)
|
||||
rv <- reactiveValues(data = NULL, new_var_name = NULL)
|
||||
|
||||
bindEvent(observe({
|
||||
data <- data_r()
|
||||
|
|
@ -351,7 +284,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
|||
req(hasName(data, variable))
|
||||
|
||||
if (is_datetime(data[[variable]])) {
|
||||
brks <- cut(data[[variable]],
|
||||
brks <- cut_var(data[[variable]],
|
||||
breaks = input$n_breaks
|
||||
)$brks
|
||||
} else {
|
||||
|
|
@ -444,8 +377,8 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
|||
if (input$method == "fixed") {
|
||||
req(input$fixed_brks)
|
||||
if (any(c("hms", "POSIXt") %in% class(data[[variable]]))) {
|
||||
cut.POSIXct <- cut.POSIXt
|
||||
f <- cut(data[[variable]], breaks = input$fixed_brks)
|
||||
# cut.POSIXct <- cut.POSIXt
|
||||
f <- cut_var(data[[variable]], breaks = input$fixed_brks)
|
||||
list(var = f, brks = levels(f))
|
||||
} else {
|
||||
classInt::classIntervals(
|
||||
|
|
@ -458,8 +391,8 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
|||
} else if (input$method == "quantile") {
|
||||
req(input$fixed_brks)
|
||||
if (any(c("hms", "POSIXt") %in% class(data[[variable]]))) {
|
||||
cut.POSIXct <- cut.POSIXt
|
||||
f <- cut(data[[variable]], breaks = input$n_breaks)
|
||||
# cut.POSIXct <- cut.POSIXt
|
||||
f <- cut_var(data[[variable]], breaks = input$n_breaks)
|
||||
list(var = f, brks = levels(f))
|
||||
} else {
|
||||
classInt::classIntervals(
|
||||
|
|
@ -478,13 +411,13 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
|||
"year"
|
||||
)) {
|
||||
# To enable datetime cutting
|
||||
cut.POSIXct <- cut.POSIXt
|
||||
f <- cut(data[[variable]], breaks = input$method)
|
||||
# cut.POSIXct <- cut.POSIXt
|
||||
f <- cut_var(data[[variable]], breaks = input$method)
|
||||
list(var = f, brks = levels(f))
|
||||
} else if (input$method %in% c("hour")) {
|
||||
# To enable datetime cutting
|
||||
cut.POSIXct <- cut.POSIXt
|
||||
f <- cut(data[[variable]], breaks = "hour")
|
||||
# cut.POSIXct <- cut.POSIXt
|
||||
f <- cut_var(data[[variable]], breaks = "hour")
|
||||
list(var = f, brks = levels(f))
|
||||
} else {
|
||||
classInt::classIntervals(
|
||||
|
|
@ -503,43 +436,75 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
|||
|
||||
|
||||
data_cutted_r <- reactive({
|
||||
req(input$method)
|
||||
data <- req(data_r())
|
||||
variable <- req(input$variable)
|
||||
|
||||
new_variable <- data.frame(cut(
|
||||
|
||||
if (input$method %in% c("day", "weekday", "week", "month", "month_only", "quarter", "year", "hour")) {
|
||||
breaks <- input$method
|
||||
} else {
|
||||
breaks <- breaks_r()$brks
|
||||
}
|
||||
|
||||
parameters <- list(
|
||||
x = data[[variable]],
|
||||
breaks = if (input$method %in% c("day", "weekday", "week", "month", "month_only", "quarter", "year", "hour")) input$method else breaks_r()$brks,
|
||||
breaks = breaks,
|
||||
include.lowest = input$include_lowest,
|
||||
right = input$right
|
||||
)) |> setNames(paste0(variable, "_cut"))
|
||||
)
|
||||
|
||||
data <- dplyr::bind_cols(data, new_variable, .name_repair = "unique_quiet")
|
||||
new_variable <- tryCatch(
|
||||
{
|
||||
rlang::exec(cut_var, !!!parameters)
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0("We encountered the following error creating your report: ", err), type = "err")
|
||||
}
|
||||
)
|
||||
|
||||
code <- call2(
|
||||
"mutate",
|
||||
!!!set_names(
|
||||
list(
|
||||
expr(cut(
|
||||
!!!syms(list(x = variable)),
|
||||
!!!list(breaks = breaks_r()$brks, include.lowest = input$include_lowest, right = input$right)
|
||||
))
|
||||
# new_variable <- do.call(
|
||||
# cut,
|
||||
# parameters
|
||||
# )
|
||||
|
||||
|
||||
data <- append_column(data, column = new_variable, name = paste0(variable, "_cut"), index = "right")
|
||||
|
||||
# setNames(paste0(variable, "_cut"))
|
||||
#
|
||||
# data <- dplyr::bind_cols(data, new_variable, .name_repair = "unique_quiet")
|
||||
|
||||
# rv$new_var_name <- names(data)[length(data)]
|
||||
# browser()
|
||||
|
||||
# browser()
|
||||
code <- rlang::call2(
|
||||
"append_column",
|
||||
!!!list(
|
||||
column = rlang::call2("cut_var",
|
||||
!!!modifyList(parameters, list(x = as.symbol(paste0("data$", variable)))),
|
||||
.ns = "FreesearchR"),
|
||||
name = paste0(variable, "_cut"), index = "right"
|
||||
),
|
||||
paste0(variable, "_cut")
|
||||
)
|
||||
)
|
||||
attr(data, "code") <- Reduce(
|
||||
f = function(x, y) expr(!!x %>% !!y),
|
||||
x = c(attr(data, "code"), code)
|
||||
.ns = "FreesearchR"
|
||||
)
|
||||
attr(data, "code") <- code
|
||||
|
||||
# attr(data, "code") <- Reduce(
|
||||
# f = function(x, y) expr(!!x %>% !!y),
|
||||
# x = c(attr(data, "code"), code)
|
||||
# )
|
||||
data
|
||||
})
|
||||
|
||||
output$count <- renderDatagrid2({
|
||||
# shiny::req(rv$new_var_name)
|
||||
data <- req(data_cutted_r())
|
||||
variable <- req(input$variable)
|
||||
# variable <- req(input$variable)
|
||||
count_data <- as.data.frame(
|
||||
table(
|
||||
breaks = data[[paste0(variable, "_cut")]],
|
||||
breaks = data[[length(data)]],
|
||||
useNA = "ifany"
|
||||
),
|
||||
responseName = "count"
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
|
|||
title = "Creating plot",
|
||||
icon = bsicons::bs_icon("graph-up"),
|
||||
shiny::uiOutput(outputId = ns("primary")),
|
||||
shiny::helpText('Only non-text variables are available for plotting. Go the "Data" to reclass data to plot.'),
|
||||
shiny::uiOutput(outputId = ns("type")),
|
||||
shiny::uiOutput(outputId = ns("secondary")),
|
||||
shiny::uiOutput(outputId = ns("tertiary")),
|
||||
|
|
@ -88,8 +89,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
|
|||
title = tab_title,
|
||||
shiny::plotOutput(ns("plot"),height = "70vh"),
|
||||
shiny::tags$br(),
|
||||
shiny::h4("Plot code:"),
|
||||
shiny::verbatimTextOutput(outputId = ns("code_plot"))
|
||||
shiny::tags$br(),
|
||||
shiny::htmlOutput(outputId = ns("code_plot"))
|
||||
)
|
||||
)
|
||||
}
|
||||
|
|
@ -209,9 +210,12 @@ data_visuals_server <- function(id,
|
|||
# })
|
||||
# )|> setNames(c("primary","type","secondary","tertiary")),keep.null = TRUE)
|
||||
|
||||
|
||||
output$primary <- shiny::renderUI({
|
||||
shiny::req(data())
|
||||
columnSelectInput(
|
||||
inputId = ns("primary"),
|
||||
col_subset=names(data())[sapply(data(),data_type)!="text"],
|
||||
data = data,
|
||||
placeholder = "Select variable",
|
||||
label = "Response variable",
|
||||
|
|
@ -219,9 +223,18 @@ data_visuals_server <- function(id,
|
|||
)
|
||||
})
|
||||
|
||||
# shiny::observeEvent(data, {
|
||||
# if (is.null(data()) | NROW(data()) == 0) {
|
||||
# shiny::updateActionButton(inputId = ns("act_plot"), disabled = TRUE)
|
||||
# } else {
|
||||
# shiny::updateActionButton(inputId = ns("act_plot"), disabled = FALSE)
|
||||
# }
|
||||
# })
|
||||
|
||||
|
||||
output$type <- shiny::renderUI({
|
||||
shiny::req(input$primary)
|
||||
shiny::req(data())
|
||||
# browser()
|
||||
|
||||
if (!input$primary %in% names(data())) {
|
||||
|
|
@ -304,6 +317,7 @@ data_visuals_server <- function(id,
|
|||
|
||||
shiny::observeEvent(input$act_plot,
|
||||
{
|
||||
if (NROW(data())>0){
|
||||
tryCatch(
|
||||
{
|
||||
parameters <- list(
|
||||
|
|
@ -333,13 +347,14 @@ data_visuals_server <- function(id,
|
|||
error = function(err) {
|
||||
showNotification(paste0(err), type = "err")
|
||||
}
|
||||
)
|
||||
)}
|
||||
},
|
||||
ignoreInit = TRUE
|
||||
)
|
||||
|
||||
output$code_plot <- shiny::renderPrint({
|
||||
cat(rv$code)
|
||||
output$code_plot <- shiny::renderUI({
|
||||
shiny::req(rv$code)
|
||||
prismCodeBlock(paste0("#Plotting\n", rv$code))
|
||||
})
|
||||
|
||||
output$plot <- shiny::renderPlot({
|
||||
|
|
|
|||
|
|
@ -1,125 +0,0 @@
|
|||
#' Shiny UI module to load a data file
|
||||
#'
|
||||
#' @param id id
|
||||
#'
|
||||
#' @return shiny UI
|
||||
#' @export
|
||||
#'
|
||||
m_datafileUI <- function(id) {
|
||||
ns <- shiny::NS(id)
|
||||
shiny::tagList(
|
||||
shiny::fileInput(
|
||||
inputId = ns("file"),
|
||||
label = "Upload a file",
|
||||
multiple = FALSE,
|
||||
accept = c(
|
||||
".csv",
|
||||
".xlsx",
|
||||
".xls",
|
||||
".dta",
|
||||
".ods",
|
||||
".rds"
|
||||
)
|
||||
),
|
||||
shiny::h4("Parameter specifications"),
|
||||
shiny::helpText(shiny::em("Select the desired variables and press 'Submit'")),
|
||||
shiny::uiOutput(ns("include_vars")),
|
||||
DT::DTOutput(ns("data_input")),
|
||||
shiny::actionButton(ns("submit"), "Submit")
|
||||
)
|
||||
}
|
||||
|
||||
m_datafileServer <- function(id, output.format = "df") {
|
||||
shiny::moduleServer(id, function(input, output, session, ...) {
|
||||
ns <- shiny::NS(id)
|
||||
ds <- shiny::reactive({
|
||||
REDCapCAST::read_input(input$file$datapath) |> REDCapCAST::parse_data()
|
||||
})
|
||||
|
||||
output$include_vars <- shiny::renderUI({
|
||||
shiny::req(input$file)
|
||||
shiny::selectizeInput(
|
||||
inputId = ns("include_vars"),
|
||||
selected = NULL,
|
||||
label = "Covariables to include",
|
||||
choices = colnames(ds()),
|
||||
multiple = TRUE
|
||||
)
|
||||
})
|
||||
|
||||
base_vars <- shiny::reactive({
|
||||
if (is.null(input$include_vars)) {
|
||||
out <- colnames(ds())
|
||||
} else {
|
||||
out <- input$include_vars
|
||||
}
|
||||
out
|
||||
})
|
||||
|
||||
output$data_input <-
|
||||
DT::renderDT({
|
||||
shiny::req(input$file)
|
||||
ds()[base_vars()]
|
||||
})
|
||||
|
||||
shiny::eventReactive(input$submit, {
|
||||
# shiny::req(input$file)
|
||||
|
||||
data <- shiny::isolate({
|
||||
ds()[base_vars()]
|
||||
})
|
||||
|
||||
file_export(data,
|
||||
output.format = output.format,
|
||||
tools::file_path_sans_ext(input$file$name)
|
||||
)
|
||||
})
|
||||
})
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
file_app <- function() {
|
||||
ui <- shiny::fluidPage(
|
||||
m_datafileUI("data"),
|
||||
# DT::DTOutput(outputId = "redcap_prev")
|
||||
toastui::datagridOutput2(outputId = "redcap_prev")
|
||||
)
|
||||
server <- function(input, output, session) {
|
||||
m_datafileServer("data", output.format = "list")
|
||||
}
|
||||
shiny::shinyApp(ui, server)
|
||||
}
|
||||
|
||||
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")
|
||||
# }
|
||||
# )
|
||||
# }
|
||||
# )
|
||||
165
R/helpers.R
165
R/helpers.R
|
|
@ -209,14 +209,14 @@ file_export <- function(data, output.format = c("df", "teal", "list"), filename,
|
|||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' str()
|
||||
#' head(starwars,5) |> str()
|
||||
#' head(starwars, 5) |> str()
|
||||
#' starwars |>
|
||||
#' default_parsing() |>
|
||||
#' head(5) |>
|
||||
#' str()
|
||||
default_parsing <- function(data) {
|
||||
name_labels <- lapply(data, \(.x) REDCapCAST::get_attr(.x, attr = "label"))
|
||||
|
||||
# browser()
|
||||
out <- data |>
|
||||
setNames(make.names(names(data), unique = TRUE)) |>
|
||||
## Temporary step to avoid nested list and crashing
|
||||
|
|
@ -227,19 +227,21 @@ default_parsing <- function(data) {
|
|||
REDCapCAST::as_logical() |>
|
||||
REDCapCAST::fct_drop()
|
||||
|
||||
purrr::map2(
|
||||
out,
|
||||
name_labels[names(name_labels) %in% names(out)],
|
||||
\(.x, .l){
|
||||
if (!(is.na(.l) | .l == "")) {
|
||||
REDCapCAST::set_attr(.x, .l, attr = "label")
|
||||
} else {
|
||||
attr(x = .x, which = "label") <- NULL
|
||||
.x
|
||||
}
|
||||
# REDCapCAST::set_attr(data = .x, label = .l,attr = "label", overwrite = FALSE)
|
||||
}
|
||||
) |> dplyr::bind_cols()
|
||||
set_column_label(out, setNames(name_labels, names(out)), overwrite = FALSE)
|
||||
|
||||
# purrr::map2(
|
||||
# out,
|
||||
# name_labels[names(name_labels) %in% names(out)],
|
||||
# \(.x, .l){
|
||||
# if (!(is.na(.l) | .l == "")) {
|
||||
# REDCapCAST::set_attr(.x, .l, attr = "label")
|
||||
# } else {
|
||||
# attr(x = .x, which = "label") <- NULL
|
||||
# .x
|
||||
# }
|
||||
# # REDCapCAST::set_attr(data = .x, label = .l,attr = "label", overwrite = FALSE)
|
||||
# }
|
||||
# ) |> dplyr::bind_cols()
|
||||
}
|
||||
|
||||
#' Remove NA labels
|
||||
|
|
@ -425,6 +427,33 @@ merge_expression <- function(data) {
|
|||
)
|
||||
}
|
||||
|
||||
#' Reduce character vector with the native pipe operator or character string
|
||||
#'
|
||||
#' @param data list
|
||||
#'
|
||||
#' @returns character string
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' list(
|
||||
#' "mtcars",
|
||||
#' rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .ns = "dplyr"),
|
||||
#' rlang::call2(.fn = "default_parsing", .ns = "FreesearchR")
|
||||
#' ) |>
|
||||
#' lapply(expression_string) |>
|
||||
#' pipe_string() |>
|
||||
#' expression_string("data<-")
|
||||
pipe_string <- function(data, collapse = "|>\n") {
|
||||
if (is.list(data)) {
|
||||
Reduce(
|
||||
f = function(x, y) glue::glue("{x}{collapse}{y}"),
|
||||
x = data
|
||||
)
|
||||
} else {
|
||||
data
|
||||
}
|
||||
}
|
||||
|
||||
#' Deparses expression as string, substitutes native pipe and adds assign
|
||||
#'
|
||||
#' @param data expression
|
||||
|
|
@ -434,14 +463,17 @@ merge_expression <- function(data) {
|
|||
#'
|
||||
#' @examples
|
||||
#' list(
|
||||
#' as.symbol(paste0("mtcars$","mpg")),
|
||||
#' rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .ns = "dplyr"),
|
||||
#' rlang::call2(.fn = "default_parsing", .ns = "FreesearchR")
|
||||
#' ) |>
|
||||
#' merge_expression() |>
|
||||
#' expression_string()
|
||||
expression_string <- function(data, assign.str = "data <- ") {
|
||||
out <- paste0(assign.str, gsub("%>%", "|>\n", paste(gsub('"', "'", deparse(data)), collapse = "")))
|
||||
gsub(" ", "", out)
|
||||
expression_string <- function(data, assign.str = "") {
|
||||
exp.str <- if (is.call(data)) deparse(data) else data
|
||||
# browser()
|
||||
out <- paste0(assign.str, gsub("%>%", "|>\n", paste(gsub('"', "'", paste(exp.str, collapse = "")), collapse = "")))
|
||||
gsub(" |`", "", out)
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -458,3 +490,100 @@ expression_string <- function(data, assign.str = "data <- ") {
|
|||
remove_nested_list <- function(data) {
|
||||
data[!sapply(data, is.list)]
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
#' (Re)label columns in data.frame
|
||||
#'
|
||||
#' @param data data.frame to be labelled
|
||||
#' @param label named list or vector
|
||||
#'
|
||||
#' @returns data.frame
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' ls <- list("mpg" = "", "cyl" = "Cylinders", "disp" = "", "hp" = "", "drat" = "", "wt" = "", "qsec" = "", "vs" = "", "am" = "", "gear" = "", "carb" = "")
|
||||
#' ls2 <- c("mpg" = "", "cyl" = "Cylinders", "disp" = "", "hp" = "Horses", "drat" = "", "wt" = "", "qsec" = "", "vs" = "", "am" = "", "gear" = "", "carb" = "")
|
||||
#' ls3 <- c("mpg" = "", "cyl" = "", "disp" = "", "hp" = "Horses", "drat" = "", "wt" = "", "qsec" = "", "vs" = "", "am" = "", "gear" = "", "carb" = "")
|
||||
#' mtcars |>
|
||||
#' set_column_label(ls) |>
|
||||
#' set_column_label(ls2) |>
|
||||
#' set_column_label(ls3)
|
||||
#' rlang::expr(FreesearchR::set_column_label(label = !!ls3)) |> expression_string()
|
||||
set_column_label <- function(data, label, overwrite = TRUE) {
|
||||
purrr::imap(data, function(.data, .name) {
|
||||
ls <- if (is.list(label)) unlist(label) else label
|
||||
ls[ls == ""] <- NA
|
||||
if (.name %in% names(ls)) {
|
||||
out <- REDCapCAST::set_attr(.data, unname(ls[.name]), attr = "label", overwrite = overwrite)
|
||||
remove_empty_attr(out)
|
||||
} else {
|
||||
.data
|
||||
}
|
||||
}) |> dplyr::bind_cols(.name_repair = "unique_quiet")
|
||||
}
|
||||
|
||||
#' Remove empty/NA attributes
|
||||
#'
|
||||
#' @param data data
|
||||
#'
|
||||
#' @returns data of same class as input
|
||||
#' @export
|
||||
#'
|
||||
remove_empty_attr <- function(data) {
|
||||
attributes(data)[is.na(attributes(data))] <- NULL
|
||||
data
|
||||
}
|
||||
|
||||
|
||||
|
||||
#' Append a column to a data.frame
|
||||
#'
|
||||
#' @param data data
|
||||
#' @param column new column (vector) or data.frame with 1 column
|
||||
#' @param name new name (pre-fix)
|
||||
#' @param index desired location. May be "left", "right" or numeric index.
|
||||
#'
|
||||
#' @returns data.frame
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |>
|
||||
#' dplyr::mutate(mpg_cut = mpg) |>
|
||||
#' append_column(mtcars$mpg, "mpg_cutter")
|
||||
append_column <- function(data, column, name, index = "right") {
|
||||
assertthat::assert_that(NCOL(column) == 1)
|
||||
assertthat::assert_that(length(index) == 1)
|
||||
|
||||
if (index == "right") {
|
||||
index <- ncol(data) + 1
|
||||
} else if (index == "left") {
|
||||
index <- 1
|
||||
} else if (is.numeric(index)) {
|
||||
if (index > ncol(data)) {
|
||||
index <- ncol(data) + 1
|
||||
}
|
||||
} else {
|
||||
index <- ncol(data) + 1
|
||||
}
|
||||
|
||||
## Identifying potential naming conflicts
|
||||
nm_conflicts <- names(data)[startsWith(names(data), name)]
|
||||
## Simple attemt to create new unique name
|
||||
if (length(nm_conflicts) > 0) {
|
||||
name <- glue::glue("{name}_{length(nm_conflicts)+1}")
|
||||
}
|
||||
## If the above not achieves a unique name, the generic approach is used
|
||||
if (name %in% names(data)) {
|
||||
name <- make.names(c(name, names(data)), unique = TRUE)[1]
|
||||
}
|
||||
new_df <- setNames(data.frame(column), name)
|
||||
|
||||
list(
|
||||
data[seq_len(index - 1)],
|
||||
new_df,
|
||||
if (!index > ncol(data)) data[index:ncol(data)]
|
||||
) |>
|
||||
dplyr::bind_cols()
|
||||
}
|
||||
|
|
|
|||
|
|
@ -192,7 +192,7 @@ import_file_server <- function(id,
|
|||
module <- function(input, output, session) {
|
||||
ns <- session$ns
|
||||
imported_rv <- shiny::reactiveValues(data = NULL, name = NULL)
|
||||
temporary_rv <- shiny::reactiveValues(data = NULL, name = NULL, status = NULL)
|
||||
temporary_rv <- shiny::reactiveValues(data = NULL, name = NULL, status = NULL, sheets = 1)
|
||||
|
||||
shiny::observeEvent(reset(), {
|
||||
temporary_rv$data <- NULL
|
||||
|
|
@ -207,19 +207,21 @@ import_file_server <- function(id,
|
|||
})
|
||||
|
||||
shiny::observeEvent(input$file, {
|
||||
## Several steps are taken to ensure no errors on changed input file
|
||||
temporary_rv$sheets <- 1
|
||||
if (isTRUE(is_workbook(input$file$datapath))) {
|
||||
if (isTRUE(is_excel(input$file$datapath))) {
|
||||
choices <- readxl::excel_sheets(input$file$datapath)
|
||||
temporary_rv$sheets <- readxl::excel_sheets(input$file$datapath)
|
||||
} else if (isTRUE(is_ods(input$file$datapath))) {
|
||||
choices <- readODS::ods_sheets(input$file$datapath)
|
||||
temporary_rv$sheets <- readODS::ods_sheets(input$file$datapath)
|
||||
}
|
||||
selected <- choices[1]
|
||||
selected <- temporary_rv$sheets[1]
|
||||
|
||||
shinyWidgets::updatePickerInput(
|
||||
session = session,
|
||||
inputId = "sheet",
|
||||
selected = selected,
|
||||
choices = choices
|
||||
choices = temporary_rv$sheets
|
||||
)
|
||||
datamods:::showUI(paste0("#", ns("sheet-container")))
|
||||
} else {
|
||||
|
|
@ -238,13 +240,18 @@ import_file_server <- function(id,
|
|||
),
|
||||
{
|
||||
req(input$file)
|
||||
if (is_workbook(input$file$datapath)) shiny::req(input$sheet)
|
||||
|
||||
if (!all(input$sheet %in% temporary_rv$sheets)) {
|
||||
sheets <- 1
|
||||
} else {
|
||||
sheets <- input$sheet
|
||||
}
|
||||
|
||||
extension <- tools::file_ext(input$file$datapath)
|
||||
|
||||
parameters <- list(
|
||||
file = input$file$datapath,
|
||||
sheet = input$sheet,
|
||||
sheet = sheets,
|
||||
skip = input$skip_rows,
|
||||
dec = input$dec,
|
||||
encoding = input$encoding,
|
||||
|
|
@ -307,7 +314,7 @@ import_file_server <- function(id,
|
|||
req(temporary_rv$data)
|
||||
tryCatch({
|
||||
toastui::datagrid(
|
||||
data = setNames(head(temporary_rv$data, 5),make.names(names(temporary_rv$data))),
|
||||
data = setNames(head(temporary_rv$data, 5),make.names(names(temporary_rv$data),unique = TRUE)),
|
||||
theme = "striped",
|
||||
colwidths = "guess",
|
||||
minBodyHeight = 250
|
||||
|
|
@ -406,7 +413,9 @@ import_delim <- function(file, skip, encoding, na.strings) {
|
|||
import_xls <- function(file, sheet, skip, na.strings) {
|
||||
tryCatch(
|
||||
{
|
||||
# browser()
|
||||
## If sheet is null, this allows purrr::map to run
|
||||
if (is.null(sheet)) sheet <- 1
|
||||
|
||||
sheet |>
|
||||
purrr::map(\(.x){
|
||||
openxlsx2::read_xlsx(
|
||||
|
|
@ -437,6 +446,7 @@ import_xls <- function(file, sheet, skip, na.strings) {
|
|||
import_ods <- function(file, sheet, skip, na.strings) {
|
||||
tryCatch(
|
||||
{
|
||||
if (is.null(sheet)) sheet <- 1
|
||||
sheet |>
|
||||
purrr::map(\(.x){
|
||||
readODS::read_ods(
|
||||
|
|
|
|||
|
|
@ -1,338 +0,0 @@
|
|||
|
||||
#' @title Import data from an Environment
|
||||
#'
|
||||
#' @description Let the user select a dataset from its own environment or from a package's environment.
|
||||
#'
|
||||
#' @param id Module's ID.
|
||||
#' @param globalenv Search for data in Global environment.
|
||||
#' @param packages Name of packages in which to search data.
|
||||
#' @param title Module's title, if `TRUE` use the default title,
|
||||
#' use `NULL` for no title or a `shiny.tag` for a custom one.
|
||||
#'
|
||||
#'
|
||||
#' @export
|
||||
#'
|
||||
#' @name import-globalenv
|
||||
#'
|
||||
#' @importFrom htmltools tags
|
||||
#' @importFrom shiny NS actionButton icon textInput
|
||||
#'
|
||||
#' @example examples/from-globalenv.R
|
||||
import_globalenv_ui <- function(id,
|
||||
globalenv = TRUE,
|
||||
packages = get_data_packages(),
|
||||
title = TRUE) {
|
||||
|
||||
ns <- NS(id)
|
||||
|
||||
choices <- list()
|
||||
if (isTRUE(globalenv)) {
|
||||
choices <- append(choices, "Global Environment")
|
||||
}
|
||||
if (!is.null(packages)) {
|
||||
choices <- append(choices, list(Packages = as.character(packages)))
|
||||
}
|
||||
|
||||
if (isTRUE(globalenv)) {
|
||||
selected <- "Global Environment"
|
||||
} else {
|
||||
selected <- packages[1]
|
||||
}
|
||||
|
||||
if (isTRUE(title)) {
|
||||
title <- tags$h4(
|
||||
i18n("Import a dataset from an environment"),
|
||||
class = "datamods-title"
|
||||
)
|
||||
}
|
||||
|
||||
tags$div(
|
||||
class = "datamods-import",
|
||||
datamods:::html_dependency_datamods(),
|
||||
title,
|
||||
shinyWidgets::pickerInput(
|
||||
inputId = ns("data"),
|
||||
label = i18n("Select a data.frame:"),
|
||||
choices = NULL,
|
||||
options = list(title = i18n("List of data.frame...")),
|
||||
width = "100%"
|
||||
),
|
||||
shinyWidgets::pickerInput(
|
||||
inputId = ns("env"),
|
||||
label = i18n("Select an environment in which to search:"),
|
||||
choices = choices,
|
||||
selected = selected,
|
||||
width = "100%",
|
||||
options = list(
|
||||
"title" = i18n("Select environment"),
|
||||
"live-search" = TRUE,
|
||||
"size" = 10
|
||||
)
|
||||
),
|
||||
|
||||
tags$div(
|
||||
id = ns("import-placeholder"),
|
||||
alert(
|
||||
id = ns("import-result"),
|
||||
status = "info",
|
||||
tags$b(i18n("No data selected!")),
|
||||
i18n("Use a data.frame from your environment or from the environment of a package."),
|
||||
dismissible = TRUE
|
||||
)
|
||||
),
|
||||
uiOutput(
|
||||
outputId = ns("container_valid_btn"),
|
||||
style = "margin-top: 20px;"
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
|
||||
#' @param btn_show_data Display or not a button to display data in a modal window if import is successful.
|
||||
#' @param show_data_in Where to display data: in a `"popup"` or in a `"modal"` window.
|
||||
#' @param trigger_return When to update selected data:
|
||||
#' `"button"` (when user click on button) or
|
||||
#' `"change"` (each time user select a dataset in the list).
|
||||
#' @param return_class Class of returned data: `data.frame`, `data.table`, `tbl_df` (tibble) or `raw`.
|
||||
#' @param reset A `reactive` function that when triggered resets the data.
|
||||
#'
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shiny moduleServer reactiveValues observeEvent reactive removeUI is.reactive icon actionLink isTruthy
|
||||
#' @importFrom htmltools tags tagList
|
||||
#'
|
||||
#' @rdname import-globalenv
|
||||
import_globalenv_server <- function(id,
|
||||
btn_show_data = TRUE,
|
||||
show_data_in = c("popup", "modal"),
|
||||
trigger_return = c("button", "change"),
|
||||
return_class = c("data.frame", "data.table", "tbl_df", "raw"),
|
||||
reset = reactive(NULL)) {
|
||||
|
||||
trigger_return <- match.arg(trigger_return)
|
||||
return_class <- match.arg(return_class)
|
||||
|
||||
module <- function(input, output, session) {
|
||||
|
||||
ns <- session$ns
|
||||
imported_rv <- reactiveValues(data = NULL, name = NULL)
|
||||
temporary_rv <- reactiveValues(data = NULL, name = NULL, status = NULL)
|
||||
|
||||
observeEvent(reset(), {
|
||||
temporary_rv$data <- NULL
|
||||
temporary_rv$name <- NULL
|
||||
temporary_rv$status <- NULL
|
||||
})
|
||||
|
||||
output$container_valid_btn <- renderUI({
|
||||
if (identical(trigger_return, "button")) {
|
||||
button_import()
|
||||
}
|
||||
})
|
||||
|
||||
observeEvent(input$env, {
|
||||
if (identical(input$env, "Global Environment")) {
|
||||
choices <- datamods:::search_obj("data.frame")
|
||||
} else {
|
||||
choices <- datamods:::list_pkg_data(input$env)
|
||||
}
|
||||
if (is.null(choices)) {
|
||||
choices <- i18n("No data.frame here...")
|
||||
choicesOpt <- list(disabled = TRUE)
|
||||
} else {
|
||||
choicesOpt <- list(
|
||||
subtext = get_dimensions(choices)
|
||||
)
|
||||
}
|
||||
temporary_rv$package <- attr(choices, "package")
|
||||
shinyWidgets::updatePickerInput(
|
||||
session = session,
|
||||
inputId = ns("data"),
|
||||
choices = choices,
|
||||
choicesOpt = choicesOpt
|
||||
)
|
||||
})
|
||||
|
||||
|
||||
observeEvent(input$trigger, {
|
||||
if (identical(trigger_return, "change")) {
|
||||
hideUI(selector = paste0("#", ns("container_valid_btn")))
|
||||
}
|
||||
})
|
||||
|
||||
|
||||
observeEvent(input$data, {
|
||||
if (!isTruthy(input$data)) {
|
||||
toggle_widget(inputId = "confirm", enable = FALSE)
|
||||
insert_alert(
|
||||
selector = ns("import"),
|
||||
status = "info",
|
||||
tags$b(i18n("No data selected!")),
|
||||
i18n("Use a data.frame from your environment or from the environment of a package.")
|
||||
)
|
||||
} else {
|
||||
name_df <- input$data
|
||||
|
||||
if (!is.null(temporary_rv$package)) {
|
||||
attr(name_df, "package") <- temporary_rv$package
|
||||
}
|
||||
|
||||
imported <- try(get_env_data(name_df), silent = TRUE)
|
||||
|
||||
if (inherits(imported, "try-error") || NROW(imported) < 1) {
|
||||
toggle_widget(inputId = "confirm", enable = FALSE)
|
||||
insert_error(mssg = i18n(attr(imported, "condition")$message))
|
||||
temporary_rv$status <- "error"
|
||||
temporary_rv$data <- NULL
|
||||
temporary_rv$name <- NULL
|
||||
} else {
|
||||
toggle_widget(inputId = "confirm", enable = TRUE)
|
||||
insert_alert(
|
||||
selector = ns("import"),
|
||||
status = "success",
|
||||
make_success_alert(
|
||||
imported,
|
||||
trigger_return = trigger_return,
|
||||
btn_show_data = btn_show_data
|
||||
)
|
||||
)
|
||||
pkg <- attr(name_df, "package")
|
||||
if (!is.null(pkg)) {
|
||||
name <- paste(pkg, input$data, sep = "::")
|
||||
} else {
|
||||
name <- input$data
|
||||
}
|
||||
name <- trimws(sub("\\(([^\\)]+)\\)", "", name))
|
||||
temporary_rv$status <- "success"
|
||||
temporary_rv$data <- imported
|
||||
temporary_rv$name <- name
|
||||
}
|
||||
}
|
||||
}, ignoreInit = TRUE, ignoreNULL = FALSE)
|
||||
|
||||
|
||||
observeEvent(input$see_data, {
|
||||
show_data(temporary_rv$data, title = i18n("Imported data"), type = show_data_in)
|
||||
})
|
||||
|
||||
observeEvent(input$confirm, {
|
||||
imported_rv$data <- temporary_rv$data
|
||||
imported_rv$name <- temporary_rv$name
|
||||
})
|
||||
|
||||
|
||||
return(list(
|
||||
status = reactive(temporary_rv$status),
|
||||
name = reactive(temporary_rv$name),
|
||||
data = reactive(datamods:::as_out(temporary_rv$data, return_class))
|
||||
))
|
||||
}
|
||||
|
||||
moduleServer(
|
||||
id = id,
|
||||
module = module
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# utils -------------------------------------------------------------------
|
||||
|
||||
|
||||
#' Get packages containing datasets
|
||||
#'
|
||||
#' @return a character vector of packages names
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom utils data
|
||||
#'
|
||||
#' @examples
|
||||
#' if (interactive()) {
|
||||
#'
|
||||
#' get_data_packages()
|
||||
#'
|
||||
#' }
|
||||
get_data_packages <- function() {
|
||||
suppressWarnings({
|
||||
pkgs <- data(package = .packages(all.available = TRUE))
|
||||
})
|
||||
unique(pkgs$results[, 1])
|
||||
}
|
||||
|
||||
|
||||
#' List dataset contained in a package
|
||||
#'
|
||||
#' @param pkg Name of the package, must be installed.
|
||||
#'
|
||||
#' @return a \code{character} vector or \code{NULL}.
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom utils data
|
||||
#'
|
||||
#' @examples
|
||||
#'
|
||||
#' list_pkg_data("ggplot2")
|
||||
list_pkg_data <- function(pkg) {
|
||||
if (isTRUE(requireNamespace(pkg, quietly = TRUE))) {
|
||||
list_data <- data(package = pkg, envir = environment())$results[, "Item"]
|
||||
list_data <- sort(list_data)
|
||||
attr(list_data, "package") <- pkg
|
||||
if (length(list_data) < 1) {
|
||||
NULL
|
||||
} else {
|
||||
unname(list_data)
|
||||
}
|
||||
} else {
|
||||
NULL
|
||||
}
|
||||
}
|
||||
|
||||
#' @importFrom utils data
|
||||
get_env_data <- function(obj, env = globalenv()) {
|
||||
pkg <- attr(obj, "package")
|
||||
re <- regexpr(pattern = "\\(([^\\)]+)\\)", text = obj)
|
||||
obj_ <- substr(x = obj, start = re + 1, stop = re + attr(re, "match.length") - 2)
|
||||
obj <- gsub(pattern = "\\s.*", replacement = "", x = obj)
|
||||
if (obj %in% ls(name = env)) {
|
||||
get(x = obj, envir = env)
|
||||
} else if (!is.null(pkg) && !identical(pkg, "")) {
|
||||
res <- suppressWarnings(try(
|
||||
get(utils::data(list = obj, package = pkg, envir = environment())), silent = TRUE
|
||||
))
|
||||
if (!inherits(res, "try-error"))
|
||||
return(res)
|
||||
data(list = obj_, package = pkg, envir = environment())
|
||||
get(obj, envir = environment())
|
||||
} else {
|
||||
NULL
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
get_dimensions <- function(objs) {
|
||||
if (is.null(objs))
|
||||
return(NULL)
|
||||
dataframes_dims <- Map(
|
||||
f = function(name, pkg) {
|
||||
attr(name, "package") <- pkg
|
||||
tmp <- suppressWarnings(get_env_data(name))
|
||||
if (is.data.frame(tmp)) {
|
||||
sprintf("%d obs. of %d variables", nrow(tmp), ncol(tmp))
|
||||
} else {
|
||||
i18n("Not a data.frame")
|
||||
}
|
||||
},
|
||||
name = objs,
|
||||
pkg = if (!is.null(attr(objs, "package"))) {
|
||||
attr(objs, "package")
|
||||
} else {
|
||||
character(1)
|
||||
}
|
||||
)
|
||||
unlist(dataframes_dims)
|
||||
}
|
||||
|
|
@ -1,3 +1,45 @@
|
|||
### On rewriting this module
|
||||
###
|
||||
### This module (and the plotting module) should be rewritten to allow for
|
||||
### dynamically defining variable-selection for model evaluation.
|
||||
### The principle of having a library of supported functions is fine, but should
|
||||
### be expanded.
|
||||
###
|
||||
###
|
||||
|
||||
# list(
|
||||
# lm = list(
|
||||
# descr = "Linear regression model",
|
||||
# design = "cross-sectional",
|
||||
# parameters=list(
|
||||
# fun = "stats::lm",
|
||||
# args.list = NULL
|
||||
# ),
|
||||
# variables = list(
|
||||
# outcome.str = list(
|
||||
# fun = "columnSelectInput",
|
||||
# multiple = FALSE,
|
||||
# label = "Select the dependent/outcome variable."
|
||||
# )
|
||||
# ),
|
||||
# out.type = "continuous",
|
||||
# formula.str = "{outcome.str}~{paste(vars,collapse='+')}",
|
||||
# table.fun = "gtsummary::tbl_regression",
|
||||
# table.args.list = list(exponentiate = FALSE)
|
||||
# ))
|
||||
#
|
||||
# Regarding the regression model, it really should be the design selection,
|
||||
# that holds the input selection information, as this is what is deciding
|
||||
# the number and type of primary inputs.
|
||||
#
|
||||
# Cross-sectional: outcome
|
||||
# MMRM: outcome, random effect (id, time)
|
||||
# Survival: time, status, strata(?)
|
||||
#
|
||||
#
|
||||
|
||||
|
||||
|
||||
regression_ui <- function(id, ...) {
|
||||
ns <- shiny::NS(id)
|
||||
|
||||
|
|
@ -62,7 +104,7 @@ regression_ui <- function(id, ...) {
|
|||
type = "secondary",
|
||||
auto_reset = TRUE
|
||||
),
|
||||
shiny::helpText("Press 'Analyse' again after changing parameters."),
|
||||
shiny::helpText("Press 'Analyse' to create the regression model and after changing parameters."),
|
||||
shiny::tags$br()
|
||||
),
|
||||
do.call(
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@
|
|||
#' )
|
||||
#' broom::tidy(m)
|
||||
regression_model <- function(data,
|
||||
outcome.str,
|
||||
outcome.str = NULL,
|
||||
auto.mode = FALSE,
|
||||
formula.str = NULL,
|
||||
args.list = NULL,
|
||||
|
|
@ -60,22 +60,14 @@ regression_model <- function(data,
|
|||
}
|
||||
|
||||
## This will handle if outcome is not in data for nicer shiny behavior
|
||||
if (!outcome.str %in% names(data)) {
|
||||
if (isTRUE(!outcome.str %in% names(data))) {
|
||||
outcome.str <- names(data)[1]
|
||||
print("outcome is not in data, first column is used")
|
||||
}
|
||||
|
||||
if (is.null(vars)) {
|
||||
vars <- names(data)[!names(data) %in% outcome.str]
|
||||
} else {
|
||||
if (outcome.str %in% vars) {
|
||||
vars <- vars[!vars %in% outcome.str]
|
||||
}
|
||||
data <- data |> dplyr::select(dplyr::all_of(c(vars, outcome.str)))
|
||||
print("Outcome variable is not in data, first column is used")
|
||||
}
|
||||
|
||||
if (!is.null(formula.str)) {
|
||||
formula.glue <- glue::glue(formula.str)
|
||||
outcome.str <- NULL
|
||||
} else {
|
||||
assertthat::assert_that(outcome.str %in% names(data),
|
||||
msg = "Outcome variable is not present in the provided dataset"
|
||||
|
|
@ -83,6 +75,15 @@ regression_model <- function(data,
|
|||
formula.glue <- glue::glue("{outcome.str}~{paste(vars,collapse='+')}")
|
||||
}
|
||||
|
||||
if (is.null(vars)) {
|
||||
vars <- names(data)[!names(data) %in% outcome.str]
|
||||
} else if (!is.null(outcome.str)) {
|
||||
if (outcome.str %in% vars) {
|
||||
vars <- vars[!vars %in% outcome.str]
|
||||
}
|
||||
data <- data |> dplyr::select(dplyr::all_of(c(vars, outcome.str)))
|
||||
}
|
||||
|
||||
# Formatting character variables as factor
|
||||
# Improvement should add a missing vector to format as NA
|
||||
data <- data |>
|
||||
|
|
@ -122,7 +123,6 @@ regression_model <- function(data,
|
|||
msg = "Please provide the function as a character vector."
|
||||
)
|
||||
|
||||
# browser()
|
||||
out <- do.call(
|
||||
getfun(fun),
|
||||
c(
|
||||
|
|
@ -358,7 +358,7 @@ supported_functions <- function() {
|
|||
#' dplyr::select("cyl") |>
|
||||
#' possible_functions(design = "cross-sectional")
|
||||
possible_functions <- function(data, design = c("cross-sectional")) {
|
||||
# browser()
|
||||
#
|
||||
# data <- if (is.reactive(data)) data() else data
|
||||
if (is.data.frame(data)) {
|
||||
data <- data[[1]]
|
||||
|
|
@ -511,31 +511,36 @@ regression_model_list <- function(data,
|
|||
}
|
||||
|
||||
parameters <- list(
|
||||
outcome.str = outcome.str,
|
||||
data = data,
|
||||
fun = fun.c,
|
||||
formula.str = formula.str.c,
|
||||
formula.str = glue::glue(formula.str.c),
|
||||
args.list = args.list.c
|
||||
)
|
||||
|
||||
model <- do.call(
|
||||
regression_model,
|
||||
append_list(parameters,
|
||||
data = data, "data"
|
||||
)
|
||||
parameters
|
||||
)
|
||||
|
||||
parameters_print <- list2str(Filter(length,
|
||||
parameters_code <- Filter(
|
||||
length,
|
||||
modifyList(parameters, list(
|
||||
formula.str = glue::glue(formula.str.c),
|
||||
args.list = NULL
|
||||
))))
|
||||
data=as.symbol("df"),
|
||||
formula.str = as.character(glue::glue(formula.str.c)),
|
||||
outcome.str = NULL
|
||||
# args.list = NULL,
|
||||
)
|
||||
))
|
||||
|
||||
code <- glue::glue("FreesearchR::regression_model(data,{parameters_print}, args.list=list({list2str(args.list.c)}))",.null = "NULL")
|
||||
## The easiest solution was to simple paste as a string
|
||||
## The rlang::call2 or rlang::expr functions would probably work as well
|
||||
# code <- glue::glue("FreesearchR::regression_model({parameters_print}, args.list=list({list2str(args.list.c)}))", .null = "NULL")
|
||||
code <- rlang::call2("regression_model",!!!parameters_code,.ns = "FreesearchR")
|
||||
|
||||
list(
|
||||
options = options,
|
||||
model = model,
|
||||
code = code
|
||||
code = expression_string(code)
|
||||
)
|
||||
}
|
||||
|
||||
|
|
@ -575,6 +580,8 @@ list2str <- function(data) {
|
|||
#' dplyr::bind_rows()
|
||||
#' ms <- regression_model_uv_list(data = default_parsing(mtcars), outcome.str = "mpg", fun.descr = "Linear regression model")
|
||||
#' ms$code
|
||||
#' ls <- regression_model_uv_list(data = default_parsing(mtcars), outcome.str = "am", fun.descr = "Logistic regression model")
|
||||
#' ls$code
|
||||
#' lapply(ms$model, broom::tidy) |> dplyr::bind_rows()
|
||||
#' }
|
||||
regression_model_uv_list <- function(data,
|
||||
|
|
@ -637,41 +644,35 @@ regression_model_uv_list <- function(data,
|
|||
# )
|
||||
# )
|
||||
|
||||
parameters <- list(
|
||||
outcome.str = outcome.str,
|
||||
model <- vars |>
|
||||
lapply(\(.var){
|
||||
|
||||
parameters <-
|
||||
list(
|
||||
fun = fun.c,
|
||||
formula.str = formula.str.c,
|
||||
data = data[c(outcome.str, .var)],
|
||||
formula.str = as.character(glue::glue(gsub("vars", ".var", formula.str.c))),
|
||||
args.list = args.list.c
|
||||
)
|
||||
|
||||
model <- vars |>
|
||||
lapply(\(.var){
|
||||
out <- do.call(
|
||||
regression_model,
|
||||
append_list(parameters,
|
||||
data = data[c(outcome.str, .var)], "data"
|
||||
)
|
||||
parameters
|
||||
)
|
||||
|
||||
## This is the very long version
|
||||
## Handles deeply nested glue string
|
||||
code <- glue::glue("FreesearchR::regression_model({list2str(modifyList(parameters,list(formula.str = glue::glue(gsub('vars','.var',formula.str.c)))))})")
|
||||
# code <- glue::glue("FreesearchR::regression_model(data=df,{list2str(modifyList(parameters,list(data=NULL,args.list=list2str(args.list.c))))})")
|
||||
code <- rlang::call2("regression_model",!!!modifyList(parameters,list(data=as.symbol("df"),args.list=args.list.c)),.ns = "FreesearchR")
|
||||
REDCapCAST::set_attr(out, code, "code")
|
||||
})
|
||||
|
||||
# vars <- "."
|
||||
#
|
||||
# code_raw <- glue::glue(
|
||||
# "{fun.c}({paste(Filter(length,list(glue::glue(formula.str.c),'data = .d',list2str(args.list.c))),collapse=', ')})"
|
||||
# )
|
||||
# browser()
|
||||
# code <- glue::glue("lapply(data,function(.d){code_raw})")
|
||||
|
||||
code <- model |>
|
||||
lapply(\(.x)REDCapCAST::get_attr(.x, "code")) |>
|
||||
purrr::reduce(c) |>
|
||||
lapply(expression_string) |>
|
||||
pipe_string(collapse = ",\n") |>
|
||||
(\(.x){
|
||||
paste0("list(\n", paste(.x, collapse = ",\n"), ")")
|
||||
paste0("list(\n", .x, ")")
|
||||
})()
|
||||
|
||||
|
||||
|
|
@ -681,3 +682,6 @@ regression_model_uv_list <- function(data,
|
|||
code = code
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
# regression_model(mtcars, fun = "stats::lm", formula.str = "mpg~cyl")
|
||||
|
|
|
|||
25
R/syntax_highlight.R
Normal file
25
R/syntax_highlight.R
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
## Inpiration:
|
||||
##
|
||||
## https://stackoverflow.com/questions/47445260/how-to-enable-syntax-highlighting-in-r-shiny-app-with-htmloutput
|
||||
|
||||
prismCodeBlock <- function(code) {
|
||||
tagList(
|
||||
HTML(html_code_wrap(code)),
|
||||
tags$script("Prism.highlightAll()")
|
||||
)
|
||||
}
|
||||
|
||||
prismDependencies <- tags$head(
|
||||
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/prism.min.js"),
|
||||
tags$link(rel = "stylesheet", type = "text/css",
|
||||
href = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/themes/prism.min.css")
|
||||
)
|
||||
|
||||
prismRDependency <- tags$head(
|
||||
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/components/prism-r.min.js")
|
||||
)
|
||||
|
||||
html_code_wrap <- function(string,lang="r"){
|
||||
glue::glue("<pre><code class='language-{lang}'>{string}
|
||||
</code></pre>")
|
||||
}
|
||||
|
|
@ -174,10 +174,14 @@ update_variables_server <- function(id,
|
|||
|
||||
old_label <- data_inputs$label
|
||||
new_label <- data_inputs$label_toset
|
||||
new_label[new_label == "New label"] <- ""
|
||||
new_label[is.na(new_label)] <- old_label[is.na(new_label)]
|
||||
new_label[new_label == ""] <- old_label[new_label == ""]
|
||||
new_label <- setNames(new_label,new_names)
|
||||
|
||||
new_label[new_label == "New label"] <- old_label[new_label == "New label"]
|
||||
|
||||
## Later, "" will be interpreted as NA/empty and removed
|
||||
new_label[is.na(new_label) | new_label %in% c('""',"''"," ")] <- ""
|
||||
|
||||
# new_label[is.na(new_label)] <- old_label[is.na(new_label)]
|
||||
new_label <- setNames(new_label, new_names)
|
||||
|
||||
new_classes <- data_inputs$class_toset
|
||||
new_classes[new_classes == "Select"] <- NA
|
||||
|
|
@ -210,17 +214,7 @@ update_variables_server <- function(id,
|
|||
|
||||
# relabel
|
||||
list_relabel <- as.list(new_label)
|
||||
data <- purrr::map2(
|
||||
data, list_relabel,
|
||||
\(.data, .label){
|
||||
if (!(is.na(.label) | .label == "")) {
|
||||
REDCapCAST::set_attr(.data, .label, attr = "label")
|
||||
} else {
|
||||
attr(x = .data, which = "label") <- NULL
|
||||
.data
|
||||
}
|
||||
}
|
||||
) |> dplyr::bind_cols(.name_repair = "unique_quiet")
|
||||
data <- set_column_label(data, list_relabel)
|
||||
|
||||
# select
|
||||
list_select <- setdiff(names(data), names(data)[new_selections])
|
||||
|
|
@ -256,30 +250,16 @@ update_variables_server <- function(id,
|
|||
data <- updated_data$x
|
||||
code <- list()
|
||||
if (!is.null(data) && shiny::isTruthy(updated_data$list_mutate) && length(updated_data$list_mutate) > 0) {
|
||||
code <- c(code, list(rlang::call2("mutate", !!!updated_data$list_mutate)))
|
||||
code <- c(code, list(rlang::call2("mutate", !!!updated_data$list_mutate,.ns="dplyr")))
|
||||
}
|
||||
if (!is.null(data) && shiny::isTruthy(updated_data$list_rename) && length(updated_data$list_rename) > 0) {
|
||||
code <- c(code, list(rlang::call2("rename", !!!updated_data$list_rename)))
|
||||
code <- c(code, list(rlang::call2("rename", !!!updated_data$list_rename,.ns="dplyr")))
|
||||
}
|
||||
if (!is.null(data) && shiny::isTruthy(updated_data$list_select) && length(updated_data$list_select) > 0) {
|
||||
code <- c(code, list(rlang::expr(select(-any_of(c(!!!updated_data$list_select))))))
|
||||
code <- c(code, list(rlang::expr(dplyr::select(-dplyr::any_of(c(!!!updated_data$list_select))))))
|
||||
}
|
||||
if (!is.null(data) && shiny::isTruthy(updated_data$list_relabel) && length(updated_data$list_relabel) > 0) {
|
||||
code <- c(
|
||||
code,
|
||||
list(
|
||||
rlang::expr(purrr::imap(.f=function(.data, .name) {
|
||||
ls <- !!updated_data$list_relabel
|
||||
ls <- ls[!is.na(ls)]
|
||||
if (.name %in% names(ls)) {
|
||||
REDCapCAST::set_attr(.data, ls[.name], attr = "label")
|
||||
} else {
|
||||
.data
|
||||
}
|
||||
}) %>% dplyr::bind_cols()
|
||||
)
|
||||
)
|
||||
)
|
||||
code <- c(code,list(rlang::call2("set_column_label",label=updated_data$list_relabel,.ns="FreesearchR")))
|
||||
}
|
||||
if (length(code) > 0) {
|
||||
attr(data, "code") <- Reduce(
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -5,6 +5,6 @@ account: agdamsbo
|
|||
server: shinyapps.io
|
||||
hostUrl: https://api.shinyapps.io/v1
|
||||
appId: 13611288
|
||||
bundleId: 10085560
|
||||
bundleId: 10098670
|
||||
url: https://agdamsbo.shinyapps.io/freesearcheR/
|
||||
version: 1
|
||||
|
|
|
|||
|
|
@ -106,7 +106,7 @@ server <- function(input, output, session) {
|
|||
shiny::observeEvent(data_file$data(), {
|
||||
shiny::req(data_file$data())
|
||||
rv$data_temp <- data_file$data()
|
||||
rv$code <- append_list(data = data_file$code(), list = rv$code, index = "import")
|
||||
rv$code <- modifyList(x = rv$code, list(import = data_file$code()))
|
||||
})
|
||||
|
||||
from_redcap <- m_redcap_readServer(
|
||||
|
|
@ -116,9 +116,10 @@ server <- function(input, output, session) {
|
|||
shiny::observeEvent(from_redcap$data(), {
|
||||
# rv$data_original <- purrr::pluck(data_redcap(), "data")()
|
||||
rv$data_temp <- from_redcap$data()
|
||||
rv$code <- append_list(data = from_redcap$code(), list = rv$code, index = "import")
|
||||
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),
|
||||
|
|
@ -140,7 +141,7 @@ server <- function(input, output, session) {
|
|||
shiny::req(from_env$data())
|
||||
|
||||
rv$data_temp <- from_env$data()
|
||||
rv$code <- append_list(data = from_env$name(),list = rv$code,index = "import")
|
||||
rv$code <- modifyList(x = rv$code, list(import = from_env$name()))
|
||||
})
|
||||
|
||||
output$import_var <- shiny::renderUI({
|
||||
|
|
@ -190,11 +191,12 @@ server <- function(input, output, session) {
|
|||
|
||||
rv$code$import <- list(
|
||||
rv$code$import,
|
||||
rlang::call2(.fn = "select", input$import_var, .ns = "dplyr"),
|
||||
rlang::expr(dplyr::select(dplyr::all_of(!!input$import_var))),
|
||||
rlang::call2(.fn = "default_parsing", .ns = "FreesearchR")
|
||||
) |>
|
||||
merge_expression() |>
|
||||
expression_string()
|
||||
lapply(expression_string) |>
|
||||
pipe_string() |>
|
||||
expression_string(assign.str = "df <-")
|
||||
|
||||
|
||||
# rv$code$import <- rv$code$import |>
|
||||
|
|
@ -217,12 +219,17 @@ server <- function(input, output, session) {
|
|||
data_description(rv$data_original)
|
||||
})
|
||||
|
||||
|
||||
## Activating action buttons on data imported
|
||||
shiny::observeEvent(rv$data_original, {
|
||||
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 = "act_eval", disabled = TRUE)
|
||||
|
||||
} else {
|
||||
shiny::updateActionButton(inputId = "act_start", disabled = FALSE)
|
||||
shiny::updateActionButton(inputId = "modal_browse", disabled = FALSE)
|
||||
shiny::updateActionButton(inputId = "act_eval", disabled = FALSE)
|
||||
}
|
||||
})
|
||||
|
||||
|
|
@ -386,6 +393,8 @@ server <- function(input, output, session) {
|
|||
rv$list$data <- data_filter() |>
|
||||
REDCapCAST::fct_drop()
|
||||
|
||||
## This looks messy!! But it works as intended for now
|
||||
|
||||
out <- gsub(
|
||||
"filter", "dplyr::filter",
|
||||
gsub(
|
||||
|
|
@ -400,7 +409,7 @@ server <- function(input, output, session) {
|
|||
out <- strsplit(out, "%>%") |>
|
||||
unlist() |>
|
||||
(\(.x){
|
||||
paste(c("data <- data", .x[-1], "REDCapCAST::fct_drop()"),
|
||||
paste(c("df <- df", .x[-1], "REDCapCAST::fct_drop()"),
|
||||
collapse = "|> \n "
|
||||
)
|
||||
})()
|
||||
|
|
@ -446,45 +455,37 @@ server <- function(input, output, session) {
|
|||
#########
|
||||
##############################################################################
|
||||
|
||||
output$code_import <- shiny::renderPrint({
|
||||
shiny::req(rv$code$import)
|
||||
cat(c("#Data import\n",rv$code$import))
|
||||
## This really should be collapsed to only one call, but I'll leave it for now
|
||||
## as a working example of dynamically defining outputs and rendering.
|
||||
|
||||
# output$code_import <- shiny::renderPrint({
|
||||
# shiny::req(rv$code$import)
|
||||
# cat(c("#Data import\n", rv$code$import))
|
||||
# })
|
||||
|
||||
output$code_import <- shiny::renderUI({
|
||||
prismCodeBlock(paste0("#Data import\n", rv$code$import))
|
||||
})
|
||||
|
||||
output$code_data <- shiny::renderPrint({
|
||||
output$code_data <- shiny::renderUI({
|
||||
shiny::req(rv$code$modify)
|
||||
# browser()
|
||||
ls <- rv$code$modify |> unique()
|
||||
out <- ls |>
|
||||
merge_expression() |>
|
||||
expression_string(assign.str = "data <- data |>\n")
|
||||
lapply(expression_string) |>
|
||||
pipe_string() |>
|
||||
expression_string(assign.str = "df <- df |>\n")
|
||||
|
||||
# out <- paste("data <- data |>",
|
||||
# sapply(ls, \(.x) paste(deparse(.x), collapse = ",")),
|
||||
# collapse = "|>"
|
||||
# ) |>
|
||||
# (\(.x){
|
||||
# gsub(
|
||||
# "\\|>", "\\|> \n",
|
||||
# gsub(
|
||||
# "%>%", "",
|
||||
# gsub(
|
||||
# "\\s{2,}", " ",
|
||||
# gsub(",\\s{,},", ", ", .x)
|
||||
# )
|
||||
# )
|
||||
# )
|
||||
# })()
|
||||
cat(c("#Data modifications\n",out))
|
||||
prismCodeBlock(paste0("#Data modifications\n", out))
|
||||
})
|
||||
|
||||
output$code_filter <- shiny::renderPrint({
|
||||
cat(c("#Data filter\n",rv$code$filter))
|
||||
output$code_filter <- shiny::renderUI({
|
||||
prismCodeBlock(paste0("#Data filter\n", rv$code$filter))
|
||||
})
|
||||
|
||||
output$code_table1 <- shiny::renderPrint({
|
||||
output$code_table1 <- shiny::renderUI({
|
||||
shiny::req(rv$code$table1)
|
||||
cat(c("#Data characteristics table\n",rv$code$table1))
|
||||
prismCodeBlock(paste0("#Data characteristics table\n", rv$code$table1))
|
||||
})
|
||||
|
||||
|
||||
|
|
@ -492,8 +493,8 @@ server <- function(input, output, session) {
|
|||
## This is a very rewarding couple of lines marking new insights to dynamically rendering code
|
||||
shiny::observe({
|
||||
rv$regression()$regression$models |> purrr::imap(\(.x, .i){
|
||||
output[[paste0("code_", tolower(.i))]] <- shiny::renderPrint({
|
||||
cat(.x$code_table)
|
||||
output[[paste0("code_", tolower(.i))]] <- shiny::renderUI({
|
||||
prismCodeBlock(paste0(paste("#",.i,"regression model\n"),.x$code_table))
|
||||
})
|
||||
})
|
||||
})
|
||||
|
|
|
|||
|
|
@ -138,7 +138,7 @@ ui_elements <- list(
|
|||
width = 9,
|
||||
shiny::uiOutput(outputId = "data_info", inline = TRUE),
|
||||
shiny::tags$p(
|
||||
"Below is a short summary table, on the right you can create data filters."
|
||||
"Below is a short summary table, on the right you can click to browse data and create data filters."
|
||||
)
|
||||
)
|
||||
),
|
||||
|
|
@ -152,7 +152,8 @@ ui_elements <- list(
|
|||
shiny::actionButton(
|
||||
inputId = "modal_browse",
|
||||
label = "Browse data",
|
||||
width = "100%"
|
||||
width = "100%",
|
||||
disabled = TRUE
|
||||
),
|
||||
shiny::tags$br(),
|
||||
shiny::tags$br(),
|
||||
|
|
@ -172,8 +173,10 @@ ui_elements <- list(
|
|||
fluidRow(
|
||||
shiny::column(
|
||||
width = 9,
|
||||
shiny::tags$p(shiny::markdown("Below, are several options for simple data manipulation like update variables by renaming, creating new labels (for nicer tables in the report) and changing variable classes (numeric, factor/categorical etc.)."),
|
||||
shiny::tags$p("There are also more advanced options to modify factor/categorical variables as well as create new factor from a continous variable or new variables with *R* code. At the bottom you can restore the original data."))
|
||||
shiny::tags$p(
|
||||
shiny::markdown("Below, are several options for simple data manipulation like update variables by renaming, creating new labels (for nicer tables in the report) and changing variable classes (numeric, factor/categorical etc.)."),
|
||||
shiny::tags$p("There are also more advanced options to modify factor/categorical variables as well as create new factor from a continous variable or new variables with *R* code. At the bottom you can restore the original data.")
|
||||
)
|
||||
)
|
||||
),
|
||||
# shiny::tags$br(),
|
||||
|
|
@ -291,7 +294,7 @@ ui_elements <- list(
|
|||
label = "Evaluate",
|
||||
width = "100%",
|
||||
icon = shiny::icon("calculator"),
|
||||
disabled = FALSE
|
||||
disabled = TRUE
|
||||
)
|
||||
),
|
||||
bslib::accordion_panel(
|
||||
|
|
@ -439,18 +442,16 @@ ui_elements <- list(
|
|||
shiny::br(),
|
||||
shiny::br(),
|
||||
shiny::h4("Code snippets"),
|
||||
shiny::tags$p("Below are the code used to create the final data set. This can be saved for reproducibility. The code may not be 100 % correct, but kan be used for learning and example code to get started on coding yourself."),
|
||||
shiny::tagAppendChildren(
|
||||
shiny::tags$p("Below are the code bits used to create the final data set and the main analyses."),
|
||||
shiny::tags$p("This can be used as a starting point for learning to code and for reproducibility."),
|
||||
shiny::tagList(
|
||||
shiny::verbatimTextOutput(outputId = "code_import"),
|
||||
shiny::verbatimTextOutput(outputId = "code_data"),
|
||||
shiny::verbatimTextOutput(outputId = "code_filter"),
|
||||
shiny::verbatimTextOutput(outputId = "code_table1")
|
||||
),
|
||||
lapply(paste0("code_",c("univariable","multivariable")),
|
||||
\(.x)shiny::verbatimTextOutput(outputId = .x))
|
||||
lapply(
|
||||
paste0("code_", c(
|
||||
"import", "data", "filter", "table1", "univariable", "multivariable"
|
||||
)),
|
||||
\(.x)shiny::htmlOutput(outputId = .x)
|
||||
)
|
||||
,
|
||||
),
|
||||
shiny::tags$br(),
|
||||
shiny::br()
|
||||
),
|
||||
|
|
@ -489,6 +490,8 @@ dark <- custom_theme(
|
|||
# https://webdesignerdepot.com/17-open-source-fonts-youll-actually-love/
|
||||
|
||||
ui <- bslib::page_fixed(
|
||||
prismDependencies,
|
||||
prismRDependency,
|
||||
shiny::tags$head(includeHTML(("www/umami-app.html"))),
|
||||
shiny::tags$style(
|
||||
type = "text/css",
|
||||
|
|
|
|||
28
man/append_column.Rd
Normal file
28
man/append_column.Rd
Normal file
|
|
@ -0,0 +1,28 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/helpers.R
|
||||
\name{append_column}
|
||||
\alias{append_column}
|
||||
\title{Append a column to a data.frame}
|
||||
\usage{
|
||||
append_column(data, column, name, index = "right")
|
||||
}
|
||||
\arguments{
|
||||
\item{data}{data}
|
||||
|
||||
\item{column}{new column (vector) or data.frame with 1 column}
|
||||
|
||||
\item{name}{new name (pre-fix)}
|
||||
|
||||
\item{index}{desired location. May be "left", "right" or numeric index.}
|
||||
}
|
||||
\value{
|
||||
data.frame
|
||||
}
|
||||
\description{
|
||||
Append a column to a data.frame
|
||||
}
|
||||
\examples{
|
||||
mtcars |>
|
||||
dplyr::mutate(mpg_cut = mpg) |>
|
||||
append_column(mtcars$mpg, "mpg_cutter")
|
||||
}
|
||||
|
|
@ -1,15 +1,21 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/cut-variable-dates.R
|
||||
\name{cut.hms}
|
||||
\alias{cut.hms}
|
||||
\alias{cut.POSIXt}
|
||||
\alias{cut.POSIXct}
|
||||
\alias{cut.Date}
|
||||
\title{Extended cutting function}
|
||||
\name{cut_var}
|
||||
\alias{cut_var}
|
||||
\alias{cut_var.default}
|
||||
\alias{cut_var.hms}
|
||||
\alias{cut_var.POSIXt}
|
||||
\alias{cut_var.POSIXct}
|
||||
\alias{cut_var.Date}
|
||||
\title{Extended cutting function with fall-back to the native base::cut}
|
||||
\usage{
|
||||
\method{cut}{hms}(x, breaks, ...)
|
||||
cut_var(x, ...)
|
||||
|
||||
\method{cut}{POSIXt}(
|
||||
\method{cut_var}{default}(x, ...)
|
||||
|
||||
\method{cut_var}{hms}(x, breaks, ...)
|
||||
|
||||
\method{cut_var}{POSIXt}(
|
||||
x,
|
||||
breaks,
|
||||
right = FALSE,
|
||||
|
|
@ -18,7 +24,7 @@
|
|||
...
|
||||
)
|
||||
|
||||
\method{cut}{POSIXct}(
|
||||
\method{cut_var}{POSIXct}(
|
||||
x,
|
||||
breaks,
|
||||
right = FALSE,
|
||||
|
|
@ -27,7 +33,7 @@
|
|||
...
|
||||
)
|
||||
|
||||
\method{cut}{Date}(x, breaks, start.on.monday = TRUE, ...)
|
||||
\method{cut_var}{Date}(x, breaks, start.on.monday = TRUE, ...)
|
||||
}
|
||||
\arguments{
|
||||
\item{x}{an object inheriting from class "POSIXct"}
|
||||
|
|
@ -38,19 +44,19 @@
|
|||
factor
|
||||
}
|
||||
\description{
|
||||
Extended cutting function
|
||||
Extended cutting function with fall-back to the native base::cut
|
||||
}
|
||||
\examples{
|
||||
readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut(2)
|
||||
readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut("min")
|
||||
readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut(breaks = "hour")
|
||||
readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut(breaks = hms::as_hms(c("01:00:00", "03:01:20", "9:20:20")))
|
||||
readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut_var(2)
|
||||
readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut_var("min")
|
||||
readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut_var(breaks = "hour")
|
||||
readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut_var(breaks = hms::as_hms(c("01:00:00", "03:01:20", "9:20:20")))
|
||||
d_t <- readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA))
|
||||
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)
|
||||
readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut(2)
|
||||
readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut(breaks="weekday")
|
||||
readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut(breaks="month_only")
|
||||
as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut(2)
|
||||
as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut(breaks="weekday")
|
||||
f <- d_t |> cut_var(2)
|
||||
readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA)) |> cut_var(breaks = lubridate::as_datetime(c(hms::as_hms(levels(f)), hms::as_hms(max(d_t, na.rm = TRUE) + 1))), right = FALSE)
|
||||
readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(2)
|
||||
readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks = "weekday")
|
||||
readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks = "month_only")
|
||||
as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(2)
|
||||
as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks = "weekday")
|
||||
}
|
||||
|
|
@ -20,4 +20,9 @@ mtcars |> str()
|
|||
mtcars |>
|
||||
default_parsing() |>
|
||||
str()
|
||||
head(starwars, 5) |> str()
|
||||
starwars |>
|
||||
default_parsing() |>
|
||||
head(5) |>
|
||||
str()
|
||||
}
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
\alias{expression_string}
|
||||
\title{Deparses expression as string, substitutes native pipe and adds assign}
|
||||
\usage{
|
||||
expression_string(data, assign.str = "data <- ")
|
||||
expression_string(data, assign.str = "")
|
||||
}
|
||||
\arguments{
|
||||
\item{data}{expression}
|
||||
|
|
@ -17,7 +17,9 @@ Deparses expression as string, substitutes native pipe and adds assign
|
|||
}
|
||||
\examples{
|
||||
list(
|
||||
rlang::call2(.fn = "select",!!!list(c("cyl","disp")),.ns = "dplyr"),
|
||||
rlang::call2(.fn = "default_parsing",.ns = "FreesearchR")
|
||||
) |> merge_expression() |> expression_string()
|
||||
rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .ns = "dplyr"),
|
||||
rlang::call2(.fn = "default_parsing", .ns = "FreesearchR")
|
||||
) |>
|
||||
merge_expression() |>
|
||||
expression_string()
|
||||
}
|
||||
|
|
|
|||
|
|
@ -19,6 +19,6 @@ Return if available
|
|||
}
|
||||
\examples{
|
||||
NULL |> if_not_missing("new")
|
||||
c(2,"a",NA) |> if_not_missing()
|
||||
c(2, "a", NA) |> if_not_missing()
|
||||
"See" |> if_not_missing()
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,17 +0,0 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/file-import-module.R
|
||||
\name{m_datafileUI}
|
||||
\alias{m_datafileUI}
|
||||
\title{Shiny UI module to load a data file}
|
||||
\usage{
|
||||
m_datafileUI(id)
|
||||
}
|
||||
\arguments{
|
||||
\item{id}{id}
|
||||
}
|
||||
\value{
|
||||
shiny UI
|
||||
}
|
||||
\description{
|
||||
Shiny UI module to load a data file
|
||||
}
|
||||
|
|
@ -17,7 +17,7 @@ Merge list of expressions
|
|||
}
|
||||
\examples{
|
||||
list(
|
||||
rlang::call2(.fn = "select",!!!list(c("cyl","disp")),.ns = "dplyr"),
|
||||
rlang::call2(.fn = "default_parsing",.ns = "FreesearchR")
|
||||
rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .ns = "dplyr"),
|
||||
rlang::call2(.fn = "default_parsing", .ns = "FreesearchR")
|
||||
) |> merge_expression()
|
||||
}
|
||||
|
|
|
|||
27
man/pipe_string.Rd
Normal file
27
man/pipe_string.Rd
Normal file
|
|
@ -0,0 +1,27 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/helpers.R
|
||||
\name{pipe_string}
|
||||
\alias{pipe_string}
|
||||
\title{Reduce character vector with the native pipe operator or character string}
|
||||
\usage{
|
||||
pipe_string(data, collapse = "|>\\n")
|
||||
}
|
||||
\arguments{
|
||||
\item{data}{list}
|
||||
}
|
||||
\value{
|
||||
character string
|
||||
}
|
||||
\description{
|
||||
Reduce character vector with the native pipe operator or character string
|
||||
}
|
||||
\examples{
|
||||
list(
|
||||
"mtcars",
|
||||
rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .ns = "dplyr"),
|
||||
rlang::call2(.fn = "default_parsing", .ns = "FreesearchR")
|
||||
) |>
|
||||
lapply(expression_string) |>
|
||||
pipe_string() |>
|
||||
expression_string("data<-")
|
||||
}
|
||||
17
man/remove_empty_attr.Rd
Normal file
17
man/remove_empty_attr.Rd
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/helpers.R
|
||||
\name{remove_empty_attr}
|
||||
\alias{remove_empty_attr}
|
||||
\title{Remove empty/NA attributes}
|
||||
\usage{
|
||||
remove_empty_attr(data)
|
||||
}
|
||||
\arguments{
|
||||
\item{data}{data}
|
||||
}
|
||||
\value{
|
||||
data of same class as input
|
||||
}
|
||||
\description{
|
||||
Remove empty/NA attributes
|
||||
}
|
||||
21
man/remove_nested_list.Rd
Normal file
21
man/remove_nested_list.Rd
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/helpers.R
|
||||
\name{remove_nested_list}
|
||||
\alias{remove_nested_list}
|
||||
\title{Very simple function to remove nested lists, lik ewhen uploading .rds}
|
||||
\usage{
|
||||
remove_nested_list(data)
|
||||
}
|
||||
\arguments{
|
||||
\item{data}{data}
|
||||
}
|
||||
\value{
|
||||
data.frame
|
||||
}
|
||||
\description{
|
||||
Very simple function to remove nested lists, lik ewhen uploading .rds
|
||||
}
|
||||
\examples{
|
||||
dplyr::tibble(a = 1:10, b = rep(list("a"), 10)) |> remove_nested_list()
|
||||
dplyr::tibble(a = 1:10, b = rep(list(c("a", "b")), 10)) |> as.data.frame()
|
||||
}
|
||||
29
man/set_column_label.Rd
Normal file
29
man/set_column_label.Rd
Normal file
|
|
@ -0,0 +1,29 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/helpers.R
|
||||
\name{set_column_label}
|
||||
\alias{set_column_label}
|
||||
\title{(Re)label columns in data.frame}
|
||||
\usage{
|
||||
set_column_label(data, label, overwrite = TRUE)
|
||||
}
|
||||
\arguments{
|
||||
\item{data}{data.frame to be labelled}
|
||||
|
||||
\item{label}{named list or vector}
|
||||
}
|
||||
\value{
|
||||
data.frame
|
||||
}
|
||||
\description{
|
||||
(Re)label columns in data.frame
|
||||
}
|
||||
\examples{
|
||||
ls <- list("mpg" = "", "cyl" = "Cylinders", "disp" = "", "hp" = "", "drat" = "", "wt" = "", "qsec" = "", "vs" = "", "am" = "", "gear" = "", "carb" = "")
|
||||
ls2 <- c("mpg" = "", "cyl" = "Cylinders", "disp" = "", "hp" = "Horses", "drat" = "", "wt" = "", "qsec" = "", "vs" = "", "am" = "", "gear" = "", "carb" = "")
|
||||
ls3 <- c("mpg" = "", "cyl" = "", "disp" = "", "hp" = "Horses", "drat" = "", "wt" = "", "qsec" = "", "vs" = "", "am" = "", "gear" = "", "carb" = "")
|
||||
mtcars |>
|
||||
set_column_label(ls) |>
|
||||
set_column_label(ls2) |>
|
||||
set_column_label(ls3)
|
||||
rlang::expr(FreesearchR::set_column_label(label = !!ls3)) |> expression_string()
|
||||
}
|
||||
|
|
@ -22,5 +22,5 @@ vector
|
|||
Drop-in replacement for the base::sort_by with option to remove NAs
|
||||
}
|
||||
\examples{
|
||||
sort_by(c("Multivariable", "Univariable"),c("Univariable","Minimal","Multivariable"))
|
||||
sort_by(c("Multivariable", "Univariable"), c("Univariable", "Minimal", "Multivariable"))
|
||||
}
|
||||
|
|
|
|||
|
|
@ -98,12 +98,36 @@ c("continuous", "dichotomous", "ordinal", "categorical") |>
|
|||
kableExtra::kable()
|
||||
```
|
||||
|
||||
Export the plots directly from the sidebar with easily adjusted plot dimensions for your next publication.
|
||||
|
||||
Also copy the code to generate the plot in your own R-environment and fine tune all the small details.
|
||||
|
||||
## Regression
|
||||
|
||||
This section is only intended for very simple explorative analyses and as a proof-of-concept for now. If you are doing complex regression analyses you should probably just write the code yourself.
|
||||
|
||||
### Table
|
||||
|
||||
Generate simple regression models and get the results in a nice table. This will also be included in the exported report.
|
||||
|
||||
### Plots
|
||||
|
||||
Plot the coefficients from the regression models in a forest plot. Choose which model(s) to include.
|
||||
|
||||
### Checks
|
||||
|
||||
Check model assumptions visually. Supported checks can be chosen.
|
||||
|
||||
## Download
|
||||
|
||||
### Report
|
||||
|
||||
Download a nice report with baseline characteristics and regression model results. Choose between MS Word or LibreOffice format.
|
||||
|
||||
### Data
|
||||
|
||||
Export the modified dataset in different formats.
|
||||
|
||||
### Code
|
||||
|
||||
See all the code snippets from the different steps in your data evaluation.
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue