#' Creation and management of GUI objects.
#'
#' Create and manipulate `gui` objects to manage 'SciViews'-compatible GUIs
#' (Graphical User Interfaces).
#'
#' @param gui.name The name of the GUI. It is also the name of the object stored
#' in `SciViews:TempEnv` where you can access it.
#' @param widgets The list of widgets that GUI uses, listed in a priority order.
#' @param ask Logical indicating if modal dialog boxes should be display
#' (`ask = TRUE`), or if those dialog boxes are by-passed, using default values
#' to simulate script running in non interactive mode, or to test scripts
#' without interruption, using only provided default values (useful for
#' automated tests).
#' @export
#' @seealso [gui], [setUI()], [dont_ask()]
#' @keywords misc
#' @concept GUI API implementation
#' @examples
#' # A 'gui' object named .GUI is automatically created in 'SciViews:TempEnv'
#' gui_list()
#'
#' # Create a new GUI object to manage a separate GUI in the same R session
#' gui_add("myGUI")
#' gui_list()
#'
#' # Change general properties of this GUI
#' gui_ask(myGUI) <- FALSE
#' # Add widgets to this GUI (you must provide methods for them)
#' # see the svDialogs package for examples
#' gui_widgets(myGUI) <- "tcltkWidgets"
#' gui_widgets(myGUI) # Added to existing ones if reset is FALSE
#'
#' # Remove this new GUI
#' gui_remove("myGUI")
gui_add <- function(gui.name = ".GUI", widgets = c("nativeGUI", "textCLI"), ask)
gui_change(gui.name = gui.name, widgets = widgets, ask = ask, reset = FALSE)
#' @export
#' @rdname gui_add
guiAdd <- gui_add # Backward compatibility
#' @export
#' @rdname gui_add
#' @param reset Should the GUI's main parameters (widgets, ask) be reset to
#' default values?
gui_change <- function(gui.name = ".GUI", widgets = c("nativeGUI", "textCLI"),
reset = FALSE, ask) {
gui.name <- as.character(gui.name)[1]
# Do the object already exists in SciViews:TempEnv?
if (exists(gui.name, envir = .TempEnv(), inherits = FALSE)) {
gui_obj <- get(gui.name, envir = .TempEnv(), inherits = FALSE)
if (!is.gui(gui_obj))
stop("'gui.name' must be a character string naming a 'gui' object',
' in SciViews:TempEnv")
gui_widgets(gui_obj, reset = reset) <- widgets
if (isTRUE(reset)) {
# Make sure name is correct
gui_obj$name <- gui.name
# Use default for ask, if not provided
if (missing(ask)) gui_obj$ask <- NULL
}
} else {# Create a new 'gui' object in SciViews:TempEnv
if (is.na(gui.name) || nchar(gui.name) < 1)
stop("Wrong 'gui.name', provide a non empty character string")
gui_obj <- new.env(parent = .GlobalEnv)
gui_obj$name <- gui.name
gui_obj$ask <- NULL
gui_obj$call <- NULL
gui_obj$res <- NULL
gui_obj$status <- NULL
gui_obj$widgets <- NULL
# In order to allow access to these function when svGUI is not imported
gui_obj$startUI <- function(...) svGUI::startUI(...)
gui_obj$setUI <- function(...) svGUI::setUI(...)
class(gui_obj) <- unique(c(widgets, "gui", "environment"))
assign(gui.name, gui_obj, envir = .TempEnv())
}
# Do we change the ask value?
if (!missing(ask))
if (is.null(ask)) gui_obj$ask <- NULL else
gui_obj$ask <- isTRUE(as.logical(ask))
gui_obj
}
#' @export
#' @rdname gui_add
guiChange <- gui_change # Backward compatibility
#' @export
#' @rdname gui_add
gui_remove <- function(gui.name) {
# Eliminate the corresponding variable, after some housekeeping
gui.name <- as.character(gui.name)
if (length(gui.name) < 1)
return(invisible(TRUE))
if (length(gui.name) > 1) {
warning("more than one item in 'gui.name', only the first one is removed")
gui.name <- gui.name[1]
}
if (gui.name == ".GUI")
stop("You cannot delete the default GUI named '.GUI'!',
' Maybe use ?gui_change.")
if (!exists(gui.name, envir = .TempEnv(), inherits = FALSE))
return(invisible(FALSE))
rm(list = gui.name, envir = .TempEnv(), inherits = FALSE)
invisible(TRUE)
}
#' @export
#' @rdname gui_add
guiRemove <- gui_remove # Backward compatibility
#' @export
#' @rdname gui_add
gui_list <- function() {
lst <- ls(envir = .TempEnv(), all.names = TRUE)
# This should never happen (default .GUI should always be there)
if (!length(lst)) # nocov
return(character(0)) # nocov
# Check which item inherits from 'gui'
lst[vapply(lst, function(x)
is.gui(get(x, envir = .TempEnv(), inherits = FALSE)),
TRUE
)]
}
#' @export
#' @rdname gui_add
guiList <- gui_list # Backward compatibility
#' @export
#' @rdname gui_add
#' @param gui A `gui` object. If provided, it supersedes any value provided in
#' `gui.name`.
gui_widgets <- function(gui, gui.name = ".GUI") {
if (missing(gui)) {
if (exists(gui.name, envir = .TempEnv(), inherits = FALSE)) {
gui <- get(gui.name, envir = .TempEnv(), inherits = FALSE)
} else {
stop("'gui' object '", gui.name, "' not found")
}
}
if (!is.gui(gui))
stop("Provide a 'gui' object or its name")
classes <- class(gui)
# Keep only all classes before 'gui'
classes <- classes[!cumsum(classes == "gui")]
classes
}
#' @export
#' @rdname gui_add
guiWidgets <- gui_widgets # Backward compatibility
#' @export
#' @rdname gui_add
#' @param x A `gui` object.
#' @param value The list of widgets to add to this GUI, in priority order, or
#' should we change ask to `TRUE`, `FALSE` or `NULL` (then, use the default
#' value stored in `getOption("gui.ask")`).
`gui_widgets<-` <- function(x, reset = FALSE, value) {
value <- as.character(value)
if (isTRUE(as.logical(reset))) {
# Change completely class
class(x) <- unique(c(value, "gui", "environment"))
} else {
# Add 'value' items to current classes
classes <- class(x)
value <- value[!value %in% classes]
if (length(value))
class(x) <- c(value, classes)
}
x
}
#' @export
#' @rdname gui_add
`guiWidgets<-` <- `gui_widgets<-` # Backward compatibility
#' @export
#' @rdname gui_add
#' @param gui.or.name A `gui` object or its name.
gui_ask <- function(gui.or.name, ask) {
if (missing(gui.or.name)) {
# Query or change the default value in 'gui.ask' option
if (missing(ask)) {
res <- getOption("gui.ask", default = NULL)
if (is.null(res))
res <- structure(TRUE, comment = "default")
return(res)
}
if (!is.null(ask))
ask <- isTRUE(as.logical(ask))
res <- options(gui.ask = ask)$gui.ask
if (!is.null(res))
res <- as.logical(res)
} else {
if (is.gui(gui.or.name)) {
gui_obj <- gui.or.name
} else {
if (!exists(gui.or.name, envir = .TempEnv(), inherits = FALSE))
stop("'gui' object '", gui.or.name, "' not found")
gui_obj <- get(gui.or.name, envir = .TempEnv(), inherits = FALSE)
if (!is.gui(gui_obj))
stop("'gui.or.name' must be a 'gui' object in',
' SciViews:TempEnv or its name")
}
if (missing(ask)) {
res <- gui_obj$ask
if (is.null(res)) # Look at default value
res <- structure(getOption("gui.ask", default = TRUE),
comment = "default")
return(res)
}
# Change the value for this GUI
res <- gui_obj$ask
if (is.null(ask)) {
gui_obj$ask <- NULL
} else {
gui_obj$ask <- isTRUE(as.logical(ask))
}
}
invisible(res)
}
#' @export
#' @rdname gui_add
guiAsk <- gui_ask # Backward compatibility
#' @export
#' @rdname gui_add
`gui_ask<-` <- function(x, value) {
if (!is.gui(x))
stop("gui_ask must be applied to a 'gui' object")
if (is.null(value)) x$ask <- NULL else
x$ask <- isTRUE(as.logical(value))
x
}
#' @export
#' @rdname gui_add
`guiAsk<-` <- `gui_ask<-` # Backward compatibility
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.