Nothing
#' GUI: Histogram Input Parameters
#'
#' A graphical user interface (\acronym{GUI}) for specifying input parameters for the \code{\link[graphics]{hist}} function.
#'
#' @param d list, data.frame, matrix, or numeric.
#' Vector(s) of values for which the histogram is desired.
#' @param var.names character.
#' Names corresponding to each vector (column) in argument \code{d}.
#' @param var.default character or integer.
#' Vector name or index in argument \code{d}.
#' @param processed.rec integer.
#' Vector of record indexes for processed data.
#' @param parent tkwin.
#' \acronym{GUI} parent window
#'
#' @return \code{NULL}
#'
#' @author J.C. Fisher, U.S. Geological Survey, Idaho Water Science Center
#'
#' @seealso \code{\link[graphics:plothistogram]{plot.histogram}}
#'
#' @keywords misc
#'
#' @import tcltk
#'
#' @export
#'
#' @examples
#' \dontrun{
#' BuildHistogram(iris)
#' }
#'
BuildHistogram <- function(d, var.names=NULL, var.default=1L, processed.rec=NULL,
parent=NULL) {
# calculate and plot histogram
CalcHist <- function(draw.plot=TRUE) {
tclServiceMode(FALSE)
on.exit(tclServiceMode(TRUE))
idx <- as.integer(tcl(f1.box.1.2, "current")) + 1L
xlab <- as.character(var.names[idx])
processed <- as.logical(as.integer(tclvalue(processed.var)))
row.idxs <- if (processed) processed.rec else seq_along(d[[idx]])
type <- as.integer(tclvalue(breaks.var))
if (type == 1L) {
breaks <- fun.names[as.integer(tcl(f2.box.2.1, "current")) + 1L]
} else if (type == 2L) {
breaks <- as.integer(tclvalue(single.var))
} else if (type == 3L) {
s <- as.character(tclvalue(vector.var))
str.split <- unlist(strsplit(s, "[[:space:]]"))
num.split <- suppressWarnings(as.numeric(str.split))
breaks <- num.split[!is.na(num.split)]
if (length(breaks) == 0) return()
}
right <- as.logical(as.integer(tclvalue(right.var)))
obs <- as.logical(as.integer(tclvalue(obs.var)))
freq <- as.logical(as.integer(tclvalue(freq.var)))
obj <- try(graphics::hist(d[[idx]][row.idxs], breaks=breaks, right=right, plot=FALSE), silent=TRUE)
if (inherits(obj, "try-error")) {
msg <- "Unable to build historgram."
tkmessageBox(icon="error", message=msg, detail=obj, title="Error", type="ok", parent=tt)
return()
}
if (draw.plot) {
if (grDevices::dev.cur() == dev) {
grDevices::dev.new()
graphics::par(mar=c(5, 5, 2, 2) + 0.1, cex=0.8)
}
graphics::plot(obj, col="light grey", freq=freq, main=NULL, xlab=xlab)
if (obs) graphics::rug(d[[idx]], quiet=TRUE)
if (!freq) {
bandwidth <- as.numeric(tclvalue(bandwidth.var))
if (!is.na(bandwidth) && bandwidth > 0) {
dens <- stats::density(d[[idx]], adjust=bandwidth, na.rm=TRUE)
graphics::lines(dens, col="blue")
}
}
} else {
obj$xname <- xlab
txt <- paste(c(utils::capture.output(obj), ""), collapse="\n")
EditText(txt, read.only=TRUE, win.title="Histogram Description",
is.fixed.width.font=TRUE, parent=tt)
}
}
# adjust scale for number of cells
AdjustScaleSingle <- function(x) {
idx <- as.integer(tcl(f1.box.1.2, "current")) + 1L
breaks <- as.integer(x * (maxs[idx] - 1) + 1)
if (breaks != as.integer(tclvalue(single.var))) {
tclvalue(single.var) <- breaks
}
}
# adjust scale for bandwidth in density estimate
AdjustScaleBandwidth <- function(x) {
tclvalue(bandwidth.var) <- round(as.numeric(x), digits=1)
}
# toggle state on break options
ToggleStateBreaks <- function() {
tclServiceMode(FALSE)
on.exit(tclServiceMode(TRUE))
type <- as.integer(tclvalue(breaks.var))
states <- rep(FALSE, 4)
states[type] <- TRUE
s <- if (states[1]) "readonly" else "disabled"
tkconfigure(f2.box.2.1, state=s)
s <- if (states[2]) "!disabled" else "disabled"
tcl(f2.scl.4.1, "state", s)
s <- if (states[2]) "normal" else "disabled"
tkconfigure(f2.ent.4.3, state=s)
s <- if (states[3]) "normal" else "disabled"
tkconfigure(f2.ent.6.1, state=s)
if (states[1]) {
tkfocus(f2.box.2.1)
} else if (states[2]) {
tkfocus(f2.ent.4.3)
} else if (states[3]) {
tkfocus(f2.ent.6.1)
}
}
# toggle state on bandwidth
ToggleStateBandwidth <- function() {
tclServiceMode(FALSE)
on.exit(tclServiceMode(TRUE))
freq <- as.logical(as.integer(tclvalue(freq.var)))
s <- if (freq) "disabled" else "!disabled"
tcl(f4.scl.2.1, "state", s)
s <- if (freq) "disabled" else "normal"
tkconfigure(f4.ent.2.3, state=s)
if (freq) tkfocus(f4.ent.2.3)
}
# check input arguments
if (inherits(d, c("data.frame", "matrix"))) {
d <- as.list(d)
} else if (!is.list(d) && is.null(dim(d))) {
d <- list(d)
}
if (!is.list(d) || length(d) == 0L) stop()
if (!is.character(var.names) || length(var.names) != length(d)) {
var.names <- names(d)
if (is.null(var.names)) var.names <- sprintf("Unknown (%d)", length(d))
}
FUN <- function(i) is.numeric(i) && !all(is.na(i))
is.num <- vapply(d, FUN, TRUE)
d <- d[is.num]
if (length(d) == 0L) {
msg <- "None of the variables can be converted to class 'numeric'."
tkmessageBox(icon="error", message=msg, title="Error", type="ok", parent=tt)
return()
}
var.names <- var.names[is.num]
if (!is.null(processed.rec) && !inherits(processed.rec, "integer"))
stop("problem with 'processed.rec' argument value")
# set defaults
if (inherits(var.default, c("character", "integer"))) {
if (is.character(var.default))
var.default <- which(var.default[1] == var.names)
if (length(var.default) != 1L || !var.default %in% seq_len(length(d)))
var.default <- 1L
} else {
var.default <- 1L
}
maxs <- vapply(d, function(i) length(unique(i)), 0L)
maxs[maxs > 100] <- 100
maxs[maxs < 10] <- 10
defs <- vapply(d, function(i) length(graphics::hist(i, plot=FALSE)$breaks), 0L)
xdef <- (defs[var.default] - 1L) / (maxs[var.default] - 1L)
# initialize device
dev <- grDevices::dev.cur()
# assign the variables linked to Tk widgets
fun.names <- c("sturges", "scott", "freedman-diaconis")
processed.var <- tclVar(FALSE)
breaks.var <- tclVar(1L)
single.var <- tclVar(defs[var.default])
scale.sgl.var <- tclVar(xdef)
vector.var <- tclVar()
right.var <- tclVar(TRUE)
obs.var <- tclVar(FALSE)
freq.var <- tclVar(TRUE)
bandwidth.var <- tclVar(1)
scale.bw.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) <- "Histogram"
tkwm.resizable(tt, 1, 0)
# frame 0
f0 <- ttkframe(tt, relief="flat")
f0.but.1 <- ttkbutton(f0, width=12, text="Plot",
command=function() CalcHist())
f0.but.2 <- ttkbutton(f0, width=12, text="View",
command=function() CalcHist(draw.plot=FALSE))
f0.but.4 <- ttkbutton(f0, width=12, text="Close",
command=function() tclvalue(tt.done.var) <- 1)
f0.but.5 <- ttkbutton(f0, width=12, text="Help",
command=function() {
print(utils::help("BuildHistogram", package="RSurvey"))
})
tkgrid(f0.but.1, f0.but.2, "x", f0.but.4, f0.but.5, pady=10)
tkgrid.configure(f0.but.1, padx=c(10, 4))
tkgrid.configure(f0.but.5, padx=c(4, 10))
tkgrid.columnconfigure(f0, 2, weight=1, minsize=15)
tkpack(f0, fill="x", expand=TRUE, side="bottom", anchor="e")
# frame 1
f1 <- ttkframe(tt, relief="flat")
f1.lab.1.1 <- ttklabel(f1, text="Variable")
f1.box.1.2 <- ttkcombobox(f1, state="readonly")
txt <- "Include only processed records"
f1.chk.2.2 <- ttkcheckbutton(f1, text=txt, variable=processed.var)
tkgrid(f1.lab.1.1, f1.box.1.2, pady=c(10, 0))
if (!is.null(processed.rec)) tkgrid("x", f1.chk.2.2, pady=c(5, 0), sticky="w")
tkgrid.configure(f1.lab.1.1, sticky="e", padx=c(10, 2))
tkgrid.configure(f1.box.1.2, sticky="we", padx=c(0, 10))
val <- if (length(var.names) == 1) sprintf("{%s}", var.names) else var.names
tkconfigure(f1.box.1.2, value=val)
tcl(f1.box.1.2, "current", var.default - 1L)
tkgrid.columnconfigure(f1, 1, weight=1, minsize=25)
tkpack(f1, fill="x", expand=TRUE, padx=10, pady=5)
# frame 2
f2 <- ttklabelframe(tt, relief="flat", borderwidth=5, padding=5, text="Breaks")
txt <- "A function to compute the number of cells for the histogram"
f2.rbt.1.1 <- ttkradiobutton(f2, variable=breaks.var, value=1L, text=txt,
command=ToggleStateBreaks)
f2.box.2.1 <- ttkcombobox(f2, state="readonly")
tkconfigure(f2.box.2.1, value=fun.names)
tcl(f2.box.2.1, "current", 0)
txt <- "A single number giving the suggested number of cells"
f2.rbt.3.1 <- ttkradiobutton(f2, variable=breaks.var, value=2L, text=txt,
command=ToggleStateBreaks)
f2.scl.4.1 <- tkwidget(f2, "ttk::scale", from=0, to=1,
orient="horizontal", variable=scale.sgl.var,
command=function(...) {
AdjustScaleSingle(x=as.numeric(...))
})
f2.ent.4.3 <- ttkentry(f2, width=4, textvariable=single.var)
txt <- "A vector giving the breakpoints between cells"
f2.rbt.5.1 <- ttkradiobutton(f2, variable=breaks.var, value=3L, text=txt,
command=ToggleStateBreaks)
f2.ent.6.1 <- ttkentry(f2, width=15, textvariable=vector.var)
tkgrid(f2.rbt.1.1, sticky="w", columnspan=3)
tkgrid(f2.box.2.1, padx=c(20, 0), pady=c(0, 10), sticky="we", columnspan=3)
tkgrid(f2.rbt.3.1, sticky="w", columnspan=3)
tkgrid(f2.scl.4.1, "x", f2.ent.4.3, pady=c(0, 5), sticky="we")
tkgrid(f2.rbt.5.1, sticky="w", columnspan=3)
tkgrid(f2.ent.6.1, padx=c(20, 0), pady=c(0, 5), sticky="we", columnspan=3)
tkgrid.configure(f2.scl.4.1, columnspan=2, padx=c(20, 4))
tkgrid.columnconfigure(f2, 1, weight=1, minsize=50)
tkpack(f2, fill="x", expand=TRUE, padx=10, pady=5)
# frame 3
f3 <- ttkframe(tt, relief="flat")
txt <- "Histogram cells are right-closed (left-open) intervals"
f3.chk.1.1 <- ttkcheckbutton(f3, text=txt, variable=right.var)
txt <- "Show individual observations"
f3.chk.2.1 <- ttkcheckbutton(f3, text=txt, variable=obs.var)
tkgrid(f3.chk.1.1, sticky="w")
tkgrid(f3.chk.2.1, sticky="w")
tkpack(f3, fill="x", expand=TRUE, padx=20, pady=5)
# frame 4
f4 <- ttklabelframe(tt, relief="flat", borderwidth=5, padding=5,
text="Axis scaling and density estimate")
f4.rbt.1.1 <- ttkradiobutton(f4, variable=freq.var, value=TRUE, text="Frequences",
command=ToggleStateBandwidth)
f4.rbt.1.2 <- ttkradiobutton(f4, variable=freq.var, value=FALSE,
text="Probability densities (adjust bandwidth)",
command=ToggleStateBandwidth)
f4.scl.2.1 <- tkwidget(f4, "ttk::scale", from=0, to=2,
orient="horizontal", variable=scale.bw.var,
command=function(...) {
AdjustScaleBandwidth(x=as.numeric(...))
})
f4.ent.2.3 <- ttkentry(f4, width=4, textvariable=bandwidth.var)
tkgrid(f4.rbt.1.1, f4.rbt.1.2, "x")
tkgrid(f4.scl.2.1, "x", f4.ent.2.3, pady=c(0, 5), sticky="we")
tkgrid.configure(f4.rbt.1.1, padx=c(0, 10))
tkgrid.configure(f4.scl.2.1, columnspan=2, padx=c(20, 4))
tkpack(f4, fill="x", expand=TRUE, padx=10, pady=5)
# bind events
tclServiceMode(TRUE)
tkbind(f1.box.1.2, "<<ComboboxSelected>>",
function() {
idx <- as.integer(tcl(f1.box.1.2, "current")) + 1
x <- as.numeric(tclvalue(scale.sgl.var))
tclvalue(single.var) <- as.integer(x * (maxs[idx] - 1) + 1)
})
tkbind(f2.ent.4.3, "<Return>",
function() {
idx <- as.integer(tcl(f1.box.1.2, "current")) + 1L
ent <- as.integer(CheckEntry("integer", tclvalue(single.var)))
if (is.na(ent)) {
ent <- 1L
} else if (ent > maxs[idx]) {
ent <- maxs[idx]
}
tclvalue(single.var) <- ent
tclvalue(scale.sgl.var) <- (ent - 1) / (maxs[idx] - 1)
})
tkbind(f4.ent.2.3, "<Return>",
function() {
ent <- as.numeric(CheckEntry("numeric", tclvalue(bandwidth.var)))
if (is.na(ent)) {
ent <- 1L
} else if (ent < 0) {
ent <- 0
} else if (ent > 2) {
ent <- 2
}
tclvalue(bandwidth.var) <- ent
tclvalue(scale.bw.var) <- ent
})
tkbind(tt, "<Destroy>", function() tclvalue(tt.done.var) <- 1)
# gui control
ToggleStateBreaks()
ToggleStateBandwidth()
tkfocus(tt)
tkgrab(tt)
tkwait.variable(tt.done.var)
tclServiceMode(FALSE)
tkgrab.release(tt)
tkdestroy(tt)
if (!is.null(parent)) tkfocus(parent)
tclServiceMode(TRUE)
if (grDevices::dev.cur() != dev) grDevices::dev.off()
invisible()
}
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.