Nothing
#' GUI: Import Data from Package Dataset
#'
#' A graphical user interface (\acronym{GUI}) for importing data from selected \R package datasets.
#'
#' @param classes character.
#' The object classes of data sets that can be loaded.
#' Set to \code{NULL} to enable loading for all object classes.
#' @param parent tkwin.
#' \acronym{GUI} parent window
#'
#' @return Returns an object of list class with the following components:
#' \item{d}{table data}
#' \item{src}{vector of length 3 that includes the dataset name, package name, and access date.}
#'
#' @author J.C. Fisher, U.S. Geological Survey, Idaho Water Science Center
#'
#' @seealso \code{\link{data}}
#'
#' @keywords IO
#'
#' @import tcltk
#'
#' @export
#'
#' @examples
#' \dontrun{
#' obj <- ImportDataset(c("data.frame", "matrix"))
#' }
#'
ImportDataset <- function(classes=NULL, parent=NULL) {
# import dataset
ImportDataset <- function() {
tkconfigure(tt, cursor="watch")
tclServiceMode(FALSE)
on.exit(tkconfigure(tt, cursor="arrow"))
on.exit(tclServiceMode(TRUE), add=TRUE)
idx <- as.integer(tkcurselection(f1.lst.2.1)) + 1L
pkg.name <- pkg.names[idx]
idx <- as.integer(tkcurselection(f1.lst.2.4))
pkg.item <- as.character(tkget(f1.lst.2.4, idx))
rtn <<- list(d=eval(parse(text=paste(pkg.name, pkg.item, sep="::"))),
src=c(dataset=pkg.item, package=pkg.name,
accessed=format(Sys.time())))
tclvalue(tt.done.var) <- 1
}
# load package
LoadPackage <- function() {
tkconfigure(tt, cursor="watch")
tclServiceMode(FALSE)
on.exit(tkconfigure(tt, cursor="arrow"))
on.exit(tclServiceMode(TRUE), add=TRUE)
idx <- as.integer(tkcurselection(f1.lst.2.1)) + 1L
pkg.name <- pkg.names[idx]
if (requireNamespace(pkg.name, quietly=TRUE)) {
idx <- as.integer(tcl(f1.box.3.1, "current"))
if (idx == 2L) {
tcl(f1.box.3.1, "current", 0)
SelectPackageType()
tkselection.clear(f1.lst.2.1, 0, "end")
idx <- which(pkg.names %in% pkg.name) - 1L
tkselection.set(f1.lst.2.1, idx)
tksee(f1.lst.2.1, idx)
}
SelectPackage()
} else {
msg <- "Unable to load package namespace."
tkmessageBox(icon="error", message=msg, title="Error", type="ok", parent=tt)
}
tkfocus(f1.lst.2.1)
}
# summarize datasets in package
SummarizePackage <- function() {
idx <- as.integer(tkcurselection(f1.lst.2.1)) + 1L
pkg.name <- pkg.names[idx]
pkg.datasets <- ds.list[[pkg.name]]
pkg.datasets <- pkg.datasets[order(pkg.datasets[, 1]), , drop=FALSE]
nmax <- max(nchar(pkg.datasets[, "Item"]))
if (nmax < 20) nmax <- 20
items <- sprintf(paste0("%-", nmax, "s"), pkg.datasets[, "Item"])
txt <- sprintf("Datasets in package %s:\n", sQuote(pkg.name))
txt <- c(txt, paste(items, pkg.datasets[, "Title"], sep=" "))
EditText(txt, read.only=TRUE, win.title="Summary of Datasets",
is.fixed.width.font=TRUE, parent=tt)
tkfocus(f1.lst.2.1)
}
# describe dataset
DescribeDataset <- function() {
idx <- as.integer(tkcurselection(f1.lst.2.1)) + 1L
pkg.name <- pkg.names[idx]
idx <- as.integer(tkcurselection(f1.lst.2.4))
pkg.item <- paste(as.character(tkget(f1.lst.2.4, idx)), collapse=" ")
ans <- try(utils::help(pkg.item, package=(pkg.name)), silent=TRUE)
if (inherits(ans, "try-error")) {
msg <- "Problem with dataset documentation."
tkmessageBox(icon="error", message=msg, title="Error", type="ok", parent=tt)
} else {
print(ans)
}
tkfocus(f1.lst.2.4)
}
# get class of dataset
GetClass <- function(pkg.name, pkg.item) {
txt <- paste(pkg.name, pkg.item, sep="::")
ans <- try(class(eval(parse(text=txt))), silent=TRUE)
pkg.item.class <- if (inherits(ans, "try-error")) "<Unknown>" else ans
return(pkg.item.class[1])
}
# gui control for select package
SelectPackage <- function() {
tkconfigure(tt, cursor="watch")
tclServiceMode(FALSE)
on.exit(tkconfigure(tt, cursor="arrow"))
on.exit(tclServiceMode(TRUE), add=TRUE)
idx <- as.integer(tkcurselection(f1.lst.2.1)) + 1L
pkg.name <- pkg.names[idx]
if (isNamespaceLoaded(pkg.name)) {
tkconfigure(f1.but.4.2, state="disabled", default="disabled")
pkg.datasets <- ds.list[[pkg.name]]
all.pkg.items <- pkg.datasets[, "Item"]
if (is.null(ds.class[[pkg.name]]))
ds.class[[pkg.name]] <<- vapply(all.pkg.items, function(i) GetClass(pkg.name, i), "")
ds.classes <- vapply(ds.class[[pkg.name]], function(i) paste(i, collapse=" "), "")
ds.in.error <- ds.classes %in% "try-error"
ds.class.vals <- sort(unique(ds.classes[!ds.in.error]))
if (as.logical(as.integer(tclvalue(fit.for.loading.var))))
ds.class.vals <- ds.class.vals[ds.class.vals %in% classes]
if (length(ds.class.vals) > 0)
ds.class.vals <- c("Show all classes", ds.class.vals)
else
ds.class.vals <- "{Show all classes}"
old.class <- paste(as.character(tkget(f1.box.3.4)), collapse=" ")
tkconfigure(f1.box.3.4, value=ds.class.vals, state="readonly")
idx <- which(ds.class.vals %in% old.class)
idx <- if (length(idx) > 0) idx - 1L else 0L
tcl(f1.box.3.4, "current", idx)
if (idx > 0)
pkg.items <- all.pkg.items[ds.classes %in% ds.class.vals[idx + 1L]]
else
pkg.items <- all.pkg.items[ds.classes %in% ds.class.vals]
if (length(pkg.items) > 0) pkg.items <- sort(pkg.items)
tkselection.clear(f1.lst.2.4, 0, "end")
tclvalue(dataset.var) <- ""
for (i in seq_along(pkg.items)) tcl("lappend", dataset.var, pkg.items[i])
if (length(pkg.items) > 0) {
tkselection.set(f1.lst.2.4, 0)
tkconfigure(f1.but.4.4, state="normal")
} else {
tkconfigure(f1.but.4.4, state="disabled")
}
} else {
tkconfigure(f1.box.3.4, value="{}")
tcl(f1.box.3.4, "current", 0)
tkconfigure(f1.box.3.4, state="disabled")
tkconfigure(f0.but.1.2, state="disabled")
tkconfigure(f1.but.4.2, state="normal", default="active")
tkconfigure(f1.but.4.4, state="disabled")
tkselection.clear(f1.lst.2.4, 0, "end")
tclvalue(dataset.var) <- ""
}
SelectDataset()
}
# gui control for select dataset
SelectDataset <- function() {
idx <- as.integer(tkcurselection(f1.lst.2.4))
if (length(idx) == 0) {
tkconfigure(f0.but.1.2, state="disabled", default="disabled")
return()
}
pkg.item <- paste(as.character(tkget(f1.lst.2.4, idx)), collapse=" ")
pkg.name <- pkg.names[as.integer(tkcurselection(f1.lst.2.1)) + 1L]
idx <- which(ds.list[[pkg.name]][, "Item"] %in% pkg.item)
is.valid <- ds.class[[pkg.name]][idx] %in% classes
if (is.null(classes) | is.valid)
tkconfigure(f0.but.1.2, state="normal", default="active")
else
tkconfigure(f0.but.1.2, state="disabled", default="disabled")
}
# gui control for select package type
SelectPackageType <- function() {
tkconfigure(tt, cursor="watch")
tclServiceMode(FALSE)
on.exit(tkconfigure(tt, cursor="arrow"))
on.exit(tclServiceMode(TRUE), add=TRUE)
idx <- as.integer(tcl(f1.box.3.1, "current"))
if (idx == 0L) {
pkg.names <<- all.pkgs
} else {
is.pkg.loaded <- all.pkgs %in% loadedNamespaces()
if (idx == 1L)
pkg.names <<- all.pkgs[is.pkg.loaded]
else
pkg.names <<- all.pkgs[!is.pkg.loaded]
}
tkselection.clear(f1.lst.2.1, 0, "end")
tclvalue(package.var) <- ""
for (i in seq_along(pkg.names)) tcl("lappend", package.var, pkg.names[i])
tkselection.set(f1.lst.2.1, 0)
SelectPackage()
tkfocus(f1.lst.2.1)
}
# gui control for select class type
SelectClassType <- function() {
SelectPackage()
if (length(as.integer(tkcurselection(f1.lst.2.4))) == 0)
tkfocus(f1.lst.2.1)
else
tkfocus(f1.lst.2.4)
}
# initialize values
all.pkgs <- .packages(all.available=TRUE, lib.loc=.libPaths())
all.pkgs <- all.pkgs[!all.pkgs %in% c("Rcmdr")]
all.ds <- suppressWarnings(utils::data(package=all.pkgs)$results)
all.ds[, "Item"] <- gsub(" \\((.*)\\).*", "", all.ds[, "Item"])
all.pkgs <- sort(unique(all.ds[, "Package"]))
FUN <- function(i) all.ds[all.ds[, "Package"] == i, c("Item", "Title"), drop=FALSE]
ds.list <- sapply(all.pkgs, FUN, simplify=FALSE)
ds.class <- list()
pkg.type.vals <- paste(c("Show all", "Loaded", "Unloaded"), "packages")
ds.class.vals <- "{}"
pkg.names <- NULL
rtn <- NULL
# assign variables linked to Tk widgets
package.var <- tclVar()
dataset.var <- tclVar()
fit.for.loading.var <- tclVar(1)
tt.done.var <- tclVar(0)
# open gui
tclServiceMode(FALSE)
tt <- tktoplevel()
if (!is.null(parent)) {
tkwm.transient(tt, parent)
geo <- unlist(strsplit(as.character(tkwm.geometry(parent)), "\\+"))
geo <- as.integer(geo[2:3]) + 25
tkwm.geometry(tt, sprintf("+%s+%s", geo[1], geo[2]))
}
tktitle(tt) <- "Import Dataset From R Package"
# frame 0 contains load, cancel, and help buttons, and size grip
f0 <- ttkframe(tt, relief="flat")
f0.but.1.2 <- ttkbutton(f0, width=12, text="Import", command=ImportDataset)
f0.but.1.3 <- ttkbutton(f0, width=12, text="Cancel",
command=function() tclvalue(tt.done.var) <- 1)
f0.but.1.4 <- ttkbutton(f0, width=12, text="Help",
command=function() {
print(utils::help("ImportDataset", package="RSurvey"))
})
f0.grp.1.5 <- ttksizegrip(f0)
tkgrid("x", f0.but.1.2, f0.but.1.3, f0.but.1.4, f0.grp.1.5)
tkgrid.configure(f0.but.1.2, padx=c(10, 0))
tkgrid.configure(f0.but.1.3, padx=4)
tkgrid.configure(f0.but.1.4, padx=c(0, 10), columnspan=2)
tkgrid.configure(f0.but.1.2, f0.but.1.3, f0.but.1.4, pady=c(15, 10))
tkgrid.configure(f0.grp.1.5, sticky="se")
tkraise(f0.but.1.4, f0.grp.1.5)
tkgrid.columnconfigure(f0, 0, weight=1)
tkpack(f0, fill="x", side="bottom", anchor="e")
tkconfigure(f0.but.1.2, state="disabled")
# frame 1, package and dataset
f1 <- ttkframe(tt, relief="flat", padding=0, borderwidth=0)
f1.lab.1.1 <- ttklabel(f1, text="Package", foreground="#141414")
f1.lab.1.4 <- ttklabel(f1, text="Dataset", foreground="#141414")
f1.lst.2.1 <- tklistbox(f1, selectmode="browse", activestyle="none",
relief="flat", borderwidth=5, width=30, height=8,
exportselection=FALSE, listvariable=package.var,
highlightthickness=0)
f1.ysc.2.3 <- ttkscrollbar(f1, orient="vertical")
tkconfigure(f1.lst.2.1, background="white", yscrollcommand=paste(.Tk.ID(f1.ysc.2.3), "set"))
tkconfigure(f1.ysc.2.3, command=paste(.Tk.ID(f1.lst.2.1), "yview"))
f1.lst.2.4 <- tklistbox(f1, selectmode="browse", activestyle="none", relief="flat",
borderwidth=5, width=30, height=8, exportselection=FALSE,
listvariable=dataset.var, highlightthickness=0)
f1.ysc.2.6 <- ttkscrollbar(f1, orient="vertical")
tkconfigure(f1.lst.2.4, background="white", yscrollcommand=paste(.Tk.ID(f1.ysc.2.6), "set"))
tkconfigure(f1.ysc.2.6, command=paste(.Tk.ID(f1.lst.2.4), "yview"))
f1.box.3.1 <- ttkcombobox(f1, state="readonly", value=pkg.type.vals)
f1.box.3.4 <- ttkcombobox(f1, state="readonly", value=ds.class.vals)
f1.but.4.1 <- ttkbutton(f1, width=10, text="Summary", command=SummarizePackage)
f1.but.4.2 <- ttkbutton(f1, width=10, text="Load", command=LoadPackage)
f1.but.4.4 <- ttkbutton(f1, width=10, text="Describe", command=DescribeDataset)
if (is.null(classes))
f1.chk.4.5 <- "x"
else
f1.chk.4.5 <- ttkcheckbutton(f1, text="Fit for loading", variable=fit.for.loading.var,
command=function() {
SelectPackage()
tkfocus(f1.lst.2.1)
})
tkgrid(f1.lab.1.1, "x", "x", f1.lab.1.4, "x", "x", pady=c(10, 0))
tkgrid(f1.lst.2.1, "x", f1.ysc.2.3, f1.lst.2.4, "x", f1.ysc.2.6)
tkgrid(f1.box.3.1, "x", "x", f1.box.3.4, "x", "x", pady=4)
tkgrid(f1.but.4.1, f1.but.4.2, "x", f1.but.4.4, f1.chk.4.5, "x")
tkgrid.configure(f1.lab.1.1, columnspan=3)
tkgrid.configure(f1.lab.1.4, columnspan=3)
tkgrid.configure(f1.lst.2.1, columnspan=2)
tkgrid.configure(f1.lst.2.4, columnspan=2)
tkgrid.configure(f1.box.3.1, columnspan=2)
tkgrid.configure(f1.box.3.4, columnspan=2)
tkgrid.configure(f1.lab.1.1, f1.lab.1.4, sticky="w")
tkgrid.configure(f1.lst.2.1, f1.lst.2.4, sticky="nswe")
tkgrid.configure(f1.ysc.2.3, f1.ysc.2.6, sticky="ns")
tkgrid.configure(f1.box.3.1, f1.box.3.4, sticky="we")
tkgrid.configure(f1.but.4.2, f1.but.4.4, f1.chk.4.5, sticky="w")
tkgrid.configure(f1.ysc.2.3, padx=c(0, 25))
tkgrid.configure(f1.but.4.1, padx=c(0, 4))
tkgrid.configure(f1.but.4.4, padx=c(0, 8))
tkgrid.columnconfigure(f1, 1, minsize=85, weight=1)
tkgrid.columnconfigure(f1, 4, minsize=85, weight=1)
tkgrid.rowconfigure(f1, 1, weight=1)
tkpack(f1, fill="both", expand=TRUE, anchor="nw", padx=10)
tkselection.set(f1.lst.2.1, 0)
tcl(f1.box.3.1, "current", 0)
# bind events
tclServiceMode(TRUE)
tkbind(f1.lst.2.1, "<<ListboxSelect>>", SelectPackage)
tkbind(f1.lst.2.4, "<<ListboxSelect>>", SelectDataset)
tkbind(f1.box.3.1, "<<ComboboxSelected>>", SelectPackageType)
tkbind(f1.box.3.4, "<<ComboboxSelected>>", SelectClassType)
tkbind(tt, "<Destroy>", function() tclvalue(tt.done.var) <- 1)
# gui control
SelectPackageType()
tkfocus(f1.lst.2.1)
tkgrab(tt)
tkwait.variable(tt.done.var)
tclServiceMode(FALSE)
tkgrab.release(tt)
tkdestroy(tt)
tclServiceMode(TRUE)
invisible(rtn)
}
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.