Nothing
R/utilities.R
In Rcmdr205: R Commander
# last modified 2014-03-27 by M. Bouchet-Valat
# utility functions
# listing objects etc.
listDataSets <- function(envir=.GlobalEnv, ...) {
Vars <- ls(envir = envir, all.names = TRUE) # + PhG
if (length(Vars) == 0) return(Vars) # + PhG
names(which(sapply(Vars, function(.x) is.data.frame(get(.x, envir=envir)))))
}
listLinearModels <- function(envir=.GlobalEnv, ...) {
objects <- ls(envir=envir, ...)
if (length(objects) == 0) NULL
else objects[sapply(objects,
function(.x) "lm" == (class(get(.x, envir=envir))[1]))]
}
listAOVModels <- function(envir=.GlobalEnv, ...) {
objects <- ls(envir=envir, ...)
if (length(objects) == 0) NULL
else objects[sapply(objects,
function(.x) "aov" == (class(get(.x, envir=envir))[1]))]
}
listGeneralizedLinearModels <- function(envir=.GlobalEnv, ...) {
objects <- ls(envir=envir, ...)
if (length(objects) == 0) NULL
else objects[sapply(objects,
function(.x) "glm" == (class(get(.x, envir=envir))[1]))]
}
listMultinomialLogitModels <- function(envir=.GlobalEnv, ...) {
objects <- ls(envir=envir, ...)
if (length(objects) == 0) NULL
else objects[sapply(objects,
function(.x) "multinom" == (class(get(.x, envir=envir))[1]))]
}
listProportionalOddsModels <- function(envir=.GlobalEnv, ...) {
objects <- ls(envir=envir, ...)
if (length(objects) == 0) NULL
else objects[sapply(objects,
function(.x) "polr" == (class(get(.x, envir=envir))[1]))]
}
listAllModels <- function(envir=.GlobalEnv, ...) {
objects <- ls(envir=envir, ...)
if (length(objects) == 0) NULL
else objects[sapply(objects,
function(.x) (class(get(.x, envir=envir))[1])) %in% getRcmdr("modelClasses")]
}
activeDataSet <- function(dsname, flushModel=TRUE, flushDialogMemory=TRUE){
.activeDataSet <- ActiveDataSet()
if (missing(dsname)) {
if (is.null(.activeDataSet)){
Message(message=gettextRcmdr("There is no active data set."), type="error")
return(FALSE)
}
else return(.activeDataSet)
}
if (!is.data.frame(ds <- get(dsname, envir=.GlobalEnv))){
if (!exists.method("as.data.frame", ds, default=FALSE)){
Message(message=paste(dsname, gettextRcmdr(" is not a data frame and cannot be attached."),
sep=""), type="error")
tkfocus(CommanderWindow())
return()
}
command <- paste(dsname, " <- as.data.frame(", dsname, ")", sep="")
justDoIt(command)
logger(command)
Message(message=paste(dsname, gettextRcmdr(" has been coerced to a data frame"), sep=""),
type="warning")
}
varnames <- names(get(dsname, envir=.GlobalEnv))
newnames <- make.names(varnames)
badnames <- varnames != newnames
if (any(badnames)){
command <- paste("names(", dsname, ") <- make.names(names(",
dsname, "))", sep="")
doItAndPrint(command)
}
if (!is.null(.activeDataSet) && getRcmdr("attach.data.set")
&& (length(grep(.activeDataSet, search())) !=0)) {
detach(pos = match(.activeDataSet, search()))
logger(paste("detach(", .activeDataSet, ")", sep=""))
}
if (flushModel) {
putRcmdr(".activeModel", NULL)
RcmdrTclSet("modelName", gettextRcmdr("<No active model>"))
tkconfigure(getRcmdr("modelLabel"), foreground="red")
}
if (flushDialogMemory) putRcmdr("dialog.values", list())
ActiveDataSet(dsname)
Message(sprintf(gettextRcmdr("The dataset %s has %d rows and %d columns."), dsname,
nrow(get(dsname, envir=.GlobalEnv)), ncol(get(dsname, envir=.GlobalEnv))), type="note")
if (any(badnames)) Message(message=paste(dsname, gettextRcmdr(" contains non-standard variable names:\n"),
paste(varnames[badnames], collapse=", "),
gettextRcmdr("\nThese have been changed to:\n"), paste(newnames[badnames], collapse=", "),
sep=""), type="warning")
RcmdrTclSet("dataSetName", paste(" ", dsname, " "))
tkconfigure(getRcmdr("dataSetLabel"), foreground="blue")
activateMenus()
dsname
}
activeModel <- function(model){
if (missing(model)) {
.activeModel <- ActiveModel()
if (is.null(.activeModel)){
Message(message=gettextRcmdr("There is no active model."), type="error")
return(FALSE)
}
else return(.activeModel)
}
ActiveModel(model)
RcmdrTclSet("modelName", paste(" ", model, " "))
tkconfigure(getRcmdr("modelLabel"), foreground="blue")
activateMenus()
model
}
listVariables <- function(dataSet=ActiveDataSet()) {
if(missing(dataSet)) {
Variables()
}
else {
vars <- names(get(dataSet, envir=.GlobalEnv))
if (getRcmdr("sort.names")) sortVarNames(vars) else vars
}
}
listFactors <- function(dataSet=ActiveDataSet()) {
if(missing(dataSet)) {
Factors()
}
else {
variables <- listVariables(dataSet)
variables[sapply(variables, function(.x)
is.factor(eval(parse(text=.x), envir=get(dataSet, envir=.GlobalEnv))))]
}
}
listTwoLevelFactors <- function(dataSet=ActiveDataSet()){
if(missing(dataSet)) {
TwoLevelFactors()
}
else {
factors <- listFactors(dataSet)
if(length(factors) == 0) return(NULL)
factors[sapply(factors, function(.x)
2 == length(levels(eval(parse(text=.x), envir=get(dataSet, envir=.GlobalEnv)))))]
}
}
listNumeric <- function(dataSet=ActiveDataSet()) {
if(missing(dataSet)) {
Numeric()
}
else {
variables <- listVariables(dataSet)
variables[sapply(variables,function(.x)
is.numeric(eval(parse(text=.x), envir=get(dataSet, envir=.GlobalEnv))))]
}
}
trim.blanks <- function(text){
gsub("^\ *", "", gsub("\ *$", "", text))
}
is.valid.name <- function(x){
length(x) == 1 && is.character(x) && x == make.names(x)
}
# statistical
colPercents <- function(tab, digits=1){
dim <- length(dim(tab))
if (is.null(dimnames(tab))){
dims <- dim(tab)
dimnames(tab) <- lapply(1:dim, function(i) 1:dims[i])
}
sums <- apply(tab, 2:dim, sum)
per <- apply(tab, 1, function(x) x/sums)
dim(per) <- dim(tab)[c(2:dim,1)]
per <- aperm(per, c(dim, 1:(dim-1)))
dimnames(per) <- dimnames(tab)
per <- round(100*per, digits)
result <- abind(per, Total=apply(per, 2:dim, sum), Count=sums, along=1)
names(dimnames(result)) <- names(dimnames(tab))
result
}
rowPercents <- function(tab, digits=1){
dim <- length(dim(tab))
if (dim == 2) return(t(colPercents(t(tab), digits=digits)))
tab <- aperm(tab, c(2,1,3:dim))
aperm(colPercents(tab, digits=digits), c(2,1,3:dim))
}
totPercents <- function(tab, digits=1){
dim <- length(dim(tab))
if (is.null(dimnames(tab))){
dims <- dim(tab)
dimnames(tab) <- lapply(1:dim, function(i) 1:dims[i])
}
tab <- 100*tab/sum(tab)
tab <- cbind(tab, rowSums(tab))
tab <- rbind(tab, colSums(tab))
rownames(tab)[nrow(tab)] <- "Total"
colnames(tab)[ncol(tab)] <- "Total"
round(tab, digits=digits)
}
reliability <- function(S){
reliab <- function(S, R){
k <- dim(S)[1]
ones <- rep(1, k)
v <- as.vector(ones %*% S %*% ones)
alpha <- (k/(k - 1)) * (1 - (1/v)*sum(diag(S)))
rbar <- mean(R[lower.tri(R)])
std.alpha <- k*rbar/(1 + (k - 1)*rbar)
c(alpha=alpha, std.alpha=std.alpha)
}
result <- list()
if ((!is.numeric(S)) || !is.matrix(S) || (nrow(S) != ncol(S))
|| any(abs(S - t(S)) > max(abs(S))*1e-10) || nrow(S) < 2)
stop(gettextRcmdr("argument must be a square, symmetric, numeric covariance matrix"))
k <- dim(S)[1]
s <- sqrt(diag(S))
R <- S/(s %o% s)
rel <- reliab(S, R)
result$alpha <- rel[1]
result$st.alpha <- rel[2]
if (k < 3) {
warning(gettextRcmdr("there are fewer than 3 items in the scale"))
return(invisible(NULL))
}
rel <- matrix(0, k, 3)
for (i in 1:k) {
rel[i, c(1,2)] <- reliab(S[-i, -i], R[-i, -i])
a <- rep(0, k)
b <- rep(1, k)
a[i] <- 1
b[i] <- 0
cov <- a %*% S %*% b
var <- b %*% S %*% b
rel[i, 3] <- cov/(sqrt(var * S[i,i]))
}
rownames(rel) <- rownames(S)
colnames(rel) <- c("Alpha", "Std.Alpha", "r(item, total)")
result$rel.matrix <- rel
class(result) <- "reliability"
result
}
print.reliability <- function(x, digits=4, ...){
cat(paste("Alpha reliability = ", round(x$alpha, digits), "\n"))
cat(paste("Standardized alpha = ", round(x$st.alpha, digits), "\n"))
cat("\nReliability deleting each item in turn:\n")
print(round(x$rel.matrix, digits))
invisible(x)
}
partial.cor <- function(X, tests=FALSE, use=c("complete.obs", "pairwise.complete.obs")){
countValid <- function(X){
X <- !is.na(X)
t(X) %*% X
}
use <- match.arg(use)
if (use == "complete.obs"){
X <- na.omit(X)
n <- nrow(X)
}
else n <- countValid(X)
R <- cor(X, use=use)
RI <- solve(R)
D <- 1/sqrt(diag(RI))
R <- - RI * (D %o% D)
diag(R) <- 0
rownames(R) <- colnames(R) <- colnames(X)
result <- list(R=R, n=n, P=NULL, P.unadj=NULL)
if (tests){
opt <- options(scipen=5)
on.exit(options(opt))
df <- n - ncol(X)
f <- (R^2)*df/(1 - R^2)
P <- P.unadj <- pf(f, 1, df, lower.tail=FALSE)
p <- P[lower.tri(P)]
adj.p <- p.adjust(p, method="holm")
P[lower.tri(P)] <- adj.p
P[upper.tri(P)] <- 0
P <- P + t(P)
P <- ifelse(P < 1e-04, 0, P)
P <- format(round(P, 4))
diag(P) <- ""
P[grep("0.0000", P)] <- "<.0001"
P.unadj <- ifelse(P.unadj < 1e-04, 0, P.unadj)
P.unadj <- format(round(P.unadj, 4))
diag(P.unadj) <- ""
P.unadj[grep("0.0000", P.unadj)] <- "<.0001"
result$P <- P
result$P.unadj <- P.unadj
}
class(result) <- "partial.cor"
result
}
print.partial.cor <- function(x, digits=max(3, getOption("digits") - 2), ...){
cat("\n Partial correlations:\n")
print(round(x$R, digits, ...))
cat("\n Number of observations: ")
n <- x$n
if (all(n[1] == n)) cat(n[1], "\n")
else{
cat("\n")
print(n)
}
if (!is.null(x$P)){
cat("\n Pairwise two-sided p-values:\n")
print(x$P.unadj, quote=FALSE)
cat("\n Adjusted p-values (Holm's method)\n")
print(x$P, quote=FALSE)
}
x
}
Confint <- function(object, parm, level=0.95, ...) UseMethod("Confint")
Confint.default <- function(object, parm, level = 0.95, ...) {
ci <- confint(object, parm, level, ...)
ci <- cbind(coef(object), ci)
colnames(ci)[1] <- "Estimate"
ci
}
Confint.glm <- function (object, parm, level=0.95, type=c("LR", "Wald"), ...){
# adapted from stats:::confint.lm
type <- match.arg(type)
cf <- coef(object)
pnames <- names(cf)
if (type == "LR")
ci <- confint.glm(object, parm, level, ...)
else {
if (missing(parm))
parm <- seq(along = pnames)
else if (is.character(parm))
parm <- match(parm, pnames, nomatch = 0)
a <- (1 - level)/2
a <- c(a, 1 - a)
pct <- paste(round(100 * a, 1), "%")
ci <- array(NA, dim = c(length(parm), 2), dimnames = list(pnames[parm],
pct))
ses <- sqrt(diag(vcov(object)))[parm]
fac <- qnorm(a)
ci[] <- cf[parm] + ses %o% fac
}
ci <- cbind(cf, ci)
colnames(ci)[1] <- "Estimate"
fam <- family(object)
if (fam$family == "binomial" && fam$link == "logit"){
expci <- exp(ci)
colnames(expci)[1] <- "exp(Estimate)"
ci <- cbind(ci, expci)
}
ci
}
confint.polr <- function (object, parm, level=0.95, ...){
# adapted from stats:::confint.lm
cf <- coef(object)
pnames <- names(cf)
if (missing(parm))
parm <- seq(along = pnames)
else if (is.character(parm))
parm <- match(parm, pnames, nomatch = 0)
a <- (1 - level)/2
a <- c(a, 1 - a)
pct <- paste(round(100 * a, 1), "%")
ci <- array(NA, dim = c(length(parm), 2), dimnames = list(pnames[parm],
pct))
ses <- sqrt(diag(vcov(object)))[parm]
fac <- qnorm(a)
ci[] <- cf[parm] + ses %o% fac
ci
}
confint.multinom <- function (object, parm, level=0.95, ...){
# adapted from stats:::confint.lm
require("abind")
cf <- coef(object)
if (is.vector(cf)) cf <- matrix(cf, nrow=1,
dimnames=list(object$lev[2], names(cf)))
pnames <- colnames(cf)
if (missing(parm))
parm <- seq(along = pnames)
else if (is.character(parm))
parm <- match(parm, pnames, nomatch = 0)
a <- (1 - level)/2
a <- c(a, 1 - a)
ses <- matrix(sqrt(diag(vcov(object))),
ncol=ncol(cf), byrow=TRUE)[,parm, drop=FALSE]
cf <- cf[,parm, drop=FALSE]
fac <- qnorm(a)
ci <- abind(cf + fac[1]*ses, cf + fac[2]*ses, along=3)
dimnames(ci)[[3]] <- paste(round(100 * a, 1), "%")
aperm(ci, c(2,3,1))
}
Confint.multinom <- function(object, parm, level = 0.95, ...) confint (object, parm=parm, level=0.95, ...)
numSummary <- function(data,
statistics=c("mean", "sd", "IQR", "quantiles", "cv", "skewness", "kurtosis"),
type=c("2", "1", "3"),
quantiles=c(0, .25, .5, .75, 1), groups){
sd <- function(x, type, ...){
apply(as.matrix(x), 2, stats::sd, na.rm=TRUE)
}
IQR <- function(x, type, ...){
apply(as.matrix(x), 2, stats::IQR, na.rm=TRUE)
}
cv <- function(x, ...){
x <- as.matrix(x)
mean <- colMeans(x, na.rm=TRUE)
sd <- sd(x)
if (any(x <= 0, na.rm=TRUE)) warning("not all values are positive")
cv <- sd/mean
cv[mean <= 0] <- NA
cv
}
skewness <- function(x, type, ...){
if (is.vector(x)) return(e1071::skewness(x, type=type, na.rm=TRUE))
apply(x, 2, skewness, type=type)
}
kurtosis <- function(x, type, ...){
if (is.vector(x)) return(e1071::kurtosis(x, type=type, na.rm=TRUE))
apply(x, 2, kurtosis, type=type)
}
if(!require(abind)) stop("abind package missing")
if(!require(e1071)) stop("e1071 package missing")
data <- as.data.frame(data)
if (!missing(groups)) {
groups <- as.factor(groups)
counts <- table(groups)
if (any(counts == 0)){
levels <- levels(groups)
warning("the following groups are empty: ", paste(levels[counts == 0], collapse=", "))
groups <- factor(groups, levels=levels[counts != 0])
}
}
variables <- names(data)
if (missing(statistics)) statistics <- c("mean", "sd", "quantiles", "IQR")
statistics <- match.arg(statistics, c("mean", "sd", "IQR", "quantiles", "cv", "skewness", "kurtosis"),
several.ok=TRUE)
type <- match.arg(type)
type <- as.numeric(type)
ngroups <- if(missing(groups)) 1 else length(grps <- levels(groups))
quantiles <- if ("quantiles" %in% statistics) quantiles else NULL
quants <- if (length(quantiles) > 1) paste(100*quantiles, "%", sep="") else NULL
nquants <- length(quants)
stats <- c(c("mean", "sd", "IQR", "cv", "skewness", "kurtosis")[c("mean", "sd", "IQR", "cv", "skewness", "kurtosis") %in% statistics], quants)
nstats <- length(stats)
nvars <- length(variables)
result <- list()
if ((ngroups == 1) && (nvars == 1) && (length(statistics) == 1)){
if (statistics == "quantiles")
table <- quantile(data[,variables], probs=quantiles, na.rm=TRUE)
else {
table <- do.call(statistics, list(x=data[,variables], na.rm=TRUE, type=type))
names(table) <- statistics
}
NAs <- sum(is.na(data[,variables]))
n <- nrow(data) - NAs
result$type <- 1
}
else if ((ngroups > 1) && (nvars == 1) && (length(statistics) == 1)){
if (statistics == "quantiles"){
table <- matrix(unlist(tapply(data[, variables], groups,
quantile, probs=quantiles, na.rm=TRUE)), ngroups, nquants,
byrow=TRUE)
rownames(table) <- grps
colnames(table) <- quants
}
else table <- tapply(data[,variables], groups, statistics,
na.rm=TRUE, type=type)
NAs <- tapply(data[, variables], groups, function(x)
sum(is.na(x)))
n <- table(groups) - NAs
result$type <- 2
}
else if ((ngroups == 1) ){
X <- as.matrix(data[, variables])
table <- matrix(0, nvars, nstats)
rownames(table) <- if (length(variables) > 1) variables else ""
colnames(table) <- stats
if ("mean" %in% stats) table[,"mean"] <- colMeans(X, na.rm=TRUE)
if ("sd" %in% stats) table[,"sd"] <- sd(X)
if ("IQR" %in% stats) table[, "IQR"] <- IQR(X)
if ("cv" %in% stats) table[,"cv"] <- cv(X)
if ("skewness" %in% statistics) table[, "skewness"] <- skewness(X, type=type)
if ("kurtosis" %in% statistics) table[, "kurtosis"] <- kurtosis(X, type=type)
if ("quantiles" %in% statistics){
table[,quants] <- t(apply(data[, variables, drop=FALSE], 2, quantile,
probs=quantiles, na.rm=TRUE))
}
NAs <- colSums(is.na(data[, variables, drop=FALSE]))
n <- nrow(data) - NAs
result$type <- 3
}
else {
table <- array(0, c(ngroups, nstats, nvars),
dimnames=list(Group=grps, Statistic=stats, Variable=variables))
NAs <- matrix(0, nvars, ngroups)
rownames(NAs) <- variables
colnames(NAs) <- grps
for (variable in variables){
if ("mean" %in% stats)
table[, "mean", variable] <- tapply(data[, variable],
groups, mean, na.rm=TRUE)
if ("sd" %in% stats)
table[, "sd", variable] <- tapply(data[, variable],
groups, sd, na.rm=TRUE)
if ("IQR" %in% stats)
table[, "IQR", variable] <- tapply(data[, variable],
groups, IQR, na.rm=TRUE)
if ("cv" %in% stats)
table[, "cv", variable] <- tapply(data[, variable],
groups, cv)
if ("skewness" %in% stats)
table[, "skewness", variable] <- tapply(data[, variable],
groups, skewness, type=type)
if ("kurtosis" %in% stats)
table[, "kurtosis", variable] <- tapply(data[, variable],
groups, kurtosis, type=type)
if ("quantiles" %in% statistics) {
res <- matrix(unlist(tapply(data[, variable], groups,
quantile, probs=quantiles, na.rm=TRUE)), ngroups, nquants,
byrow=TRUE)
table[, quants, variable] <- res
}
NAs[variable,] <- tapply(data[, variable], groups, function(x)
sum(is.na(x)))
}
if (nstats == 1) table <- table[,1,]
if (nvars == 1) table <- table[,,1]
n <- table(groups)
n <- matrix(n, nrow=nrow(NAs), ncol=ncol(NAs), byrow=TRUE)
n <- n - NAs
result$type <- 4
}
result$table <- table
result$statistics <- statistics
result$n <- n
if (any(NAs > 0)) result$NAs <- NAs
class(result) <- "numSummary"
result
}
print.numSummary <- function(x, ...){
NAs <- x$NAs
table <- x$table
n <- x$n
statistics <- x$statistics
switch(x$type,
"1" = {
if (!is.null(NAs)) {
table <- c(table, n, NAs)
names(table)[length(table) - 1:0] <- c("n", "NA")
}
print(table)
},
"2" = {
if (statistics == "quantiles") {
table <- cbind(table, n)
colnames(table)[ncol(table)] <- "n"
if (!is.null(NAs)) {
table <- cbind(table, NAs)
colnames(table)[ncol(table)] <- "NA"
}
}
else {
table <- rbind(table, n)
rownames(table)[c(1, nrow(table))] <- c(statistics, "n")
if (!is.null(NAs)) {
table <- rbind(table, NAs)
rownames(table)[nrow(table)] <- "NA"
}
table <- t(table)
}
print(table)
},
"3" = {
table <- cbind(table, n)
colnames(table)[ncol(table)] <- "n"
if (!is.null(NAs)) {
table <- cbind(table, NAs)
colnames(table)[ncol(table)] <- "NA"
}
print(table)
},
"4" = {
if (length(dim(table)) == 2){
n <- t(n)
nms <- colnames(n)
colnames(n) <- paste(nms, ":n", sep="")
table <- cbind(table, n)
if (!is.null(NAs)) {
NAs <- t(NAs)
nms <- colnames(NAs)
colnames(NAs) <- paste(nms, ":NA", sep="")
table <- cbind(table, NAs)
}
print(table)
}
else {
table <- abind(table, t(n), along=2)
dimnames(table)[[2]][dim(table)[2]] <- "n"
if (!is.null(NAs)) {
table <- abind(table, t(NAs), along=2)
dimnames(table)[[2]][dim(table)[2]] <- "NA"
}
nms <- dimnames(table)[[3]]
for (name in nms){
cat("\nVariable:", name, "\n")
print(table[,,name])
}
}
}
)
invisible(x)
}
stepwise <- function(mod,
direction=c("backward/forward", "forward/backward", "backward", "forward"),
criterion=c("BIC", "AIC"), ...){
if (!require(MASS)) stop("MASS package not available")
criterion <- match.arg(criterion)
cat("\nDirection: ", direction)
cat("\nCriterion: ", criterion, "\n\n")
k <- if (criterion == "BIC") log(nrow(model.matrix(mod))) else 2
rhs <- paste(c("~", deparse(formula(mod)[[3]])), collapse="")
rhs <- gsub(" ", "", rhs)
if (direction == "forward" || direction == "forward/backward")
mod <- update(mod, . ~ 1)
if (direction == "backward/forward" || direction == "forward/backward") direction <- "both"
lower <- ~ 1
upper <- eval(parse(text=rhs))
stepAIC(mod, scope=list(lower=lower, upper=upper), direction=direction, k=k, ...)
}
# wrapper function for histograms
Hist <- function(x, groups, scale=c("frequency", "percent", "density"), xlab=deparse(substitute(x)),
ylab=scale, main="", breaks="Sturges", ...){
xlab # evaluate
scale <- match.arg(scale)
ylab
if (!missing(groups)){
levels <- levels(groups)
hists <- lapply(levels, function(level) hist(x[groups == level], plot=FALSE, breaks=breaks))
range.x <- range(unlist(lapply(hists, function(hist) hist$breaks)))
n.breaks <- max(sapply(hists, function(hist) length(hist$breaks)))
breaks. <- seq(range.x[1], range.x[2], length=n.breaks)
hists <- lapply(levels, function(level) hist(x[groups == level], plot=FALSE, breaks=breaks.))
ylim <- if (scale == "frequency"){
max(sapply(hists, function(hist) max(hist$counts)))
}
else if (scale == "density"){
max(sapply(hists, function(hist) max(hist$density)))
}
else {
max.counts <- sapply(hists, function(hist) max(hist$counts))
tot.counts <- sapply(hists, function(hist) sum(hist$counts))
ylims <- tot.counts*(max(max.counts/tot.counts))
names(ylims) <- levels
ylims
}
save.par <- par(mfrow=n2mfrow(length(levels)), oma = c(0, 0, if (main != "") 1.5 else 0, 0))
on.exit(par(save.par))
for (level in levels){
if (scale != "percent") Hist(x[groups == level], scale=scale, xlab=xlab, ylab=ylab,
main=paste(deparse(substitute(groups)), "=", level), breaks=breaks., ylim=c(0, ylim), ...)
else Hist(x[groups == level], scale=scale, xlab=xlab, ylab=ylab,
main=paste(deparse(substitute(groups)), "=", level), breaks=breaks., ylim=c(0, ylim[level]), ...)
}
if (main != "") mtext(side = 3, outer = TRUE, main, cex = 1.2)
return(invisible(NULL))
}
x <- na.omit(x)
if (scale == "frequency") hist(x, xlab=xlab, ylab=ylab, main=main, breaks=breaks, ...)
else if (scale == "density") hist(x, freq=FALSE, xlab=xlab, ylab=ylab, main=main, breaks=breaks, ...)
else {
n <- length(x)
hist(x, axes=FALSE, xlab=xlab, ylab=ylab, main=main, breaks=breaks, ...)
axis(1)
max <- ceiling(10*par("usr")[4]/n)
at <- if (max <= 3) (0:(2*max))/20
else (0:max)/10
axis(2, at=at*n, labels=at*100)
}
box()
abline(h=0)
invisible(NULL)
}
plotMeans <- function(response, factor1, factor2, error.bars = c("se", "sd", "conf.int", "none"),
level=0.95, xlab=deparse(substitute(factor1)), ylab=paste("mean of", deparse(substitute(response))),
legend.lab=deparse(substitute(factor2)), main="Plot of Means",
pch=1:n.levs.2, lty=1:n.levs.2, col=palette(), ...){
if (!is.numeric(response)) stop(gettextRcmdr("Argument response must be numeric."))
xlab # force evaluation
ylab
legend.lab
error.bars <- match.arg(error.bars)
if (missing(factor2)){
if (!is.factor(factor1)) stop(gettextRcmdr("Argument factor1 must be a factor."))
valid <- complete.cases(factor1, response)
factor1 <- factor1[valid]
response <- response[valid]
means <- tapply(response, factor1, mean)
sds <- tapply(response, factor1, sd)
ns <- tapply(response, factor1, length)
if (error.bars == "se") sds <- sds/sqrt(ns)
if (error.bars == "conf.int") sds <- qt((1 - level)/2, df=ns - 1, lower.tail=FALSE) * sds/sqrt(ns)
sds[is.na(sds)] <- 0
yrange <- if (error.bars != "none") c( min(means - sds, na.rm=TRUE), max(means + sds, na.rm=TRUE)) else range(means, na.rm=TRUE)
levs <- levels(factor1)
n.levs <- length(levs)
plot(c(1, n.levs), yrange, type="n", xlab=xlab, ylab=ylab, axes=FALSE, main=main, ...)
points(1:n.levs, means, type="b", pch=16, cex=2)
box()
axis(2)
axis(1, at=1:n.levs, labels=levs)
if (error.bars != "none") arrows(1:n.levs, means - sds, 1:n.levs, means + sds,
angle=90, lty=2, code=3, length=0.125)
}
else {
if (!(is.factor(factor1) | is.factor(factor2))) stop(gettextRcmdr("Arguments factor1 and factor2 must be factors."))
valid <- complete.cases(factor1, factor2, response)
factor1 <- factor1[valid]
factor2 <- factor2[valid]
response <- response[valid]
means <- tapply(response, list(factor1, factor2), mean)
sds <- tapply(response, list(factor1, factor2), sd)
ns <- tapply(response, list(factor1, factor2), length)
if (error.bars == "se") sds <- sds/sqrt(ns)
if (error.bars == "conf.int") sds <- qt((1 - level)/2, df=ns - 1, lower.tail=FALSE) * sds/sqrt(ns)
sds[is.na(sds)] <- 0
yrange <- if (error.bars != "none") c( min(means - sds, na.rm=TRUE), max(means + sds, na.rm=TRUE)) else range(means, na.rm=TRUE)
levs.1 <- levels(factor1)
levs.2 <- levels(factor2)
n.levs.1 <- length(levs.1)
n.levs.2 <- length(levs.2)
if (length(pch) == 1) pch <- rep(pch, n.levs.2)
if (length(col) == 1) col <- rep(col, n.levs.2)
if (length(lty) == 1) lty <- rep(lty, n.levs.2)
if (n.levs.2 > length(col)) stop(sprintf(gettextRcmdr("Number of groups for factor2, %d, exceeds number of distinct colours, %d."), n.levs.2, length(col)))
plot(c(1, n.levs.1 * 1.4), yrange, type="n", xlab=xlab, ylab=ylab, axes=FALSE, main=main, ...)
box()
axis(2)
axis(1, at=1:n.levs.1, labels=levs.1)
for (i in 1:n.levs.2){
points(1:n.levs.1, means[, i], type="b", pch=pch[i], cex=2, col=col[i], lty=lty[i])
if (error.bars != "none") arrows(1:n.levs.1, means[, i] - sds[, i],
1:n.levs.1, means[, i] + sds[, i], angle=90, code=3, col=col[i], lty=lty[i], length=0.125)
}
x.posn <- n.levs.1 * 1.1
y.posn <- sum(c(0.1, 0.9) * par("usr")[c(3,4)])
text(x.posn, y.posn, legend.lab, adj=c(0, -.5))
legend(x.posn, y.posn, levs.2, pch=pch, col=col, lty=lty)
}
invisible(NULL)
}
lineplot <- function(x, ..., legend){
xlab <- deparse(substitute(x))
y <- cbind(...)
m <- ncol(y)
legend <- if (missing(legend)) m > 1
if (legend && m > 1) {
mar <- par("mar")
top <- 3.5 + m
old.mar <- par(mar=c(mar[1:2], top, mar[4]))
on.exit(par(old.mar))
}
if (m > 1) matplot(x, y, type="b", lty=1, xlab=xlab, ylab="")
else plot(x, y, type="b", pch=16, xlab=xlab, ylab=colnames(y))
if (legend && ncol(y) > 1){
xpd <- par(xpd=TRUE)
on.exit(par(xpd), add=TRUE)
ncols <- length(palette())
cols <- rep(1:ncols, 1 + m %/% ncols)[1:m]
usr <- par("usr")
legend(usr[1], usr[4] + 1.2*top*strheight("x"),
legend=colnames(y), col=cols, lty=1, pch=as.character(1:m))
}
return(invisible(NULL))
}
indexplot <- function(x, labels=seq_along(x), id.method="y", type="h", id.n=0, ylab, ...){
if (missing(ylab)) ylab <- deparse(substitute(x))
plot(x, type=type, ylab=ylab, xlab="Observation Index", ...)
if (par("usr")[3] <= 0) abline(h=0, col='gray')
ids <- showLabels(seq_along(x), x, labels=labels, id.method=id.method, id.n=id.n)
if (is.null(ids)) return(invisible(NULL)) else return(ids)
}
bin.var <- function (x, bins=4, method=c("intervals", "proportions", "natural"), labels=FALSE){
method <- match.arg(method)
# Author: Dan Putler (revision by J. Fox, 5 Dec 04 & 5 Mar 13)
if(length(x) < bins) {
stop(gettextRcmdr("The number of bins exceeds the number of data values"))
}
x <- if(method == "intervals") cut(x, bins, labels=labels)
else if (method == "proportions") cut(x, quantile(x, probs=seq(0,1,1/bins), na.rm=TRUE),
include.lowest = TRUE, labels=labels)
else {
xx <- na.omit(x)
breaks <- c(-Inf, tapply(xx, KMeans(xx, bins)$cluster, max))
cut(x, breaks, labels=labels)
}
as.factor(x)
}
# the following function is adapted from a suggestion by Robert Muenchen
rcorr.adjust <- function(x, type=c("pearson", "spearman"),
use=c("complete.obs", "pairwise.complete.obs")){
require("Hmisc")
opt <- options(scipen=5)
on.exit(options(opt))
type <- match.arg(type)
use <- match.arg(use)
x <- if (use == "complete.obs") as.matrix(na.omit(x)) else as.matrix(x)
R <- rcorr(x, type=type)
P <- P.unadj <- R$P
p <- P[lower.tri(P)]
adj.p <- p.adjust(p, method="holm")
P[lower.tri(P)] <- adj.p
P[upper.tri(P)] <- 0
P <- P + t(P)
P <- ifelse(P < 1e-04, 0, P)
P <- format(round(P, 4))
diag(P) <- ""
P[grep("0.0000", P)] <- "<.0001"
P.unadj <- ifelse(P.unadj < 1e-04, 0, P.unadj)
P.unadj <- format(round(P.unadj, 4))
diag(P.unadj) <- ""
P.unadj[grep("0.0000", P.unadj)] <- "<.0001"
result <- list(R=R, P=P, P.unadj=P.unadj, type=type)
class(result) <- "rcorr.adjust"
result
}
print.rcorr.adjust <- function(x, ...){
cat("\n", if (x$type == "pearson") "Pearson" else "Spearman", "correlations:\n")
print(round(x$R$r, 4))
cat("\n Number of observations: ")
n <- x$R$n
if (all(n[1] == n)) cat(n[1], "\n")
else{
cat("\n")
print(n)
}
cat("\n Pairwise two-sided p-values:\n")
print(x$P.unadj, quote=FALSE)
cat("\n Adjusted p-values (Holm's method)\n")
print(x$P, quote=FALSE)
}
# Pager
# this is slightly modified from tkpager to use the Rcmdr monospaced font
# and a white background
RcmdrPager <- function (file, header, title, delete.file)
{
title <- paste(title, header)
for (i in seq(along = file)) {
zfile <- file[[i]]
tt <- tktoplevel()
if (WindowsP()) tkwm.iconbitmap(tt, system.file("etc", "R-logo.ico", package="Rcmdr"))
tkwm.title(tt, if (length(title))
title[(i - 1)%%length(title) + 1]
else "")
txt <- tktext(tt, bg = "white", font = getRcmdr("logFont"))
scr <- ttkscrollbar(tt, command = function(...) tkyview(txt,
...))
tkconfigure(txt, yscrollcommand = function(...) tkset(scr,
...))
tkpack(txt, side = "left", fill = "both", expand = TRUE)
tkpack(scr, side = "right", fill = "y")
chn <- tcl("open", zfile)
tkinsert(txt, "end", gsub("_\b", "", tclvalue(tcl("read",
chn))))
tcl("close", chn)
tkconfigure(txt, state = "disabled")
tkmark.set(txt, "insert", "0.0")
tkfocus(txt)
if (delete.file)
tcl("file", "delete", zfile)
}
}
# help functions
helpCommander <- function() {
PDF <- file.access(paste(file.path(path.package(package="Rcmdr")[1], "doc"),
"/", gettextRcmdr("Commander"), ".pdf", sep=""), mode=4)
if (PDF == 0){
browseURL(paste(file.path(path.package(package="Rcmdr")[1], "doc"),
"/", gettextRcmdr("Commander"), ".pdf", sep=""))
}
else if (as.numeric(R.Version()$major) >= 2) print(help(gettextRcmdr("Commander")))
else help(gettextRcmdr("Commander"))
}
helpAboutCommander <- function() {
if (as.numeric(R.Version()$major) >= 2) print(help("Rcmdr"))
else help("Rcmdr")
}
browseManual <- function() {
browseURL(paste(file.path(path.package(package="Rcmdr")[1], "doc"),
"/", gettextRcmdr("Getting-Started-with-the-Rcmdr"), ".pdf", sep=""))
}
browseEnglishManual <- function() {
browseURL(paste(file.path(path.package(package="Rcmdr")[1], "doc"),
"/Getting-Started-with-the-Rcmdr.pdf", sep=""))
}
manualTranslationP <- function(){
gettextRcmdr("Getting-Started-with-the-Rcmdr") != "Getting-Started-with-the-Rcmdr"
}
browseRcmdrWebsite <- function() browseURL("http://socserv.socsci.mcmaster.ca/jfox/Misc/Rcmdr/")
browseRWebsite <- function() browseURL("http://www.r-project.org/")
browseRMarkdown <- function() browseURL("http://www.rstudio.com/ide/docs/authoring/using_markdown")
# functions for building dialog boxes
# the following function is slightly modified, with permission, from Thomas Lumley,
# "Programmer's Niche: Macros in R," R-News, Sept. 2001, Vol. 1, No. 3, pp.11-13.
defmacro <- function(..., expr){
expr <- substitute(expr)
len <- length(expr)
expr[3:(len+1)] <- expr[2:len]
## delete "macro" variables starting in ..
expr[[2]] <- quote(on.exit(remove(list=objects(pattern="^\\.\\.", all.names=TRUE))))
a <- substitute(list(...))[-1]
## process the argument list
nn <- names(a)
if (is.null(nn)) nn <- rep("", length(a))
for (i in seq(length.out=length(a))){
if (nn[i] == "") {
nn[i] <- paste(a[[i]])
msg <- paste(a[[i]], gettext("not supplied", domain="R-Rcmdr"))
a[[i]] <- substitute(stop(foo), list(foo = msg))
}
}
names(a) <- nn
a <- as.list(a)
ff <- eval(substitute(
function(){
tmp <- substitute(body)
eval(tmp, parent.frame())
},
list(body = expr)))
## add the argument list
formals(ff) <- a
## create a fake source attribute
mm <- match.call()
mm$expr <- NULL
mm[[1]] <- as.name("macro")
expr[[2]] <- NULL # get "local" variable removal out of source
attr(ff, "source") <- c(deparse(mm), deparse(expr))
## return the macro
ff
}
OKCancelHelp <- defmacro(window=top, helpSubject=NULL, model=FALSE, reset=NULL, apply=NULL,
expr={
memory <- getRcmdr("retain.selections")
button.strings <- c("OK", "Cancel",
if (!is.null(helpSubject)) "Help",
if (!is.null(reset) && memory) "Reset",
if (!is.null(apply)) "Apply")
width <- max(nchar(gettextRcmdr(button.strings)))
if (WindowsP()) width <- width + 2
buttonsFrame <- tkframe(window)
leftButtonsBox <- tkframe(buttonsFrame)
rightButtonsBox <- tkframe(buttonsFrame)
OnOK <- function(){
putRcmdr("restoreTab", FALSE)
if (getRcmdr("use.markdown")) {
putRcmdr("startNewCommandBlock", FALSE)
beginRmdBlock()
}
if (getRcmdr("use.knitr")) {
putRcmdr("startNewKnitrCommandBlock", FALSE)
beginRnwBlock()
}
setBusyCursor()
on.exit(setIdleCursor())
onOK()
if (getRcmdr("use.markdown")){
removeNullRmdBlocks()
putRcmdr("startNewCommandBlock", TRUE)
if (getRcmdr("rmd.generated")) {
endRmdBlock()
putRcmdr("rmd.generated", FALSE)
}
removeNullRmdBlocks()
}
if (getRcmdr("use.knitr")){
removeNullRnwBlocks()
putRcmdr("startNewKnitrCommandBlock", TRUE)
if (getRcmdr("rnw.generated")) {
endRnwBlock()
putRcmdr("rnw.generated", FALSE)
}
removeNullRnwBlocks()
}
}
OKbutton <- buttonRcmdr(rightButtonsBox, text=gettextRcmdr("OK"), foreground="darkgreen", width=width, command=OnOK, default="active",
image="::image::okIcon", compound="left")
onCancel <- function() {
if (exists(".exit")){
result <- .exit()
if (result == "abort") return()
}
putRcmdr("restoreTab", FALSE)
if (model) putRcmdr("modelNumber", getRcmdr("modelNumber") - 1)
if (GrabFocus()) tkgrab.release(window)
tkdestroy(window)
tkfocus(CommanderWindow())
}
cancelButton <- buttonRcmdr(rightButtonsBox, text=gettextRcmdr("Cancel"), foreground="red", width=width, command=onCancel, # borderwidth=3,
image="::image::cancelIcon", compound="left")
if (!is.null(helpSubject)){
onHelp <- function() {
if (GrabFocus() && (!WindowsP())) tkgrab.release(window)
if (as.numeric(R.Version()$major) >= 2) print(help(helpSubject))
else help(helpSubject)
}
helpButton <- buttonRcmdr(leftButtonsBox, text=gettextRcmdr("Help"), width=width, command=onHelp, # borderwidth=3,
image="::image::helpIcon", compound="left")
}
if (!is.null(reset) && memory){
onReset <- function(){
ID <- window$ID
putRcmdr("cancelDialogReopen", TRUE)
putRcmdr("open.dialog.here", as.character(.Tcl(paste("winfo geometry", ID))))
if (model) putRcmdr("modelNumber", getRcmdr("modelNumber") - 1)
putDialog(reset, NULL)
putDialog(reset, NULL, resettable=FALSE)
closeDialog()
eval(parse(text=paste(reset, "()")))
putRcmdr("open.dialog.here", NULL)
putRcmdr("restoreTab", FALSE)
}
resetButton <- buttonRcmdr(leftButtonsBox, text=gettextRcmdr("Reset"), width=width, command=onReset,
image="::image::resetIcon", compound="left")
}
if (!is.null(apply)){
onApply <- function(){
putRcmdr("restoreTab", TRUE)
putRcmdr("cancelDialogReopen", FALSE)
ID <- window$ID
putRcmdr("open.dialog.here", as.character(.Tcl(paste("winfo geometry", ID))))
if (getRcmdr("use.markdown")) {
putRcmdr("startNewCommandBlock", FALSE)
beginRmdBlock()
}
if (getRcmdr("use.knitr")) {
putRcmdr("startNewKnitrCommandBlock", FALSE)
beginRnwBlock()
}
setBusyCursor()
on.exit(setIdleCursor())
onOK()
if (getRcmdr("use.markdown")){
removeNullRmdBlocks()
putRcmdr("startNewCommandBlock", TRUE)
if (getRcmdr("rmd.generated")) {
endRmdBlock()
putRcmdr("rmd.generated", FALSE)
}
removeNullRmdBlocks()
}
if (getRcmdr("use.knitr")){
removeNullRnwBlocks()
putRcmdr("startNewKnitrCommandBlock", TRUE)
if (getRcmdr("rnw.generated")) {
endRnwBlock()
putRcmdr("rnw.generated", FALSE)
}
removeNullRnwBlocks()
}
if (getRcmdr("cancelDialogReopen")){
putRcmdr("cancelDialogReopen", FALSE)
}
else{
eval(parse(text=paste(apply, "()")))
putRcmdr("open.dialog.here", NULL)
}
}
applyButton <- buttonRcmdr(rightButtonsBox, text=gettextRcmdr("Apply"), foreground="yellow", width=width, command=onApply,
image="::image::applyIcon", compound="left")
}
if(!WindowsP()) {
if (!is.null(apply)){
tkgrid(applyButton, cancelButton, OKbutton, sticky="w")
tkgrid.configure(OKbutton, padx=c(6, 0))
}
else{
tkgrid(cancelButton, OKbutton, sticky="w")
}
tkgrid.configure(cancelButton, padx=c(6, 6))
}
else {
if (!is.null(apply)){
tkgrid(OKbutton, cancelButton, applyButton, sticky="w")
tkgrid.configure(applyButton, padx=c(6, 0))
}
else{
tkgrid(OKbutton, cancelButton, sticky="w")
}
tkgrid.configure(OKbutton, padx=c(6, 6))
}
if (!is.null(reset) && memory) {
if (! is.null(helpSubject)){
tkgrid (helpButton, resetButton, pady=6)
}
else tkgrid (resetButton, pady=6)
if (!WindowsP()) tkgrid.configure(resetButton, padx=c(0, 6))
}
else if (! is.null(helpSubject)){
tkgrid(helpButton, pady=6)
}
tkgrid(leftButtonsBox, rightButtonsBox, pady=6, sticky="ew")
if (!is.null(helpSubject)) tkgrid.configure(helpButton, padx=c(0, 18))
else if (!is.null(reset) && memory) tkgrid.configure(resetButton, padx=c(0, 18))
tkgrid.columnconfigure(buttonsFrame, 0, weight=1)
tkgrid.columnconfigure(buttonsFrame, 1, weight=1)
tkgrid.configure(leftButtonsBox, sticky="w")
tkgrid.configure(rightButtonsBox, sticky="e")
})
subOKCancelHelp <- defmacro(window=subdialog, helpSubject=NULL,
expr={
button.strings <- c("OK", "Cancel",
if (!is.null(helpSubject)) "Help")
width <- max(nchar(gettextRcmdr(button.strings)))
if (WindowsP()) width <- width + 2
subButtonsFrame <- tkframe(window)
subLeftButtonsBox <- tkframe(subButtonsFrame)
subRightButtonsBox <- tkframe(subButtonsFrame)
subOKbutton <- buttonRcmdr(subRightButtonsBox, text=gettextRcmdr("OK"), foreground="darkgreen", width=width, command=onOKsub, default="active",
image="::image::okIcon", compound="left")
onCancelSub <- function() {
if (GrabFocus()) tkgrab.release(window)
tkdestroy(window)
tkfocus(CommanderWindow())
}
subCancelButton <- buttonRcmdr(subRightButtonsBox, text=gettextRcmdr("Cancel"), foreground="red", width=width, command=onCancelSub,
image="::image::cancelIcon", compound="left") # borderwidth=3,
if (!is.null(helpSubject)){
onHelpSub <- function(){
if (GrabFocus() && (!WindowsP())) tkgrab.release(window)
if (as.numeric(R.Version()$major) >= 2) print(help(helpSubject))
else help(helpSubject)
}
subHelpButton <- buttonRcmdr(subLeftButtonsBox, text=gettextRcmdr("Help"), width=width, command=onHelpSub,
image="::image::helpIcon", compound="left")
}
if(!WindowsP()) {
tkgrid(subCancelButton, subOKbutton, sticky="w")
tkgrid.configure(subOKbutton, padx=c(6, 0))
}
else {
tkgrid(subOKbutton, subCancelButton, sticky="w")
tkgrid.configure(subOKbutton, padx=c(0, 6))
}
if (! is.null(helpSubject)){
tkgrid(subHelpButton, pady=6, padx=c(0, 18))
}
tkgrid(subLeftButtonsBox, subRightButtonsBox, pady=6, sticky="ew")
tkgrid.columnconfigure(subButtonsFrame, 0, weight=1)
tkgrid.columnconfigure(subButtonsFrame, 1, weight=1)
tkgrid.configure(subLeftButtonsBox, sticky="w")
tkgrid.configure(subRightButtonsBox, sticky="e")
})
checkActiveDataSet <- function(){
if (activeDataSet() == FALSE) {
tkfocus(CommanderWindow())
FALSE
}
else TRUE
}
checkActiveModel <- function(){
if (activeModel() == FALSE) {
tkfocus(CommanderWindow())
FALSE
}
else TRUE
}
checkFactors <- function(n=1){
if (length(Factors()) < n){
if (n > 1)
Message(message=sprintf(gettextRcmdr("There fewer than %d factors in the active data set."), n),
type="error")
else Message(message=gettextRcmdr("There are no factors in the active data set."),
type="error")
tkfocus(CommanderWindow())
FALSE
}
else TRUE
}
checkTwoLevelFactors <- function(n=1){
if (length(TwoLevelFactors()) < n){
if (n > 1)
Message(message=sprintf(gettextRcmdr("There fewer than %d two-level factors in the active data set."), n),
type="error")
else Message(message=gettextRcmdr("There are no two-level factors in the active data set."),
type="error")
tkfocus(CommanderWindow())
FALSE
}
else TRUE
}
checkNumeric <- function(n=1){
if (length(Numeric()) < n){
if (n > 1)
Message(message=sprintf(gettextRcmdr("There fewer than %d numeric variables in the active data set."), n),
type="error")
else Message(message=gettextRcmdr("There are no numeric variables in the active data set."),
type="error")
tkfocus(CommanderWindow())
FALSE
}
else TRUE
}
checkVariables <- function(n=1){
if (length(Variables()) < n){
if (n > 1)
Message(message=sprintf(gettextRcmdr("There fewer than %d variables in the active data set."), n),
type="error")
else Message(message=gettextRcmdr("There are no variables in the active data set."),
type="error")
tkfocus(CommanderWindow())
FALSE
}
else TRUE
}
commanderPosition <- function (){
ID <- CommanderWindow()$ID
as.numeric(c(tclvalue(.Tcl(paste("winfo rootx", ID))),
tclvalue(.Tcl(paste("winfo rooty", ID)))))
}
initializeDialog <- defmacro(window=top, title="", offset=10, preventCrisp,
use.tabs=FALSE, notebook=notebook, tabs=c("dataTab", "optionsTab"),
expr={
if (getRcmdr("crisp.dialogs")) tclServiceMode(on=FALSE)
window <- tktoplevel(borderwidth=10)
if (use.tabs){
notebook <- ttknotebook(window)
for (tab in tabs) assign(tab, tkframe(window))
}
tkwm.title(window, title)
location <- getRcmdr("open.dialog.here")
position <- if (!is.null(location)) location
else {
pos <- offset + commanderPosition()
if (any(pos < 0)) "-50+50"
else paste("+", paste(pos, collapse="+"), sep="")
}
tkwm.geometry(window, position)
tkwm.transient(window, CommanderWindow())
}
)
closeDialog <- defmacro(window=top, release=TRUE,
expr={
if (release && GrabFocus()) tkgrab.release(window)
tkdestroy(window)
}
)
dialogSuffix <- defmacro(window=top, onOK=onOK, onCancel=onCancel, rows, columns, focus=top,
bindReturn=TRUE, preventGrabFocus=FALSE, preventDoubleClick=FALSE,
preventCrisp,
use.tabs=FALSE, notebook=notebook, tabs=c("dataTab", "optionsTab"), tab.names=c("Data", "Options"),
grid.buttons=FALSE, resizable=FALSE,
expr={
if (use.tabs){
for (i in 1:length(tabs)){
tkadd(notebook, get(tabs[i]), text=gettextRcmdr(tab.names[i]), padding=6, sticky="nsew")
}
tkgrid(notebook, sticky="nsew")
}
if (grid.buttons) tkgrid(buttonsFrame, sticky = "ew")
if (use.tabs && exists("dialog.values") && !is.null(dialog.values$initial.tab) && getRcmdr("restoreTab"))
tkselect(notebook, dialog.values$initial.tab)
.Tcl("update idletasks")
tkwm.resizable(window, as.numeric(resizable), as.numeric(resizable))
if (bindReturn) tkbind(window, "<Return>", onOK)
tkbind(window, "<Escape>", onCancel)
if (getRcmdr("double.click") && (!preventDoubleClick)) tkbind(window, "<Double-ButtonPress-1>", onOK)
tkwm.deiconify(window)
# focus grabs appear to cause problems for some dialogs
if (GrabFocus() && (!preventGrabFocus)) tkgrab.set(window)
tkfocus(focus)
tkwait.window(window)
if (getRcmdr("crisp.dialogs")) tclServiceMode(on=TRUE)
}
)
variableListBox <- function(parentWindow, variableList=Variables(), bg="white",
selectmode="single", export="FALSE", initialSelection=NULL, listHeight=getRcmdr("variable.list.height"), title){
if (selectmode == "multiple") selectmode <- getRcmdr("multiple.select.mode")
if (length(variableList) == 1 && is.null(initialSelection)) initialSelection <- 0
frame <- tkframe(parentWindow)
minmax <- getRcmdr("variable.list.width")
listbox <- tklistbox(frame, height=min(listHeight, length(variableList)),
selectmode=selectmode, background=bg, exportselection=export,
width=min(max(minmax[1], nchar(variableList)), minmax[2]))
scrollbar <- ttkscrollbar(frame, command=function(...) tkyview(listbox, ...))
tkconfigure(listbox, yscrollcommand=function(...) tkset(scrollbar, ...))
for (var in variableList) tkinsert(listbox, "end", var)
if (is.numeric(initialSelection)) for (sel in initialSelection) tkselection.set(listbox, sel)
firstChar <- tolower(substr(variableList, 1, 1))
len <- length(variableList)
onLetter <- function(letter){
letter <- tolower(letter)
current <- 1 + round(as.numeric(unlist(strsplit(tclvalue(tkyview(listbox) ), " "))[1])*len)
mat <- match(letter, firstChar[-(1:current)])
if (is.na(mat)) return()
tkyview.scroll(listbox, mat, "units")
}
onA <- function() onLetter("a")
onB <- function() onLetter("b")
onC <- function() onLetter("c")
onD <- function() onLetter("d")
onE <- function() onLetter("e")
onF <- function() onLetter("f")
onG <- function() onLetter("g")
onH <- function() onLetter("h")
onI <- function() onLetter("i")
onJ <- function() onLetter("j")
onK <- function() onLetter("k")
onL <- function() onLetter("l")
onM <- function() onLetter("m")
onN <- function() onLetter("n")
onO <- function() onLetter("o")
onP <- function() onLetter("p")
onQ <- function() onLetter("q")
onR <- function() onLetter("r")
onS <- function() onLetter("s")
onT <- function() onLetter("t")
onU <- function() onLetter("u")
onV <- function() onLetter("v")
onW <- function() onLetter("w")
onX <- function() onLetter("x")
onY <- function() onLetter("y")
onZ <- function() onLetter("z")
for (letter in c(letters, LETTERS)){
tkbind(listbox, paste("<", letter, ">", sep=""),
get(paste("on", toupper(letter), sep="")))
}
onClick <- function() tkfocus(listbox)
toggleSelection <- function(){
active <- tclvalue(tkindex(listbox, "active"))
selected <- tclvalue(tkcurselection(listbox))
if (selected == active) tkselection.clear(listbox, "active") else tkselection.set(listbox, "active")
}
tkbind(listbox, "<ButtonPress-1>", onClick)
if (selectmode == "single") tkbind(listbox, "<Control-ButtonPress-1>", toggleSelection)
tkgrid(labelRcmdr(frame, text=title, fg=getRcmdr("title.color"), font="RcmdrTitleFont"), columnspan=2, sticky="w")
tkgrid(listbox, scrollbar, sticky="nw")
tkgrid.configure(scrollbar, sticky="wns")
tkgrid.configure(listbox, sticky="ewns")
result <- list(frame=frame, listbox=listbox, scrollbar=scrollbar,
selectmode=selectmode, varlist=variableList)
class(result) <- "listbox"
result
}
getSelection <- function(object) UseMethod("getSelection")
getSelection.listbox <- function(object){
object$varlist[as.numeric(tkcurselection(object$listbox)) + 1]
}
getFrame <- function(object) UseMethod("getFrame")
getFrame.listbox <- function(object){
object$frame
}
# This function modified based on code by Liviu Andronic (13 Dec 09) and on code by Milan Bouchet-Valat (29 Jun 12):
radioButtons <- defmacro(window=top, name, buttons, values=NULL, initialValue=..values[1], labels,
title="", title.color=getRcmdr("title.color"), right.buttons=FALSE, command=function(){},
expr={
..values <- if (is.null(values)) buttons else values
..frame <- paste(name, "Frame", sep="")
assign(..frame, tkframe(window))
..variable <- paste(name, "Variable", sep="")
assign(..variable, tclVar(initialValue))
if(title != ""){
tkgrid(labelRcmdr(eval(parse(text=..frame)), text=title, foreground=title.color, font="RcmdrTitleFont"), columnspan=2, sticky="w")
}
for (i in 1:length(buttons)) {
..button <- paste(buttons[i], "Button", sep="")
if (right.buttons) {
assign(..button, ttkradiobutton(eval(parse(text=..frame)), variable=eval(parse(text=..variable)),
value=..values[i], command=command))
tkgrid(labelRcmdr(eval(parse(text=..frame)), text=labels[i], justify="left"), eval(parse(text=..button)), sticky="w")
}
else{
assign(..button, ttkradiobutton(eval(parse(text=..frame)), variable=eval(parse(text=..variable)),
value=..values[i], text=labels[i], command=command))
tkgrid(eval(parse(text=..button)), sticky="w")
}
}
}
)
checkBoxes <- defmacro(window=top, frame, boxes, initialValues=NULL, labels, title=NULL, ttk=FALSE,
expr={
..initialValues <- if (is.null(initialValues)) rep("1", length(boxes)) else initialValues
assign(frame, if (ttk) ttklabelframe(window, text=title) else tkframe(window))
if (!is.null(title) && !ttk) tkgrid(labelRcmdr(eval(parse(text=frame)), text=title, fg=getRcmdr("title.color"), font="RcmdrTitleFont"), sticky="w")
..variables <- paste(boxes, "Variable", sep="")
for (i in 1:length(boxes)) {
assign(..variables[i], tclVar(..initialValues[i]))
..checkBox <- paste(boxes[i], "CheckBox", sep="")
assign(..checkBox,
ttkcheckbutton(eval(parse(text=frame)), variable=eval(parse(text=..variables[i])), text=labels[i]))
tkgrid(eval(parse(text=..checkBox)), sticky="w")
}
}
)
checkReplace <- function(name, type=gettextRcmdr("Variable")){
RcmdrTkmessageBox(message=sprintf(gettextRcmdr("%s %s already exists.\nOverwrite %s?"),
type, name, tolower(type)), icon="warning", type="yesno", default="no")
}
errorCondition <- defmacro(window=top, recall=NULL, message, model=FALSE,
expr={
putRcmdr("cancelDialogReopen", TRUE)
if (model) putRcmdr("modelNumber", getRcmdr("modelNumber") - 1)
if (!is.null(window)){
if (GrabFocus()) tkgrab.release(window)
tkdestroy(window)
}
Message(message=message, type="error")
if (!is.null(recall)) recall()
else tkfocus(CommanderWindow())
})
subsetBox <- defmacro(window=top, subset.expression=NULL, model=FALSE,
expr={
subsetVariable <- if (!is.null(subset.expression)) tclVar(gettextRcmdr(subset.expression))
else if (model){
if (currentModel && currentFields$subset != "")
tclVar(currentFields$subset) else tclVar(gettextRcmdr("<all valid cases>"))
}
else tclVar(gettextRcmdr("<all valid cases>"))
subsetFrame <- tkframe(window)
subsetEntry <- ttkentry(subsetFrame, width="20", textvariable=subsetVariable)
subsetScroll <- ttkscrollbar(subsetFrame, orient="horizontal",
command=function(...) tkxview(subsetEntry, ...))
tkconfigure(subsetEntry, xscrollcommand=function(...) tkset(subsetScroll, ...))
tkgrid(labelRcmdr(subsetFrame, text=gettextRcmdr("Subset expression"), fg=getRcmdr("title.color"), font="RcmdrTitleFont"), sticky="w")
tkgrid(subsetEntry, sticky="ew")
tkgrid(subsetScroll, sticky="ew")
tkgrid.columnconfigure(subsetFrame, 0, weight=1)
})
groupsBox <- defmacro(recall=NULL, label=gettextRcmdr("Plot by:"), initialLabel=gettextRcmdr("Plot by groups"),
errorText=gettextRcmdr("There are no factors in the active data set."),
variables=Factors(), plotLinesByGroup=FALSE, positionLegend=FALSE, plotLinesByGroupsText=gettextRcmdr("Plot lines by group"),
initialGroup=NULL, initialLinesByGroup=1, window=top,
expr={
env <- environment()
.groups <- if (is.null(initialGroup)) FALSE else initialGroup
.linesByGroup <- initialLinesByGroup == 1
.groupsLabel <- tclVar(if (!is.null(initialGroup)) initialLabel else paste(initialLabel, "...", sep=""))
.factors <- variables
onGroups <- function(){
if (length(.factors) == 0){
errorCondition(recall=recall, message=errorText)
return()
}
initializeDialog(subdialog, title=gettextRcmdr("Groups"))
groupsBox <- variableListBox(subdialog, .factors, title=gettextRcmdr("Groups variable (pick one)"),
initialSelection=varPosn(initialGroup, "factor"))
if (plotLinesByGroup){
linesByGroupFrame <- tkframe(subdialog)
linesByGroup <- tclVar(if(initialLinesByGroup == 1) "1" else "0")
linesCheckBox <- ttkcheckbutton(linesByGroupFrame, variable=linesByGroup)
tkgrid(labelRcmdr(linesByGroupFrame, text=plotLinesByGroupsText), linesCheckBox, sticky="w")
}
onOKsub <- function() {
groups <- getSelection(groupsBox)
if (length(groups) == 0){
assign(".groups", FALSE, envir=env)
tclvalue(.groupsLabel) <- paste(gettextRcmdr("Plot by groups"), "...", sep="")
tkconfigure(groupsButton, foreground="black")
if (GrabFocus()) tkgrab.release(subdialog)
tkdestroy(subdialog)
tkwm.deiconify(top)
if (GrabFocus()) tkgrab.set(top)
tkfocus(top)
tkwait.window(top)
return()
}
assign(".groups", groups, envir=env)
tclvalue(.groupsLabel) <- paste(label, groups)
tkconfigure(groupsButton, foreground=getRcmdr("title.color"))
tkconfigure(groupsButton, font="RcmdrTitleFont")
if (plotLinesByGroup) {
lines <- as.character("1" == tclvalue(linesByGroup))
assign(".linesByGroup", lines, envir=env)
}
if (GrabFocus()) tkgrab.release(subdialog)
tkdestroy(subdialog)
tkwm.deiconify(top)
if (GrabFocus()) tkgrab.set(top)
tkfocus(top)
tkwait.window(top)
}
subOKCancelHelp()
tkgrid(getFrame(groupsBox), sticky="nw")
if (plotLinesByGroup) tkgrid(linesByGroupFrame, sticky="w")
tkgrid(subButtonsFrame, sticky="ew")
if (positionLegend) tkgrid(labelRcmdr(subdialog, text=gettextRcmdr("Position legend with mouse click"), fg=getRcmdr("title.color"), font="RcmdrTitleFont"))
dialogSuffix(subdialog, onOK=onOKsub, focus=subdialog)
}
groupsFrame <- tkframe(window)
groupsButton <- tkbutton(groupsFrame, textvariable=.groupsLabel, command=onGroups)
if (!is.null(initialGroup)) tkconfigure(groupsButton, foreground=getRcmdr("title.color"), font="RcmdrTitleFont")
tkgrid(groupsButton, sticky="we")
tkgrid.columnconfigure(groupsFrame, 0, weight=1)
})
groupsLabel <- defmacro(frame=top, groupsBox=groupsBox, columnspan=1, initialText=NULL,
expr={
initial.label <- if (exists("dialog.values")) dialog.values$initial.label else NULL
if (is.null(initial.label)) {
group <- getSelection(groupsBox)
initial.label <- if (length(group) == 0) NULL
else {
levels <- eval(parse(text = paste("levels(", ActiveDataSet(),
"$", group, ")", sep = "")))
paste(levels[1], "-", levels[2])
}
}
groupsFrame <- tkframe(frame)
.groupsLabel <- if (!is.null(initialText)) initialText
else if (is.null(initial.label)) gettextRcmdr("<No groups selected>")
else initial.label
groupsLabel <- labelRcmdr(groupsFrame, text=.groupsLabel)
tkgrid(labelRcmdr(groupsFrame, text=gettextRcmdr("Difference: "), fg=getRcmdr("title.color"), font="RcmdrTitleFont"), groupsLabel, sticky="w")
tkgrid(groupsFrame, sticky="w", columnspan=columnspan)
onSelect <- function(){
group <- getSelection(groupsBox)
if (length(group) == 0) {
.groupsLabel <<- gettextRcmdr("<No groups selected>")
}
else {
levels <- eval(parse(text=paste("levels(", ActiveDataSet(), "$", group, ")", sep="")))
.groupsLabel <<- paste(levels[1], "-", levels[2])
}
tkconfigure(groupsLabel, text=.groupsLabel)
}
tkbind(groupsBox$listbox, "<ButtonRelease-1>", onSelect)
})
modelFormula <- defmacro(frame=top, hasLhs=TRUE, expr={
checkAddOperator <- function(rhs){
rhs.chars <- rev(strsplit(rhs, "")[[1]])
if (length(rhs.chars) < 1) return(FALSE)
check.char <- if ((rhs.chars[1] != " ") || (length(rhs.chars) == 1))
rhs.chars[1] else rhs.chars[2]
!is.element(check.char, c("+", "*", ":", "/", "-", "^", "(", "%"))
}
.variables <- Variables()
word <- paste("\\[", gettextRcmdr("factor"), "\\]", sep="")
variables <- paste(.variables,
ifelse(is.element(.variables, Factors()), paste("[", gettextRcmdr("factor"), "]", sep=""), ""))
xBox <- variableListBox(frame, variables, selectmode="multiple", title=gettextRcmdr("Variables (double-click to formula)"))
onDoubleClick <- if (!hasLhs){
function(){
var <- getSelection(xBox)
tkselection.clear(xBox$listbox, "0", "end")
if (length(grep(word, var)) == 1) var <- sub(word, "", var)
tkfocus(rhsEntry)
rhs <- tclvalue(rhsVariable)
rhs.chars <- rev(strsplit(rhs, "")[[1]])
check.char <- if (length(rhs.chars) > 0){
if ((rhs.chars[1] != " ") || (length(rhs.chars) == 1))
rhs.chars[1] else rhs.chars[2]
}
else ""
tclvalue(rhsVariable) <- if (rhs == "" ||
is.element(check.char, c("+", "*", ":", "/", "-", "^", "(", "%")))
paste(rhs, var, sep="")
else paste(rhs, "+", var)
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
}
else{
function(){
var <- getSelection(xBox)
which <- tkcurselection(xBox$listbox)
tkselection.clear(xBox$listbox, "0", "end")
if (length(grep(word, var)) == 1) var <- sub(word, "", var)
lhs <- tclvalue(lhsVariable)
if (lhs == "" || tclvalue(tkselection.present(lhsEntry)) == "1"){
tclvalue(lhsVariable) <- var
tkselection.clear(lhsEntry)
tkfocus(rhsEntry)
}
else {
tkfocus(rhsEntry)
rhs <- tclvalue(rhsVariable)
rhs.chars <- rev(strsplit(rhs, "")[[1]])
check.char <- if (length(rhs.chars) > 0){
if ((rhs.chars[1] != " ") || (length(rhs.chars) == 1))
rhs.chars[1] else rhs.chars[2]
}
else ""
tclvalue(rhsVariable) <- if (rhs == "" ||
is.element(check.char, c("+", "*", ":", "/", "-", "^", "(", "%")))
paste(rhs, var, sep="")
else paste(rhs, "+", var)
}
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
}
tkbind(xBox$listbox, "<Double-ButtonPress-1>", onDoubleClick)
onPlus <- function(){
rhs <- tclvalue(rhsVariable)
var <- getSelection(xBox)
tkselection.clear(xBox$listbox, "0", "end")
if ((check <- !checkAddOperator(rhs)) && length(var) == 0) return()
if (length(var) > 1){
if (length(grep(word, var)) > 0) var <- sub(word, "", var)
if (length(var) > 1) var <- paste(var, collapse=" + ")
}
tclvalue(rhsVariable) <- paste(rhs, if (!check) " + ", var, sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onTimes <- function(){
rhs <- tclvalue(rhsVariable)
var <- getSelection(xBox)
tkselection.clear(xBox$listbox, "0", "end")
if ((check <- !checkAddOperator(rhs)) && length(var) == 0) return()
if (length(var) > 1){
if (length(grep(word, var)) > 0) var <- sub(word, "", var)
var <- trim.blanks(var)
if (length(var) > 1) var <- paste(var, collapse="*")
tclvalue(rhsVariable) <- paste(rhs, if (!check) " + ", var, sep="")
}
else tclvalue(rhsVariable) <- paste(rhs, if (!check) "*", sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onColon <- function(){
rhs <- tclvalue(rhsVariable)
var <- getSelection(xBox)
tkselection.clear(xBox$listbox, "0", "end")
if ((check <- !checkAddOperator(rhs)) && length(var) == 0) return()
if (length(var) > 1){
if (length(grep(word, var)) > 0) var <- sub(word, "", var)
var <- trim.blanks(var)
if (length(var) > 1) var <- paste(var, collapse=":")
tclvalue(rhsVariable) <- paste(rhs, if (!check) " + ", var, sep="")
}
else tclvalue(rhsVariable) <- paste(rhs, if (!check) ":", sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onSlash <- function(){
rhs <- tclvalue(rhsVariable)
if (!checkAddOperator(rhs)) return()
tclvalue(rhsVariable) <- paste(rhs, "/", sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onIn <- function(){
rhs <- tclvalue(rhsVariable)
if (!checkAddOperator(rhs)) return()
tclvalue(rhsVariable) <- paste(rhs, "%in% ")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onMinus <- function(){
rhs <- tclvalue(rhsVariable)
if (!checkAddOperator(rhs)) return()
tclvalue(rhsVariable) <- paste(rhs, "- ")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onPower <- function(){
rhs <- tclvalue(rhsVariable)
if (!checkAddOperator(rhs)) return()
tclvalue(rhsVariable) <- paste(rhs, "^", sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onLeftParen <- function(){
tkfocus(rhsEntry)
rhs <- tclvalue(rhsVariable)
tclvalue(rhsVariable) <- paste(rhs, "(", sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onRightParen <- function(){
rhs <- tclvalue(rhsVariable)
if (!checkAddOperator(rhs)) return()
tclvalue(rhsVariable) <- paste(rhs, ")", sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
outerOperatorsFrame <- tkframe(frame)
operatorsFrame <- tkframe(outerOperatorsFrame)
splinePolyFrame <- tkframe(outerOperatorsFrame)
plusButton <- buttonRcmdr(operatorsFrame, text="+", width="3", command=onPlus)
timesButton <- buttonRcmdr(operatorsFrame, text="*", width="3", command=onTimes)
colonButton <- buttonRcmdr(operatorsFrame, text=":", width="3", command=onColon)
slashButton <- buttonRcmdr(operatorsFrame, text="/", width="3", command=onSlash)
inButton <- buttonRcmdr(operatorsFrame, text="%in%", width="5", command=onIn)
minusButton <- buttonRcmdr(operatorsFrame, text="-", width="3", command=onMinus)
powerButton <- buttonRcmdr(operatorsFrame, text="^", width="3", command=onPower)
leftParenButton <- buttonRcmdr(operatorsFrame, text="(", width="3", command=onLeftParen)
rightParenButton <- buttonRcmdr(operatorsFrame, text=")", width="3", command=onRightParen)
onBSpline <- function(){
rhs <- tclvalue(rhsVariable)
var <- getSelection(xBox)
tkselection.clear(xBox$listbox, "0", "end")
if (length(var) == 0) var <- " "
if (grepl("\\[factor\\]", var)){
Message("spline requires a numeric variable", type="error")
return()
}
if (length(var) > 1){
Message("cannot select more than one variable", type="error")
return()
}
check <- !checkAddOperator(rhs)
tclvalue(rhsVariable) <- paste(rhs,
if (!check) paste(" + bs(", var, ", df=", tclvalue(dfSplineVar), ")", sep="")
else paste(" bs(", var, ", df=", tclvalue(dfSplineVar), ")", sep=""),
sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onNatSline <- function(){
rhs <- tclvalue(rhsVariable)
var <- getSelection(xBox)
tkselection.clear(xBox$listbox, "0", "end")
if (length(var) == 0) var <- " "
if (grepl("\\[factor\\]", var)){
Message("spline requires a numeric variable", type="error")
return()
}
if (length(var) > 1){
Message("cannot select more than one variable", type="error")
return()
}
check <- !checkAddOperator(rhs)
tclvalue(rhsVariable) <- paste(rhs,
if (!check) paste(" + ns(", var, ", df=", tclvalue(dfSplineVar), ")", sep="")
else paste(" ns(", var, ", df=", tclvalue(dfSplineVar), ")", sep=""),
sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onPoly <- function(){
rhs <- tclvalue(rhsVariable)
var <- getSelection(xBox)
tkselection.clear(xBox$listbox, "0", "end")
if (length(var) == 0) var <- " "
if (grepl("\\[factor\\]", var)){
Message("polynomial requires a numeric variable", type="error")
return()
}
if (length(var) > 1){
Message("cannot select more than one variable", type="error")
return()
}
check <- !checkAddOperator(rhs)
tclvalue(rhsVariable) <- paste(rhs,
if (!check) paste(" + poly(", var, ", degree=", tclvalue(degPolyVar), ")", sep="")
else paste(" poly(", var, ", degree=", tclvalue(degPolyVar), ")", sep=""),
sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onRawPoly <- function(){
rhs <- tclvalue(rhsVariable)
var <- getSelection(xBox)
tkselection.clear(xBox$listbox, "0", "end")
if (length(var) == 0) var <- " "
if (grepl("\\[factor\\]", var)){
Message("polynomial requires a numeric variable", type="error")
return()
}
if (length(var) > 1){
Message("cannot select more than one variable", type="error")
return()
}
check <- !checkAddOperator(rhs)
tclvalue(rhsVariable) <- paste(rhs,
if (!check) paste(" + poly(", var, ", degree=", tclvalue(degPolyVar), ", raw=TRUE)", sep="")
else paste(" poly(", var, ", degree=", tclvalue(degPolyVar), ", raw=TRUE)", sep=""),
sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
bsplineButton <- buttonRcmdr(splinePolyFrame, text=gettextRcmdr("B-spline\n"), width="10", command=onBSpline)
nsplineButton <- buttonRcmdr(splinePolyFrame, text=gettextRcmdr("natural\nspline"), width="10", command=onNatSline)
polyButton <- buttonRcmdr(splinePolyFrame, text=gettextRcmdr("orthogonal\npolynomial"), width="10", command=onPoly)
RawPolyButton <- buttonRcmdr(splinePolyFrame, text=gettextRcmdr("raw\npolynomial"), width="10", command=onRawPoly)
dfSplineVar <- tclVar("5")
degPolyVar <- tclVar("2")
dfDegFrame <- tkframe(outerOperatorsFrame)
dfSplineSpin <- tkspinbox(dfDegFrame, textvariable=dfSplineVar, state="readonly", from=2, to=10, width=2)
degPolySpin <- tkspinbox(dfDegFrame, textvariable=degPolyVar, state="readonly", from=2, to=5, width=2)
tkgrid(plusButton, timesButton, colonButton, slashButton, inButton, minusButton,
powerButton, leftParenButton, rightParenButton, sticky="w")
tkgrid(labelRcmdr(dfDegFrame, text=gettextRcmdr("df for splines: ")), dfSplineSpin, sticky="se")
tkgrid(labelRcmdr(dfDegFrame, text=gettextRcmdr("deg. for polynomials: ")), degPolySpin, sticky="se")
formulaFrame <- tkframe(frame)
if (hasLhs){
tkgrid(labelRcmdr(outerOperatorsFrame, text=gettextRcmdr("Model Formula"),
fg=getRcmdr("title.color"), font="RcmdrTitleFont"), sticky="w")
tkgrid(labelRcmdr(outerOperatorsFrame, text="Operators (click to formula): "), operatorsFrame, sticky="nw")
tkgrid(bsplineButton, nsplineButton, polyButton, RawPolyButton, sticky="nw")
tkgrid(labelRcmdr(outerOperatorsFrame, text=gettextRcmdr("Splines/Polynomials:\n(select variable and click)")),
splinePolyFrame, dfDegFrame, sticky="nw")
lhsVariable <- if (currentModel) tclVar(currentFields$lhs) else tclVar("")
rhsVariable <- if (currentModel) tclVar(currentFields$rhs) else tclVar("")
rhsEntry <- ttkentry(formulaFrame, width="75", textvariable=rhsVariable)
rhsXscroll <- ttkscrollbar(formulaFrame,
orient="horizontal", command=function(...) tkxview(rhsEntry, ...))
tkconfigure(rhsEntry, xscrollcommand=function(...) tkset(rhsXscroll, ...))
lhsEntry <- ttkentry(formulaFrame, width="10", textvariable=lhsVariable)
lhsScroll <- ttkscrollbar(formulaFrame,
orient="horizontal", command=function(...) tkxview(lhsEntry, ...))
tkconfigure(lhsEntry, xscrollcommand=function(...) tkset(lhsScroll, ...))
tkgrid(lhsEntry, labelRcmdr(formulaFrame, text=" ~ "), rhsEntry, sticky="w")
tkgrid(lhsScroll, labelRcmdr(formulaFrame, text=""), rhsXscroll, sticky="w")
tkgrid.configure(lhsScroll, sticky="ew")
}
else{
rhsVariable <- if (currentModel) tclVar(currentFields$rhs) else tclVar("")
rhsEntry <- ttkentry(formulaFrame, width="75", textvariable=rhsVariable)
rhsXscroll <- ttkscrollbar(formulaFrame,
orient="horizontal", command=function(...) tkxview(rhsEntry, ...))
tkconfigure(rhsEntry, xscrollcommand=function(...) tkset(rhsXscroll, ...))
tkgrid(labelRcmdr(formulaFrame, text=" ~ "), rhsEntry, sticky="w")
tkgrid(labelRcmdr(formulaFrame, text=""), rhsXscroll, sticky="w")
}
tkgrid.configure(rhsXscroll, sticky="ew")
})
exists.method <- function(generic, object, default=TRUE, strict=FALSE){
classes <- class(object)
if (default) classes <- c(classes, "default")
if (strict) classes <- classes[1]
any(paste(generic, ".", classes, sep="") %in%
as.character(methods(generic)))
}
checkMethod <- defmacro(generic, object, message=NULL, default=FALSE, strict=FALSE, reportError=TRUE,
expr={
msg <- if (is.null(message)) sprintf(gettextRcmdr("No appropriate %s method exists\nfor a model of this class."), generic)
else message
method <- exists.method(generic, get(object), default=default, strict=strict)
if ((!method) && reportError) Message(message=msg, type="error")
method
}
)
checkClass <- defmacro(object, class, message=NULL,
expr={
msg <- if (is.null(message)) sprintf(gettextRcmdr('The model is not of class "%s".'), class)
else message
properClass <- class(get(object))[1] == class
if (!properClass) Message(message=msg, type="error")
properClass
}
)
# the following function is from John Chambers (plus new test for R 2.4.0)
isS4object <- function(object) {
if (getRversion() < "2.4.0"){
if (length(attr(object, "class"))!= 1)
return(FALSE)
!isVirtualClass(getClass(class(object), TRUE))
}
else isS4(object)
}
.RcmdrEnv <- new.env(parent=emptyenv())
# putRcmdr <- function(x, value) assign(x, value, envir=.RcmdrEnv)
#
# getRcmdr <- function(x, mode="any") get(x, envir=.RcmdrEnv, mode=mode, inherits=FALSE)
RcmdrEnv <- function() .RcmdrEnv
putRcmdr <- function(x, value) assign(x, value, envir=RcmdrEnv())
# getRcmdr <- function(x, mode="any") get(x, envir=RcmdrEnv(), mode=mode, inherits=FALSE)
getRcmdr <- function(x, mode="any", fail=TRUE){
if ((!fail) && (!exists(x, mode=mode, envir=RcmdrEnv(), inherits=FALSE))) return(NULL)
get(x, envir=RcmdrEnv(), mode=mode, inherits=FALSE)
}
RcmdrTclSet <- function(name, value){
name <- ls(unclass(getRcmdr(name))$env)
tcl("set", name, value)
}
# functions to store or retrieve Rcmdr state information
Variables <- function(names){
if (missing(names)) getRcmdr("variables")
else putRcmdr("variables", names)
}
Numeric <- function(names){
if (missing(names)) getRcmdr("numeric")
else putRcmdr("numeric", names)
}
Factors <- function(names){
if (missing(names)) getRcmdr("factors")
else putRcmdr("factors", names)
}
TwoLevelFactors <- function(names){
if (missing(names)) getRcmdr("twoLevelFactors")
else putRcmdr("twoLevelFactors", names)
}
# The following two functions were modified by Erich Neuwrith
# and subsequently by John Fox (23 July 07)
# and Milan Bouchet-Valat (27 March 14)
ActiveDataSet <- function(name){
if (missing(name)) {
temp <- getRcmdr(".activeDataSet")
if (is.null(temp))
return(NULL)
else
if (!exists(temp) || !is.data.frame(get(temp,envir=.GlobalEnv))) {
Message(sprintf(gettextRcmdr("the dataset %s is no longer available"),
temp), type="error")
putRcmdr(".activeDataSet", NULL)
Variables(NULL)
Numeric(NULL)
Factors(NULL)
TwoLevelFactors(NULL)
RcmdrTclSet("dataSetName", gettextRcmdr("<No active dataset>"))
putRcmdr(".activeModel", NULL)
RcmdrTclSet("modelName", gettextRcmdr("<No active model>"))
tkconfigure(getRcmdr("dataSetLabel"), foreground="red")
tkconfigure(getRcmdr("modelLabel"), foreground="red")
activateMenus()
if (getRcmdr("suppress.menus") && RExcelSupported()) return(NULL)
}
return(temp)
}
else {
putRcmdr(".activeDataSet", name)
if(!is.null(name)) {
Variables(listVariables(name))
Numeric(listNumeric(name))
Factors(listFactors(name))
TwoLevelFactors(listTwoLevelFactors(name))
}
else {
Variables(NULL)
Numeric(NULL)
Factors(NULL)
TwoLevelFactors(NULL)
RcmdrTclSet("dataSetName", gettextRcmdr("<No active dataset>"))
putRcmdr(".activeModel", NULL)
RcmdrTclSet("modelName", gettextRcmdr("<No active model>"))
tkconfigure(getRcmdr("dataSetLabel"), foreground="red")
tkconfigure(getRcmdr("modelLabel"), foreground="red")
activateMenus()
if (getRcmdr("suppress.menus") && RExcelSupported()) return(NULL)
}
}
}
ActiveModel <- function(name){
if (missing(name)) {
temp <- getRcmdr(".activeModel")
if (is.null(temp))
return(NULL)
else
if (!exists(temp) || !is.model(get(temp,envir=.GlobalEnv))) {
Message(sprintf(gettextRcmdr("the model %s is no longer available"),
temp), type="error")
putRcmdr(".activeModel", NULL)
RcmdrTclSet("modelName", gettextRcmdr("<No active model>"))
tkconfigure(getRcmdr("modelLabel"), foreground="red")
activateMenus()
return(NULL)
}
else return(temp)
}
else putRcmdr(".activeModel", name)
}
GrabFocus <- function(value){
if (missing(value)) getRcmdr("grab.focus")
else putRcmdr("grab.focus", value)
}
UpdateModelNumber <- function(increment=1){
modelNumber <- getRcmdr("modelNumber")
modelNumber <- modelNumber + increment
if (modelNumber < 1) modelNumber <- 1 # sanity check
putRcmdr("modelNumber", modelNumber)
}
CommanderWindow <- function() getRcmdr("commanderWindow")
LogWindow <- function() getRcmdr("logWindow")
RmdWindow <- function() getRcmdr("RmdWindow")
RnwWindow <- function() getRcmdr("RnwWindow")
OutputWindow <- function() getRcmdr("outputWindow")
MessagesWindow <- function() getRcmdr("messagesWindow")
# some predicates for the menu system
activeDataSetP <- function() !is.null(ActiveDataSet())
dataSetsP <- function(n=1){
datasets <- listDataSets()
(!is.null(datasets)) && length(datasets) >= n
}
numericP <- function(n=1) activeDataSetP() && length(listNumeric()) >= n
factorsP <- function(n=1) activeDataSetP() && length(listFactors()) >= n
twoLevelFactorsP <- function(n=1) activeDataSetP() && length(listTwoLevelFactors()) >= n
modelsP <- function(n=1) activeDataSetP() && length(listAllModels()) >= n
activeModelP <- function() !is.null(ActiveModel())
lmP <- function() activeModelP() && any(class(get(ActiveModel()))[1] == c('lm', 'aov'))
glmP <- function() activeModelP() && class(get(ActiveModel()))[1] == 'glm'
aicP <- function() activeModelP() && exists.method("extractAIC", get(ActiveModel()))
polrP <- function() activeModelP() && class(get(ActiveModel()))[1] == 'polr'
multinomP <- function() activeModelP() && class(get(ActiveModel()))[1] == 'multinom'
hclustSolutionsP <- function() length(listHclustSolutions()) > 0
MacOSXP <- function() {
sys <- Sys.info()
!is.null(sys) && length(grep("[Dd]arwin", sys["sysname"]) > 0)
}
packageAvailable <- function(name) 0 != length(find.package(name, quiet=TRUE))
rglLoaded <- function() 0 != length(grep("^rgl", loadedNamespaces()))
activateMenus <- function(){
if (getRcmdr("suppress.menus")) return()
for (item in getRcmdr("Menus")){
if (item$activation()) .Tcl(paste(item$ID, " entryconfigure ", item$position - 1," -state normal", sep=""))
else .Tcl(paste(item$ID, " entryconfigure ", item$position - 1," -state disabled", sep=""))
}
}
# for internationalization
gettextRcmdr <- function(...) gettext(..., domain="R-Rcmdr205")
gettextMenus <- function(...){
text <- gettextRcmdr(...)
plugins <- getOption("Rcmdr")$plugins
if (is.null(plugins)) return(text)
plugins <- paste("R-", plugins, sep="")
for (plugin in plugins){
text <- gettext(text, domain=plugin)
}
text
}
English <- function() {
env <- Sys.getenv()
names(env) <- toupper(names(env))
LANG <- env["LANGUAGE"]
LC_CTYPE <- Sys.getlocale("LC_CTYPE")
if (!is.na(LANG)) length(grep("^en", LANG, ignore.case=TRUE)) > 0
else LC_CTYPE == "C" || length(grep("^en", LC_CTYPE, ignore.case=TRUE)) > 0
}
# to replace tkmessageBox on non-English Windows systems,
# to allow for translation of button text
RcmdrTkmessageBox <- function(message, icon=c("info", "question", "warning",
"error"), type=c("okcancel", "yesno", "ok"), default, title="") {
if ( (English()) || (!WindowsP()) ){
if (missing(default)){
default <- switch(type,
okcancel="ok",
yesno="yes",
ok="ok")}
return(tkmessageBox(message=message, icon=icon, type=type,
default=default, title=title))
}
icon <- match.arg(icon)
type <- match.arg(type)
initializeDialog(messageBox, title=title)
messageFrame <- tkframe(messageBox, borderwidth=5)
buttonFrame <- tkframe(messageBox, borderwidth=5)
if (icon != "question") tkbell()
result <- tclVar()
iconColor <- switch(icon, info=getRcmdr("title.color"), question=getRcmdr("title.color"), warning="black",
error="red")
onOK <- function() {
if (GrabFocus()) tkgrab.release(messageBox)
tkdestroy(messageBox)
tkfocus(CommanderWindow())
tclvalue(result) <- "ok"
}
OKbutton <- buttonRcmdr(buttonFrame, text=gettextRcmdr("OK"),
foreground="darkgreen", width="12", command=onOK, borderwidth=3,
default=if (missing(default)) "active"
else if (default == "ok") "active" else "normal")
onCancel <- function() {
if (GrabFocus()) tkgrab.release(messageBox)
tkdestroy(messageBox)
tkfocus(CommanderWindow())
tclvalue(result) <- "cancel"
}
cancelButton <- buttonRcmdr(buttonFrame, text=gettextRcmdr("Cancel"),
foreground="red", width="12", command=onCancel, borderwidth=3,
default=if (missing(default)) "normal"
else if (default == "cancel") "active" else "normal")
onYes <- function() {
if (GrabFocus()) tkgrab.release(messageBox)
tkdestroy(messageBox)
tkfocus(CommanderWindow())
tclvalue(result) <- "yes"
}
yesButton <- buttonRcmdr(buttonFrame, text=gettextRcmdr("Yes"),
foreground="darkgreen", width="12", command=onYes, borderwidth=3,
default=if (missing(default)) "active"
else if (default == "yes") "active" else "normal")
onNo <- function() {
if (GrabFocus()) tkgrab.release(messageBox)
tkdestroy(messageBox)
tkfocus(CommanderWindow())
tclvalue(result) <- "no"
}
noButton <- buttonRcmdr(buttonFrame, text=gettextRcmdr("No"),
foreground="red", width="12", command=onNo, borderwidth=3,
default=if (missing(default)) "normal"
else if (default == "no") "active" else "normal")
## FIXME -- left in old style
tkgrid(tklabel(messageFrame, bitmap=icon, fg=iconColor),
tklabel(messageFrame, text=" "),
tklabel(messageFrame, text=message))
tkgrid(messageFrame)
switch(type,
okcancel = {
tkgrid(OKbutton, labelRcmdr(buttonFrame, text=" "), cancelButton)
if (missing(default) || default == "ok") tkbind(messageBox, "<Return>",
onOK)
else if (default == "cancel") tkbind(messageBox, "<Return>", onCancel)
},
yesno = {
tkgrid(yesButton, labelRcmdr(buttonFrame, text=" "), noButton)
if (missing(default) || default == "yes") tkbind(messageBox, "<Return>",
onYes)
else if (default == "no") tkbind(messageBox, "<Return>", onNo)
},
ok = {
tkgrid(OKbutton)
if (missing(default) || default == "ok") tkbind(messageBox, "<Return>",
onOK)
}
)
tkgrid(buttonFrame)
dialogSuffix(messageBox, focus=messageBox, bindReturn=FALSE)
result
}
# The following function was contributed by Matthieu Lesnoff (added 20 July 06)
trim.col.na <- function(dat){
# Remove variables with only missing values (occurs sometimes with modified Excel file)
colsup <- NULL
for (i in 1:ncol(dat))
{
if (length(dat[is.na(dat[,i])==T,i]) ==length(dat[,i]))
colsup <- c(colsup,i)
}
if (length(colsup) > 0)
dat <- dat[,-colsup]
dat
}
# check whether packages are available
packagesAvailable <- function(packages){
sapply(sapply(packages, find.package, quiet=TRUE),
function(x) length(x) != 0)
}
# insert a row (or rows) in a matrix or data frame
insertRows <- function(object1, object2, where=NULL, ...){
if (ncol(object1) != ncol(object2))
stop(gettextRcmdr("objects have different numbers of columns"))
if (!(TRUE == all.equal(colnames(object1), colnames(object2))))
stop(gettextRcmdr("objects have different column names"))
n <- nrow(object1)
if (is.null(where) || where >= n) rbind(object1, object2)
else if (where < 1) rbind(object2, object1)
else rbind(object1[1:floor(where),], object2,
object1[(floor(where) + 1):n,])
}
# functions for handling Rcmdr plug-in packages
# the following function based on a suggestion by Brian Ripley
listPlugins <- function(loaded=FALSE){
plugins <- unlist(lapply(.libPaths(),
function(x) Sys.glob(file.path(x, "*/etc/menus.txt"))))
plugins <- sub(".*/([^/]*)/etc/menus.txt", "\\1", plugins)
if (loaded) plugins else sort(setdiff(plugins, .packages()))
}
loadPlugins <- function(){
plugins <- listPlugins()
initializeDialog(title=gettextRcmdr("Load Plug-ins"))
packagesBox <- variableListBox(top, plugins, title=gettextRcmdr("Plug-ins (pick one or more)"),
selectmode="multiple", listHeight=10)
onOK <- function(){
plugins <- getSelection(packagesBox)
closeDialog(top)
if (length(plugins) == 0){
errorCondition(recall=loadPlugins, message=gettextRcmdr("You must select at least one plug-in."))
return()
}
opts <- options("Rcmdr")
opts$Rcmdr$plugins <- c(plugins, opts$Rcmdr$plugins)
options(opts)
for (plugin in plugins) {
command <- paste('library("', plugin, '", character.only=TRUE)', sep="")
justDoIt(command)
}
Message(paste(gettextRcmdr("Plug-ins loaded:"), paste(plugins, collapse=", ")), type="note")
response <- tkmessageBox(message=paste(gettextRcmdr(
"The plug-in(s) will not be available until the Commander is restarted.\nRestart now?")),
icon="question", type="yesno")
if (tclvalue(response) == "yes") {
putRcmdr("autoRestart", TRUE)
closeCommander(ask=FALSE)
Commander()
}
}
OKCancelHelp(helpSubject="Plugins")
tkgrid(getFrame(packagesBox), sticky="nw")
tkgrid(buttonsFrame, sticky="w")
dialogSuffix()
}
# the following two functions contributed by Erich Neuwirth (added 22 July 07)
whitespaceonly <- function(str) sub('[[:space:]]+$', '', str) == ''
is.model <- function(object) {
any(class(object) %in% getRcmdr("modelClasses"))
}
# the following lines, adding support for ttk widgets, adapted from code by Brian Ripley
if (!(as.character(tcl("info", "tclversion")) >= "8.5" && getRversion() >= "2.7.0")){
buttonRcmdr <- tkbutton
labelRcmdr <- tklabel
ttkentry <- function(parent, ...) tkentry(parent, ...)
ttkframe <- tkframe
ttkradiobutton <- tkradiobutton
ttkscrollbar <- function(...) tkscrollbar(..., repeatinterval=5)
} else {
buttonRcmdr <- function(..., borderwidth, fg, foreground, relief) ttkbutton(...)
labelRcmdr <- function(..., fg)
if(missing(fg)) ttklabel(...) else ttklabel(..., foreground=fg)
}
# Label looking like that of a TtkLabelFrame
titleLabel <- function(...) labelRcmdr(..., font="RcmdrTitleFont", fg=getRcmdr("title.color"))
# the following function alters the default behaviour of tclvalue() by trimming leading and trailing blanks
tclvalue <- function(x) trim.blanks(tcltk::tclvalue(x))
# the following function splits a character string at blanks and commas according to width
splitCmd <- function(cmd, width=getOption("width") - 4, at="[ ,]"){
if (nchar(cmd) <= width) return(cmd)
where <- gregexpr(at, cmd)[[1]]
if (where[1] < 0) return(cmd)
singleQuotes <- gregexpr("'", cmd)[[1]]
doubleQuotes <- gregexpr('"', cmd)[[1]]
comment <- regexpr("#", cmd)
if (singleQuotes[1] > 0 && (singleQuotes[1] < doubleQuotes[1] || doubleQuotes[1] < 0 ) && (singleQuotes[1] < comment[1] || comment[1] < 0 )){
nquotes <- length(singleQuotes)
if (nquotes < 2) stop("unbalanced quotes")
for(i in seq(nquotes/2))
where[(where > singleQuotes[2 * i - 1]) & (where < singleQuotes[2 * i])] <- NA
where <- na.omit(where)
}
else if (doubleQuotes[1] > 0 && (doubleQuotes[1] < singleQuotes[1] || singleQuotes[1] < 0) && (doubleQuotes[1] < comment[1] || comment[1] < 0 )){
nquotes <- length(doubleQuotes)
if (nquotes < 2) stop("unbalanced quotes")
for(i in seq(nquotes/2))
where[(where > doubleQuotes[2 * i - 1]) & (where < doubleQuotes[2 * i])] <- NA
where <- na.omit(where)
}
else if (comment > 0){
where[where > comment] <- NA
where <- na.omit(where)
}
if (length(where) == 0) return(cmd)
where2 <- where[where <= width]
where2 <- if (length(where2) == 0) where[1]
else where2[length(where2)]
paste(substr(cmd, 1, where2), "\n ",
Recall(substr(cmd, where2 + 1, nchar(cmd)), width, at), sep="")
}
# the following function sorts names containing numerals "more naturally" than does sort()
sortVarNames <- function(x){
sort.helper <- function(x){
prefix <- strsplit(x, "[0-9]+")
prefix <- sapply(prefix, "[", 1)
prefix[is.na(prefix)] <- ""
suffix <- strsplit(x, "[^0-9]+")
suffix <- as.numeric(sapply(suffix, "[", 2))
suffix[is.na(suffix)] <- -Inf
remainder <- sub("[^0-9]+", "", x)
remainder <- sub("[0-9]+", "", remainder)
if (all (remainder == "")) list(prefix, suffix)
else c(list(prefix, suffix), Recall(remainder))
}
ord <- do.call("order", sort.helper(x))
x[ord]
}
# to load packages
Library <- function(package, pos=4, rmd=TRUE){
loaded <- search()
loaded <- loaded[grep("^package:", loaded)]
loaded <- sub("^package:", "", loaded)
if (!getRcmdr("suppress.X11.warnings")){
messages.connection <- file(open="w+")
sink(messages.connection, type="message")
on.exit({
sink(type="message")
close(messages.connection)
})
}
if (!(package %in% loaded)){
command <- paste("library(", package, ", pos=", pos, ")", sep="")
logger(command, rmd=rmd)
result <- try(eval(parse(text=command), envir=.GlobalEnv), silent=TRUE)
if (class(result)[1] == "try-error"){
Message(message=paste(strsplit(result, ":")[[1]][2]), type="error")
tkfocus(CommanderWindow())
return("error")
}
return(package)
}
else return(invisible(NULL))
}
# to merge data frames by rows
mergeRows <- function(X, Y, common.only=FALSE, ...){
UseMethod("mergeRows")
}
mergeRows.data.frame <- function(X, Y, common.only=FALSE, ...){
cols1 <- names(X)
cols2 <- names(Y)
if (common.only){
common <- intersect(cols1, cols2)
rbind(X[, common], Y[, common])
}
else {
all <- union(cols1, cols2)
miss1 <- setdiff(all, cols1)
miss2 <- setdiff(all, cols2)
X[, miss1] <- NA
Y[, miss2] <- NA
rbind(X, Y)
}
}
# start help system
startHelp <- function(){
Sys.sleep(2)
help.start()
}
# dialog memory support
putDialog <- function (dialog, values=NULL, resettable=TRUE){
if (resettable){
dialog.values <- getRcmdr("dialog.values")
dialog.values[[dialog]] <- values
putRcmdr("dialog.values", dialog.values)
}
else{
dialog.values <- getRcmdr("dialog.values.noreset")
dialog.values[[dialog]] <- values
putRcmdr("dialog.values.noreset", dialog.values)
}
}
getDialog <- function(dialog, defaults=NULL){
values <- getRcmdr("dialog.values.noreset")[[dialog]]
if (getRcmdr("retain.selections") && !is.null(values)) return(values)
values <- getRcmdr("dialog.values")[[dialog]]
if (!getRcmdr("retain.selections") || is.null(values)) return(defaults)
else return (values)
}
varPosn <- function(variables, type=c("all", "factor", "numeric", "nonfactor", "twoLevelFactor")){
if (is.null(variables)) return(NULL)
type <- match.arg(type)
vars <- switch(type,
all = Variables(),
factor = Factors(),
numeric = Numeric(),
nonfactor = setdiff(Variables(), Factors()),
twoLevelFactor = TwoLevelFactors()
)
if (any(!variables %in% vars)) NULL
else apply(outer(variables, vars, "=="), 1, which) - 1
}
flushDialogMemory <- function(what){
if (missing(what)) putRcmdr("dialog.values", list())
else{
dialog.values <- getRcmdr("dialog.values")
dialog.values.noreset <- getRcmdr("dialog.values.noreset")
for (dialog in what){
dialog.values[dialog] <- NULL
dialog.values.noreset[dialog] <- NULL
}
putRcmdr("dialog.values", dialog.values)
putRcmdr("dialog.values.noreset", dialog.values.noreset)
}
}
# for assignments to the global environment
gassign <- function(x, value){
if (!(is.valid.name(x))) stop("argument x not a valid R name")
G <- .GlobalEnv
assign(x, value, envir=G)
}
# because it's no longer possible to access these functions from their packages:
# from car:
coef.multinom <- function (object, ...)
{
# the following from nnet:
cf <- function (object, ...)
{
r <- length(object$vcoefnames)
if (length(object$lev) == 2L) {
coef <- object$wts[1L + (1L:r)]
names(coef) <- object$vcoefnames
}
else {
coef <- matrix(object$wts, nrow = object$n[3L], byrow = TRUE)[,
1L + (1L:r), drop = FALSE]
if (length(object$lev))
dimnames(coef) <- list(object$lev, object$vcoefnames)
if (length(object$lab))
dimnames(coef) <- list(object$lab, object$vcoefnames)
coef <- coef[-1L, , drop = FALSE]
}
coef
}
b <- cf(object, ...)
cn <- colnames(b)
rn <- rownames(b)
b <- as.vector(t(b))
names(b) <- as.vector(outer(cn, rn, function(c, r) paste(r,
c, sep = ":")))
b
}
# from MASS:
confint.glm <- function (object, parm, level = 0.95, trace = FALSE, ...)
{
pnames <- names(coef(object))
if (missing(parm))
parm <- seq_along(pnames)
else if (is.character(parm))
parm <- match(parm, pnames, nomatch = 0L)
message("Waiting for profiling to be done...")
utils::flush.console()
object <- profile(object, which = parm, alpha = (1 - level)/4,
trace = trace)
confint(object, parm = parm, level = level, trace = trace,
...)
}
tkfocus <- function(...) tcl("focus", ...)
tkspinbox <- function(parent, ...) tkwidget(parent, "spinbox", ...)
# the following two functions adapted from Milan Bouchet-Valat
WindowsP <- function() {
.Platform$OS.type == "windows"
}
X11P <- function(){
.Platform$GUI == "X11"
}
# the following functions to support R Markdown
suppressMarkdown <- function(command){
attr(command, "suppressRmd") <- TRUE
command
}
beginRmdBlock <- function(){
.rmd <- RmdWindow()
last2 <- tclvalue(tkget(.rmd, "end -2 chars", "end"))
if (last2 != "\n\n") tkinsert(.rmd, "end", "\n")
tkinsert(.rmd, "end", "\n")
tkinsert(.rmd, "end", "```{r}\n")
}
endRmdBlock <- function(){
.rmd <- RmdWindow()
rmd <- tclvalue(tkget(.rmd, "1.0", "end"))
rmd <- paste(substring(rmd, 1, nchar(rmd) - 1), "```\n", sep="")
rmd <- trimHangingEndRmdBlock(rmd)
tkdelete(.rmd, "1.0", "end")
tkinsert(.rmd, "end", rmd)
tkyview.moveto(.rmd, 1)
}
removeNullRmdBlocks <- function(){
.rmd <- RmdWindow()
rmd <- tclvalue(tkget(.rmd, "1.0", "end"))
rmd <- gsub("\n+$", "\n", rmd)
rmd <- gsub("```\\{r\\}\n$", "", rmd)
rmd <- gsub("```\\{r\\}\n```\n$", "", rmd)
tkdelete(.rmd, "1.0", "end")
tkinsert(.rmd, "end", rmd)
tkyview.moveto(.rmd, 1)
}
removeStrayRmdBlocks <- function(){
.rmd <- RmdWindow()
rmd <- tclvalue(tkget(.rmd, "1.0", "end"))
rmd <- strsplit(rmd, "\\n")[[1]]
starts <- grep("^```\\{r.*\\}$", rmd)
ends <- grep("^```$", rmd)
n.ends <- length(ends)
j <- 1
if (length(starts) > 1){
for (i in 1:(length(starts) - 1)){
if (j > n.ends || ends[j] > starts[i + 1]) {
rmd[starts[i]] <- ""
}
else {
j <- j + 1
next
}
}
}
else return()
rmd <- paste(rmd, collapse="\n")
tkdelete(.rmd, "1.0", "end")
tkinsert(.rmd, "end", rmd)
tkyview.moveto(.rmd, 1)
}
enterMarkdown <- function(command){
if (!getRcmdr("use.markdown")) return()
.rmd <- RmdWindow()
command <- splitCmd(command)
beginRmdBlock()
tkinsert(.rmd, "end", paste(command, "\n", sep=""))
tkyview.moveto(.rmd, 1)
putRcmdr("markdown.output", TRUE)
endRmdBlock()
command
}
trimHangingEndRmdBlock <- function(string){
loc.ends <- gregexpr("```\n", string)[[1]]
n.ends <- length(loc.ends)
if (n.ends > 1){
substr <- substring(string, loc.ends[n.ends - 1], loc.ends[n.ends])
if (!grepl("```\\{r\\}", substr)){
string <- cutstring(string, loc.ends[n.ends], loc.ends[n.ends] + 3)
}
}
string
}
removeLastRmdBlock <- function(){
.rmd <- RmdWindow()
rmd <- tclvalue(tkget(.rmd, "1.0", "end"))
start <- gregexpr("```\\{r\\}\n", rmd)
if (start[[1]][1] > 0){
start <- start[[1]]
start <- start[length(start)]
tail <- substring(rmd, start, nchar(rmd))
end <- gregexpr("```\n", tail)
end <- if (end[[1]][1] > 0) end[[1]][1] + 3 else nchar(tail)
rmd <- cutstring(rmd, start, start + end)
tkdelete(.rmd, "1.0", "end")
tkinsert(.rmd, "end", rmd)
tkyview.moveto(.rmd, 1)
}
}
cutstring <- function(x, start=1, end=nchar(x)){
one <- if (start > 1) substr(x, 1, start - 1) else ""
two <- if (end < nchar(x)) substr(x, end + 1, nchar(x)) else ""
paste0(one, two)
}
MarkdownP <- function(){
getRcmdr("log.commands") && getRcmdr("use.markdown")
}
compileRmd <- function() {
if (!(require(knitr))) return()
if (!(require(markdown))) return()
fig.files <- list.files("./figure")
fig.files <- fig.files[grep("^unnamed-chunk-[0-9]*\\..*$", fig.files)]
if (length(fig.files) != 0) {
response <- tkmessageBox(message = gettextRcmdr("Delete previously created R Markdown\ngraphics files (recommended)?"),
icon = "question", type = "okcancel", default = "ok")
if (tclvalue(response) == "ok") unlink(paste("./figure/", fig.files, sep=""))
}
removeStrayRmdBlocks()
lines <- tclvalue(tkget(RmdWindow(), "1.0", "end"))
.RmdFile <- getRcmdr("RmdFileName")
.filename <- sub("\\.Rmd$", "", trim.blanks(.RmdFile))
writeLines(lines, .RmdFile)
knit(.RmdFile, paste(.filename, ".md", sep=""), quiet=TRUE)
.html.file <- paste(.filename, ".html", sep="")
markdownToHTML(paste(.filename, ".md", sep=""), .html.file)
.html.file.location <- paste("file:///", normalizePath(.html.file), sep="")
browseURL(.html.file.location)
}
# the following functions to support knitr
beginRnwBlock <- function(){
.rnw <- RnwWindow()
last2 <- tclvalue(tkget(.rnw, "end -2 chars", "end"))
if (last2 != "\n\n") tkinsert(.rnw, "end", "\n")
tkinsert(.rnw, "end", "\n")
tkinsert(.rnw, "end", "\\newpage\n")
tkinsert(.rnw, "end", "<<>>=\n")
}
endRnwBlock <- function(){
.rnw <- RnwWindow()
rnw <- tclvalue(tkget(.rnw, "1.0", "end"))
rnw <- paste(substring(rnw, 1, nchar(rnw) - 1), "@\n", sep="")
rnw <- trimHangingEndRnwBlock(rnw)
tkdelete(.rnw, "1.0", "end")
tkinsert(.rnw, "end", rnw)
tkyview.moveto(.rnw, 1)
}
removeNullRnwBlocks <- function(){
.rnw <- RnwWindow()
rnw <- tclvalue(tkget(.rnw, "1.0", "end"))
rnw <- gsub("\n+$", "\n", rnw)
rnw <- gsub("<<>>=\n$", "", rnw)
rnw <- gsub("<<>>=\n@\n$", "", rnw)
rnw <- gsub("\\\\newpage\n*$", "", rnw)
rnw <- gsub("\\\\newpage\n*$", "", rnw)
tkdelete(.rnw, "1.0", "end")
tkinsert(.rnw, "end", rnw)
tkyview.moveto(.rnw, 1)
}
removeStrayRnwBlocks <- function(){
.rnw <- RnwWindow()
rnw <- tclvalue(tkget(.rnw, "1.0", "end"))
rnw <- strsplit(rnw, "\\n")[[1]]
starts <- grep("^<<.*>>=$", rnw)
ends <- grep("^@$", rnw)
n.ends <- length(ends)
j <- 1
if (length(starts) > 1){
for (i in (length(starts) - 1)){
if (j > n.ends || ends[j] > starts[i + 1]) {
rnw[starts[i]] <- ""
}
else {
j <- j + 1
next
}
}
}
else return()
rnw <- paste(rnw, collapse="\n")
tkdelete(.rnw, "1.0", "end")
tkinsert(.rnw, "end", rnw)
tkyview.moveto(.rnw, 1)
}
enterKnitr <- function(command){
.rnw <- RnwWindow()
if (!getRcmdr("use.knitr")) return()
command <- splitCmd(command)
beginRnwBlock()
tkinsert(.rnw, "end", paste(command, "\n", sep=""))
tkyview.moveto(.rnw, 1)
putRcmdr("knitr.output", TRUE)
endRnwBlock()
command
}
trimHangingEndRnwBlock <- function(string){
loc.ats <- gregexpr("@\n", string)[[1]]
n.ats <- length(loc.ats)
if (n.ats > 1){
substr <- substring(string, loc.ats[n.ats - 1], loc.ats[n.ats])
if (!grepl("<<>>=", substr)){
string <- cutstring(string, loc.ats[n.ats], loc.ats[n.ats] + 1)
}
}
string
}
removeLastRnwBlock <- function(){
.rnw <- RnwWindow()
rnw <- tclvalue(tkget(.rnw, "1.0", "end"))
start <- gregexpr("\\\\newpage\n<<>>=\n", rnw)
if (start[[1]][1] > 0){
start <- start[[1]]
start <- start[length(start)]
tail <- substring(rnw, start, nchar(rnw))
end <- gregexpr("@\n", tail)
end <- if (end[[1]][1] > 0) end[[1]][1] + 1 else nchar(tail)
rnw <- cutstring(rnw, start, start + end)
tkdelete(.rnw, "1.0", "end")
tkinsert(.rnw, "end", rnw)
tkyview.moveto(.rnw, 1)
}
}
compileRnw <- function(){
if (!require(knitr)) return()
fig.files <- list.files("./figure")
fig.files <- fig.files[grep("^unnamed-chunk-[0-9]*\\..*$", fig.files)]
if (length(fig.files) != 0) {
response <- tkmessageBox(message = gettextRcmdr("Delete previously created knitr\ngraphics files (recommended)?"),
icon = "question", type = "okcancel", default = "ok")
if (tclvalue(response) == "ok") unlink(paste("./figure/", fig.files, sep=""))
}
removeStrayRnwBlocks()
lines <- tclvalue(tkget(RnwWindow(), "1.0", "end"))
lines <- paste(lines, "\n\\end{document}\n")
.RnwFile <- getRcmdr("RnwFileName")
.filename <- sub("\\.Rnw$", "", trim.blanks(.RnwFile))
writeLines(lines, .RnwFile)
knit2pdf(.RnwFile)
.pdf.file <- paste(.filename, ".pdf", sep="")
.pdf.file.location <- paste("file:///", normalizePath(.pdf.file), sep="")
browseURL(.pdf.file.location)
}
knitrP <- function(){
getRcmdr("log.commands") && getRcmdr("use.knitr")
}
# editor for R Markdown and knitr documents
RcmdrEditor <- function(buffer, title="R Commander Editor",
help=NULL, file.menu=NULL, edit.menu=NULL, context.menu=NULL, toolbar.buttons=NULL){
contextMenu <- function(){
contextMenu <- tkmenu(tkmenu(editor), tearoff=FALSE)
if (!is.null(context.menu)){
for (item in context.menu){
tkadd(contextMenu, "command", label=gettextRcmdr(item$label), command=item$command)
}
tkadd(contextMenu, "separator")
}
tkadd(contextMenu, "command", label=gettextRcmdr("Cut"), command=onCut)
tkadd(contextMenu, "command", label=gettextRcmdr("Copy"), command=onCopy)
tkadd(contextMenu, "command", label=gettextRcmdr("Paste"), command=onPaste)
tkadd(contextMenu, "command", label=gettextRcmdr("Delete"), command=onDelete)
tkadd(contextMenu, "separator")
tkadd(contextMenu, "command", label=gettextRcmdr("Find..."), command=onFind)
tkadd(contextMenu, "command", label=gettextRcmdr("Select all"), command=onSelectAll)
tkadd(contextMenu, "separator")
tkadd(contextMenu, "command", label=gettextRcmdr("Undo"), command=onUndo)
tkadd(contextMenu, "command", label=gettextRcmdr("Redo"), command=onRedo)
tkadd(contextMenu, "separator")
tkadd(contextMenu, "command", label=gettextRcmdr("Clear window"), command=onClear)
tkpopup(contextMenu, tkwinfo("pointerx", editor), tkwinfo("pointery", editor))
}
onCopy <- function(){
selection <- strsplit(tclvalue(tktag.ranges(editor, "sel")), " ")[[1]]
if (is.na(selection[1])) return()
text <- tclvalue(tkget(editor, selection[1], selection[2]))
tkclipboard.clear()
tkclipboard.append(text)
}
onDelete <- function(){
selection <- strsplit(tclvalue(tktag.ranges(editor, "sel")), " ")[[1]]
if (is.na(selection[1])) return()
tkdelete(editor, selection[1], selection[2])
}
onCut <- function(){
onCopy()
onDelete()
}
onPaste <- function(){
onDelete()
text <- tclvalue(.Tcl("selection get -selection CLIPBOARD"))
if (length(text) == 0) return()
tkinsert(editor, "insert", text)
}
onFind <- function(){
initializeDialog(title=gettextRcmdr("Find"))
textFrame <- tkframe(top)
textVar <- tclVar(getRcmdr("last.search"))
textEntry <- ttkentry(textFrame, width="20", textvariable=textVar)
checkBoxes(frame="optionsFrame", boxes=c("regexpr", "case"), initialValues=c("0", "1"),
labels=gettextRcmdr(c("Regular-expression search", "Case sensitive")))
radioButtons(name="direction", buttons=c("foward", "backward"), labels=gettextRcmdr(c("Forward", "Backward")),
values=c("-forward", "-backward"), title=gettextRcmdr("Search Direction"))
onOK <- function(){
text <- tclvalue(textVar)
putRcmdr("last.search", text)
if (text == ""){
errorCondition(recall=onFind, message=gettextRcmdr("No search text specified."))
return()
}
type <- if (tclvalue(regexprVariable) == 1) "-regexp" else "-exact"
case <- tclvalue(caseVariable) == 1
direction <- tclvalue(directionVariable)
stop <- if (direction == "-forward") "end" else "1.0"
where.txt <- if (case) tksearch(editor, type, direction, "--", text, "insert", stop)
else tksearch(editor, type, direction, "-nocase", "--", text, "insert", stop)
where.txt <- tclvalue(where.txt)
if (where.txt == "") {
Message(message=gettextRcmdr("Text not found."),
type="note")
if (GrabFocus()) tkgrab.release(top)
tkdestroy(top)
tkfocus(CommanderWindow())
return()
}
if (GrabFocus()) tkgrab.release(top)
tkfocus(editor)
tkmark.set(editor, "insert", where.txt)
tksee(editor, where.txt)
tkdestroy(top)
}
.exit <- function(){
text <- tclvalue(textVar)
putRcmdr("last.search", text)
return("")
}
OKCancelHelp()
tkgrid(labelRcmdr(textFrame, text=gettextRcmdr("Search for:")), textEntry, sticky="w")
tkgrid(textFrame, sticky="w")
tkgrid(optionsFrame, sticky="w")
tkgrid(directionFrame, sticky="w")
tkgrid(buttonsFrame, sticky="w")
dialogSuffix(focus=textEntry)
}
onSelectAll <- function() {
tktag.add(editor, "sel", "1.0", "end")
tkfocus(editor)
}
onClear <- function(){
onSelectAll()
onDelete()
}
onUndo <- function(){
tcl(editor, "edit", "undo")
}
onRedo <- function(){
tcl(editor, "edit", "redo")
}
initializeDialog(title = gettextRcmdr(title))
toolbarFrame <- tkframe(top)
cutButton <- buttonRcmdr(toolbarFrame, image="::image::cutIcon", command=onCut)
copyButton <- buttonRcmdr(toolbarFrame, image="::image::copyIcon", command=onCopy)
pasteButton <- buttonRcmdr(toolbarFrame, image="::image::pasteIcon", command=onPaste)
deleteButton <- buttonRcmdr(toolbarFrame, image="::image::deleteIcon", command=onDelete)
undoButton <- buttonRcmdr(toolbarFrame, image="::image::undoIcon", command=onUndo)
redoButton <- buttonRcmdr(toolbarFrame, image="::image::redoIcon", command=onRedo)
findButton <- buttonRcmdr(toolbarFrame, image="::image::findIcon", command=onFind)
if (!is.null(toolbar.buttons)){
for (i in 1:length(toolbar.buttons)){
tool <- toolbar.buttons[[i]]
assign(paste("var", i, sep=""), tclVar(gettextRcmdr(tool$label)))
assign(paste("button", i, sep=""), buttonRcmdr(toolbarFrame, textvariable=eval(parse(text=paste("var", i, sep=""))),
borderwidth="2", command=tool$command, image=tool$image, compound="left"))
}
}
editorFrame <- tkframe(top)
screenheight <- as.numeric(.Tcl(paste("winfo screenheight", top$ID)))
char.size <- as.numeric(.Tcl(paste("font metrics", getRcmdr('logFont'))))[6]
width <- as.numeric(tkcget(LogWindow(), "-width")) + 5
height <- max(floor(screenheight/(2.5*char.size)), 25)
editor <- tktext(editorFrame, bg = "white", font = getRcmdr("logFont"),
height = height, width = width, wrap = "none", undo=TRUE)
putRcmdr("editor.text", editor)
editorXscroll <- ttkscrollbar(editorFrame, orient = "horizontal",
command = function(...) tkxview(editor, ...))
editorYscroll <- ttkscrollbar(editorFrame, command = function(...) tkyview(editor,
...))
tkconfigure(editor, xscrollcommand = function(...) tkset(editorXscroll,
...))
tkconfigure(editor, yscrollcommand = function(...) tkset(editorYscroll,
...))
tkinsert(editor, "1.0", buffer)
putRcmdr("buffer", NULL)
onOK <- function(){
putRcmdr("buffer", tclvalue(tkget(editor, "1.0", "end")))
closeDialog()
}
.exit <- function(){
answer <- RcmdrTkmessageBox("Discard edits?", icon="question", type="yesno")
if (as.character(answer) == "no") "abort" else ""
}
OKCancelHelp(helpSubject = "ScriptEditor")
editorMenu <- tkmenu(top)
tkconfigure(top, menu = editorMenu)
fileMenu <- tkmenu(editorMenu, tearoff=FALSE)
if (!is.null(file.menu)){
for (item in file.menu){
tkadd(fileMenu, "command", label=gettextRcmdr(item$label), command=item$command)
}
tkadd(fileMenu, "separator")
}
tkadd(fileMenu, "command", label=gettextRcmdr("Exit editor"), command=onOK)
tkadd(fileMenu, "command", label=gettextRcmdr("Cancel"), command=onCancel)
tkadd(editorMenu, "cascade", label=gettextRcmdr("File"), menu=fileMenu)
editMenu <- tkmenu(editorMenu, tearoff=FALSE)
if (!is.null(edit.menu)){
for (item in edit.menu){
tkadd(editMenu, "command", label=gettextRcmdr(item$label), command=item$command)
}
tkadd(editMenu, "separator")
}
tkadd(editMenu, "command", label=gettextRcmdr("Cut"), command=onCut)
tkadd(editMenu, "command", label=gettextRcmdr("Copy"), command=onCopy)
tkadd(editMenu, "command", label=gettextRcmdr("Paste"), command=onPaste)
tkadd(editMenu, "command", label=gettextRcmdr("Delete"), command=onDelete)
tkadd(editMenu, "separator")
tkadd(editMenu, "command", label=gettextRcmdr("Find..."), command=onFind)
tkadd(editMenu, "command", label=gettextRcmdr("Select all"), command=onSelectAll)
tkadd(editMenu, "separator")
tkadd(editMenu, "command", label=gettextRcmdr("Undo"), command=onUndo)
tkadd(editMenu, "command", label=gettextRcmdr("Redo"), command=onRedo)
tkadd(editMenu, "separator")
tkadd(editMenu, "command", label=gettextRcmdr("Clear window"), command=onClear)
tkadd(editorMenu, "cascade", label=gettextRcmdr("Edit"), menu=editMenu)
helpMenu <- tkmenu(editorMenu, tearoff=FALSE)
onEditorHelp <- function() print(help("ScriptEditor", package="Rcmdr"))
tkadd(helpMenu, "command", label=gettextRcmdr("Editor help"), command=onEditorHelp)
if (!is.null(help)){
tkadd(helpMenu, "command", label=gettextRcmdr(help$label), command=help$command)
}
tkadd(editorMenu, "cascade", label=gettextRcmdr("Help"), menu=helpMenu)
tkgrid(editor, editorYscroll, sticky = "nsew")
tkgrid(editorXscroll)
if (!is.null(toolbar.buttons)){
for (i in 1:length(toolbar.buttons)){
tkgrid(eval(parse(text=paste("button", i, sep=""))), sticky="w", row=0, column=i - 1,
padx=c(3, 3), pady=c(0, 8))
}
}
else i <- 0
tkgrid(cutButton, sticky="w", row=0, column=i, padx=c(3, 3), pady=c(0, 8))
tkgrid(copyButton, sticky="w", row=0, column=i + 1, padx=c(3, 3), pady=c(0, 8))
tkgrid(pasteButton, sticky="w", row=0, column=i + 2, padx=c(3, 3), pady=c(0, 8))
tkgrid(deleteButton, sticky="w", row=0, column=i + 3, padx=c(3, 3), pady=c(0, 8))
tkgrid(undoButton, sticky="w", row=0, column=i + 4, padx=c(3, 3), pady=c(0, 8))
tkgrid(redoButton, sticky="w", row=0, column=i + 5, padx=c(3, 3), pady=c(0, 8))
tkgrid(findButton, sticky="w", row=0, column=i + 6, padx=c(3, 3), pady=c(0, 8))
tkgrid(toolbarFrame, sticky="w")
tk2tip(cutButton, gettextRcmdr("Cut"))
tk2tip(copyButton, gettextRcmdr("Copy"))
tk2tip(pasteButton, gettextRcmdr("Paste"))
tk2tip(deleteButton, gettextRcmdr("Delete"))
tk2tip(undoButton, gettextRcmdr("Undo"))
tk2tip(redoButton, gettextRcmdr("Redo"))
tk2tip(findButton, gettextRcmdr("Find"))
tkgrid(editorFrame, sticky = "nsew")
tkgrid.configure(editorXscroll, sticky = "ew")
tkgrid.configure(editorYscroll, sticky = "ns")
tkgrid.configure(editor, sticky = "nsew")
tkgrid.configure(editorFrame, sticky = "nsew")
tkgrid(buttonsFrame, sticky = "ew")
tkbind(top, "<ButtonPress-3>", contextMenu)
tkbind(top, "<Control-x>", onCut)
tkbind(top, "<Control-X>", onCut)
tkbind(top, "<Control-c>", onCopy)
tkbind(top, "<Control-C>", onCopy)
tkbind(top, "<Control-f>", onFind)
tkbind(top, "<Control-F>", onFind)
tkbind(top, "<F3>", onFind)
tkbind(top, "<Control-a>", onSelectAll)
tkbind(top, "<Control-A>", onSelectAll)
tkbind(top, "<Control-w>", onRedo)
tkbind(top, "<Control-W>", onRedo)
tkbind(top, "<Alt-BackSpace>", onUndo)
if (MacOSXP()){
tkbind(top, "<Meta-x>", onCut)
tkbind(top, "<Meta-X>", onCut)
tkbind(top, "<Meta-c>", onCopy)
tkbind(top, "<Meta-C>", onCopy)
tkbind(top, "<Meta-v>", onPaste)
tkbind(top, "<Meta-V>", onPaste)
tkbind(top, "<Meta-f>", onFind)
tkbind(top, "<Meta-F>", onFind)
tkbind(top, "<Meta-a>", onSelectAll)
tkbind(top, "<Meta-A>", onSelectAll)
tkbind(top, "<Meta-w>", onRedo)
tkbind(top, "<Meta-W>", onRedo)
}
tkwm.protocol(top, "WM_DELETE_WINDOW", onCancel)
tkgrid.rowconfigure(top, 1, weight=0)
tkgrid.rowconfigure(top, 0, weight=1)
tkgrid.columnconfigure(top, 0, weight=1)
tkgrid.rowconfigure(editorFrame, 1, weight=0)
tkgrid.rowconfigure(editorFrame, 0, weight=1)
tkgrid.columnconfigure(editorFrame, 0, weight=1)
tkgrid.columnconfigure(editorFrame, 1, weight=0)
dialogSuffix(bindReturn = FALSE, resizable=TRUE, focus=editor)
}
# the rgb2col function translates #RRGGBB colors to names if a named color exists or otherwise a "close" color (not exported)
# uses code from r-help adapted from Kevin Wright
rgb2col <- local({
all.names <- colors(distinct=TRUE)
all.lab <- t(convertColor(t(col2rgb(all.names)), from = "sRGB",
to = "Lab", scale.in = 255))
findNear <- function(x.lab) {
sq.dist <- colSums((all.lab - x.lab)^2)
rbind(all.names[which.min(sq.dist)], min(sq.dist))
}
function(cols.hex, near = 15) { # near = 2.3 is nominally the JND
cols.lab <- t(convertColor(t(col2rgb(cols.hex)), from = "sRGB",
to = "Lab", scale.in = 255))
cols.near <- apply(cols.lab, 2, findNear)
ifelse(as.numeric(cols.near[2, ]) < near^2, cols.near[1, ], toupper(cols.hex))
}
})
# the following function is for plug-ins that test for SciViews (which is no longer supported)
is.SciViews <- function() FALSE
# the following two functions from Milan Bouchet-Valat
setBusyCursor <- function() {
.commander <- CommanderWindow()
.menu <- tkcget(.commander, menu=NULL)
.log <- LogWindow()
.output <- OutputWindow()
.messages <- MessagesWindow()
tkconfigure(.commander, cursor="watch")
tkconfigure(.menu, cursor="watch")
tkconfigure(.log, cursor="watch")
tkconfigure(.output, cursor="watch")
tkconfigure(.messages, cursor="watch")
}
setIdleCursor <- function() {
.commander <- CommanderWindow()
.menu <- tkcget(.commander, menu=NULL)
.log <- LogWindow()
.output <- OutputWindow()
.messages <- MessagesWindow()
tkconfigure(.commander, cursor="")
tkconfigure(.menu, cursor="")
tkconfigure(.log, cursor="xterm")
tkconfigure(.output, cursor="xterm")
tkconfigure(.messages, cursor="xterm")
}
Try the Rcmdr205 package in your browser
Any scripts or data that you put into this service are public.
Rcmdr205 documentation built on May 2, 2019, 5:52 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
# last modified 2014-03-27 by M. Bouchet-Valat
# utility functions
# listing objects etc.
listDataSets <- function(envir=.GlobalEnv, ...) {
Vars <- ls(envir = envir, all.names = TRUE) # + PhG
if (length(Vars) == 0) return(Vars) # + PhG
names(which(sapply(Vars, function(.x) is.data.frame(get(.x, envir=envir)))))
}
listLinearModels <- function(envir=.GlobalEnv, ...) {
objects <- ls(envir=envir, ...)
if (length(objects) == 0) NULL
else objects[sapply(objects,
function(.x) "lm" == (class(get(.x, envir=envir))[1]))]
}
listAOVModels <- function(envir=.GlobalEnv, ...) {
objects <- ls(envir=envir, ...)
if (length(objects) == 0) NULL
else objects[sapply(objects,
function(.x) "aov" == (class(get(.x, envir=envir))[1]))]
}
listGeneralizedLinearModels <- function(envir=.GlobalEnv, ...) {
objects <- ls(envir=envir, ...)
if (length(objects) == 0) NULL
else objects[sapply(objects,
function(.x) "glm" == (class(get(.x, envir=envir))[1]))]
}
listMultinomialLogitModels <- function(envir=.GlobalEnv, ...) {
objects <- ls(envir=envir, ...)
if (length(objects) == 0) NULL
else objects[sapply(objects,
function(.x) "multinom" == (class(get(.x, envir=envir))[1]))]
}
listProportionalOddsModels <- function(envir=.GlobalEnv, ...) {
objects <- ls(envir=envir, ...)
if (length(objects) == 0) NULL
else objects[sapply(objects,
function(.x) "polr" == (class(get(.x, envir=envir))[1]))]
}
listAllModels <- function(envir=.GlobalEnv, ...) {
objects <- ls(envir=envir, ...)
if (length(objects) == 0) NULL
else objects[sapply(objects,
function(.x) (class(get(.x, envir=envir))[1])) %in% getRcmdr("modelClasses")]
}
activeDataSet <- function(dsname, flushModel=TRUE, flushDialogMemory=TRUE){
.activeDataSet <- ActiveDataSet()
if (missing(dsname)) {
if (is.null(.activeDataSet)){
Message(message=gettextRcmdr("There is no active data set."), type="error")
return(FALSE)
}
else return(.activeDataSet)
}
if (!is.data.frame(ds <- get(dsname, envir=.GlobalEnv))){
if (!exists.method("as.data.frame", ds, default=FALSE)){
Message(message=paste(dsname, gettextRcmdr(" is not a data frame and cannot be attached."),
sep=""), type="error")
tkfocus(CommanderWindow())
return()
}
command <- paste(dsname, " <- as.data.frame(", dsname, ")", sep="")
justDoIt(command)
logger(command)
Message(message=paste(dsname, gettextRcmdr(" has been coerced to a data frame"), sep=""),
type="warning")
}
varnames <- names(get(dsname, envir=.GlobalEnv))
newnames <- make.names(varnames)
badnames <- varnames != newnames
if (any(badnames)){
command <- paste("names(", dsname, ") <- make.names(names(",
dsname, "))", sep="")
doItAndPrint(command)
}
if (!is.null(.activeDataSet) && getRcmdr("attach.data.set")
&& (length(grep(.activeDataSet, search())) !=0)) {
detach(pos = match(.activeDataSet, search()))
logger(paste("detach(", .activeDataSet, ")", sep=""))
}
if (flushModel) {
putRcmdr(".activeModel", NULL)
RcmdrTclSet("modelName", gettextRcmdr("<No active model>"))
tkconfigure(getRcmdr("modelLabel"), foreground="red")
}
if (flushDialogMemory) putRcmdr("dialog.values", list())
ActiveDataSet(dsname)
Message(sprintf(gettextRcmdr("The dataset %s has %d rows and %d columns."), dsname,
nrow(get(dsname, envir=.GlobalEnv)), ncol(get(dsname, envir=.GlobalEnv))), type="note")
if (any(badnames)) Message(message=paste(dsname, gettextRcmdr(" contains non-standard variable names:\n"),
paste(varnames[badnames], collapse=", "),
gettextRcmdr("\nThese have been changed to:\n"), paste(newnames[badnames], collapse=", "),
sep=""), type="warning")
RcmdrTclSet("dataSetName", paste(" ", dsname, " "))
tkconfigure(getRcmdr("dataSetLabel"), foreground="blue")
activateMenus()
dsname
}
activeModel <- function(model){
if (missing(model)) {
.activeModel <- ActiveModel()
if (is.null(.activeModel)){
Message(message=gettextRcmdr("There is no active model."), type="error")
return(FALSE)
}
else return(.activeModel)
}
ActiveModel(model)
RcmdrTclSet("modelName", paste(" ", model, " "))
tkconfigure(getRcmdr("modelLabel"), foreground="blue")
activateMenus()
model
}
listVariables <- function(dataSet=ActiveDataSet()) {
if(missing(dataSet)) {
Variables()
}
else {
vars <- names(get(dataSet, envir=.GlobalEnv))
if (getRcmdr("sort.names")) sortVarNames(vars) else vars
}
}
listFactors <- function(dataSet=ActiveDataSet()) {
if(missing(dataSet)) {
Factors()
}
else {
variables <- listVariables(dataSet)
variables[sapply(variables, function(.x)
is.factor(eval(parse(text=.x), envir=get(dataSet, envir=.GlobalEnv))))]
}
}
listTwoLevelFactors <- function(dataSet=ActiveDataSet()){
if(missing(dataSet)) {
TwoLevelFactors()
}
else {
factors <- listFactors(dataSet)
if(length(factors) == 0) return(NULL)
factors[sapply(factors, function(.x)
2 == length(levels(eval(parse(text=.x), envir=get(dataSet, envir=.GlobalEnv)))))]
}
}
listNumeric <- function(dataSet=ActiveDataSet()) {
if(missing(dataSet)) {
Numeric()
}
else {
variables <- listVariables(dataSet)
variables[sapply(variables,function(.x)
is.numeric(eval(parse(text=.x), envir=get(dataSet, envir=.GlobalEnv))))]
}
}
trim.blanks <- function(text){
gsub("^\ *", "", gsub("\ *$", "", text))
}
is.valid.name <- function(x){
length(x) == 1 && is.character(x) && x == make.names(x)
}
# statistical
colPercents <- function(tab, digits=1){
dim <- length(dim(tab))
if (is.null(dimnames(tab))){
dims <- dim(tab)
dimnames(tab) <- lapply(1:dim, function(i) 1:dims[i])
}
sums <- apply(tab, 2:dim, sum)
per <- apply(tab, 1, function(x) x/sums)
dim(per) <- dim(tab)[c(2:dim,1)]
per <- aperm(per, c(dim, 1:(dim-1)))
dimnames(per) <- dimnames(tab)
per <- round(100*per, digits)
result <- abind(per, Total=apply(per, 2:dim, sum), Count=sums, along=1)
names(dimnames(result)) <- names(dimnames(tab))
result
}
rowPercents <- function(tab, digits=1){
dim <- length(dim(tab))
if (dim == 2) return(t(colPercents(t(tab), digits=digits)))
tab <- aperm(tab, c(2,1,3:dim))
aperm(colPercents(tab, digits=digits), c(2,1,3:dim))
}
totPercents <- function(tab, digits=1){
dim <- length(dim(tab))
if (is.null(dimnames(tab))){
dims <- dim(tab)
dimnames(tab) <- lapply(1:dim, function(i) 1:dims[i])
}
tab <- 100*tab/sum(tab)
tab <- cbind(tab, rowSums(tab))
tab <- rbind(tab, colSums(tab))
rownames(tab)[nrow(tab)] <- "Total"
colnames(tab)[ncol(tab)] <- "Total"
round(tab, digits=digits)
}
reliability <- function(S){
reliab <- function(S, R){
k <- dim(S)[1]
ones <- rep(1, k)
v <- as.vector(ones %*% S %*% ones)
alpha <- (k/(k - 1)) * (1 - (1/v)*sum(diag(S)))
rbar <- mean(R[lower.tri(R)])
std.alpha <- k*rbar/(1 + (k - 1)*rbar)
c(alpha=alpha, std.alpha=std.alpha)
}
result <- list()
if ((!is.numeric(S)) || !is.matrix(S) || (nrow(S) != ncol(S))
|| any(abs(S - t(S)) > max(abs(S))*1e-10) || nrow(S) < 2)
stop(gettextRcmdr("argument must be a square, symmetric, numeric covariance matrix"))
k <- dim(S)[1]
s <- sqrt(diag(S))
R <- S/(s %o% s)
rel <- reliab(S, R)
result$alpha <- rel[1]
result$st.alpha <- rel[2]
if (k < 3) {
warning(gettextRcmdr("there are fewer than 3 items in the scale"))
return(invisible(NULL))
}
rel <- matrix(0, k, 3)
for (i in 1:k) {
rel[i, c(1,2)] <- reliab(S[-i, -i], R[-i, -i])
a <- rep(0, k)
b <- rep(1, k)
a[i] <- 1
b[i] <- 0
cov <- a %*% S %*% b
var <- b %*% S %*% b
rel[i, 3] <- cov/(sqrt(var * S[i,i]))
}
rownames(rel) <- rownames(S)
colnames(rel) <- c("Alpha", "Std.Alpha", "r(item, total)")
result$rel.matrix <- rel
class(result) <- "reliability"
result
}
print.reliability <- function(x, digits=4, ...){
cat(paste("Alpha reliability = ", round(x$alpha, digits), "\n"))
cat(paste("Standardized alpha = ", round(x$st.alpha, digits), "\n"))
cat("\nReliability deleting each item in turn:\n")
print(round(x$rel.matrix, digits))
invisible(x)
}
partial.cor <- function(X, tests=FALSE, use=c("complete.obs", "pairwise.complete.obs")){
countValid <- function(X){
X <- !is.na(X)
t(X) %*% X
}
use <- match.arg(use)
if (use == "complete.obs"){
X <- na.omit(X)
n <- nrow(X)
}
else n <- countValid(X)
R <- cor(X, use=use)
RI <- solve(R)
D <- 1/sqrt(diag(RI))
R <- - RI * (D %o% D)
diag(R) <- 0
rownames(R) <- colnames(R) <- colnames(X)
result <- list(R=R, n=n, P=NULL, P.unadj=NULL)
if (tests){
opt <- options(scipen=5)
on.exit(options(opt))
df <- n - ncol(X)
f <- (R^2)*df/(1 - R^2)
P <- P.unadj <- pf(f, 1, df, lower.tail=FALSE)
p <- P[lower.tri(P)]
adj.p <- p.adjust(p, method="holm")
P[lower.tri(P)] <- adj.p
P[upper.tri(P)] <- 0
P <- P + t(P)
P <- ifelse(P < 1e-04, 0, P)
P <- format(round(P, 4))
diag(P) <- ""
P[grep("0.0000", P)] <- "<.0001"
P.unadj <- ifelse(P.unadj < 1e-04, 0, P.unadj)
P.unadj <- format(round(P.unadj, 4))
diag(P.unadj) <- ""
P.unadj[grep("0.0000", P.unadj)] <- "<.0001"
result$P <- P
result$P.unadj <- P.unadj
}
class(result) <- "partial.cor"
result
}
print.partial.cor <- function(x, digits=max(3, getOption("digits") - 2), ...){
cat("\n Partial correlations:\n")
print(round(x$R, digits, ...))
cat("\n Number of observations: ")
n <- x$n
if (all(n[1] == n)) cat(n[1], "\n")
else{
cat("\n")
print(n)
}
if (!is.null(x$P)){
cat("\n Pairwise two-sided p-values:\n")
print(x$P.unadj, quote=FALSE)
cat("\n Adjusted p-values (Holm's method)\n")
print(x$P, quote=FALSE)
}
x
}
Confint <- function(object, parm, level=0.95, ...) UseMethod("Confint")
Confint.default <- function(object, parm, level = 0.95, ...) {
ci <- confint(object, parm, level, ...)
ci <- cbind(coef(object), ci)
colnames(ci)[1] <- "Estimate"
ci
}
Confint.glm <- function (object, parm, level=0.95, type=c("LR", "Wald"), ...){
# adapted from stats:::confint.lm
type <- match.arg(type)
cf <- coef(object)
pnames <- names(cf)
if (type == "LR")
ci <- confint.glm(object, parm, level, ...)
else {
if (missing(parm))
parm <- seq(along = pnames)
else if (is.character(parm))
parm <- match(parm, pnames, nomatch = 0)
a <- (1 - level)/2
a <- c(a, 1 - a)
pct <- paste(round(100 * a, 1), "%")
ci <- array(NA, dim = c(length(parm), 2), dimnames = list(pnames[parm],
pct))
ses <- sqrt(diag(vcov(object)))[parm]
fac <- qnorm(a)
ci[] <- cf[parm] + ses %o% fac
}
ci <- cbind(cf, ci)
colnames(ci)[1] <- "Estimate"
fam <- family(object)
if (fam$family == "binomial" && fam$link == "logit"){
expci <- exp(ci)
colnames(expci)[1] <- "exp(Estimate)"
ci <- cbind(ci, expci)
}
ci
}
confint.polr <- function (object, parm, level=0.95, ...){
# adapted from stats:::confint.lm
cf <- coef(object)
pnames <- names(cf)
if (missing(parm))
parm <- seq(along = pnames)
else if (is.character(parm))
parm <- match(parm, pnames, nomatch = 0)
a <- (1 - level)/2
a <- c(a, 1 - a)
pct <- paste(round(100 * a, 1), "%")
ci <- array(NA, dim = c(length(parm), 2), dimnames = list(pnames[parm],
pct))
ses <- sqrt(diag(vcov(object)))[parm]
fac <- qnorm(a)
ci[] <- cf[parm] + ses %o% fac
ci
}
confint.multinom <- function (object, parm, level=0.95, ...){
# adapted from stats:::confint.lm
require("abind")
cf <- coef(object)
if (is.vector(cf)) cf <- matrix(cf, nrow=1,
dimnames=list(object$lev[2], names(cf)))
pnames <- colnames(cf)
if (missing(parm))
parm <- seq(along = pnames)
else if (is.character(parm))
parm <- match(parm, pnames, nomatch = 0)
a <- (1 - level)/2
a <- c(a, 1 - a)
ses <- matrix(sqrt(diag(vcov(object))),
ncol=ncol(cf), byrow=TRUE)[,parm, drop=FALSE]
cf <- cf[,parm, drop=FALSE]
fac <- qnorm(a)
ci <- abind(cf + fac[1]*ses, cf + fac[2]*ses, along=3)
dimnames(ci)[[3]] <- paste(round(100 * a, 1), "%")
aperm(ci, c(2,3,1))
}
Confint.multinom <- function(object, parm, level = 0.95, ...) confint (object, parm=parm, level=0.95, ...)
numSummary <- function(data,
statistics=c("mean", "sd", "IQR", "quantiles", "cv", "skewness", "kurtosis"),
type=c("2", "1", "3"),
quantiles=c(0, .25, .5, .75, 1), groups){
sd <- function(x, type, ...){
apply(as.matrix(x), 2, stats::sd, na.rm=TRUE)
}
IQR <- function(x, type, ...){
apply(as.matrix(x), 2, stats::IQR, na.rm=TRUE)
}
cv <- function(x, ...){
x <- as.matrix(x)
mean <- colMeans(x, na.rm=TRUE)
sd <- sd(x)
if (any(x <= 0, na.rm=TRUE)) warning("not all values are positive")
cv <- sd/mean
cv[mean <= 0] <- NA
cv
}
skewness <- function(x, type, ...){
if (is.vector(x)) return(e1071::skewness(x, type=type, na.rm=TRUE))
apply(x, 2, skewness, type=type)
}
kurtosis <- function(x, type, ...){
if (is.vector(x)) return(e1071::kurtosis(x, type=type, na.rm=TRUE))
apply(x, 2, kurtosis, type=type)
}
if(!require(abind)) stop("abind package missing")
if(!require(e1071)) stop("e1071 package missing")
data <- as.data.frame(data)
if (!missing(groups)) {
groups <- as.factor(groups)
counts <- table(groups)
if (any(counts == 0)){
levels <- levels(groups)
warning("the following groups are empty: ", paste(levels[counts == 0], collapse=", "))
groups <- factor(groups, levels=levels[counts != 0])
}
}
variables <- names(data)
if (missing(statistics)) statistics <- c("mean", "sd", "quantiles", "IQR")
statistics <- match.arg(statistics, c("mean", "sd", "IQR", "quantiles", "cv", "skewness", "kurtosis"),
several.ok=TRUE)
type <- match.arg(type)
type <- as.numeric(type)
ngroups <- if(missing(groups)) 1 else length(grps <- levels(groups))
quantiles <- if ("quantiles" %in% statistics) quantiles else NULL
quants <- if (length(quantiles) > 1) paste(100*quantiles, "%", sep="") else NULL
nquants <- length(quants)
stats <- c(c("mean", "sd", "IQR", "cv", "skewness", "kurtosis")[c("mean", "sd", "IQR", "cv", "skewness", "kurtosis") %in% statistics], quants)
nstats <- length(stats)
nvars <- length(variables)
result <- list()
if ((ngroups == 1) && (nvars == 1) && (length(statistics) == 1)){
if (statistics == "quantiles")
table <- quantile(data[,variables], probs=quantiles, na.rm=TRUE)
else {
table <- do.call(statistics, list(x=data[,variables], na.rm=TRUE, type=type))
names(table) <- statistics
}
NAs <- sum(is.na(data[,variables]))
n <- nrow(data) - NAs
result$type <- 1
}
else if ((ngroups > 1) && (nvars == 1) && (length(statistics) == 1)){
if (statistics == "quantiles"){
table <- matrix(unlist(tapply(data[, variables], groups,
quantile, probs=quantiles, na.rm=TRUE)), ngroups, nquants,
byrow=TRUE)
rownames(table) <- grps
colnames(table) <- quants
}
else table <- tapply(data[,variables], groups, statistics,
na.rm=TRUE, type=type)
NAs <- tapply(data[, variables], groups, function(x)
sum(is.na(x)))
n <- table(groups) - NAs
result$type <- 2
}
else if ((ngroups == 1) ){
X <- as.matrix(data[, variables])
table <- matrix(0, nvars, nstats)
rownames(table) <- if (length(variables) > 1) variables else ""
colnames(table) <- stats
if ("mean" %in% stats) table[,"mean"] <- colMeans(X, na.rm=TRUE)
if ("sd" %in% stats) table[,"sd"] <- sd(X)
if ("IQR" %in% stats) table[, "IQR"] <- IQR(X)
if ("cv" %in% stats) table[,"cv"] <- cv(X)
if ("skewness" %in% statistics) table[, "skewness"] <- skewness(X, type=type)
if ("kurtosis" %in% statistics) table[, "kurtosis"] <- kurtosis(X, type=type)
if ("quantiles" %in% statistics){
table[,quants] <- t(apply(data[, variables, drop=FALSE], 2, quantile,
probs=quantiles, na.rm=TRUE))
}
NAs <- colSums(is.na(data[, variables, drop=FALSE]))
n <- nrow(data) - NAs
result$type <- 3
}
else {
table <- array(0, c(ngroups, nstats, nvars),
dimnames=list(Group=grps, Statistic=stats, Variable=variables))
NAs <- matrix(0, nvars, ngroups)
rownames(NAs) <- variables
colnames(NAs) <- grps
for (variable in variables){
if ("mean" %in% stats)
table[, "mean", variable] <- tapply(data[, variable],
groups, mean, na.rm=TRUE)
if ("sd" %in% stats)
table[, "sd", variable] <- tapply(data[, variable],
groups, sd, na.rm=TRUE)
if ("IQR" %in% stats)
table[, "IQR", variable] <- tapply(data[, variable],
groups, IQR, na.rm=TRUE)
if ("cv" %in% stats)
table[, "cv", variable] <- tapply(data[, variable],
groups, cv)
if ("skewness" %in% stats)
table[, "skewness", variable] <- tapply(data[, variable],
groups, skewness, type=type)
if ("kurtosis" %in% stats)
table[, "kurtosis", variable] <- tapply(data[, variable],
groups, kurtosis, type=type)
if ("quantiles" %in% statistics) {
res <- matrix(unlist(tapply(data[, variable], groups,
quantile, probs=quantiles, na.rm=TRUE)), ngroups, nquants,
byrow=TRUE)
table[, quants, variable] <- res
}
NAs[variable,] <- tapply(data[, variable], groups, function(x)
sum(is.na(x)))
}
if (nstats == 1) table <- table[,1,]
if (nvars == 1) table <- table[,,1]
n <- table(groups)
n <- matrix(n, nrow=nrow(NAs), ncol=ncol(NAs), byrow=TRUE)
n <- n - NAs
result$type <- 4
}
result$table <- table
result$statistics <- statistics
result$n <- n
if (any(NAs > 0)) result$NAs <- NAs
class(result) <- "numSummary"
result
}
print.numSummary <- function(x, ...){
NAs <- x$NAs
table <- x$table
n <- x$n
statistics <- x$statistics
switch(x$type,
"1" = {
if (!is.null(NAs)) {
table <- c(table, n, NAs)
names(table)[length(table) - 1:0] <- c("n", "NA")
}
print(table)
},
"2" = {
if (statistics == "quantiles") {
table <- cbind(table, n)
colnames(table)[ncol(table)] <- "n"
if (!is.null(NAs)) {
table <- cbind(table, NAs)
colnames(table)[ncol(table)] <- "NA"
}
}
else {
table <- rbind(table, n)
rownames(table)[c(1, nrow(table))] <- c(statistics, "n")
if (!is.null(NAs)) {
table <- rbind(table, NAs)
rownames(table)[nrow(table)] <- "NA"
}
table <- t(table)
}
print(table)
},
"3" = {
table <- cbind(table, n)
colnames(table)[ncol(table)] <- "n"
if (!is.null(NAs)) {
table <- cbind(table, NAs)
colnames(table)[ncol(table)] <- "NA"
}
print(table)
},
"4" = {
if (length(dim(table)) == 2){
n <- t(n)
nms <- colnames(n)
colnames(n) <- paste(nms, ":n", sep="")
table <- cbind(table, n)
if (!is.null(NAs)) {
NAs <- t(NAs)
nms <- colnames(NAs)
colnames(NAs) <- paste(nms, ":NA", sep="")
table <- cbind(table, NAs)
}
print(table)
}
else {
table <- abind(table, t(n), along=2)
dimnames(table)[[2]][dim(table)[2]] <- "n"
if (!is.null(NAs)) {
table <- abind(table, t(NAs), along=2)
dimnames(table)[[2]][dim(table)[2]] <- "NA"
}
nms <- dimnames(table)[[3]]
for (name in nms){
cat("\nVariable:", name, "\n")
print(table[,,name])
}
}
}
)
invisible(x)
}
stepwise <- function(mod,
direction=c("backward/forward", "forward/backward", "backward", "forward"),
criterion=c("BIC", "AIC"), ...){
if (!require(MASS)) stop("MASS package not available")
criterion <- match.arg(criterion)
cat("\nDirection: ", direction)
cat("\nCriterion: ", criterion, "\n\n")
k <- if (criterion == "BIC") log(nrow(model.matrix(mod))) else 2
rhs <- paste(c("~", deparse(formula(mod)[[3]])), collapse="")
rhs <- gsub(" ", "", rhs)
if (direction == "forward" || direction == "forward/backward")
mod <- update(mod, . ~ 1)
if (direction == "backward/forward" || direction == "forward/backward") direction <- "both"
lower <- ~ 1
upper <- eval(parse(text=rhs))
stepAIC(mod, scope=list(lower=lower, upper=upper), direction=direction, k=k, ...)
}
# wrapper function for histograms
Hist <- function(x, groups, scale=c("frequency", "percent", "density"), xlab=deparse(substitute(x)),
ylab=scale, main="", breaks="Sturges", ...){
xlab # evaluate
scale <- match.arg(scale)
ylab
if (!missing(groups)){
levels <- levels(groups)
hists <- lapply(levels, function(level) hist(x[groups == level], plot=FALSE, breaks=breaks))
range.x <- range(unlist(lapply(hists, function(hist) hist$breaks)))
n.breaks <- max(sapply(hists, function(hist) length(hist$breaks)))
breaks. <- seq(range.x[1], range.x[2], length=n.breaks)
hists <- lapply(levels, function(level) hist(x[groups == level], plot=FALSE, breaks=breaks.))
ylim <- if (scale == "frequency"){
max(sapply(hists, function(hist) max(hist$counts)))
}
else if (scale == "density"){
max(sapply(hists, function(hist) max(hist$density)))
}
else {
max.counts <- sapply(hists, function(hist) max(hist$counts))
tot.counts <- sapply(hists, function(hist) sum(hist$counts))
ylims <- tot.counts*(max(max.counts/tot.counts))
names(ylims) <- levels
ylims
}
save.par <- par(mfrow=n2mfrow(length(levels)), oma = c(0, 0, if (main != "") 1.5 else 0, 0))
on.exit(par(save.par))
for (level in levels){
if (scale != "percent") Hist(x[groups == level], scale=scale, xlab=xlab, ylab=ylab,
main=paste(deparse(substitute(groups)), "=", level), breaks=breaks., ylim=c(0, ylim), ...)
else Hist(x[groups == level], scale=scale, xlab=xlab, ylab=ylab,
main=paste(deparse(substitute(groups)), "=", level), breaks=breaks., ylim=c(0, ylim[level]), ...)
}
if (main != "") mtext(side = 3, outer = TRUE, main, cex = 1.2)
return(invisible(NULL))
}
x <- na.omit(x)
if (scale == "frequency") hist(x, xlab=xlab, ylab=ylab, main=main, breaks=breaks, ...)
else if (scale == "density") hist(x, freq=FALSE, xlab=xlab, ylab=ylab, main=main, breaks=breaks, ...)
else {
n <- length(x)
hist(x, axes=FALSE, xlab=xlab, ylab=ylab, main=main, breaks=breaks, ...)
axis(1)
max <- ceiling(10*par("usr")[4]/n)
at <- if (max <= 3) (0:(2*max))/20
else (0:max)/10
axis(2, at=at*n, labels=at*100)
}
box()
abline(h=0)
invisible(NULL)
}
plotMeans <- function(response, factor1, factor2, error.bars = c("se", "sd", "conf.int", "none"),
level=0.95, xlab=deparse(substitute(factor1)), ylab=paste("mean of", deparse(substitute(response))),
legend.lab=deparse(substitute(factor2)), main="Plot of Means",
pch=1:n.levs.2, lty=1:n.levs.2, col=palette(), ...){
if (!is.numeric(response)) stop(gettextRcmdr("Argument response must be numeric."))
xlab # force evaluation
ylab
legend.lab
error.bars <- match.arg(error.bars)
if (missing(factor2)){
if (!is.factor(factor1)) stop(gettextRcmdr("Argument factor1 must be a factor."))
valid <- complete.cases(factor1, response)
factor1 <- factor1[valid]
response <- response[valid]
means <- tapply(response, factor1, mean)
sds <- tapply(response, factor1, sd)
ns <- tapply(response, factor1, length)
if (error.bars == "se") sds <- sds/sqrt(ns)
if (error.bars == "conf.int") sds <- qt((1 - level)/2, df=ns - 1, lower.tail=FALSE) * sds/sqrt(ns)
sds[is.na(sds)] <- 0
yrange <- if (error.bars != "none") c( min(means - sds, na.rm=TRUE), max(means + sds, na.rm=TRUE)) else range(means, na.rm=TRUE)
levs <- levels(factor1)
n.levs <- length(levs)
plot(c(1, n.levs), yrange, type="n", xlab=xlab, ylab=ylab, axes=FALSE, main=main, ...)
points(1:n.levs, means, type="b", pch=16, cex=2)
box()
axis(2)
axis(1, at=1:n.levs, labels=levs)
if (error.bars != "none") arrows(1:n.levs, means - sds, 1:n.levs, means + sds,
angle=90, lty=2, code=3, length=0.125)
}
else {
if (!(is.factor(factor1) | is.factor(factor2))) stop(gettextRcmdr("Arguments factor1 and factor2 must be factors."))
valid <- complete.cases(factor1, factor2, response)
factor1 <- factor1[valid]
factor2 <- factor2[valid]
response <- response[valid]
means <- tapply(response, list(factor1, factor2), mean)
sds <- tapply(response, list(factor1, factor2), sd)
ns <- tapply(response, list(factor1, factor2), length)
if (error.bars == "se") sds <- sds/sqrt(ns)
if (error.bars == "conf.int") sds <- qt((1 - level)/2, df=ns - 1, lower.tail=FALSE) * sds/sqrt(ns)
sds[is.na(sds)] <- 0
yrange <- if (error.bars != "none") c( min(means - sds, na.rm=TRUE), max(means + sds, na.rm=TRUE)) else range(means, na.rm=TRUE)
levs.1 <- levels(factor1)
levs.2 <- levels(factor2)
n.levs.1 <- length(levs.1)
n.levs.2 <- length(levs.2)
if (length(pch) == 1) pch <- rep(pch, n.levs.2)
if (length(col) == 1) col <- rep(col, n.levs.2)
if (length(lty) == 1) lty <- rep(lty, n.levs.2)
if (n.levs.2 > length(col)) stop(sprintf(gettextRcmdr("Number of groups for factor2, %d, exceeds number of distinct colours, %d."), n.levs.2, length(col)))
plot(c(1, n.levs.1 * 1.4), yrange, type="n", xlab=xlab, ylab=ylab, axes=FALSE, main=main, ...)
box()
axis(2)
axis(1, at=1:n.levs.1, labels=levs.1)
for (i in 1:n.levs.2){
points(1:n.levs.1, means[, i], type="b", pch=pch[i], cex=2, col=col[i], lty=lty[i])
if (error.bars != "none") arrows(1:n.levs.1, means[, i] - sds[, i],
1:n.levs.1, means[, i] + sds[, i], angle=90, code=3, col=col[i], lty=lty[i], length=0.125)
}
x.posn <- n.levs.1 * 1.1
y.posn <- sum(c(0.1, 0.9) * par("usr")[c(3,4)])
text(x.posn, y.posn, legend.lab, adj=c(0, -.5))
legend(x.posn, y.posn, levs.2, pch=pch, col=col, lty=lty)
}
invisible(NULL)
}
lineplot <- function(x, ..., legend){
xlab <- deparse(substitute(x))
y <- cbind(...)
m <- ncol(y)
legend <- if (missing(legend)) m > 1
if (legend && m > 1) {
mar <- par("mar")
top <- 3.5 + m
old.mar <- par(mar=c(mar[1:2], top, mar[4]))
on.exit(par(old.mar))
}
if (m > 1) matplot(x, y, type="b", lty=1, xlab=xlab, ylab="")
else plot(x, y, type="b", pch=16, xlab=xlab, ylab=colnames(y))
if (legend && ncol(y) > 1){
xpd <- par(xpd=TRUE)
on.exit(par(xpd), add=TRUE)
ncols <- length(palette())
cols <- rep(1:ncols, 1 + m %/% ncols)[1:m]
usr <- par("usr")
legend(usr[1], usr[4] + 1.2*top*strheight("x"),
legend=colnames(y), col=cols, lty=1, pch=as.character(1:m))
}
return(invisible(NULL))
}
indexplot <- function(x, labels=seq_along(x), id.method="y", type="h", id.n=0, ylab, ...){
if (missing(ylab)) ylab <- deparse(substitute(x))
plot(x, type=type, ylab=ylab, xlab="Observation Index", ...)
if (par("usr")[3] <= 0) abline(h=0, col='gray')
ids <- showLabels(seq_along(x), x, labels=labels, id.method=id.method, id.n=id.n)
if (is.null(ids)) return(invisible(NULL)) else return(ids)
}
bin.var <- function (x, bins=4, method=c("intervals", "proportions", "natural"), labels=FALSE){
method <- match.arg(method)
# Author: Dan Putler (revision by J. Fox, 5 Dec 04 & 5 Mar 13)
if(length(x) < bins) {
stop(gettextRcmdr("The number of bins exceeds the number of data values"))
}
x <- if(method == "intervals") cut(x, bins, labels=labels)
else if (method == "proportions") cut(x, quantile(x, probs=seq(0,1,1/bins), na.rm=TRUE),
include.lowest = TRUE, labels=labels)
else {
xx <- na.omit(x)
breaks <- c(-Inf, tapply(xx, KMeans(xx, bins)$cluster, max))
cut(x, breaks, labels=labels)
}
as.factor(x)
}
# the following function is adapted from a suggestion by Robert Muenchen
rcorr.adjust <- function(x, type=c("pearson", "spearman"),
use=c("complete.obs", "pairwise.complete.obs")){
require("Hmisc")
opt <- options(scipen=5)
on.exit(options(opt))
type <- match.arg(type)
use <- match.arg(use)
x <- if (use == "complete.obs") as.matrix(na.omit(x)) else as.matrix(x)
R <- rcorr(x, type=type)
P <- P.unadj <- R$P
p <- P[lower.tri(P)]
adj.p <- p.adjust(p, method="holm")
P[lower.tri(P)] <- adj.p
P[upper.tri(P)] <- 0
P <- P + t(P)
P <- ifelse(P < 1e-04, 0, P)
P <- format(round(P, 4))
diag(P) <- ""
P[grep("0.0000", P)] <- "<.0001"
P.unadj <- ifelse(P.unadj < 1e-04, 0, P.unadj)
P.unadj <- format(round(P.unadj, 4))
diag(P.unadj) <- ""
P.unadj[grep("0.0000", P.unadj)] <- "<.0001"
result <- list(R=R, P=P, P.unadj=P.unadj, type=type)
class(result) <- "rcorr.adjust"
result
}
print.rcorr.adjust <- function(x, ...){
cat("\n", if (x$type == "pearson") "Pearson" else "Spearman", "correlations:\n")
print(round(x$R$r, 4))
cat("\n Number of observations: ")
n <- x$R$n
if (all(n[1] == n)) cat(n[1], "\n")
else{
cat("\n")
print(n)
}
cat("\n Pairwise two-sided p-values:\n")
print(x$P.unadj, quote=FALSE)
cat("\n Adjusted p-values (Holm's method)\n")
print(x$P, quote=FALSE)
}
# Pager
# this is slightly modified from tkpager to use the Rcmdr monospaced font
# and a white background
RcmdrPager <- function (file, header, title, delete.file)
{
title <- paste(title, header)
for (i in seq(along = file)) {
zfile <- file[[i]]
tt <- tktoplevel()
if (WindowsP()) tkwm.iconbitmap(tt, system.file("etc", "R-logo.ico", package="Rcmdr"))
tkwm.title(tt, if (length(title))
title[(i - 1)%%length(title) + 1]
else "")
txt <- tktext(tt, bg = "white", font = getRcmdr("logFont"))
scr <- ttkscrollbar(tt, command = function(...) tkyview(txt,
...))
tkconfigure(txt, yscrollcommand = function(...) tkset(scr,
...))
tkpack(txt, side = "left", fill = "both", expand = TRUE)
tkpack(scr, side = "right", fill = "y")
chn <- tcl("open", zfile)
tkinsert(txt, "end", gsub("_\b", "", tclvalue(tcl("read",
chn))))
tcl("close", chn)
tkconfigure(txt, state = "disabled")
tkmark.set(txt, "insert", "0.0")
tkfocus(txt)
if (delete.file)
tcl("file", "delete", zfile)
}
}
# help functions
helpCommander <- function() {
PDF <- file.access(paste(file.path(path.package(package="Rcmdr")[1], "doc"),
"/", gettextRcmdr("Commander"), ".pdf", sep=""), mode=4)
if (PDF == 0){
browseURL(paste(file.path(path.package(package="Rcmdr")[1], "doc"),
"/", gettextRcmdr("Commander"), ".pdf", sep=""))
}
else if (as.numeric(R.Version()$major) >= 2) print(help(gettextRcmdr("Commander")))
else help(gettextRcmdr("Commander"))
}
helpAboutCommander <- function() {
if (as.numeric(R.Version()$major) >= 2) print(help("Rcmdr"))
else help("Rcmdr")
}
browseManual <- function() {
browseURL(paste(file.path(path.package(package="Rcmdr")[1], "doc"),
"/", gettextRcmdr("Getting-Started-with-the-Rcmdr"), ".pdf", sep=""))
}
browseEnglishManual <- function() {
browseURL(paste(file.path(path.package(package="Rcmdr")[1], "doc"),
"/Getting-Started-with-the-Rcmdr.pdf", sep=""))
}
manualTranslationP <- function(){
gettextRcmdr("Getting-Started-with-the-Rcmdr") != "Getting-Started-with-the-Rcmdr"
}
browseRcmdrWebsite <- function() browseURL("http://socserv.socsci.mcmaster.ca/jfox/Misc/Rcmdr/")
browseRWebsite <- function() browseURL("http://www.r-project.org/")
browseRMarkdown <- function() browseURL("http://www.rstudio.com/ide/docs/authoring/using_markdown")
# functions for building dialog boxes
# the following function is slightly modified, with permission, from Thomas Lumley,
# "Programmer's Niche: Macros in R," R-News, Sept. 2001, Vol. 1, No. 3, pp.11-13.
defmacro <- function(..., expr){
expr <- substitute(expr)
len <- length(expr)
expr[3:(len+1)] <- expr[2:len]
## delete "macro" variables starting in ..
expr[[2]] <- quote(on.exit(remove(list=objects(pattern="^\\.\\.", all.names=TRUE))))
a <- substitute(list(...))[-1]
## process the argument list
nn <- names(a)
if (is.null(nn)) nn <- rep("", length(a))
for (i in seq(length.out=length(a))){
if (nn[i] == "") {
nn[i] <- paste(a[[i]])
msg <- paste(a[[i]], gettext("not supplied", domain="R-Rcmdr"))
a[[i]] <- substitute(stop(foo), list(foo = msg))
}
}
names(a) <- nn
a <- as.list(a)
ff <- eval(substitute(
function(){
tmp <- substitute(body)
eval(tmp, parent.frame())
},
list(body = expr)))
## add the argument list
formals(ff) <- a
## create a fake source attribute
mm <- match.call()
mm$expr <- NULL
mm[[1]] <- as.name("macro")
expr[[2]] <- NULL # get "local" variable removal out of source
attr(ff, "source") <- c(deparse(mm), deparse(expr))
## return the macro
ff
}
OKCancelHelp <- defmacro(window=top, helpSubject=NULL, model=FALSE, reset=NULL, apply=NULL,
expr={
memory <- getRcmdr("retain.selections")
button.strings <- c("OK", "Cancel",
if (!is.null(helpSubject)) "Help",
if (!is.null(reset) && memory) "Reset",
if (!is.null(apply)) "Apply")
width <- max(nchar(gettextRcmdr(button.strings)))
if (WindowsP()) width <- width + 2
buttonsFrame <- tkframe(window)
leftButtonsBox <- tkframe(buttonsFrame)
rightButtonsBox <- tkframe(buttonsFrame)
OnOK <- function(){
putRcmdr("restoreTab", FALSE)
if (getRcmdr("use.markdown")) {
putRcmdr("startNewCommandBlock", FALSE)
beginRmdBlock()
}
if (getRcmdr("use.knitr")) {
putRcmdr("startNewKnitrCommandBlock", FALSE)
beginRnwBlock()
}
setBusyCursor()
on.exit(setIdleCursor())
onOK()
if (getRcmdr("use.markdown")){
removeNullRmdBlocks()
putRcmdr("startNewCommandBlock", TRUE)
if (getRcmdr("rmd.generated")) {
endRmdBlock()
putRcmdr("rmd.generated", FALSE)
}
removeNullRmdBlocks()
}
if (getRcmdr("use.knitr")){
removeNullRnwBlocks()
putRcmdr("startNewKnitrCommandBlock", TRUE)
if (getRcmdr("rnw.generated")) {
endRnwBlock()
putRcmdr("rnw.generated", FALSE)
}
removeNullRnwBlocks()
}
}
OKbutton <- buttonRcmdr(rightButtonsBox, text=gettextRcmdr("OK"), foreground="darkgreen", width=width, command=OnOK, default="active",
image="::image::okIcon", compound="left")
onCancel <- function() {
if (exists(".exit")){
result <- .exit()
if (result == "abort") return()
}
putRcmdr("restoreTab", FALSE)
if (model) putRcmdr("modelNumber", getRcmdr("modelNumber") - 1)
if (GrabFocus()) tkgrab.release(window)
tkdestroy(window)
tkfocus(CommanderWindow())
}
cancelButton <- buttonRcmdr(rightButtonsBox, text=gettextRcmdr("Cancel"), foreground="red", width=width, command=onCancel, # borderwidth=3,
image="::image::cancelIcon", compound="left")
if (!is.null(helpSubject)){
onHelp <- function() {
if (GrabFocus() && (!WindowsP())) tkgrab.release(window)
if (as.numeric(R.Version()$major) >= 2) print(help(helpSubject))
else help(helpSubject)
}
helpButton <- buttonRcmdr(leftButtonsBox, text=gettextRcmdr("Help"), width=width, command=onHelp, # borderwidth=3,
image="::image::helpIcon", compound="left")
}
if (!is.null(reset) && memory){
onReset <- function(){
ID <- window$ID
putRcmdr("cancelDialogReopen", TRUE)
putRcmdr("open.dialog.here", as.character(.Tcl(paste("winfo geometry", ID))))
if (model) putRcmdr("modelNumber", getRcmdr("modelNumber") - 1)
putDialog(reset, NULL)
putDialog(reset, NULL, resettable=FALSE)
closeDialog()
eval(parse(text=paste(reset, "()")))
putRcmdr("open.dialog.here", NULL)
putRcmdr("restoreTab", FALSE)
}
resetButton <- buttonRcmdr(leftButtonsBox, text=gettextRcmdr("Reset"), width=width, command=onReset,
image="::image::resetIcon", compound="left")
}
if (!is.null(apply)){
onApply <- function(){
putRcmdr("restoreTab", TRUE)
putRcmdr("cancelDialogReopen", FALSE)
ID <- window$ID
putRcmdr("open.dialog.here", as.character(.Tcl(paste("winfo geometry", ID))))
if (getRcmdr("use.markdown")) {
putRcmdr("startNewCommandBlock", FALSE)
beginRmdBlock()
}
if (getRcmdr("use.knitr")) {
putRcmdr("startNewKnitrCommandBlock", FALSE)
beginRnwBlock()
}
setBusyCursor()
on.exit(setIdleCursor())
onOK()
if (getRcmdr("use.markdown")){
removeNullRmdBlocks()
putRcmdr("startNewCommandBlock", TRUE)
if (getRcmdr("rmd.generated")) {
endRmdBlock()
putRcmdr("rmd.generated", FALSE)
}
removeNullRmdBlocks()
}
if (getRcmdr("use.knitr")){
removeNullRnwBlocks()
putRcmdr("startNewKnitrCommandBlock", TRUE)
if (getRcmdr("rnw.generated")) {
endRnwBlock()
putRcmdr("rnw.generated", FALSE)
}
removeNullRnwBlocks()
}
if (getRcmdr("cancelDialogReopen")){
putRcmdr("cancelDialogReopen", FALSE)
}
else{
eval(parse(text=paste(apply, "()")))
putRcmdr("open.dialog.here", NULL)
}
}
applyButton <- buttonRcmdr(rightButtonsBox, text=gettextRcmdr("Apply"), foreground="yellow", width=width, command=onApply,
image="::image::applyIcon", compound="left")
}
if(!WindowsP()) {
if (!is.null(apply)){
tkgrid(applyButton, cancelButton, OKbutton, sticky="w")
tkgrid.configure(OKbutton, padx=c(6, 0))
}
else{
tkgrid(cancelButton, OKbutton, sticky="w")
}
tkgrid.configure(cancelButton, padx=c(6, 6))
}
else {
if (!is.null(apply)){
tkgrid(OKbutton, cancelButton, applyButton, sticky="w")
tkgrid.configure(applyButton, padx=c(6, 0))
}
else{
tkgrid(OKbutton, cancelButton, sticky="w")
}
tkgrid.configure(OKbutton, padx=c(6, 6))
}
if (!is.null(reset) && memory) {
if (! is.null(helpSubject)){
tkgrid (helpButton, resetButton, pady=6)
}
else tkgrid (resetButton, pady=6)
if (!WindowsP()) tkgrid.configure(resetButton, padx=c(0, 6))
}
else if (! is.null(helpSubject)){
tkgrid(helpButton, pady=6)
}
tkgrid(leftButtonsBox, rightButtonsBox, pady=6, sticky="ew")
if (!is.null(helpSubject)) tkgrid.configure(helpButton, padx=c(0, 18))
else if (!is.null(reset) && memory) tkgrid.configure(resetButton, padx=c(0, 18))
tkgrid.columnconfigure(buttonsFrame, 0, weight=1)
tkgrid.columnconfigure(buttonsFrame, 1, weight=1)
tkgrid.configure(leftButtonsBox, sticky="w")
tkgrid.configure(rightButtonsBox, sticky="e")
})
subOKCancelHelp <- defmacro(window=subdialog, helpSubject=NULL,
expr={
button.strings <- c("OK", "Cancel",
if (!is.null(helpSubject)) "Help")
width <- max(nchar(gettextRcmdr(button.strings)))
if (WindowsP()) width <- width + 2
subButtonsFrame <- tkframe(window)
subLeftButtonsBox <- tkframe(subButtonsFrame)
subRightButtonsBox <- tkframe(subButtonsFrame)
subOKbutton <- buttonRcmdr(subRightButtonsBox, text=gettextRcmdr("OK"), foreground="darkgreen", width=width, command=onOKsub, default="active",
image="::image::okIcon", compound="left")
onCancelSub <- function() {
if (GrabFocus()) tkgrab.release(window)
tkdestroy(window)
tkfocus(CommanderWindow())
}
subCancelButton <- buttonRcmdr(subRightButtonsBox, text=gettextRcmdr("Cancel"), foreground="red", width=width, command=onCancelSub,
image="::image::cancelIcon", compound="left") # borderwidth=3,
if (!is.null(helpSubject)){
onHelpSub <- function(){
if (GrabFocus() && (!WindowsP())) tkgrab.release(window)
if (as.numeric(R.Version()$major) >= 2) print(help(helpSubject))
else help(helpSubject)
}
subHelpButton <- buttonRcmdr(subLeftButtonsBox, text=gettextRcmdr("Help"), width=width, command=onHelpSub,
image="::image::helpIcon", compound="left")
}
if(!WindowsP()) {
tkgrid(subCancelButton, subOKbutton, sticky="w")
tkgrid.configure(subOKbutton, padx=c(6, 0))
}
else {
tkgrid(subOKbutton, subCancelButton, sticky="w")
tkgrid.configure(subOKbutton, padx=c(0, 6))
}
if (! is.null(helpSubject)){
tkgrid(subHelpButton, pady=6, padx=c(0, 18))
}
tkgrid(subLeftButtonsBox, subRightButtonsBox, pady=6, sticky="ew")
tkgrid.columnconfigure(subButtonsFrame, 0, weight=1)
tkgrid.columnconfigure(subButtonsFrame, 1, weight=1)
tkgrid.configure(subLeftButtonsBox, sticky="w")
tkgrid.configure(subRightButtonsBox, sticky="e")
})
checkActiveDataSet <- function(){
if (activeDataSet() == FALSE) {
tkfocus(CommanderWindow())
FALSE
}
else TRUE
}
checkActiveModel <- function(){
if (activeModel() == FALSE) {
tkfocus(CommanderWindow())
FALSE
}
else TRUE
}
checkFactors <- function(n=1){
if (length(Factors()) < n){
if (n > 1)
Message(message=sprintf(gettextRcmdr("There fewer than %d factors in the active data set."), n),
type="error")
else Message(message=gettextRcmdr("There are no factors in the active data set."),
type="error")
tkfocus(CommanderWindow())
FALSE
}
else TRUE
}
checkTwoLevelFactors <- function(n=1){
if (length(TwoLevelFactors()) < n){
if (n > 1)
Message(message=sprintf(gettextRcmdr("There fewer than %d two-level factors in the active data set."), n),
type="error")
else Message(message=gettextRcmdr("There are no two-level factors in the active data set."),
type="error")
tkfocus(CommanderWindow())
FALSE
}
else TRUE
}
checkNumeric <- function(n=1){
if (length(Numeric()) < n){
if (n > 1)
Message(message=sprintf(gettextRcmdr("There fewer than %d numeric variables in the active data set."), n),
type="error")
else Message(message=gettextRcmdr("There are no numeric variables in the active data set."),
type="error")
tkfocus(CommanderWindow())
FALSE
}
else TRUE
}
checkVariables <- function(n=1){
if (length(Variables()) < n){
if (n > 1)
Message(message=sprintf(gettextRcmdr("There fewer than %d variables in the active data set."), n),
type="error")
else Message(message=gettextRcmdr("There are no variables in the active data set."),
type="error")
tkfocus(CommanderWindow())
FALSE
}
else TRUE
}
commanderPosition <- function (){
ID <- CommanderWindow()$ID
as.numeric(c(tclvalue(.Tcl(paste("winfo rootx", ID))),
tclvalue(.Tcl(paste("winfo rooty", ID)))))
}
initializeDialog <- defmacro(window=top, title="", offset=10, preventCrisp,
use.tabs=FALSE, notebook=notebook, tabs=c("dataTab", "optionsTab"),
expr={
if (getRcmdr("crisp.dialogs")) tclServiceMode(on=FALSE)
window <- tktoplevel(borderwidth=10)
if (use.tabs){
notebook <- ttknotebook(window)
for (tab in tabs) assign(tab, tkframe(window))
}
tkwm.title(window, title)
location <- getRcmdr("open.dialog.here")
position <- if (!is.null(location)) location
else {
pos <- offset + commanderPosition()
if (any(pos < 0)) "-50+50"
else paste("+", paste(pos, collapse="+"), sep="")
}
tkwm.geometry(window, position)
tkwm.transient(window, CommanderWindow())
}
)
closeDialog <- defmacro(window=top, release=TRUE,
expr={
if (release && GrabFocus()) tkgrab.release(window)
tkdestroy(window)
}
)
dialogSuffix <- defmacro(window=top, onOK=onOK, onCancel=onCancel, rows, columns, focus=top,
bindReturn=TRUE, preventGrabFocus=FALSE, preventDoubleClick=FALSE,
preventCrisp,
use.tabs=FALSE, notebook=notebook, tabs=c("dataTab", "optionsTab"), tab.names=c("Data", "Options"),
grid.buttons=FALSE, resizable=FALSE,
expr={
if (use.tabs){
for (i in 1:length(tabs)){
tkadd(notebook, get(tabs[i]), text=gettextRcmdr(tab.names[i]), padding=6, sticky="nsew")
}
tkgrid(notebook, sticky="nsew")
}
if (grid.buttons) tkgrid(buttonsFrame, sticky = "ew")
if (use.tabs && exists("dialog.values") && !is.null(dialog.values$initial.tab) && getRcmdr("restoreTab"))
tkselect(notebook, dialog.values$initial.tab)
.Tcl("update idletasks")
tkwm.resizable(window, as.numeric(resizable), as.numeric(resizable))
if (bindReturn) tkbind(window, "<Return>", onOK)
tkbind(window, "<Escape>", onCancel)
if (getRcmdr("double.click") && (!preventDoubleClick)) tkbind(window, "<Double-ButtonPress-1>", onOK)
tkwm.deiconify(window)
# focus grabs appear to cause problems for some dialogs
if (GrabFocus() && (!preventGrabFocus)) tkgrab.set(window)
tkfocus(focus)
tkwait.window(window)
if (getRcmdr("crisp.dialogs")) tclServiceMode(on=TRUE)
}
)
variableListBox <- function(parentWindow, variableList=Variables(), bg="white",
selectmode="single", export="FALSE", initialSelection=NULL, listHeight=getRcmdr("variable.list.height"), title){
if (selectmode == "multiple") selectmode <- getRcmdr("multiple.select.mode")
if (length(variableList) == 1 && is.null(initialSelection)) initialSelection <- 0
frame <- tkframe(parentWindow)
minmax <- getRcmdr("variable.list.width")
listbox <- tklistbox(frame, height=min(listHeight, length(variableList)),
selectmode=selectmode, background=bg, exportselection=export,
width=min(max(minmax[1], nchar(variableList)), minmax[2]))
scrollbar <- ttkscrollbar(frame, command=function(...) tkyview(listbox, ...))
tkconfigure(listbox, yscrollcommand=function(...) tkset(scrollbar, ...))
for (var in variableList) tkinsert(listbox, "end", var)
if (is.numeric(initialSelection)) for (sel in initialSelection) tkselection.set(listbox, sel)
firstChar <- tolower(substr(variableList, 1, 1))
len <- length(variableList)
onLetter <- function(letter){
letter <- tolower(letter)
current <- 1 + round(as.numeric(unlist(strsplit(tclvalue(tkyview(listbox) ), " "))[1])*len)
mat <- match(letter, firstChar[-(1:current)])
if (is.na(mat)) return()
tkyview.scroll(listbox, mat, "units")
}
onA <- function() onLetter("a")
onB <- function() onLetter("b")
onC <- function() onLetter("c")
onD <- function() onLetter("d")
onE <- function() onLetter("e")
onF <- function() onLetter("f")
onG <- function() onLetter("g")
onH <- function() onLetter("h")
onI <- function() onLetter("i")
onJ <- function() onLetter("j")
onK <- function() onLetter("k")
onL <- function() onLetter("l")
onM <- function() onLetter("m")
onN <- function() onLetter("n")
onO <- function() onLetter("o")
onP <- function() onLetter("p")
onQ <- function() onLetter("q")
onR <- function() onLetter("r")
onS <- function() onLetter("s")
onT <- function() onLetter("t")
onU <- function() onLetter("u")
onV <- function() onLetter("v")
onW <- function() onLetter("w")
onX <- function() onLetter("x")
onY <- function() onLetter("y")
onZ <- function() onLetter("z")
for (letter in c(letters, LETTERS)){
tkbind(listbox, paste("<", letter, ">", sep=""),
get(paste("on", toupper(letter), sep="")))
}
onClick <- function() tkfocus(listbox)
toggleSelection <- function(){
active <- tclvalue(tkindex(listbox, "active"))
selected <- tclvalue(tkcurselection(listbox))
if (selected == active) tkselection.clear(listbox, "active") else tkselection.set(listbox, "active")
}
tkbind(listbox, "<ButtonPress-1>", onClick)
if (selectmode == "single") tkbind(listbox, "<Control-ButtonPress-1>", toggleSelection)
tkgrid(labelRcmdr(frame, text=title, fg=getRcmdr("title.color"), font="RcmdrTitleFont"), columnspan=2, sticky="w")
tkgrid(listbox, scrollbar, sticky="nw")
tkgrid.configure(scrollbar, sticky="wns")
tkgrid.configure(listbox, sticky="ewns")
result <- list(frame=frame, listbox=listbox, scrollbar=scrollbar,
selectmode=selectmode, varlist=variableList)
class(result) <- "listbox"
result
}
getSelection <- function(object) UseMethod("getSelection")
getSelection.listbox <- function(object){
object$varlist[as.numeric(tkcurselection(object$listbox)) + 1]
}
getFrame <- function(object) UseMethod("getFrame")
getFrame.listbox <- function(object){
object$frame
}
# This function modified based on code by Liviu Andronic (13 Dec 09) and on code by Milan Bouchet-Valat (29 Jun 12):
radioButtons <- defmacro(window=top, name, buttons, values=NULL, initialValue=..values[1], labels,
title="", title.color=getRcmdr("title.color"), right.buttons=FALSE, command=function(){},
expr={
..values <- if (is.null(values)) buttons else values
..frame <- paste(name, "Frame", sep="")
assign(..frame, tkframe(window))
..variable <- paste(name, "Variable", sep="")
assign(..variable, tclVar(initialValue))
if(title != ""){
tkgrid(labelRcmdr(eval(parse(text=..frame)), text=title, foreground=title.color, font="RcmdrTitleFont"), columnspan=2, sticky="w")
}
for (i in 1:length(buttons)) {
..button <- paste(buttons[i], "Button", sep="")
if (right.buttons) {
assign(..button, ttkradiobutton(eval(parse(text=..frame)), variable=eval(parse(text=..variable)),
value=..values[i], command=command))
tkgrid(labelRcmdr(eval(parse(text=..frame)), text=labels[i], justify="left"), eval(parse(text=..button)), sticky="w")
}
else{
assign(..button, ttkradiobutton(eval(parse(text=..frame)), variable=eval(parse(text=..variable)),
value=..values[i], text=labels[i], command=command))
tkgrid(eval(parse(text=..button)), sticky="w")
}
}
}
)
checkBoxes <- defmacro(window=top, frame, boxes, initialValues=NULL, labels, title=NULL, ttk=FALSE,
expr={
..initialValues <- if (is.null(initialValues)) rep("1", length(boxes)) else initialValues
assign(frame, if (ttk) ttklabelframe(window, text=title) else tkframe(window))
if (!is.null(title) && !ttk) tkgrid(labelRcmdr(eval(parse(text=frame)), text=title, fg=getRcmdr("title.color"), font="RcmdrTitleFont"), sticky="w")
..variables <- paste(boxes, "Variable", sep="")
for (i in 1:length(boxes)) {
assign(..variables[i], tclVar(..initialValues[i]))
..checkBox <- paste(boxes[i], "CheckBox", sep="")
assign(..checkBox,
ttkcheckbutton(eval(parse(text=frame)), variable=eval(parse(text=..variables[i])), text=labels[i]))
tkgrid(eval(parse(text=..checkBox)), sticky="w")
}
}
)
checkReplace <- function(name, type=gettextRcmdr("Variable")){
RcmdrTkmessageBox(message=sprintf(gettextRcmdr("%s %s already exists.\nOverwrite %s?"),
type, name, tolower(type)), icon="warning", type="yesno", default="no")
}
errorCondition <- defmacro(window=top, recall=NULL, message, model=FALSE,
expr={
putRcmdr("cancelDialogReopen", TRUE)
if (model) putRcmdr("modelNumber", getRcmdr("modelNumber") - 1)
if (!is.null(window)){
if (GrabFocus()) tkgrab.release(window)
tkdestroy(window)
}
Message(message=message, type="error")
if (!is.null(recall)) recall()
else tkfocus(CommanderWindow())
})
subsetBox <- defmacro(window=top, subset.expression=NULL, model=FALSE,
expr={
subsetVariable <- if (!is.null(subset.expression)) tclVar(gettextRcmdr(subset.expression))
else if (model){
if (currentModel && currentFields$subset != "")
tclVar(currentFields$subset) else tclVar(gettextRcmdr("<all valid cases>"))
}
else tclVar(gettextRcmdr("<all valid cases>"))
subsetFrame <- tkframe(window)
subsetEntry <- ttkentry(subsetFrame, width="20", textvariable=subsetVariable)
subsetScroll <- ttkscrollbar(subsetFrame, orient="horizontal",
command=function(...) tkxview(subsetEntry, ...))
tkconfigure(subsetEntry, xscrollcommand=function(...) tkset(subsetScroll, ...))
tkgrid(labelRcmdr(subsetFrame, text=gettextRcmdr("Subset expression"), fg=getRcmdr("title.color"), font="RcmdrTitleFont"), sticky="w")
tkgrid(subsetEntry, sticky="ew")
tkgrid(subsetScroll, sticky="ew")
tkgrid.columnconfigure(subsetFrame, 0, weight=1)
})
groupsBox <- defmacro(recall=NULL, label=gettextRcmdr("Plot by:"), initialLabel=gettextRcmdr("Plot by groups"),
errorText=gettextRcmdr("There are no factors in the active data set."),
variables=Factors(), plotLinesByGroup=FALSE, positionLegend=FALSE, plotLinesByGroupsText=gettextRcmdr("Plot lines by group"),
initialGroup=NULL, initialLinesByGroup=1, window=top,
expr={
env <- environment()
.groups <- if (is.null(initialGroup)) FALSE else initialGroup
.linesByGroup <- initialLinesByGroup == 1
.groupsLabel <- tclVar(if (!is.null(initialGroup)) initialLabel else paste(initialLabel, "...", sep=""))
.factors <- variables
onGroups <- function(){
if (length(.factors) == 0){
errorCondition(recall=recall, message=errorText)
return()
}
initializeDialog(subdialog, title=gettextRcmdr("Groups"))
groupsBox <- variableListBox(subdialog, .factors, title=gettextRcmdr("Groups variable (pick one)"),
initialSelection=varPosn(initialGroup, "factor"))
if (plotLinesByGroup){
linesByGroupFrame <- tkframe(subdialog)
linesByGroup <- tclVar(if(initialLinesByGroup == 1) "1" else "0")
linesCheckBox <- ttkcheckbutton(linesByGroupFrame, variable=linesByGroup)
tkgrid(labelRcmdr(linesByGroupFrame, text=plotLinesByGroupsText), linesCheckBox, sticky="w")
}
onOKsub <- function() {
groups <- getSelection(groupsBox)
if (length(groups) == 0){
assign(".groups", FALSE, envir=env)
tclvalue(.groupsLabel) <- paste(gettextRcmdr("Plot by groups"), "...", sep="")
tkconfigure(groupsButton, foreground="black")
if (GrabFocus()) tkgrab.release(subdialog)
tkdestroy(subdialog)
tkwm.deiconify(top)
if (GrabFocus()) tkgrab.set(top)
tkfocus(top)
tkwait.window(top)
return()
}
assign(".groups", groups, envir=env)
tclvalue(.groupsLabel) <- paste(label, groups)
tkconfigure(groupsButton, foreground=getRcmdr("title.color"))
tkconfigure(groupsButton, font="RcmdrTitleFont")
if (plotLinesByGroup) {
lines <- as.character("1" == tclvalue(linesByGroup))
assign(".linesByGroup", lines, envir=env)
}
if (GrabFocus()) tkgrab.release(subdialog)
tkdestroy(subdialog)
tkwm.deiconify(top)
if (GrabFocus()) tkgrab.set(top)
tkfocus(top)
tkwait.window(top)
}
subOKCancelHelp()
tkgrid(getFrame(groupsBox), sticky="nw")
if (plotLinesByGroup) tkgrid(linesByGroupFrame, sticky="w")
tkgrid(subButtonsFrame, sticky="ew")
if (positionLegend) tkgrid(labelRcmdr(subdialog, text=gettextRcmdr("Position legend with mouse click"), fg=getRcmdr("title.color"), font="RcmdrTitleFont"))
dialogSuffix(subdialog, onOK=onOKsub, focus=subdialog)
}
groupsFrame <- tkframe(window)
groupsButton <- tkbutton(groupsFrame, textvariable=.groupsLabel, command=onGroups)
if (!is.null(initialGroup)) tkconfigure(groupsButton, foreground=getRcmdr("title.color"), font="RcmdrTitleFont")
tkgrid(groupsButton, sticky="we")
tkgrid.columnconfigure(groupsFrame, 0, weight=1)
})
groupsLabel <- defmacro(frame=top, groupsBox=groupsBox, columnspan=1, initialText=NULL,
expr={
initial.label <- if (exists("dialog.values")) dialog.values$initial.label else NULL
if (is.null(initial.label)) {
group <- getSelection(groupsBox)
initial.label <- if (length(group) == 0) NULL
else {
levels <- eval(parse(text = paste("levels(", ActiveDataSet(),
"$", group, ")", sep = "")))
paste(levels[1], "-", levels[2])
}
}
groupsFrame <- tkframe(frame)
.groupsLabel <- if (!is.null(initialText)) initialText
else if (is.null(initial.label)) gettextRcmdr("<No groups selected>")
else initial.label
groupsLabel <- labelRcmdr(groupsFrame, text=.groupsLabel)
tkgrid(labelRcmdr(groupsFrame, text=gettextRcmdr("Difference: "), fg=getRcmdr("title.color"), font="RcmdrTitleFont"), groupsLabel, sticky="w")
tkgrid(groupsFrame, sticky="w", columnspan=columnspan)
onSelect <- function(){
group <- getSelection(groupsBox)
if (length(group) == 0) {
.groupsLabel <<- gettextRcmdr("<No groups selected>")
}
else {
levels <- eval(parse(text=paste("levels(", ActiveDataSet(), "$", group, ")", sep="")))
.groupsLabel <<- paste(levels[1], "-", levels[2])
}
tkconfigure(groupsLabel, text=.groupsLabel)
}
tkbind(groupsBox$listbox, "<ButtonRelease-1>", onSelect)
})
modelFormula <- defmacro(frame=top, hasLhs=TRUE, expr={
checkAddOperator <- function(rhs){
rhs.chars <- rev(strsplit(rhs, "")[[1]])
if (length(rhs.chars) < 1) return(FALSE)
check.char <- if ((rhs.chars[1] != " ") || (length(rhs.chars) == 1))
rhs.chars[1] else rhs.chars[2]
!is.element(check.char, c("+", "*", ":", "/", "-", "^", "(", "%"))
}
.variables <- Variables()
word <- paste("\\[", gettextRcmdr("factor"), "\\]", sep="")
variables <- paste(.variables,
ifelse(is.element(.variables, Factors()), paste("[", gettextRcmdr("factor"), "]", sep=""), ""))
xBox <- variableListBox(frame, variables, selectmode="multiple", title=gettextRcmdr("Variables (double-click to formula)"))
onDoubleClick <- if (!hasLhs){
function(){
var <- getSelection(xBox)
tkselection.clear(xBox$listbox, "0", "end")
if (length(grep(word, var)) == 1) var <- sub(word, "", var)
tkfocus(rhsEntry)
rhs <- tclvalue(rhsVariable)
rhs.chars <- rev(strsplit(rhs, "")[[1]])
check.char <- if (length(rhs.chars) > 0){
if ((rhs.chars[1] != " ") || (length(rhs.chars) == 1))
rhs.chars[1] else rhs.chars[2]
}
else ""
tclvalue(rhsVariable) <- if (rhs == "" ||
is.element(check.char, c("+", "*", ":", "/", "-", "^", "(", "%")))
paste(rhs, var, sep="")
else paste(rhs, "+", var)
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
}
else{
function(){
var <- getSelection(xBox)
which <- tkcurselection(xBox$listbox)
tkselection.clear(xBox$listbox, "0", "end")
if (length(grep(word, var)) == 1) var <- sub(word, "", var)
lhs <- tclvalue(lhsVariable)
if (lhs == "" || tclvalue(tkselection.present(lhsEntry)) == "1"){
tclvalue(lhsVariable) <- var
tkselection.clear(lhsEntry)
tkfocus(rhsEntry)
}
else {
tkfocus(rhsEntry)
rhs <- tclvalue(rhsVariable)
rhs.chars <- rev(strsplit(rhs, "")[[1]])
check.char <- if (length(rhs.chars) > 0){
if ((rhs.chars[1] != " ") || (length(rhs.chars) == 1))
rhs.chars[1] else rhs.chars[2]
}
else ""
tclvalue(rhsVariable) <- if (rhs == "" ||
is.element(check.char, c("+", "*", ":", "/", "-", "^", "(", "%")))
paste(rhs, var, sep="")
else paste(rhs, "+", var)
}
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
}
tkbind(xBox$listbox, "<Double-ButtonPress-1>", onDoubleClick)
onPlus <- function(){
rhs <- tclvalue(rhsVariable)
var <- getSelection(xBox)
tkselection.clear(xBox$listbox, "0", "end")
if ((check <- !checkAddOperator(rhs)) && length(var) == 0) return()
if (length(var) > 1){
if (length(grep(word, var)) > 0) var <- sub(word, "", var)
if (length(var) > 1) var <- paste(var, collapse=" + ")
}
tclvalue(rhsVariable) <- paste(rhs, if (!check) " + ", var, sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onTimes <- function(){
rhs <- tclvalue(rhsVariable)
var <- getSelection(xBox)
tkselection.clear(xBox$listbox, "0", "end")
if ((check <- !checkAddOperator(rhs)) && length(var) == 0) return()
if (length(var) > 1){
if (length(grep(word, var)) > 0) var <- sub(word, "", var)
var <- trim.blanks(var)
if (length(var) > 1) var <- paste(var, collapse="*")
tclvalue(rhsVariable) <- paste(rhs, if (!check) " + ", var, sep="")
}
else tclvalue(rhsVariable) <- paste(rhs, if (!check) "*", sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onColon <- function(){
rhs <- tclvalue(rhsVariable)
var <- getSelection(xBox)
tkselection.clear(xBox$listbox, "0", "end")
if ((check <- !checkAddOperator(rhs)) && length(var) == 0) return()
if (length(var) > 1){
if (length(grep(word, var)) > 0) var <- sub(word, "", var)
var <- trim.blanks(var)
if (length(var) > 1) var <- paste(var, collapse=":")
tclvalue(rhsVariable) <- paste(rhs, if (!check) " + ", var, sep="")
}
else tclvalue(rhsVariable) <- paste(rhs, if (!check) ":", sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onSlash <- function(){
rhs <- tclvalue(rhsVariable)
if (!checkAddOperator(rhs)) return()
tclvalue(rhsVariable) <- paste(rhs, "/", sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onIn <- function(){
rhs <- tclvalue(rhsVariable)
if (!checkAddOperator(rhs)) return()
tclvalue(rhsVariable) <- paste(rhs, "%in% ")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onMinus <- function(){
rhs <- tclvalue(rhsVariable)
if (!checkAddOperator(rhs)) return()
tclvalue(rhsVariable) <- paste(rhs, "- ")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onPower <- function(){
rhs <- tclvalue(rhsVariable)
if (!checkAddOperator(rhs)) return()
tclvalue(rhsVariable) <- paste(rhs, "^", sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onLeftParen <- function(){
tkfocus(rhsEntry)
rhs <- tclvalue(rhsVariable)
tclvalue(rhsVariable) <- paste(rhs, "(", sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onRightParen <- function(){
rhs <- tclvalue(rhsVariable)
if (!checkAddOperator(rhs)) return()
tclvalue(rhsVariable) <- paste(rhs, ")", sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
outerOperatorsFrame <- tkframe(frame)
operatorsFrame <- tkframe(outerOperatorsFrame)
splinePolyFrame <- tkframe(outerOperatorsFrame)
plusButton <- buttonRcmdr(operatorsFrame, text="+", width="3", command=onPlus)
timesButton <- buttonRcmdr(operatorsFrame, text="*", width="3", command=onTimes)
colonButton <- buttonRcmdr(operatorsFrame, text=":", width="3", command=onColon)
slashButton <- buttonRcmdr(operatorsFrame, text="/", width="3", command=onSlash)
inButton <- buttonRcmdr(operatorsFrame, text="%in%", width="5", command=onIn)
minusButton <- buttonRcmdr(operatorsFrame, text="-", width="3", command=onMinus)
powerButton <- buttonRcmdr(operatorsFrame, text="^", width="3", command=onPower)
leftParenButton <- buttonRcmdr(operatorsFrame, text="(", width="3", command=onLeftParen)
rightParenButton <- buttonRcmdr(operatorsFrame, text=")", width="3", command=onRightParen)
onBSpline <- function(){
rhs <- tclvalue(rhsVariable)
var <- getSelection(xBox)
tkselection.clear(xBox$listbox, "0", "end")
if (length(var) == 0) var <- " "
if (grepl("\\[factor\\]", var)){
Message("spline requires a numeric variable", type="error")
return()
}
if (length(var) > 1){
Message("cannot select more than one variable", type="error")
return()
}
check <- !checkAddOperator(rhs)
tclvalue(rhsVariable) <- paste(rhs,
if (!check) paste(" + bs(", var, ", df=", tclvalue(dfSplineVar), ")", sep="")
else paste(" bs(", var, ", df=", tclvalue(dfSplineVar), ")", sep=""),
sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onNatSline <- function(){
rhs <- tclvalue(rhsVariable)
var <- getSelection(xBox)
tkselection.clear(xBox$listbox, "0", "end")
if (length(var) == 0) var <- " "
if (grepl("\\[factor\\]", var)){
Message("spline requires a numeric variable", type="error")
return()
}
if (length(var) > 1){
Message("cannot select more than one variable", type="error")
return()
}
check <- !checkAddOperator(rhs)
tclvalue(rhsVariable) <- paste(rhs,
if (!check) paste(" + ns(", var, ", df=", tclvalue(dfSplineVar), ")", sep="")
else paste(" ns(", var, ", df=", tclvalue(dfSplineVar), ")", sep=""),
sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onPoly <- function(){
rhs <- tclvalue(rhsVariable)
var <- getSelection(xBox)
tkselection.clear(xBox$listbox, "0", "end")
if (length(var) == 0) var <- " "
if (grepl("\\[factor\\]", var)){
Message("polynomial requires a numeric variable", type="error")
return()
}
if (length(var) > 1){
Message("cannot select more than one variable", type="error")
return()
}
check <- !checkAddOperator(rhs)
tclvalue(rhsVariable) <- paste(rhs,
if (!check) paste(" + poly(", var, ", degree=", tclvalue(degPolyVar), ")", sep="")
else paste(" poly(", var, ", degree=", tclvalue(degPolyVar), ")", sep=""),
sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
onRawPoly <- function(){
rhs <- tclvalue(rhsVariable)
var <- getSelection(xBox)
tkselection.clear(xBox$listbox, "0", "end")
if (length(var) == 0) var <- " "
if (grepl("\\[factor\\]", var)){
Message("polynomial requires a numeric variable", type="error")
return()
}
if (length(var) > 1){
Message("cannot select more than one variable", type="error")
return()
}
check <- !checkAddOperator(rhs)
tclvalue(rhsVariable) <- paste(rhs,
if (!check) paste(" + poly(", var, ", degree=", tclvalue(degPolyVar), ", raw=TRUE)", sep="")
else paste(" poly(", var, ", degree=", tclvalue(degPolyVar), ", raw=TRUE)", sep=""),
sep="")
tkicursor(rhsEntry, "end")
tkxview.moveto(rhsEntry, "1")
}
bsplineButton <- buttonRcmdr(splinePolyFrame, text=gettextRcmdr("B-spline\n"), width="10", command=onBSpline)
nsplineButton <- buttonRcmdr(splinePolyFrame, text=gettextRcmdr("natural\nspline"), width="10", command=onNatSline)
polyButton <- buttonRcmdr(splinePolyFrame, text=gettextRcmdr("orthogonal\npolynomial"), width="10", command=onPoly)
RawPolyButton <- buttonRcmdr(splinePolyFrame, text=gettextRcmdr("raw\npolynomial"), width="10", command=onRawPoly)
dfSplineVar <- tclVar("5")
degPolyVar <- tclVar("2")
dfDegFrame <- tkframe(outerOperatorsFrame)
dfSplineSpin <- tkspinbox(dfDegFrame, textvariable=dfSplineVar, state="readonly", from=2, to=10, width=2)
degPolySpin <- tkspinbox(dfDegFrame, textvariable=degPolyVar, state="readonly", from=2, to=5, width=2)
tkgrid(plusButton, timesButton, colonButton, slashButton, inButton, minusButton,
powerButton, leftParenButton, rightParenButton, sticky="w")
tkgrid(labelRcmdr(dfDegFrame, text=gettextRcmdr("df for splines: ")), dfSplineSpin, sticky="se")
tkgrid(labelRcmdr(dfDegFrame, text=gettextRcmdr("deg. for polynomials: ")), degPolySpin, sticky="se")
formulaFrame <- tkframe(frame)
if (hasLhs){
tkgrid(labelRcmdr(outerOperatorsFrame, text=gettextRcmdr("Model Formula"),
fg=getRcmdr("title.color"), font="RcmdrTitleFont"), sticky="w")
tkgrid(labelRcmdr(outerOperatorsFrame, text="Operators (click to formula): "), operatorsFrame, sticky="nw")
tkgrid(bsplineButton, nsplineButton, polyButton, RawPolyButton, sticky="nw")
tkgrid(labelRcmdr(outerOperatorsFrame, text=gettextRcmdr("Splines/Polynomials:\n(select variable and click)")),
splinePolyFrame, dfDegFrame, sticky="nw")
lhsVariable <- if (currentModel) tclVar(currentFields$lhs) else tclVar("")
rhsVariable <- if (currentModel) tclVar(currentFields$rhs) else tclVar("")
rhsEntry <- ttkentry(formulaFrame, width="75", textvariable=rhsVariable)
rhsXscroll <- ttkscrollbar(formulaFrame,
orient="horizontal", command=function(...) tkxview(rhsEntry, ...))
tkconfigure(rhsEntry, xscrollcommand=function(...) tkset(rhsXscroll, ...))
lhsEntry <- ttkentry(formulaFrame, width="10", textvariable=lhsVariable)
lhsScroll <- ttkscrollbar(formulaFrame,
orient="horizontal", command=function(...) tkxview(lhsEntry, ...))
tkconfigure(lhsEntry, xscrollcommand=function(...) tkset(lhsScroll, ...))
tkgrid(lhsEntry, labelRcmdr(formulaFrame, text=" ~ "), rhsEntry, sticky="w")
tkgrid(lhsScroll, labelRcmdr(formulaFrame, text=""), rhsXscroll, sticky="w")
tkgrid.configure(lhsScroll, sticky="ew")
}
else{
rhsVariable <- if (currentModel) tclVar(currentFields$rhs) else tclVar("")
rhsEntry <- ttkentry(formulaFrame, width="75", textvariable=rhsVariable)
rhsXscroll <- ttkscrollbar(formulaFrame,
orient="horizontal", command=function(...) tkxview(rhsEntry, ...))
tkconfigure(rhsEntry, xscrollcommand=function(...) tkset(rhsXscroll, ...))
tkgrid(labelRcmdr(formulaFrame, text=" ~ "), rhsEntry, sticky="w")
tkgrid(labelRcmdr(formulaFrame, text=""), rhsXscroll, sticky="w")
}
tkgrid.configure(rhsXscroll, sticky="ew")
})
exists.method <- function(generic, object, default=TRUE, strict=FALSE){
classes <- class(object)
if (default) classes <- c(classes, "default")
if (strict) classes <- classes[1]
any(paste(generic, ".", classes, sep="") %in%
as.character(methods(generic)))
}
checkMethod <- defmacro(generic, object, message=NULL, default=FALSE, strict=FALSE, reportError=TRUE,
expr={
msg <- if (is.null(message)) sprintf(gettextRcmdr("No appropriate %s method exists\nfor a model of this class."), generic)
else message
method <- exists.method(generic, get(object), default=default, strict=strict)
if ((!method) && reportError) Message(message=msg, type="error")
method
}
)
checkClass <- defmacro(object, class, message=NULL,
expr={
msg <- if (is.null(message)) sprintf(gettextRcmdr('The model is not of class "%s".'), class)
else message
properClass <- class(get(object))[1] == class
if (!properClass) Message(message=msg, type="error")
properClass
}
)
# the following function is from John Chambers (plus new test for R 2.4.0)
isS4object <- function(object) {
if (getRversion() < "2.4.0"){
if (length(attr(object, "class"))!= 1)
return(FALSE)
!isVirtualClass(getClass(class(object), TRUE))
}
else isS4(object)
}
.RcmdrEnv <- new.env(parent=emptyenv())
# putRcmdr <- function(x, value) assign(x, value, envir=.RcmdrEnv)
#
# getRcmdr <- function(x, mode="any") get(x, envir=.RcmdrEnv, mode=mode, inherits=FALSE)
RcmdrEnv <- function() .RcmdrEnv
putRcmdr <- function(x, value) assign(x, value, envir=RcmdrEnv())
# getRcmdr <- function(x, mode="any") get(x, envir=RcmdrEnv(), mode=mode, inherits=FALSE)
getRcmdr <- function(x, mode="any", fail=TRUE){
if ((!fail) && (!exists(x, mode=mode, envir=RcmdrEnv(), inherits=FALSE))) return(NULL)
get(x, envir=RcmdrEnv(), mode=mode, inherits=FALSE)
}
RcmdrTclSet <- function(name, value){
name <- ls(unclass(getRcmdr(name))$env)
tcl("set", name, value)
}
# functions to store or retrieve Rcmdr state information
Variables <- function(names){
if (missing(names)) getRcmdr("variables")
else putRcmdr("variables", names)
}
Numeric <- function(names){
if (missing(names)) getRcmdr("numeric")
else putRcmdr("numeric", names)
}
Factors <- function(names){
if (missing(names)) getRcmdr("factors")
else putRcmdr("factors", names)
}
TwoLevelFactors <- function(names){
if (missing(names)) getRcmdr("twoLevelFactors")
else putRcmdr("twoLevelFactors", names)
}
# The following two functions were modified by Erich Neuwrith
# and subsequently by John Fox (23 July 07)
# and Milan Bouchet-Valat (27 March 14)
ActiveDataSet <- function(name){
if (missing(name)) {
temp <- getRcmdr(".activeDataSet")
if (is.null(temp))
return(NULL)
else
if (!exists(temp) || !is.data.frame(get(temp,envir=.GlobalEnv))) {
Message(sprintf(gettextRcmdr("the dataset %s is no longer available"),
temp), type="error")
putRcmdr(".activeDataSet", NULL)
Variables(NULL)
Numeric(NULL)
Factors(NULL)
TwoLevelFactors(NULL)
RcmdrTclSet("dataSetName", gettextRcmdr("<No active dataset>"))
putRcmdr(".activeModel", NULL)
RcmdrTclSet("modelName", gettextRcmdr("<No active model>"))
tkconfigure(getRcmdr("dataSetLabel"), foreground="red")
tkconfigure(getRcmdr("modelLabel"), foreground="red")
activateMenus()
if (getRcmdr("suppress.menus") && RExcelSupported()) return(NULL)
}
return(temp)
}
else {
putRcmdr(".activeDataSet", name)
if(!is.null(name)) {
Variables(listVariables(name))
Numeric(listNumeric(name))
Factors(listFactors(name))
TwoLevelFactors(listTwoLevelFactors(name))
}
else {
Variables(NULL)
Numeric(NULL)
Factors(NULL)
TwoLevelFactors(NULL)
RcmdrTclSet("dataSetName", gettextRcmdr("<No active dataset>"))
putRcmdr(".activeModel", NULL)
RcmdrTclSet("modelName", gettextRcmdr("<No active model>"))
tkconfigure(getRcmdr("dataSetLabel"), foreground="red")
tkconfigure(getRcmdr("modelLabel"), foreground="red")
activateMenus()
if (getRcmdr("suppress.menus") && RExcelSupported()) return(NULL)
}
}
}
ActiveModel <- function(name){
if (missing(name)) {
temp <- getRcmdr(".activeModel")
if (is.null(temp))
return(NULL)
else
if (!exists(temp) || !is.model(get(temp,envir=.GlobalEnv))) {
Message(sprintf(gettextRcmdr("the model %s is no longer available"),
temp), type="error")
putRcmdr(".activeModel", NULL)
RcmdrTclSet("modelName", gettextRcmdr("<No active model>"))
tkconfigure(getRcmdr("modelLabel"), foreground="red")
activateMenus()
return(NULL)
}
else return(temp)
}
else putRcmdr(".activeModel", name)
}
GrabFocus <- function(value){
if (missing(value)) getRcmdr("grab.focus")
else putRcmdr("grab.focus", value)
}
UpdateModelNumber <- function(increment=1){
modelNumber <- getRcmdr("modelNumber")
modelNumber <- modelNumber + increment
if (modelNumber < 1) modelNumber <- 1 # sanity check
putRcmdr("modelNumber", modelNumber)
}
CommanderWindow <- function() getRcmdr("commanderWindow")
LogWindow <- function() getRcmdr("logWindow")
RmdWindow <- function() getRcmdr("RmdWindow")
RnwWindow <- function() getRcmdr("RnwWindow")
OutputWindow <- function() getRcmdr("outputWindow")
MessagesWindow <- function() getRcmdr("messagesWindow")
# some predicates for the menu system
activeDataSetP <- function() !is.null(ActiveDataSet())
dataSetsP <- function(n=1){
datasets <- listDataSets()
(!is.null(datasets)) && length(datasets) >= n
}
numericP <- function(n=1) activeDataSetP() && length(listNumeric()) >= n
factorsP <- function(n=1) activeDataSetP() && length(listFactors()) >= n
twoLevelFactorsP <- function(n=1) activeDataSetP() && length(listTwoLevelFactors()) >= n
modelsP <- function(n=1) activeDataSetP() && length(listAllModels()) >= n
activeModelP <- function() !is.null(ActiveModel())
lmP <- function() activeModelP() && any(class(get(ActiveModel()))[1] == c('lm', 'aov'))
glmP <- function() activeModelP() && class(get(ActiveModel()))[1] == 'glm'
aicP <- function() activeModelP() && exists.method("extractAIC", get(ActiveModel()))
polrP <- function() activeModelP() && class(get(ActiveModel()))[1] == 'polr'
multinomP <- function() activeModelP() && class(get(ActiveModel()))[1] == 'multinom'
hclustSolutionsP <- function() length(listHclustSolutions()) > 0
MacOSXP <- function() {
sys <- Sys.info()
!is.null(sys) && length(grep("[Dd]arwin", sys["sysname"]) > 0)
}
packageAvailable <- function(name) 0 != length(find.package(name, quiet=TRUE))
rglLoaded <- function() 0 != length(grep("^rgl", loadedNamespaces()))
activateMenus <- function(){
if (getRcmdr("suppress.menus")) return()
for (item in getRcmdr("Menus")){
if (item$activation()) .Tcl(paste(item$ID, " entryconfigure ", item$position - 1," -state normal", sep=""))
else .Tcl(paste(item$ID, " entryconfigure ", item$position - 1," -state disabled", sep=""))
}
}
# for internationalization
gettextRcmdr <- function(...) gettext(..., domain="R-Rcmdr205")
gettextMenus <- function(...){
text <- gettextRcmdr(...)
plugins <- getOption("Rcmdr")$plugins
if (is.null(plugins)) return(text)
plugins <- paste("R-", plugins, sep="")
for (plugin in plugins){
text <- gettext(text, domain=plugin)
}
text
}
English <- function() {
env <- Sys.getenv()
names(env) <- toupper(names(env))
LANG <- env["LANGUAGE"]
LC_CTYPE <- Sys.getlocale("LC_CTYPE")
if (!is.na(LANG)) length(grep("^en", LANG, ignore.case=TRUE)) > 0
else LC_CTYPE == "C" || length(grep("^en", LC_CTYPE, ignore.case=TRUE)) > 0
}
# to replace tkmessageBox on non-English Windows systems,
# to allow for translation of button text
RcmdrTkmessageBox <- function(message, icon=c("info", "question", "warning",
"error"), type=c("okcancel", "yesno", "ok"), default, title="") {
if ( (English()) || (!WindowsP()) ){
if (missing(default)){
default <- switch(type,
okcancel="ok",
yesno="yes",
ok="ok")}
return(tkmessageBox(message=message, icon=icon, type=type,
default=default, title=title))
}
icon <- match.arg(icon)
type <- match.arg(type)
initializeDialog(messageBox, title=title)
messageFrame <- tkframe(messageBox, borderwidth=5)
buttonFrame <- tkframe(messageBox, borderwidth=5)
if (icon != "question") tkbell()
result <- tclVar()
iconColor <- switch(icon, info=getRcmdr("title.color"), question=getRcmdr("title.color"), warning="black",
error="red")
onOK <- function() {
if (GrabFocus()) tkgrab.release(messageBox)
tkdestroy(messageBox)
tkfocus(CommanderWindow())
tclvalue(result) <- "ok"
}
OKbutton <- buttonRcmdr(buttonFrame, text=gettextRcmdr("OK"),
foreground="darkgreen", width="12", command=onOK, borderwidth=3,
default=if (missing(default)) "active"
else if (default == "ok") "active" else "normal")
onCancel <- function() {
if (GrabFocus()) tkgrab.release(messageBox)
tkdestroy(messageBox)
tkfocus(CommanderWindow())
tclvalue(result) <- "cancel"
}
cancelButton <- buttonRcmdr(buttonFrame, text=gettextRcmdr("Cancel"),
foreground="red", width="12", command=onCancel, borderwidth=3,
default=if (missing(default)) "normal"
else if (default == "cancel") "active" else "normal")
onYes <- function() {
if (GrabFocus()) tkgrab.release(messageBox)
tkdestroy(messageBox)
tkfocus(CommanderWindow())
tclvalue(result) <- "yes"
}
yesButton <- buttonRcmdr(buttonFrame, text=gettextRcmdr("Yes"),
foreground="darkgreen", width="12", command=onYes, borderwidth=3,
default=if (missing(default)) "active"
else if (default == "yes") "active" else "normal")
onNo <- function() {
if (GrabFocus()) tkgrab.release(messageBox)
tkdestroy(messageBox)
tkfocus(CommanderWindow())
tclvalue(result) <- "no"
}
noButton <- buttonRcmdr(buttonFrame, text=gettextRcmdr("No"),
foreground="red", width="12", command=onNo, borderwidth=3,
default=if (missing(default)) "normal"
else if (default == "no") "active" else "normal")
## FIXME -- left in old style
tkgrid(tklabel(messageFrame, bitmap=icon, fg=iconColor),
tklabel(messageFrame, text=" "),
tklabel(messageFrame, text=message))
tkgrid(messageFrame)
switch(type,
okcancel = {
tkgrid(OKbutton, labelRcmdr(buttonFrame, text=" "), cancelButton)
if (missing(default) || default == "ok") tkbind(messageBox, "<Return>",
onOK)
else if (default == "cancel") tkbind(messageBox, "<Return>", onCancel)
},
yesno = {
tkgrid(yesButton, labelRcmdr(buttonFrame, text=" "), noButton)
if (missing(default) || default == "yes") tkbind(messageBox, "<Return>",
onYes)
else if (default == "no") tkbind(messageBox, "<Return>", onNo)
},
ok = {
tkgrid(OKbutton)
if (missing(default) || default == "ok") tkbind(messageBox, "<Return>",
onOK)
}
)
tkgrid(buttonFrame)
dialogSuffix(messageBox, focus=messageBox, bindReturn=FALSE)
result
}
# The following function was contributed by Matthieu Lesnoff (added 20 July 06)
trim.col.na <- function(dat){
# Remove variables with only missing values (occurs sometimes with modified Excel file)
colsup <- NULL
for (i in 1:ncol(dat))
{
if (length(dat[is.na(dat[,i])==T,i]) ==length(dat[,i]))
colsup <- c(colsup,i)
}
if (length(colsup) > 0)
dat <- dat[,-colsup]
dat
}
# check whether packages are available
packagesAvailable <- function(packages){
sapply(sapply(packages, find.package, quiet=TRUE),
function(x) length(x) != 0)
}
# insert a row (or rows) in a matrix or data frame
insertRows <- function(object1, object2, where=NULL, ...){
if (ncol(object1) != ncol(object2))
stop(gettextRcmdr("objects have different numbers of columns"))
if (!(TRUE == all.equal(colnames(object1), colnames(object2))))
stop(gettextRcmdr("objects have different column names"))
n <- nrow(object1)
if (is.null(where) || where >= n) rbind(object1, object2)
else if (where < 1) rbind(object2, object1)
else rbind(object1[1:floor(where),], object2,
object1[(floor(where) + 1):n,])
}
# functions for handling Rcmdr plug-in packages
# the following function based on a suggestion by Brian Ripley
listPlugins <- function(loaded=FALSE){
plugins <- unlist(lapply(.libPaths(),
function(x) Sys.glob(file.path(x, "*/etc/menus.txt"))))
plugins <- sub(".*/([^/]*)/etc/menus.txt", "\\1", plugins)
if (loaded) plugins else sort(setdiff(plugins, .packages()))
}
loadPlugins <- function(){
plugins <- listPlugins()
initializeDialog(title=gettextRcmdr("Load Plug-ins"))
packagesBox <- variableListBox(top, plugins, title=gettextRcmdr("Plug-ins (pick one or more)"),
selectmode="multiple", listHeight=10)
onOK <- function(){
plugins <- getSelection(packagesBox)
closeDialog(top)
if (length(plugins) == 0){
errorCondition(recall=loadPlugins, message=gettextRcmdr("You must select at least one plug-in."))
return()
}
opts <- options("Rcmdr")
opts$Rcmdr$plugins <- c(plugins, opts$Rcmdr$plugins)
options(opts)
for (plugin in plugins) {
command <- paste('library("', plugin, '", character.only=TRUE)', sep="")
justDoIt(command)
}
Message(paste(gettextRcmdr("Plug-ins loaded:"), paste(plugins, collapse=", ")), type="note")
response <- tkmessageBox(message=paste(gettextRcmdr(
"The plug-in(s) will not be available until the Commander is restarted.\nRestart now?")),
icon="question", type="yesno")
if (tclvalue(response) == "yes") {
putRcmdr("autoRestart", TRUE)
closeCommander(ask=FALSE)
Commander()
}
}
OKCancelHelp(helpSubject="Plugins")
tkgrid(getFrame(packagesBox), sticky="nw")
tkgrid(buttonsFrame, sticky="w")
dialogSuffix()
}
# the following two functions contributed by Erich Neuwirth (added 22 July 07)
whitespaceonly <- function(str) sub('[[:space:]]+$', '', str) == ''
is.model <- function(object) {
any(class(object) %in% getRcmdr("modelClasses"))
}
# the following lines, adding support for ttk widgets, adapted from code by Brian Ripley
if (!(as.character(tcl("info", "tclversion")) >= "8.5" && getRversion() >= "2.7.0")){
buttonRcmdr <- tkbutton
labelRcmdr <- tklabel
ttkentry <- function(parent, ...) tkentry(parent, ...)
ttkframe <- tkframe
ttkradiobutton <- tkradiobutton
ttkscrollbar <- function(...) tkscrollbar(..., repeatinterval=5)
} else {
buttonRcmdr <- function(..., borderwidth, fg, foreground, relief) ttkbutton(...)
labelRcmdr <- function(..., fg)
if(missing(fg)) ttklabel(...) else ttklabel(..., foreground=fg)
}
# Label looking like that of a TtkLabelFrame
titleLabel <- function(...) labelRcmdr(..., font="RcmdrTitleFont", fg=getRcmdr("title.color"))
# the following function alters the default behaviour of tclvalue() by trimming leading and trailing blanks
tclvalue <- function(x) trim.blanks(tcltk::tclvalue(x))
# the following function splits a character string at blanks and commas according to width
splitCmd <- function(cmd, width=getOption("width") - 4, at="[ ,]"){
if (nchar(cmd) <= width) return(cmd)
where <- gregexpr(at, cmd)[[1]]
if (where[1] < 0) return(cmd)
singleQuotes <- gregexpr("'", cmd)[[1]]
doubleQuotes <- gregexpr('"', cmd)[[1]]
comment <- regexpr("#", cmd)
if (singleQuotes[1] > 0 && (singleQuotes[1] < doubleQuotes[1] || doubleQuotes[1] < 0 ) && (singleQuotes[1] < comment[1] || comment[1] < 0 )){
nquotes <- length(singleQuotes)
if (nquotes < 2) stop("unbalanced quotes")
for(i in seq(nquotes/2))
where[(where > singleQuotes[2 * i - 1]) & (where < singleQuotes[2 * i])] <- NA
where <- na.omit(where)
}
else if (doubleQuotes[1] > 0 && (doubleQuotes[1] < singleQuotes[1] || singleQuotes[1] < 0) && (doubleQuotes[1] < comment[1] || comment[1] < 0 )){
nquotes <- length(doubleQuotes)
if (nquotes < 2) stop("unbalanced quotes")
for(i in seq(nquotes/2))
where[(where > doubleQuotes[2 * i - 1]) & (where < doubleQuotes[2 * i])] <- NA
where <- na.omit(where)
}
else if (comment > 0){
where[where > comment] <- NA
where <- na.omit(where)
}
if (length(where) == 0) return(cmd)
where2 <- where[where <= width]
where2 <- if (length(where2) == 0) where[1]
else where2[length(where2)]
paste(substr(cmd, 1, where2), "\n ",
Recall(substr(cmd, where2 + 1, nchar(cmd)), width, at), sep="")
}
# the following function sorts names containing numerals "more naturally" than does sort()
sortVarNames <- function(x){
sort.helper <- function(x){
prefix <- strsplit(x, "[0-9]+")
prefix <- sapply(prefix, "[", 1)
prefix[is.na(prefix)] <- ""
suffix <- strsplit(x, "[^0-9]+")
suffix <- as.numeric(sapply(suffix, "[", 2))
suffix[is.na(suffix)] <- -Inf
remainder <- sub("[^0-9]+", "", x)
remainder <- sub("[0-9]+", "", remainder)
if (all (remainder == "")) list(prefix, suffix)
else c(list(prefix, suffix), Recall(remainder))
}
ord <- do.call("order", sort.helper(x))
x[ord]
}
# to load packages
Library <- function(package, pos=4, rmd=TRUE){
loaded <- search()
loaded <- loaded[grep("^package:", loaded)]
loaded <- sub("^package:", "", loaded)
if (!getRcmdr("suppress.X11.warnings")){
messages.connection <- file(open="w+")
sink(messages.connection, type="message")
on.exit({
sink(type="message")
close(messages.connection)
})
}
if (!(package %in% loaded)){
command <- paste("library(", package, ", pos=", pos, ")", sep="")
logger(command, rmd=rmd)
result <- try(eval(parse(text=command), envir=.GlobalEnv), silent=TRUE)
if (class(result)[1] == "try-error"){
Message(message=paste(strsplit(result, ":")[[1]][2]), type="error")
tkfocus(CommanderWindow())
return("error")
}
return(package)
}
else return(invisible(NULL))
}
# to merge data frames by rows
mergeRows <- function(X, Y, common.only=FALSE, ...){
UseMethod("mergeRows")
}
mergeRows.data.frame <- function(X, Y, common.only=FALSE, ...){
cols1 <- names(X)
cols2 <- names(Y)
if (common.only){
common <- intersect(cols1, cols2)
rbind(X[, common], Y[, common])
}
else {
all <- union(cols1, cols2)
miss1 <- setdiff(all, cols1)
miss2 <- setdiff(all, cols2)
X[, miss1] <- NA
Y[, miss2] <- NA
rbind(X, Y)
}
}
# start help system
startHelp <- function(){
Sys.sleep(2)
help.start()
}
# dialog memory support
putDialog <- function (dialog, values=NULL, resettable=TRUE){
if (resettable){
dialog.values <- getRcmdr("dialog.values")
dialog.values[[dialog]] <- values
putRcmdr("dialog.values", dialog.values)
}
else{
dialog.values <- getRcmdr("dialog.values.noreset")
dialog.values[[dialog]] <- values
putRcmdr("dialog.values.noreset", dialog.values)
}
}
getDialog <- function(dialog, defaults=NULL){
values <- getRcmdr("dialog.values.noreset")[[dialog]]
if (getRcmdr("retain.selections") && !is.null(values)) return(values)
values <- getRcmdr("dialog.values")[[dialog]]
if (!getRcmdr("retain.selections") || is.null(values)) return(defaults)
else return (values)
}
varPosn <- function(variables, type=c("all", "factor", "numeric", "nonfactor", "twoLevelFactor")){
if (is.null(variables)) return(NULL)
type <- match.arg(type)
vars <- switch(type,
all = Variables(),
factor = Factors(),
numeric = Numeric(),
nonfactor = setdiff(Variables(), Factors()),
twoLevelFactor = TwoLevelFactors()
)
if (any(!variables %in% vars)) NULL
else apply(outer(variables, vars, "=="), 1, which) - 1
}
flushDialogMemory <- function(what){
if (missing(what)) putRcmdr("dialog.values", list())
else{
dialog.values <- getRcmdr("dialog.values")
dialog.values.noreset <- getRcmdr("dialog.values.noreset")
for (dialog in what){
dialog.values[dialog] <- NULL
dialog.values.noreset[dialog] <- NULL
}
putRcmdr("dialog.values", dialog.values)
putRcmdr("dialog.values.noreset", dialog.values.noreset)
}
}
# for assignments to the global environment
gassign <- function(x, value){
if (!(is.valid.name(x))) stop("argument x not a valid R name")
G <- .GlobalEnv
assign(x, value, envir=G)
}
# because it's no longer possible to access these functions from their packages:
# from car:
coef.multinom <- function (object, ...)
{
# the following from nnet:
cf <- function (object, ...)
{
r <- length(object$vcoefnames)
if (length(object$lev) == 2L) {
coef <- object$wts[1L + (1L:r)]
names(coef) <- object$vcoefnames
}
else {
coef <- matrix(object$wts, nrow = object$n[3L], byrow = TRUE)[,
1L + (1L:r), drop = FALSE]
if (length(object$lev))
dimnames(coef) <- list(object$lev, object$vcoefnames)
if (length(object$lab))
dimnames(coef) <- list(object$lab, object$vcoefnames)
coef <- coef[-1L, , drop = FALSE]
}
coef
}
b <- cf(object, ...)
cn <- colnames(b)
rn <- rownames(b)
b <- as.vector(t(b))
names(b) <- as.vector(outer(cn, rn, function(c, r) paste(r,
c, sep = ":")))
b
}
# from MASS:
confint.glm <- function (object, parm, level = 0.95, trace = FALSE, ...)
{
pnames <- names(coef(object))
if (missing(parm))
parm <- seq_along(pnames)
else if (is.character(parm))
parm <- match(parm, pnames, nomatch = 0L)
message("Waiting for profiling to be done...")
utils::flush.console()
object <- profile(object, which = parm, alpha = (1 - level)/4,
trace = trace)
confint(object, parm = parm, level = level, trace = trace,
...)
}
tkfocus <- function(...) tcl("focus", ...)
tkspinbox <- function(parent, ...) tkwidget(parent, "spinbox", ...)
# the following two functions adapted from Milan Bouchet-Valat
WindowsP <- function() {
.Platform$OS.type == "windows"
}
X11P <- function(){
.Platform$GUI == "X11"
}
# the following functions to support R Markdown
suppressMarkdown <- function(command){
attr(command, "suppressRmd") <- TRUE
command
}
beginRmdBlock <- function(){
.rmd <- RmdWindow()
last2 <- tclvalue(tkget(.rmd, "end -2 chars", "end"))
if (last2 != "\n\n") tkinsert(.rmd, "end", "\n")
tkinsert(.rmd, "end", "\n")
tkinsert(.rmd, "end", "```{r}\n")
}
endRmdBlock <- function(){
.rmd <- RmdWindow()
rmd <- tclvalue(tkget(.rmd, "1.0", "end"))
rmd <- paste(substring(rmd, 1, nchar(rmd) - 1), "```\n", sep="")
rmd <- trimHangingEndRmdBlock(rmd)
tkdelete(.rmd, "1.0", "end")
tkinsert(.rmd, "end", rmd)
tkyview.moveto(.rmd, 1)
}
removeNullRmdBlocks <- function(){
.rmd <- RmdWindow()
rmd <- tclvalue(tkget(.rmd, "1.0", "end"))
rmd <- gsub("\n+$", "\n", rmd)
rmd <- gsub("```\\{r\\}\n$", "", rmd)
rmd <- gsub("```\\{r\\}\n```\n$", "", rmd)
tkdelete(.rmd, "1.0", "end")
tkinsert(.rmd, "end", rmd)
tkyview.moveto(.rmd, 1)
}
removeStrayRmdBlocks <- function(){
.rmd <- RmdWindow()
rmd <- tclvalue(tkget(.rmd, "1.0", "end"))
rmd <- strsplit(rmd, "\\n")[[1]]
starts <- grep("^```\\{r.*\\}$", rmd)
ends <- grep("^```$", rmd)
n.ends <- length(ends)
j <- 1
if (length(starts) > 1){
for (i in 1:(length(starts) - 1)){
if (j > n.ends || ends[j] > starts[i + 1]) {
rmd[starts[i]] <- ""
}
else {
j <- j + 1
next
}
}
}
else return()
rmd <- paste(rmd, collapse="\n")
tkdelete(.rmd, "1.0", "end")
tkinsert(.rmd, "end", rmd)
tkyview.moveto(.rmd, 1)
}
enterMarkdown <- function(command){
if (!getRcmdr("use.markdown")) return()
.rmd <- RmdWindow()
command <- splitCmd(command)
beginRmdBlock()
tkinsert(.rmd, "end", paste(command, "\n", sep=""))
tkyview.moveto(.rmd, 1)
putRcmdr("markdown.output", TRUE)
endRmdBlock()
command
}
trimHangingEndRmdBlock <- function(string){
loc.ends <- gregexpr("```\n", string)[[1]]
n.ends <- length(loc.ends)
if (n.ends > 1){
substr <- substring(string, loc.ends[n.ends - 1], loc.ends[n.ends])
if (!grepl("```\\{r\\}", substr)){
string <- cutstring(string, loc.ends[n.ends], loc.ends[n.ends] + 3)
}
}
string
}
removeLastRmdBlock <- function(){
.rmd <- RmdWindow()
rmd <- tclvalue(tkget(.rmd, "1.0", "end"))
start <- gregexpr("```\\{r\\}\n", rmd)
if (start[[1]][1] > 0){
start <- start[[1]]
start <- start[length(start)]
tail <- substring(rmd, start, nchar(rmd))
end <- gregexpr("```\n", tail)
end <- if (end[[1]][1] > 0) end[[1]][1] + 3 else nchar(tail)
rmd <- cutstring(rmd, start, start + end)
tkdelete(.rmd, "1.0", "end")
tkinsert(.rmd, "end", rmd)
tkyview.moveto(.rmd, 1)
}
}
cutstring <- function(x, start=1, end=nchar(x)){
one <- if (start > 1) substr(x, 1, start - 1) else ""
two <- if (end < nchar(x)) substr(x, end + 1, nchar(x)) else ""
paste0(one, two)
}
MarkdownP <- function(){
getRcmdr("log.commands") && getRcmdr("use.markdown")
}
compileRmd <- function() {
if (!(require(knitr))) return()
if (!(require(markdown))) return()
fig.files <- list.files("./figure")
fig.files <- fig.files[grep("^unnamed-chunk-[0-9]*\\..*$", fig.files)]
if (length(fig.files) != 0) {
response <- tkmessageBox(message = gettextRcmdr("Delete previously created R Markdown\ngraphics files (recommended)?"),
icon = "question", type = "okcancel", default = "ok")
if (tclvalue(response) == "ok") unlink(paste("./figure/", fig.files, sep=""))
}
removeStrayRmdBlocks()
lines <- tclvalue(tkget(RmdWindow(), "1.0", "end"))
.RmdFile <- getRcmdr("RmdFileName")
.filename <- sub("\\.Rmd$", "", trim.blanks(.RmdFile))
writeLines(lines, .RmdFile)
knit(.RmdFile, paste(.filename, ".md", sep=""), quiet=TRUE)
.html.file <- paste(.filename, ".html", sep="")
markdownToHTML(paste(.filename, ".md", sep=""), .html.file)
.html.file.location <- paste("file:///", normalizePath(.html.file), sep="")
browseURL(.html.file.location)
}
# the following functions to support knitr
beginRnwBlock <- function(){
.rnw <- RnwWindow()
last2 <- tclvalue(tkget(.rnw, "end -2 chars", "end"))
if (last2 != "\n\n") tkinsert(.rnw, "end", "\n")
tkinsert(.rnw, "end", "\n")
tkinsert(.rnw, "end", "\\newpage\n")
tkinsert(.rnw, "end", "<<>>=\n")
}
endRnwBlock <- function(){
.rnw <- RnwWindow()
rnw <- tclvalue(tkget(.rnw, "1.0", "end"))
rnw <- paste(substring(rnw, 1, nchar(rnw) - 1), "@\n", sep="")
rnw <- trimHangingEndRnwBlock(rnw)
tkdelete(.rnw, "1.0", "end")
tkinsert(.rnw, "end", rnw)
tkyview.moveto(.rnw, 1)
}
removeNullRnwBlocks <- function(){
.rnw <- RnwWindow()
rnw <- tclvalue(tkget(.rnw, "1.0", "end"))
rnw <- gsub("\n+$", "\n", rnw)
rnw <- gsub("<<>>=\n$", "", rnw)
rnw <- gsub("<<>>=\n@\n$", "", rnw)
rnw <- gsub("\\\\newpage\n*$", "", rnw)
rnw <- gsub("\\\\newpage\n*$", "", rnw)
tkdelete(.rnw, "1.0", "end")
tkinsert(.rnw, "end", rnw)
tkyview.moveto(.rnw, 1)
}
removeStrayRnwBlocks <- function(){
.rnw <- RnwWindow()
rnw <- tclvalue(tkget(.rnw, "1.0", "end"))
rnw <- strsplit(rnw, "\\n")[[1]]
starts <- grep("^<<.*>>=$", rnw)
ends <- grep("^@$", rnw)
n.ends <- length(ends)
j <- 1
if (length(starts) > 1){
for (i in (length(starts) - 1)){
if (j > n.ends || ends[j] > starts[i + 1]) {
rnw[starts[i]] <- ""
}
else {
j <- j + 1
next
}
}
}
else return()
rnw <- paste(rnw, collapse="\n")
tkdelete(.rnw, "1.0", "end")
tkinsert(.rnw, "end", rnw)
tkyview.moveto(.rnw, 1)
}
enterKnitr <- function(command){
.rnw <- RnwWindow()
if (!getRcmdr("use.knitr")) return()
command <- splitCmd(command)
beginRnwBlock()
tkinsert(.rnw, "end", paste(command, "\n", sep=""))
tkyview.moveto(.rnw, 1)
putRcmdr("knitr.output", TRUE)
endRnwBlock()
command
}
trimHangingEndRnwBlock <- function(string){
loc.ats <- gregexpr("@\n", string)[[1]]
n.ats <- length(loc.ats)
if (n.ats > 1){
substr <- substring(string, loc.ats[n.ats - 1], loc.ats[n.ats])
if (!grepl("<<>>=", substr)){
string <- cutstring(string, loc.ats[n.ats], loc.ats[n.ats] + 1)
}
}
string
}
removeLastRnwBlock <- function(){
.rnw <- RnwWindow()
rnw <- tclvalue(tkget(.rnw, "1.0", "end"))
start <- gregexpr("\\\\newpage\n<<>>=\n", rnw)
if (start[[1]][1] > 0){
start <- start[[1]]
start <- start[length(start)]
tail <- substring(rnw, start, nchar(rnw))
end <- gregexpr("@\n", tail)
end <- if (end[[1]][1] > 0) end[[1]][1] + 1 else nchar(tail)
rnw <- cutstring(rnw, start, start + end)
tkdelete(.rnw, "1.0", "end")
tkinsert(.rnw, "end", rnw)
tkyview.moveto(.rnw, 1)
}
}
compileRnw <- function(){
if (!require(knitr)) return()
fig.files <- list.files("./figure")
fig.files <- fig.files[grep("^unnamed-chunk-[0-9]*\\..*$", fig.files)]
if (length(fig.files) != 0) {
response <- tkmessageBox(message = gettextRcmdr("Delete previously created knitr\ngraphics files (recommended)?"),
icon = "question", type = "okcancel", default = "ok")
if (tclvalue(response) == "ok") unlink(paste("./figure/", fig.files, sep=""))
}
removeStrayRnwBlocks()
lines <- tclvalue(tkget(RnwWindow(), "1.0", "end"))
lines <- paste(lines, "\n\\end{document}\n")
.RnwFile <- getRcmdr("RnwFileName")
.filename <- sub("\\.Rnw$", "", trim.blanks(.RnwFile))
writeLines(lines, .RnwFile)
knit2pdf(.RnwFile)
.pdf.file <- paste(.filename, ".pdf", sep="")
.pdf.file.location <- paste("file:///", normalizePath(.pdf.file), sep="")
browseURL(.pdf.file.location)
}
knitrP <- function(){
getRcmdr("log.commands") && getRcmdr("use.knitr")
}
# editor for R Markdown and knitr documents
RcmdrEditor <- function(buffer, title="R Commander Editor",
help=NULL, file.menu=NULL, edit.menu=NULL, context.menu=NULL, toolbar.buttons=NULL){
contextMenu <- function(){
contextMenu <- tkmenu(tkmenu(editor), tearoff=FALSE)
if (!is.null(context.menu)){
for (item in context.menu){
tkadd(contextMenu, "command", label=gettextRcmdr(item$label), command=item$command)
}
tkadd(contextMenu, "separator")
}
tkadd(contextMenu, "command", label=gettextRcmdr("Cut"), command=onCut)
tkadd(contextMenu, "command", label=gettextRcmdr("Copy"), command=onCopy)
tkadd(contextMenu, "command", label=gettextRcmdr("Paste"), command=onPaste)
tkadd(contextMenu, "command", label=gettextRcmdr("Delete"), command=onDelete)
tkadd(contextMenu, "separator")
tkadd(contextMenu, "command", label=gettextRcmdr("Find..."), command=onFind)
tkadd(contextMenu, "command", label=gettextRcmdr("Select all"), command=onSelectAll)
tkadd(contextMenu, "separator")
tkadd(contextMenu, "command", label=gettextRcmdr("Undo"), command=onUndo)
tkadd(contextMenu, "command", label=gettextRcmdr("Redo"), command=onRedo)
tkadd(contextMenu, "separator")
tkadd(contextMenu, "command", label=gettextRcmdr("Clear window"), command=onClear)
tkpopup(contextMenu, tkwinfo("pointerx", editor), tkwinfo("pointery", editor))
}
onCopy <- function(){
selection <- strsplit(tclvalue(tktag.ranges(editor, "sel")), " ")[[1]]
if (is.na(selection[1])) return()
text <- tclvalue(tkget(editor, selection[1], selection[2]))
tkclipboard.clear()
tkclipboard.append(text)
}
onDelete <- function(){
selection <- strsplit(tclvalue(tktag.ranges(editor, "sel")), " ")[[1]]
if (is.na(selection[1])) return()
tkdelete(editor, selection[1], selection[2])
}
onCut <- function(){
onCopy()
onDelete()
}
onPaste <- function(){
onDelete()
text <- tclvalue(.Tcl("selection get -selection CLIPBOARD"))
if (length(text) == 0) return()
tkinsert(editor, "insert", text)
}
onFind <- function(){
initializeDialog(title=gettextRcmdr("Find"))
textFrame <- tkframe(top)
textVar <- tclVar(getRcmdr("last.search"))
textEntry <- ttkentry(textFrame, width="20", textvariable=textVar)
checkBoxes(frame="optionsFrame", boxes=c("regexpr", "case"), initialValues=c("0", "1"),
labels=gettextRcmdr(c("Regular-expression search", "Case sensitive")))
radioButtons(name="direction", buttons=c("foward", "backward"), labels=gettextRcmdr(c("Forward", "Backward")),
values=c("-forward", "-backward"), title=gettextRcmdr("Search Direction"))
onOK <- function(){
text <- tclvalue(textVar)
putRcmdr("last.search", text)
if (text == ""){
errorCondition(recall=onFind, message=gettextRcmdr("No search text specified."))
return()
}
type <- if (tclvalue(regexprVariable) == 1) "-regexp" else "-exact"
case <- tclvalue(caseVariable) == 1
direction <- tclvalue(directionVariable)
stop <- if (direction == "-forward") "end" else "1.0"
where.txt <- if (case) tksearch(editor, type, direction, "--", text, "insert", stop)
else tksearch(editor, type, direction, "-nocase", "--", text, "insert", stop)
where.txt <- tclvalue(where.txt)
if (where.txt == "") {
Message(message=gettextRcmdr("Text not found."),
type="note")
if (GrabFocus()) tkgrab.release(top)
tkdestroy(top)
tkfocus(CommanderWindow())
return()
}
if (GrabFocus()) tkgrab.release(top)
tkfocus(editor)
tkmark.set(editor, "insert", where.txt)
tksee(editor, where.txt)
tkdestroy(top)
}
.exit <- function(){
text <- tclvalue(textVar)
putRcmdr("last.search", text)
return("")
}
OKCancelHelp()
tkgrid(labelRcmdr(textFrame, text=gettextRcmdr("Search for:")), textEntry, sticky="w")
tkgrid(textFrame, sticky="w")
tkgrid(optionsFrame, sticky="w")
tkgrid(directionFrame, sticky="w")
tkgrid(buttonsFrame, sticky="w")
dialogSuffix(focus=textEntry)
}
onSelectAll <- function() {
tktag.add(editor, "sel", "1.0", "end")
tkfocus(editor)
}
onClear <- function(){
onSelectAll()
onDelete()
}
onUndo <- function(){
tcl(editor, "edit", "undo")
}
onRedo <- function(){
tcl(editor, "edit", "redo")
}
initializeDialog(title = gettextRcmdr(title))
toolbarFrame <- tkframe(top)
cutButton <- buttonRcmdr(toolbarFrame, image="::image::cutIcon", command=onCut)
copyButton <- buttonRcmdr(toolbarFrame, image="::image::copyIcon", command=onCopy)
pasteButton <- buttonRcmdr(toolbarFrame, image="::image::pasteIcon", command=onPaste)
deleteButton <- buttonRcmdr(toolbarFrame, image="::image::deleteIcon", command=onDelete)
undoButton <- buttonRcmdr(toolbarFrame, image="::image::undoIcon", command=onUndo)
redoButton <- buttonRcmdr(toolbarFrame, image="::image::redoIcon", command=onRedo)
findButton <- buttonRcmdr(toolbarFrame, image="::image::findIcon", command=onFind)
if (!is.null(toolbar.buttons)){
for (i in 1:length(toolbar.buttons)){
tool <- toolbar.buttons[[i]]
assign(paste("var", i, sep=""), tclVar(gettextRcmdr(tool$label)))
assign(paste("button", i, sep=""), buttonRcmdr(toolbarFrame, textvariable=eval(parse(text=paste("var", i, sep=""))),
borderwidth="2", command=tool$command, image=tool$image, compound="left"))
}
}
editorFrame <- tkframe(top)
screenheight <- as.numeric(.Tcl(paste("winfo screenheight", top$ID)))
char.size <- as.numeric(.Tcl(paste("font metrics", getRcmdr('logFont'))))[6]
width <- as.numeric(tkcget(LogWindow(), "-width")) + 5
height <- max(floor(screenheight/(2.5*char.size)), 25)
editor <- tktext(editorFrame, bg = "white", font = getRcmdr("logFont"),
height = height, width = width, wrap = "none", undo=TRUE)
putRcmdr("editor.text", editor)
editorXscroll <- ttkscrollbar(editorFrame, orient = "horizontal",
command = function(...) tkxview(editor, ...))
editorYscroll <- ttkscrollbar(editorFrame, command = function(...) tkyview(editor,
...))
tkconfigure(editor, xscrollcommand = function(...) tkset(editorXscroll,
...))
tkconfigure(editor, yscrollcommand = function(...) tkset(editorYscroll,
...))
tkinsert(editor, "1.0", buffer)
putRcmdr("buffer", NULL)
onOK <- function(){
putRcmdr("buffer", tclvalue(tkget(editor, "1.0", "end")))
closeDialog()
}
.exit <- function(){
answer <- RcmdrTkmessageBox("Discard edits?", icon="question", type="yesno")
if (as.character(answer) == "no") "abort" else ""
}
OKCancelHelp(helpSubject = "ScriptEditor")
editorMenu <- tkmenu(top)
tkconfigure(top, menu = editorMenu)
fileMenu <- tkmenu(editorMenu, tearoff=FALSE)
if (!is.null(file.menu)){
for (item in file.menu){
tkadd(fileMenu, "command", label=gettextRcmdr(item$label), command=item$command)
}
tkadd(fileMenu, "separator")
}
tkadd(fileMenu, "command", label=gettextRcmdr("Exit editor"), command=onOK)
tkadd(fileMenu, "command", label=gettextRcmdr("Cancel"), command=onCancel)
tkadd(editorMenu, "cascade", label=gettextRcmdr("File"), menu=fileMenu)
editMenu <- tkmenu(editorMenu, tearoff=FALSE)
if (!is.null(edit.menu)){
for (item in edit.menu){
tkadd(editMenu, "command", label=gettextRcmdr(item$label), command=item$command)
}
tkadd(editMenu, "separator")
}
tkadd(editMenu, "command", label=gettextRcmdr("Cut"), command=onCut)
tkadd(editMenu, "command", label=gettextRcmdr("Copy"), command=onCopy)
tkadd(editMenu, "command", label=gettextRcmdr("Paste"), command=onPaste)
tkadd(editMenu, "command", label=gettextRcmdr("Delete"), command=onDelete)
tkadd(editMenu, "separator")
tkadd(editMenu, "command", label=gettextRcmdr("Find..."), command=onFind)
tkadd(editMenu, "command", label=gettextRcmdr("Select all"), command=onSelectAll)
tkadd(editMenu, "separator")
tkadd(editMenu, "command", label=gettextRcmdr("Undo"), command=onUndo)
tkadd(editMenu, "command", label=gettextRcmdr("Redo"), command=onRedo)
tkadd(editMenu, "separator")
tkadd(editMenu, "command", label=gettextRcmdr("Clear window"), command=onClear)
tkadd(editorMenu, "cascade", label=gettextRcmdr("Edit"), menu=editMenu)
helpMenu <- tkmenu(editorMenu, tearoff=FALSE)
onEditorHelp <- function() print(help("ScriptEditor", package="Rcmdr"))
tkadd(helpMenu, "command", label=gettextRcmdr("Editor help"), command=onEditorHelp)
if (!is.null(help)){
tkadd(helpMenu, "command", label=gettextRcmdr(help$label), command=help$command)
}
tkadd(editorMenu, "cascade", label=gettextRcmdr("Help"), menu=helpMenu)
tkgrid(editor, editorYscroll, sticky = "nsew")
tkgrid(editorXscroll)
if (!is.null(toolbar.buttons)){
for (i in 1:length(toolbar.buttons)){
tkgrid(eval(parse(text=paste("button", i, sep=""))), sticky="w", row=0, column=i - 1,
padx=c(3, 3), pady=c(0, 8))
}
}
else i <- 0
tkgrid(cutButton, sticky="w", row=0, column=i, padx=c(3, 3), pady=c(0, 8))
tkgrid(copyButton, sticky="w", row=0, column=i + 1, padx=c(3, 3), pady=c(0, 8))
tkgrid(pasteButton, sticky="w", row=0, column=i + 2, padx=c(3, 3), pady=c(0, 8))
tkgrid(deleteButton, sticky="w", row=0, column=i + 3, padx=c(3, 3), pady=c(0, 8))
tkgrid(undoButton, sticky="w", row=0, column=i + 4, padx=c(3, 3), pady=c(0, 8))
tkgrid(redoButton, sticky="w", row=0, column=i + 5, padx=c(3, 3), pady=c(0, 8))
tkgrid(findButton, sticky="w", row=0, column=i + 6, padx=c(3, 3), pady=c(0, 8))
tkgrid(toolbarFrame, sticky="w")
tk2tip(cutButton, gettextRcmdr("Cut"))
tk2tip(copyButton, gettextRcmdr("Copy"))
tk2tip(pasteButton, gettextRcmdr("Paste"))
tk2tip(deleteButton, gettextRcmdr("Delete"))
tk2tip(undoButton, gettextRcmdr("Undo"))
tk2tip(redoButton, gettextRcmdr("Redo"))
tk2tip(findButton, gettextRcmdr("Find"))
tkgrid(editorFrame, sticky = "nsew")
tkgrid.configure(editorXscroll, sticky = "ew")
tkgrid.configure(editorYscroll, sticky = "ns")
tkgrid.configure(editor, sticky = "nsew")
tkgrid.configure(editorFrame, sticky = "nsew")
tkgrid(buttonsFrame, sticky = "ew")
tkbind(top, "<ButtonPress-3>", contextMenu)
tkbind(top, "<Control-x>", onCut)
tkbind(top, "<Control-X>", onCut)
tkbind(top, "<Control-c>", onCopy)
tkbind(top, "<Control-C>", onCopy)
tkbind(top, "<Control-f>", onFind)
tkbind(top, "<Control-F>", onFind)
tkbind(top, "<F3>", onFind)
tkbind(top, "<Control-a>", onSelectAll)
tkbind(top, "<Control-A>", onSelectAll)
tkbind(top, "<Control-w>", onRedo)
tkbind(top, "<Control-W>", onRedo)
tkbind(top, "<Alt-BackSpace>", onUndo)
if (MacOSXP()){
tkbind(top, "<Meta-x>", onCut)
tkbind(top, "<Meta-X>", onCut)
tkbind(top, "<Meta-c>", onCopy)
tkbind(top, "<Meta-C>", onCopy)
tkbind(top, "<Meta-v>", onPaste)
tkbind(top, "<Meta-V>", onPaste)
tkbind(top, "<Meta-f>", onFind)
tkbind(top, "<Meta-F>", onFind)
tkbind(top, "<Meta-a>", onSelectAll)
tkbind(top, "<Meta-A>", onSelectAll)
tkbind(top, "<Meta-w>", onRedo)
tkbind(top, "<Meta-W>", onRedo)
}
tkwm.protocol(top, "WM_DELETE_WINDOW", onCancel)
tkgrid.rowconfigure(top, 1, weight=0)
tkgrid.rowconfigure(top, 0, weight=1)
tkgrid.columnconfigure(top, 0, weight=1)
tkgrid.rowconfigure(editorFrame, 1, weight=0)
tkgrid.rowconfigure(editorFrame, 0, weight=1)
tkgrid.columnconfigure(editorFrame, 0, weight=1)
tkgrid.columnconfigure(editorFrame, 1, weight=0)
dialogSuffix(bindReturn = FALSE, resizable=TRUE, focus=editor)
}
# the rgb2col function translates #RRGGBB colors to names if a named color exists or otherwise a "close" color (not exported)
# uses code from r-help adapted from Kevin Wright
rgb2col <- local({
all.names <- colors(distinct=TRUE)
all.lab <- t(convertColor(t(col2rgb(all.names)), from = "sRGB",
to = "Lab", scale.in = 255))
findNear <- function(x.lab) {
sq.dist <- colSums((all.lab - x.lab)^2)
rbind(all.names[which.min(sq.dist)], min(sq.dist))
}
function(cols.hex, near = 15) { # near = 2.3 is nominally the JND
cols.lab <- t(convertColor(t(col2rgb(cols.hex)), from = "sRGB",
to = "Lab", scale.in = 255))
cols.near <- apply(cols.lab, 2, findNear)
ifelse(as.numeric(cols.near[2, ]) < near^2, cols.near[1, ], toupper(cols.hex))
}
})
# the following function is for plug-ins that test for SciViews (which is no longer supported)
is.SciViews <- function() FALSE
# the following two functions from Milan Bouchet-Valat
setBusyCursor <- function() {
.commander <- CommanderWindow()
.menu <- tkcget(.commander, menu=NULL)
.log <- LogWindow()
.output <- OutputWindow()
.messages <- MessagesWindow()
tkconfigure(.commander, cursor="watch")
tkconfigure(.menu, cursor="watch")
tkconfigure(.log, cursor="watch")
tkconfigure(.output, cursor="watch")
tkconfigure(.messages, cursor="watch")
}
setIdleCursor <- function() {
.commander <- CommanderWindow()
.menu <- tkcget(.commander, menu=NULL)
.log <- LogWindow()
.output <- OutputWindow()
.messages <- MessagesWindow()
tkconfigure(.commander, cursor="")
tkconfigure(.menu, cursor="")
tkconfigure(.log, cursor="xterm")
tkconfigure(.output, cursor="xterm")
tkconfigure(.messages, cursor="xterm")
}
Try the Rcmdr205 package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.