andreas/FreesearchR
1
0
Fork 0
mirror of https://github.com/agdamsbo/FreesearchR.git synced 2026-06-19 04:27:30 +02:00
Code Issues Projects Releases Packages Wiki Activity

feat: limiting data set size by default

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2026-02-23 13:20:02 +01:00
commit 42bf96eade
No known key found for this signature in database
1 changed files with 114 additions and 78 deletions
Download patch file Download diff file Expand all files Collapse all files

186
R/import_globalenv-ext.R
View file

@ -1,4 +1,6 @@
#' @title Import data from an Environment #' @title Import data from an Environment
#' #'
#' @description Let the user select a dataset from its own environment or from a package's environment. #' @description Let the user select a dataset from its own environment or from a package's environment.
@ -18,7 +20,6 @@ import_globalenv_ui <- function(id,
globalenv = TRUE, globalenv = TRUE,
packages = datamods::get_data_packages(), packages = datamods::get_data_packages(),
title = TRUE) { title = TRUE) {
ns <- NS(id) ns <- NS(id)
choices <- list() choices <- list()
@ -31,15 +32,14 @@ import_globalenv_ui <- function(id,
if (isTRUE(globalenv)) { if (isTRUE(globalenv)) {
selected <- "Global Environment" selected <- "Global Environment"
select_label <- i18n$t("Select a dataset from your environment or sample dataset from a package.")
} else { } else {
selected <- packages[1] selected <- packages[1]
select_label <- i18n$t("Select a sample dataset from a package.")
} }
if (isTRUE(title)) { if (isTRUE(title)) {
title <- tags$h4( title <- tags$h4(i18n$t("Import a dataset from an environment"), class = "datamods-title")
i18n$t("Import a dataset from an environment"),
class = "datamods-title"
)
} }
tags$div( tags$div(
@ -66,14 +66,13 @@ import_globalenv_ui <- function(id,
# options = list(title = i18n$t("List of datasets...")), # options = list(title = i18n$t("List of datasets...")),
width = "100%" width = "100%"
), ),
tags$div( tags$div(
id = ns("import-placeholder"), id = ns("import-placeholder"),
shinyWidgets::alert( shinyWidgets::alert(
id = ns("import-result"), id = ns("import-result"),
status = "info", status = "info",
tags$b(i18n$t("No data selected!")), tags$b(i18n$t("No data selected!")),
i18n$t("Use a dataset from your environment or from the environment of a package."), select_label,
dismissible = TRUE dismissible = TRUE
) )
), ),
@ -87,12 +86,14 @@ import_globalenv_ui <- function(id,
#' @param btn_show_data Display or not a button to display data in a modal window if import is successful. #' @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 show_data_in Where to display data: in a `"popup"` or in a `"modal"` window.
#' @param trigger_return When to update selected data: #' @param trigger_return When to update selected data:
#' `"button"` (when user click on button) or #' `"button"` (when user click on button) or
#' `"change"` (each time user select a dataset in the list). #' `"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 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. #' @param reset A `reactive` function that when triggered resets the data.
#' @param limit_data upper limit to imported data
#' #'
#' @export #' @export
#' #'
@ -106,16 +107,17 @@ import_globalenv_server <- function(id,
show_data_in = c("popup", "modal"), show_data_in = c("popup", "modal"),
trigger_return = c("button", "change"), trigger_return = c("button", "change"),
return_class = c("data.frame", "data.table", "tbl_df", "raw"), return_class = c("data.frame", "data.table", "tbl_df", "raw"),
reset = reactive(NULL)) { reset = reactive(NULL),
limit_data = NULL) {
trigger_return <- match.arg(trigger_return) trigger_return <- match.arg(trigger_return)
return_class <- match.arg(return_class) return_class <- match.arg(return_class)
module <- function(input, output, session) { module <- function(input, output, session) {
ns <- session$ns ns <- session$ns
imported_rv <- reactiveValues(data = NULL, name = NULL) imported_rv <- reactiveValues(data = NULL, name = NULL)
temporary_rv <- reactiveValues(data = NULL, name = NULL, status = NULL) temporary_rv <- reactiveValues(data = NULL,
name = NULL,
status = NULL)
observeEvent(reset(), { observeEvent(reset(), {
temporary_rv$data <- NULL temporary_rv$data <- NULL
@ -130,6 +132,7 @@ import_globalenv_server <- function(id,
}) })
observeEvent(input$env, { observeEvent(input$env, {
# browser()
if (identical(input$env, "Global Environment")) { if (identical(input$env, "Global Environment")) {
choices <- datamods:::search_obj("data.frame") choices <- datamods:::search_obj("data.frame")
} else { } else {
@ -139,9 +142,14 @@ import_globalenv_server <- function(id,
choices <- i18n$t("No dataset here...") choices <- i18n$t("No dataset here...")
choicesOpt <- list(disabled = TRUE) choicesOpt <- list(disabled = TRUE)
} else { } else {
choicesOpt <- list( choicesOpt <- list(subtext = get_dimensions(choices,filter_df=TRUE))
subtext = datamods:::get_dimensions(choices) # browser()
) ## choices are corrected if GlobalEnv is not chosen
if (!identical(input$env, "Global Environment")) {
choices <- structure(names(choicesOpt$subtext),
package = attr(choices, "package"))
}
} }
temporary_rv$package <- attr(choices, "package") temporary_rv$package <- attr(choices, "package")
shinyWidgets::updatePickerInput( shinyWidgets::updatePickerInput(
@ -152,7 +160,8 @@ import_globalenv_server <- function(id,
choicesOpt = choicesOpt, choicesOpt = choicesOpt,
options = list( options = list(
title = i18n$t("List of datasets..."), title = i18n$t("List of datasets..."),
"live-search" = TRUE) "live-search" = TRUE
)
) )
}) })
@ -161,7 +170,9 @@ import_globalenv_server <- function(id,
id = "import-result", id = "import-result",
status = "info", status = "info",
tags$b(i18n$t("No data selected!")), tags$b(i18n$t("No data selected!")),
i18n$t("Use a dataset from your environment or from the environment of a package."), i18n$t(
"Use a dataset from your environment or from the environment of a package."
),
dismissible = TRUE dismissible = TRUE
) )
) )
@ -175,58 +186,68 @@ import_globalenv_server <- function(id,
observeEvent(input$data, { observeEvent(input$data,
if (!isTruthy(input$data)) { {
datamods:::toggle_widget(inputId = "confirm", enable = FALSE) if (!isTruthy(input$data)) {
datamods:::insert_alert( datamods:::toggle_widget(inputId = "confirm", enable = FALSE)
selector = ns("import"), datamods:::insert_alert(
status = "info", selector = ns("import"),
tags$b(i18n$t("No data selected!")), status = "info",
i18n$t("Use a dataset from your environment or from the environment of a package.") tags$b(i18n$t("No data selected!")),
) i18n$t(
} else { "Use a dataset from your environment or from the environment of a package."
name_df <- input$data )
)
} else {
# browser()
name_df <- input$data
if (!is.null(temporary_rv$package)) { if (!is.null(temporary_rv$package)) {
attr(name_df, "package") <- temporary_rv$package attr(name_df, "package") <- temporary_rv$package
} }
imported <- try(get_env_data(name_df), silent = TRUE) imported <- try(get_env_data(name_df), silent = TRUE)
if (inherits(imported, "try-error") || NROW(imported) < 1) { if (inherits(imported, "try-error") ||
datamods:::toggle_widget(inputId = "confirm", enable = FALSE) NROW(imported) < 1) {
datamods:::insert_error(mssg = i18n$t(attr(imported, "condition")$message)) datamods:::toggle_widget(inputId = "confirm", enable = FALSE)
temporary_rv$status <- "error" datamods:::insert_error(mssg = i18n$t(attr(imported, "condition")$message))
temporary_rv$data <- NULL temporary_rv$status <- "error"
temporary_rv$name <- NULL temporary_rv$data <- NULL
} else { temporary_rv$name <- NULL
datamods:::toggle_widget(inputId = "confirm", enable = TRUE) } else {
datamods:::insert_alert( datamods:::toggle_widget(inputId = "confirm", enable = TRUE)
selector = ns("import"), datamods:::insert_alert(
status = "success", selector = ns("import"),
datamods:::make_success_alert( status = "success",
imported, make_success_alert(
trigger_return = trigger_return, data = imported,
btn_show_data = btn_show_data trigger_return = trigger_return,
) btn_show_data = btn_show_data
) )
pkg <- attr(name_df, "package") )
if (!is.null(pkg)) { pkg <- attr(name_df, "package")
name <- paste(pkg, input$data, sep = "::") if (!is.null(pkg)) {
} else { name <- paste(pkg, input$data, sep = "::")
name <- input$data } else {
} name <- input$data
name <- trimws(sub("\\(([^\\)]+)\\)", "", name)) }
temporary_rv$status <- "success" name <- trimws(sub("\\(([^\\)]+)\\)", "", name))
temporary_rv$data <- imported temporary_rv$status <- "success"
temporary_rv$name <- name
} temporary_rv$data <- limit_data_size(imported,limit = limit_data)
} temporary_rv$name <- name
}, ignoreInit = TRUE, ignoreNULL = FALSE) }
}
},
ignoreInit = TRUE,
ignoreNULL = FALSE)
observeEvent(input$see_data, { observeEvent(input$see_data, {
show_data(temporary_rv$data, title = i18n$t("Imported data"), type = show_data_in) show_data(temporary_rv$data,
title = i18n$t("Imported data"),
type = show_data_in)
}) })
observeEvent(input$confirm, { observeEvent(input$confirm, {
@ -250,10 +271,7 @@ import_globalenv_server <- function(id,
} }
} }
moduleServer( moduleServer(id = id, module = module)
id = id,
module = module
)
} }
@ -300,6 +318,7 @@ get_data_packages <- function() {
#' list_pkg_data("ggplot2") #' list_pkg_data("ggplot2")
list_pkg_data <- function(pkg) { list_pkg_data <- function(pkg) {
if (isTRUE(requireNamespace(pkg, quietly = TRUE))) { if (isTRUE(requireNamespace(pkg, quietly = TRUE))) {
# browser()
list_data <- data(package = pkg, envir = environment())$results[, "Item"] list_data <- data(package = pkg, envir = environment())$results[, "Item"]
list_data <- sort(list_data) list_data <- sort(list_data)
attr(list_data, "package") <- pkg attr(list_data, "package") <- pkg
@ -317,17 +336,27 @@ list_pkg_data <- function(pkg) {
get_env_data <- function(obj, env = globalenv()) { get_env_data <- function(obj, env = globalenv()) {
pkg <- attr(obj, "package") pkg <- attr(obj, "package")
re <- regexpr(pattern = "\\(([^\\)]+)\\)", text = obj) re <- regexpr(pattern = "\\(([^\\)]+)\\)", text = obj)
obj_ <- substr(x = obj, start = re + 1, stop = re + attr(re, "match.length") - 2) obj_ <- substr(
obj <- gsub(pattern = "\\s.*", replacement = "", x = obj) 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)) { if (obj %in% ls(name = env)) {
get(x = obj, envir = env) get(x = obj, envir = env)
} else if (!is.null(pkg) && !identical(pkg, "")) { } else if (!is.null(pkg) && !identical(pkg, "")) {
res <- suppressWarnings(try( res <- suppressWarnings(try(get(utils::data(
get(utils::data(list = obj, package = pkg, envir = environment())), silent = TRUE list = obj,
)) package = pkg,
envir = environment()
)), silent = TRUE))
if (!inherits(res, "try-error")) if (!inherits(res, "try-error"))
return(res) return(res)
data(list = obj_, package = pkg, envir = environment()) data(list = obj_,
package = pkg,
envir = environment())
get(obj, envir = environment()) get(obj, envir = environment())
} else { } else {
NULL NULL
@ -335,16 +364,23 @@ get_env_data <- function(obj, env = globalenv()) {
} }
get_dimensions <- function(objs) { #' Extension of the helper function from datamods
if (is.null(objs)) #'
#' @param objs objs
#' @param filter_df flag to only include data frames
#'
#' @returns vector of data frames with the package names as attr
get_dimensions <- function(objs,filter_df=TRUE) {
if (is.null(objs)){
return(NULL) return(NULL)
}
dataframes_dims <- Map( dataframes_dims <- Map(
f = function(name, pkg) { f = function(name, pkg) {
attr(name, "package") <- pkg attr(name, "package") <- pkg
tmp <- suppressWarnings(get_env_data(name)) tmp <- suppressWarnings(get_env_data(name))
if (is.data.frame(tmp)) { if (is.data.frame(tmp)) {
sprintf("%d obs. of %d variables", nrow(tmp), ncol(tmp)) sprintf("%d obs. of %d variables", nrow(tmp), ncol(tmp))
} else { } else if (isFALSE(filter_df)) {
i18n$t("Not a data.frame") i18n$t("Not a data.frame")
} }
}, },