#' Functions to implement an object browser
#'
#' @description These functions provide features required to implement a
#' complete object browser in a GUI client.
#'
#' @param id The id of the object browser (you can run several ones
#' concurrently, providing you give them different ids).
#' @param envir An environment, or the name of the environment, or the position
#' in the [search()] path.
#' @param all.names Do we display all names (including hidden variables starting
#' with '.')?
#' @param pattern A pattern to match for selecting variables.
#' @param group A group to filter.
#' @param sep Separator to use between items (if path is not `NULL`).
#' @param path The path where to write a temporary file with the requested
#' information. Set to NULL (default) if you don't pass this data to your GUI
#' client by mean of a file.
#' @param regenerate Do we force to regenerate the information?
#' @param object Name of the object selected in the object browser,
#' components/arguments of which should be listed.
#' @param objects A list with selected items in the object browser.
#' @param all.info Do we return all the information (envir as first column or
#' not (by default).
#' @param compare If TRUE, result is compared with last cached value and the
#' client is updated only if something changed.
#' @param x Object returned by `obj_list()`.
#' @param eol Separator to use between object entries, default is to list each
#' item in a separate line.
#' @param header If `TRUE`, two-line header is printed, of the form: \cr
#' Environment = environment name \cr
#' Object = object name \cr
#' Default is not to print header if `all.info == TRUE`.
#' @param raw.output If `TRUE`, a compact, better suited for parsing output is
#' produced.
#' @param ... Further arguments, passed to [write.table()].
#' @return Depending on the function, a list, a string, a reference to an
#' external, temporary file or `TRUE` in case of success or `FALSE` otherwise
#' is returned invisibly.
#' @details `obj_browse()` does the horse work. `obj_dir()` gets the temporary
#' directory where exchange files with the GUI client are stored, in case you
#' exchange data through files. You can use a better way to communicate with
#' your GUI (you have to provide your code) and disable writing to files by
#' using `path = NULL`.
#'
#' `obj_list()` lists objects in a given environment, elements of a recursive
#' object or function argument.
#'
#' `obj_search()` lists the search path.
#'
#' `obj_clear()` clears any reference to a given object browser.
#'
#' `obj_info()` computes a tooltip info for a given object.
#'
#' obj_menu()` computes a context menu for selected object(s) in the object
#' explorer managed by the GUI client.
#'
#' `print.objList()` print method for `objList` objects.
#' @author Philippe Grosjean <phgrosjean@sciviews.org> &
#' Kamil Barton <kamil.barton@uni-wuerzburg.de>
#' @export
#' @seealso [completion()], [call_tip()]
#' @keywords misc
#' @examples
#' # Create various context menus
#' data(iris)
#' (obj_info(object = "iris"))
#' data(trees)
#' # For one object
#' (obj_menu(objects = "iris"))
#' # For multiple objects
#' (obj_menu(objects = c("iris", "trees")))
#' # For inexistant object (return "")
#' (obj_info(object = "noobject"))
#' (obj_menu(objects = "noobject"))
#' rm(iris, trees)
#'
#' # For environments
#' (obj_info(envir = ".GlobalEnv"))
#' (obj_menu(envir = ".GlobalEnv"))
#' (obj_info(envir = "SciViews:TempEnv"))
#' (obj_menu(envir = "SciViews:TempEnv"))
#' (obj_info(envir = "package:datasets"))
#' (obj_menu(envir = "package:datasets"))
#' # For an environment that does not exist on the search path (return "")
#' (obj_info(envir = "noenvir"))
#' (obj_menu(envir = "noenvir"))
obj_browse <- function(id = "default", envir = .GlobalEnv, all.names = NULL,
pattern = NULL, group = NULL, sep = "\t", path = NULL, regenerate = FALSE) {
# Maintain files for remote Object Browser
# If four first parameters are NULL, use cached version of these parameters,
# or default values
# Format envir as character (use only first item provided!)
if (is.environment(envir)) envir <- deparse(substitute(envir))
if (is.numeric(envir)) envir <- search()[envir[1]]
envir <- as.character(envir)[1]
# Get the current position in the search path for envir
pos <- match(envir, search(), nomatch = -1)
if (pos < 1) {
pos <- 1 # NOT FOUND, use .GlobalEnv
envir = ".GlobalEnv"
}
if (!is.null(path)) {
# Does the directory exists?
if (path == "") path <- objDir()
if (!file.exists(path) || !file.info(path)$isdir) {
#unlink(path)
if (!dir.create(path))
stop("Impossible to create the Object Browser 'path' directory!")
}
}
# Control that 'Search.txt' is up-to-date
changed_search <- obj_search(path = path, compare = !regenerate)
# Make sure id is character
id <- as.character(id)[1]
if (id == "") id <- "default"
# Get the five parameters pos, envir, all.names, pattern & group
all_pars <- get_temp(".guiObjParsCache", default = NULL)
if (!is.null(all_pars)) {
pars <- all_pars[[id]]
} else {
pars <- list(pos = 1, envir = ".GlobalEnv", all.names = FALSE,
pattern = "", group = "")
assign_temp(".guiObjParsCache", list()) # Create the list
}
if (is.null(pars))
pars <- list(pos = 1, envir = ".GlobalEnv", all.names = FALSE,
pattern = "", group = "")
# Possibly change some parameters (and make sure they are valid!)
pars_changed <- FALSE
if (!is.null(pos)) {
pars_changed <- TRUE
pars$pos <- as.integer(pos[1])
pars$envir <- envir
if (pars$pos < 1) {
pars_changed <- TRUE
pars$pos <- 1
pars$envir <- ".GlobalEnv"
}
}
if (pars$pos > length(search())) {
pars_changed <- TRUE
pars$pos <- 1
pars$envir <- ".GlobalEnv"
}
# Track possible changes in the search path
if (is.na(match(pars$envir, search()))) {
pars_changed <- TRUE
pars$pos <- 1
pars$envir <- ".GlobalEnv"
}
if (match(pars$envir, search()) != pars$pos) {
pars_changed <- TRUE
pars$pos <- match(pars$envir, search())
}
# Track changes in the options
if (!is.null(all.names)) {
pars_changed <- TRUE
pars$all.names <- as.logical(all.names[1])
}
if (!is.null(pattern)) {
pars_changed <- TRUE
pars$pattern <- as.character(pattern[1])
}
if (!is.null(group)) {
pars_changed <- TRUE
pars$group <- as.character(group[1])
}
# Write a cached version of these parameters in SciViews:TempEnv
all_pars <- get_temp(".guiObjParsCache", default = list())
all_pars[[id]] <- pars
assign_temp(".guiObjParsCache", all_pars)
# Control that 'List_<id>.txt' is up-to-date, but only if pos == 1 or
# envir is not a package or regenerate or pars or Search have changed
# to limit the work done on workspaces that are unlikely to have change
if (pars_changed || regenerate || (changed_search != "") || (pars$pos == 1) ||
(regexpr("^package:", envir) == -1)) {
changed_list <- objList(id = id, envir = pars$pos,
all.names = pars$all.names, pattern = pars$pattern,
group = pars$group, path = path, compare = !regenerate,
sep = sep)
changed_list <- if (!is.null(nrow(changed_list)) && nrow(changed_list) > 0) {
apply(changed_list, 1, paste, collapse = sep)
} else ""
} else changed_list <- ""
# We return the data, or indication that the data have changed to the client
res <- ""
if (length(changed_search) > 1 || changed_search != "") {
res <- "<<<search>>>\n"
if (is.null(path)) res <- paste0(res,
paste(changed_search, collapse = sep), "\n")
}
if (length(changed_list) > 1 || changed_list != "") {
res <- paste(res, "<<<list>>>", sep = "")
if (is.null(path)) res <- paste(c(res, changed_list),
collapse = "\n")
}
# Possibly call a .guiObjBrowse function to pass the res to the GUI client
cmd_fun <- get_temp(".guiObjBrowse", mode = "function")
if (!is.null(cmd_fun)) cmd_fun(id = id, data = res)
invisible(res)
}
#' @export
#' @rdname obj_browse
obj_clear <- function(id = "default") {
# Clear any reference to a given 'id' object browser
id <- as.character(id)[1] # Make sure id is character
if (id == "") id <- "default"
pars <- get_temp(".guiObjParsCache", default = list())
pars[[id]] <- NULL
assign_temp(".guiObjParsCache", pars)
list_cache <- get_temp(".guiObjListCache", default = list())
list_cache[[id]] <- NULL
assign_temp(".guiObjListCache", list_cache)
# Also delete corresponding files
root <- obj_dir()
pars_file = file.path(root, paste0("Pars_", id, ".txt"))
if (file.exists(pars_file)) unlink(pars_file)
list_file = file.path(root, paste0("List_", id, ".txt"))
if (file.exists(list_file)) unlink(list_file)
menu_file = file.path(root, paste0("Menu_", id, ".txt"))
if (file.exists(menu_file)) unlink(menu_file)
invisible(TRUE)
}
#' @export
#' @rdname obj_browse
obj_dir <- function()
file.path(tempdir(), "svObjBrowser")
#' @export
#' @rdname obj_browse
obj_info <- function(id = "default", envir = .GlobalEnv, object = "",
path = NULL) {
# Get a tooltip information for an object (for mouseover method)
# Format envir as character (use only first item provided!)
if (is.environment(envir)) envir <- deparse(substitute(envir))
if (is.numeric(envir)) envir <- search()[envir[1]]
envir <- as.character(envir)[1]
# Possibly call a custom function .objInfo() in SciViews:TempEnv
cmd_fun <- get_temp(".objInfo", mode = "function")
if (!is.null(cmd_fun)) { # We call a custom function
info <- cmd_fun(id = id, envir = envir, object = object)
} else if (object == "") { # An environment...
info <- switch(envir,
.GlobalEnv = paste(c("Global environment\n", capture.output(gc())),
collapse = "\n"),
`SciViews:TempEnv` = "SciViews temporary variables environment",
RcmdrEnv = "R Commander temporary variables environment",
`tools:RGUI` = "R.app tools environment",
`tools:rstudio` = "RStudio tools environment",
Autoloads = "R autoloading objects environment",
if (regexpr("^package:", envir) > -1) {
pkg <- sub("^package:", "", envir)
paste(library(help = pkg, character.only = TRUE)$info[[1]],
collapse = "\n")
} else if (envir %in% search()) {
paste0("'", envir, "' environment")
} else ""
)
} else {# An object...
if (!exists(object, where = envir))
return(invisible(""))
obj <- get(object, pos = envir)
# The info is simply a str() representation of the object
# We need to capture output
info <- capture.output(str(obj))
# Add estimation of size for this object, if it is not a function
if (!inherits(obj, "function")) {
size <- object.size(obj)
if (size > 1024 * 1024) {
size <- paste("Estimated size:",
format(size / 1024 / 1024, digits = 3), "Mb")
} else if (size > 1024) {
size <- paste("Estimated size:",
format(size / 1024, digits = 3), "kb")
} else size <- paste("Estimated size:",
format(size, digits = 3), "bytes")
info[length(info) + 1] <- size
}
}
if (!is.null(path)) {
# Save the data in a file
if (path == "") path <- obj_dir()
info_file <- file.path(path, paste("Info_", id, ".txt", sep = ""))
cat(info, collapse = "\n", file = info_file)
}
# Possibly call a .guiObjInfo function to pass the data to the GUI client
cmd_fun <- get_temp(".guiObjInfo", mode = "function")
if (!is.null(cmd_fun)) cmd_fun(id = id, data = info)
# Return the info tooltip invisibly
invisible(info)
}
#' @export
#' @rdname obj_browse
obj_list <- function(id = "default", envir = .GlobalEnv, object = NULL,
all.names = FALSE, pattern = "", group = "", all.info = FALSE, sep = "\t",
path = NULL, compare = TRUE, ...) {
# Make sure that id is character
id <- as.character(id)[1]
if (id == "") id <- "default"
ename <- NA
# Format envir as character (use only first item provided!)
if (!is.environment(envir)) {
if (is.numeric(envir) && envir > 0)
envir <- search()[envir]
if (is.character(envir)) {
ename <- envir
envir <- tryCatch(as.environment(envir), error = function(e) NULL)
if (is.null(envir) || inherits(envir, "error")) {
envir <- NULL
ename <- ""
}
}
}
# base and .GlobalEnv do not have name attribute
if (!is.null(attr(envir, "name"))) ename <- attr(envir, "name")
else if (is.na(ename)) ename <- deparse(substitute(envir))
if (ename %in% c("baseenv()", ".BaseNamespaceEnv"))
ename <- "package:base"
# Object to return in case of empty data
#nothing <- data.frame(Envir = character(0), Name = character(0),
# Dims = character(0), Group = character(0), Class = character(0),
# Recursive = logical(0), stringsAsFactors = FALSE)
#if (!isTRUE(all.info)) nothing <- nothing[, -1]
#attr(nothing, "all.info") <- all.info
#attr(nothing, "envir") <- ename
#attr(nothing, "object") <- object
#class(nothing) <- c("objList", "data.frame")
# This is ~15x faster:
nothing <- structure(list(Name = character(0),
Dims = character(0), Group = character(0), Class = character(0),
Recursive = logical(0), stringsAsFactors = FALSE),
class = c("objList", "data.frame"),
all.info = all.info, envir = ename, object = object
)
if (isTRUE(all.info))
nothing <- cbind(Envir = character(0), nothing)
if (is.null(envir))
return(nothing)
if (!missing(object) && is.character(object) && object != "") {
res <- .ls_obj(envir = envir, objname = object)
} else {
# Get the list of objects in this environment
items <- ls(envir = envir, all.names = all.names, pattern = pattern)
if (length(items) > 0) {
# Get characteristics of all objects
describe <- function(name, all.info = FALSE) {
# Get a vector with five items:
# Name, Dims, Group, Class and Recursive
obj <- envir[[name]]
res <- c(
Name = name,
Dims = if (is.null(Dim <- dim(obj))) length(obj) else
paste(Dim, collapse = "x"),
Group = mode(obj),
Class = class(obj)[1],
Recursive = is.recursive(obj) || mode(obj) == "S4"
)
return(res)
}
res <- data.frame(t(sapply(items, describe, all.info = all.info)),
stringsAsFactors = FALSE)
# Quote non-syntactic names
nsx <- res$Name != make.names(res$Name)
res$Full.name[!nsx] <- res$Name[!nsx]
res$Full.name[nsx] <- paste("`", res$Name[nsx], "`", sep = "")
res <- res[, c(1, 6, 2:5)]
} else res <- nothing
# No, because if rm(list = ls()), we must reactualize the objects
# browser anyway
if (NROW(res) == 0) return(nothing)
if (isTRUE(all.info)) res <- cbind(Envir = ename, res)
v_mode <- groups <- res$Group
v_class <- res$Class
# Recalculate groups into meaningful ones for the object explorer
# 1) Correspondance of typeof() and group depicted in the browser
groups[groups %in% c("name", "environment", "promise", "language", "char",
"...", "any", "(", "call", "expression", "bytecode", "weakref",
"externalptr")] <- "language"
groups[groups == "pairlist"] <- "list"
# 2) All groups not being language, function or S4 whose class is
# different than typeof are flagged as S3 objects
groups[!(groups %in% c("language", "function", "S4")) &
v_mode != v_class] <- "S3"
# 3) Integers of class factor become factor in group
groups[v_class == "factor"] <- "factor"
# 4) Objects of class 'data.frame' are also group 'data.frame'
groups[v_class == "data.frame"] <- "data.frame"
# 5) Objects of class 'Date' or 'POSIXt' are of group 'DateTime'
groups[v_class == "Date" | v_class == "POSIXt"] <- "DateTime"
# Reaffect groups
res$Group <- groups
# Possibly filter according to group
if (!is.null(group) && group != "")
res <- res[groups == group, ]
}
# Determine if it is required to refresh something
Changed <- TRUE
if (isTRUE(compare)) {
allList <- get_temp(".guiObjListCache", default = list())
if (identical(res, allList[[id]])) Changed <- FALSE else {
# Keep a copy of the last version in SciViews:TempEnv
allList[[id]] <- res
assign_temp(".guiObjListCache", allList)
}
}
## Create the 'objList' object
attr(res, "all.info") <- all.info
attr(res, "envir") <- ename
attr(res, "object") <- object
attr(res, "changed") <- Changed
attr(res, "class") <- c("objList", "data.frame")
if (is.null(path)) { # Return results or "" if not changed
return(if (Changed) res else nothing)
} else if (Changed) { # Write to files in this path
return(write.objList(res, path = path, sep = sep, ...))
} else {
return(nothing) # Not changed
}
}
#' @export
#' @rdname obj_browse
write.objList <- function(x, path, sep = "\t", ...) {
id <- attr(x, "id")
list_file <- file.path(path, sprintf("List_%s.txt", id))
pars_file <- file.path(path, sprintf("Pars_%s.txt", id))
write.table(as.data.frame(x), row.names = FALSE, col.names = FALSE,
sep = sep, quote = FALSE, file = list_file)
## Write also in the Pars_<id>.txt file in the same directory
cat(sprintf("envir=%s\nall.names=%s\npattern=%s\ngroup=%s",
attr(x, "envir"), attr(x, "all.names"), attr(x, "pattern"),
attr(x, "group")), file = pars_file, append = FALSE)
invisible(list_file)
}
#' @export
#' @rdname obj_browse
print.objList <- function(x, sep = NA, eol = "\n",
header = !attr(x, "all.info"), raw.output = !is.na(sep), ...) {
if (!inherits(x, "objList"))
stop("x must be an 'objList' object")
empty <- NROW(x) == 0
if (!raw.output)
cat(if (empty) "An empty objects list\n" else "Objects list:\n")
if (header) {
header_fmt <- if (raw.output) "Env=%s\nObj=%s\n" else
"\tEnvironment: %s\n\tObject: %s\n"
objname <- if (is.null(attr(x, "object"))) {
if (raw.output) "" else "<All>"
} else attr(x, "object")
cat(sprintf(header_fmt, attr(x, "envir"), objname))
}
if (!empty) {
if (is.na(sep)) {
print(as.data.frame(x))
} else if (!is.null(nrow(x)) && nrow(x) > 0) {
write.table(x, row.names = FALSE, col.names = FALSE, sep = sep,
eol = eol, quote = FALSE)
}
}
invisible(x)
}
# Called by obj_list() when object is provided
.ls_obj <- function(objname, envir, ...) {
obj <- try(eval(parse(text = objname), envir = as.environment(envir)),
silent = TRUE)
if (inherits(obj, "try-error"))
return(NULL)
if (is.environment(obj))
obj <- as.list(obj)
if (mode(obj) == "S4") {
ret <- .ls_obj_s4(obj, objname)
} else if (is.function(obj)) {
ret <- .ls_obj_function(obj, objname)
} else {# S3
if (!(mode(obj) %in% c("list", "pairlist")) || length(obj) == 0)
return(NULL)
item_names <- full_names <- names(obj)
if (is.null(item_names)) {
item_names <- seq_along(obj)
full_names <- paste(objname, "[[", item_names, "]]", sep = "")
} else {
w_names <- item_names != ""
i_names <- item_names[w_names]
nsx <- i_names != make.names(i_names) # Non-syntactic names
i_names[nsx] <- paste0("`", i_names[nsx], "`")
full_names[w_names] <- paste0(objname, "$", i_names)
full_names[!w_names] <- paste0(objname, "[[",
seq_along(item_names)[!w_names], "]]")
}
ret <- t(sapply(seq_along(obj), function(i) .obj_desc(obj[[i]])))
ret <- data.frame(itemnames = item_names, fullnames = full_names, ret,
stringsAsFactors = FALSE)
}
if (!is.null(ret))
names(ret) <- c("Name", "Full.name", "Dims/default", "Group", "Class",
"Recursive")
ret
}
# Called by .ls_obj for functions
.ls_obj_function <- function(obj, objname = deparse(substitute(obj))){
# formals(obj) returns NULL if only arg is ..., try: formals(expression)
obj <- formals(args(obj))
objname <- paste("formals(args(", objname, "))", sep = "")
if (length(obj) == 0)
return(NULL)
item_names <- full_names <- names(obj)
nsx <- item_names != make.names(item_names) # non-syntactic names
item_names[nsx] <- paste("`", item_names[nsx], "`", sep = "")
full_names <- paste(objname, "$", item_names, sep = "")
ret <- t(sapply(seq_along(obj), function(i) {
x <- obj[[i]]
lang <- is.language(obj[[i]])
obj_class <- class(obj[[i]])[1]
obj_mode <- mode(obj[[i]])
d <- deparse(obj[[i]])
if (lang && obj_class == "name") {
obj_class <- ""
obj_mode <- ""
}
ret <- c(paste(d, collapse = "x"), obj_class, obj_mode, FALSE)
return(ret)
}))
data.frame(itemnames = item_names, fullnames = full_names, ret,
stringsAsFactors = FALSE)
}
# Called by .ls_obj in S4 case
.ls_obj_s4 <- function(obj, objname = deparse(substitute(obj))) {
item_names <- full_names <- slotNames(obj)
nsx <- item_names != make.names(item_names)
item_names[nsx] <- paste("`", item_names[nsx], "`", sep = "")
full_names <- paste(objname, "@", item_names, sep = "")
ret <- t(sapply(item_names, function(i) .obj_desc(slot(obj, i))))
data.frame(itemnames = item_names, fullnames = full_names,
ret, stringsAsFactors = FALSE)
}
# Returns a *character* vector with elements: dims, mode, class, rec(ursive)
.obj_desc <- function(x) {
d <- dim(x)
if (is.null(d)) d <- length(x)
c(dims = paste(d, collapse = "x"),
mode = mode(x), class = class(x)[1],
rec = mode(x) == "S4" || is.function(x) ||
(is.recursive(x) && !is.language(x) && sum(d) != 0))
}
#' @export
#' @rdname obj_browse
obj_search <- function(sep = "\t", path = NULL, compare = TRUE) {
new_search <- search()
if (isTRUE(compare)) {
old_search <- get_temp(".guiObjSearchCache", default = "")
# Compare both versions
if (length(new_search) != length(old_search) ||
!all(new_search == old_search)) {
# Keep a copy of the last version in SciViews:TempEnv
assign_temp(".guiObjSearchCache", new_search)
is_changed <- TRUE
} else is_changed <- FALSE
} else is_changed <- TRUE
if (is.null(path)) {# Return result, as a single character string with sep
if (is_changed) {
if (!is.null(sep)) new_search <- paste(new_search, collapse = sep)
return(new_search)
} else return("")
} else {# Write to a file called 'Search.txt' in this path
file <- file.path(path, "Search.txt")
if (is_changed) {
if (is.null(sep)) sep <- "\n"
cat(new_search, sep = sep, file = file)
}
invisible(is_changed)
}
}
#' @export
#' @rdname obj_browse
obj_menu <- function(id = "default", envir = .GlobalEnv, objects = "",
sep = "\t", path = NULL) {
# TODO: look also in .required (now .Depends) in .GlobalEnv to determine
# if one can detach a package
# TODO: copy name to clipboard, send name to editor in menu
# Get a context menu for given object(s) or environment
# It returns a matrix with the following columns:
# - widget: "menu", "item", "sep" or "space"
# - value: label of the menu or the item, or "-" for a separator
# - tip: a short description of this menu entry
# - code: the command to issue. Precede it with <<<h>>> to run the command
# silently and by <<<H>>> to run it silently and disconnect immediately
# Use a substitution placeholder for replacement in value, tip and code.
# For instance, <<<obj>>>, <<<objname>>>, <<<pos>>>, <<<envir>>> and
# add an argument returning the string to place there in the call to
# .addStripbar()
# - icon: the URL of the icon to use in the menu
# - checked: if the menu entry should present a check mark
# - disabled: if the menu entry is disabled
# - hidden: if the menu entry is hidden
# - options: further options that the GUI client can interpret
# Notes:
# - Selecting environments and objects inside environments is not allowed
# - Selecting multiples environments is not supported
# - Selecting items in different environments is not allowed
popup <- .create_stripbar("popupbar")
# Format envir as character (use only first item provided!)
if (is.environment(envir)) envir = deparse(substitute(envir))
if (is.numeric(envir)) envir <- search()[envir[1]]
envir <- as.character(envir)[1]
# Get the current position in the search path for envir
pos <- match(envir, search(), nomatch = -1)
if (pos < 1)
return(invisible(popup)) # Not found!
# Do we replace envir or not?
if (envir == ".GlobalEnv") Envir <- "<<<envir>>>" else Envir <- envir
# Look at 'objects'
if (length(objects) > 1) { # We have a multiple selection
obj_type <- "multiple"
# Add 'save' and 'remove' menu entries
objs_par <- paste(objects, collapse = ", ")
popup <- .add_stripbar(popup, c("save", "remove"), obj = objs_par,
envir = Envir)
} else {# Only one item is selected
if (objects == "") {# This is a menu for the environment
# The menu is different depending if we are in .GlobalEnv or not
if (envir == ".GlobalEnv") {
obj_type <- ".GlobalEnv"
obj_par <- NULL # Nothing special to propose
popup <- .add_stripbar(popup, c("load", "source", "import", "sep_",
"detach (d)"), envir = envir)
} else if (regexpr("^package:", envir) > -1) {# A package envir
obj_type <- "package"
obj_par <- sub("^package:", "", envir)
req <- getOption("required.packages")
if (is.null(req)) # Use list of known sensible environments
req <- c("package:base", "package:methods", "package:datasets",
"package:utils", "package:grDevices", "package:graphics",
"package:stats", "package:tcltk", "package:svMisc",
"package:svGUI", "package:svSocket", "package:svViews",
"package:svIO", "package:svIDE", "package:svDialogs",
"package:svWidgets", "package:tcltk2")
# Make sure that "package:base" is in the list
req <- c("package:base", req)
detachable <- !(envir %in% req)
if (detachable) state <- "" else state <- " (d)"
popup <- .add_stripbar(popup, c("pkgInfo", "sep_",
paste("detach", state, sep = ""),
paste("detachUnload", state, sep = "")
), package = obj_par, envir = Envir)
} else {# Another environment than .GlobalEnv, but not a package
obj_type <- "environment"
req <- getOption("required.environments")
if (is.null(req)) # Use list of known sensible environments
req <- c("SciViews:TempEnv", "RcmdrEnv", "Autoloads", "tools:RGUI")
detachable <- !(envir %in% req)
if (detachable) state <- "" else state <- " (d)"
obj_par <- detachable
popup <- .add_stripbar(popup, c(paste("detach", state, sep = "")),
envir = Envir)
}
} else {# This is a menu for an object
if (!exists(objects, where = envir))
return(invisible(popup))
obj_type <- "object"
obj <- get(objects, pos = envir)
obj_par <- class(obj)
# Look if there is an help file and examples for this object
hlp <- is_help(objects)
names(hlp) <- NULL
# Then we add 'help' and 'example' at the top of the menu
popup <- .add_stripbar(popup, c(
ifelse(hlp, c("help", "example"),
c("help (d)", "example (d)")), "sep_"), obj = objects)
# Add a series of standard functions/methods for this object
mets <- list_methods(class = obj_par)
popup <- .add_stripbar(popup, c("Functions_.", "._print",
ifelse("summary" %in% mets, "._generic", "._generic (d)")
), obj = objects, fun = "summary")
popup <- .add_stripbar(popup, c(
ifelse("plot" %in% mets, "._generic", "._generic (d)"),
ifelse(!is.null(names(obj)), "._names", "._names (d)"), "._str"
), obj = objects, fun = "plot")
# Eliminate 'print', 'show', 'summary' and 'plot' from mets
mets <- mets[!(mets %in% c("print", "show", "summary", "plot"))]
# Add the other methods from mets in the menu
if (length(mets) > 0) {
popup <- .add_stripbar(popup, "._sep_")
for (met in mets)
popup <- .add_stripbar(popup, "._generic", obj = objects, fun = met)
}
# Add a &View menu and at least one entry: &Default view
enabled_views <- "svViews" %in% search() # We need this package
if (enabled_views) {
popup <- .add_stripbar(popup, c("View_.", "._viewDef"
), obj = objects)
# Complete the '&View' submenu with more entries
view_types <- list_types("view", obj_par)
for (view_type in view_types)
popup <- .add_stripbar(popup, "._view", obj = objects,
type = view_type)
popup <- .add_stripbar(popup, "report", obj = objects)
} else {# Give the opportunity to load the svViews package
popup <- .add_stripbar(popup, c("View_.", "._viewDef (d)", "._require",
"report (d)"), obj = objects, pkg = "svViews")
}
# Add &edit/fix and &save
popup <- .add_stripbar(popup, c(
ifelse(envir == ".GlobalEnv", "edit", "fix"), "save"
), obj = objects, envir = Envir)
# If we are in .GlobalEnv and the object is a data.frame or a list,
# then I can attach/detach it
if (envir == ".GlobalEnv" && inherits(obj, "list")) {
# Is this object already attached (present in the search path)
if (objects %in% search()) {
popup <- .add_stripbar(popup, c("detach", "reattach", "sep_"),
obj = objects)
} else {# The object is not attached yet...
popup <- .add_stripbar(popup, c("attach", "sep_"), obj = objects)
}
}
# Create the '©' submenu with all possible entries
# plus &Export and &Remove
enabled_copy <- "svIO" %in% search() # We need this package
if (enabled_copy) {
popup <- .add_stripbar(popup, c("Copy_.", "._copyDef"
), obj = objects)
# Complete the '&Copy' submenu with more entries
copy_types <- list_types("copy", obj_par)
for (copy_type in copy_types)
popup <- .add_stripbar(popup, "._copy", obj = objects,
type = copy_type)
popup <- .add_stripbar(popup, c("export", "sep_", "remove"
), obj = objects, envir = Envir)
} else {# Give the opportunity to load the svIO package
popup <- .add_stripbar(popup, c("Copy_.", "._copyDef (d)", "._require",
"export (d)", "sep_", "remove"
), obj = objects, envir = Envir, pkg = "svIO")
}
}
}# Done (menu construction)
# Possibly call a custom function .objMenu() in SciViews:TempEnv
# to finalize the menu
# Depending on obj_type, we send something we already calculated to avoid
# doing it twice:
# obj_type -> obj_par
# .GlobalEnv NULL
# package Package name
# environment is it detachable or not?
# object class of the object
# multiple string with the multiple objects separated by ', '
cmd_fun <- get_temp(".objMenu", mode = "function")
if (!is.null(cmd_fun))
popup <- cmd_fun(popup, id = id, envir = envir, pos = pos,
objects = objects, path = path, objType = obj_type, objPar = obj_par)
if (!is.null(path)) {
# Save the data in a file
if (path == "") path <- obj_dir()
menu_file <- file.path(path, paste("Menu_", id, ".txt", sep = ""))
write.table(popup, file = menu_file, sep = sep, row.names = FALSE,
col.names = FALSE)
}
# TODO: make this more flexible
# Possibly call a .guiObjMenu function to pass the data to the GUI client
cmd_fun <- get_temp(".guiObjMenu", mode = "function")
if (!is.null(cmd_fun))
cmd_fun(id = id, data = popup)
# Return the menu specification invisibly
invisible(popup)
}
.create_stripbar <- function(type = c("menubar", "popupbar", "toolbar",
"buttonbar", "statusbar")) {
type <- match.arg(type)
strp <- data.frame(widget = character(), value = character(),
tip = character(), code = character(), icon = character(),
checked = logical(), disabled = logical(), hidden = logical(),
options = character(), stringsAsFactors = FALSE)
class(strp) <- unique(c("svStripbar", "svStrip", class(strp)))
attr(strp, "type") <- type
strp
}
.add_stripbar <- function(strip, widgets, gui = getOption("svGUI.name"),
actions = NULL, ..., icons = NULL) {
if (!inherits(strip, "svStripbar"))
stop("'strip' must be a 'svStripbar' object")
strip_type <- attr(strip, "type")
if (is.null(strip_type))
strip_type <- "menubar" # Default value
# Extract possible state information from widgets
pos <- regexpr(" *[(][cCuUdDeEhHvV]+[)] *$", widgets)
pos[pos == -1] <- 1000000
state <- substr(widgets, pos, 1000000)
# Clean up state to keep only digits
state <- tolower(sub("^ *[(]([cCuUdDeEhHvV]+)[)] *$", "\\1", state))
widgets <- substr(widgets, 1, pos - 1)
# If widgets is a named character vector, just check it is
# 'menu', 'item', 'sep' or 'space', otherwise, compile name = widget
wnames <- names(widgets)
if (is.null(wnames)) {
wnames <- widgets
# Determine widgets according to wnames
widgets <- rep("item", length.out = length(wnames))
widgets[regexpr("_[.]$", wnames) > -1] <- "menu"
widgets[regexpr("_$", wnames) > -1] <- "sep"
widgets[regexpr("__$", wnames) > -1] <- "space"
names(widgets) <- wnames
} else {
# Name is provided => check content for 'menu', 'item', 'sep' or 'space'
if (!all(widgets %in% c("menu", "item", "sep", "space")))
stop("'widgets' must be 'menu', 'item', 'sep' or 'space'")
}
# Get tree hierarchy of the menus being the number of dots before '_'
tree <- sub("^([.]+)_.*$", "\\1", wnames)
tree[regexpr("^[.]+$", tree) == -1] <- ""
tree <- gsub("[.]", "|", tree)
# Clean up widget names
wnames <- sub("^[.]+_", "", wnames)
wnames <- sub("_[.|_]{0,1}$", "", wnames)
# Guess some of the values from the names
value_def <- wnames
value_def[widgets == "sep"] <- "-"
value_def[widgets == "space"] <- "<->"
# Collect together 'text', 'code', 'state' and 'options' from actions,
# .svActions.[gui] and .svActions
if (is.null(gui)) gui <- "___" # Default value if no gui exists
act_gui <- get_temp(paste(".svActions", gui, sep = "."),
default = structure(list(), class = c("svActions", "list")))
act <- get_actions()
# Collect together items
def_text <- c(actions$text, act_gui$text, act$text)
def_code <- c(actions$code, act_gui$code, act$code)
def_state <- c(actions$state, act_gui$state, act$state)
def_options <- c(actions$options, act_gui$options, act$options)
# Do the same for icons
def_icons <- c(icons,
get_temp(paste(".svIcons", gui, sep = "."), default = character()),
get_temp(".svIcons", default = character()))
# The function used to replace placeholders in text and code
replace <- function(x, ...) {
# Do replacement for ... arguments
args <- list(...)
largs <- length(args)
if (length(args) > 0) {
nargs <- names(args)
for (i in 1:largs)
if (nargs[i] != "")
x <- gsub(paste("<<<", nargs[i], ">>>", sep = ""), args[[i]], x)
}
# Eliminate optional parts where no replacement occured
x <- gsub("\\[\\[\\[.*<<<.*>>>.*\\]\\]\\]", "", x)
# Eliminate triple square brackets for optional parts we keep
x <- gsub("\\[\\[\\[", "", x)
x <- gsub("\\]\\]\\]", "", x)
x
}
# Compute the different elements we need
# - text => value (first line) and tip (the rest)
text <- replace(def_text[wnames], ...)
text[is.na(text)] <- "" # TODO: a better guess for menus, items and sep/space
names(text) <- wnames
pos <- regexpr("\n", text)
pos[pos == -1] <- 1000000
value <- substr(text, 1, pos - 1)
value[value == ""] <- value_def[value == ""]
tip <- substr(text, pos + 1, 1000000)
# Indicate menu hierarchy in value
value <- paste(tree, value, sep = "")
# - code
code <- replace(def_code[wnames], ...)
code[is.na(code)] <- ""
names(code) <- wnames
# - icon
icon <- def_icons[wnames]
icon[is.na(icon)] <- ""
names(icon) <- wnames
# - options
options <- def_options[wnames]
options[is.na(options)] <- ""
names(options) <- wnames
# Compute state => checked, disabled and hidden
state2 <- def_state[wnames]
state2[is.na(state2)] <- ""
state <- paste(state, tolower(state2))
checked <- ifelse(regexpr("c", state) > -1, TRUE, FALSE)
disabled <- ifelse(regexpr("d", state) > -1, TRUE, FALSE)
hidden <- ifelse(regexpr("h", state) > -1, TRUE, FALSE)
# Create the data frame containing the data
add_strip <- data.frame(widget = widgets, value = value, tip = tip,
code = code, icon = icon, checked = checked, disabled = disabled,
hidden = hidden, options = options, stringsAsFactors = FALSE)
snames <- rownames(strip)
# Add it to strip and return it
strip <- rbind(strip, add_strip)
rownames(strip) <- make.names(c(snames, wnames), unique = TRUE)
# Make sure class and type are kept
class(strip) <- unique(c("svStripbar", "svStrip", class(strip)))
attr(strip, "type") <- strip_type
strip
}
#test <- c(
# "load",
# "sep_",
# "File_.",
# "._import (cdh)",
# "._sep_",
# "._export (h) ",
# "._View_.",
# ".._viewDef (ch)",
# ".._view",
# "._report",
# "attach (d) "
#)
#pop <- .create_stripbar("popupbar")
#.add_stripbar(pop, test, obj = "testobj", type = "mytype")
# Backward compatibility
#' @export
#' @rdname obj_browse
objBrowse <- obj_browse
#' @export
#' @rdname obj_browse
objClear <- obj_clear
#' @export
#' @rdname obj_browse
objDir <- obj_dir
#' @export
#' @rdname obj_browse
objInfo <- obj_info
#' @export
#' @rdname obj_browse
objList <- obj_list
#' @export
#' @rdname obj_browse
objSearch <- obj_search
#' @export
#' @rdname obj_browse
objMenu <- obj_menu
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.