Nothing
#' @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.
#'
#' @template module-import
#'
#' @export
#'
#' @name import-globalenv
#'
#' @importFrom htmltools tags
#' @importFrom shiny NS actionButton icon textInput
#' @importFrom shinyWidgets pickerInput alert
#'
#' @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",
html_dependency_datamods(),
title,
pickerInput(
inputId = ns("data"),
label = i18n("Select a data.frame:"),
choices = NULL,
options = list(title = i18n("List of data.frame...")),
width = "100%"
),
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
#' @importFrom shinyWidgets updatePickerInput
#'
#' @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 <- search_obj("data.frame")
} else {
choices <- 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")
updatePickerInput(
session = session,
inputId = "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
})
if (identical(trigger_return, "button")) {
return(list(
status = reactive(temporary_rv$status),
name = reactive(imported_rv$name),
data = reactive(as_out(imported_rv$data, return_class))
))
} else {
return(list(
status = reactive(temporary_rv$status),
name = reactive(temporary_rv$name),
data = reactive(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)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.