mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2025-09-12 01:49:39 +02:00
This commit is contained in:
parent
347490605f
commit
8469a5ca64
13 changed files with 1123 additions and 273 deletions
|
|
@ -133,12 +133,14 @@ 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)
|
||||
|
|
@ -147,6 +149,7 @@ importFrom(shiny,observeEvent)
|
|||
importFrom(shiny,plotOutput)
|
||||
importFrom(shiny,reactive)
|
||||
importFrom(shiny,reactiveValues)
|
||||
importFrom(shiny,removeUI)
|
||||
importFrom(shiny,renderPlot)
|
||||
importFrom(shiny,req)
|
||||
importFrom(shiny,restoreInput)
|
||||
|
|
@ -171,4 +174,5 @@ importFrom(toastui,grid_colorbar)
|
|||
importFrom(toastui,grid_columns)
|
||||
importFrom(toastui,renderDatagrid)
|
||||
importFrom(toastui,renderDatagrid2)
|
||||
importFrom(utils,data)
|
||||
importFrom(utils,type.convert)
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
app_version <- function()'Version: 25.4.1.250409_1216'
|
||||
app_version <- function()'Version: 25.4.1.250410_1545'
|
||||
|
|
|
|||
|
|
@ -104,13 +104,13 @@ library(shiny)
|
|||
cut.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, ...)
|
||||
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"))))
|
||||
if (hms::is_hms(breaks)) {
|
||||
breaks <- lubridate::as_datetime(breaks)
|
||||
}
|
||||
x <- lubridate::as_datetime(x)
|
||||
out <- cut.POSIXt(x, breaks = breaks, ...)
|
||||
attr(out, which = "brks") <- hms::as_hms(lubridate::as_datetime(attr(out, which = "brks")))
|
||||
attr(out, which = "levels") <- as.character(hms::as_hms(lubridate::as_datetime(attr(out, which = "levels"))))
|
||||
})
|
||||
out
|
||||
}
|
||||
|
|
@ -120,9 +120,9 @@ cut.hms <- function(x, breaks, ...) {
|
|||
#'
|
||||
#' @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(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, ...) {
|
||||
breaks_o <- breaks
|
||||
# browser()
|
||||
if (is.numeric(breaks)) {
|
||||
|
|
@ -131,30 +131,34 @@ cut.POSIXt <- function(x, breaks, right = FALSE, include.lowest = TRUE, start.on
|
|||
probs = seq(0, 1, 1 / breaks),
|
||||
right = right,
|
||||
include.lowest = include.lowest,
|
||||
na.rm=TRUE
|
||||
na.rm = TRUE
|
||||
)
|
||||
}
|
||||
|
||||
if(identical(breaks,"weekday")){
|
||||
days <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday",
|
||||
"Sunday")
|
||||
if (!start.on.monday){
|
||||
days <- days[c(7,1:6)]
|
||||
if (identical(breaks, "weekday")) {
|
||||
days <- c(
|
||||
"Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday",
|
||||
"Sunday"
|
||||
)
|
||||
if (!start.on.monday) {
|
||||
days <- days[c(7, 1:6)]
|
||||
}
|
||||
out <- factor(weekdays(x),levels=days) |> forcats::fct_drop()
|
||||
} else if (identical(breaks,"month_only")){
|
||||
ms <- paste0("1970-",1:12,"-01") |> as.Date() |> months()
|
||||
out <- factor(weekdays(x), levels = days) |> forcats::fct_drop()
|
||||
} else if (identical(breaks, "month_only")) {
|
||||
ms <- paste0("1970-", 1:12, "-01") |>
|
||||
as.Date() |>
|
||||
months()
|
||||
|
||||
out <- factor(months(x),levels=ms) |> forcats::fct_drop()
|
||||
out <- factor(months(x), levels = ms) |> forcats::fct_drop()
|
||||
} else {
|
||||
## Doesn't really work very well for breaks other than the special character cases as right border is excluded
|
||||
out <- base::cut.POSIXt(x, breaks=breaks,right=right,...) |> forcats::fct_drop()
|
||||
# browser()
|
||||
}
|
||||
## Doesn't really work very well for breaks other than the special character cases as right border is excluded
|
||||
out <- base::cut.POSIXt(x, breaks = breaks, right = right, ...) |> forcats::fct_drop()
|
||||
# browser()
|
||||
}
|
||||
l <- levels(out)
|
||||
if (is.numeric(breaks_o)) {
|
||||
l <- breaks
|
||||
} else if (is.character(breaks) && length(breaks) == 1 && !(identical(breaks,"weekday") | identical(breaks,"month_only"))) {
|
||||
} else if (is.character(breaks) && length(breaks) == 1 && !(identical(breaks, "weekday") | identical(breaks, "month_only"))) {
|
||||
if (include.lowest) {
|
||||
if (right) {
|
||||
l <- c(l, min(as.character(x)))
|
||||
|
|
@ -179,22 +183,26 @@ cut.POSIXct <- cut.POSIXt
|
|||
#'
|
||||
#' @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,...){
|
||||
if(identical(breaks,"weekday")){
|
||||
days <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday",
|
||||
"Sunday")
|
||||
if (!start.on.monday){
|
||||
days <- days[c(7,1:6)]
|
||||
#' 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, ...) {
|
||||
if (identical(breaks, "weekday")) {
|
||||
days <- c(
|
||||
"Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday",
|
||||
"Sunday"
|
||||
)
|
||||
if (!start.on.monday) {
|
||||
days <- days[c(7, 1:6)]
|
||||
}
|
||||
out <- factor(weekdays(x),levels=days) |> forcats::fct_drop()
|
||||
} else if (identical(breaks,"month_only")){
|
||||
ms <- paste0("1970-",1:12,"-01") |> as.Date() |> months()
|
||||
out <- factor(weekdays(x), levels = days) |> forcats::fct_drop()
|
||||
} else if (identical(breaks, "month_only")) {
|
||||
ms <- paste0("1970-", 1:12, "-01") |>
|
||||
as.Date() |>
|
||||
months()
|
||||
|
||||
out <- factor(months(x),levels=ms) |> forcats::fct_drop()
|
||||
out <- factor(months(x), levels = ms) |> forcats::fct_drop()
|
||||
} else {
|
||||
## Doesn't really work very well for breaks other than the special character cases as right border is excluded
|
||||
out <- base::cut.Date(x, breaks=breaks,...) |> forcats::fct_drop()
|
||||
out <- base::cut.Date(x, breaks = breaks, ...) |> forcats::fct_drop()
|
||||
# browser()
|
||||
}
|
||||
out
|
||||
|
|
@ -384,11 +392,11 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
|||
|
||||
choices <- c(
|
||||
# "quantile"
|
||||
)
|
||||
)
|
||||
|
||||
if ("hms" %in% class(data[[variable]])) {
|
||||
choices <- c(choices, "hour")
|
||||
} else if (any(c("POSIXt","Date") %in% class(data[[variable]]))) {
|
||||
} else if (any(c("POSIXt", "Date") %in% class(data[[variable]]))) {
|
||||
choices <- c(
|
||||
choices,
|
||||
"day",
|
||||
|
|
@ -497,12 +505,16 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
|||
data_cutted_r <- reactive({
|
||||
data <- req(data_r())
|
||||
variable <- req(input$variable)
|
||||
data[[paste0(variable, "_cut")]] <- cut(
|
||||
|
||||
new_variable <- data.frame(cut(
|
||||
x = data[[variable]],
|
||||
breaks = if (input$method %in% c("day", "weekday", "week", "month", "month_only", "quarter", "year", "hour")) input$method else breaks_r()$brks,
|
||||
include.lowest = input$include_lowest,
|
||||
right = input$right
|
||||
)
|
||||
)) |> setNames(paste0(variable, "_cut"))
|
||||
|
||||
data <- dplyr::bind_cols(data, new_variable, .name_repair = "unique_quiet")
|
||||
|
||||
code <- call2(
|
||||
"mutate",
|
||||
!!!set_names(
|
||||
|
|
|
|||
85
R/helpers.R
85
R/helpers.R
|
|
@ -209,26 +209,37 @@ file_export <- function(data, output.format = c("df", "teal", "list"), filename,
|
|||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' 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"))
|
||||
|
||||
out <- data |>
|
||||
setNames(make.names(names(data),unique = TRUE)) |>
|
||||
setNames(make.names(names(data), unique = TRUE)) |>
|
||||
## Temporary step to avoid nested list and crashing
|
||||
remove_nested_list() |>
|
||||
REDCapCAST::parse_data() |>
|
||||
REDCapCAST::as_factor() |>
|
||||
REDCapCAST::numchar2fct(numeric.threshold = 8, character.throshold = 10) |>
|
||||
REDCapCAST::as_logical() |>
|
||||
REDCapCAST::fct_drop()
|
||||
|
||||
purrr::map2(out, name_labels, \(.x, .l){
|
||||
if (!(is.na(.l) | .l == "")) {
|
||||
REDCapCAST::set_attr(.x, .l, attr = "label")
|
||||
} else {
|
||||
attr(x = .x, which = "label") <- NULL
|
||||
.x
|
||||
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)
|
||||
}
|
||||
# REDCapCAST::set_attr(data = .x, label = .l,attr = "label", overwrite = FALSE)
|
||||
}) |> dplyr::bind_cols()
|
||||
) |> dplyr::bind_cols()
|
||||
}
|
||||
|
||||
#' Remove NA labels
|
||||
|
|
@ -333,7 +344,7 @@ data_description <- function(data) {
|
|||
n <- nrow(data)
|
||||
n_var <- ncol(data)
|
||||
n_complete <- sum(complete.cases(data))
|
||||
p_complete <- n_complete/n
|
||||
p_complete <- n_complete / n
|
||||
|
||||
sprintf(
|
||||
i18n("Data has %s observations and %s variables, with %s (%s%%) complete cases."),
|
||||
|
|
@ -355,10 +366,10 @@ data_description <- function(data) {
|
|||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' sort_by(c("Multivariable", "Univariable"),c("Univariable","Minimal","Multivariable"))
|
||||
sort_by <- function(x,y,na.rm=FALSE,...){
|
||||
out <- base::sort_by(x,y,...)
|
||||
if (na.rm==TRUE){
|
||||
#' sort_by(c("Multivariable", "Univariable"), c("Univariable", "Minimal", "Multivariable"))
|
||||
sort_by <- function(x, y, na.rm = FALSE, ...) {
|
||||
out <- base::sort_by(x, y, ...)
|
||||
if (na.rm == TRUE) {
|
||||
out[!is.na(out)]
|
||||
} else {
|
||||
out
|
||||
|
|
@ -366,7 +377,7 @@ sort_by <- function(x,y,na.rm=FALSE,...){
|
|||
}
|
||||
|
||||
|
||||
get_ggplot_label <- function(data,label){
|
||||
get_ggplot_label <- function(data, label) {
|
||||
assertthat::assert_that(ggplot2::is.ggplot(data))
|
||||
data$labels[[label]]
|
||||
}
|
||||
|
|
@ -382,12 +393,12 @@ get_ggplot_label <- function(data,label){
|
|||
#'
|
||||
#' @examples
|
||||
#' NULL |> if_not_missing("new")
|
||||
#' c(2,"a",NA) |> if_not_missing()
|
||||
#' c(2, "a", NA) |> if_not_missing()
|
||||
#' "See" |> if_not_missing()
|
||||
if_not_missing <- function(data,default=NULL){
|
||||
if (length(data)>1){
|
||||
Reduce(c,lapply(data,if_not_missing))
|
||||
} else if (is.na(data) || is.null(data)){
|
||||
if_not_missing <- function(data, default = NULL) {
|
||||
if (length(data) > 1) {
|
||||
Reduce(c, lapply(data, if_not_missing))
|
||||
} else if (is.na(data) || is.null(data)) {
|
||||
return(default)
|
||||
} else {
|
||||
return(data)
|
||||
|
|
@ -404,10 +415,10 @@ if_not_missing <- function(data,default=NULL){
|
|||
#'
|
||||
#' @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()
|
||||
merge_expression <- function(data){
|
||||
merge_expression <- function(data) {
|
||||
Reduce(
|
||||
f = function(x, y) rlang::expr(!!x %>% !!y),
|
||||
x = data
|
||||
|
|
@ -423,11 +434,27 @@ merge_expression <- function(data){
|
|||
#'
|
||||
#' @examples
|
||||
#' list(
|
||||
#' 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)
|
||||
#' 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)
|
||||
}
|
||||
|
||||
|
||||
#' Very simple function to remove nested lists, lik ewhen uploading .rds
|
||||
#'
|
||||
#' @param data data
|
||||
#'
|
||||
#' @returns data.frame
|
||||
#' @export
|
||||
#'
|
||||
#' @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()
|
||||
remove_nested_list <- function(data) {
|
||||
data[!sapply(data, is.list)]
|
||||
}
|
||||
|
|
|
|||
338
R/import-global-env-mod.R
Normal file
338
R/import-global-env-mod.R
Normal file
|
|
@ -0,0 +1,338 @@
|
|||
|
||||
#' @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)
|
||||
}
|
||||
|
|
@ -655,7 +655,7 @@ regression_model_uv_list <- function(data,
|
|||
|
||||
## This is the very long version
|
||||
## Handles deeply nested glue string
|
||||
code <- glue::glue("dplyr::select(data,{paste0(paste(names(data[c(outcome.str, .var)]),collapse=','))})|>\nFreesearchR::regression_model({list2str(modifyList(parameters,list(formula.str = glue::glue(gsub('vars','.var',formula.str.c)))))})")
|
||||
code <- glue::glue("FreesearchR::regression_model({list2str(modifyList(parameters,list(formula.str = glue::glue(gsub('vars','.var',formula.str.c)))))})")
|
||||
REDCapCAST::set_attr(out, code, "code")
|
||||
})
|
||||
|
||||
|
|
|
|||
|
|
@ -154,6 +154,7 @@ update_variables_server <- function(id,
|
|||
updated_data$list_select <- NULL
|
||||
updated_data$list_mutate <- NULL
|
||||
updated_data$list_relabel <- NULL
|
||||
# shiny::req(updated_data$x)
|
||||
data <- data_r()
|
||||
new_selections <- input$row_selected
|
||||
if (length(new_selections) < 1) {
|
||||
|
|
@ -169,11 +170,14 @@ update_variables_server <- function(id,
|
|||
new_names[is.na(new_names)] <- old_names[is.na(new_names)]
|
||||
new_names[new_names == ""] <- old_names[new_names == ""]
|
||||
|
||||
# browser()
|
||||
|
||||
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_classes <- data_inputs$class_toset
|
||||
new_classes[new_classes == "Select"] <- NA
|
||||
|
|
@ -247,6 +251,8 @@ update_variables_server <- function(id,
|
|||
# shiny::observeEvent(input$close,
|
||||
# {
|
||||
return(shiny::reactive({
|
||||
shiny::req(updated_data$x)
|
||||
# browser()
|
||||
data <- updated_data$x
|
||||
code <- list()
|
||||
if (!is.null(data) && shiny::isTruthy(updated_data$list_mutate) && length(updated_data$list_mutate) > 0) {
|
||||
|
|
@ -259,10 +265,21 @@ update_variables_server <- function(id,
|
|||
code <- c(code, list(rlang::expr(select(-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::call2("purrr::map2(list_relabel,
|
||||
function(.data,.label){
|
||||
REDCapCAST::set_attr(.data,.label,attr = 'label')
|
||||
}) |> dplyr::bind_cols(.name_repair = 'unique_quiet')")))
|
||||
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()
|
||||
)
|
||||
)
|
||||
)
|
||||
}
|
||||
if (length(code) > 0) {
|
||||
attr(data, "code") <- Reduce(
|
||||
|
|
@ -272,7 +289,7 @@ update_variables_server <- function(id,
|
|||
}
|
||||
return(data)
|
||||
}))
|
||||
# })
|
||||
# })
|
||||
|
||||
# shiny::reactive({
|
||||
# data <- updated_data$x
|
||||
|
|
@ -309,7 +326,6 @@ update_variables_server <- function(id,
|
|||
# return(data)
|
||||
# }))
|
||||
# })
|
||||
|
||||
}
|
||||
)
|
||||
}
|
||||
|
|
|
|||
24
ROADMAP.md
24
ROADMAP.md
|
|
@ -4,15 +4,15 @@ The current state of the app is considered experimental, and a lot of things are
|
|||
|
||||
Below are some (the actual list is quite long and growing) of the planned features and improvements:
|
||||
|
||||
- [ ] Stratified analyses
|
||||
|
||||
- Additional study designs:
|
||||
- Additional study designs in regression models (expansion of the regression analysis functionality have been put on hold for now to focus on the more basic use-cases):
|
||||
|
||||
- [x] Cross-sectional data analyses
|
||||
|
||||
- [ ] Longitudinal data analyses
|
||||
|
||||
- [ ] Survival analysis
|
||||
|
||||
- [ ] Stratified analyses
|
||||
|
||||
- More detailed variable browser
|
||||
|
||||
|
|
@ -22,13 +22,13 @@ Below are some (the actual list is quite long and growing) of the planned featur
|
|||
|
||||
- More output controls
|
||||
|
||||
- [ ] Theming output tables
|
||||
- [x] ~~Theming output tables~~ The "JAMA" theme is the new standard.
|
||||
|
||||
- [ ] Select analyses to include in report
|
||||
- [x] ~~Select analyses to include in report.~~ Includes characteristics table and regression table if present. No other analyses are intended for the report as of now.
|
||||
|
||||
- [x] Export modified data. 2025-01-16
|
||||
|
||||
- [ ] Include reproducible code for all steps (maybe not all, but most steps, and the final dataset can be exported)
|
||||
- [x] Include reproducible code for all steps (maybe not all, but most steps, and the final dataset can be exported) 2025-04-10
|
||||
|
||||
- [x] ~~Modify factor levels~~ Factor level modifications is possible through converting factors to numeric > cutting numeric with desired fixed values. 2024-12-12
|
||||
|
||||
|
|
@ -41,3 +41,15 @@ Below are some (the actual list is quite long and growing) of the planned featur
|
|||
- [x] Grotta bars for ordianl outcomes (and sankey) 2025-3-17
|
||||
|
||||
- [x] Coefficient plotting for regression analyses (forest plot) 2025-2-20
|
||||
|
||||
Documentation:
|
||||
|
||||
- [ ] Complete getting started page describing all functionality.
|
||||
|
||||
- [ ] Streamlined functions documentation
|
||||
|
||||
New features:
|
||||
|
||||
- [ ] Merge data from multiple sources (this would in itself be a great feature, but not of highest importance)
|
||||
|
||||
- [ ] Additional plot types (missingness, *others...*)
|
||||
|
|
|
|||
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: 10084710
|
||||
bundleId: 10085560
|
||||
url: https://agdamsbo.shinyapps.io/freesearcheR/
|
||||
version: 1
|
||||
|
|
|
|||
|
|
@ -30,8 +30,10 @@ library(gtsummary)
|
|||
|
||||
# source("functions.R")
|
||||
|
||||
data(starwars)
|
||||
data(mtcars)
|
||||
trial <- gtsummary::trial |> default_parsing()
|
||||
data(trial)
|
||||
|
||||
|
||||
# light <- custom_theme()
|
||||
#
|
||||
|
|
@ -138,7 +140,7 @@ server <- function(input, output, session) {
|
|||
shiny::req(from_env$data())
|
||||
|
||||
rv$data_temp <- from_env$data()
|
||||
# rv$code <- append_list(data = from_env$code(),list = rv$code,index = "import")
|
||||
rv$code <- append_list(data = from_env$name(),list = rv$code,index = "import")
|
||||
})
|
||||
|
||||
output$import_var <- shiny::renderUI({
|
||||
|
|
@ -160,11 +162,11 @@ server <- function(input, output, session) {
|
|||
|
||||
output$data_loaded <- shiny::reactive({
|
||||
!is.null(rv$data_temp)
|
||||
})
|
||||
})
|
||||
|
||||
shiny::observeEvent(input$source,{
|
||||
shiny::observeEvent(input$source, {
|
||||
rv$data_temp <- NULL
|
||||
})
|
||||
})
|
||||
|
||||
shiny::outputOptions(output, "data_loaded", suspendWhenHidden = FALSE)
|
||||
|
||||
|
|
@ -179,7 +181,7 @@ server <- function(input, output, session) {
|
|||
shiny::req(input$import_var)
|
||||
# browser()
|
||||
temp_data <- rv$data_temp
|
||||
if (all(input$import_var %in% names(temp_data))){
|
||||
if (all(input$import_var %in% names(temp_data))) {
|
||||
temp_data <- temp_data |> dplyr::select(input$import_var)
|
||||
}
|
||||
|
||||
|
|
@ -188,8 +190,8 @@ server <- function(input, output, session) {
|
|||
|
||||
rv$code$import <- list(
|
||||
rv$code$import,
|
||||
rlang::call2(.fn = "select",input$import_var,.ns = "dplyr"),
|
||||
rlang::call2(.fn = "default_parsing",.ns = "FreesearchR")
|
||||
rlang::call2(.fn = "select", input$import_var, .ns = "dplyr"),
|
||||
rlang::call2(.fn = "default_parsing", .ns = "FreesearchR")
|
||||
) |>
|
||||
merge_expression() |>
|
||||
expression_string()
|
||||
|
|
@ -207,7 +209,7 @@ server <- function(input, output, session) {
|
|||
|
||||
rv$code$filter <- NULL
|
||||
rv$code$modify <- NULL
|
||||
},ignoreNULL = FALSE
|
||||
}, ignoreNULL = FALSE
|
||||
)
|
||||
|
||||
output$data_info_import <- shiny::renderUI({
|
||||
|
|
@ -280,7 +282,8 @@ server <- function(input, output, session) {
|
|||
title = "Update and select variables",
|
||||
footer = tagList(
|
||||
actionButton("ok", "OK")
|
||||
))
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
output$data_info <- shiny::renderUI({
|
||||
|
|
@ -445,44 +448,54 @@ server <- function(input, output, session) {
|
|||
|
||||
output$code_import <- shiny::renderPrint({
|
||||
shiny::req(rv$code$import)
|
||||
cat(rv$code$import)
|
||||
cat(c("#Data import\n",rv$code$import))
|
||||
})
|
||||
|
||||
output$code_data <- shiny::renderPrint({
|
||||
shiny::req(rv$code$modify)
|
||||
# browser()
|
||||
ls <- rv$code$modify |> unique()
|
||||
out <- paste("data <- data |>",
|
||||
sapply(ls, \(.x) paste(deparse(.x), collapse = ",")),
|
||||
collapse = "|>"
|
||||
) |>
|
||||
(\(.x){
|
||||
gsub(
|
||||
"\\|>", "\\|> \n",
|
||||
gsub(
|
||||
"%>%", "",
|
||||
gsub(
|
||||
"\\s{2,}", " ",
|
||||
gsub(",\\s{,},", ", ", .x)
|
||||
)
|
||||
)
|
||||
)
|
||||
})()
|
||||
cat(out)
|
||||
out <- ls |>
|
||||
merge_expression() |>
|
||||
expression_string(assign.str = "data <- data |>\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))
|
||||
})
|
||||
|
||||
output$code_filter <- shiny::renderPrint({
|
||||
cat(rv$code$filter)
|
||||
cat(c("#Data filter\n",rv$code$filter))
|
||||
})
|
||||
|
||||
output$code_table1 <- shiny::renderPrint({
|
||||
shiny::req(rv$code$table1)
|
||||
cat(rv$code$table1)
|
||||
cat(c("#Data characteristics table\n",rv$code$table1))
|
||||
})
|
||||
|
||||
|
||||
## Just a note to self
|
||||
## 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)})
|
||||
})
|
||||
rv$regression()$regression$models |> purrr::imap(\(.x, .i){
|
||||
output[[paste0("code_", tolower(.i))]] <- shiny::renderPrint({
|
||||
cat(.x$code_table)
|
||||
})
|
||||
})
|
||||
})
|
||||
|
||||
|
||||
|
|
@ -610,7 +623,7 @@ server <- function(input, output, session) {
|
|||
)
|
||||
|
||||
shiny::withProgress(message = "Creating the table. Hold on for a moment..", {
|
||||
rv$list$table1 <- rlang::exec(create_baseline, !!!append_list(rv$list$data,parameters,"data"))
|
||||
rv$list$table1 <- rlang::exec(create_baseline, !!!append_list(rv$list$data, parameters, "data"))
|
||||
|
||||
# rv$list$table1 <- create_baseline(
|
||||
# data = rv$list$data,
|
||||
|
|
@ -629,7 +642,6 @@ server <- function(input, output, session) {
|
|||
# ) |>
|
||||
# merge_expression() |>
|
||||
# expression_string()
|
||||
|
||||
}
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -159,7 +159,12 @@ ui_elements <- list(
|
|||
IDEAFilter::IDEAFilter_ui("data_filter"),
|
||||
shiny::tags$br()
|
||||
)
|
||||
)
|
||||
),
|
||||
shiny::tags$br(),
|
||||
shiny::tags$br(),
|
||||
shiny::tags$br(),
|
||||
shiny::tags$br(),
|
||||
shiny::tags$br()
|
||||
),
|
||||
bslib::nav_panel(
|
||||
title = "Modify",
|
||||
|
|
|
|||
|
|
@ -59,12 +59,20 @@ This will unfold options to preview your data dictionary (the main database meta
|
|||
|
||||
### Local or sample data
|
||||
|
||||
When opening the online hosted app, this is mainly for testing purposes. When running the app locally from *R* on your own computer, you will find all data.frames in the current environment here. This extends the possible uses of this app to allow for quick and easy data insights and code generation for basic plotting to fine tune.
|
||||
|
||||
## Evaluate
|
||||
|
||||
### Baseline
|
||||
This panel allows for basic data evaluation.
|
||||
|
||||
### Characteristics
|
||||
|
||||
Create a classical baseline characteristics table with optional data stratification and comparisons.
|
||||
|
||||
### Correlation matrix
|
||||
|
||||
Visualise variable correlations and get suggestions to exclude highly correlated variables.
|
||||
|
||||
## Visuals
|
||||
|
||||
There are a number of plotting options to visualise different aspects of the data.
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue