.packageName <- "Rcmdr" Recode <- function(){ require("car") processRecode <- function(recode){ parts <- strsplit(recode, "=")[[1]] if (length(grep(",", parts[1])) > 0) paste("c(", parts[1], ") = ", parts[2], sep="") else paste(parts, collapse="=") } dataSet <- activeDataSet() initializeDialog(title=gettextRcmdr("Recode Variables")) variablesBox <- variableListBox(top, Variables(), selectmode="multiple", title=gettextRcmdr("Variables to recode (pick one or more)")) variablesFrame <- tkframe(top) newVariableName <- tclVar(gettextRcmdr("variable")) newVariable <- tkentry(variablesFrame, width="20", textvariable=newVariableName) recodesFrame <- tkframe(top) recodes <- tktext(recodesFrame, bg="white", font=getRcmdr("logFont"), height="5", width="40", wrap="none") recodesXscroll <- tkscrollbar(recodesFrame, repeatinterval=5, orient="horizontal", command=function(...) tkxview(recodes, ...)) recodesYscroll <- tkscrollbar(recodesFrame, repeatinterval=5, command=function(...) tkyview(recodes, ...)) tkconfigure(recodes, xscrollcommand=function(...) tkset(recodesXscroll, ...)) tkconfigure(recodes, yscrollcommand=function(...) tkset(recodesYscroll, ...)) asFactorFrame <- tkframe(top) asFactorVariable <- tclVar("1") asFactorCheckBox <- tkcheckbutton(asFactorFrame, variable=asFactorVariable) onOK <- function(){ asFactor <- tclvalue(asFactorVariable) == "1" recode.directives <- gsub("\n", "; ", tclvalue(tkget(recodes, "1.0", "end"))) check.empty <- gsub(";", "", gsub(" ", "", recode.directives)) if ("" == check.empty) { errorCondition(recall=Recode, message=gettextRcmdr("No recode directives specified.")) return() } if (0 != length(grep("'", recode.directives))) { errorCondition(recall=Recode, message=gettextRcmdr('Use only double-quotes (" ") in recode directives')) return() } recode.directives <- strsplit(recode.directives, ";")[[1]] recode.directives <- paste(sapply(recode.directives, processRecode), collapse=";") variables <- getSelection(variablesBox) closeDialog() if (length(variables) == 0) { errorCondition(recall=Recode, message=gettextRcmdr("You must select a variable.")) return() } multiple <- if (length(variables) > 1) TRUE else FALSE name <- trim.blanks(tclvalue(newVariableName)) for (variable in variables){ newVar <- if (multiple) paste(name, variable, sep="") else name if (!is.valid.name(newVar)){ errorCondition(recall=Recode, message=paste('"', newVar, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(newVar, Variables())) { if ("no" == tclvalue(checkReplace(newVar))){ Recode() return() } } cmd <- paste("recode(", dataSet,"$",variable, ", '", recode.directives, "', as.factor.result=", asFactor, ")", sep="") logger(paste(dataSet,"$",newVar, " <- ", cmd, sep="")) justDoIt(paste(dataSet,"$",newVar, " <- ", cmd, sep="")) activeDataSet(dataSet, flushModel=FALSE) tkfocus(CommanderWindow()) } } OKCancelHelp(helpSubject="Recode") tkgrid(getFrame(variablesBox), sticky="nw") tkgrid(tklabel(variablesFrame, text="")) tkgrid(tklabel(variablesFrame, text=gettextRcmdr("New variable name or prefix for multiple recodes: ")), newVariable, sticky="w") tkgrid(tklabel(asFactorFrame, text=gettextRcmdr("Make (each) new variable a factor")), asFactorCheckBox, sticky="w") tkgrid(tklabel(asFactorFrame, text="")) tkgrid(tklabel(recodesFrame, text=gettextRcmdr("Enter recode directives"), fg="blue"), sticky="w") tkgrid(recodes, recodesYscroll, sticky="nw") tkgrid(recodesXscroll) tkgrid(variablesFrame, sticky="w") tkgrid(asFactorFrame, sticky="w") tkgrid(recodesFrame, sticky="w") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(recodesXscroll, sticky="ew") tkgrid.configure(recodesYscroll, sticky="ns") dialogSuffix(rows=4, columns=2, bindReturn=FALSE) } # this code by Dan Putler, used with permission # last modified 2 March 06 by J. Fox assignCluster <- function(clusterData, origData, clusterVec){ rowsDX <- row.names(clusterData) rowsX <- row.names(origData) clustAssign <- rep(NA, length(rowsX)) validData <- rowsX %in% rowsDX clustAssign[validData] <- clusterVec return(as.factor(clustAssign)) } KMeans <- function (x, centers, iter.max=10, num.seeds=10) { # fixed 15 Mar 05 by J. Fox if(mode(x)=="numeric") x<-data.frame(new.x=x) KM <- kmeans(x=x, centers=centers, iter.max=iter.max) for(i in 2:num.seeds) { newKM <- kmeans(x=x, centers=centers, iter.max=iter.max) if(sum(newKM$withinss) < sum(KM$withinss)) { KM <- newKM } } KM$tot.withinss <- sum(KM$withinss) xmean <- apply(x, 2, mean) centers <- rbind(KM$centers, xmean) bss1 <- as.matrix(dist(centers)^2) KM$betweenss <- sum(as.vector(bss1[nrow(bss1),])*c(KM$size,0)) return(KM) } listKmeansSolutions <- function(envir=.GlobalEnv, ...) { objects <- ls(envir=envir, ...) if (length(objects) == 0) NULL else objects[sapply(objects, function(.x) { if(mode(eval(parse(text=.x), envir=envir)) != "list" ) return(FALSE) else {"cluster" == (names(eval(parse(text=.x), envir=envir))[1]) & "centers" == (names(eval(parse(text=.x), envir=envir))[2])} } )] } kmeansClustering <- function(){ initializeDialog(title=gettextRcmdr("KMeans Clustering")) dataFrame <- tkframe(top) xBox <- variableListBox(dataFrame, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick one or more)")) subsetBox(dataFrame) optionsFrame <- tkframe(top) clusterNumber <- tclVar("2") clusterNumSlider <- tkscale(optionsFrame, from=2, to=10, showvalue=TRUE, variable=clusterNumber, resolution=1, orient="horizontal") seedNumber <- tclVar("10") seedNumSlider <- tkscale(optionsFrame, from=1, to=20, showvalue=TRUE, variable=seedNumber, resolution=1, orient="horizontal") iterNumber <- tclVar("10") iterNumSlider <- tkscale(optionsFrame, from=5, to=30, showvalue=TRUE, variable=iterNumber, resolution=5, orient="horizontal") summaryClusters <- tclVar("1") summaryCB <- tkcheckbutton(optionsFrame) tkconfigure(summaryCB, variable=summaryClusters) plotClusters <- tclVar("1") plotCB <- tkcheckbutton(optionsFrame) tkconfigure(plotCB, variable=plotClusters) assignClusters <- tclVar("0") assignCB <- tkcheckbutton(optionsFrame) tkconfigure(assignCB, variable=assignClusters) assignName <- tclVar("KMeans") assignField <- tkentry(optionsFrame, width="15", textvariable=assignName) onOK <- function(){ x <- getSelection(xBox) nvar <- length(x) subset <- trim.blanks(tclvalue(subsetVariable)) nClusters <- tclvalue(clusterNumber) seeds <- tclvalue(seedNumber) iters <- tclvalue(iterNumber) clusterSummary <- tclvalue(summaryClusters) clusterPlot <- tclvalue(plotClusters) clusterAssign <- tclvalue(assignClusters) clusterVariable <- trim.blanks(tclvalue(assignName)) closeDialog() if (clusterAssign == "1"){ if (is.element(clusterVariable, Variables())) { if ("no" == tclvalue(checkReplace(clusterVariable))){ kmeansClustering() return() } } } if (length(x)==0) { errorCondition(recall=kmeansClustering, message=gettextRcmdr("No variables selected.")) return() } varFormula <- paste(x, collapse=" + ") vars <- paste(x, collapse=",", sep="") .activeDataSet <- ActiveDataSet() dset <- if (trim.blanks(subset) == gettextRcmdr("")) .activeDataSet else {paste(.activeDataSet, "[", .activeDataSet, "$", subset, ", ]", sep="")} xmat <- paste("model.matrix(~-1 + ", varFormula, ", ", dset, ")", sep="") command <- paste("KMeans(", xmat, ", centers = ", nClusters, ", iter.max = ", iters, ", num.seeds = ", seeds, ")", sep="") assign(".cluster", justDoIt(command), envir=.GlobalEnv) logger(paste(".cluster <- ", command, sep="")) if (clusterSummary == "1") { doItAndPrint(paste(".cluster$size # Cluster Sizes")) doItAndPrint(paste(".cluster$centers # Cluster Centroids")) doItAndPrint(paste( ".cluster$withinss # Within Cluster Sum of Squares")) doItAndPrint(paste( ".cluster$tot.withinss # Total Within Sum of Squares")) doItAndPrint(paste( ".cluster$betweenss # Between Cluster Sum of Squares")) } if (clusterPlot == "1") { plotCommand <- paste("biplot(princomp(", xmat, "), xlabs = as.character(.cluster$cluster))", sep="") justDoIt(plotCommand) logger(plotCommand) } if (clusterAssign == "1") { assignCommand <- paste(.activeDataSet, "$", clusterVariable, " <- assignCluster(", xmat, ", ", .activeDataSet, ", .cluster$cluster)", sep="") justDoIt(assignCommand) logger(assignCommand) activeDataSet(.activeDataSet) } justDoIt(paste("remove(.cluster)")) logger(paste("remove(.cluster)")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="KMeans") tkgrid(getFrame(xBox), sticky="nw") tkgrid(subsetFrame, sticky="w") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Number of clusters:")), clusterNumSlider, sticky="sw") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Number of starting seeds:")), seedNumSlider, sticky="sw") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Maximum iterations:")), iterNumSlider, sticky="sw") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Print cluster summary")), summaryCB, sticky="w") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Bi-plot of clusters")), plotCB, sticky="w") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Assign clusters to\nthe data set ")), assignCB, sticky="w") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Assignment variable: ")), assignField, sticky="w") tkgrid(dataFrame, tklabel(top, text=" "), optionsFrame, sticky="nw") tkgrid(buttonsFrame, columnspan=3, sticky="w") dialogSuffix(rows=3, columns=3) } listHclustSolutions <- function(envir=.GlobalEnv, ...) { objects <- ls(envir=envir, ...) if (length(objects) == 0) NULL else objects[sapply(objects, function(.x) "hclust" == (class(eval(parse(text=.x), envir=envir))[1]))] } hierarchicalCluster <- function(){ solutionNumber=length(listHclustSolutions()) initializeDialog(title=gettextRcmdr("Hierarchical Clustering")) solutionFrame <- tkframe(top) solutionName <- tclVar(paste("HClust.", (solutionNumber+1), sep="")) solutionField <- tkentry(solutionFrame, width="20", textvariable=solutionName) dataFrame <- tkframe(top) xBox <- variableListBox(dataFrame, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick one or more)")) subsetBox(dataFrame) radioButtons(name="method", buttons=c("ward", "single", "complete","average", "mcquitty", "median", "centroid"), labels=gettextRcmdr(c("Ward's Method", "Single Linkage", "Complete Linkage", "Average Linkage", "McQuitty's Method", "Median Linkage", "Centroid Linkage")), title=gettextRcmdr("Clustering Method")) optionsFrame <- tkframe(top) radioButtons(optionsFrame, name="distanceType", buttons=c("euc", "euc2", "city", "none"), labels=gettextRcmdr(c("Euclidean", "Squared-Euclidian", "Manhattan (City Block)", "No Transformation")), title=gettextRcmdr("Distance Measure")) checkFrame <- tkframe(optionsFrame) plotDendro <- tclVar("1") plotCB <- tkcheckbutton(checkFrame) tkconfigure(plotCB, variable=plotDendro) onOK <- function(){ x <- getSelection(xBox) nvar <- length(x) clusMethod <- tclvalue(methodVariable) distance <- tclvalue(distanceTypeVariable) subset <- trim.blanks(tclvalue(subsetVariable)) dendro <- tclvalue(plotDendro) solution <- trim.blanks(tclvalue(solutionName)) if (length(x)==0) { errorCondition(recall=hierarchicalCluster, message=gettextRcmdr("No variables selected.")) return() } closeDialog() varFormula <- paste(x, collapse="+") vars <- paste(x, collapse=",", sep="") .activeDataSet <- ActiveDataSet() dset <- if (subset == gettextRcmdr("")) .activeDataSet else {paste(.activeDataSet, "[", .activeDataSet, "$", subset, ", ]", sep="")} xmat <- paste("model.matrix(~-1 + ", varFormula, ", ", dset, ")", sep="") if(distance=="euc") { dx <- paste("dist(", xmat, ")", sep="") distlab <- "euclidian" } else if(distance=="euc2") { dx <- paste("dist(", xmat, ")^2", sep="") distlab <- "squared-euclidian" } else if(distance=="city") { dx <- paste("dist(", xmat, ", method= ", '"manhattan"', ")", sep="") distlab <- "city-block" } else { dx <- xmat distlab <- "untransformed" } command <- paste("hclust(", dx, " , method= ", '"', clusMethod, '"', ")", sep="") assign(solution, justDoIt(command), envir=.GlobalEnv) logger(paste(solution, " <- ", command, sep="")) if (dendro == "1") { justDoIt(paste("plot(", solution, ", main= ",'"', "Cluster Dendrogram for Solution ", solution, '"', ", xlab= ", '"',"Observation Number in Data Set ", dset, '"', ", sub=", '"', "Method=", clusMethod, "; Distance=", distlab, '"', ")", sep="")) logger(paste("plot(", solution, ", main= ",'"', "Cluster Dendrogram for Solution ", solution, '"', ", xlab= ", '"',"Observation Number in Data Set ", dset, '"', ", sub=", '"', "Method=", clusMethod, "; Distance=", distlab, '"', ")", sep="")) } activateMenus() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="hclust") tkgrid(solutionField, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Clustering solution name:")), solutionFrame, sticky="w") tkgrid(getFrame(xBox), sticky="nw") tkgrid(subsetFrame, sticky="w") tkgrid(distanceTypeFrame, sticky="w") tkgrid(tklabel(checkFrame, text=" "), sticky="w") tkgrid(tklabel(checkFrame, text=gettextRcmdr("Plot Dendrogram ")), plotCB, sticky="w") tkgrid(checkFrame, sticky="w") tkgrid(dataFrame, methodFrame, optionsFrame, sticky="nw") tkgrid(buttonsFrame, columnspan=3, sticky="w") dialogSuffix(rows=3, columns=3) } hclustSummary <- function(){ parseDataSet <- function(x) { y <- eval(parse(text=paste(x, "$call", sep=""))) string1 <- unlist(strsplit(as.character(y)[2], "\\(")) string2 <- unlist(strsplit(string1[3], ",")) if(length(grep("\\[", string2[2])) == 0) { out <- gsub(")", "", gsub(" ", "", gsub("\\^2", "", string2[2]))) } else { string3 <- unlist(strsplit(string2[2], "\\[")) out <- gsub(" ", "", string3[1]) } return(out) } hclustObjects <- listHclustSolutions() testDataSet <- tapply(hclustObjects, as.factor(1:length(hclustObjects)), parseDataSet) .activeDataSet <- ActiveDataSet() validHclust <- hclustObjects[testDataSet==.activeDataSet] initializeDialog( title=gettextRcmdr("Hierarchical Cluster Summary")) hclustBox <- variableListBox(top, validHclust, selectmode="single", title=gettextRcmdr("Select One Clustering Solution")) optionsFrame <- tkframe(top) clusterNumber <- tclVar("2") slider <- tkscale(optionsFrame, from=2, to=10, showvalue=TRUE, variable=clusterNumber, resolution=1, orient="horizontal") summaryClusters <- tclVar("1") summaryCB <- tkcheckbutton(optionsFrame) tkconfigure(summaryCB, variable=summaryClusters) plotClusters <- tclVar("1") plotCB <- tkcheckbutton(optionsFrame) tkconfigure(plotCB, variable=plotClusters) if(length(hclustObjects)==0) { errorCondition(recall=return, message=gettextRcmdr("There are no hierachical clustering solutions")) } if(length(validHclust)==0) { errorCondition(recall=return, message= gettextRcmdr("No hierachical clustering solutions are associated with this data set.")) } onOK <- function(){ solution <- getSelection(hclustBox) if(length(solution)==0) { errorCondition(recall=hclustSummary, message=gettextRcmdr("A clustering solution has not been selected.")) return() } clusters <- as.numeric(tclvalue(clusterNumber)) clusterVar <- paste("cutree(", solution, ", k = ", clusters, ")", sep="") clusterSummary <- tclvalue(summaryClusters) clusterPlot <- tclvalue(plotClusters) hclustCall <- eval(parse(text=paste(solution,"$call",sep=""))) string1 <- unlist(strsplit(as.character(hclustCall)[2], "\\(")) string2 <- unlist(strsplit(string1[3], ",")) form.vars <- string2[1] closeDialog() if(length(grep("\\[", string2[2])) == 0) { xmat <- paste("model.matrix(", form.vars, ", ", .activeDataSet, ")", sep="") } else { string3 <- unlist(strsplit(string2[2], "\\[")) xmat <- paste("model.matrix(", form.vars, ", ", .activeDataSet, "[", string3[2], ", ]",")", sep="") } if (clusterSummary == "1") { doItAndPrint(paste("summary(as.factor(", clusterVar, ")) # Cluster Sizes", sep="")) centroidsCommand <- paste("by(", xmat, ", as.factor(", clusterVar, "), mean) # Cluster Centroids", sep="") doItAndPrint(centroidsCommand) } if (clusterPlot == "1") { plotCommand <- paste("biplot(princomp(", xmat, "), xlabs = as.character(", clusterVar, "))", sep="") justDoIt(plotCommand) logger(plotCommand) } tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="biplot") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Number of clusters:")), slider, sticky="sw") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Print cluster summary")), summaryCB, sticky="w") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Bi-plot of clusters")), plotCB, sticky="w") tkgrid(getFrame(hclustBox), optionsFrame, sticky="nw") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=2, columns=3) } appendHclustGroup <- function(){ parseDataSet <- function(x) { y <- eval(parse(text=paste(x, "$call", sep=""))) string1 <- unlist(strsplit(as.character(y)[2], "\\(")) string2 <- unlist(strsplit(string1[3], ",")) if(length(grep("\\[", string2[2])) == 0) { out <- gsub(")", "", gsub(" ", "", gsub("\\^2", "", string2[2]))) } else { string3 <- unlist(strsplit(string2[2], "\\[")) out <- gsub(" ", "", string3[1]) } return(out) } hclustObjects <- listHclustSolutions() if(length(hclustObjects)==0) { Message(message=gettextRcmdr("There are no hierachical clustering solutions"), type = "error") return() } testDataSet <- tapply(hclustObjects, as.factor(1:length(hclustObjects)), parseDataSet) .activeDataSet <- ActiveDataSet() validHclust <- hclustObjects[testDataSet==.activeDataSet] if(length(validHclust)==0) { Message(message=gettextRcmdr("No hierachical clustering solutions are associated with this data set."), type = "error") return() } initializeDialog( title=gettextRcmdr("Append Cluster Groups to the Active Data Set")) hclustBox <- variableListBox(top, validHclust, selectmode="single", title=gettextRcmdr("Select One Clustering Solution")) optionsFrame <- tkframe(top) labelName <- tclVar("hclus.label") labelNameField <- tkentry(optionsFrame, width="15", textvariable=labelName) clusterNumber <- tclVar("2") slider <- tkscale(optionsFrame, from=2, to=10, showvalue=TRUE, variable=clusterNumber, resolution=1, orient="horizontal") onOK <- function(){ solution <- getSelection(hclustBox) if(length(solution)==0) { errorCondition(recall=appendHclustGroup, message=gettextRcmdr("A clustering solution has not been selected.")) return() } clusters <- as.numeric(tclvalue(clusterNumber)) label <- trim.blanks(tclvalue(labelName)) closeDialog() if (is.element(label, Variables())) { if ("no" == tclvalue(checkReplace(label))){ appendHclustGroup() return() } } hclustCall <- eval(parse(text=paste(solution,"$call",sep=""))) string1 <- unlist(strsplit(as.character(hclustCall)[2], "\\(")) string2 <- unlist(strsplit(string1[3], ",")) form.vars <- string2[1] if(length(grep("\\[", string2[2])) == 0) { xmat <- paste("model.matrix(", form.vars, ", ", .activeDataSet, ")", sep="") } else { string3 <- unlist(strsplit(string2[2], "\\[")) xmat <- paste("model.matrix(", form.vars, ", ", .activeDataSet, "[", string3[2], ", ]",")", sep="") } clusterVar <- paste("cutree(", solution, ", k = ", clusters, ")", sep="") command <- paste(.activeDataSet, "$", label, " <- assignCluster(", xmat, ", ", .activeDataSet, ", ", clusterVar, ")", sep="") justDoIt(command) logger(command) activeDataSet(.activeDataSet) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="assignCluster") tkgrid(tklabel(optionsFrame, text=gettextRcmdr(" Assigned cluster label:")), labelNameField, sticky="w") tkgrid(tklabel(optionsFrame, text=gettextRcmdr(" Number of clusters:")), slider, sticky="sw") tkgrid(getFrame(hclustBox), optionsFrame, sticky="nw") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=2, columns=3) } # The R Commander and command logger # last modified 24 May 2007 by J. Fox # slight changes 12 Aug 04 by Ph. Grosjean Commander <- function(){ RcmdrVersion <- "1.3-0" # the following test suggested by Richard Heiberger if ("RcmdrEnv" %in% search() && exists("commanderWindow", "RcmdrEnv") && !is.null(get("commanderWindow", "RcmdrEnv"))) { warning("The R Commander is already open.") return(invisible(NULL)) } if (is.SciViews()) return(invisible(svCommander(Version=RcmdrVersion))) # +PhG setOption <- function(option, default, global=TRUE) { opt <- if (is.null(current[option][[1]])) default else current[option][[1]] if (global) putRcmdr(option, opt) else opt } current <- options("Rcmdr")[[1]] etc <- setOption("etc", file.path(.path.package(package="Rcmdr")[1], "etc")) etcMenus <- setOption("etcMenus", etc) putRcmdr("etcMenus", etcMenus) onCopy <- function(){ focused <- tkfocus() if ((tclvalue(focused) != LogWindow()$ID) && (tclvalue(focused) != OutputWindow()$ID)) focused <- LogWindow() selection <- strsplit(tclvalue(tktag.ranges(focused, "sel")), " ")[[1]] if (is.na(selection[1])) return() text <- tclvalue(tkget(focused, selection[1], selection[2])) tkclipboard.clear() tkclipboard.append(text) } onDelete <- function(){ focused <- tkfocus() if ((tclvalue(focused) != LogWindow()$ID) && (tclvalue(focused) != OutputWindow()$ID)) focused <- LogWindow() selection <- strsplit(tclvalue(tktag.ranges(focused, "sel")), " ")[[1]] if (is.na(selection[1])) return() tkdelete(focused, selection[1], selection[2]) } onCut <- function(){ onCopy() onDelete() } onPaste <- function(){ focused <- tkfocus() if ((tclvalue(focused) != LogWindow()$ID) && (tclvalue(focused) != OutputWindow()$ID)) focused <- LogWindow() text <- tclvalue(.Tcl("selection get -selection CLIPBOARD")) if (length(text) == 0) return() tkinsert(focused, "insert", text) } onFind <- function(){ focused <- tkfocus() if ((tclvalue(focused) != LogWindow()$ID) && (tclvalue(focused) != OutputWindow()$ID)) focused <- LogWindow() initializeDialog(title=gettextRcmdr("Find")) textFrame <- tkframe(top) textVar <- tclVar("") textEntry <- tkentry(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) 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 <- if (case) tksearch(focused, type, direction, "--", text, "insert", stop) else tksearch(focused, type, direction, "-nocase", "--", text, "insert", stop) where <- tclvalue(where) if (where == "") { Message(message=gettextRcmdr("Text not found."), type="note") if (GrabFocus()) tkgrab.release(top) tkdestroy(top) tkfocus(CommanderWindow()) return() } if (GrabFocus()) tkgrab.release(top) tkfocus(focused) tkmark.set(focused, "insert", where) tksee(focused, where) tkdestroy(top) } OKCancelHelp() tkgrid(tklabel(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(rows=4, columns=1, focus=textEntry) } onSelectAll <- function() { focused <- tkfocus() if ((tclvalue(focused) != LogWindow()$ID) && (tclvalue(focused) != OutputWindow()$ID)) focused <- LogWindow() tktag.add(focused, "sel", "1.0", "end") tkfocus(focused) } onClear <- function(){ onSelectAll() onDelete() } messageTag(reset=TRUE) putRcmdr("RcmdrVersion", RcmdrVersion) putRcmdr(".activeDataSet", NULL) putRcmdr(".activeModel", NULL) putRcmdr("logFileName", NULL) putRcmdr("outputFileName", NULL) putRcmdr("saveFileName", NULL) putRcmdr("modelNumber", 0) putRcmdr("rgl", FALSE) putRcmdr("Identify3d", NULL) setOption("log.font.size", if (.Platform$OS.type == "windows") 10 else 12) putRcmdr("logFont", tkfont.create(family="courier", size=getRcmdr("log.font.size"))) putRcmdr("operatorFont", tkfont.create(family="courier", size=getRcmdr("log.font.size"))) scale.factor <- current$scale.factor if (!is.null(scale.factor)) .Tcl(paste("tk scaling ", scale.factor, sep="")) if (packageAvailable("car")){ require("car") setOption("contrasts", c("contr.Treatment", "contr.poly")) } else setOption("contrasts", c("contr.treatment", "contr.poly")) setOption("log.commands", TRUE) setOption("console.output", FALSE) log.height <- as.character(setOption("log.height", if (!getRcmdr("log.commands")) 0 else 10, global=FALSE)) log.width <- as.character(setOption("log.width", 80, global=FALSE)) output.height <- as.character(setOption("output.height", if (getRcmdr("console.output")) 0 else if ((as.numeric(log.height) != 0) || (!getRcmdr("log.commands"))) 2*as.numeric(log.height) else 20, global=FALSE)) putRcmdr("saveOptions", options(warn=1, contrasts=getRcmdr("contrasts"), width=as.numeric(log.width), na.action="na.exclude", graphics.record=TRUE)) setOption("double.click", FALSE) setOption("sort.names", TRUE) setOption("grab.focus", TRUE) setOption("attach.data.set", FALSE) setOption("log.text.color", "black") setOption("command.text.color", "red") setOption("output.text.color", "darkblue") setOption("error.text.color", "red") setOption("warning.text.color", "darkgreen") setOption("multiple.select.mode", "extended") setOption("suppress.X11.warnings", interactive() && .Platform$GUI == "X11" && getRversion() < "2.4.0") # to address problem in Linux setOption("showData.threshold", 100) setOption("retain.messages", TRUE) setOption("crisp.dialogs", (.Platform$OS.type == "windows") && (getRversion() >= "2.1.1")) if (getRcmdr("suppress.X11.warnings")) { putRcmdr("messages.connection", file(open = "w+")) sink(getRcmdr("messages.connection"), type="message") # putRcmdr("length.messages", 0) } if (.Platform$OS.type != "windows") { putRcmdr("oldPager", options(pager=RcmdrPager)) default.font.size <- as.character(setOption("default.font.size", 12, global=FALSE)) default.font <- setOption("default.font", paste("*helvetica-medium-r-normal-*-", default.font.size, "*", sep=""), global=FALSE) .Tcl(paste("option add *font ", default.font, sep="")) } if (getRcmdr("crisp.dialogs")) tclServiceMode(on=FALSE) putRcmdr("commanderWindow", tktoplevel()) .commander <- CommanderWindow() placement <- setOption("placement", "-40+20", global=FALSE) tkwm.geometry(.commander, placement) tkwm.title(.commander, gettextRcmdr("R Commander")) tkwm.protocol(.commander, "WM_DELETE_WINDOW", CloseCommander) topMenu <- tkmenu(.commander) tkconfigure(.commander, menu=topMenu) source.files <- list.files(etc, pattern="\\.[Rr]$") for (file in source.files) { source(file.path(etc, file)) cat(paste(gettextRcmdr("Sourced:"), file, "\n")) } Plugins <- options()$Rcmdr$plugins allPlugins <- listPlugins(loaded=TRUE) for (plugin in Plugins){ if (!require(plugin, character.only=TRUE)){ putRcmdr("commanderWindow", NULL) stop(sprintf(gettextRcmdr("the plug-in package %s is missing"), plugin)) } if (!is.element(plugin, allPlugins)){ putRcmdr("commanderWindow", NULL) stop(sprintf(gettextRcmdr("the package %s is not an Rcmdr plug-in"), plugin)) } } Menus <- read.table(file.path(etcMenus, "Rcmdr-menus.txt"), colClasses = "character") addMenus <- function(Menus){ nms <- c("type", "menuOrItem", "operationOrParent", "label", "commandOrMenu", "activation", "install") names(Menus) <- nms for (plugin in Plugins) { MenusToAdd <- read.table(file.path(.path.package(package=plugin)[1], "etc/menus.txt"), colClasses = "character") names(MenusToAdd) <- nms for (i in 1:nrow(MenusToAdd)){ line <- MenusToAdd[i,] if (line[1, "type"] == "menu"){ where <- if (line[1, "operationOrParent"] == "topMenu") 0 else which((Menus[, "type"] == "menu") & (Menus[, "menuOrItem"] == line[1, "operationOrParent"])) } else if (line[1, "type"] == "item"){ if (line[1, "operationOrParent"] == "command"){ which <- which((Menus[, "operationOrParent"] == "command") & (Menus[, "menuOrItem"] == line[1, "menuOrItem"])) where <- if (length(which) == 0) which((Menus[, "type"] == "menu") & (Menus[, "menuOrItem"] == line[1, "menuOrItem"])) else max(which) } else if (line[1, "operationOrParent"] == "cascade"){ where <- if (line[1, "menuOrItem"] != "topMenu") max(which((Menus[, "operationOrParent"] == "cascade") & (Menus[, "menuOrItem"] == line[1, "menuOrItem"]))) else { max(which((Menus[, "operationOrParent"] == "cascade") & (Menus[, "menuOrItem"] == "topMenu") & (Menus[, "commandOrMenu"] != "toolsMenu") & (Menus[, "commandOrMenu"] != "helpMenu"))) } } else stop(sprintf(gettextRcmdr('unrecognized operation, "%s", in plugin menu line %i'), line[1, "operation"], i)) } else stop(sprintf(gettextRcmdr('unrecognized type, "%s", in plugin menu line %i'), line[1, "type"], i)) Menus <- insertRows(Menus, line, where) } } Menus } Menus <- addMenus(Menus) .Menus <- menus <- list() menuItems <- 0 oldMenu <- ncol(Menus) == 6 setOption("suppress.menus", FALSE) if (!getRcmdr("suppress.menus")){ for (m in 1:nrow(Menus)){ install <- if (oldMenu) "" else Menus[m, 7] if ((install != "") && (!eval(parse(text=install)))) next if (Menus[m, 1] == "menu") { position <- 0 assign(Menus[m, 2], tkmenu(eval(parse(text=Menus[m, 3])), tearoff=FALSE)) menus[[Menus[m, 2]]] <- list(ID=get(Menus[m, 2])$ID, position=0) } else if (Menus[m, 1] == "item") { if (Menus[m, 3] == "command"){ position <- position + 1 if (Menus[m, 6] == "") tkadd(eval(parse(text=Menus[m, 2])),"command", label=gettextRcmdr(Menus[m, 4]), command=eval(parse(text=Menus[m, 5]))) else { tkadd(eval(parse(text=Menus[m, 2])),"command", label=gettextRcmdr(Menus[m, 4]), command=eval(parse(text=Menus[m, 5])), state="disabled") menuItems <- menuItems + 1 menus[[Menus[m, 2]]]$position <- position .Menus[[menuItems]] <- list(ID=menus[[Menus[m, 2]]]$ID, position=position, activation=eval(parse(text=paste("function()", Menus[m, 6])))) } } else if (Menus[m, 3] == "cascade") tkadd(eval(parse(text=Menus[m, 2])),"cascade", label=gettextRcmdr(Menus[m, 4]), menu=eval(parse(text=Menus[m, 5]))) else stop(paste(gettextRcmdr("menu definition error:"), Menus[m, ], collapse=" "), domain=NA) } else stop(paste(gettextRcmdr("menu definition error:"), Menus[m, ], collapse=" "), domain=NA) } } putRcmdr("Menus", .Menus) putRcmdr("autoRestart", FALSE) activateMenus() exceptions <- scan(file.path(etc, "log-exceptions.txt"), what="", quiet=TRUE, comment.char="#") modelClasses <- scan(file.path(etc, "model-classes.txt"), what="", quiet=TRUE, comment.char="#") for (plugin in Plugins){ description <- readLines(file.path(.path.package(package=plugin)[1], "DESCRIPTION")) addExceptions <- description[grep("Log-Exceptions:", description)] addExceptions <- gsub(" ", "", sub("^Log-Exceptions:", "", addExceptions)) addExceptions <- unlist(strsplit(addExceptions, ",")) addModels <- description[grep("Models:", description)] addModels <- gsub(" ", "", sub("^Models:", "", addModels)) addModels <- unlist(strsplit(addModels, ",")) if (length(addExceptions) > 0) exceptions <- c(exceptions, addExceptions) if (length(addModels) > 0) modelClasses <- c(modelClasses, addModels) } putRcmdr("modelClasses", modelClasses) onEdit <- function(){ if (activeDataSet() == FALSE) { tkfocus(CommanderWindow()) return() } command <- paste("fix(", ActiveDataSet(), ")", sep="") logger(command) justDoIt(command) activeDataSet(ActiveDataSet()) tkwm.deiconify(CommanderWindow()) tkfocus(CommanderWindow()) } onView <- function(){ if (activeDataSet() == FALSE) { tkfocus(CommanderWindow()) return() } view.height <- max(as.numeric(output.height) + as.numeric(log.height), 10) ncols <- eval(parse(text=paste("ncol(", ActiveDataSet(), ")"))) command <- if (packageAvailable("relimp") && ncols <= getRcmdr("showData.threshold")){ require("relimp") paste("showData(", ActiveDataSet(), ", placement='-20+200', font=getRcmdr('logFont'), maxwidth=", log.width, ", maxheight=", view.height, ")", sep="") } else paste("View(", ActiveDataSet(), ")", sep="") logger(command) justDoIt(command) tkwm.deiconify(CommanderWindow()) tkfocus(CommanderWindow()) } onSubmit <- function(){ .log <- LogWindow() selection <- strsplit(tclvalue(tktag.ranges(.log, "sel")), " ")[[1]] if (is.na(selection[1])) { tktag.add(.log, "currentLine", "insert linestart", "insert lineend") selection <- strsplit(tclvalue(tktag.ranges(.log, "currentLine")), " ")[[1]] tktag.delete(.log, "currentLine") if (is.na(selection[1])) { Message(message=gettextRcmdr("Nothing is selected."), type="error") tkfocus(CommanderWindow()) return() } } lines <- tclvalue(tkget(.log, selection[1], selection[2])) lines <- strsplit(lines, "\n")[[1]] .console.output <- getRcmdr("console.output") .output <- OutputWindow() if (!.console.output) tkinsert(.output, "end", "\n") iline <- 1 nlines <- length(lines) while (iline <= nlines){ current.line <- lines[iline] if (.console.output) cat(paste("\nRcmdr> ", current.line,"\n", sep="")) else{ tkinsert(.output, "end", paste("> ", current.line,"\n", sep="")) tktag.add(.output, "currentLine", "end - 2 lines linestart", "end - 2 lines lineend") tktag.configure(.output, "currentLine", foreground=getRcmdr("command.text.color")) } jline <- iline + 1 while (jline <= nlines){ if (length(grep("^[\\ \t]", lines[jline])) == 0) break if (.console.output)cat(paste("Rcmdr+ ", lines[jline],"\n", sep="")) else{ tkinsert(.output, "end", paste("+ ", lines[jline],"\n", sep="")) tktag.add(.output, "currentLine", "end - 2 lines linestart", "end - 2 lines lineend") tktag.configure(.output, "currentLine", foreground=getRcmdr("command.text.color")) } current.line <- paste(current.line, lines[jline]) jline <- jline + 1 iline <- iline + 1 } if (length(grep("<-", current.line)) > 0){ justDoIt(current.line) } else if (length(grep("^remove\\(", current.line)) > 0){ current.line <- sub(")", ", envir=.GlobalEnv)", current.line) justDoIt(current.line) } else if (any(sapply(exceptions, function(.x) length(grep(paste("^", .x, "\\(", sep=""), current.line)) > 0))){ justDoIt(current.line) } else doItAndPrint(current.line, log=FALSE) iline <- iline + 1 } tkyview.moveto(.output, 1) } contextMenuLog <- function(){ .log <- LogWindow() contextMenu <- tkmenu(tkmenu(.log), tearoff=FALSE) tkadd(contextMenu, "command", label=gettextRcmdr("Clear window"), command=onClear) tkadd(contextMenu, "command", label=gettextRcmdr("Submit"), command=onSubmit) 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, "command", label=gettextRcmdr("Find..."), command=onFind) tkadd(contextMenu, "command", label=gettextRcmdr("Select all"), command=onSelectAll) tkpopup(contextMenu, tkwinfo("pointerx", .log), tkwinfo("pointery", .log)) } contextMenuOutput <- function(){ .output <- OutputWindow() contextMenu <- tkmenu(tkmenu(.output), tearoff=FALSE) tkadd(contextMenu, "command", label=gettextRcmdr("Clear window"), command=onClear) 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, "command", label=gettextRcmdr("Find..."), command=onFind) tkadd(contextMenu, "command", label=gettextRcmdr("Select all"), command=onSelectAll) tkpopup(contextMenu, tkwinfo("pointerx", .output), tkwinfo("pointery", .output)) } controlsFrame <- tkframe(CommanderWindow()) editButton <- tkbutton(controlsFrame, text=gettextRcmdr("Edit data set"), command=onEdit) viewButton <- tkbutton(controlsFrame, text=gettextRcmdr("View data set"), command=onView) putRcmdr("dataSetName", tclVar(gettextRcmdr(""))) putRcmdr("dataSetLabel", tkbutton(controlsFrame, textvariable=getRcmdr("dataSetName"), fg="red", relief="groove", command=selectActiveDataSet)) logFrame <- tkframe(CommanderWindow()) putRcmdr("logWindow", tktext(logFrame, bg="white", fg=getRcmdr("log.text.color"), font=getRcmdr("logFont"), height=log.height, width=log.width, wrap="none")) .log <- LogWindow() logXscroll <- tkscrollbar(logFrame, repeatinterval=5, orient="horizontal", command=function(...) tkxview(.log, ...)) logYscroll <- tkscrollbar(logFrame, repeatinterval=5, command=function(...) tkyview(.log, ...)) tkconfigure(.log, xscrollcommand=function(...) tkset(logXscroll, ...)) tkconfigure(.log, yscrollcommand=function(...) tkset(logYscroll, ...)) outputFrame <- tkframe(.commander) if (getRcmdr("console.output")) submitButton <- if (English()) tkbutton(logFrame, bitmap=paste("@", file.path(etc, "submit.xbm"), sep=""), borderwidth="2", command=onSubmit) else tkbutton(logFrame, text=gettextRcmdr("Submit"), borderwidth="2", command=onSubmit) else submitButton <- if (English())tkbutton(outputFrame, bitmap=paste("@", file.path(etc, "submit.xbm"), sep=""), borderwidth="2", command=onSubmit) else tkbutton(outputFrame, text=gettextRcmdr("Submit"), borderwidth="2", command=onSubmit) putRcmdr("outputWindow", tktext(outputFrame, bg="white", fg=getRcmdr("output.text.color"), font=getRcmdr("logFont"), height=output.height, width=log.width, wrap="none")) .output <- OutputWindow() outputXscroll <- tkscrollbar(outputFrame, repeatinterval=5, orient="horizontal", command=function(...) tkxview(.output, ...)) outputYscroll <- tkscrollbar(outputFrame, repeatinterval=5, command=function(...) tkyview(.output, ...)) tkconfigure(.output, xscrollcommand=function(...) tkset(outputXscroll, ...)) tkconfigure(.output, yscrollcommand=function(...) tkset(outputYscroll, ...)) messagesFrame <- tkframe(.commander) putRcmdr("messagesWindow", tktext(messagesFrame, bg="lightgray", font=getRcmdr("logFont"), height=3, width=log.width, wrap="none")) .messages <- MessagesWindow() messagesXscroll <- tkscrollbar(messagesFrame, repeatinterval=5, orient="horizontal", command=function(...) tkxview(.messages, ...)) messagesYscroll <- tkscrollbar(messagesFrame, repeatinterval=5, command=function(...) tkyview(.messages, ...)) tkconfigure(.messages, xscrollcommand=function(...) tkset(messagesXscroll, ...)) tkconfigure(.messages, yscrollcommand=function(...) tkset(messagesYscroll, ...)) putRcmdr("modelName", tclVar(gettextRcmdr(""))) putRcmdr("modelLabel", tkbutton(controlsFrame, textvariable=getRcmdr("modelName"), fg="red", relief="groove", command=selectActiveModel)) show.edit.button <- options("Rcmdr")[[1]]$show.edit.button show.edit.button <- if (is.null(show.edit.button)) TRUE else show.edit.button if (!getRcmdr("suppress.menus")){ tkgrid(tklabel(controlsFrame, bitmap=paste("@", file.path(etc, "Rcmdr.xbm"), sep=""), fg="red"), tklabel(controlsFrame, text=gettextRcmdr("Data set:")), getRcmdr("dataSetLabel"), tklabel(controlsFrame, text=" "), if(show.edit.button) editButton, viewButton, tklabel(controlsFrame, text=gettextRcmdr(" Model: ")), getRcmdr("modelLabel"), sticky="w") tkgrid(controlsFrame, sticky="w") } .log.commands <- getRcmdr("log.commands") .console.output <- getRcmdr("console.output") if (.log.commands) tkgrid(tklabel(logFrame, text=gettextRcmdr("Script Window"), fg="blue"), if (.log.commands && .console.output) submitButton, sticky="w") tkgrid(.log, logYscroll, sticky="news", columnspan=2) tkgrid(logXscroll) if (.log.commands) tkgrid(logFrame, sticky="news", padx=10, pady=0, columnspan=2) tkgrid(tklabel(outputFrame, text=gettextRcmdr("Output Window"), fg="blue"), if (.log.commands && !.console.output) submitButton, sticky="w") tkgrid(.output, outputYscroll, sticky="news", columnspan=2) tkgrid(outputXscroll, columnspan=1 + (.log.commands && !.console.output)) if (!.console.output) tkgrid(outputFrame, sticky="news", padx=10, pady=0, columnspan=2) tkgrid(tklabel(messagesFrame, text=gettextRcmdr("Messages"), fg=getRcmdr("error.text.color")), sticky="w") tkgrid(.messages, messagesYscroll, sticky="news", columnspan=2) tkgrid(messagesXscroll) tkgrid(messagesFrame, sticky="news", padx=10, pady=0, columnspan=2) tkgrid.configure(logYscroll, sticky="ns") tkgrid.configure(logXscroll, sticky="ew") tkgrid.configure(outputYscroll, sticky="ns") tkgrid.configure(outputXscroll, sticky="ew") tkgrid.configure(messagesYscroll, sticky="ns") tkgrid.configure(messagesXscroll, sticky="ew") .commander <- CommanderWindow() tkgrid.rowconfigure(.commander, 0, weight=0) tkgrid.rowconfigure(.commander, 1, weight=1) tkgrid.rowconfigure(.commander, 2, weight=1) tkgrid.columnconfigure(.commander, 0, weight=1) tkgrid.columnconfigure(.commander, 1, weight=0) if (.log.commands){ tkgrid.rowconfigure(logFrame, 0, weight=0) tkgrid.rowconfigure(logFrame, 1, weight=1) tkgrid.rowconfigure(logFrame, 2, weight=0) tkgrid.columnconfigure(logFrame, 0, weight=1) tkgrid.columnconfigure(logFrame, 1, weight=0) } if (!.console.output){ tkgrid.rowconfigure(outputFrame, 0, weight=0) tkgrid.rowconfigure(outputFrame, 1, weight=1) tkgrid.rowconfigure(outputFrame, 2, weight=0) tkgrid.columnconfigure(outputFrame, 0, weight=1) tkgrid.columnconfigure(outputFrame, 1, weight=0) } tkgrid.rowconfigure(messagesFrame, 0, weight=0) tkgrid.rowconfigure(messagesFrame, 1, weight=0) tkgrid.rowconfigure(messagesFrame, 2, weight=0) tkgrid.columnconfigure(messagesFrame, 0, weight=1) tkgrid.columnconfigure(messagesFrame, 1, weight=0) .Tcl("update idletasks") tkbind(.commander, "", onSubmit) tkbind(.commander, "", onSubmit) tkbind(.commander, "", onFind) tkbind(.commander, "", onFind) tkbind(.commander, "", saveLog) tkbind(.commander, "", saveLog) tkbind(.commander, "", onSelectAll) tkbind(.commander, "", onSelectAll) tkbind(.log, "", contextMenuLog) tkbind(.output, "", contextMenuOutput) tkwm.deiconify(.commander) tkfocus(.commander) if (getRcmdr("crisp.dialogs")) tclServiceMode(on=TRUE) tkwait <- options("Rcmdr")[[1]]$tkwait # to address problem in Debian Linux if ((!is.null(tkwait)) && tkwait) { .commander.done <<- tclVar("0") tkwait.variable(.commander.done) } ## if (!packageAvailable("rgl")) Message(gettextRcmdr("The rgl package is absent; 3D plots are unavailable."), type="warning") Message(paste(gettextRcmdr("R Commander Version "), getRcmdr("RcmdrVersion"), ": ", date(), sep="")) } logger <- function(command){ if (is.SciViews()) return(svlogger(command)) # +PhG .log <- LogWindow() .output <- OutputWindow() if (getRcmdr("log.commands")) { tkinsert(.log, "end", paste(command,"\n", sep="")) tkyview.moveto(.log, 1) } lines <- strsplit(command, "\n")[[1]] tkinsert(.output, "end", "\n") if (getRcmdr("console.output")) for (line in lines) cat(paste("\nRcmdr>", line, "\n")) else { for (line in lines) tkinsert(.output, "end", paste("> ", command,"\n", sep="")) tktag.add(.output, "currentLine", "end - 2 lines linestart", "end - 2 lines lineend") tktag.configure(.output, "currentLine", foreground=getRcmdr("command.text.color")) tkyview.moveto(.output, 1) } command } justDoIt <- function(command) { Message() if (!getRcmdr("suppress.X11.warnings")){ messages.connection <- file(open="w+") sink(messages.connection, type="message") on.exit({ sink(type="message") close(messages.connection) }) } else messages.connection <- getRcmdr("messages.connection") capture.output(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() } checkWarnings(readLines(messages.connection)) result } doItAndPrint <- function(command, log=TRUE) { Message() .console.output <- getRcmdr("console.output") .output <- OutputWindow() if (!.console.output) { width <- (as.numeric(tkwinfo("width", .output)) - 2*as.numeric(tkcget(.output, borderwidth=NULL)) - 2)/ as.numeric(tkfont.measure(tkcget(.output, font=NULL), "0")) eval(parse(text=paste("options(width=", floor(width), ")", sep=""))) } if (!getRcmdr("suppress.X11.warnings")){ messages.connection <- file(open="w+") sink(messages.connection, type="message") on.exit({ sink(type="message") close(messages.connection) }) } else messages.connection <- getRcmdr("messages.connection") output.connection <- file(open="w+") sink(output.connection, type="output") on.exit({ if (!.console.output) sink(type="output") # if .console.output, output connection already closed close(output.connection) }, add=TRUE) if (log) logger(command) 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") if (.console.output) sink(type="output") tkfocus(CommanderWindow()) return() } if (isS4object(result)) show(result) else print(result) .Output <- readLines(output.connection) if (length(.Output) > 0 && .Output[length(.Output)] == "NULL") .Output <- .Output[-length(.Output)] # suppress "NULL" line at end of output if (length(.Output) != 0) { # is there output to print? if (.console.output) { out <- .Output sink(type="output") for (line in out) cat(paste(line, "\n", sep="")) } else{ for (line in .Output) tkinsert(.output, "end", paste(line, "\n", sep="")) tkyview.moveto(.output, 1) } } else if (.console.output) sink(type="output") # errors already intercepted, display any warnings checkWarnings(readLines(messages.connection)) result } checkWarnings <- function(messages){ if (getRcmdr("suppress.X11.warnings")){ X11.warning <- grep("^Warning\\: X11 protocol error\\: BadWindow \\(invalid Window parameter\\)", messages) if (length(X11.warning) > 0){ messages <- messages[-X11.warning] } if (length(messages) == 0) Message() else if (length(messages) > 10) { messages <- c(paste(length(messages), "warnings."), gettextRcmdr("First and last 5 warnings:"), head(messages,5), ". . .", tail(messages, 5)) Message(message=paste(messages, collapse="\n"), type="warning") } else Message(message=paste(messages, collapse="\n"), type="warning") } else{ if (length(messages) == 0) Message() else if (length(messages) > 10){ messages <- c(paste(length(messages), "warnings."), gettextRcmdr("First and last 5 warnings:"), head(messages, 5), ". . .", tail(messages, 5)) Message(message=paste(messages, collapse="\n"), type="warning") } else Message(message=paste(messages, collapse="\n"), type="warning") } tkfocus(CommanderWindow()) } Message <- function(message, type=c("note", "error", "warning")){ if (is.SciViews()) return(svMessage(message, type)) # +PhG .message <- MessagesWindow() type <- match.arg(type) if (type != "note") tkbell() if (getRcmdr("retain.messages")) { if (!missing(message)) tkinsert(.message, "end", "\n") else if (!is.null(getRcmdr("last.message"))) { tkinsert(.message, "end", "\n\n") putRcmdr("last.message", NULL) tkyview.moveto(.message, 1.0) } } else if (type == "note"){ lastMessage <- tclvalue(tkget(MessagesWindow(), "end - 2 lines", "end")) if (length(c(grep(gettextRcmdr("ERROR:"), lastMessage), grep(gettextRcmdr("WARNING:"), lastMessage))) == 0) tkdelete(.message, "1.0", "end") } else tkdelete(.message, "1.0", "end") col <- if (type == "error") getRcmdr("error.text.color") else if (type == "warning") getRcmdr("warning.text.color") else getRcmdr("output.text.color") prefix <- switch(type, error=gettextRcmdr("ERROR"), warning=gettextRcmdr("WARNING"), note=gettextRcmdr("NOTE")) if (missing(message)){ return() } putRcmdr("last.message", type) message <- paste(prefix, ": ", message, sep="") lines <- strsplit(message, "\n")[[1]] for (line in lines){ tagName <- messageTag() tkinsert(.message, "end", paste(line, "\n", sep="")) tktag.add(.message, tagName, "end - 2 lines linestart", "end - 2 lines lineend") tktag.configure(.message, tagName, foreground=col) tkyview.moveto(.message, 1.0) } } messageTag <- function(reset=FALSE){ if (reset){ putRcmdr("tagNumber", 0) return() } tagNumber <- getRcmdr("tagNumber") + 1 putRcmdr("tagNumber", tagNumber) paste("message", tagNumber, sep="") } # last modified 22 May 2007 by J. Fox # Data menu dialogs newDataSet <- function() { initializeDialog(title=gettextRcmdr("New Data Set")) dsname <- tclVar(gettextRcmdr("Dataset")) entryDsname <- tkentry(top, width="20", textvariable=dsname) onOK <- function(){ dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=newDataSet, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=newDataSet, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ newDataSet() return() } } command <- "edit(as.data.frame(NULL))" assign(dsnameValue, justDoIt(command), envir=.GlobalEnv) logger(paste(dsnameValue, "<-", command)) if (eval(parse(text=paste("nrow(", dsnameValue, ")"))) == 0){ errorCondition(recall=newDataSet, message=gettextRcmdr("empty data set.")) return() } activeDataSet(dsnameValue) closeDialog() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="edit.data.frame") tkgrid(tklabel(top, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="e") tkgrid(buttonsFrame, columnspan="2", sticky="w") tkgrid.configure(entryDsname, sticky="w") dialogSuffix(rows=2, columns=2, focus=entryDsname) } selectActiveDataSet <- function(){ dataSets <- listDataSets() .activeDataSet <- ActiveDataSet() if ((length(dataSets) == 1) && !is.null(.activeDataSet)) { Message(message=gettextRcmdr("There is only one dataset in memory."), type="warning") tkfocus(CommanderWindow()) return() } if (length(dataSets) == 0){ Message(message=gettextRcmdr("There are no data sets from which to choose."), type="error") tkfocus(CommanderWindow()) return() } initializeDialog(title=gettextRcmdr("Select Data Set")) dataSetsBox <- variableListBox(top, dataSets, title=gettextRcmdr("Data Sets (pick one)"), initialSelection=if (is.null(.activeDataSet)) NULL else which(.activeDataSet == dataSets) - 1) onOK <- function(){ activeDataSet(getSelection(dataSetsBox)) closeDialog() tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(getFrame(dataSetsBox), sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2, columns=1) } listDataSetsInPackages <- function() doItAndPrint("data()") Recode <- function(){ require("car") processRecode <- function(recode){ parts <- strsplit(recode, "=")[[1]] if (length(grep(",", parts[1])) > 0) paste("c(", parts[1], ") = ", parts[2], sep="") else paste(parts, collapse="=") } dataSet <- activeDataSet() initializeDialog(title=gettextRcmdr("Recode Variables")) variablesBox <- variableListBox(top, Variables(), selectmode="multiple", title=gettextRcmdr("Variables to recode (pick one or more)")) variablesFrame <- tkframe(top) newVariableName <- tclVar(gettextRcmdr("variable")) newVariable <- tkentry(variablesFrame, width="20", textvariable=newVariableName) recodesFrame <- tkframe(top) recodes <- tktext(recodesFrame, bg="white", font=getRcmdr("logFont"), height="5", width="40", wrap="none") recodesXscroll <- tkscrollbar(recodesFrame, repeatinterval=5, orient="horizontal", command=function(...) tkxview(recodes, ...)) recodesYscroll <- tkscrollbar(recodesFrame, repeatinterval=5, command=function(...) tkyview(recodes, ...)) tkconfigure(recodes, xscrollcommand=function(...) tkset(recodesXscroll, ...)) tkconfigure(recodes, yscrollcommand=function(...) tkset(recodesYscroll, ...)) asFactorFrame <- tkframe(top) asFactorVariable <- tclVar("1") asFactorCheckBox <- tkcheckbutton(asFactorFrame, variable=asFactorVariable) onOK <- function(){ asFactor <- tclvalue(asFactorVariable) == "1" recode.directives <- gsub("\n", "; ", tclvalue(tkget(recodes, "1.0", "end"))) check.empty <- gsub(";", "", gsub(" ", "", recode.directives)) if ("" == check.empty) { errorCondition(recall=Recode, message=gettextRcmdr("No recode directives specified.")) return() } if (0 != length(grep("'", recode.directives))) { errorCondition(recall=Recode, message=gettextRcmdr('Use only double-quotes (" ") in recode directives')) return() } recode.directives <- strsplit(recode.directives, ";")[[1]] recode.directives <- paste(sapply(recode.directives, processRecode), collapse=";") variables <- getSelection(variablesBox) closeDialog() if (length(variables) == 0) { errorCondition(recall=Recode, message=gettextRcmdr("You must select a variable.")) return() } multiple <- if (length(variables) > 1) TRUE else FALSE name <- trim.blanks(tclvalue(newVariableName)) for (variable in variables){ newVar <- if (multiple) paste(name, variable, sep="") else name if (!is.valid.name(newVar)){ errorCondition(recall=Recode, message=paste('"', newVar, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(newVar, Variables())) { if ("no" == tclvalue(checkReplace(newVar))){ Recode() return() } } cmd <- paste("recode(", dataSet,"$",variable, ", '", recode.directives, "', as.factor.result=", asFactor, ")", sep="") logger(paste(dataSet,"$",newVar, " <- ", cmd, sep="")) justDoIt(paste(dataSet,"$",newVar, " <- ", cmd, sep="")) activeDataSet(dataSet, flushModel=FALSE) tkfocus(CommanderWindow()) } } OKCancelHelp(helpSubject="Recode") tkgrid(getFrame(variablesBox), sticky="nw") tkgrid(tklabel(variablesFrame, text="")) tkgrid(tklabel(variablesFrame, text=gettextRcmdr("New variable name or prefix for multiple recodes: ")), newVariable, sticky="w") tkgrid(tklabel(asFactorFrame, text=gettextRcmdr("Make (each) new variable a factor")), asFactorCheckBox, sticky="w") tkgrid(tklabel(asFactorFrame, text="")) tkgrid(tklabel(recodesFrame, text=gettextRcmdr("Enter recode directives"), fg="blue"), sticky="w") tkgrid(recodes, recodesYscroll, sticky="nw") tkgrid(recodesXscroll) tkgrid(variablesFrame, sticky="w") tkgrid(asFactorFrame, sticky="w") tkgrid(recodesFrame, sticky="w") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(recodesXscroll, sticky="ew") tkgrid.configure(recodesYscroll, sticky="ns") dialogSuffix(rows=4, columns=2, bindReturn=FALSE) } Compute <- function(){ # if (!checkActiveDataSet()) return(invisible()) onDoubleClick <-function(){ var <- trim.blanks(getSelection(variablesBox)) if (length(grep("\\[factor\\]", var)) == 1) var <- trim.blanks(sub("\\[factor\\]", "", var)) tkfocus(compute) expr <- tclvalue(computeVar) tclvalue(computeVar) <- if (expr == "") var else paste(expr, var, sep=if (rev(strsplit(expr, "")[[1]])[1] =="(" ) "" else " ") tkicursor(compute, "end") tkxview.moveto(compute, "1") } dataSet <- activeDataSet() initializeDialog(title=gettextRcmdr("Compute New Variable")) .variables <- Variables() variables <- paste(.variables, ifelse(is.element(.variables, Factors()), gettextRcmdr("[factor]"), "")) variablesBox <- variableListBox(top, variables, title=gettextRcmdr("Current variables (double-click to expression)")) tkbind(variablesBox$listbox, "", onDoubleClick) variablesFrame <- tkframe(top) newVariableName <- tclVar(gettextRcmdr("variable")) newVariable <- tkentry(variablesFrame, width="20", textvariable=newVariableName) computeFrame <- tkframe(top) computeVar <- tclVar("") compute <- tkentry(computeFrame, font=getRcmdr("logFont"), width="30", textvariable=computeVar) computeXscroll <- tkscrollbar(computeFrame, repeatinterval=10, orient="horizontal", command=function(...) tkxview(compute, ...)) tkconfigure(compute, xscrollcommand=function(...) tkset(computeXscroll, ...)) onOK <- function(){ closeDialog() newVar <- trim.blanks(tclvalue(newVariableName)) if (!is.valid.name(newVar)){ errorCondition(recall=Compute, message=paste('"', newVar, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } express <- tclvalue(computeVar) check.empty <- gsub(";", "", gsub(" ", "", express)) if ("" == check.empty) { errorCondition(recall=Compute, message=gettextRcmdr("No expression specified.")) return() } if (is.element(newVar, Variables())) { if ("no" == tclvalue(checkReplace(newVar, gettextRcmdr("Variable")))){ Compute() return() } } command <- paste(dataSet,"$",newVar, " <- with(", ActiveDataSet(), ", ", express, ")", sep="") logger(command) justDoIt(command) activeDataSet(dataSet, flushModel=FALSE) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="Compute") tkgrid(getFrame(variablesBox), sticky="nw", columnspan=2) tkgrid(tklabel(variablesFrame, text=gettextRcmdr("New variable name")), sticky="w") tkgrid(newVariable, tklabel(variablesFrame, text=" "), sticky="w") tkgrid(tklabel(computeFrame, text=gettextRcmdr("Expression to compute")), sticky="w") tkgrid(compute, sticky="w") tkgrid(computeXscroll, sticky="ew") tkgrid(variablesFrame, computeFrame, sticky="nw") tkgrid(buttonsFrame, sticky="w", columnspan=2) dialogSuffix(rows=3, columns=2, focus=compute) } deleteVariable <- function(){ dataSet <- activeDataSet() initializeDialog(title=gettextRcmdr("Delete Variables")) variablesBox <- variableListBox(top, Variables(), title=gettextRcmdr("Variable(s) to delete (pick one or more)"), selectmode="multiple", initialSelection=NULL) onOK <- function(){ variables <- getSelection(variablesBox) closeDialog() if (length(variables) == 0) { errorCondition(recall=deleteVariable, message=gettextRcmdr("You must select one or more variables.")) return() } if (length(variables) == 1){ response <- tclvalue(RcmdrTkmessageBox(message=sprintf(gettextRcmdr("Delete %s?\nPlease confirm."), variables), icon="warning", type="okcancel", default="cancel")) if (response == "cancel") { onCancel() return() } } else{ response <- tclvalue(RcmdrTkmessageBox(message= sprintf(gettextRcmdr("Delete %d variables?\nPlease confirm."), length(variables)), icon="warning", type="okcancel", default="cancel")) if (response == "cancel") { onCancel() return() } } for (variable in variables){ eval(parse(text=paste(dataSet, "$", variable, "<- NULL", sep="")), envir=.GlobalEnv) logger(paste(dataSet, "$", variable, " <- NULL", sep="")) } activeDataSet(dataSet, flushModel=FALSE) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="NULL") tkgrid(getFrame(variablesBox), sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2, columns=1) } readDataSet <- function() { initializeDialog(title=gettextRcmdr("Read Data From Text File or Clipboard")) optionsFrame <- tkframe(top) dsname <- tclVar(gettextRcmdr("Dataset")) entryDsname <- tkentry(optionsFrame, width="20", textvariable=dsname) headerVariable <- tclVar("1") headerCheckBox <- tkcheckbutton(optionsFrame, variable=headerVariable) clipboardVariable <- tclVar("0") clipboardCheckBox <- tkcheckbutton(optionsFrame, variable=clipboardVariable) radioButtons(optionsFrame, "delimiter", buttons=c("whitespace", "commas", "tabs"), labels=gettextRcmdr(c("White space", "Commas", "Tabs")), title=gettextRcmdr("Field Separator")) otherButton <- tkradiobutton(delimiterFrame, variable=delimiterVariable, value="other") otherVariable <- tclVar("") otherEntry <- tkentry(delimiterFrame, width="4", textvariable=otherVariable) radioButtons(optionsFrame, "decimal", buttons=c("period", "comma"), labels=gettextRcmdr(c("Period [.]", "Comma [,]")), title=gettextRcmdr("Decimal-Point Character")) missingVariable <- tclVar("NA") missingEntry <- tkentry(optionsFrame, width="8", textvariable=missingVariable) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == ""){ errorCondition(recall=readDataSet, message=gettextRcmdr("You must enter a name for the data set.")) return() } if (!is.valid.name(dsnameValue)){ errorCondition(recall=readDataSet, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ readDataSet() return() } } clip <- tclvalue(clipboardVariable) == "1" file <- if (clip) "clipboard" else tclvalue(tkgetOpenFile(filetypes= gettextRcmdr('{"Text Files" {".txt" ".TXT" ".dat" ".DAT" ".csv" ".CSV"}} {"All Files" {"*"}}'))) if (file == "") { if (getRcmdr("grab.focus")) tkgrab.release(top) tkdestroy(top) return() } head <- tclvalue(headerVariable) == "1" delimiter <- tclvalue(delimiterVariable) del <- if (delimiter == "whitespace") "" else if (delimiter == "commas") "," else if (delimiter == "tabs") "\\t" else tclvalue(otherVariable) miss <- tclvalue(missingVariable) dec <- if (tclvalue(decimalVariable) == "period") "." else "," command <- paste('read.table("', file,'", header=', head, ', sep="', del, '", na.strings="', miss, '", dec="', dec, '", strip.white=TRUE)', sep="") logger(paste(dsnameValue, " <- ", command, sep="")) assign(dsnameValue, justDoIt(command), envir=.GlobalEnv) activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="read.table") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Variable names in file:")), headerCheckBox, sticky="w") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Read data from clipboard:")), clipboardCheckBox, sticky="w") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Missing data indicator:")), missingEntry, sticky="w") tkgrid(tklabel(delimiterFrame, text=gettextRcmdr("Other")), otherButton, tklabel(delimiterFrame, text=gettextRcmdr(" Specify:")), otherEntry, sticky="w") tkgrid(delimiterFrame, sticky="w", columnspan=2) tkgrid(decimalFrame, sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } readDataFromPackage <- function() { env <- environment() initializeDialog(title=gettextRcmdr("Read Data From Package")) dsname <- tclVar("") package <- NULL enterFrame <- tkframe(top) entryDsname <- tkentry(enterFrame, width="20", textvariable=dsname) packages <- sort(.packages()) packages <- packages[! packages %in% c("base", "stats")] packages <- packages[sapply(packages, function(package) nrow(data(package=package)$results) > 0)] packageDatasetFrame <- tkframe(top) packageFrame <- tkframe(packageDatasetFrame) packageBox <- tklistbox(packageFrame, height="4", exportselection="FALSE", selectmode="single", background="white") packageScroll <- tkscrollbar(packageFrame, repeatinterval=5, command=function(...) tkyview(packageBox, ...)) tkconfigure(packageBox, yscrollcommand=function(...) tkset(packageScroll, ...)) for (p in packages) tkinsert(packageBox, "end", p) datasetFrame <- tkframe(packageDatasetFrame) datasetBox <- tklistbox(datasetFrame, height="4", exportselection="FALSE", selectmode="single", background="white") datasetScroll <- tkscrollbar(datasetFrame, repeatinterval=5, command=function(...) tkyview(datasetBox, ...)) tkconfigure(datasetBox, yscrollcommand=function(...) tkset(datasetScroll, ...)) onPackageSelect <- function(){ assign("package", packages[as.numeric(tkcurselection(packageBox)) + 1], envir=env) datasets <- data(package=package)$results[,3] tkdelete(datasetBox, "0", "end") for (dataset in datasets) tkinsert(datasetBox, "end", dataset) tkconfigure(datasetBox, height=min(4, length(datasets))) firstChar <- tolower(substr(datasets, 1, 1)) len <- length(datasets) onLetter <- function(letter){ letter <- tolower(letter) current <- 1 + round(as.numeric(unlist(strsplit(tclvalue(tkyview(datasetBox) ), " "))[1])*len) mat <- match(letter, firstChar[-(1:current)]) if (is.na(mat)) return() tkyview.scroll(datasetBox, 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(datasetBox, paste("<", letter, ">", sep=""), get(paste("on", toupper(letter), sep=""))) } onClick <- function() tkfocus(datasetBox) tkbind(datasetBox, "", onClick) } onDatasetSelect <- function(){ tclvalue(dsname) <- data(package=package)$results[as.numeric(tkcurselection(datasetBox)) + 1,3] } firstChar <- tolower(substr(packages, 1, 1)) len <- length(packages) onLetter <- function(letter){ letter <- tolower(letter) current <- 1 + round(as.numeric(unlist(strsplit(tclvalue(tkyview(packageBox) ), " "))[1])*len) mat <- match(letter, firstChar[-(1:current)]) if (is.na(mat)) return() tkyview.scroll(packageBox, 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(packageBox, paste("<", letter, ">", sep=""), get(paste("on", toupper(letter), sep=""))) } onClick <- function() tkfocus(packageBox) tkbind(packageBox, "", onClick) onOK <- function(){ datasetName <- data(package=package)$results[as.numeric(tkcurselection(datasetBox)) + 1,3] dsnameValue <- tclvalue(dsname) if (dsnameValue != "" && is.null(package)){ closeDialog() if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ if (GrabFocus()) tkgrab.release(top) tkdestroy(top) readDataFromPackage() return() } } save.options <- options(warn=2) check <- try(eval(parse(text=logger(paste("data(", dsnameValue, ")", sep=""))), envir=.GlobalEnv), silent=TRUE) options(save.options) if (class(check) == "try-error"){ errorCondition(recall=readDataFromPackage, message=sprintf(gettextRcmdr("Data set %s does not exit"), dsnameValue)) return() } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } else{ if (is.null(package)) { errorCondition(recall=readDataFromPackage, message=gettextRcmdr("You must select a package.")) return() } if (length(datasetName) == 0) { errorCondition(recall=readDataFromPackage, message=gettextRcmdr("You must select a data set.") ) return() } if (is.element(datasetName, listDataSets())) { if ("no" == tclvalue(checkReplace(datasetName, gettextRcmdr("Data set")))){ if (GrabFocus()) tkgrab.release(top) tkdestroy(top) readDataFromPackage() return() } } closeDialog() command <- paste("data(", datasetName, ', package="', package, '")', sep="") justDoIt(command) logger(command) activeDataSet(datasetName) tkfocus(CommanderWindow()) } } OKCancelHelp(helpSubject="data") tkgrid(tklabel(packageDatasetFrame, text=gettextRcmdr("Package (Double-click to select)"), fg="blue"), tklabel(packageDatasetFrame, text=" "), tklabel(packageDatasetFrame, text=gettextRcmdr("Data set (Double-click to select)"), fg="blue"), sticky="w") tkgrid(packageBox, packageScroll, sticky="nw") tkgrid(datasetBox, datasetScroll, sticky="nw") tkgrid(packageFrame, tklabel(packageDatasetFrame, text=" "), datasetFrame, sticky="nw") tkgrid(packageDatasetFrame, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("OR"), fg="red"), sticky="w") tkgrid(tklabel(enterFrame, text=gettextRcmdr("Enter name of data set: "), fg="blue"), entryDsname, sticky="w") tkgrid(enterFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") tkgrid.configure(packageScroll, sticky="ns") tkgrid.configure(datasetScroll, sticky="ns") tkbind(packageBox, "", onPackageSelect) tkbind(datasetBox, "", onDatasetSelect) tkgrid(buttonsFrame, columnspan="2", sticky="w") dialogSuffix(rows=4, columns=1, focus=entryDsname) } importSPSS <- function() { require("foreign") initializeDialog(title=gettextRcmdr("Import SPSS Data Set")) dsname <- tclVar(gettextRcmdr("Dataset")) entryDsname <- tkentry(top, width="20", textvariable=dsname) asFactor <- tclVar("1") asFactorCheckBox <- tkcheckbutton(top, variable=asFactor) maxLevels <- tclVar("Inf") entryMaxLevels <- tkentry(top, width="5", textvariable=maxLevels) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == ""){ errorCondition(recall=importSPSS, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)){ errorCondition(recall=importSPSS, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ importSPSS() return() } } file <- tclvalue(tkgetOpenFile( filetypes=gettextRcmdr('{"SPSS save files" {".sav" ".SAV"}} {"SPSS portable files" {".por" ".POR"}} {"All Files" {"*"}}'))) if (file == "") { tkfocus(CommanderWindow()) return() } factor <- tclvalue(asFactor) == "1" levels <- as.numeric(tclvalue(maxLevels)) command <- paste('read.spss("', file,'", use.value.labels=', factor, ", max.value.labels=", levels, ", to.data.frame=TRUE)", sep="") logger(paste(dsnameValue, " <- ", command, sep="")) assign(dsnameValue, justDoIt(command), envir=.GlobalEnv) activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="read.spss") tkgrid(tklabel(top, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Convert value labels\nto factor levels"), justify="left"), asFactorCheckBox, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Maximum number\nof value labels\nfor factor conversion"), justify="left"), entryMaxLevels, sticky="w") tkgrid(buttonsFrame, columnspan="2", sticky="w") tkgrid.configure(entryDsname, sticky="w") tkgrid.configure(asFactorCheckBox, sticky="w") tkgrid.configure(entryMaxLevels, sticky="w") dialogSuffix(rows=4, columns=2, focus=entryDsname) } importMinitab <- function() { require("foreign") initializeDialog(title=gettextRcmdr("Import Minitab Data Set")) dsname <- tclVar(gettextRcmdr("Dataset")) entryDsname <- tkentry(top, width="20", textvariable=dsname) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == ""){ errorCondition(recall=importMinitab, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)){ errorCondition(recall=importMinitab, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ importMinitab() return() } } file <- tclvalue(tkgetOpenFile( filetypes=gettextRcmdr('{"Minitab portable files" {".mtp" ".MTP"}} {"All Files" {"*"}}'))) if (file == "") { tkfocus(CommanderWindow()) return() } command <- paste('read.mtp("', file,'")', sep="") datalist <- justDoIt(command) lengths <- sapply(datalist, length) datalist <- datalist[lengths != 0] lengths <- lengths[lengths != 0] if (!all(lengths == length(datalist[[1]]))){ Message(message= paste(gettextRcmdr("Minitab data set contains elements of unequal length.\nData set cannot be converted.")), type="error") tkdestroy(top) tkfocus(CommanderWindow()) return() } assign(dsnameValue, as.data.frame(datalist), envir=.GlobalEnv) logger(paste(dsnameValue, " <- as.data.frame(", command, ")", sep="")) activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="read.mtp") tkgrid(tklabel(top, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="e") tkgrid(buttonsFrame, columnspan="2", sticky="w") tkgrid.configure(entryDsname, sticky="w") dialogSuffix(rows=2, columns=2, focus=entryDsname) } # the following function was contributed by Michael Ash (modified by J. Fox 2 Feb 05) importSTATA <- function() { require("foreign") initializeDialog(title=gettextRcmdr("Import STATA Data Set")) dsname <- tclVar(gettextRcmdr("Dataset")) entryDsname <- tkentry(top, width="20", textvariable=dsname) asFactor <- tclVar("1") asFactorCheckBox <- tkcheckbutton(top, variable=asFactor) asDate <- tclVar("1") asDateCheckBox <- tkcheckbutton(top, variable=asDate) asMissingType <- tclVar("1") asMissingTypeCheckBox <- tkcheckbutton(top, variable=asMissingType) asConvertUnderscore <- tclVar("1") asConvertUnderscoreCheckBox <- tkcheckbutton(top, variable=asConvertUnderscore) asWarnMissingLabels <- tclVar("1") asWarnMissingLabelsCheckBox <- tkcheckbutton(top, variable=asWarnMissingLabels) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == ""){ errorCondition(recall=importSTATA, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)){ errorCondition(recall=importSTATA, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ importSTATA() return() } } file <- tclvalue(tkgetOpenFile( filetypes=gettextRcmdr('{"STATA datasets" {".dta" ".DTA"}} {"All Files" {"*"}}'))) if (file == "") { tkfocus(CommanderWindow()) return() } convert.date <- tclvalue(asDate) == "1" factor <- tclvalue(asFactor) == "1" missingtype <- tclvalue(asMissingType) == "1" convertunderscore <- tclvalue(asConvertUnderscore) == "1" warnmissinglabels <- tclvalue(asWarnMissingLabels) == "1" command <- paste('read.dta("', file,'", convert.dates=', convert.date, ", convert.factors=", factor, ", missing.type=", missingtype, ", convert.underscore=", convertunderscore, ", warn.missing.labels=TRUE)", sep="") logger(paste(dsnameValue, " <- ", command, sep="")) assign(dsnameValue, justDoIt(command), envir=.GlobalEnv) activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="read.dta") tkgrid(tklabel(top, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Convert value labels\nto factor levels"), justify="left"), asFactorCheckBox, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Convert dates to R format"), justify="left"), asDateCheckBox, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Multiple missing types (>=Stata 8)"), justify="left"), asMissingTypeCheckBox, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Convert underscore to period"), justify="left"), asConvertUnderscoreCheckBox, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Warn on missing labels"), justify="left"), asWarnMissingLabelsCheckBox, sticky="w") tkgrid(buttonsFrame, columnspan="2", sticky="w") tkgrid.configure(entryDsname, sticky="w") tkgrid.configure(asFactorCheckBox, sticky="w") tkgrid.configure(asDateCheckBox, sticky="w") tkgrid.configure(asMissingTypeCheckBox, sticky="w") tkgrid.configure(asWarnMissingLabelsCheckBox, sticky="w") dialogSuffix(rows=4, columns=2, focus=entryDsname) } # The following function was contributed by Matthieu Lesnoff # (added with small changes by J. Fox, 20 July 06) importRODBCtable <- function(){ # load the RODBC package and stops the program if not available if(!require(RODBC)) stop(gettextRcmdr("This function requires the RODBC package.\n")) # close all databases in case of error on.exit(odbcCloseAll()) # Enter the name of data set, by default : Dataset initializeDialog(title = gettextRcmdr("Import from Excel, Access or dBase data set")) dsname <- tclVar(gettextRcmdr("Dataset")) entryDsname <- tkentry(top, width = "35", textvariable = dsname) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if(dsnameValue == ""){ errorCondition(recall = importRODBCtable, message = gettextRcmdr("You must enter the name of a data set.")) return() } if(!is.valid.name(dsnameValue)){ errorCondition(recall = queryimportRODBCtable, message = paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep = "")) return() } if(is.element(dsnameValue, listDataSets())){ if("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ importRODBCtable() return() } } File <- tclvalue(tkgetOpenFile(filetypes = gettextRcmdr( '{"MS Excel file" {*.xls ".XLS"}} {"MS Access database" {*.mdb ".MDB"}} {"dBase-like file" {*.dbf ".DBF"}} {"All Files" {"*"}}' ))) if(File == ""){ tkfocus(CommanderWindow()) return() } sop <- match(".", rev(strsplit(File, NULL)[[1]]))[1] ext <- tolower(substring(File, nchar(File) - sop + 2, nchar(File))) channel <- switch(EXPR = ext, xls = odbcConnectExcel(File), mdb = odbcConnectAccess(File), dbf = odbcConnectDbase(File)) # For Excel and Access cases, need to select a particular sheet or table if(ext != "dbf"){ tabdat <- sqlTables(channel) names(tabdat) <- tolower(names(tabdat)) if(ext == "mdb") tabdat <- tabdat[tabdat$table_type == "TABLE", 3] if(ext == "xls"){ tabname <- tabdat$table_name tabdat <- ifelse(tabdat$table_type =="TABLE", substring(tabname, 2, nchar(tabname) - 2), substring(tabname, 1, nchar(tabname) - 1)) } # if there are several tables if(length(tabdat)>1) fil <- tk_select.list(sort(tabdat), title = gettextRcmdr("Select one table")) else fil <- tabdat if(fil == ""){ errorCondition(message=gettextRcmdr("No table selected")) return() } if(ext == "xls") fil <- paste("[", fil, "$]", sep = "") } # dBase file else{ sop <- match(".", rev(strsplit(File, NULL)[[1]]))[1] root <- tolower(substring(File, 1, nchar(File) - sop)) revstr <- rev(strsplit(root, NULL)[[1]]) sop <- if(is.na(match(c("/", "\\"), revstr)[1])) length(revstr) else match(c("/", "\\"), revstr)[1] - 1 toor <- revstr[seq(sop)] fil <- paste(rev(toor), collapse = "") } # Retrieve the data dat <- sqlQuery(channel = channel, query = paste("select * from", fil)) names(dat)<- trim.blanks(names(dat)) dat <- trim.col.na(dat) odbcCloseAll() assign(dsnameValue, as.data.frame(dat), envir = .GlobalEnv) command <- paste("sqlQuery(channel = ",channel,", select * from ", fil,")", sep = "") logger(paste(dsnameValue, " <- ", command, sep = "")) activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } ## End of function onOK OKCancelHelp(helpSubject="odbcConnect") tkgrid(tklabel(top, text=gettextRcmdr("Enter name of data set: ")), entryDsname, sticky="e") tkgrid(buttonsFrame, columnspan="2", sticky="w") tkgrid.configure(entryDsname, sticky="w") dialogSuffix(rows=2, columns=2, focus=entryDsname) } numericToFactor <- function(){ initializeDialog(title=gettextRcmdr("Convert Numeric Variables to Factors")) variableBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick one or more)")) radioButtons(name="levels", buttons=c("names", "numbers"), labels=gettextRcmdr(c("Supply level names", "Use numbers")), title=gettextRcmdr("Factor Levels")) factorName <- tclVar(gettextRcmdr("")) factorNameField <- tkentry(top, width="20", textvariable=factorName) onOK <- function(){ variables <- getSelection(variableBox) closeDialog() if (length(variables) == 0) { errorCondition(recall=numericToFactor, message=gettextRcmdr("You must select a variable.")) return() } facname <- trim.blanks(tclvalue(factorName)) .activeDataSet <- ActiveDataSet() cmd <- paste("apply(", .activeDataSet, "[c(", paste( paste('"', variables, '"', sep=""), collapse=","), ")], 2, function(x) sort(unique(x)))", sep="") levs <- eval(parse(text=cmd), envir=.GlobalEnv) sameLevels <- (length(variables) == 1) || ((is.matrix(levs)) && (all(0 == apply(levs, 1, var)))) for (name in variables){ fname <- if (facname == gettextRcmdr("")) name else if (length(variables) == 1) facname else paste(facname, name, sep="") if (!is.valid.name(fname)){ errorCondition(recall=numericToFactor, message=paste('"', fname, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(fname, Variables())) { if ("no" == tclvalue(checkReplace(fname))){ numericToFactor() return() } } levelsType <- tclvalue(levelsVariable) env <- environment() if (((name == variables[1]) || (!sameLevels)) && (levelsType == "names")){ values <- sort(unique(eval(parse(text=paste(.activeDataSet, "$", name, sep="")), envir=.GlobalEnv))) nvalues <- length(values) if (nvalues > 30) { errorCondition(recall=numericToFactor, message=sprintf(gettextRcmdr("Number of levels (%d) too large."), nvalues)) return() } initializeDialog(subdialog, title=paste(gettextRcmdr("Level Names for"), if(sameLevels && length(variables) > 1) "Factors" else fname)) names <- rep("", nvalues) onOKsub <- function() { closeDialog(subdialog) for (i in 1:nvalues){ names[i] <- eval(parse(text=paste("tclvalue(levelName", i, ")", sep=""))) } if (length(unique(names)) != nvalues){ errorCondition(recall=numericToFactor, message=gettextRcmdr("Levels names are not unique.")) return() } if (any(names == "")){ errorCondition(recall=numericToFactor, message=gettextRcmdr("A level name is empty.")) return() } assign("labels", paste(paste("'", names, "'", sep=""), collapse=","), envir=env) } subOKCancelHelp() tkgrid(tklabel(subdialog, text=gettextRcmdr("Numeric value")), tklabel(subdialog, text=gettextRcmdr("Level name")), sticky="w") for (i in 1:nvalues){ valVar <- paste("levelName", i, sep="") assign(valVar, tclVar("")) assign(paste("entry", i, sep=""), tkentry(subdialog, width="20", textvariable=eval(parse(text=valVar)))) tkgrid(tklabel(subdialog, text=values[i]), eval(parse(text=paste("entry", i, sep=""))), sticky="w") } tkgrid(subButtonsFrame, sticky="w", columnspan=2) dialogSuffix(subdialog, rows=nvalues+2, columns=2, focus=entry1, onOK=onOKsub) } if (levelsType == "names"){ if (!exists("labels", mode="character")) return() command <- paste("factor(", .activeDataSet, "$", name, ", labels=c(", labels, "))", sep="") justDoIt(paste(.activeDataSet, "$", fname, " <- ", command, sep="")) logger(paste(.activeDataSet,"$", fname," <- ", command, sep="")) activeDataSet(.activeDataSet) tkfocus(CommanderWindow()) } else{ command <- paste("as.factor(", .activeDataSet, "$", name, ")", sep="") justDoIt(paste(.activeDataSet, "$", fname, " <- ", command, sep="")) logger(paste(.activeDataSet, "$", fname," <- ", command, sep="")) activeDataSet(.activeDataSet, flushModel=FALSE) tkfocus(CommanderWindow()) } } } OKCancelHelp(helpSubject="factor") tkgrid(getFrame(variableBox), levelsFrame, sticky="nw") tkgrid(tklabel(top, text=gettextRcmdr("New variable name or prefix for multiple variables:")), factorNameField, sticky="w") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(numbersButton, sticky="w") tkgrid.configure(namesButton, sticky="w") dialogSuffix(rows=4, columns=2, preventGrabFocus=TRUE) } binVariable <- function(){ # Author: Dan Putler (revision by J. Fox, 2 Feb 05) # if (!checkActiveDataSet()) return() # if (!checkNumeric()) return() env <- environment() initializeDialog(title=gettextRcmdr("Bin a Numeric Variable")) variableFrame <- tkframe(top) variableBox <- variableListBox(variableFrame, Numeric(), title=gettextRcmdr("Variable to bin (pick one)")) newVariableFrame <- tkframe(variableFrame) newVariableName <- tclVar(gettextRcmdr("variable")) newVariable <- tkentry(newVariableFrame, width="18", textvariable=newVariableName) binsFrame <- tkframe(top) binsVariable <- tclVar("3") slider <- tkscale(binsFrame, from=2, to=10, showvalue=TRUE, variable=binsVariable, resolution=1, orient="horizontal") optionsFrame <- tkframe(top) radioButtons(optionsFrame, name="levels", buttons=c("specify", "numbers", "ranges"), labels=gettextRcmdr(c("Specify names", "Numbers", "Ranges")), title=gettextRcmdr("Level Names")) radioButtons(optionsFrame, name="method", buttons=c("intervals", "proportions", "natural"), labels=gettextRcmdr(c("Equal-width bins", "Equal-count bins", "Natural breaks\n(from K-means clustering)")), title=gettextRcmdr("Binning Method")) onOK <- function(){ levels <- tclvalue(levelsVariable) bins <- as.numeric(tclvalue(binsVariable)) varName <- getSelection(variableBox) closeDialog() if (length(varName) == 0){ errorCondition(recall=binVariable, message=gettextRcmdr("You must select a variable.")) return() } newVar <- tclvalue(newVariableName) if (is.element(newVar, Variables())) { if ("no" == tclvalue(checkReplace(newVar))){ binVariable() return() } } if (!is.valid.name(newVar)){ errorCondition(message=paste('"', newVar, '" ', gettextRcmdr("is not a valid name."), sep=""), recall=binVariable) return() } method <- tclvalue(methodVariable) if (levels == "specify"){ initializeDialog(subdialog, title=gettextRcmdr("Bin Names")) onOKsub <- function() { closeDialog(subdialog) level <- character(bins) for (i in 1:bins){ level[i] <- eval(parse(text=paste("tclvalue(levelName", i, ")", sep=""))) } if (length(unique(level)) != length(level)){ errorCondition(window=subdialog, message=gettextRcmdr("Level names must be unique."), recall=onOK) return() } assign("levelNames", level, envir=env) } subOKCancelHelp() tkgrid(tklabel(subdialog, text=gettextRcmdr("Bin"), fg="blue"), tklabel(subdialog, text=gettextRcmdr("Name"), fg="blue"), sticky="w") for (i in 1:bins){ valVar <- paste("levelName", i, sep="") assign(valVar, tclVar(i)) assign(paste("entry", i, sep=""), tkentry(subdialog, width="20", textvariable=eval(parse(text=valVar)))) tkgrid(tklabel(subdialog, text=as.character(i)), eval(parse(text=paste("entry", i, sep=""))), sticky="w") } tkgrid(subButtonsFrame, sticky="w", columnspan=2) dialogSuffix(subdialog, focus=entry1, rows=bins+1, columns=2, bindReturn=FALSE) } labels <- if (levels == "numbers") "FALSE" else if (levels == "ranges") "NULL" else { if (!exists("levelNames")){ onCancel() binVariable() return() } paste("c('", paste(levelNames, collapse="','"), "')", sep="") } .activeDataSet <- ActiveDataSet() command <- paste(.activeDataSet,"$",newVar, " <- ", "bin.var(", .activeDataSet,"$", varName, ", bins=", bins, ", method=", "'", method, "', labels=", labels, ")", sep="") logger(command) justDoIt(command) activeDataSet(.activeDataSet, flushModel=FALSE) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="bin.var") tkgrid(tklabel(newVariableFrame, text=gettextRcmdr("New variable name"), fg="blue"), sticky="w") tkgrid(newVariable, sticky="w") tkgrid(getFrame(variableBox), tklabel(variableFrame, text=" "), newVariableFrame, sticky="nw") tkgrid(variableFrame, sticky="w") tkgrid(tklabel(binsFrame, text=gettextRcmdr("Number of bins:")), slider, sticky="s") tkgrid(binsFrame, sticky="w") tkgrid(levelsFrame, tklabel(optionsFrame, text=" "), methodFrame, sticky="nw") tkgrid(optionsFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } reorderFactor <- function(){ initializeDialog(title=gettextRcmdr("Reorder Factor Levels")) variableBox <- variableListBox(top, Factors(), title=gettextRcmdr("Factor (pick one)")) orderedFrame <- tkframe(top) orderedVariable <- tclVar("0") orderedCheckBox <- tkcheckbutton(orderedFrame, variable=orderedVariable) factorName <- tclVar(gettextRcmdr("")) factorNameField <- tkentry(top, width="20", textvariable=factorName) onOK <- function(){ variable <- getSelection(variableBox) closeDialog() if (length(variable) == 0) { errorCondition(recall=reorderFactor, message=gettextRcmdr("You must select a variable.")) return() } name <- trim.blanks(tclvalue(factorName)) if (name == gettextRcmdr("")) name <- variable if (!is.valid.name(name)){ errorCondition(recall=reorderFactor, message=paste('"', name, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(name, Variables())) { if ("no" == tclvalue(checkReplace(name))){ reorderFactor() return() } } .activeDataSet <- ActiveDataSet() old.levels <- eval(parse(text=paste("levels(", .activeDataSet, "$", variable, ")", sep="")), envir=.GlobalEnv) nvalues <- length(old.levels) ordered <- tclvalue(orderedVariable) if (nvalues > 30) { errorCondition(recall=reorderFactor, message=sprintf(gettextRcmdr("Number of levels (%d) too large."), nvalues)) return() } initializeDialog(subdialog, title=gettextRcmdr("Reorder Levels")) order <- 1:nvalues onOKsub <- function() { closeDialog(subdialog) opt <- options(warn=-1) for (i in 1:nvalues){ order[i] <- as.numeric(eval(parse(text=paste("tclvalue(levelOrder", i, ")", sep="")))) } options(opt) if (any(sort(order) != 1:nvalues) || any(is.na(order))){ errorCondition(recall=reorderFactor, message=paste(gettextRcmdr("Order of levels must include all integers from 1 to "), nvalues, sep="")) return() } levels <- old.levels[order(order)] ordered <- if (ordered == "1") ", ordered=TRUE" else "" command <- paste("factor(", .activeDataSet, "$", variable, ", levels=c(", paste(paste("'", levels, "'", sep=""), collapse=","), ")", ordered, ")", sep="") justDoIt(paste(.activeDataSet, "$", name, " <- ", command, sep="")) logger(paste(.activeDataSet,"$", name," <- ", command, sep="")) activeDataSet(.activeDataSet, flushModel=FALSE) } subOKCancelHelp() tkgrid(tklabel(subdialog, text=gettextRcmdr("Old Levels"), fg="blue"), tklabel(subdialog, text=gettextRcmdr("New order"), fg="blue"), sticky="w") for (i in 1:nvalues){ valVar <- paste("levelOrder", i, sep="") assign(valVar, tclVar(i)) assign(paste("entry", i, sep=""), tkentry(subdialog, width="2", textvariable=eval(parse(text=valVar)))) tkgrid(tklabel(subdialog, text=old.levels[i]), eval(parse(text=paste("entry", i, sep=""))), sticky="w") } tkgrid(subButtonsFrame, sticky="w", columnspan=2) dialogSuffix(subdialog, focus=entry1, rows=nvalues+1, columns=2) } OKCancelHelp(helpSubject="factor") tkgrid(getFrame(variableBox), sticky="nw") tkgrid(tklabel(top, text=gettextRcmdr("Name for factor")), sticky="w") tkgrid(factorNameField, sticky="w") tkgrid(tklabel(orderedFrame, text=gettextRcmdr("Make ordered factor")), orderedCheckBox, sticky="w") tkgrid(orderedFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=5, columns=1, preventGrabFocus=TRUE) } standardize <- function(X){ initializeDialog(title=gettextRcmdr("Standardize Variables")) xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variables (pick one or more)"), selectmode="multiple") onOK <- function(){ x <- getSelection(xBox) closeDialog() if (length(x) == 0) { errorCondition(recall=standardize, message=gettextRcmdr("You must select one or more variables.")) return() } xx <- paste('"', x, '"', sep="") .activeDataSet <- ActiveDataSet() command <- paste("scale(", .activeDataSet, "[,c(", paste(xx, collapse=","), ")])", sep="") assign(".Z", justDoIt(command), envir=.GlobalEnv) logger(paste(".Z <- ", command, sep="")) for (i in 1:length(x)){ Z <- paste("Z.", x[i], sep="") if (is.element(Z, Variables())) { if ("no" == tclvalue(checkReplace(Z))){ if (GrabFocus()) tkgrab.release(top) tkdestroy(top) next } } justDoIt(paste(.activeDataSet, "$", Z, " <- .Z[,", i, "]", sep="")) logger(paste(.activeDataSet, "$", Z, " <- .Z[,", i, "]", sep="")) } remove(.Z, envir=.GlobalEnv) logger("remove(.Z)") activeDataSet(.activeDataSet, flushModel=FALSE) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="scale") tkgrid(getFrame(xBox), sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2, columns=1) } helpDataSet <- function(){ .activeDataSet <- ActiveDataSet() if (as.numeric(R.Version()$major) >= 2) doItAndPrint(paste('help("', .activeDataSet, '")', sep="")) else { justDoIt(paste("help('", .activeDataSet, "')", sep="")) logger(paste('help("', .activeDataSet, '")', sep="")) } NULL } variablesDataSet <- function(){ doItAndPrint(paste("names(", ActiveDataSet(), ")", sep="")) } exportDataSet <- function() { dsname <- activeDataSet() initializeDialog(title=gettextRcmdr("Export Active Data Set")) checkBoxes(frame="optionsFrame", boxes=c("colnames", "rownames", "quotes"), initialValues=rep(1,3), labels=gettextRcmdr(c("Write variable names:", "Write row names:", "Quotes around character values:"))) missingVariable <- tclVar("NA") missingEntry <- tkentry(optionsFrame, width="8", textvariable=missingVariable) radioButtons(name="delimiter", buttons=c("spaces", "tabs", "commas"), labels=gettextRcmdr(c("Spaces", "Tabs", "Commas")), title=gettextRcmdr("Field Separator")) onOK <- function(){ closeDialog() col <- tclvalue(colnamesVariable) == 1 row <- tclvalue(rownamesVariable) == 1 quote <- tclvalue(quotesVariable) == 1 delim <- tclvalue(delimiterVariable) missing <- tclvalue(missingVariable) sep <- if (delim == "tabs") "\\t" else if (delim == "spaces") " " else "," saveFile <- tclvalue(tkgetSaveFile(filetypes=gettextRcmdr('{"Text Files" {".txt" ".TXT" ".dat" ".DAT" ".csv" ".CSV"}} {"All Files" {"*"}}'), defaultextension="txt", initialfile=paste(dsname, ".txt", sep=""))) if (saveFile == "") { tkfocus(CommanderWindow()) return() } command <- paste("write.table(", dsname, ', "', saveFile, '", sep="', sep, '", col.names=', col, ", row.names=", row, ", quote=", quote, ', na="', missing, '")', sep="") justDoIt(command) logger(command) Message(paste(gettextRcmdr("Active dataset exported to file"), saveFile), type="note") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="write.table") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Missing values:")), missingEntry, sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(delimiterFrame, stick="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=3, columns=1) } filterNA <- function(){ dataSet <- activeDataSet() initializeDialog(title=gettextRcmdr("Remove Missing Data")) allVariablesFrame <- tkframe(top) allVariables <- tclVar("1") allVariablesCheckBox <- tkcheckbutton(allVariablesFrame, variable=allVariables) variablesBox <- variableListBox(top, Variables(), selectmode="multiple", initialSelection=NULL, title=gettextRcmdr("Variables (select one or more)")) newDataSetName <- tclVar(gettextRcmdr("")) dataSetNameFrame <- tkframe(top) dataSetNameEntry <- tkentry(dataSetNameFrame, width="25", textvariable=newDataSetName) onOK <- function(){ x <- getSelection(variablesBox) closeDialog() newName <- trim.blanks(tclvalue(newDataSetName)) .activeDataSet <- ActiveDataSet() if (newName == gettextRcmdr("")) newName <- .activeDataSet if (!is.valid.name(newName)){ errorCondition(recall=filterNA, message=paste('"', newName, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(newName, listDataSets())) { if ("no" == tclvalue(checkReplace(newName, gettextRcmdr("Data set")))){ filterNA() return() } } if (tclvalue(allVariables) == "1"){ command <- paste(newName, " <- na.omit(", .activeDataSet, ")", sep="") logger(command) justDoIt(command) activeDataSet(newName) tkfocus(CommanderWindow()) } else { if (length(x) == 0) { errorCondition(recall=filterNA, message=gettextRcmdr("No variables were selected.")) return() } x <- paste('"', x, '"', sep="") command <- paste(newName, " <- na.omit(", .activeDataSet, "[,c(", paste(x, collapse=","), ')])', sep="") logger(command) justDoIt(command) activeDataSet(newName) tkfocus(CommanderWindow()) } } OKCancelHelp(helpSubject="na.omit") tkgrid(tklabel(allVariablesFrame, text=gettextRcmdr("Include all variables")), allVariablesCheckBox, sticky="w") tkgrid(allVariablesFrame, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr(" OR"), fg="red"), sticky="w") tkgrid(getFrame(variablesBox), sticky="nw") tkgrid(tklabel(dataSetNameFrame, text=gettextRcmdr("Name for new data set")), sticky="w") tkgrid(dataSetNameEntry, sticky="w") tkgrid(dataSetNameFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } subsetDataSet <- function(){ dataSet <- activeDataSet() initializeDialog(title=gettextRcmdr("Subset Data Set")) allVariablesFrame <- tkframe(top) allVariables <- tclVar("1") allVariablesCheckBox <- tkcheckbutton(allVariablesFrame, variable=allVariables) variablesBox <- variableListBox(top, Variables(), selectmode="multiple", initialSelection=NULL, title=gettextRcmdr("Variables (select one or more)")) subsetVariable <- tclVar(gettextRcmdr("")) subsetFrame <- tkframe(top) subsetEntry <- tkentry(subsetFrame, width="20", textvariable=subsetVariable) subsetScroll <- tkscrollbar(subsetFrame, orient="horizontal", repeatinterval=5, command=function(...) tkxview(subsetEntry, ...)) tkconfigure(subsetEntry, xscrollcommand=function(...) tkset(subsetScroll, ...)) newDataSetName <- tclVar(gettextRcmdr("")) dataSetNameFrame <- tkframe(top) dataSetNameEntry <- tkentry(dataSetNameFrame, width="25", textvariable=newDataSetName) onOK <- function(){ newName <- trim.blanks(tclvalue(newDataSetName)) if (newName == gettextRcmdr("")) newName <- ActiveDataSet() if (!is.valid.name(newName)){ errorCondition(recall=subsetDataSet, message=paste('"', newName, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(newName, listDataSets())) { if ("no" == tclvalue(checkReplace(newName, type=gettextRcmdr("Data set")))){ closeDialog() subsetDataSet() return() } } selectVars <- if (tclvalue(allVariables) == "1") "" else { x <- getSelection(variablesBox) if (0 > length(x)) { errorCondition(recall=subsetDataSet, message=gettextRcmdr("No variables were selected.")) return() } paste(", select=c(", paste(x, collapse=","), ")", sep="") } closeDialog() cases <- tclvalue(subsetVariable) selectCases <- if (cases == gettextRcmdr("")) "" else paste(", subset=", cases, sep="") if (selectVars == "" && selectCases ==""){ errorCondition(recall=subsetDataSet, message=gettextRcmdr("New data set same as active data set.")) return() } command <- paste(newName, " <- subset(", ActiveDataSet(), selectCases, selectVars, ")", sep="") logger(command) justDoIt(command) activeDataSet(newName) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="subset") tkgrid(tklabel(allVariablesFrame, text=gettextRcmdr("Include all variables")), allVariablesCheckBox, sticky="w") tkgrid(allVariablesFrame, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr(" OR"), fg="red"), sticky="w") tkgrid(getFrame(variablesBox), sticky="nw") tkgrid(tklabel(subsetFrame, text=gettextRcmdr("Subset expression")), sticky="w") tkgrid(subsetEntry, sticky="w") tkgrid(subsetScroll, sticky="ew") tkgrid(subsetFrame, sticky="w") tkgrid(tklabel(dataSetNameFrame, text=gettextRcmdr("Name for new data set")), sticky="w") tkgrid(dataSetNameEntry, sticky="w") tkgrid(dataSetNameFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1) } setCaseNames <- function(){ dataSet <- activeDataSet() initializeDialog(title=gettextRcmdr("Set Case Names")) variablesBox <- variableListBox(top, Variables(), title=gettextRcmdr("Select variable containing row names"), initialSelection=NULL) onOK <- function(){ variable <- getSelection(variablesBox) closeDialog() if (length(variable) == 0) { errorCondition(recall=setCaseNames, message=gettextRcmdr("You must select a variable.")) return() } var <- eval(parse(text=paste(dataSet, "$", variable, sep="")), envir=.GlobalEnv) if (length(var) != length(unique(var))){ errorCondition(recall=setCaseNames, message=gettextRcmdr("Case names must be unique.")) return() } command <- paste("row.names(", dataSet, ") <- as.character(", dataSet, "$", variable, ")", sep="") justDoIt(command) logger(command) eval(parse(text=paste(dataSet, "$", variable, "<- NULL", sep="")), envir=.GlobalEnv) logger(paste(dataSet, "$", variable, " <- NULL", sep="")) activeDataSet(dataSet, flushModel=FALSE) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="row.names") tkgrid(getFrame(variablesBox), sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=3, columns=1) } renameVariables <- function(){ initializeDialog(title=gettextRcmdr("Rename Variables")) variableBox <- variableListBox(top, Variables(), title=gettextRcmdr("Variables (pick one or more)"), selectmode="multiple", initialSelection=NULL) onOK <- function(){ variables <- getSelection(variableBox) closeDialog() nvariables <- length(variables) if (nvariables < 1) { errorCondition(recall=renameVariables, message=gettextRcmdr("No variables selected.")) return() } .activeDataSet <- ActiveDataSet() unordered.names <- names(eval(parse(text=.activeDataSet))) which.variables <- match(variables, unordered.names) initializeDialog(subdialog, title=gettextRcmdr("Variable Names")) newnames <- rep("", nvariables) onOKsub <- function() { closeDialog(subdialog) for (i in 1:nvariables){ newnames[i] <- eval(parse(text=paste("tclvalue(newName", i, ")", sep=""))) } if (any(newnames == "")){ errorCondition(recall=renameVariables, message=gettextRcmdr("A variable name is empty.")) return() } test.names <- newnames == make.names(newnames) if (!all(test.names)){ errorCondition(recall=renameVariables, message=paste(gettextRcmdr("The following variable names are not valid:\n"), paste(newnames[!test.names], collapse=", "))) return() } all.names <- eval(parse(text=paste("names(", .activeDataSet, ")"))) all.names[which.variables] <- newnames if (length(unique(all.names)) != length(all.names)){ errorCondition(recall=renameVariables, message=gettextRcmdr("Variable names are not unique")) return() } command <- paste("names(", .activeDataSet, ")[c(", paste(which.variables, collapse=","), ")] <- c(", paste('"', newnames, '"', collapse=",", sep=""), ")", sep="") justDoIt(command) logger(command) activeDataSet(.activeDataSet, flushModel=FALSE) tkfocus(CommanderWindow()) } subOKCancelHelp() tkgrid(tklabel(subdialog, text=gettextRcmdr("Old Name"), fg="blue"), tklabel(subdialog, text=gettextRcmdr("New name"), fg="blue"), sticky="w") for (i in 1:nvariables){ valVar <- paste("newName", i, sep="") assign(valVar, tclVar("")) assign(paste("entry", i, sep=""), tkentry(subdialog, width="20", textvariable=eval(parse(text=valVar)))) tkgrid(tklabel(subdialog, text=variables[i]), eval(parse(text=paste("entry", i, sep=""))), sticky="w") } tkgrid(subButtonsFrame, sticky="w", columnspan=2) dialogSuffix(subdialog, rows=nvariables+2, columns=2, focus=entry1, onOK=onOKsub) } OKCancelHelp(helpSubject="names") tkgrid(getFrame(variableBox), sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2, columns=1) } setContrasts <- function(){ initializeDialog(title=gettextRcmdr("Set Contrasts for Factor")) variableBox <- variableListBox(top, Factors(), title=gettextRcmdr("Factor (pick one)")) radioButtons(name="contrasts", buttons=c("treatment", "sum", "helmert", "poly", "specify"), values=c("contr.Treatment", "contr.Sum", "contr.helmert", "contr.poly", "specify"), labels=gettextRcmdr(c("Treatment (dummy) contrasts", "Sum (deviation) contrasts", "Helmert contrasts", "Polynomial contrasts", "Other (specify)")), title=gettextRcmdr("Contrasts")) onOK <- function(){ variable <- getSelection(variableBox) closeDialog() if (length(variable) == 0) { errorCondition(recall=setContrasts, message=gettextRcmdr("You must select a variable.")) return() } contrasts <- tclvalue(contrastsVariable) if (contrasts != "specify"){ command <- paste("contrasts(", ActiveDataSet(), "$", variable, ') <- "', contrasts, '"', sep="") justDoIt(command) logger(command) activeDataSet(ActiveDataSet()) tkfocus(CommanderWindow()) } else{ initializeDialog(subdialog, title=gettextRcmdr("Specify Contrasts")) tkgrid(tklabel(subdialog, text=gettextRcmdr("Enter Contrast Coefficients"), fg="blue"), sticky="w") env <- environment() tableFrame <- tkframe(subdialog) row.names <- eval(parse(text=paste("levels(", ActiveDataSet(), "$", variable, ")"))) row.names <- substring(paste(abbreviate(row.names, 12), " "), 1, 12) nrows <- length(row.names) ncols <- nrows - 1 make.col.names <- paste("tklabel(tableFrame, text='", gettextRcmdr("Contrast Name:"), "')", sep="") for (j in 1:ncols) { varname <- paste(".col.", j, sep="") assign(varname, tclVar(paste(".", j, sep="")), envir=env) make.col.names <- paste(make.col.names, ", ", "tkentry(tableFrame, width='12', textvariable=", varname, ")", sep="") } eval(parse(text=paste("tkgrid(", make.col.names, ", sticky='w')", sep="")), envir=env) for (i in 1:nrows){ make.row <- paste("tklabel(tableFrame, text='", row.names[i], "')") for (j in 1:ncols){ varname <- paste(".tab.", i, ".", j, sep="") assign(varname, tclVar("0"), envir=env) make.row <- paste(make.row, ", ", "tkentry(tableFrame, width='5', textvariable=", varname, ")", sep="") } eval(parse(text=paste("tkgrid(", make.row, ", sticky='w')", sep="")), envir=env) } tkgrid(tableFrame, sticky="w") onOKsub <- function(){ closeDialog(subdialog) cell <- 0 values <- rep(NA, nrows*ncols) for (j in 1:ncols){ for (i in 1:nrows){ cell <- cell + 1 varname <- paste(".tab.", i, ".", j, sep="") values[cell] <- as.numeric(eval(parse(text=paste("tclvalue(", varname,")", sep="")))) } } values <- na.omit(values) if (length(values) != nrows*ncols){ errorCondition(subdialog, recall=setContrasts, message=sprintf(gettextRcmdr( "Number of valid entries in contrast matrix(%d)\nnot equal to number of levels (%d) * number of contrasts (%d)."), length(values), nrows, ncols)) return() } if (qr(matrix(values, nrows, ncols))$rank < ncols) { errorCondition(subdialog, recall=setContrasts, message=gettextRcmdr("Contrast matrix is not of full column rank")) return() } contrast.names <- rep("", ncols) for (j in 1:ncols){ varname <- paste(".col.", j, sep="") contrast.names[j] <- eval(parse(text=paste("tclvalue(", varname,")", sep=""))) } if (length(unique(contrast.names)) < ncols) { errorCondition(subdialog, recall=setContrasts, message=gettextRcmdr("Contrast names must be unique")) return() } command <- paste("matrix(c(", paste(values, collapse=","), "), ", nrows, ", ", ncols, ")", sep="") assign(".Contrasts", justDoIt(command), envir=.GlobalEnv) logger(paste(".Contrasts <- ", command, sep="")) command <- paste("colnames(.Contrasts) <- c(", paste("'", contrast.names, "'", sep="", collapse=", "), ")", sep="") justDoIt(command) logger(command) command <- paste("contrasts(", ActiveDataSet(), "$", variable, ") <- .Contrasts", sep="") justDoIt(command) logger(command) justDoIt("remove(.Contrasts, envir=.GlobalEnv)") logger("remove(.Contrasts)") activeDataSet(ActiveDataSet(), flushModel=FALSE) tkfocus(CommanderWindow()) } subOKCancelHelp(helpSubject="contrasts") tkgrid(tableFrame, sticky="w") tkgrid(tklabel(subdialog, text="")) tkgrid(subButtonsFrame, sticky="w") dialogSuffix(subdialog, rows=5, columns=1, focus=subdialog) } } OKCancelHelp(helpSubject="contrasts") tkgrid(getFrame(variableBox), sticky="nw") tkgrid(contrastsFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } refreshActiveDataSet <- function() activeDataSet(ActiveDataSet()) addObsNumbers <- function(){ dsname <- ActiveDataSet() if (is.element("ObsNumber", listVariables())) { if ("no" == tclvalue(checkReplace("ObsNumber", gettextRcmdr("Variable")))){ return() } } nrows <- eval(parse(text=paste("nrow(", dsname, ")", sep="")), envir=.GlobalEnv) command <- paste(dsname, "$ObsNumber <- 1:", nrows, sep="") logger(command) justDoIt(command) activeDataSet(dsname, flushModel=FALSE) } Stack <- function(){ initializeDialog(title=gettextRcmdr("Stack Variables")) variableBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick two or more)")) factorName <- tclVar(gettextRcmdr("factor")) factorNameField <- tkentry(top, width="20", textvariable=factorName) variableName <- tclVar(gettextRcmdr("variable")) variableNameField <- tkentry(top, width="20", textvariable=variableName) datasetName <- tclVar(gettextRcmdr("StackedData")) datasetNameField <- tkentry(top, width="20", textvariable=datasetName) onOK <- function(){ variables <- getSelection(variableBox) facname <- tclvalue(factorName) varname <- tclvalue(variableName) dsname <- tclvalue(datasetName) closeDialog() if (length(variables) < 2) { errorCondition(recall=Stack, message=gettextRcmdr("You must select at least two variables.")) return() } if (!is.valid.name(facname)){ errorCondition(recall=Stack, message=paste('"', facname, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (!is.valid.name(varname)){ errorCondition(recall=Stack, message=paste('"', varname, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (!is.valid.name(dsname)){ errorCondition(recall=Stack, message=paste('"', dsname, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsname, listDataSets())) { if ("no" == tclvalue(checkReplace(dsname, gettextRcmdr("Data set")))){ Stack() return() } } command <- paste(dsname, " <- stack(", activeDataSet(), "[, c(", paste(paste('"', variables, '"', sep=""), collapse=","), ")])", sep="") logger(command) justDoIt(command) command <- paste("names(", dsname, ') <- c("', varname, '", "', facname, '")', sep="") logger(command) justDoIt(command) activeDataSet(dsname) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="stack") tkgrid(getFrame(variableBox), sticky="nw", columnspan=2) tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Name for stacked data set:")), datasetNameField, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Name for variable:")), variableNameField, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Name for factor:")), factorNameField, sticky="w") tkgrid(buttonsFrame, sticky="w", columnspan=2) dialogSuffix(rows=5, columns=2, preventGrabFocus=TRUE) } loadDataSet <- function() { file <- tclvalue(tkgetOpenFile(filetypes= gettextRcmdr('{"R Data Files" {".rda" ".Rda" ".RDA"}} {"All Files" {"*"}}'))) if (file == "") { if (getRcmdr("grab.focus")) tkgrab.release(top) tkdestroy(top) return() } command <- paste('load("', file,'")', sep="") dsname <- justDoIt(command) logger(command) activeDataSet(dsname) tkfocus(CommanderWindow()) } saveDataSet <- function() { file <- tclvalue(tkgetSaveFile(filetypes= gettextRcmdr('{"R Data Files" {".rda" ".Rda" ".RDA"}} {"All Files" {"*"}}'), defaultextension="rda", initialfile=paste(activeDataSet(), "rda", sep="."))) if (file == "") return() command <- paste('save("', activeDataSet(), '", file="', file, '")', sep="") justDoIt(command) logger(command) } # Distributions menu dialogs # last modified 28 July 06 by J. Fox # many distributions added (and some other changes) by Miroslav Ristic (20 July 06) normalQuantiles <- function(){ initializeDialog(title=gettextRcmdr("Normal Quantiles")) quantilesVar <- tclVar("") quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar) muVar <- tclVar("0") muEntry <- tkentry(top, width="6", textvariable=muVar) sigmaVar <- tclVar("1") sigmaEntry <- tkentry(top, width="6", textvariable=sigmaVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(quantilesVar)) if ("" == quantiles) { errorCondition(recall=normalQuantiles, message=gettextRcmdr("No probabilities specified.")) return() } mu <- as.numeric(tclvalue(muVar)) sigma <- as.numeric(tclvalue(sigmaVar)) if (is.na(sigma) || sigma <= 0) { errorCondition(recall=normalQuantiles, message=gettextRcmdr("Standard deviation must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("qnorm(c(", quantiles, "), mean=", mu, ", sd=", sigma, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qnorm") tkgrid(tklabel(top, text=gettextRcmdr("Probabilities")), quantilesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("mu (mean)")), muEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("sigma (standard deviation)")), sigmaEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(quantilesEntry, sticky="w") tkgrid.configure(muEntry, sticky="w") tkgrid.configure(sigmaEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=2, focus=quantilesEntry) } normalProbabilities <- function(){ initializeDialog(title=gettextRcmdr("Normal Probabilities")) probabilitiesVar <- tclVar("") probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar) muVar <- tclVar("0") muEntry <- tkentry(top, width="6", textvariable=muVar) sigmaVar <- tclVar("1") sigmaEntry <- tkentry(top, width="6", textvariable=sigmaVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar)) if ("" == probabilities) { errorCondition(recall=normalProbabilities, message=gettextRcmdr("No values specified.")) return() } mu <- as.numeric(tclvalue(muVar)) sigma <- as.numeric(tclvalue(sigmaVar)) if (is.na(sigma) || sigma <= 0) { errorCondition(recall=normalProbabilities, message=gettextRcmdr("Standard deviation must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("pnorm(c(", probabilities, "), mean=", mu, ", sd=", sigma, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="pnorm") tkgrid(tklabel(top, text=gettextRcmdr("Variable value(s)")), probabilitiesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("mu (mean)")), muEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("sigma (standard deviation)")), sigmaEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(probabilitiesEntry, sticky="w") tkgrid.configure(muEntry, sticky="w") tkgrid.configure(sigmaEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=1, focus=probabilitiesEntry) } tQuantiles <- function(){ initializeDialog(title=gettextRcmdr("t Quantiles")) quantilesVar <- tclVar("") quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar) dfVar <- tclVar("") dfEntry <- tkentry(top, width="6", textvariable=dfVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(quantilesVar)) if ("" == quantiles) { errorCondition(recall=tQuantiles, message=gettextRcmdr("No probabilities specified.")) return() } df <- as.numeric(tclvalue(dfVar)) if (is.na(df)) { errorCondition(recall=tQuantiles, message=gettextRcmdr("Degrees of freedom not specified.")) return() } if (df <= 0) { errorCondition(recall=tQuantiles, message=gettextRcmdr("Degrees of freedom must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("qt(c(", quantiles, "), df=", df, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qt") tkgrid(tklabel(top, text=gettextRcmdr("Probabilities")), quantilesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Degrees of freedom")), dfEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(quantilesEntry, sticky="w") tkgrid.configure(dfEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=5, columns=2, focus=quantilesEntry) } tProbabilities <- function(){ initializeDialog(title=gettextRcmdr("t Probabilities")) probabilitiesVar <- tclVar("") probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar) dfVar <- tclVar("") dfEntry <- tkentry(top, width="6", textvariable=dfVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar)) df <- as.numeric(tclvalue(dfVar)) if ("" == probabilities) { errorCondition(recall=tProbabilities, message=gettextRcmdr("No values specified.")) return() } df <- as.numeric(tclvalue(dfVar)) if (is.na(df)) { errorCondition(recall=tProbabilities, message=gettextRcmdr("Degrees of freedom not specified.")) return() } if (df <= 0) { errorCondition(recall=tProbabilities, message=gettextRcmdr("Degrees of freedom must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("pt(c(", probabilities, "), df=", df, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="pt") tkgrid(tklabel(top, text=gettextRcmdr("Variable value(s)")), probabilitiesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Degrees of freedom")), dfEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(probabilitiesEntry, sticky="w") tkgrid.configure(dfEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=5, columns=2, focus=probabilitiesEntry) } chisqQuantiles <- function(){ initializeDialog(title=gettextRcmdr("Chi-Squared Quantiles")) quantilesVar <- tclVar("") quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar) dfVar <- tclVar("") dfEntry <- tkentry(top, width="6", textvariable=dfVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(quantilesVar)) if ("" == quantiles) { errorCondition(recall=chisqQuantiles, message=gettextRcmdr("No probabilities specified.")) return() } df <- as.numeric(tclvalue(dfVar)) if (is.na(df)) { errorCondition(recall=chisqQuantiles, message=gettextRcmdr("Degrees of freedom not specified.")) return() } if (df <= 0) { errorCondition(recall=chisqQuantiles, message=gettextRcmdr("Degrees of freedom must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("qchisq(c(", quantiles, "), df=", df, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qchisq") tkgrid(tklabel(top, text=gettextRcmdr("Probabilities")), quantilesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Degrees of freedom")), dfEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(quantilesEntry, sticky="w") tkgrid.configure(dfEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=5, columns=2, focus=quantilesEntry) } chisqProbabilities <- function(){ initializeDialog(title=gettextRcmdr("Chi-Squared Probabilities")) probabilitiesVar <- tclVar("") probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar) dfVar <- tclVar("") dfEntry <- tkentry(top, width="6", textvariable=dfVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar)) if ("" == probabilities) { errorCondition(recall=chisqProbabilities, message=gettextRcmdr("No values specified.")) return() } df <- as.numeric(tclvalue(dfVar)) if (is.na(df)) { errorCondition(recall=chisqProbabilities, message=gettextRcmdr("Degrees of freedom not specified.")) return() } if (df <= 0) { errorCondition(recall=chisqProbabilities, message=gettextRcmdr("Degrees of freedom must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("pchisq(c(", probabilities, "), df=", df, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="pchisq") tkgrid(tklabel(top, text=gettextRcmdr("Variable value(s)")), probabilitiesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Degrees of freedom")), dfEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(OKbutton, cancelButton, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(probabilitiesEntry, sticky="w") tkgrid.configure(dfEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=5, columns=2, focus=probabilitiesEntry) } FQuantiles <- function(){ initializeDialog(title=gettextRcmdr("F Quantiles")) quantilesVar <- tclVar("") quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar) df1Var <- tclVar("") df1Entry <- tkentry(top, width="6", textvariable=df1Var) df2Var <- tclVar("") df2Entry <- tkentry(top, width="6", textvariable=df2Var) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(quantilesVar)) if ("" == quantiles) { errorCondition(recall=FQuantiles, message=gettextRcmdr("Probabilities not specified")) return() } df1 <- as.numeric(tclvalue(df1Var)) df2 <- as.numeric(tclvalue(df2Var)) if (is.na(df1) || is.na(df2)) { errorCondition(recall=FQuantiles, message=gettextRcmdr("Degrees of freedom not specified.")) return() } if (df1 <= 0 || df2 <= 0) { errorCondition(recall=FQuantiles, message=gettextRcmdr("Degrees of freedom must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("qf(c(", quantiles, "), df1=", df1, ", df2=", df2, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qf") tkgrid(tklabel(top, text=gettextRcmdr("Probabilities")), quantilesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Numerator degrees of freedom")), df1Entry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Denominator degrees of freedom")), df2Entry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(quantilesEntry, sticky="w") tkgrid.configure(df1Entry, sticky="w") tkgrid.configure(df2Entry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=2, focus=quantilesEntry) } FProbabilities <- function(){ initializeDialog(title=gettextRcmdr("F Probabilities")) probabilitiesVar <- tclVar("") probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar) df1Var <- tclVar("") df1Entry <- tkentry(top, width="6", textvariable=df1Var) df2Var <- tclVar("") df2Entry <- tkentry(top, width="6", textvariable=df2Var) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar)) if ("" == probabilities) { errorCondition(recall=FProbabilities, message=gettextRcmdr("Values not specified.")) return() } df1 <- as.numeric(tclvalue(df1Var)) df2 <- as.numeric(tclvalue(df2Var)) if (is.na(df1) || is.na(df2)) { errorCondition(recall=FProbabilities, message=gettextRcmdr("Degrees of freedom not specified.")) return() } if (df1 <= 0 || df2 <= 0) { errorCondition(recall=FProbabilities, message=gettextRcmdr("Degrees of freedom must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("pf(c(", probabilities, "), df1=", df1, ", df2=", df2, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="pf") tkgrid(tklabel(top, text=gettextRcmdr("Variable value(s)")), probabilitiesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Numerator degrees of freedom")), df1Entry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Denominator degrees of freedom")), df2Entry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(probabilitiesEntry, sticky="w") tkgrid.configure(df1Entry, sticky="w") tkgrid.configure(df2Entry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=2, focus=probabilitiesEntry) } exponentialQuantiles<-function() { initializeDialog(title=gettextRcmdr("Exponential Quantiles")) quantilesVar <- tclVar("") quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar) rateVar <- tclVar("1") rateEntry <- tkentry(top, width="6", textvariable=rateVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(quantilesVar)) if ("" == quantiles) { errorCondition(recall=exponentialQuantiles, message=gettextRcmdr("Probabilities not specified.")) return() } rate <- as.numeric(tclvalue(rateVar)) if (is.na(rate) || rate <= 0) { errorCondition(recall=exponentialQuantiles, message=gettextRcmdr("Rate must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("qexp(c(", quantiles, "), rate=", rate, ", lower.tail=", tail == "lower", ")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qexp") tkgrid(tklabel(top, text=gettextRcmdr("Probabilities")), quantilesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Rate")), rateEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(quantilesEntry, sticky="w") tkgrid.configure(rateEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=1, focus=quantilesEntry) } exponentialProbabilities <- function(){ initializeDialog(title=gettextRcmdr("Exponential Probabilities")) probabilitiesVar <- tclVar("") probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar) rateVar <- tclVar("1") rateEntry <- tkentry(top, width="6", textvariable=rateVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar)) if ("" == probabilities) { errorCondition(recall=exponentialProbabilities, message=gettextRcmdr("No values specified.")) return() } rate <- as.numeric(tclvalue(rateVar)) if (is.na(rate) || rate <= 0) { errorCondition(recall=exponentialProbabilities, message=gettextRcmdr("Rate must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("pexp(c(", probabilities, "), rate=", rate, ", lower.tail=", tail == "lower", ")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="pexp") tkgrid(tklabel(top, text=gettextRcmdr("Variable value(s)")), probabilitiesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Rate")), rateEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(probabilitiesEntry, sticky="w") tkgrid.configure(rateEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=1, focus=probabilitiesEntry) } uniformQuantiles<-function() { initializeDialog(title=gettextRcmdr("Uniform Quantiles")) quantilesVar <- tclVar("") quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar) minVar <- tclVar("0") maxVar <- tclVar("1") minEntry <- tkentry(top, width="6", textvariable=minVar) maxEntry <- tkentry(top, width="6", textvariable=maxVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(quantilesVar)) if ("" == quantiles) { errorCondition(recall=uniformQuantiles, message=gettextRcmdr("Probabilities not specified.")) return() } min <- as.numeric(tclvalue(minVar)) max <- as.numeric(tclvalue(maxVar)) if (is.na(min) || is.na(max) || min >= max) { errorCondition(recall=uniformQuantiles, message=gettextRcmdr("Lower limit must be less than upper limit.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("qunif(c(", quantiles, "), min=", min, ", max=", max, ", lower.tail=", tail == "lower", ")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qunif") tkgrid(tklabel(top, text=gettextRcmdr("Probabilities")), quantilesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Minimum")), minEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Maximum")), maxEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(quantilesEntry, sticky="w") tkgrid.configure(minEntry, sticky="w") tkgrid.configure(maxEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=1, focus=quantilesEntry) } uniformProbabilities <- function(){ initializeDialog(title=gettextRcmdr("Uniform Probabilities")) probabilitiesVar <- tclVar("") probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar) minVar <- tclVar("0") maxVar <- tclVar("1") minEntry <- tkentry(top, width="6", textvariable=minVar) maxEntry <- tkentry(top, width="6", textvariable=maxVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar)) if ("" == probabilities) { errorCondition(recall=uniformProbabilities, message=gettextRcmdr("No values specified.")) return() } if (is.na(min) || is.na(max) || min >= max) { errorCondition(recall=uniformProbabilities, message=gettextRcmdr("Lower limit must be less than upper limit.")) return() } min <- as.numeric(tclvalue(minVar)) max <- as.numeric(tclvalue(maxVar)) tail <- tclvalue(tailVar) doItAndPrint(paste("punif(c(", probabilities, "), min=", min, ", max=", max, ", lower.tail=", tail == "lower", ")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="punif") tkgrid(tklabel(top, text=gettextRcmdr("Variable value(s)")), probabilitiesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Minimum")), minEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Maximum")), maxEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(probabilitiesEntry, sticky="w") tkgrid.configure(minEntry, sticky="w") tkgrid.configure(maxEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=1, focus=probabilitiesEntry) } betaQuantiles <- function(){ initializeDialog(title=gettextRcmdr("Beta Quantiles")) quantilesVar <- tclVar("") quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar) shape1Var <- tclVar("") shape1Entry <- tkentry(top, width="6", textvariable=shape1Var) shape2Var <- tclVar("") shape2Entry <- tkentry(top, width="6", textvariable=shape2Var) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(quantilesVar)) if ("" == quantiles) { errorCondition(recall=betaQuantiles, message=gettextRcmdr("Probabilities not specified")) return() } shape1 <- as.numeric(tclvalue(shape1Var)) shape2 <- as.numeric(tclvalue(shape2Var)) if (is.na(shape1) || is.na(shape2)) { errorCondition(recall=betaQuantiles, message=gettextRcmdr("Shapes not specified.")) return() } if (shape1 <= 0 || shape2 <= 0) { errorCondition(recall=betaQuantiles, message=gettextRcmdr("Shapes must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("qbeta(c(", quantiles, "), shape1=", shape1, ", shape2=", shape2, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qbeta") tkgrid(tklabel(top, text=gettextRcmdr("Probabilities")), quantilesEntry, sticky="e") tkgrid(tklabel(top, text=paste(gettextRcmdr("Shape"), "1")), shape1Entry, sticky="e") tkgrid(tklabel(top, text=paste(gettextRcmdr("Shape"), "2")), shape2Entry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(quantilesEntry, sticky="w") tkgrid.configure(shape1Entry, sticky="w") tkgrid.configure(shape2Entry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=2, focus=quantilesEntry) } betaProbabilities <- function(){ initializeDialog(title=gettextRcmdr("Beta Probabilities")) probabilitiesVar <- tclVar("") probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar) shape1Var <- tclVar("") shape1Entry <- tkentry(top, width="6", textvariable=shape1Var) shape2Var <- tclVar("") shape2Entry <- tkentry(top, width="6", textvariable=shape2Var) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar)) if ("" == probabilities) { errorCondition(recall=betaProbabilities, message=gettextRcmdr("Values not specified.")) return() } shape1 <- as.numeric(tclvalue(shape1Var)) shape2 <- as.numeric(tclvalue(shape2Var)) if (is.na(shape1) || is.na(shape2)) { errorCondition(recall=betaProbabilities, message=gettextRcmdr("Shapes not specified.")) return() } if (shape1 <= 0 || shape2 <= 0) { errorCondition(recall=betaProbabilities, message=gettextRcmdr("Shapes must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("pbeta(c(", probabilities, "), shape1=", shape1, ", shape2=", shape2, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="pbeta") tkgrid(tklabel(top, text=gettextRcmdr("Variable value(s)")), probabilitiesEntry, sticky="e") tkgrid(tklabel(top, text=paste(gettextRcmdr("Shape"), "1")), shape1Entry, sticky="e") tkgrid(tklabel(top, text=paste(gettextRcmdr("Shape"), "2")), shape2Entry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(probabilitiesEntry, sticky="w") tkgrid.configure(shape1Entry, sticky="w") tkgrid.configure(shape2Entry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=2, focus=probabilitiesEntry) } CauchyQuantiles <- function(){ initializeDialog(title=gettextRcmdr("Cauchy Quantiles")) quantilesVar <- tclVar("") quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar) locationVar <- tclVar("0") locationEntry <- tkentry(top, width="6", textvariable=locationVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(quantilesVar)) if ("" == quantiles) { errorCondition(recall=CauchyQuantiles, message=gettextRcmdr("No probabilities specified.")) return() } location <- as.numeric(tclvalue(locationVar)) s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=CauchyQuantiles, message=gettextRcmdr("Scale must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("qcauchy(c(", quantiles, "), location=", location, ", scale=", s, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qcauchy") tkgrid(tklabel(top, text=gettextRcmdr("Probabilities")), quantilesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Location")), locationEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Scale")), sEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(quantilesEntry, sticky="w") tkgrid.configure(locationEntry, sticky="w") tkgrid.configure(sEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=2, focus=quantilesEntry) } CauchyProbabilities <- function(){ initializeDialog(title=gettextRcmdr("Cauchy Probabilities")) probabilitiesVar <- tclVar("") probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar) locationVar <- tclVar("0") locationEntry <- tkentry(top, width="6", textvariable=locationVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar)) if ("" == probabilities) { errorCondition(recall=CauchyProbabilities, message=gettextRcmdr("No values specified.")) return() } location <- as.numeric(tclvalue(locationVar)) s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=CauchyProbabilities, message=gettextRcmdr("Scale must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("pcauchy(c(", probabilities, "), location=", location, ", scale=", s, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="pcauchy") tkgrid(tklabel(top, text=gettextRcmdr("Variable value(s)")), probabilitiesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Location")), locationEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Scale")), sEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(probabilitiesEntry, sticky="w") tkgrid.configure(locationEntry, sticky="w") tkgrid.configure(sEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=1, focus=probabilitiesEntry) } logisticQuantiles <- function(){ initializeDialog(title=gettextRcmdr("Logistic Quantiles")) quantilesVar <- tclVar("") quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar) locationVar <- tclVar("0") locationEntry <- tkentry(top, width="6", textvariable=locationVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(quantilesVar)) if ("" == quantiles) { errorCondition(recall=logisticQuantiles, message=gettextRcmdr("No probabilities specified.")) return() } location <- as.numeric(tclvalue(locationVar)) s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=logisticQuantiles, message=gettextRcmdr("Scale must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("qlogis(c(", quantiles, "), location=", location, ", scale=", s, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qlogis") tkgrid(tklabel(top, text=gettextRcmdr("Probabilities")), quantilesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Location")), locationEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Scale")), sEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(quantilesEntry, sticky="w") tkgrid.configure(locationEntry, sticky="w") tkgrid.configure(sEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=2, focus=quantilesEntry) } logisticProbabilities <- function(){ initializeDialog(title=gettextRcmdr("Logistic Probabilities")) probabilitiesVar <- tclVar("") probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar) locationVar <- tclVar("0") locationEntry <- tkentry(top, width="6", textvariable=locationVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar)) if ("" == probabilities) { errorCondition(recall=logisticProbabilities, message=gettextRcmdr("No values specified.")) return() } location <- as.numeric(tclvalue(locationVar)) s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=logisticProbabilities, message=gettextRcmdr("Scale must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("plogis(c(", probabilities, "), location=", location, ", scale=", s, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="plogis") tkgrid(tklabel(top, text=gettextRcmdr("Variable value(s)")), probabilitiesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Location")), locationEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Scale")), sEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(probabilitiesEntry, sticky="w") tkgrid.configure(locationEntry, sticky="w") tkgrid.configure(sEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=1, focus=probabilitiesEntry) } lognormalQuantiles <- function(){ initializeDialog(title=gettextRcmdr("Lognormal Quantiles")) quantilesVar <- tclVar("") quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar) meanlogVar <- tclVar("0") meanlogEntry <- tkentry(top, width="6", textvariable=meanlogVar) sdlogVar <- tclVar("1") sdlogEntry <- tkentry(top, width="6", textvariable=sdlogVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(quantilesVar)) if ("" == quantiles) { errorCondition(recall=lognormalQuantiles, message=gettextRcmdr("No probabilities specified.")) return() } meanlog <- as.numeric(tclvalue(meanlogVar)) sdlog <- as.numeric(tclvalue(sdlogVar)) if (is.na(sdlog) || sdlog <= 0) { errorCondition(recall=lognormalQuantiles, message=gettextRcmdr("Standard deviation must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("qlnorm(c(", quantiles, "), meanlog=", meanlog, ", sdlog=", sdlog, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qlnorm") tkgrid(tklabel(top, text=gettextRcmdr("Probabilities")), quantilesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Mean (log scale)")), meanlogEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Standard deviation (log scale)")), sdlogEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(quantilesEntry, sticky="w") tkgrid.configure(meanlogEntry, sticky="w") tkgrid.configure(sdlogEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=2, focus=quantilesEntry) } lognormalProbabilities <- function(){ initializeDialog(title=gettextRcmdr("Lognormal Probabilities")) probabilitiesVar <- tclVar("") probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar) meanlogVar <- tclVar("0") meanlogEntry <- tkentry(top, width="6", textvariable=meanlogVar) sdlogVar <- tclVar("1") sdlogEntry <- tkentry(top, width="6", textvariable=sdlogVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar)) if ("" == probabilities) { errorCondition(recall=lognormalProbabilities, message=gettextRcmdr("No values specified.")) return() } meanlog <- as.numeric(tclvalue(meanlogVar)) sdlog <- as.numeric(tclvalue(sdlogVar)) if (is.na(sdlog) || sdlog <= 0) { errorCondition(recall=lognormalProbabilities, message=gettextRcmdr("Scale must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("plnorm(c(", probabilities, "), meanlog=", meanlog, ", sdlog=", sdlog, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="plnorm") tkgrid(tklabel(top, text=gettextRcmdr("Variable value(s)")), probabilitiesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Mean (log scale)")), meanlogEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Standard deviation (log scale)")), sdlogEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(probabilitiesEntry, sticky="w") tkgrid.configure(meanlogEntry, sticky="w") tkgrid.configure(sdlogEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=1, focus=probabilitiesEntry) } gammaQuantiles <- function(){ initializeDialog(title=gettextRcmdr("Gamma Quantiles")) quantilesVar <- tclVar("") quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar) shapeVar <- tclVar("") shapeEntry <- tkentry(top, width="6", textvariable=shapeVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(quantilesVar)) if ("" == quantiles) { errorCondition(recall=gammaQuantiles, message=gettextRcmdr("No probabilities specified.")) return() } shape <- as.numeric(tclvalue(shapeVar)) if (is.na(shape)) { errorCondition(recall=gammaQuantiles, message=gettextRcmdr("Shape not specified.")) return() } if (shape <= 0) { errorCondition(recall=gammaQuantiles, message=gettextRcmdr("Shape must be positive.")) return() } s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=gammaQuantiles, message=gettextRcmdr("Scale must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("qgamma(c(", quantiles, "), shape=", shape, ", scale=", s, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qgamma") tkgrid(tklabel(top, text=gettextRcmdr("Probabilities")), quantilesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Shape")), shapeEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Scale (inverse rate)")), sEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(quantilesEntry, sticky="w") tkgrid.configure(shapeEntry, sticky="w") tkgrid.configure(sEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=2, focus=quantilesEntry) } gammaProbabilities <- function(){ initializeDialog(title=gettextRcmdr("Gamma Probabilities")) probabilitiesVar <- tclVar("") probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar) shapeVar <- tclVar("") shapeEntry <- tkentry(top, width="6", textvariable=shapeVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar)) if ("" == probabilities) { errorCondition(recall=gammaProbabilities, message=gettextRcmdr("No values specified.")) return() } shape <- as.numeric(tclvalue(shapeVar)) if (is.na(shape)) { errorCondition(recall=gammaProbabilities, message=gettextRcmdr("Shape not specified.")) return() } if (shape <= 0) { errorCondition(recall=gammaProbabilities, message=gettextRcmdr("Shape must be positive.")) return() } s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=gammaProbabilities, message=gettextRcmdr("Scale must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("pgamma(c(", probabilities, "), shape=", shape, ", scale=", s, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="pgamma") tkgrid(tklabel(top, text=gettextRcmdr("Variable value(s)")), probabilitiesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Shape")), shapeEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Scale (inverse rate)")), sEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(probabilitiesEntry, sticky="w") tkgrid.configure(shapeEntry, sticky="w") tkgrid.configure(sEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=1, focus=probabilitiesEntry) } WeibullQuantiles <- function(){ initializeDialog(title=gettextRcmdr("Weibull Quantiles")) quantilesVar <- tclVar("") quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar) shapeVar <- tclVar("") shapeEntry <- tkentry(top, width="6", textvariable=shapeVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(quantilesVar)) if ("" == quantiles) { errorCondition(recall=WeibullQuantiles, message=gettextRcmdr("No probabilities specified.")) return() } shape <- as.numeric(tclvalue(shapeVar)) if (is.na(shape)) { errorCondition(recall=WeibullQuantiles, message=gettextRcmdr("Shape not specified.")) return() } if (shape <= 0) { errorCondition(recall=WeibullQuantiles, message=gettextRcmdr("Shape must be positive.")) return() } s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=WeibullQuantiles, message=gettextRcmdr("Scale must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("qweibull(c(", quantiles, "), shape=", shape, ", scale=", s, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qweibull") tkgrid(tklabel(top, text=gettextRcmdr("Probabilities")), quantilesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Shape")), shapeEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Scale")), sEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(quantilesEntry, sticky="w") tkgrid.configure(shapeEntry, sticky="w") tkgrid.configure(sEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=2, focus=quantilesEntry) } WeibullProbabilities <- function(){ initializeDialog(title=gettextRcmdr("Weibull Probabilities")) probabilitiesVar <- tclVar("") probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar) shapeVar <- tclVar("") shapeEntry <- tkentry(top, width="6", textvariable=shapeVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar)) if ("" == probabilities) { errorCondition(recall=WeibullProbabilities, message=gettextRcmdr("No values specified.")) return() } shape <- as.numeric(tclvalue(shapeVar)) if (is.na(shape)) { errorCondition(recall=WeibullProbabilities, message=gettextRcmdr("Shape not specified.")) return() } if (shape <= 0) { errorCondition(recall=WeibullProbabilities, message=gettextRcmdr("Shape must be positive.")) return() } s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=WeibullProbabilities, message=gettextRcmdr("Scale must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("pweibull(c(", probabilities, "), shape=", shape, ", scale=", s, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="pweibull") tkgrid(tklabel(top, text=gettextRcmdr("Variable value(s)")), probabilitiesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Shape")), shapeEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Scale")), sEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(probabilitiesEntry, sticky="w") tkgrid.configure(shapeEntry, sticky="w") tkgrid.configure(sEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=1, focus=probabilitiesEntry) } GumbelQuantiles <- function(){ initializeDialog(title=gettextRcmdr("Gumbel Quantiles")) quantilesVar <- tclVar("") quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar) shapeVar <- tclVar("") shapeEntry <- tkentry(top, width="6", textvariable=shapeVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(quantilesVar)) if ("" == quantiles) { errorCondition(recall=GumbelQuantiles, message=gettextRcmdr("No probabilities specified.")) return() } shape <- as.numeric(tclvalue(shapeVar)) if (is.na(shape)) { errorCondition(recall=GumbelQuantiles, message=gettextRcmdr("Shape not specified.")) return() } if (shape <= 0) { errorCondition(recall=GumbelQuantiles, message=gettextRcmdr("Shape must be positive.")) return() } s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=GumbelQuantiles, message=gettextRcmdr("Scale must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("log(qweibull(c(", quantiles, "), shape=", shape, ", scale=", s, ", lower.tail=", tail == "lower",")) # Gumbel distribution", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qweibull") tkgrid(tklabel(top, text=gettextRcmdr("Probabilities")), quantilesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Shape (log scale)")), shapeEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Scale (log scale)")), sEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(quantilesEntry, sticky="w") tkgrid.configure(shapeEntry, sticky="w") tkgrid.configure(sEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=2, focus=quantilesEntry) } GumbelProbabilities <- function(){ initializeDialog(title=gettextRcmdr("Gumbel Probabilities")) probabilitiesVar <- tclVar("") probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar) shapeVar <- tclVar("") shapeEntry <- tkentry(top, width="6", textvariable=shapeVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar)) if ("" == probabilities) { errorCondition(recall=GumbelProbabilities, message=gettextRcmdr("No values specified.")) return() } shape <- as.numeric(tclvalue(shapeVar)) if (is.na(shape)) { errorCondition(recall=GumbelProbabilities, message=gettextRcmdr("Shape not specified.")) return() } if (shape <= 0) { errorCondition(recall=GumbelProbabilities, message=gettextRcmdr("Shape must be positive.")) return() } s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=GumbelProbabilities, message=gettextRcmdr("Scale must be positive.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("pweibull(exp(c(", probabilities, ")), shape=", shape, ", scale=", s, ", lower.tail=", tail == "lower",") # Gumbel distribution", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="pweibull") tkgrid(tklabel(top, text=gettextRcmdr("Variable value(s)")), probabilitiesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Shape (log scale)")), shapeEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Scale (log scale)")), sEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(probabilitiesEntry, sticky="w") tkgrid.configure(shapeEntry, sticky="w") tkgrid.configure(sEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=1, focus=probabilitiesEntry) } binomialQuantiles <- function(){ initializeDialog(title=gettextRcmdr("Binomial Quantiles")) quantilesVar <- tclVar("") quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar) trialsVar <- tclVar("") trialsEntry <- tkentry(top, width="6", textvariable=trialsVar) probVar <- tclVar(".5") probEntry <- tkentry(top, width="6", textvariable=probVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(quantilesVar)) trials <- round(as.numeric(tclvalue(trialsVar))) prob <- as.numeric(tclvalue(probVar)) if ("" == quantiles) { errorCondition(recall=binomialQuantiles, message=gettextRcmdr("Probabilities not specified.")) return() } if (is.na(trials)) { errorCondition(recall=binomialQuantiles, message=gettextRcmdr("Binomial trials not specified.")) return() } if (is.na(prob)) { errorCondition(recall=binomialQuantiles, message=gettextRcmdr("Probability of success not specified.")) return() } if (prob < 0 || prob > 1) { errorCondition(recall=binomialQuantiles, message=gettextRcmdr("Probability of success must be between 0 and 1.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("qbinom(c(", quantiles, "), size=", trials, ", prob=", prob, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qbinom") tkgrid(tklabel(top, text=gettextRcmdr("Probabilities")), quantilesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Binomial trials")), trialsEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Probability of success")), probEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame,columnspan=2, sticky="w") tkgrid.configure(quantilesEntry, sticky="w") tkgrid.configure(trialsEntry, sticky="w") tkgrid.configure(probEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=2, focus=quantilesEntry) } binomialProbabilities <- function(){ initializeDialog(title=gettextRcmdr("Cumulative Binomial Probabilities")) probabilitiesVar <- tclVar("") probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar) trialsVar <- tclVar("") trialsEntry <- tkentry(top, width="6", textvariable=trialsVar) probVar <- tclVar(".5") probEntry <- tkentry(top, width="6", textvariable=probVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar)) trials <- round(as.numeric(tclvalue(trialsVar))) prob <- as.numeric(tclvalue(probVar)) if ("" == probabilities) { errorCondition(recall=binomialProbabilities, message=gettextRcmdr("Values not specified.")) return() } if (is.na(trials)) { errorCondition(recall=binomialProbabilities, message=gettextRcmdr("Binomial trials not specified.")) return() } if (is.na(prob)) { errorCondition(recall=binomialProbabilities, message=gettextRcmdr("Probability of success not specified.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("pbinom(c(", probabilities, "), size=", trials, ", prob=", prob, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="pbinom") tkgrid(tklabel(top, text=gettextRcmdr("Variable value(s)")), probabilitiesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Binomial trials")), trialsEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Probability of success")), probEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(probabilitiesEntry, sticky="w") tkgrid.configure(trialsEntry, sticky="w") tkgrid.configure(probEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=2, focus=probabilitiesEntry) } binomialMass <- function(){ checkTrials <- function(trials){ RcmdrTkmessageBox(message=sprintf(gettextRcmdr("Number of trials, %d, is large.\nCreate long output?"), trials), icon="warning", type="yesno", default="no") } initializeDialog(title=gettextRcmdr("Binomial Probabilities")) trialsVar <- tclVar("") trialsEntry <- tkentry(top, width="6", textvariable=trialsVar) probVar <- tclVar(".5") probEntry <- tkentry(top, width="6", textvariable=probVar) onOK <- function(){ closeDialog() trials <- as.numeric(tclvalue(trialsVar)) if (is.na(trials)) { errorCondition(recall=binomialMass, message=gettextRcmdr("Binomial trials not specified.")) return() } if (trials > 50){ if ("no" == tclvalue(checkTrials(trials))){ if (getRcmdr("grab.focus")) tkgrab.release(top) tkdestroy(top) binomialMass() return() } } prob <- as.numeric(tclvalue(probVar)) if (is.na(prob)) { errorCondition(recall=binomialMass, message=gettextRcmdr("Probability of success not specified.")) return() } command <- paste("data.frame(Pr=dbinom(0:", trials, ", size=", trials, ", prob=", prob, "))", sep="") logger(paste(".Table <- ", command, sep="")) assign(".Table", justDoIt(command), envir=.GlobalEnv) logger(paste("rownames(.Table) <- 0:", trials, sep="")) justDoIt(paste("rownames(.Table) <- 0:", trials, sep="")) doItAndPrint(".Table") logger("remove(.Table)") remove(.Table, envir=.GlobalEnv) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dbinom") tkgrid(tklabel(top, text=gettextRcmdr("Binomial trials")), trialsEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Probability of success")), probEntry, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(trialsEntry, sticky="w") tkgrid.configure(probEntry, sticky="w") dialogSuffix(rows=3, columns=2, focus=trialsEntry) } PoissonMass <- function(){ checkRange <- function(range){ RcmdrTkmessageBox(message=sprintf(gettextRcmdr("Range of values over which to plot, %d, is large.\nCreate long output?"), range), icon="warning", type="yesno", default="no") } initializeDialog(title=gettextRcmdr("Poisson Probabilities")) meanVar <- tclVar("") meanEntry <- tkentry(top, width="6", textvariable=meanVar) onOK <- function(){ closeDialog() mean <- as.numeric(tclvalue(meanVar)) if (is.na(mean)) { errorCondition(recall=PoissonMass, message=gettextRcmdr("Poisson mean not specified.")) return() } if (mean < 0) { errorCondition(recall=PoissonMass, message=gettextRcmdr("Poisson mean cannot be negative.")) return() } min <- qpois(.00005, lambda=mean) max <- qpois(.99995, lambda=mean) range <- max - min if (range > 50){ if ("no" == tclvalue(checkRange(range))){ if (getRcmdr("grab.focus")) tkgrab.release(top) tkdestroy(top) PoissonMass() return() } } command <- paste("data.frame(Pr=round(dpois(", min, ":", max, ", lambda=", mean, "), 4))", sep="") logger(paste(".Table <- ", command, sep="")) assign(".Table", justDoIt(command), envir=.GlobalEnv) logger(paste("rownames(.Table) <- ", min, ":", max, sep="")) justDoIt(paste("rownames(.Table) <- ", min, ":", max, sep="")) doItAndPrint(".Table") logger("remove(.Table)") remove(.Table, envir=.GlobalEnv) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dpois") tkgrid(tklabel(top, text=gettextRcmdr("Mean")), meanEntry, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(meanEntry, sticky="w") dialogSuffix(rows=2, columns=2, focus=meanEntry) } # the following functions were contributed by G. Jay Kerns, Andy Chang, and Theophilius Boye # modified by J. Fox PoissonQuantiles <- function(){ initializeDialog(title=gettextRcmdr("Poisson Quantiles")) quantilesVar <- tclVar("") quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar) lambdaVar <- tclVar("1") lambdaEntry <- tkentry(top, width="6", textvariable=lambdaVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(quantilesVar)) if ("" == quantiles) { errorCondition(recall=PoissonQuantiles, message=gettextRcmdr("No probabilities specified.")) return() } lambda <- tclvalue(lambdaVar) tail <- tclvalue(tailVar) if (is.na(lambda)) { errorCondition(recall=PoissonQuantiles, message=gettextRcmdr("Poisson mean not specified.")) return() } if (lambda < 0) { errorCondition(recall=PoissonQuantiles, message=gettextRcmdr("Poisson mean cannot be negative.")) return() } doItAndPrint(paste("qpois(c(", quantiles, "), lambda=", lambda, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qpois") tkgrid(tklabel(top, text=gettextRcmdr("Probabilities")), quantilesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Mean")),lambdaEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(quantilesEntry, sticky="w") tkgrid.configure(lambdaEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=2, focus=quantilesEntry) } PoissonProbabilities <- function(){ initializeDialog(title=gettextRcmdr("Poisson Probabilities")) probabilitiesVar <- tclVar("") probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar) lambdaVar <- tclVar("1") lambdaEntry <- tkentry(top, width="6", textvariable=lambdaVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar)) if ("" == probabilities) { errorCondition(recall=PoissonProbabilities, message=gettextRcmdr("No values specified.")) return() } lambda <- tclvalue(lambdaVar) tail <- tclvalue(tailVar) if (is.na(lambda)) { errorCondition(recall=PoissonProbabilities, message=gettextRcmdr("Poisson mean not specified.")) return() } if (lambda < 0) { errorCondition(recall=PoissonProbabilities, message=gettextRcmdr("Poisson mean cannot be negative.")) return() } doItAndPrint(paste("ppois(c(", probabilities, "), lambda=", lambda, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="ppois") tkgrid(tklabel(top, text=gettextRcmdr("Variable value(s)")), probabilitiesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Mean")), lambdaEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(probabilitiesEntry, sticky="w") tkgrid.configure(lambdaEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=1, focus=probabilitiesEntry) } geomQuantiles <- function(){ initializeDialog(title=gettextRcmdr("Geometric Quantiles")) quantilesVar <- tclVar("") quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar) probVar <- tclVar("0.5") probEntry <- tkentry(top, width="6", textvariable=probVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(quantilesVar)) if ("" == quantiles) { errorCondition(recall=geomQuantiles, message=gettextRcmdr("No probabilities specified.")) return() } prob <- tclvalue(probVar) tail <- tclvalue(tailVar) if ( is.na(prob) ){ errorCondition(recall=geomQuantiles, message=gettextRcmdr("Probability of success not specified.")) return() } if (prob < 0 || prob > 1) { errorCondition(recall=geomQuantiles, message=gettextRcmdr("Probability of success must be between 0 and 1.")) return() } doItAndPrint(paste("qgeom(c(", quantiles, "), prob=", prob, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qgeom") tkgrid(tklabel(top, text=gettextRcmdr("Probabilities")), quantilesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Probability of success")), probEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(quantilesEntry, sticky="w") tkgrid.configure(probEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=2, focus=quantilesEntry) } geomProbabilities <- function(){ initializeDialog(title=gettextRcmdr("Geometric Probabilities")) probabilitiesVar <- tclVar("") probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar) probVar <- tclVar("0.5") probEntry <- tkentry(top, width="6", textvariable=probVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar)) if ("" == probabilities) { errorCondition(recall=geomProbabilities, message=gettextRcmdr("No values specified.")) return() } prob <- tclvalue(probVar) tail <- tclvalue(tailVar) if ( is.na(prob) ){ errorCondition(recall=geomProbabilities, message=gettextRcmdr("Probability of success was not specified.")) return() } if (prob < 0 || prob > 1) { errorCondition(recall=geomProbabilities, message=gettextRcmdr("Probability of success must be between 0 and 1.")) return() } doItAndPrint(paste("pgeom(c(", probabilities, "), prob=", prob, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="pgeom") tkgrid(tklabel(top, text=gettextRcmdr("Variable value(s)")), probabilitiesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Probability of success")), probEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(probabilitiesEntry, sticky="w") tkgrid.configure(probEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=1, focus=probabilitiesEntry) } geomMass <- function(){ checkRange <- function(range){ RcmdrTkmessageBox(message=sprintf(gettextRcmdr("Range of values over which to plot, %d, is large.\nCreate long output?"), range), icon="warning", type="yesno", default="no") } initializeDialog(title=gettextRcmdr("Geometric Probabilities")) probVar <- tclVar("0.5") probEntry <- tkentry(top, width="6", textvariable=probVar) onOK <- function(){ closeDialog() prob <- as.numeric(tclvalue(probVar)) if (is.na(prob) ) { errorCondition(recall=geomMass, message=gettextRcmdr("Probability of success was not specified.")) return() } if (prob < 0 || prob > 1) { errorCondition(recall=geomMass, message=gettextRcmdr("Probability of success must be between 0 and 1.")) return() } xmin <- qgeom(.0005, prob=prob) xmax <- qgeom(.9995, prob=prob) range <- xmax - xmin if (range > 50){ if ("no" == tclvalue(checkRange(range))){ if (getRcmdr("grab.focus")) tkgrab.release(top) tkdestroy(top) geomMass() return() } } command <- paste("data.frame(Pr=dgeom(", xmin, ":", xmax, ", prob=", prob, "))", sep="") logger(paste(".Table <- ", command, sep="")) assign(".Table", justDoIt(command), envir=.GlobalEnv) logger(paste("rownames(.Table) <- ", xmin, ":", xmax, sep="")) justDoIt(paste("rownames(.Table) <- ", xmin, ":", xmax, sep="")) doItAndPrint(".Table") logger("remove(.Table)") remove(.Table, envir=.GlobalEnv) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dgeom") tkgrid(tklabel(top, text=gettextRcmdr("Probability of success")), probEntry, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(probEntry, sticky="w") dialogSuffix(rows=2, columns=2, focus=probEntry) } hyperQuantiles <- function(){ initializeDialog(title=gettextRcmdr("Hypergeometric Quantiles")) quantilesVar <- tclVar("") quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar) mVar <- tclVar("1") mEntry <- tkentry(top, width="6", textvariable=mVar) nVar <- tclVar("1") nEntry <- tkentry(top, width="6", textvariable=nVar) kVar <- tclVar("1") kEntry <- tkentry(top, width="6", textvariable=kVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(quantilesVar)) if ("" == quantiles) { errorCondition(recall=hyperQuantiles, message=gettextRcmdr("No probabilities specified.")) return() } m <- as.numeric(tclvalue(mVar)) n <- as.numeric(tclvalue(nVar)) k <- as.numeric(tclvalue(kVar)) # Do some error checking if ( is.na(m) ){ errorCondition(recall=hyperQuantiles, message=gettextRcmdr("The m parameter was not specified.")) return() } if ( m < 0 ){ errorCondition(recall=hyperQuantiles, message=gettextRcmdr("The m parameter cannot be negative.")) return() } m <- round(m) if ( is.na(n) ){ errorCondition(recall=hyperQuantiles, message=gettextRcmdr("The n parameter was not specified.")) return() } if ( n < 0 ){ errorCondition(recall=hyperQuantiles, message=gettextRcmdr("The n parameter cannot be negative.")) return() } n <- round(n) if ( is.na(k) ){ errorCondition(recall=hyperQuantiles, message=gettextRcmdr("The k parameter was not specified.")) return() } k <- round(k) if ( k > (m + n) ){ errorCondition(recall=hyperQuantiles, message=gettextRcmdr("The k parameter cannot be greater than m + n.")) return() } if ( k < 0 ){ errorCondition(recall=hyperQuantiles, message=gettextRcmdr("The k parameter cannot be negative.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("qhyper(c(", quantiles, "), m=", m, ", n=", n, ", k=", k,", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qhyper") tkgrid(tklabel(top, text=gettextRcmdr("Probabilities")), quantilesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("m (number of white balls in the urn)")), mEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("n (number of black balls in the urn)")), nEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("k (number of balls drawn from the urn)")), kEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(quantilesEntry, sticky="w") tkgrid.configure(mEntry, sticky="w") tkgrid.configure(nEntry, sticky="w") tkgrid.configure(kEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=7, columns=2, focus=quantilesEntry) } hyperProbabilities <- function(){ initializeDialog(title=gettextRcmdr("Hypergeometric Probabilities")) ProbabilitiesVar <- tclVar("") ProbabilitiesEntry <- tkentry(top, width="30", textvariable=ProbabilitiesVar) mVar <- tclVar("1") mEntry <- tkentry(top, width="6", textvariable=mVar) nVar <- tclVar("1") nEntry <- tkentry(top, width="6", textvariable=nVar) kVar <- tclVar("1") kEntry <- tkentry(top, width="6", textvariable=kVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() probabilities <- gsub(" ", ",", tclvalue(ProbabilitiesVar)) if ("" == probabilities) { errorCondition(recall=hyperProbabilities.ipsr, message=gettextRcmdr("No values specified.")) return() } m <- as.numeric(tclvalue(mVar)) n <- as.numeric(tclvalue(nVar)) k <- as.numeric(tclvalue(kVar)) # Do some error checking if ( is.na(m) ){ errorCondition(recall=hyperProbabilities, message=gettextRcmdr("The m parameter was not specified.")) return() } if ( m < 0 ){ errorCondition(recall=hyperProbabilities, message=gettextRcmdr("The m parameter cannot be negative.")) return() } m <- round(m) if ( is.na(n) ){ errorCondition(recall=hyperProbabilities, message=gettextRcmdr("The n parameter was not specified.")) return() } if ( n < 0 ){ errorCondition(recall=hyperProbabilities, message=gettextRcmdr("The n parameter cannot be negative.")) return() } n <- round(n) if ( is.na(k) ){ errorCondition(recall=hyperProbabilities, message=gettextRcmdr("The k parameter was not specified.")) return() } k <- round(k) if ( k > (m + n) ){ errorCondition(recall=hyperProbabilities, message=gettextRcmdr("The k parameter cannot be greater than m + n.")) return() } if ( k < 0 ){ errorCondition(recall=hyperProbabilities, message=gettextRcmdr("The k parameter cannot be negative.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("phyper(c(", probabilities, "), m=", m, ", n=", n, ", k=", k,", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="phyper") tkgrid(tklabel(top, text=gettextRcmdr("Variable value(s)")), ProbabilitiesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("m (number of white balls in the urn)")), mEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("n (number of black balls in the urn)")), nEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("k (number of balls drawn from the urn)")), kEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(ProbabilitiesEntry, sticky="w") tkgrid.configure(mEntry, sticky="w") tkgrid.configure(nEntry, sticky="w") tkgrid.configure(kEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=7, columns=2, focus=ProbabilitiesEntry) } hyperMass <- function(){ checkRange <- function(range){ RcmdrTkmessageBox(message=sprintf(gettextRcmdr("Range of values over which to plot, %d, is large.\nCreate long output?"), range), icon="warning", type="yesno", default="no") } initializeDialog(title=gettextRcmdr("Hypergeometric Probabilities")) mVar <- tclVar("1") mEntry <- tkentry(top, width="6", textvariable=mVar) nVar <- tclVar("1") nEntry <- tkentry(top, width="6", textvariable=nVar) kVar <- tclVar("1") kEntry <- tkentry(top, width="6", textvariable=kVar) onOK <- function(){ closeDialog() m <- as.numeric(tclvalue(mVar)) n <- as.numeric(tclvalue(nVar)) k <- as.numeric(tclvalue(kVar)) # Do some error checking if ( is.na(m) ){ errorCondition(recall=hyperMass, message=gettextRcmdr("The m parameter was not specified.")) return() } if ( m < 0 ){ errorCondition(recall=hyperMass, message=gettextRcmdr("The m parameter cannot be negative.")) return() } m <- round(m) if ( is.na(n) ){ errorCondition(recall=hyperMass, message=gettextRcmdr("The n parameter was not specified.")) return() } if ( n < 0 ){ errorCondition(recall=hyperMass, message=gettextRcmdr("The n parameter cannot be negative.")) return() } n <- round(n) if ( is.na(k) ){ errorCondition(recall=hyperMass, message=gettextRcmdr("The k parameter was not specified.")) return() } k <- round(k) if ( k > (m + n) ){ errorCondition(recall=hyperMass, message=gettextRcmdr("The k parameter cannot be greater than m + n.")) return() } if ( k < 0 ){ errorCondition(recall=hyperMass, message=gettextRcmdr("The k parameter cannot be negative.")) return() } xmin <- qhyper(.0005, m=m, n=n, k=k) xmax <- qhyper(.9995, m=m, n=n, k=k) if (xmax - xmin > 50){ if ("no" == tclvalue(checkRange(range))){ if (getRcmdr("grab.focus")) tkgrab.release(top) tkdestroy(top) hyperMass() return() } } command <- paste("data.frame(Pr=dhyper(", xmin, ":", xmax, ", m=", m, ", n=", n, ", k=", k, "))", sep="") logger(paste(".Table <- ", command, sep="")) assign(".Table", justDoIt(command), envir=.GlobalEnv) logger(paste("rownames(.Table) <- ", xmin, ":", xmax, sep="")) justDoIt(paste("rownames(.Table) <- ", xmin, ":", xmax, sep="")) doItAndPrint(".Table") logger("remove(.Table)") remove(.Table, envir=.GlobalEnv) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dhyper") tkgrid(tklabel(top, text=gettextRcmdr("m (number of white balls in the urn)")), mEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("n (number of black balls in the urn)")), nEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("k (number of balls drawn from the urn)")), kEntry, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(mEntry, sticky="w") tkgrid.configure(nEntry, sticky="w") tkgrid.configure(kEntry, sticky="w") dialogSuffix(rows=4, columns=2, focus=mEntry) } negbinomialQuantiles <- function(){ initializeDialog(title=gettextRcmdr("Negative Binomial Quantiles")) quantilesVar <- tclVar("") quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar) sizeVar <- tclVar("1") sizeEntry <- tkentry(top, width="6", textvariable=sizeVar) probVar <- tclVar("0.5") probEntry <- tkentry(top, width="6", textvariable=probVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(quantilesVar)) if ("" == quantiles) { errorCondition(recall=negbinomialQuantiles, message=gettextRcmdr("No probabilities specified.")) return() } size <- as.numeric(tclvalue(sizeVar)) prob <- as.numeric(tclvalue(probVar)) # Do some error checking if ( is.na(size) ){ errorCondition(recall=negbinomialQuantiles, message=gettextRcmdr("Target number of successes not specified.")) return() } if ( size < 0){ errorCondition(recall=negbinomialQuantiles, message=gettextRcmdr("Target number of successes cannot be negative.")) return() } size <- round(size) if ( is.na(prob) ){ errorCondition(recall=negbinomialQuantiles, message=gettextRcmdr("Probability of success not specified.")) return() } if (prob < 0 || prob > 1) { errorCondition(recall=negbinomialQuantiles, message=gettextRcmdr("Probability of success must be between 0 and 1.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("qnbinom(c(", quantiles, "), size=", size, ", prob=", prob, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qnbinom") tkgrid(tklabel(top, text=gettextRcmdr("Probabilities")), quantilesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Target number of successes")), sizeEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Probability of success")), probEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(quantilesEntry, sticky="w") tkgrid.configure(sizeEntry, sticky="w") tkgrid.configure(probEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=2, focus=quantilesEntry) } negbinomialProbabilities <- function(){ initializeDialog(title=gettextRcmdr("Negative Binomial Probabilities")) ProbabilitiesVar <- tclVar("") ProbabilitiesEntry <- tkentry(top, width="30", textvariable=ProbabilitiesVar) sizeVar <- tclVar("1") sizeEntry <- tkentry(top, width="6", textvariable=sizeVar) probVar <- tclVar("0.5") probEntry <- tkentry(top, width="6", textvariable=probVar) tailVar <- tclVar("lower") lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower") upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper") onOK <- function(){ closeDialog() quantiles <- gsub(" ", ",", tclvalue(ProbabilitiesVar)) if ("" == quantiles) { errorCondition(recall=negbinomialProbabilities, message=gettextRcmdr("No values specified.")) return() } size <- as.numeric(tclvalue(sizeVar)) prob <- as.numeric(tclvalue(probVar)) # Do some error checking if ( is.na(size) ){ errorCondition(recall=negbinomialProbabilities, message=gettextRcmdr("Target number of successes not specified.")) return() } if ( size < 0){ errorCondition(recall=negbinomialProbabilities, message=gettextRcmdr("Target number of successes cannot be negative.")) return() } size <- round(size) if ( is.na(prob) ){ errorCondition(recall=negbinomialProbabilities, message=gettextRcmdr("Probability of success not specified.")) return() } if (prob < 0 || prob > 1) { errorCondition(recall=negbinomialProbabilities, message=gettextRcmdr("Probability of success must be between 0 and 1.")) return() } tail <- tclvalue(tailVar) doItAndPrint(paste("pnbinom(c(", quantiles, "), size=", size, ", prob=", prob, ", lower.tail=", tail == "lower",")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="pnbinom") tkgrid(tklabel(top, text=gettextRcmdr("Variable value(s)")), ProbabilitiesEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Target number of successes")), sizeEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Probability of success")), probEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Lower tail")), lowerTailButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Upper tail")), upperTailButton, sticky="e") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(ProbabilitiesEntry, sticky="w") tkgrid.configure(sizeEntry, sticky="w") tkgrid.configure(probEntry, sticky="w") tkgrid.configure(lowerTailButton, sticky="w") tkgrid.configure(upperTailButton, sticky="w") dialogSuffix(rows=6, columns=2, focus=ProbabilitiesEntry) } negbinomialMass <- function(){ checkRange <- function(range){ RcmdrTkmessageBox(message=sprintf(gettextRcmdr("Range of values over which to plot, %d, is large.\nCreate long output?"), range), icon="warning", type="yesno", default="no") } initializeDialog(title=gettextRcmdr("Negative Binomial Probabilities")) trialsVar <- tclVar("1") trialsEntry <- tkentry(top, width="6", textvariable=trialsVar) probVar <- tclVar("0.5") probEntry <- tkentry(top, width="6", textvariable=probVar) onOK <- function(){ closeDialog() trials <- as.numeric(tclvalue(trialsVar)) if ( is.na(trials) ){ errorCondition(recall=negbinomialMass, message=gettextRcmdr("Target number of successes not specified.")) return() } if ( trials < 0){ errorCondition(recall=negbinomialMass, message=gettextRcmdr("Target number of successes cannot be negative.")) return() } trials <- round(trials) prob <- as.numeric(tclvalue(probVar)) if ( is.na(prob) ){ errorCondition(recall=negbinomialMass, message=gettextRcmdr("Probability of success not specified.")) return() } if (prob < 0 || prob > 1) { errorCondition(recall=negbinomialMass, message=gettextRcmdr("Probability of success must be between 0 and 1.")) return() } xmin <- qnbinom(.0005, size=trials, prob=prob) xmax <- qnbinom(.9995, size=trials, prob=prob) range <- xmax - xmin if (range > 50){ if ("no" == tclvalue(checkRange(range))){ if (getRcmdr("grab.focus")) tkgrab.release(top) tkdestroy(top) negbinomialMass() return() } } command <- paste("data.frame(Pr=dnbinom(", xmin, ":", xmax, ", size=", trials,", prob=", prob, "))", sep="") logger(paste(".Table <- ", command, sep="")) assign(".Table", justDoIt(command), envir=.GlobalEnv) logger(paste("rownames(.Table) <- ", xmin, ":", xmax, sep="")) justDoIt(paste("rownames(.Table) <- ", xmin, ":", xmax, sep="")) doItAndPrint(".Table") logger("remove(.Table)") remove(.Table, envir=.GlobalEnv) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dnbinom") tkgrid(tklabel(top, text=gettextRcmdr("Target number of successes")), trialsEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Probability of success")), probEntry, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(trialsEntry, sticky="w") tkgrid.configure(probEntry, sticky="w") dialogSuffix(rows=3, columns=2, focus=trialsEntry) } # Distributions menu dialogs for plots # last modified 28 July 06 by J. Fox # many distributions added (and some other changes) by Miroslav Ristic (20 July 06) normalDistributionPlot <- function(){ initializeDialog(title=gettextRcmdr("Normal Distribution")) muVar <- tclVar("0") muEntry <- tkentry(top, width="6", textvariable=muVar) sigmaVar <- tclVar("1") sigmaEntry <- tkentry(top, width="6", textvariable=sigmaVar) functionVar <- tclVar("Density") densityButton <- tkradiobutton(top, variable=functionVar, value="Density") distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability") onOK <- function(){ closeDialog() mu <- as.numeric(tclvalue(muVar)) sigma <- as.numeric(tclvalue(sigmaVar)) if (is.na(sigma) || sigma <= 0) { errorCondition(recall=normalDistributionPlot, message=gettextRcmdr("Standard deviation must be positive.")) return() } fun <- tclvalue(functionVar) fn <- if (fun == "Density") "dnorm" else "pnorm" min <- round(qnorm(.0005, mean=mu, sd=sigma), 3) max <- round(qnorm(.9995, mean=mu, sd=sigma), 3) command <- paste("seq(", min, ", ", max, ", length=100)", sep="") logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(x11(),"plot(.x, ", fn, "(.x, mean=", mu, ", sd=", sigma, '), xlab="x", ylab="', fun, '", main=expression(paste("Normal Distribution: ", mu, " = ', mu, ', ", sigma, " = ', sigma, '")), type="l")', sep="")) doItAndPrint('abline(h=0, col="gray")') remove(.x, envir=.GlobalEnv) logger("remove(.x)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dnorm") tkgrid(tklabel(top, text=gettextRcmdr("mu (mean)")), muEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("sigma (standard deviation)")), sigmaEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot density function")), densityButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot distribution function")), distributionButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(muEntry, sticky="w") tkgrid.configure(sigmaEntry, sticky="w") tkgrid.configure(densityButton, sticky="w") tkgrid.configure(distributionButton, sticky="w") dialogSuffix(rows=5, columns=2, focus=muEntry) } tDistributionPlot <- function(){ initializeDialog(title=gettextRcmdr("t Distribution")) dfVar <- tclVar("") dfEntry <- tkentry(top, width="6", textvariable=dfVar) functionVar <- tclVar("Density") densityButton <- tkradiobutton(top, variable=functionVar, value="Density") distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability") onOK <- function(){ closeDialog() df <- as.numeric(tclvalue(dfVar)) if (is.na(df)) { errorCondition(recall=tDistributionPlot, message=gettextRcmdr("Degrees of freedom not specified.")) return() } if (df<=0) { errorCondition(recall=tDistributionPlot, message=gettextRcmdr("Degrees of freedom must be positive.")) return() } fun <- tclvalue(functionVar) fn <- if (fun == "Density") "dt" else "pt" min <- round(qt(.0005, df=df), 3) max <- round(qt(.9995, df=df), 3) command <- paste("seq(", min, ", ", max, ", length=100)", sep="") logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(x11(),"plot(.x, ", fn, "(.x, df=", df, '), xlab="t", ylab="', fun, '", main="t Distribution: df = ', df, '", type="l")', sep="")) doItAndPrint('abline(h=0, col="gray")') remove(.x, envir=.GlobalEnv) logger("remove(.x)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dt") tkgrid(tklabel(top, text=gettextRcmdr("Degrees of freedom")), dfEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot density function")), densityButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot distribution function")), distributionButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(dfEntry, sticky="w") tkgrid.configure(densityButton, sticky="w") tkgrid.configure(distributionButton, sticky="w") dialogSuffix(rows=4, columns=2, focus=dfEntry) } chisquareDistributionPlot <- function(){ initializeDialog(title=gettextRcmdr("Chi-squared Distribution")) dfVar <- tclVar("") dfEntry <- tkentry(top, width="6", textvariable=dfVar) functionVar <- tclVar("Density") densityButton <- tkradiobutton(top, variable=functionVar, value="Density") distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability") onOK <- function(){ closeDialog() df <- as.numeric(tclvalue(dfVar)) if (is.na(df)) { errorCondition(recall=chisquareDistributionPlot,message=gettextRcmdr("Degrees of freedom not specified.")) return() } if (df<=0) { errorCondition(recall=chisquareDistributionPlot, message=gettextRcmdr("Degrees of freedom must be positive.")) return() } fun <- tclvalue(functionVar) fn <- if (fun == "Density") "dchisq" else "pchisq" min <- round(qchisq(.0005, df=df), 3) max <- round(qchisq(.9995, df=df), 3) command <- paste("seq(", min, ", ", max, ", length=100)", sep="") logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(x11(),"plot(.x, ", fn, "(.x, df=", df, '), xlab=expression(chi^2), ylab="', fun, '", main="Chi-Squared Distribution: df = ', df, '", type="l")', sep="")) doItAndPrint('abline(h=0, col="gray")') remove(.x, envir=.GlobalEnv) logger("remove(.x)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dchisq") tkgrid(tklabel(top, text=gettextRcmdr("Degrees of freedom")), dfEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot density function")), densityButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot distribution function")), distributionButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(dfEntry, sticky="w") tkgrid.configure(densityButton, sticky="w") tkgrid.configure(distributionButton, sticky="w") dialogSuffix(rows=4, columns=2, focus=dfEntry) } FDistributionPlot <- function(){ initializeDialog(title=gettextRcmdr("F Distribution")) df1Var <- tclVar("") df2Var <- tclVar("") df1Entry <- tkentry(top, width="6", textvariable=df1Var) df2Entry <- tkentry(top, width="6", textvariable=df2Var) functionVar <- tclVar("Density") densityButton <- tkradiobutton(top, variable=functionVar, value="Density") distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability") onOK <- function(){ closeDialog() df1 <- as.numeric(tclvalue(df1Var)) df2 <- as.numeric(tclvalue(df2Var)) if (is.na(df1)) { errorCondition(recall=FDistributionPlot, message=gettextRcmdr("Numerator degrees of freedom not specified.")) return() } if (is.na(df2)) { errorCondition(recall=FDistributionPlot, message=gettextRcmdr("Denominator degrees of freedom not specified.")) return() } if (df1 <= 0) { errorCondition(recall=FDistributionPlot, message=gettextRcmdr("Numerator degrees of freedom must be positive.")) return() } if (df2 <= 0) { errorCondition(recall=FDistributionPlot, message=gettextRcmdr("Denominator degrees of freedom must be positive.")) return() } fun <- tclvalue(functionVar) fn <- if (fun == "Density") "df" else "pf" min <- round(qf(.0005, df1=df1, df2=df2), 3) max <- round(qf(.9995, df1=df1, df2=df2), 3) command <- paste("seq(", min, ", ", max, ", length=100)", sep="") logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(x11(),"plot(.x, ", fn, "(.x, df1=", df1, ", df2=", df2, '), xlab="f", ylab="', fun, '", main="F Distribution: Numerator df = ', df1, ', Denominator df = ', df2, '", type="l")', sep="")) doItAndPrint('abline(h=0, col="gray")') remove(.x, envir=.GlobalEnv) logger("remove(.x)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="df") tkgrid(tklabel(top, text=gettextRcmdr("Numerator degrees of freedom")), df1Entry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Denominator degrees of freedom")), df2Entry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot density function")), densityButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot distribution function")), distributionButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(df1Entry, sticky="w") tkgrid.configure(df2Entry, sticky="w") tkgrid.configure(densityButton, sticky="w") tkgrid.configure(distributionButton, sticky="w") dialogSuffix(rows=5, columns=2, focus=df1Entry) } exponentialDistributionPlot <- function() { initializeDialog(title=gettextRcmdr("Exponential Distribution")) rateVar <- tclVar("1") rateEntry <- tkentry(top, width="6", textvariable=rateVar) functionVar <- tclVar("Density") densityButton <- tkradiobutton(top, variable=functionVar, value="Density") distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability") onOK <- function(){ closeDialog() rate <- as.numeric(tclvalue(rateVar)) if (is.na(rate) || rate <= 0) { errorCondition(recall=exponentialDistributionPlot, message=gettextRcmdr("Rate must be positive.")) return() } fun <- tclvalue(functionVar) fn <- if (fun == "Density") "dexp" else "pexp" min <- round(qexp(.0005, rate=rate), 3) max <- round(qexp(.9995, rate=rate), 3) command <- paste("seq(", min, ", ", max, ", length=100)", sep="") logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(x11(),"plot(.x, ", fn, "(.x, rate=", rate, '), xlab="x", ylab="', fun, '", main="Exponential Distribution: rate = ', rate, '", type="l")', sep="")) doItAndPrint('abline(h=0, col="gray")') remove(.x, envir=.GlobalEnv) logger("remove(.x)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dexp") tkgrid(tklabel(top, text=gettextRcmdr("Rate")), rateEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot density function")), densityButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot distribution function")), distributionButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(rateEntry, sticky="w") tkgrid.configure(densityButton, sticky="w") tkgrid.configure(distributionButton, sticky="w") dialogSuffix(rows=4, columns=2, focus=rateEntry) } uniformDistributionPlot <- function() { initializeDialog(title=gettextRcmdr("Uniform Distribution")) minVar <- tclVar("0") maxVar <- tclVar("1") minEntry <- tkentry(top, width="6", textvariable=minVar) maxEntry <- tkentry(top, width="6", textvariable=maxVar) functionVar <- tclVar("Density") densityButton <- tkradiobutton(top, variable=functionVar, value="Density") distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability") onOK <- function(){ closeDialog() minValue <- as.numeric(tclvalue(minVar)) maxValue <- as.numeric(tclvalue(maxVar)) if (is.na(minValue) || is.na(maxValue) || minValue >= maxValue) { errorCondition(recall=uniformDistributionPlot, message=gettextRcmdr("Lower limit must be less than upper limit.")) return() } fun <- tclvalue(functionVar) fn <- if (fun == "Density") "dunif" else "punif" min <- round(qunif(.0005, min=minValue, max=maxValue), 3) max <- round(qunif(.9995, min=minValue, max=maxValue), 3) command <- paste("seq(", min, ", ", max, ", length=100)", sep="") logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(x11(),"plot(.x, ", fn, "(.x, min=", minValue, ", max=", maxValue, '), xlab="x", ylab="', fun, '", main="Uniform Distribution: min=', minValue, ', max=', maxValue, '", type="l")', sep="")) doItAndPrint('abline(h=0, col="gray")') remove(.x, envir=.GlobalEnv) logger("remove(.x)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dunif") tkgrid(tklabel(top, text=gettextRcmdr("Minimum")), minEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Maximum")), maxEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot density function")), densityButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot distribution function")), distributionButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(minEntry, sticky="w") tkgrid.configure(maxEntry, sticky="w") tkgrid.configure(densityButton, sticky="w") tkgrid.configure(distributionButton, sticky="w") dialogSuffix(rows=4, columns=2, focus=minEntry) } betaDistributionPlot <- function(){ initializeDialog(title=gettextRcmdr("Beta Distribution")) shape1Var <- tclVar("") shape2Var <- tclVar("") shape1Entry <- tkentry(top, width="6", textvariable=shape1Var) shape2Entry <- tkentry(top, width="6", textvariable=shape2Var) functionVar <- tclVar("Density") densityButton <- tkradiobutton(top, variable=functionVar, value="Density") distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability") onOK <- function(){ closeDialog() shape1 <- as.numeric(tclvalue(shape1Var)) shape2 <- as.numeric(tclvalue(shape2Var)) if (is.na(shape1) || is.na(shape2)) { errorCondition(recall=betaDistributionPlot, message=gettextRcmdr("Shapes not specified.")) return() } if (shape1 <= 0 || shape2 <= 0) { errorCondition(recall=betaDistributionPlot, message=gettextRcmdr("Shapes must be positive.")) return() } fun <- tclvalue(functionVar) fn <- if (fun == "Density") "dbeta" else "pbeta" min <- round(qbeta(.0005, shape1=shape1, shape2=shape2), 3) max <- round(qbeta(.9995, shape1=shape1, shape2=shape2), 3) command <- paste("seq(", min, ", ", max, ", length=100)", sep="") logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(x11(),"plot(.x, ", fn, "(.x, shape1=", shape1, ", shape2=", shape2, '), xlab="x", ylab="', fun, '", main="Beta Distribution: Shapes a = ', shape1, ', b = ', shape2, '", type="l")', sep="")) doItAndPrint('abline(h=0, col="gray")') remove(.x, envir=.GlobalEnv) logger("remove(.x)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dbeta") tkgrid(tklabel(top, text=paste(gettextRcmdr("Shape"), "1")), shape1Entry, sticky="e") tkgrid(tklabel(top, text=paste(gettextRcmdr("Shape"), 2)), shape2Entry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot density function")), densityButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot distribution function")), distributionButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(shape1Entry, sticky="w") tkgrid.configure(shape2Entry, sticky="w") tkgrid.configure(densityButton, sticky="w") tkgrid.configure(distributionButton, sticky="w") dialogSuffix(rows=5, columns=2, focus=shape1Entry) } CauchyDistributionPlot <- function(){ initializeDialog(title=gettextRcmdr("Cauchy Distribution")) locationVar <- tclVar("0") locationEntry <- tkentry(top, width="6", textvariable=locationVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) functionVar <- tclVar("Density") densityButton <- tkradiobutton(top, variable=functionVar, value="Density") distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability") onOK <- function(){ closeDialog() location <- as.numeric(tclvalue(locationVar)) s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=CauchyDistributionPlot, message=gettextRcmdr("Scale must be positive.")) return() } fun <- tclvalue(functionVar) fn <- if (fun == "Density") "dcauchy" else "pcauchy" min <- round(qcauchy(.01, location=location, scale=s), 3) max <- round(qcauchy(.99, location=location, scale=s), 3) command <- paste("seq(", min, ", ", max, ", length=100)", sep="") logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(x11(),"plot(.x, ", fn, "(.x, location=", location, ", scale=", s, '), xlab="x", ylab="', fun, '", main="Cauchy Distribution: location = ', location, ', scale = ', s, '", type="l")', sep="")) doItAndPrint('abline(h=0, col="gray")') remove(.x, envir=.GlobalEnv) logger("remove(.x)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dcauchy") tkgrid(tklabel(top, text=gettextRcmdr("Location")), locationEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Scale")), sEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot density function")), densityButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot distribution function")), distributionButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(locationEntry, sticky="w") tkgrid.configure(sEntry, sticky="w") tkgrid.configure(densityButton, sticky="w") tkgrid.configure(distributionButton, sticky="w") dialogSuffix(rows=5, columns=2, focus=locationEntry) } logisticDistributionPlot <- function(){ initializeDialog(title=gettextRcmdr("Logistic Distribution")) locationVar <- tclVar("0") locationEntry <- tkentry(top, width="6", textvariable=locationVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) functionVar <- tclVar("Density") densityButton <- tkradiobutton(top, variable=functionVar, value="Density") distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability") onOK <- function(){ closeDialog() location <- as.numeric(tclvalue(locationVar)) s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=logisticDistributionPlot, message=gettextRcmdr("Scale must be positive.")) return() } fun <- tclvalue(functionVar) fn <- if (fun == "Density") "dlogis" else "plogis" min <- round(qlogis(.0005, location=location, scale=s), 3) max <- round(qlogis(.9995, location=location, scale=s), 3) command <- paste("seq(", min, ", ", max, ", length=100)", sep="") logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(x11(),"plot(.x, ", fn, "(.x, location=", location, ", scale=", s, '), xlab="x", ylab="', fun, '", main="Logistic Distribution: location = ', location, ', scale = ', s, '", type="l")', sep="")) doItAndPrint('abline(h=0, col="gray")') remove(.x, envir=.GlobalEnv) logger("remove(.x)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dlogis") tkgrid(tklabel(top, text=gettextRcmdr("Location")), locationEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Scale")), sEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot density function")), densityButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot distribution function")), distributionButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(locationEntry, sticky="w") tkgrid.configure(sEntry, sticky="w") tkgrid.configure(densityButton, sticky="w") tkgrid.configure(distributionButton, sticky="w") dialogSuffix(rows=5, columns=2, focus=locationEntry) } lognormalDistributionPlot <- function(){ initializeDialog(title=gettextRcmdr("Lognormal Distribution")) meanlogVar <- tclVar("0") meanlogEntry <- tkentry(top, width="6", textvariable=meanlogVar) sdlogVar <- tclVar("1") sdlogEntry <- tkentry(top, width="6", textvariable=sdlogVar) functionVar <- tclVar("Density") densityButton <- tkradiobutton(top, variable=functionVar, value="Density") distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability") onOK <- function(){ closeDialog() meanlog <- as.numeric(tclvalue(meanlogVar)) sdlog <- as.numeric(tclvalue(sdlogVar)) if (is.na(sdlog) || sdlog <= 0) { errorCondition(recall=lognormalDistributionPlot, message=gettextRcmdr("Standard deviation must be positive.")) return() } fun <- tclvalue(functionVar) fn <- if (fun == "Density") "dlnorm" else "plnorm" min <- round(qlnorm(.0005, meanlog=meanlog, sdlog=sdlog), 3) max <- round(qlnorm(.9995, meanlog=meanlog, sdlog=sdlog), 3) command <- paste("seq(", min, ", ", max, ", length=100)", sep="") logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(x11(),"plot(.x, ", fn, "(.x, meanlog=", meanlog, ", sdlog=", sdlog, '), xlab="x", ylab="', fun, '", main="Lognormal Distribution: Mean (log scale) = ', meanlog, ', SD (log scale) = ', sdlog, '", type="l")', sep="")) doItAndPrint('abline(h=0, col="gray")') remove(.x, envir=.GlobalEnv) logger("remove(.x)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dlnorm") tkgrid(tklabel(top, text=gettextRcmdr("Mean (log scale)")), meanlogEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Standard deviation (log scale)")), sdlogEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot density function")), densityButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot distribution function")), distributionButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(meanlogEntry, sticky="w") tkgrid.configure(sdlogEntry, sticky="w") tkgrid.configure(densityButton, sticky="w") tkgrid.configure(distributionButton, sticky="w") dialogSuffix(rows=5, columns=2, focus=meanlogEntry) } gammaDistributionPlot <- function(){ initializeDialog(title=gettextRcmdr("Gamma Distribution")) shapeVar <- tclVar("") shapeEntry <- tkentry(top, width="6", textvariable=shapeVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) functionVar <- tclVar("Density") densityButton <- tkradiobutton(top, variable=functionVar, value="Density") distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability") onOK <- function(){ closeDialog() shape <- as.numeric(tclvalue(shapeVar)) if (is.na(shape)) { errorCondition(recall=gammaDistributionPlot, message=gettextRcmdr("Shape not specified.")) return() } if (shape <= 0) { errorCondition(recall=gammaDistributionPlot, message=gettextRcmdr("Shape must be positive.")) return() } s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=gammaDistributionPlot, message=gettextRcmdr("Scale must be positive.")) return() } fun <- tclvalue(functionVar) fn <- if (fun == "Density") "dgamma" else "pgamma" min <- round(qgamma(.0005, shape=shape, scale=s), 3) max <- round(qgamma(.9995, shape=shape, scale=s), 3) command <- paste("seq(", min, ", ", max, ", length=100)", sep="") logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(x11(),"plot(.x, ", fn, "(.x, shape=", shape, ", scale=", s, '), xlab="x", ylab="', fun, '", main="Gamma Distribution: shape = ', shape, ', scale = ', s, '", type="l")', sep="")) doItAndPrint('abline(h=0, col="gray")') remove(.x, envir=.GlobalEnv) logger("remove(.x)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dgamma") tkgrid(tklabel(top, text=gettextRcmdr("Shape")), shapeEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Scale (inverse rate)")), sEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot density function")), densityButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot distribution function")), distributionButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(shapeEntry, sticky="w") tkgrid.configure(sEntry, sticky="w") tkgrid.configure(densityButton, sticky="w") tkgrid.configure(distributionButton, sticky="w") dialogSuffix(rows=5, columns=2, focus=shapeEntry) } WeibullDistributionPlot <- function(){ initializeDialog(title=gettextRcmdr("Weibull Distribution")) shapeVar <- tclVar("") shapeEntry <- tkentry(top, width="6", textvariable=shapeVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) functionVar <- tclVar("Density") densityButton <- tkradiobutton(top, variable=functionVar, value="Density") distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability") onOK <- function(){ closeDialog() shape <- as.numeric(tclvalue(shapeVar)) if (is.na(shape)) { errorCondition(recall=WeibullDistributionPlot, message=gettextRcmdr("Shape not specified.")) return() } if (shape <= 0) { errorCondition(recall=WeibullDistributionPlot, message=gettextRcmdr("Shape must be positive.")) return() } s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=WeibullDistributionPlot, message=gettextRcmdr("Scale must be positive.")) return() } fun <- tclvalue(functionVar) fn <- if (fun == "Density") "dweibull" else "pweibull" min <- round(qweibull(.0005, shape=shape, scale=s), 3) max <- round(qweibull(.9995, shape=shape, scale=s), 3) command <- paste("seq(", min, ", ", max, ", length=100)", sep="") logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(x11(),"plot(.x, ", fn, "(.x, shape=", shape, ", scale=", s, '), xlab="x", ylab="', fun, '", main="Weibull Distribution: shape = ', shape, ', scale = ', s, '", type="l")', sep="")) doItAndPrint('abline(h=0, col="gray")') remove(.x, envir=.GlobalEnv) logger("remove(.x)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dweibull") tkgrid(tklabel(top, text=gettextRcmdr("Shape")), shapeEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Scale")), sEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot density function")), densityButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot distribution function")), distributionButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(shapeEntry, sticky="w") tkgrid.configure(sEntry, sticky="w") tkgrid.configure(densityButton, sticky="w") tkgrid.configure(distributionButton, sticky="w") dialogSuffix(rows=5, columns=2, focus=shapeEntry) } GumbelDistributionPlot <- function(){ initializeDialog(title=gettextRcmdr("Gumbel Distribution")) shapeVar <- tclVar("") shapeEntry <- tkentry(top, width="6", textvariable=shapeVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) functionVar <- tclVar("Density") densityButton <- tkradiobutton(top, variable=functionVar, value="Density") distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability") onOK <- function(){ closeDialog() shape <- as.numeric(tclvalue(shapeVar)) if (is.na(shape)) { errorCondition(recall=GumbelDistributionPlot, message=gettextRcmdr("Shape not specified.")) return() } if (shape <= 0) { errorCondition(recall=GumbelDistributionPlot, message=gettextRcmdr("Shape must be positive.")) return() } s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=GumbelDistributionPlot, message=gettextRcmdr("Scale must be positive.")) return() } fun <- tclvalue(functionVar) fn <- if (fun == "Density") "dweibull" else "pweibull" min <- round(log(qweibull(.0005, shape=shape, scale=s)), 3) max <- round(log(qweibull(.9995, shape=shape, scale=s)), 3) command <- paste("exp(seq(", min, ", ", max, ", length=100))", sep="") logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(x11(),"plot(log(.x), ", fn, "(.x, shape=", shape, ", scale=", s, '), xlab="x", ylab="', fun, '", main="Gumbel Distribution: shape (log scale) = ', shape, ', scale (log scale) = ', s, '", type="l")', sep="")) doItAndPrint('abline(h=0, col="gray")') remove(.x, envir=.GlobalEnv) logger("remove(.x)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dweibull") tkgrid(tklabel(top, text=gettextRcmdr("Shape (log shape)")), shapeEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Scale (log scale)")), sEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot density function")), densityButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot distribution function")), distributionButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(shapeEntry, sticky="w") tkgrid.configure(sEntry, sticky="w") tkgrid.configure(densityButton, sticky="w") tkgrid.configure(distributionButton, sticky="w") dialogSuffix(rows=5, columns=2, focus=shapeEntry) } binomialDistributionPlot <- function(){ initializeDialog(title=gettextRcmdr("Binomial Distribution")) trialsVar <- tclVar("") trialsEntry <- tkentry(top, width="6", textvariable=trialsVar) probVar <- tclVar(".5") probEntry <- tkentry(top, width="6", textvariable=probVar) functionVar <- tclVar("Probability") densityButton <- tkradiobutton(top, variable=functionVar, value="Probability") distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability") onOK <- function(){ closeDialog() trials <- round(as.numeric(tclvalue(trialsVar))) if (is.na(trials)) { errorCondition(recall=binomialDistributionPlot, message=gettextRcmdr("Binomial trials not specified.")) return() } prob <- as.numeric(tclvalue(probVar)) if (is.na(prob)) { errorCondition(recall=binomialDistributionPlot, message=gettextRcmdr("Probability of success not specified.")) return() } fun <- tclvalue(functionVar) min <- qbinom(.0005, size=trials, prob=prob) max <- qbinom(.9995, size=trials, prob=prob) command <- paste(min, ":", max, sep="") logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) if (fun == "Probability"){ doItAndPrint(paste(x11(),"plot(.x, dbinom(.x, size=", trials, ", prob=", prob, '), xlab="Number of Successes", ylab="Probability Mass", main="Binomial Distribution: Trials = ', trials, ', Probability of success = ', prob, '", type="h")', sep="")) doItAndPrint(paste("points(.x, dbinom(.x, size=", trials, ", prob=", prob, '), pch=16)', sep="")) } else { command <- "rep(.x, rep(2, length(.x)))" logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(x11(),"plot(.x[-1], pbinom(.x, size=", trials, ", prob=", prob, ')[-length(.x)], xlab="Number of Successes", ylab="Cumulative Probability", main="Binomial Distribution: Trials = ', trials, ', Probability of success = ', prob, '", type="l")', sep="")) } doItAndPrint('abline(h=0, col="gray")') remove(.x, envir=.GlobalEnv) logger("remove(.x)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dbinom") tkgrid(tklabel(top, text=gettextRcmdr("Binomial trials")), trialsEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Probability of success")), probEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot probability mass function")), densityButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot distribution function")), distributionButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(trialsEntry, sticky="w") tkgrid.configure(probEntry, sticky="w") tkgrid.configure(densityButton, sticky="w") tkgrid.configure(distributionButton, sticky="w") dialogSuffix(rows=5, columns=2, focus=trialsEntry) } PoissonDistributionPlot <- function(){ initializeDialog(title=gettextRcmdr("Poisson Distribution")) meanVar <- tclVar("") meanEntry <- tkentry(top, width="6", textvariable=meanVar) functionVar <- tclVar("Probability") densityButton <- tkradiobutton(top, variable=functionVar, value="Probability") distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability") onOK <- function(){ closeDialog() mean <- as.numeric(tclvalue(meanVar)) if (is.na(mean)) { errorCondition(recall=PoissonDistributionPlot, message=gettextRcmdr("Mean not specified.")) return() } if (mean < 0) { errorCondition(recall=PoissonDistributionPlot, message=gettextRcmdr("Poisson mean cannot be negative.")) return() } fun <- tclvalue(functionVar) min <- qpois(.0005, lambda=mean) max <- qpois(.9995, lambda=mean) command <- paste(min, ":", max, sep="") logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) if (fun == "Probability"){ doItAndPrint(paste(x11(),"plot(.x, dpois(.x, lambda=", mean, '), xlab="x", ylab="Probability Mass", main="Poisson Distribution: Mean = ', mean, '", type="h")', sep="")) doItAndPrint(paste("points(.x, dpois(.x, lambda=", mean, '), pch=16)', sep="")) } else { command <- "rep(.x, rep(2, length(.x)))" logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(x11(),"plot(.x[-1], ppois(.x, lambda=", mean, ')[-length(.x)], xlab="x", ylab="Probability Mass", main="Poisson Distribution: Mean = ', mean, '", type="l")', sep="")) } doItAndPrint('abline(h=0, col="gray")') remove(.x, envir=.GlobalEnv) logger("remove(.x)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dpois") tkgrid(tklabel(top, text=gettextRcmdr("Mean")), meanEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot probability mass function")), densityButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot distribution function")), distributionButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(meanEntry, sticky="w") tkgrid.configure(densityButton, sticky="w") tkgrid.configure(distributionButton, sticky="w") dialogSuffix(rows=4, columns=2, focus=meanEntry) } # the following functions were contributed by G. Jay Kerns, Andy Chang, and Theophilius Boye # last modified 26 July 06 by J. Fox geomDistributionPlot <- function(){ initializeDialog(title=gettextRcmdr("Geometric Distribution")) probVar <- tclVar("0.5") probEntry <- tkentry(top, width="6", textvariable=probVar) functionVar <- tclVar("Probability") densityButton <- tkradiobutton(top, variable=functionVar, value="Probability") distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability") onOK <- function(){ closeDialog() prob <- as.numeric(tclvalue(probVar)) if ( is.na(prob) ) { errorCondition(recall=geomDistributionPlot, message=gettextRcmdr("Probability of success was not specified.")) return() } if (prob < 0 || prob > 1) { errorCondition(recall=geomDistributionPlot, message=gettextRcmdr("Probability of success must be between 0 and 1.")) return() } fun <- tclvalue(functionVar) xmin <- qgeom(.0005, prob=prob) xmax <- qgeom(.9995, prob=prob) command <- paste(xmin, ":", xmax, sep="") logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) if (fun == "Probability"){ doItAndPrint(paste(x11(),"plot(.x, dgeom(.x, prob=", prob, '), xlab="Number of Failures until Success", ylab="Probability Mass", main="Geometric Distribution: Prob of success = ', prob, '", type="h")', sep="")) doItAndPrint(paste("points(.x, dgeom(.x, prob=", prob, '), pch=16)', sep="")) } else { command <- "rep(.x, rep(2, length(.x)))" logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(x11(),"plot(.x[-1], pgeom(.x, prob=", prob, ')[-length(.x)], xlab="Number of Failures until Success", ylab="Cumulative Probability", main="Geometric Distribution: Probability of success = ', prob, '", type="l")', sep="")) } doItAndPrint('abline(h=0, col="gray")') remove(.x, envir=.GlobalEnv) logger("remove(.x)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dgeom") tkgrid(tklabel(top, text=gettextRcmdr("Probability of success")), probEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot probability mass function")), densityButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot distribution function")), distributionButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(probEntry, sticky="w") tkgrid.configure(densityButton, sticky="w") tkgrid.configure(distributionButton, sticky="w") dialogSuffix(rows=5, columns=2, focus=probEntry) } hyperDistributionPlot <- function(){ initializeDialog(title=gettextRcmdr("Hypergeometric Distribution")) mVar <- tclVar("1") mEntry <- tkentry(top, width="6", textvariable=mVar) nVar <- tclVar("1") nEntry <- tkentry(top, width="6", textvariable=nVar) kVar <- tclVar("1") kEntry <- tkentry(top, width="6", textvariable=kVar) functionVar <- tclVar("Probability") densityButton <- tkradiobutton(top, variable=functionVar, value="Probability") distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability") onOK <- function(){ closeDialog() m <- as.numeric(tclvalue(mVar)) n <- as.numeric(tclvalue(nVar)) k <- as.numeric(tclvalue(kVar)) fun <- tclvalue(functionVar) # Do some error checking if ( is.na(m) ){ errorCondition(recall=hyperDistributionPlot, message=gettextRcmdr("The m parameter was not specified.")) return() } if ( m < 0 ){ errorCondition(recall=hyperDistributionPlot, message=gettextRcmdr("The m parameter cannot be negative.")) return() } m <- round(m) if ( is.na(n) ){ errorCondition(recall=hyperDistributionPlot, message=gettextRcmdr("The n parameter was not specified.")) return() } if ( n < 0 ){ errorCondition(recall=hyperDistributionPlot, message=gettextRcmdr("The n parameter cannot be negative.")) return() } n <- round(n) if ( is.na(k) ){ errorCondition(recall=hyperDistributionPlot, message=gettextRcmdr("The k parameter was not specified.")) return() } k <- round(k) if ( k > (m + n) ){ errorCondition(recall=hyperDistributionPlot, message=gettextRcmdr("The k parameter cannot be greater than m + n.")) return() } if ( k < 0 ){ errorCondition(recall=hyperDistributionPlot, message=gettextRcmdr("The k parameter cannot be negative.")) return() } xmin <- qhyper(.0005, m=m, n=n, k=k) xmax <- qhyper(.9995, m=m, n=n, k=k) command <- paste(xmin, ":", xmax, sep="") logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) if (fun == "Probability"){ doItAndPrint(paste(x11(),"plot(.x, dhyper(.x, m=", m, ", n=", n, ", k=", k, '), xlab="Number of White Balls in Sample", ylab="Probability Mass", main="Hypergeometric Distribution: m=', m, ", n=", n, ", k=", k, '", type="h")', sep="")) doItAndPrint(paste("points(.x, dhyper(.x, m=", m, ", n=", n, ", k=", k, '), pch=16)', sep="")) } else { command <- "rep(.x, rep(2, length(.x)))" logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(x11(),"plot(.x[-1], phyper(.x, m=", m, ", n=", n, ", k=", k, ')[-length(.x)], xlab="Number of White Balls in Sample", ylab="Cumulative Probability", main="Hypergeometric Distribution: m=', m, ", n=", n, ", k=", k, '", type="l")', sep="")) } doItAndPrint('abline(h=0, col="gray")') remove(.x, envir=.GlobalEnv) logger("remove(.x)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dhyper") tkgrid(tklabel(top, text=gettextRcmdr("m (number of white balls in the urn)")), mEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("n (number of black balls in the urn)")), nEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("k (number of balls drawn from the urn)")), kEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot probability mass function")), densityButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot distribution function")), distributionButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(mEntry, sticky="w") tkgrid.configure(nEntry, sticky="w") tkgrid.configure(kEntry, sticky="w") tkgrid.configure(densityButton, sticky="w") tkgrid.configure(distributionButton, sticky="w") dialogSuffix(rows=6, columns=2, focus=mEntry) } negbinomialDistributionPlot <- function(){ initializeDialog(title=gettextRcmdr("Negative Binomial Distribution")) trialsVar <- tclVar("1") trialsEntry <- tkentry(top, width="6", textvariable=trialsVar) probVar <- tclVar("0.5") probEntry <- tkentry(top, width="6", textvariable=probVar) functionVar <- tclVar("Probability") densityButton <- tkradiobutton(top, variable=functionVar, value="Probability") distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability") onOK <- function(){ closeDialog() trials <- as.numeric(tclvalue(trialsVar)) if ( is.na(trials) ){ errorCondition(recall=negbinomialDistributionPlot, message=gettextRcmdr("Target number of successes not specified.")) return() } if ( trials < 0){ errorCondition(recall=negbinomialDistributionPlot, message=gettextRcmdr("Target number of successes cannot be negative.")) return() } trials <- round(trials) prob <- as.numeric(tclvalue(probVar)) if ( is.na(prob) ){ errorCondition(recall=negbinomialDistributionPlot, message=gettextRcmdr("Probability of success not specified.")) return() } if (prob < 0 || prob > 1) { errorCondition(recall=negbinomialDistributionPlot, message=gettextRcmdr("Probability of success must be between 0 and 1.")) return() } xmin <- qnbinom(.0005, size=trials, prob=prob) xmax <- qnbinom(.9995, size=trials, prob=prob) logger(paste(".x <- ", xmin, ":", xmax, sep="")) assign(".x", justDoIt(paste(".x <- ", xmin, ":", xmax, sep="")), envir=.GlobalEnv) fun <- tclvalue(functionVar) if (fun == "Probability"){ doItAndPrint(paste(x11(),"plot(.x, dnbinom(.x, size=", trials, ", prob=", prob, '), xlab="Number of Failures Until Target Successes", ylab="Probability Mass", main=', paste('"Negative Binomial Distribution:\\nTarget successes = ', trials, ', Probability of success = ', prob, '"', sep=""), ', type="h")', sep="")) doItAndPrint(paste("points(.x, dnbinom(.x, size=", trials, ", prob=", prob, '), pch=16)', sep="")) } else { command <- "rep(.x, rep(2, length(.x)))" logger(paste(".x <- ", command, sep="")) assign(".x", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(x11(),"plot(.x[-1], pnbinom(.x, size=", trials, ", prob=", prob, ')[-length(.x)], xlab="Number of Failures Until Target Successes", ylab="Cumulative Probability", main=', paste('"Negative Binomial Distribution:\\nTarget successes = ',trials, ', Probability of success = ', prob, '"', sep=""), ', type="l")', sep="")) } doItAndPrint('abline(h=0, col="gray")') remove(.x, envir=.GlobalEnv) logger("remove(.x)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dnbinom") tkgrid(tklabel(top, text=gettextRcmdr("Target number of successes")), trialsEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Probability of success")), probEntry, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot probability mass function")), densityButton, sticky="e") tkgrid(tklabel(top, text=gettextRcmdr("Plot distribution function")), distributionButton, sticky="e") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(trialsEntry, sticky="w") tkgrid.configure(probEntry, sticky="w") tkgrid.configure(densityButton, sticky="w") tkgrid.configure(distributionButton, sticky="w") dialogSuffix(rows=5, columns=2, focus=trialsEntry) } # Distributions menu dialogs for selecting samples # last modified 26 July 06 by J. Fox normalDistributionSamples <- function(){ initializeDialog(title=gettextRcmdr("Sample from Normal Distribution")) dsname <- tclVar(gettextRcmdr("NormalSamples")) dsFrame <- tkframe(top) entryDsname <- tkentry(dsFrame, width="20", textvariable=dsname) muVar <- tclVar("0") muEntry <- tkentry(top, width="6", textvariable=muVar) sigmaVar <- tclVar("1") sigmaEntry <- tkentry(top, width="6", textvariable=sigmaVar) nVar <- tclVar("100") nEntry <- tkentry(top, width="6", textvariable=nVar) samplesVar <- tclVar("1") samplesEntry <- tkentry(top, width="6", textvariable=samplesVar) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sum", "sd"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Sample means", "Sample sums", "Sample standard deviations"))) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=normalDistributionSamples, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=normalDistributionSamples, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ normalDistributionSamples() return() } } mu <- as.numeric(tclvalue(muVar)) sigma <- as.numeric(tclvalue(sigmaVar)) n <- as.numeric(tclvalue(nVar)) samples <- as.numeric(tclvalue(samplesVar)) if (is.na(sigma) || sigma <= 0) { errorCondition(recall=normalDistributionSamples, message=gettextRcmdr("Standard deviation must be positive.")) return() } if (is.na(n) || n <= 0) { errorCondition(recall=normalDistributionSamples, message=gettextRcmdr("Sample size must be positive.")) return() } if (is.na(samples) || samples <= 0) { errorCondition(recall=normalDistributionSamples, message=gettextRcmdr("Number of samples must be positive.")) return() } command <- paste(dsnameValue, " <- as.data.frame(matrix(rnorm(", samples, "*", n, ", mean=", mu, ", sd=", sigma, "), ncol=", n, "))", sep="") justDoIt(command) logger(command) command <- if (samples == 1) paste("rownames(", dsnameValue, ') <- "sample"', sep="") else paste("rownames(", dsnameValue, ') <- paste("sample", 1:', samples, ', sep="")', sep="") justDoIt(command) logger(command) command <- if (n == 1) paste("colnames(", dsnameValue, ') <- "obs"', sep="") else paste("colnames(", dsnameValue, ') <- paste("obs", 1:', n, ', sep="")', sep="") justDoIt(command) logger(command) if (tclvalue(meanVariable) == "1") { command <- paste(dsnameValue, "$mean <- rowMeans(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sumVariable) == "1") { command <- paste(dsnameValue, "$sum <- rowSums(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sdVariable) == "1") { command <- paste(dsnameValue, "$sd <- apply(", dsnameValue, "[,1:", n, "], 1, sd)", sep="") justDoIt(command) logger(command) } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="rnorm") tkgrid(tklabel(dsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(dsFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("mu (mean)")), muEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("sigma (standard deviation)")), sigmaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of samples (rows) ")), samplesEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of observations (columns) ")), nEntry, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Add to Data Set:"), fg="blue"), sticky="w") tkgrid(checkBoxFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=10, columns=2, focus=muEntry) } # --- t distribution tDistributionSamples <- function(){ initializeDialog(title=gettextRcmdr("Sample from t Distribution")) dsname <- tclVar(gettextRcmdr("tSamples")) dsFrame <- tkframe(top) entryDsname <- tkentry(dsFrame, width="20", textvariable=dsname) dfVar <- tclVar("") dfEntry <- tkentry(top, width="6", textvariable=dfVar) nVar <- tclVar("100") nEntry <- tkentry(top, width="6", textvariable=nVar) samplesVar <- tclVar("1") samplesEntry <- tkentry(top, width="6", textvariable=samplesVar) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sum", "sd"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Sample means", "Sample sums", "Sample standard deviations"))) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=tDistributionSamples, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=tDistributionSamples, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ tDistributionSamples() return() } } df <- as.numeric(tclvalue(dfVar)) if (is.na(df)) { errorCondition(recall=tDistributionSamples, message=gettextRcmdr("Degrees of freedom not specified.")) return() } if (df<=0) { errorCondition(recall=tDistributionSamples, message=gettextRcmdr("Degrees of freedom must be positive.")) return() } n <- as.numeric(tclvalue(nVar)) samples <- as.numeric(tclvalue(samplesVar)) if (is.na(n) || n <= 0) { errorCondition(recall=tDistributionSamples, message=gettextRcmdr("Sample size must be positive.")) return() } if (is.na(samples) || samples <= 0) { errorCondition(recall=tDistributionSamples, message=gettextRcmdr("Number of samples must be positive.")) return() } command <- paste(dsnameValue, " <- as.data.frame(matrix(rt(", samples, "*", n, ", df=", df, "), ncol=", n, "))", sep="") justDoIt(command) logger(command) command <- if (samples == 1) paste("rownames(", dsnameValue, ') <- "sample"', sep="") else paste("rownames(", dsnameValue, ') <- paste("sample", 1:', samples, ', sep="")', sep="") justDoIt(command) logger(command) command <- if (n == 1) paste("colnames(", dsnameValue, ') <- "obs"', sep="") else paste("colnames(", dsnameValue, ') <- paste("obs", 1:', n, ', sep="")', sep="") justDoIt(command) logger(command) if (tclvalue(meanVariable) == "1") { command <- paste(dsnameValue, "$mean <- rowMeans(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sumVariable) == "1") { command <- paste(dsnameValue, "$sum <- rowSums(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sdVariable) == "1") { command <- paste(dsnameValue, "$sd <- apply(", dsnameValue, "[,1:", n, "], 1, sd)", sep="") justDoIt(command) logger(command) } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="rt") tkgrid(tklabel(dsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(dsFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Degrees of freedom")), dfEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of samples (rows) ")), samplesEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of observations (columns) ")), nEntry, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Add to Data Set:"), fg="blue"), sticky="w") tkgrid(checkBoxFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=10, columns=2, focus=dfEntry) } # ------- chisquare distribution chisquareDistributionSamples <- function(){ initializeDialog(title=gettextRcmdr("Sample from Chi-squared Distribution")) dsname <- tclVar(gettextRcmdr("ChisquareSamples")) dsFrame <- tkframe(top) entryDsname <- tkentry(dsFrame, width="20", textvariable=dsname) dfVar <- tclVar("") dfEntry <- tkentry(top, width="6", textvariable=dfVar) nVar <- tclVar("100") nEntry <- tkentry(top, width="6", textvariable=nVar) samplesVar <- tclVar("1") samplesEntry <- tkentry(top, width="6", textvariable=samplesVar) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sum", "sd"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Sample means", "Sample sums", "Sample standard deviations"))) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=chisquareDistributionSamples, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=chisquareDistributionSamples, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ chisquareDistributionSamples() return() } } df <- as.numeric(tclvalue(dfVar)) if (is.na(df)) { errorCondition(recall=chisquareDistributionSamples, message=gettextRcmdr("Degrees of freedom not specified.")) return() } if (df<=0) { errorCondition(recall=chisquareDistributionSamples, message=gettextRcmdr("Degrees of freedom must be positive.")) return() } n <- as.numeric(tclvalue(nVar)) samples <- as.numeric(tclvalue(samplesVar)) if (is.na(n) || n <= 0) { errorCondition(recall=chisquareDistributionSamples, message=gettextRcmdr("Sample size must be positive.")) return() } if (is.na(samples) || samples <= 0) { errorCondition(recall=chisquareDistributionSamples, message=gettextRcmdr("Number of samples must be positive.")) return() } command <- paste(dsnameValue, " <- as.data.frame(matrix(rchisq(", samples, "*", n, ", df=", df, "), ncol=", n, "))", sep="") justDoIt(command) logger(command) command <- if (samples == 1) paste("rownames(", dsnameValue, ') <- "sample"', sep="") else paste("rownames(", dsnameValue, ') <- paste("sample", 1:', samples, ', sep="")', sep="") justDoIt(command) logger(command) command <- if (n == 1) paste("colnames(", dsnameValue, ') <- "obs"', sep="") else paste("colnames(", dsnameValue, ') <- paste("obs", 1:', n, ', sep="")', sep="") justDoIt(command) logger(command) if (tclvalue(meanVariable) == "1") { command <- paste(dsnameValue, "$mean <- rowMeans(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sumVariable) == "1") { command <- paste(dsnameValue, "$sum <- rowSums(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sdVariable) == "1") { command <- paste(dsnameValue, "$sd <- apply(", dsnameValue, "[,1:", n, "], 1, sd)", sep="") justDoIt(command) logger(command) } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="rchisq") tkgrid(tklabel(dsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(dsFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Degrees of freedom")), dfEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of samples (rows) ")), samplesEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of observations (columns) ")), nEntry, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Add to Data Set:"), fg="blue"), sticky="w") tkgrid(checkBoxFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=10, columns=2, focus=dfEntry) } # ------ F-distribution FDistributionSamples <- function(){ initializeDialog(title=gettextRcmdr("Sample from F Distribution")) dsname <- tclVar(gettextRcmdr("FSamples")) dsFrame <- tkframe(top) entryDsname <- tkentry(dsFrame, width="20", textvariable=dsname) df1Var <- tclVar("") df2Var <- tclVar("") df1Entry <- tkentry(top, width="6", textvariable=df1Var) df2Entry <- tkentry(top, width="6", textvariable=df2Var) nVar <- tclVar("100") nEntry <- tkentry(top, width="6", textvariable=nVar) samplesVar <- tclVar("1") samplesEntry <- tkentry(top, width="6", textvariable=samplesVar) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sum", "sd"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Sample means", "Sample sums", "Sample standard deviations"))) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=FDistributionSamples, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=FDistributionSamples, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ FDistributionSamples() return() } } df1 <- as.numeric(tclvalue(df1Var)) df2 <- as.numeric(tclvalue(df2Var)) if (is.na(df1)) { errorCondition(recall=FDistributionSamples, message=gettextRcmdr("Numerator degrees of freedom not specified.")) return() } if (is.na(df2)) { errorCondition(recall=FDistributionSamples, message=gettextRcmdr("Denominator degrees of freedom not specified.")) return() } if (df1 <= 0) { errorCondition(recall=FDistributionSamples, message=gettextRcmdr("Numerator degrees of freedom must be positive.")) return() } if (df2 <= 0) { errorCondition(recall=FDistributionSamples, message=gettextRcmdr("Denominator degrees of freedom must be positive.")) return() } n <- as.numeric(tclvalue(nVar)) samples <- as.numeric(tclvalue(samplesVar)) if (is.na(n) || n <= 0) { errorCondition(recall=FDistributionSamples, message=gettextRcmdr("Sample size must be positive.")) return() } if (is.na(samples) || samples <= 0) { errorCondition(recall=FDistributionSamples, message=gettextRcmdr("Number of samples must be positive.")) return() } command <- paste(dsnameValue, " <- as.data.frame(matrix(rf(", samples, "*", n, ", df1=", df1, ", df2=", df2, "), ncol=", n, "))", sep="") justDoIt(command) logger(command) command <- if (samples == 1) paste("rownames(", dsnameValue, ') <- "sample"', sep="") else paste("rownames(", dsnameValue, ') <- paste("sample", 1:', samples, ', sep="")', sep="") justDoIt(command) logger(command) command <- if (n == 1) paste("colnames(", dsnameValue, ') <- "obs"', sep="") else paste("colnames(", dsnameValue, ') <- paste("obs", 1:', n, ', sep="")', sep="") justDoIt(command) logger(command) if (tclvalue(meanVariable) == "1") { command <- paste(dsnameValue, "$mean <- rowMeans(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sumVariable) == "1") { command <- paste(dsnameValue, "$sum <- rowSums(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sdVariable) == "1") { command <- paste(dsnameValue, "$sd <- apply(", dsnameValue, "[,1:", n, "], 1, sd)", sep="") justDoIt(command) logger(command) } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="rf") tkgrid(tklabel(dsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(dsFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Numerator degrees of freedom")), df1Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Denominator degrees of freedom")), df2Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of samples (rows) ")), samplesEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of observations (columns) ")), nEntry, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Add to Data Set:"), fg="blue"), sticky="w") tkgrid(checkBoxFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=11, columns=2, focus=df1Entry) } # ----- exponential distribution exponentialDistributionSamples <- function(){ initializeDialog(title=gettextRcmdr("Sample from Exponential Distribution")) dsname <- tclVar(gettextRcmdr("ExponentialSamples")) dsFrame <- tkframe(top) entryDsname <- tkentry(dsFrame, width="20", textvariable=dsname) rateVar <- tclVar("1") rateEntry <- tkentry(top, width="6", textvariable=rateVar) nVar <- tclVar("100") nEntry <- tkentry(top, width="6", textvariable=nVar) samplesVar <- tclVar("1") samplesEntry <- tkentry(top, width="6", textvariable=samplesVar) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sum", "sd"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Sample means", "Sample sums", "Sample standard deviations"))) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=tDistributionSamples, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=tDistributionSamples, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ tDistributionSamples() return() } } rate <- as.numeric(tclvalue(rateVar)) if (is.na(rate) || rate <= 0) { errorCondition(recall=exponentialDistributionPlot, message=gettextRcmdr("Rate must be positive.")) return() } n <- as.numeric(tclvalue(nVar)) samples <- as.numeric(tclvalue(samplesVar)) if (is.na(n) || n <= 0) { errorCondition(recall=tDistributionSamples, message=gettextRcmdr("Sample size must be positive.")) return() } if (is.na(samples) || samples <= 0) { errorCondition(recall=tDistributionSamples, message=gettextRcmdr("Number of samples must be positive.")) return() } command <- paste(dsnameValue, " <- as.data.frame(matrix(rexp(", samples, "*", n, ", rate=", rate, "), ncol=", n, "))", sep="") justDoIt(command) logger(command) command <- if (samples == 1) paste("rownames(", dsnameValue, ') <- "sample"', sep="") else paste("rownames(", dsnameValue, ') <- paste("sample", 1:', samples, ', sep="")', sep="") justDoIt(command) logger(command) command <- if (n == 1) paste("colnames(", dsnameValue, ') <- "obs"', sep="") else paste("colnames(", dsnameValue, ') <- paste("obs", 1:', n, ', sep="")', sep="") justDoIt(command) logger(command) if (tclvalue(meanVariable) == "1") { command <- paste(dsnameValue, "$mean <- rowMeans(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sumVariable) == "1") { command <- paste(dsnameValue, "$sum <- rowSums(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sdVariable) == "1") { command <- paste(dsnameValue, "$sd <- apply(", dsnameValue, "[,1:", n, "], 1, sd)", sep="") justDoIt(command) logger(command) } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="rexp") tkgrid(tklabel(dsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(dsFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Rate")), rateEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of samples (rows) ")), samplesEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of observations (columns) ")), nEntry, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Add to Data Set:"), fg="blue"), sticky="w") tkgrid(checkBoxFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=10, columns=2, focus=rateEntry) } # ----- uniform distribution uniformDistributionSamples <- function(){ initializeDialog(title=gettextRcmdr("Sample from Uniform Distribution")) dsname <- tclVar(gettextRcmdr("UniformSamples")) dsFrame <- tkframe(top) entryDsname <- tkentry(dsFrame, width="20", textvariable=dsname) minVar <- tclVar("0") maxVar <- tclVar("1") minEntry <- tkentry(top, width="6", textvariable=minVar) maxEntry <- tkentry(top, width="6", textvariable=maxVar) nVar <- tclVar("100") nEntry <- tkentry(top, width="6", textvariable=nVar) samplesVar <- tclVar("1") samplesEntry <- tkentry(top, width="6", textvariable=samplesVar) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sum", "sd"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Sample means", "Sample sums", "Sample standard deviations"))) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=uniformDistributionSamples, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=uniformDistributionSamples, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ uniformDistributionSamples() return() } } minValue <- as.numeric(tclvalue(minVar)) maxValue <- as.numeric(tclvalue(maxVar)) if (is.na(minValue) || is.na(maxValue) || minValue >= maxValue) { errorCondition(recall=uniformDistributionSamples, message=gettextRcmdr("Lower limit must be less than upper limit.")) return() } n <- as.numeric(tclvalue(nVar)) samples <- as.numeric(tclvalue(samplesVar)) if (is.na(n) || n <= 0) { errorCondition(recall=uniformDistributionSamples, message=gettextRcmdr("Sample size must be positive.")) return() } if (is.na(samples) || samples <= 0) { errorCondition(recall=uniformDistributionSamples, message=gettextRcmdr("Number of samples must be positive.")) return() } command <- paste(dsnameValue, " <- as.data.frame(matrix(runif(", samples, "*", n, ", min=", minValue, ", max=", maxValue, "), ncol=", n, "))", sep="") justDoIt(command) logger(command) command <- if (samples == 1) paste("rownames(", dsnameValue, ') <- "sample"', sep="") else paste("rownames(", dsnameValue, ') <- paste("sample", 1:', samples, ', sep="")', sep="") justDoIt(command) logger(command) command <- if (n == 1) paste("colnames(", dsnameValue, ') <- "obs"', sep="") else paste("colnames(", dsnameValue, ') <- paste("obs", 1:', n, ', sep="")', sep="") justDoIt(command) logger(command) if (tclvalue(meanVariable) == "1") { command <- paste(dsnameValue, "$mean <- rowMeans(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sumVariable) == "1") { command <- paste(dsnameValue, "$sum <- rowSums(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sdVariable) == "1") { command <- paste(dsnameValue, "$sd <- apply(", dsnameValue, "[,1:", n, "], 1, sd)", sep="") justDoIt(command) logger(command) } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="runif") tkgrid(tklabel(dsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(dsFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Minimum")), minEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Maximum")), maxEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of samples (rows) ")), samplesEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of observations (columns) ")), nEntry, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Add to Data Set:"), fg="blue"), sticky="w") tkgrid(checkBoxFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=11, columns=2, focus=minEntry) } # ----- beta distribution betaDistributionSamples <- function(){ initializeDialog(title=gettextRcmdr("Sample from Beta Distribution")) dsname <- tclVar(gettextRcmdr("BetaSamples")) dsFrame <- tkframe(top) entryDsname <- tkentry(dsFrame, width="20", textvariable=dsname) shape1Var <- tclVar("") shape1Entry <- tkentry(top, width="6", textvariable=shape1Var) shape2Var <- tclVar("") shape2Entry <- tkentry(top, width="6", textvariable=shape2Var) nVar <- tclVar("100") nEntry <- tkentry(top, width="6", textvariable=nVar) samplesVar <- tclVar("1") samplesEntry <- tkentry(top, width="6", textvariable=samplesVar) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sum", "sd"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Sample means", "Sample sums", "Sample standard deviations"))) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=betaDistributionSamples, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=betaDistributionSamples, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ betaDistributionSamples() return() } } shape1 <- as.numeric(tclvalue(shape1Var)) shape2 <- as.numeric(tclvalue(shape2Var)) if (is.na(shape1) || is.na(shape2)) { errorCondition(recall=betaDistributionSamples, message=gettextRcmdr("Shapes not specified.")) return() } if (shape1 <= 0 || shape2 <= 0) { errorCondition(recall=betaDistributionSamples, message=gettextRcmdr("Shapes must be positive.")) return() } n <- as.numeric(tclvalue(nVar)) samples <- as.numeric(tclvalue(samplesVar)) if (is.na(n) || n <= 0) { errorCondition(recall=betaDistributionSamples, message=gettextRcmdr("Sample size must be positive.")) return() } if (is.na(samples) || samples <= 0) { errorCondition(recall=betaDistributionSamples, message=gettextRcmdr("Number of samples must be positive.")) return() } command <- paste(dsnameValue, " <- as.data.frame(matrix(rbeta(", samples, "*", n, ", shape1=", shape1, ", shape2=", shape2, "), ncol=", n, "))", sep="") justDoIt(command) logger(command) command <- if (samples == 1) paste("rownames(", dsnameValue, ') <- "sample"', sep="") else paste("rownames(", dsnameValue, ') <- paste("sample", 1:', samples, ', sep="")', sep="") justDoIt(command) logger(command) command <- if (n == 1) paste("colnames(", dsnameValue, ') <- "obs"', sep="") else paste("colnames(", dsnameValue, ') <- paste("obs", 1:', n, ', sep="")', sep="") justDoIt(command) logger(command) if (tclvalue(meanVariable) == "1") { command <- paste(dsnameValue, "$mean <- rowMeans(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sumVariable) == "1") { command <- paste(dsnameValue, "$sum <- rowSums(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sdVariable) == "1") { command <- paste(dsnameValue, "$sd <- apply(", dsnameValue, "[,1:", n, "], 1, sd)", sep="") justDoIt(command) logger(command) } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="rbeta") tkgrid(tklabel(dsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(dsFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Shape 1")), shape1Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Shape 2")), shape2Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of samples (rows) ")), samplesEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of observations (columns) ")), nEntry, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Add to Data Set:"), fg="blue"), sticky="w") tkgrid(checkBoxFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=11, columns=2, focus=shape1Entry) } # ---- Cauchy distribution CauchyDistributionSamples <- function(){ initializeDialog(title=gettextRcmdr("Sample from Cauchy Distribution")) dsname <- tclVar(gettextRcmdr("CauchySamples")) dsFrame <- tkframe(top) entryDsname <- tkentry(dsFrame, width="20", textvariable=dsname) locationVar <- tclVar("0") locationEntry <- tkentry(top, width="6", textvariable=locationVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) nVar <- tclVar("100") nEntry <- tkentry(top, width="6", textvariable=nVar) samplesVar <- tclVar("1") samplesEntry <- tkentry(top, width="6", textvariable=samplesVar) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sum", "sd"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Sample means", "Sample sums", "Sample standard deviations"))) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=CauchyDistributionSamples, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=CauchyDistributionSamples, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ CauchyDistributionSamples() return() } } location <- as.numeric(tclvalue(locationVar)) s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=CauchyDistributionSamples, message=gettextRcmdr("Scale must be positive.")) return() } n <- as.numeric(tclvalue(nVar)) samples <- as.numeric(tclvalue(samplesVar)) if (is.na(n) || n <= 0) { errorCondition(recall=CauchyDistributionSamples, message=gettextRcmdr("Sample size must be positive.")) return() } if (is.na(samples) || samples <= 0) { errorCondition(recall=CauchyDistributionSamples, message=gettextRcmdr("Number of samples must be positive.")) return() } command <- paste(dsnameValue, " <- as.data.frame(matrix(rcauchy(", samples, "*", n, ", location=", location, ", scale=", s, "), ncol=", n, "))", sep="") justDoIt(command) logger(command) command <- if (samples == 1) paste("rownames(", dsnameValue, ') <- "sample"', sep="") else paste("rownames(", dsnameValue, ') <- paste("sample", 1:', samples, ', sep="")', sep="") justDoIt(command) logger(command) command <- if (n == 1) paste("colnames(", dsnameValue, ') <- "obs"', sep="") else paste("colnames(", dsnameValue, ') <- paste("obs", 1:', n, ', sep="")', sep="") justDoIt(command) logger(command) if (tclvalue(meanVariable) == "1") { command <- paste(dsnameValue, "$mean <- rowMeans(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sumVariable) == "1") { command <- paste(dsnameValue, "$sum <- rowSums(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sdVariable) == "1") { command <- paste(dsnameValue, "$sd <- apply(", dsnameValue, "[,1:", n, "], 1, sd)", sep="") justDoIt(command) logger(command) } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="rcauchy") tkgrid(tklabel(dsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(dsFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Location")), locationEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Scale")), sEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of samples (rows) ")), samplesEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of observations (columns) ")), nEntry, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Add to Data Set:"), fg="blue"), sticky="w") tkgrid(checkBoxFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=11, columns=2, focus=locationEntry) } # ---- logistic distribution logisticDistributionSamples <- function(){ initializeDialog(title=gettextRcmdr("Sample from Logistic Distribution")) dsname <- tclVar(gettextRcmdr("LogisticSamples")) dsFrame <- tkframe(top) entryDsname <- tkentry(dsFrame, width="20", textvariable=dsname) locationVar <- tclVar("0") locationEntry <- tkentry(top, width="6", textvariable=locationVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) nVar <- tclVar("100") nEntry <- tkentry(top, width="6", textvariable=nVar) samplesVar <- tclVar("1") samplesEntry <- tkentry(top, width="6", textvariable=samplesVar) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sum", "sd"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Sample means", "Sample sums", "Sample standard deviations"))) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=logisticDistributionSamples, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=logisticDistributionSamples, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ CauchyDistributionSamples() return() } } location <- as.numeric(tclvalue(locationVar)) s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=logisticDistributionSamples, message=gettextRcmdr("Scale must be positive.")) return() } n <- as.numeric(tclvalue(nVar)) samples <- as.numeric(tclvalue(samplesVar)) if (is.na(n) || n <= 0) { errorCondition(recall=logisticDistributionSamples, message=gettextRcmdr("Sample size must be positive.")) return() } if (is.na(samples) || samples <= 0) { errorCondition(recall=logisticDistributionSamples, message=gettextRcmdr("Number of samples must be positive.")) return() } command <- paste(dsnameValue, " <- as.data.frame(matrix(rlogis(", samples, "*", n, ", location=", location, ", scale=", s, "), ncol=", n, "))", sep="") justDoIt(command) logger(command) command <- if (samples == 1) paste("rownames(", dsnameValue, ') <- "sample"', sep="") else paste("rownames(", dsnameValue, ') <- paste("sample", 1:', samples, ', sep="")', sep="") justDoIt(command) logger(command) command <- if (n == 1) paste("colnames(", dsnameValue, ') <- "obs"', sep="") else paste("colnames(", dsnameValue, ') <- paste("obs", 1:', n, ', sep="")', sep="") justDoIt(command) logger(command) if (tclvalue(meanVariable) == "1") { command <- paste(dsnameValue, "$mean <- rowMeans(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sumVariable) == "1") { command <- paste(dsnameValue, "$sum <- rowSums(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sdVariable) == "1") { command <- paste(dsnameValue, "$sd <- apply(", dsnameValue, "[,1:", n, "], 1, sd)", sep="") justDoIt(command) logger(command) } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="rlogis") tkgrid(tklabel(dsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(dsFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Location")), locationEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Scale")), sEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of samples (rows) ")), samplesEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of observations (columns) ")), nEntry, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Add to Data Set:"), fg="blue"), sticky="w") tkgrid(checkBoxFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=11, columns=2, focus=locationEntry) } # ---- lognormal distribution lognormalDistributionSamples <- function(){ initializeDialog(title=gettextRcmdr("Sample from Log-Normal Distribution")) dsname <- tclVar(gettextRcmdr("LogNormalSamples")) dsFrame <- tkframe(top) entryDsname <- tkentry(dsFrame, width="20", textvariable=dsname) meanlogVar <- tclVar("0") meanlogEntry <- tkentry(top, width="6", textvariable=meanlogVar) sdlogVar <- tclVar("1") sdlogEntry <- tkentry(top, width="6", textvariable=sdlogVar) nVar <- tclVar("100") nEntry <- tkentry(top, width="6", textvariable=nVar) samplesVar <- tclVar("1") samplesEntry <- tkentry(top, width="6", textvariable=samplesVar) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sum", "sd"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Sample means", "Sample sums", "Sample standard deviations"))) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=lognormalDistributionSamples, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=lognormalDistributionSamples, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ normalDistributionSamples() return() } } meanlog <- as.numeric(tclvalue(meanlogVar)) sdlog <- as.numeric(tclvalue(sdlogVar)) if (is.na(sdlog) || sdlog <= 0) { errorCondition(recall=lognormalDistributionSamples, message=gettextRcmdr("Standard deviation must be positive.")) return() } n <- as.numeric(tclvalue(nVar)) samples <- as.numeric(tclvalue(samplesVar)) if (is.na(n) || n <= 0) { errorCondition(recall=lognormalDistributionSamples, message=gettextRcmdr("Sample size must be positive.")) return() } if (is.na(samples) || samples <= 0) { errorCondition(recall=lognormalDistributionSamples, message=gettextRcmdr("Number of samples must be positive.")) return() } command <- paste(dsnameValue, " <- as.data.frame(matrix(rlnorm(", samples, "*", n, ", meanlog=", meanlog, ", sdlog=", sdlog, "), ncol=", n, "))", sep="") justDoIt(command) logger(command) command <- if (samples == 1) paste("rownames(", dsnameValue, ') <- "sample"', sep="") else paste("rownames(", dsnameValue, ') <- paste("sample", 1:', samples, ', sep="")', sep="") justDoIt(command) logger(command) command <- if (n == 1) paste("colnames(", dsnameValue, ') <- "obs"', sep="") else paste("colnames(", dsnameValue, ') <- paste("obs", 1:', n, ', sep="")', sep="") justDoIt(command) logger(command) if (tclvalue(meanVariable) == "1") { command <- paste(dsnameValue, "$mean <- rowMeans(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sumVariable) == "1") { command <- paste(dsnameValue, "$sum <- rowSums(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sdVariable) == "1") { command <- paste(dsnameValue, "$sd <- apply(", dsnameValue, "[,1:", n, "], 1, sd)", sep="") justDoIt(command) logger(command) } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="rlnorm") tkgrid(tklabel(dsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(dsFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Mean (log scale)")), meanlogEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Standard deviation (log scale)")), sdlogEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of samples (rows) ")), samplesEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of observations (columns) ")), nEntry, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Add to Data Set:"), fg="blue"), sticky="w") tkgrid(checkBoxFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=11, columns=2, focus=meanlogEntry) } # ---- gamma distribution gammaDistributionSamples <- function(){ initializeDialog(title=gettextRcmdr("Sample from Gamma Distribution")) dsname <- tclVar(gettextRcmdr("GammaSamples")) dsFrame <- tkframe(top) entryDsname <- tkentry(dsFrame, width="20", textvariable=dsname) shapeVar <- tclVar("") shapeEntry <- tkentry(top, width="6", textvariable=shapeVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) nVar <- tclVar("100") nEntry <- tkentry(top, width="6", textvariable=nVar) samplesVar <- tclVar("1") samplesEntry <- tkentry(top, width="6", textvariable=samplesVar) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sum", "sd"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Sample means", "Sample sums", "Sample standard deviations"))) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=gammaDistributionSamples, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=gammaDistributionSamples, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ gammaDistributionSamples() return() } } shape <- as.numeric(tclvalue(shapeVar)) if (is.na(shape)) { errorCondition(recall=gammaDistributionSamples, message=gettextRcmdr("Shape not specified.")) return() } if (shape <= 0) { errorCondition(recall=gammaDistributionSamples, message=gettextRcmdr("Shape must be positive.")) return() } s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=gammaDistributionSamples, message=gettextRcmdr("Scale must be positive.")) return() } n <- as.numeric(tclvalue(nVar)) samples <- as.numeric(tclvalue(samplesVar)) if (is.na(n) || n <= 0) { errorCondition(recall=gammaDistributionSamples, message=gettextRcmdr("Sample size must be positive.")) return() } if (is.na(samples) || samples <= 0) { errorCondition(recall=gammaDistributionSamples, message=gettextRcmdr("Number of samples must be positive.")) return() } command <- paste(dsnameValue, " <- as.data.frame(matrix(rgamma(", samples, "*", n, ", shape=", shape, ", scale=", s, "), ncol=", n, "))", sep="") justDoIt(command) logger(command) command <- if (samples == 1) paste("rownames(", dsnameValue, ') <- "sample"', sep="") else paste("rownames(", dsnameValue, ') <- paste("sample", 1:', samples, ', sep="")', sep="") justDoIt(command) logger(command) command <- if (n == 1) paste("colnames(", dsnameValue, ') <- "obs"', sep="") else paste("colnames(", dsnameValue, ') <- paste("obs", 1:', n, ', sep="")', sep="") justDoIt(command) logger(command) if (tclvalue(meanVariable) == "1") { command <- paste(dsnameValue, "$mean <- rowMeans(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sumVariable) == "1") { command <- paste(dsnameValue, "$sum <- rowSums(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sdVariable) == "1") { command <- paste(dsnameValue, "$sd <- apply(", dsnameValue, "[,1:", n, "], 1, sd)", sep="") justDoIt(command) logger(command) } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="rgamma") tkgrid(tklabel(dsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(dsFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Shape")), shapeEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Scale (inverse rate)")), sEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of samples (rows) ")), samplesEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of observations (columns) ")), nEntry, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Add to Data Set:"), fg="blue"), sticky="w") tkgrid(checkBoxFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=11, columns=2, focus=shapeEntry) } # ---- Weibull distribution WeibullDistributionSamples <- function(){ initializeDialog(title=gettextRcmdr("Sample from Weibull Distribution")) dsname <- tclVar(gettextRcmdr("WeibullSamples")) dsFrame <- tkframe(top) entryDsname <- tkentry(dsFrame, width="20", textvariable=dsname) shapeVar <- tclVar("") shapeEntry <- tkentry(top, width="6", textvariable=shapeVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) nVar <- tclVar("100") nEntry <- tkentry(top, width="6", textvariable=nVar) samplesVar <- tclVar("1") samplesEntry <- tkentry(top, width="6", textvariable=samplesVar) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sum", "sd"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Sample means", "Sample sums", "Sample standard deviations"))) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=WeibullDistributionSamples, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=WeibullDistributionSamples, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ normalDistributionSamples() return() } } shape <- as.numeric(tclvalue(shapeVar)) if (is.na(shape)) { errorCondition(recall=WeibullDistributionSamples, message=gettextRcmdr("Shape not specified.")) return() } if (shape <= 0) { errorCondition(recall=WeibullDistributionSamples, message=gettextRcmdr("Shape must be positive.")) return() } s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=WeibullDistributionSamples, message=gettextRcmdr("Scale must be positive.")) return() } n <- as.numeric(tclvalue(nVar)) samples <- as.numeric(tclvalue(samplesVar)) if (is.na(n) || n <= 0) { errorCondition(recall=WeibullDistributionSamples, message=gettextRcmdr("Sample size must be positive.")) return() } if (is.na(samples) || samples <= 0) { errorCondition(recall=WeibullDistributionSamples, message=gettextRcmdr("Number of samples must be positive.")) return() } command <- paste(dsnameValue, " <- as.data.frame(matrix(rweibull(", samples, "*", n, ", shape=", shape, ", scale=", s, "), ncol=", n, "))", sep="") justDoIt(command) logger(command) command <- if (samples == 1) paste("rownames(", dsnameValue, ') <- "sample"', sep="") else paste("rownames(", dsnameValue, ') <- paste("sample", 1:', samples, ', sep="")', sep="") justDoIt(command) logger(command) command <- if (n == 1) paste("colnames(", dsnameValue, ') <- "obs"', sep="") else paste("colnames(", dsnameValue, ') <- paste("obs", 1:', n, ', sep="")', sep="") justDoIt(command) logger(command) if (tclvalue(meanVariable) == "1") { command <- paste(dsnameValue, "$mean <- rowMeans(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sumVariable) == "1") { command <- paste(dsnameValue, "$sum <- rowSums(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sdVariable) == "1") { command <- paste(dsnameValue, "$sd <- apply(", dsnameValue, "[,1:", n, "], 1, sd)", sep="") justDoIt(command) logger(command) } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="rweibull") tkgrid(tklabel(dsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(dsFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Shape")), shapeEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Scale")), sEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of samples (rows) ")), samplesEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of observations (columns) ")), nEntry, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Add to Data Set:"), fg="blue"), sticky="w") tkgrid(checkBoxFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=11, columns=2, focus=shapeEntry) } # ---- Gumbel distribution GumbelDistributionSamples <- function(){ initializeDialog(title=gettextRcmdr("Sample from Gumbel Distribution")) dsname <- tclVar(gettextRcmdr("GumbelSamples")) dsFrame <- tkframe(top) entryDsname <- tkentry(dsFrame, width="20", textvariable=dsname) shapeVar <- tclVar("") shapeEntry <- tkentry(top, width="6", textvariable=shapeVar) sVar <- tclVar("1") sEntry <- tkentry(top, width="6", textvariable=sVar) nVar <- tclVar("100") nEntry <- tkentry(top, width="6", textvariable=nVar) samplesVar <- tclVar("1") samplesEntry <- tkentry(top, width="6", textvariable=samplesVar) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sum", "sd"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Sample means", "Sample sums", "Sample standard deviations"))) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=GumbelDistributionSamples, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=GumbelDistributionSamples, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ normalDistributionSamples() return() } } shape <- as.numeric(tclvalue(shapeVar)) if (is.na(shape)) { errorCondition(recall=GumbelDistributionSamples, message=gettextRcmdr("Shape not specified.")) return() } if (shape <= 0) { errorCondition(recall=GumbelDistributionSamples, message=gettextRcmdr("Shape must be positive.")) return() } s <- as.numeric(tclvalue(sVar)) if (is.na(s) || s <= 0) { errorCondition(recall=GumbelDistributionSamples, message=gettextRcmdr("Scale must be positive.")) return() } n <- as.numeric(tclvalue(nVar)) samples <- as.numeric(tclvalue(samplesVar)) if (is.na(n) || n <= 0) { errorCondition(recall=GumbelDistributionSamples, message=gettextRcmdr("Sample size must be positive.")) return() } if (is.na(samples) || samples <= 0) { errorCondition(recall=GumbelDistributionSamples, message=gettextRcmdr("Number of samples must be positive.")) return() } command <- paste(dsnameValue, " <- as.data.frame(matrix(log(rweibull(", samples, "*", n, ", shape=", shape, ", scale=", s, ")), ncol=", n, "))", sep="") justDoIt(command) logger(command) command <- if (samples == 1) paste("rownames(", dsnameValue, ') <- "sample"', sep="") else paste("rownames(", dsnameValue, ') <- paste("sample", 1:', samples, ', sep="")', sep="") justDoIt(command) logger(command) command <- if (n == 1) paste("colnames(", dsnameValue, ') <- "obs"', sep="") else paste("colnames(", dsnameValue, ') <- paste("obs", 1:', n, ', sep="")', sep="") justDoIt(command) logger(command) if (tclvalue(meanVariable) == "1") { command <- paste(dsnameValue, "$mean <- rowMeans(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sumVariable) == "1") { command <- paste(dsnameValue, "$sum <- rowSums(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sdVariable) == "1") { command <- paste(dsnameValue, "$sd <- apply(", dsnameValue, "[,1:", n, "], 1, sd)", sep="") justDoIt(command) logger(command) } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="rweibull") tkgrid(tklabel(dsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(dsFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Shape (log shape)")), shapeEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Scale (log scale)")), sEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of samples (rows) ")), samplesEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of observations (columns) ")), nEntry, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Add to Data Set:"), fg="blue"), sticky="w") tkgrid(checkBoxFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=11, columns=2, focus=shapeEntry) } # ---- binomial distribution binomialDistributionSamples <- function(){ initializeDialog(title=gettextRcmdr("Sample from Binomial Distribution")) dsname <- tclVar(gettextRcmdr("BinomialSamples")) dsFrame <- tkframe(top) entryDsname <- tkentry(dsFrame, width="20", textvariable=dsname) probVar <- tclVar(".5") probEntry <- tkentry(top, width="6", textvariable=probVar) trialsVar <- tclVar("1") trialsEntry <- tkentry(top, width="6", textvariable=trialsVar) nVar <- tclVar("100") nEntry <- tkentry(top, width="6", textvariable=nVar) samplesVar <- tclVar("1") samplesEntry <- tkentry(top, width="6", textvariable=samplesVar) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sum", "sd"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Sample means", "Sample sums", "Sample standard deviations"))) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=binomialDistributionSamples, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=binomialDistributionSamples, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ binomialDistributionSamples() return() } } prob <- as.numeric(tclvalue(probVar)) if (is.na(prob)) { errorCondition(recall=binomialDistributionSamples, message=gettextRcmdr("Probability of success not specified.")) return() } if (prob < 0 || prob > 1) { errorCondition(recall=binomialDistributionSamples, message=gettextRcmdr("Probability of success must be between 0 and 1.")) return() } trials <- round(as.numeric(tclvalue(trialsVar))) if (is.na(trials)) { errorCondition(recall=binomialDistributionSamples, message=gettextRcmdr("Binomial trials not specified.")) return() } n <- as.numeric(tclvalue(nVar)) samples <- as.numeric(tclvalue(samplesVar)) if (is.na(n) || n <= 0) { errorCondition(recall=binomialDistributionSamples, message=gettextRcmdr("Sample size must be positive.")) return() } if (is.na(samples) || samples <= 0) { errorCondition(recall=binomialDistributionSamples, message=gettextRcmdr("Number of samples must be positive.")) return() } command <- paste(dsnameValue, " <- as.data.frame(matrix(rbinom(", samples, "*", n, ", size=", trials, ", prob=", prob, "), ncol=", n, "))", sep="") justDoIt(command) logger(command) command <- if (samples == 1) paste("rownames(", dsnameValue, ') <- "sample"', sep="") else paste("rownames(", dsnameValue, ') <- paste("sample", 1:', samples, ', sep="")', sep="") justDoIt(command) logger(command) command <- if (n == 1) paste("colnames(", dsnameValue, ') <- "obs"', sep="") else paste("colnames(", dsnameValue, ') <- paste("obs", 1:', n, ', sep="")', sep="") justDoIt(command) logger(command) if (tclvalue(meanVariable) == "1") { command <- paste(dsnameValue, "$mean <- rowMeans(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sumVariable) == "1") { command <- paste(dsnameValue, "$sum <- rowSums(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sdVariable) == "1") { command <- paste(dsnameValue, "$sd <- apply(", dsnameValue, "[,1:", n, "], 1, sd)", sep="") justDoIt(command) logger(command) } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="rbinom") tkgrid(tklabel(dsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(dsFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Binomial trials")), trialsEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Probability of success")), probEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of samples (rows) ")), samplesEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of observations (columns) ")), nEntry, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Add to Data Set:"), fg="blue"), sticky="w") tkgrid(checkBoxFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=11, columns=2, focus=trialsEntry) } # ---- Poisson distribution PoissonDistributionSamples <- function(){ initializeDialog(title=gettextRcmdr("Sample from Poisson Distribution")) dsname <- tclVar(gettextRcmdr("PoissonSamples")) dsFrame <- tkframe(top) entryDsname <- tkentry(dsFrame, width="20", textvariable=dsname) meanVar <- tclVar("") meanEntry <- tkentry(top, width="6", textvariable=meanVar) nVar <- tclVar("100") nEntry <- tkentry(top, width="6", textvariable=nVar) samplesVar <- tclVar("1") samplesEntry <- tkentry(top, width="6", textvariable=samplesVar) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sum", "sd"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Sample means", "Sample sums", "Sample standard deviations"))) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=PoissonDistributionSamples, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=PoissonDistributionSamples, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ PoissonDistributionSamples() return() } } mean <- as.numeric(tclvalue(meanVar)) if (is.na(mean)) { errorCondition(recall=PoissonDistributionPlot, message=gettextRcmdr("Mean not specified.")) return() } if (mean < 0) { errorCondition(recall=PoissonDistributionPlot, message=gettextRcmdr("Poisson mean cannot be negative.")) return() } n <- as.numeric(tclvalue(nVar)) samples <- as.numeric(tclvalue(samplesVar)) if (is.na(n) || n <= 0) { errorCondition(recall=PoissonDistributionSamples, message=gettextRcmdr("Sample size must be positive.")) return() } if (is.na(samples) || samples <= 0) { errorCondition(recall=PoissonDistributionSamples, message=gettextRcmdr("Number of samples must be positive.")) return() } command <- paste(dsnameValue, " <- as.data.frame(matrix(rpois(", samples, "*", n, ", lambda=", mean, "), ncol=", n, "))", sep="") justDoIt(command) logger(command) command <- if (samples == 1) paste("rownames(", dsnameValue, ') <- "sample"', sep="") else paste("rownames(", dsnameValue, ') <- paste("sample", 1:', samples, ', sep="")', sep="") justDoIt(command) logger(command) command <- if (n == 1) paste("colnames(", dsnameValue, ') <- "obs"', sep="") else paste("colnames(", dsnameValue, ') <- paste("obs", 1:', n, ', sep="")', sep="") justDoIt(command) logger(command) if (tclvalue(meanVariable) == "1") { command <- paste(dsnameValue, "$mean <- rowMeans(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sumVariable) == "1") { command <- paste(dsnameValue, "$sum <- rowSums(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sdVariable) == "1") { command <- paste(dsnameValue, "$sd <- apply(", dsnameValue, "[,1:", n, "], 1, sd)", sep="") justDoIt(command) logger(command) } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="rpois") tkgrid(tklabel(dsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(dsFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Mean")), meanEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of samples (rows) ")), samplesEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of observations (columns) ")), nEntry, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Add to Data Set:"), fg="blue"), sticky="w") tkgrid(checkBoxFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=10, columns=2, focus=meanEntry) } # ---- geometric distribution geomDistributionSamples <- function(){ initializeDialog(title=gettextRcmdr("Sample from Geometric Distribution")) dsname <- tclVar(gettextRcmdr("GeometricSamples")) dsFrame <- tkframe(top) entryDsname <- tkentry(dsFrame, width="20", textvariable=dsname) probVar <- tclVar(".5") probEntry <- tkentry(top, width="6", textvariable=probVar) nVar <- tclVar("100") nEntry <- tkentry(top, width="6", textvariable=nVar) samplesVar <- tclVar("1") samplesEntry <- tkentry(top, width="6", textvariable=samplesVar) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sum", "sd"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Sample means", "Sample sums", "Sample standard deviations"))) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=geomDistributionSamples, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=geomDistributionSamples, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ geomDistributionSamples() return() } } prob <- as.numeric(tclvalue(probVar)) if (is.na(prob)) { errorCondition(recall=geomDistributionSamples, message=gettextRcmdr("Probability of success not specified.")) return() } if (prob < 0 || prob > 1) { errorCondition(recall=geomDistributionSamples, message=gettextRcmdr("Probability of success must be between 0 and 1.")) return() } n <- as.numeric(tclvalue(nVar)) samples <- as.numeric(tclvalue(samplesVar)) if (is.na(n) || n <= 0) { errorCondition(recall=geomDistributionSamples, message=gettextRcmdr("Sample size must be positive.")) return() } if (is.na(samples) || samples <= 0) { errorCondition(recall=geomDistributionSamples, message=gettextRcmdr("Number of samples must be positive.")) return() } command <- paste(dsnameValue, " <- as.data.frame(matrix(rgeom(", samples, "*", n, ", prob=", prob, "), ncol=", n, "))", sep="") justDoIt(command) logger(command) command <- if (samples == 1) paste("rownames(", dsnameValue, ') <- "sample"', sep="") else paste("rownames(", dsnameValue, ') <- paste("sample", 1:', samples, ', sep="")', sep="") justDoIt(command) logger(command) command <- if (n == 1) paste("colnames(", dsnameValue, ') <- "obs"', sep="") else paste("colnames(", dsnameValue, ') <- paste("obs", 1:', n, ', sep="")', sep="") justDoIt(command) logger(command) if (tclvalue(meanVariable) == "1") { command <- paste(dsnameValue, "$mean <- rowMeans(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sumVariable) == "1") { command <- paste(dsnameValue, "$sum <- rowSums(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sdVariable) == "1") { command <- paste(dsnameValue, "$sd <- apply(", dsnameValue, "[,1:", n, "], 1, sd)", sep="") justDoIt(command) logger(command) } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="rgeom") tkgrid(tklabel(dsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(dsFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Probability of success")), probEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of samples (rows) ")), samplesEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of observations (columns) ")), nEntry, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Add to Data Set:"), fg="blue"), sticky="w") tkgrid(checkBoxFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=10, columns=2, focus=probEntry) } # ---- hypergeometric distribution hyperDistributionSamples <- function(){ initializeDialog(title=gettextRcmdr("Sample from Hypergeometric Distribution")) dsname <- tclVar(gettextRcmdr("HypergeometricSamples")) dsFrame <- tkframe(top) entryDsname <- tkentry(dsFrame, width="20", textvariable=dsname) mVar <- tclVar("1") mEntry <- tkentry(top, width="6", textvariable=mVar) nVar <- tclVar("1") nEntry <- tkentry(top, width="6", textvariable=nVar) kVar <- tclVar("1") kEntry <- tkentry(top, width="6", textvariable=kVar) sampleSizeVar <- tclVar("100") sampleSizeEntry <- tkentry(top, width="6", textvariable=sampleSizeVar) samplesVar <- tclVar("1") samplesEntry <- tkentry(top, width="6", textvariable=samplesVar) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sum", "sd"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Sample means", "Sample sums", "Sample standard deviations"))) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=geometricDistributionSamples, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=geometricDistributionSamples, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ geometricDistributionSamples() return() } } m <- as.numeric(tclvalue(mVar)) n <- as.numeric(tclvalue(nVar)) k <- as.numeric(tclvalue(kVar)) if ( is.na(m) ){ errorCondition(recall=hyperDistributionSamples, message=gettextRcmdr("The m parameter was not specified.")) return() } if ( m < 0 ){ errorCondition(recall=hyperDistributionSamples, message=gettextRcmdr("The m parameter cannot be negative.")) return() } m <- round(m) if ( is.na(n) ){ errorCondition(recall=hyperDistributionSamples, message=gettextRcmdr("The n parameter was not specified.")) return() } if ( n < 0 ){ errorCondition(recall=hyperDistributionSamples, message=gettextRcmdr("The n parameter cannot be negative.")) return() } n <- round(n) if ( is.na(k) ){ errorCondition(recall=hyperDistributionSamples, message=gettextRcmdr("The k parameter was not specified.")) return() } k <- round(k) if ( k > (m + n) ){ errorCondition(recall=hyperDistributionSamples, message=gettextRcmdr("The k parameter cannot be greater than m + n.")) return() } if ( k < 0 ){ errorCondition(recall=hyperDistributionSamples, message=gettextRcmdr("The k parameter cannot be negative.")) return() } sampleSize <- as.numeric(tclvalue(sampleSizeVar)) samples <- as.numeric(tclvalue(samplesVar)) if (is.na(sampleSize) || sampleSize <= 0) { errorCondition(recall=geometricDistributionSamples, message=gettextRcmdr("Sample size must be positive.")) return() } if (is.na(samples) || samples <= 0) { errorCondition(recall=geometricDistributionSamples, message=gettextRcmdr("Number of samples must be positive.")) return() } command <- paste(dsnameValue, " <- as.data.frame(matrix(rhyper(", samples, "*", sampleSize, ", n=", n, ", m=", m, ", k=", k,"), ncol=", sampleSize, "))", sep="") justDoIt(command) logger(command) command <- if (samples == 1) paste("rownames(", dsnameValue, ') <- "sample"', sep="") else paste("rownames(", dsnameValue, ') <- paste("sample", 1:', samples, ', sep="")', sep="") justDoIt(command) logger(command) command <- if (sampleSize == 1) paste("colnames(", dsnameValue, ') <- "obs"', sep="") else paste("colnames(", dsnameValue, ') <- paste("obs", 1:', sampleSize, ', sep="")', sep="") justDoIt(command) logger(command) if (tclvalue(meanVariable) == "1") { command <- paste(dsnameValue, "$mean <- rowMeans(", dsnameValue, "[,1:", sampleSize, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sumVariable) == "1") { command <- paste(dsnameValue, "$sum <- rowSums(", dsnameValue, "[,1:", sampleSize, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sdVariable) == "1") { command <- paste(dsnameValue, "$sd <- apply(", dsnameValue, "[,1:", sampleSize, "], 1, sd)", sep="") justDoIt(command) logger(command) } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="rhyper") tkgrid(tklabel(dsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(dsFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("m (number of white balls in the urn)")), mEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("n (number of black balls in the urn)")), nEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("k (number of balls drawn from the urn)")), kEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of samples (rows) ")), samplesEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of observations (columns) ")), sampleSizeEntry, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Add to Data Set:"), fg="blue"), sticky="w") tkgrid(checkBoxFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=12, columns=2, focus=mEntry) } negbinomialDistributionSamples <- function(){ initializeDialog(title=gettextRcmdr("Sample from Negative Binomial Distribution")) dsname <- tclVar(gettextRcmdr("NegativeBinomialSamples")) dsFrame <- tkframe(top) entryDsname <- tkentry(dsFrame, width="22", textvariable=dsname) probVar <- tclVar(".5") probEntry <- tkentry(top, width="6", textvariable=probVar) trialsVar <- tclVar("1") trialsEntry <- tkentry(top, width="6", textvariable=trialsVar) nVar <- tclVar("100") nEntry <- tkentry(top, width="6", textvariable=nVar) samplesVar <- tclVar("1") samplesEntry <- tkentry(top, width="6", textvariable=samplesVar) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sum", "sd"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Sample means", "Sample sums", "Sample standard deviations"))) onOK <- function(){ closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=negbinomialDistributionSamples, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=negbinomialDistributionSamples, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ negbinomialDistributionSamples() return() } } prob <- as.numeric(tclvalue(probVar)) if (is.na(prob)) { errorCondition(recall=negbinomialDistributionSamples, message=gettextRcmdr("Probability of success not specified.")) return() } if (prob < 0 || prob > 1) { errorCondition(recall=negbinomialDistributionSamples, message=gettextRcmdr("Probability of success must be between 0 and 1.")) return() } trials <- round(as.numeric(tclvalue(trialsVar))) if (is.na(trials)) { errorCondition(recall=negbinomialDistributionSamples, message=gettextRcmdr("Target number of successes not specified.")) return() } if ( trials < 0){ errorCondition(recall=negnegbinomialDistributionSamples, message=gettextRcmdr("Target number of successes cannot be negative.")) return() } n <- as.numeric(tclvalue(nVar)) samples <- as.numeric(tclvalue(samplesVar)) if (is.na(n) || n <= 0) { errorCondition(recall=negbinomialDistributionSamples, message=gettextRcmdr("Sample size must be positive.")) return() } if (is.na(samples) || samples <= 0) { errorCondition(recall=negbinomialDistributionSamples, message=gettextRcmdr("Number of samples must be positive.")) return() } command <- paste(dsnameValue, " <- as.data.frame(matrix(rnbinom(", samples, "*", n, ", size=", trials, ", prob=", prob, "), ncol=", n, "))", sep="") justDoIt(command) logger(command) command <- if (samples == 1) paste("rownames(", dsnameValue, ') <- "sample"', sep="") else paste("rownames(", dsnameValue, ') <- paste("sample", 1:', samples, ', sep="")', sep="") justDoIt(command) logger(command) command <- if (n == 1) paste("colnames(", dsnameValue, ') <- "obs"', sep="") else paste("colnames(", dsnameValue, ') <- paste("obs", 1:', n, ', sep="")', sep="") justDoIt(command) logger(command) if (tclvalue(meanVariable) == "1") { command <- paste(dsnameValue, "$mean <- rowMeans(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sumVariable) == "1") { command <- paste(dsnameValue, "$sum <- rowSums(", dsnameValue, "[,1:", n, "])", sep="") justDoIt(command) logger(command) } if (tclvalue(sdVariable) == "1") { command <- paste(dsnameValue, "$sd <- apply(", dsnameValue, "[,1:", n, "], 1, sd)", sep="") justDoIt(command) logger(command) } activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="rnbinom") tkgrid(tklabel(dsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(dsFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Target number of successes")), trialsEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Probability of success")), probEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of samples (rows) ")), samplesEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of observations (columns) ")), nEntry, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(tklabel(top, text=gettextRcmdr("Add to Data Set:"), fg="blue"), sticky="w") tkgrid(checkBoxFrame, columnspan=2, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=11, columns=2, focus=trialsEntry) } # last modified 18 May 2007 by J. Fox # File menu dialogs loadLog <- function(){ logFile <- tclvalue(tkgetOpenFile(filetypes=gettextRcmdr('{"Script Files" {".R"}} {"All Files" {"*"}}'), defaultextension="log")) if (logFile == "") return() fileCon <- file(logFile, "r") contents <- readLines(fileCon) close(fileCon) currentLogFileName <- getRcmdr("logFileName") putRcmdr("logFileName", logFile) .log <- LogWindow() if (tclvalue(tkget(.log, "1.0", "end")) != "\n"){ response2 <- RcmdrTkmessageBox(message=gettextRcmdr("Save current log file?"), icon="question", type="yesno", default="yes") if ("yes" == tclvalue(response2)) saveLog(currentLogFileName) } tkdelete(.log, "1.0", "end") tkinsert(.log, "end", paste(contents, collapse="\n")) } saveLog <- function() { .logFileName <- getRcmdr("logFileName") if (is.null(.logFileName)) { saveLogAs() return() } log <- tclvalue(tkget(LogWindow(), "1.0", "end")) fileCon <- file(.logFileName, "w") cat(log, file = fileCon) close(fileCon) Message(paste(gettextRcmdr("Script saved to"), .logFileName), type="note") } saveLogAs <- function() { logFile <- tclvalue(tkgetSaveFile(filetypes=gettextRcmdr('{"Script Files" {".R"}} {"All Files" {"*"}}'), defaultextension="R", initialfile="RCommander.R")) if (logFile == "") return() log <- tclvalue(tkget(LogWindow(), "1.0", "end")) fileCon <- file(logFile, "w") cat(log, file = fileCon) close(fileCon) putRcmdr("logFileName", logFile) Message(paste(gettextRcmdr("Script saved to"), logFile), type="note") } saveOutput <- function() { .outputFileName <- getRcmdr("outputFileName") if (is.null(.outputFileName)) { saveOutputAs() return() } output <- tclvalue(tkget(OutputWindow(), "1.0", "end")) fileCon <- file(.outputFileName, "w") cat(output, file = fileCon) close(fileCon) Message(paste(gettextRcmdr("Output saved to"), .outputFileName), type="note") } saveOutputAs <- function() { outputFile <- tclvalue(tkgetSaveFile(filetypes=gettextRcmdr('{"Output Files" {".txt"}} {"All Files" {"*"}}'), defaultextension="txt", initialfile="RCommander.txt")) if (outputFile == "") return() output <- tclvalue(tkget(OutputWindow(), "1.0", "end")) fileCon <- file(outputFile, "w") cat(output, file = fileCon) close(fileCon) putRcmdr("outputFileName", outputFile) Message(paste(gettextRcmdr("Output saved to"), outputFile), type="note") } saveWorkspaceAs <- function(){ saveFile <- tclvalue(tkgetSaveFile(filetypes=gettextRcmdr('{"All Files" {"*"}}'), defaultextension="", initialfile=".RData")) if (saveFile == "") return() save(list=ls(envir=.GlobalEnv), file=saveFile) putRcmdr("saveFileName", saveFile) Message(paste(gettextRcmdr("R workspace saved to"), saveFile), type="note") } saveWorkspace <- function() { .saveFileName <- getRcmdr("saveFileName") if (is.null(.saveFileName)) { saveWorkspaceAs() return() } else save(list=ls(envir=.GlobalEnv), file=.saveFileName) Message(paste(gettextRcmdr("R workspace saved to"), .saveFileName), type="note") } CloseCommander <- function() closeCommander() closeCommander <- function(ask=TRUE, ask.save=ask){ if (ask){ response <- tclvalue(RcmdrTkmessageBox(message=gettextRcmdr("Exit?"), icon="question", type="okcancel", default="cancel")) if (response == "cancel") return(invisible(response)) } sink(type="message") if (rglLoaded()) rgl.quit() if (!is.null(ActiveDataSet()) && getRcmdr("attach.data.set")) justDoIt(logger(paste("detach(", ActiveDataSet(), ")", sep=""))) putRcmdr(".activeDataSet", NULL) putRcmdr(".activeModel", NULL) if (ask.save && getRcmdr("log.commands") && tclvalue(tkget(LogWindow(), "1.0", "end")) != "\n"){ response2 <- RcmdrTkmessageBox(message=gettextRcmdr("Save script file?"), icon="question", type="yesno", default="yes") if ("yes" == tclvalue(response2)) saveLog() } if (ask.save && !getRcmdr("console.output") && tclvalue(tkget(OutputWindow(), "1.0", "end")) != "\n"){ response3 <- RcmdrTkmessageBox(message=gettextRcmdr("Save output file?"), icon="question", type="yesno", default="yes") if ("yes" == tclvalue(response3)) saveOutput() } if (.Platform$OS.type != "windows") options(getRcmdr("oldPager")) if (getRcmdr("suppress.X11.warnings")) { sink(type = "message") close(getRcmdr("messages.connection")) } options(getRcmdr("saveOptions")) tkdestroy(CommanderWindow()) putRcmdr("commanderWindow", NULL) putRcmdr("logWindow", NULL) putRcmdr("messagesWindow", NULL) putRcmdr("outputWindow", NULL) tkwait <- options("Rcmdr")[[1]]$tkwait # to address problem in Debian Linux if ((!is.null(tkwait)) && tkwait) tclvalue(.commander.done) <<- "1" return(invisible(response)) } closeCommanderAndR <- function(){ response <- closeCommander() if (response == "cancel") return() cat("\n") quit(save="no") } Options <- function(){ setOption <- function(option, default) { if (is.null(current[[option]])) default else current[[option]] } initializeDialog(title=gettextRcmdr("Commander Options")) current <- options("Rcmdr")[[1]] console.output <- setOption("console.output", FALSE) log.commands <- setOption("log.commands", TRUE) log.font.size <- setOption("log.font.size", 10) log.width <- setOption("log.width", 80) log.height <- if (!is.null(current$log.height)) current$log.height else if (!log.commands) 0 else 10 output.height <- if (!is.null(current$output.height)) current$output.height else if (console.output) 0 else 2*log.height contrasts <- setOption("contrasts", c("contr.Treatment", "contr.poly")) grab.focus <- setOption("grab.focus", TRUE) double.click <- setOption("double.click", FALSE) sort.names <- setOption("sort.names", TRUE) show.edit.button <- setOption("show.edit.button", TRUE) scale.factor <- current$scale.factor default.font.size <- setOption("default.font.size", 10) default.font <- setOption("default.font", paste("*helvetica-medium-r-normal-*-", default.font.size, "*", sep="")) consoleOutputVar <- tclVar(console.output) consoleOutputCheckBox <- tkcheckbutton(top, variable=consoleOutputVar) logCommandsVar <- tclVar(log.commands) logCommandsCheckBox <- tkcheckbutton(top, variable=logCommandsVar) logFontSizeVar <- tclVar(log.font.size) logFontSizeSlider <- tkscale(top, from=6, to=20, showvalue=TRUE, variable=logFontSizeVar, resolution=1, orient="horizontal") logWidthVar <- tclVar(log.width) logWidthSlider <- tkscale(top, from=30, to=120, showvalue=TRUE, variable=logWidthVar, resolution=5, orient="horizontal") logHeightVar <- tclVar(log.height) logHeightSlider <- tkscale(top, from=0, to=25, showvalue=TRUE, variable=logHeightVar, resolution=1, orient="horizontal") outputHeightVar <- tclVar(output.height) outputHeightSlider <- tkscale(top, from=0, to=50, showvalue=TRUE, variable=outputHeightVar, resolution=5, orient="horizontal") contrasts1 <- tclVar(contrasts[1]) contrasts2 <- tclVar(contrasts[2]) contrastsFrame <- tkframe(top) contrasts1Entry <- tkentry(contrastsFrame, width="15", textvariable=contrasts1) contrasts2Entry <- tkentry(contrastsFrame, width="15", textvariable=contrasts2) grabFocusVar <- tclVar(as.numeric(grab.focus)) grabFocusCheckBox <- tkcheckbutton(top, variable=grabFocusVar) doubleClickVar <- tclVar(as.numeric(double.click)) doubleClickCheckBox <- tkcheckbutton(top, variable=doubleClickVar) sortNamesVar <- tclVar(as.numeric(sort.names)) sortNamesCheckBox <- tkcheckbutton(top, variable=sortNamesVar) showEditButtonVar <- tclVar(as.numeric(show.edit.button)) showEditButtonCheckBox <- tkcheckbutton(top, variable=showEditButtonVar) scaleFactorVar <- tclVar(if (is.null(scale.factor)) 1.0 else scale.factor) scaleFactorSlider <- tkscale(top, from=0.2, to=3.0, showvalue=TRUE, variable=scaleFactorVar, resolution=0.2, orient="horizontal") defaultFont <- tclVar(default.font) defaultFontEntry <- tkentry(top, width="30", textvariable=scaleFactorVar) onOK <- function(){ closeDialog(top) log.font.size <- round(as.numeric(tclvalue(logFontSizeVar))) log.width <- round(as.numeric(tclvalue(logWidthVar))) log.height <- as.numeric(tclvalue(logHeightVar)) log.commands <- as.logical(tclvalue(logCommandsVar) == "1") && (log.height != 0) output.height <- as.numeric(tclvalue(outputHeightVar)) console.output <- as.logical(tclvalue(consoleOutputVar) == "1") || (output.height == 0) contrasts <- c(tclvalue(contrasts1), tclvalue(contrasts2)) grab.focus <- tclvalue(grabFocusVar) == 1 double.click <- tclvalue(doubleClickVar) == 1 sort.names <- tclvalue(sortNamesVar) == 1 show.edit.button <- tclvalue(showEditButtonVar) == 1 scale.factor <- round(as.numeric(tclvalue(scaleFactorVar)), 1) if (scale.factor == 1) scale.factor <- NULL default.font <- tclvalue(defaultFont) options <- list( log.font.size=log.font.size, log.width=log.width, log.height=log.height, log.commands=log.commands, output.height=output.height, console.output=console.output, contrasts=contrasts, grab.focus=grab.focus, double.click=double.click, sort.names=sort.names, show.edit.button=show.edit.button ) if (.Platform$OS.type == "windows") options$scale.factor <- scale.factor else options$default.font <- default.font options(Rcmdr=options) closeCommander() Commander() } OKCancelHelp(helpSubject="Commander") tkgrid(tklabel(top, text=gettextRcmdr("Log commands to script window")), logCommandsCheckBox, sticky="e") tkgrid.configure(logCommandsCheckBox, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Log-font size (points)")), logFontSizeSlider, sticky="se") tkgrid.configure(logFontSizeSlider, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Log width (characters)")), logWidthSlider, sticky="se") tkgrid.configure(logWidthSlider, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Log height (lines)")), logHeightSlider, sticky="se") tkgrid.configure(logHeightSlider, sticky="w") tkgrid(tklabel(top, text=" "), sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Send output to R Console")), consoleOutputCheckBox, sticky="e") tkgrid.configure(consoleOutputCheckBox, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Output height (lines)")), outputHeightSlider, sticky="se") tkgrid.configure(outputHeightSlider, sticky="w") tkgrid(tklabel(contrastsFrame, text=gettextRcmdr("Unordered factors")), tklabel(contrastsFrame, text=" "), tklabel(contrastsFrame, text=gettextRcmdr("Ordered factors")), sticky="w") tkgrid(contrasts1Entry, tklabel(contrastsFrame, text=" "), contrasts2Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Contrasts")), contrastsFrame, sticky="se") tkgrid.configure(contrastsFrame, sticky="sw") tkgrid(tklabel(top, text=gettextRcmdr("Active window grabs focus")), grabFocusCheckBox, sticky="e") tkgrid.configure(grabFocusCheckBox, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Double-click presses OK button")), doubleClickCheckBox, sticky="e") tkgrid.configure(doubleClickCheckBox, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Sort variable names alphabetically")), sortNamesCheckBox, sticky="e") tkgrid.configure(sortNamesCheckBox, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Show edit button")), showEditButtonCheckBox, sticky="e") tkgrid.configure(showEditButtonCheckBox, sticky="w") tkconfigure(OKbutton, text=gettextRcmdr("Exit and Restart\nR Commander"), width=18) if (.Platform$OS.type == "windows"){ tkgrid(tklabel(top, text=gettextRcmdr("Scale factor for Tk elements")), scaleFactorSlider, sticky="se") tkgrid.configure(scaleFactorSlider, sticky="w") } else { tkgrid(tklabel(top, text=gettextRcmdr("Default font")), defaultFontEntry, sticky="e") tkgrid.configure(defaultFontEntry, sticky="w") } tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=11, columns=2) } loadPackages <- function(){ availablePackages <- sort(setdiff(.packages(all.available = TRUE), .packages())) if (length(availablePackages) == 0){ errorCondition(message=gettextRcmdr("No packages available to load.")) return() } initializeDialog(title=gettextRcmdr("Load Packages")) packagesBox <- variableListBox(top, availablePackages, title=gettextRcmdr("Packages (pick one or more)"), selectmode="multiple", listHeight=10) onOK <- function(){ packages <- getSelection(packagesBox) closeDialog(top) if (length(packages) == 0){ errorCondition(recall=loadPackages, message=gettextRcmdr("You must select at least one package.")) return() } for (package in packages) { command <- paste('library("', package, '", character.only=TRUE)', sep="") justDoIt(command) } Message(paste(gettextRcmdr("Packages loaded:"), paste(packages, collapse=", ")), type="note") } OKCancelHelp(helpSubject="library") tkgrid(getFrame(packagesBox), sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=1, columns=1) } # Graphs menu dialogs # last modified 24 May 2007 by J. Fox indexPlot <- function(){ initializeDialog(title=gettextRcmdr("Index Plot")) xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)")) onOK <- function(){ x <- getSelection(xBox) closeDialog() if (length(x) == 0){ errorCondition(recall=indexPlot, message=gettextRcmdr("You must select a variable")) return() } type <- if (tclvalue(typeVariable) == "spikes") "h" else "p" identify <- tclvalue(identifyVariable) == "1" .activeDataSet <- ActiveDataSet() command <- paste(x11(),"plot(", .activeDataSet, "$", x, ', type="', type, '")', sep="") doItAndPrint(command) if (par("usr")[3] <= 0) doItAndPrint('abline(h=0, col="gray")') if (identify) { RcmdrTkmessageBox(title="Identify Points", message=gettextRcmdr("Use left mouse button to identify points,\nright button to exit."), icon="info", type="ok") command <- paste("identify(", .activeDataSet, "$", x, ", labels=rownames(", .activeDataSet, "))", sep="") doItAndPrint(command) } activateMenus() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="plot") optionsFrame <- tkframe(top) typeVariable <- tclVar("spikes") spikesButton <- tkradiobutton(optionsFrame, variable=typeVariable, value="spikes") pointsButton <- tkradiobutton(optionsFrame, variable=typeVariable, value="points") identifyVariable <- tclVar("0") identifyCheckBox <- tkcheckbutton(optionsFrame, variable=identifyVariable) tkgrid(getFrame(xBox), sticky="nw") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Identify observations\nwith mouse"), justify="left"), identifyCheckBox, sticky="w") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Spikes")), spikesButton, sticky="w") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Points")), pointsButton, sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2, columns=1) } Histogram <- function(){ initializeDialog(title=gettextRcmdr("Histogram")) xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)")) onOK <- function(){ x <- getSelection(xBox) closeDialog() if (length(x) == 0){ errorCondition(recall=Histogram, message=gettextRcmdr("You must select a variable")) return() } bins <- tclvalue(binsVariable) opts <- options(warn=-1) bins <- if (bins == gettextRcmdr("")) '"Sturges"' else as.numeric(bins) options(opts) scale <- tclvalue(scaleVariable) command <- paste(x11(),"Hist(", ActiveDataSet(), "$", x, ', scale="', scale, '", breaks=', bins, ', col="darkgray")', sep="") doItAndPrint(command) activateMenus() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="Hist") radioButtons(name="scale", buttons=c("frequency", "percent", "density"), labels=gettextRcmdr(c("Frequency counts", "Percentages", "Densities")), title=gettextRcmdr("Axis Scaling")) binsFrame <- tkframe(top) binsVariable <- tclVar(gettextRcmdr("")) binsField <- tkentry(binsFrame, width="6", textvariable=binsVariable) tkgrid(getFrame(xBox), sticky="nw") tkgrid(tklabel(binsFrame, text=gettextRcmdr("Number of bins: ")), binsField, sticky="w") tkgrid(binsFrame, sticky="w") tkgrid(scaleFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") tkgrid.configure(binsField, sticky="e") dialogSuffix(rows=4, columns=1) } stemAndLeaf <- function(){ initializeDialog(title=gettextRcmdr("Stem and Leaf Display"), preventCrisp=TRUE) xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)")) displayDigits <- tclVar("1") onDigits <- function(...){ tclvalue(displayDigits) <- formatC(10^as.numeric(tclvalue(leafsDigitValue)), format="fg", big.mark=",") tclvalue(leafsAutoVariable) <- "0" } radioButtons(name="parts", buttons=c("auto", "one", "two", "five"), values=c("auto", "1", "2", "5"), labels=c(gettextRcmdr("Automatic"), " 1", " 2", " 5"), title=gettextRcmdr("Parts Per Stem")) radioButtons(name="style", buttons=c("Tukey", "bare"), labels=gettextRcmdr(c("Tukey", "Repeated stem digits")), title=gettextRcmdr("Style of Divided Stems")) checkBoxes(frame="optionsFrame", boxes=c("trimOutliers", "showDepths", "reverseNegative"), initialValues=rep(1, 3), labels=gettextRcmdr(c("Trim outliers", "Show depths", "Reverse negative leaves"))) leafsFrame <- tkframe(top) leafsDigitValue <- tclVar("0") leafsDigitSlider <- tkscale(leafsFrame, from=-6, to=6, showvalue=FALSE, variable=leafsDigitValue, resolution=1, orient="horizontal", command=onDigits) leafsDigitShow <- tklabel(leafsFrame, textvariable=displayDigits, width=8, justify="right") leafsAutoVariable <- tclVar("1") leafsDigitCheckBox <- tkcheckbutton(leafsFrame, variable=leafsAutoVariable) onOK <- function(){ x <- getSelection(xBox) closeDialog() if (length(x) == 0){ errorCondition(recall=stemAndLeaf, message=gettextRcmdr("You must select a variable")) return() } unit <- if (tclvalue(leafsAutoVariable) == "1") "" else paste(", unit=", 10^as.numeric(tclvalue(leafsDigitValue)), sep="") m <- if (tclvalue(partsVariable) == "auto") "" else paste(", m=", tclvalue(partsVariable), sep="") trim <- if (tclvalue(trimOutliersVariable) == "1") "" else ", trim.outliers=FALSE" depths <- if (tclvalue(showDepthsVariable) == "1") "" else ", depths=FALSE" reverse <- if (tclvalue(reverseNegativeVariable) == "1") "" else ", reverse.negative.leaves=FALSE" style <- if (tclvalue(styleVariable) == "Tukey") "" else ', style="bare"' command <- paste("stem.leaf(", ActiveDataSet(), "$", x, style, unit, m, trim, depths, reverse, ")", sep="") doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="stem.leaf") tkgrid(getFrame(xBox), sticky="nw") tkgrid(tklabel(leafsFrame, text=gettextRcmdr("Leafs Digit: "), fg="blue"), tklabel(leafsFrame, text=gettextRcmdr("Automatic")), leafsDigitCheckBox, tklabel(leafsFrame, text=gettextRcmdr(" or set:"), fg="red"), leafsDigitShow, leafsDigitSlider, sticky="w") tkgrid(leafsFrame, sticky="w") tkgrid(partsFrame, sticky="w") tkgrid(styleFrame, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Options"), fg="blue"), sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") tclvalue(leafsAutoVariable) <- "1" dialogSuffix(rows=7, columns=1, preventCrisp=TRUE) } boxPlot <- function(){ initializeDialog(title=gettextRcmdr("Boxplot")) xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)")) identifyVariable <- tclVar("0") identifyFrame <- tkframe(top) identifyCheckBox <- tkcheckbutton(identifyFrame, variable=identifyVariable) .groups <- FALSE onOK <- function(){ x <- getSelection(xBox) closeDialog() if (length(x) == 0){ errorCondition(recall=boxPlot, message=gettextRcmdr("You must select a variable")) return() } identifyPoints <- "1" == tclvalue(identifyVariable) .activeDataSet <- ActiveDataSet() var <- paste(.activeDataSet, "$", x, sep="") if (.groups == FALSE) { command <- (paste(x11(),"boxplot(", var, ', ylab="', x, '")', sep="")) logger(command) justDoIt(command) if (identifyPoints) { RcmdrTkmessageBox(title="Identify Points", message=gettextRcmdr("Use left mouse button to identify points,\nright button to exit."), icon="info", type="ok") doItAndPrint(paste("identify(rep(1, length(", var, ")), ", var, ", rownames(", .activeDataSet,"))", sep="")) } } else { command <- (paste(x11(),"boxplot(", x, "~", .groups, ', ylab="', x, '", xlab="', .groups,'"', ", data=", .activeDataSet, ")", sep="")) logger(command) justDoIt(command) if (identifyPoints) { RcmdrTkmessageBox(title="Identify Points", message=gettextRcmdr("Use left mouse button to identify points,\nright button to exit."), icon="info", type="ok") doItAndPrint(paste("identify(", .activeDataSet, "$", .groups, ", ", var, ", rownames(", .activeDataSet,"))", sep="")) } } activateMenus() tkfocus(CommanderWindow()) } groupsBox(boxPlot) OKCancelHelp(helpSubject="boxplot") tkgrid(getFrame(xBox), sticky="nw") tkgrid(tklabel(identifyFrame, text=gettextRcmdr("Identify outliers with mouse"), justify="left"), identifyCheckBox, sticky="w") tkgrid(identifyFrame, stick="w") tkgrid(groupsFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } scatterPlot <- function(){ require("car") initializeDialog(title=gettextRcmdr("Scatterplot")) .numeric <- Numeric() variablesFrame <- tkframe(top) xBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("x-variable (pick one)")) yBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("y-variable (pick one)")) checkBoxes(frame="optionsFrame", boxes=c("identify", "jitterX", "jitterY", "boxplots", "lsLine", "smoothLine"), initialValues=c(0, 0, 0, 1, 1, 1), labels=gettextRcmdr(c("Identify points", "Jitter x-variable", "Jitter y-variable", "Marginal boxplots", "Least-squares line", "Smooth Line"))) sliderValue <- tclVar("50") slider <- tkscale(optionsFrame, from=0, to=100, showvalue=TRUE, variable=sliderValue, resolution=5, orient="horizontal") subsetBox() labelsFrame <- tkframe(top) xlabVar <- tclVar(gettextRcmdr("")) ylabVar <- tclVar(gettextRcmdr("")) xlabFrame <- tkframe(labelsFrame) xlabEntry <- tkentry(xlabFrame, width="25", textvariable=xlabVar) xlabScroll <- tkscrollbar(xlabFrame, orient="horizontal", repeatinterval=5, command=function(...) tkxview(xlabEntry, ...)) tkconfigure(xlabEntry, xscrollcommand=function(...) tkset(xlabScroll, ...)) tkgrid(tklabel(xlabFrame, text=gettextRcmdr("x-axis label"), fg="blue"), sticky="w") tkgrid(xlabEntry, sticky="w") tkgrid(xlabScroll, sticky="ew") ylabFrame <- tkframe(labelsFrame) ylabEntry <- tkentry(ylabFrame, width="25", textvariable=ylabVar) ylabScroll <- tkscrollbar(ylabFrame, orient="horizontal", repeatinterval=5, command=function(...) tkxview(ylabEntry, ...)) tkconfigure(ylabEntry, xscrollcommand=function(...) tkset(ylabScroll, ...)) tkgrid(tklabel(ylabFrame, text=gettextRcmdr("y-axis label"), fg="blue"), sticky="w") tkgrid(ylabEntry, sticky="w") tkgrid(ylabScroll, sticky="ew") tkgrid(xlabFrame, tklabel(labelsFrame, text=" "), ylabFrame, sticky="w") parFrame <- tkframe(top) pchVar <- tclVar(gettextRcmdr("")) pchEntry <- tkentry(parFrame, width=25, textvariable=pchVar) cexValue <- tclVar("1") cex.axisValue <- tclVar("1") cex.labValue <- tclVar("1") cexSlider <- tkscale(parFrame, from=0.5, to=2.5, showvalue=TRUE, variable=cexValue, resolution=0.1, orient="horizontal") cex.axisSlider <- tkscale(parFrame, from=0.5, to=2.5, showvalue=TRUE, variable=cex.axisValue, resolution=0.1, orient="horizontal") cex.labSlider <- tkscale(parFrame, from=0.5, to=2.5, showvalue=TRUE, variable=cex.labValue, resolution=0.1, orient="horizontal") onOK <- function(){ x <- getSelection(xBox) y <- getSelection(yBox) closeDialog() if (length(x) == 0 || length(y) == 0){ errorCondition(recall=scatterPlot, message=gettextRcmdr("You must select two variables")) return() } if (x == y) { errorCondition(recall=scatterPlot, message=gettextRcmdr("x and y variables must be different")) return() } .activeDataSet <- ActiveDataSet() jitter <- if ("1" == tclvalue(jitterXVariable) && "1" == tclvalue(jitterYVariable)) ", jitter=list(x=1, y=1)" else if ("1" == tclvalue(jitterXVariable)) ", jitter=list(x=1)" else if ("1" == tclvalue(jitterYVariable)) ", jitter=list(y=1)" else "" if("1" == tclvalue(identifyVariable)){ RcmdrTkmessageBox(title="Identify Points", message=gettextRcmdr("Use left mouse button to identify points,\nright button to exit."), icon="info", type="ok") labels <- paste("rownames(", .activeDataSet, ")", sep="") } else labels <- "FALSE" box <- if ("1" == tclvalue(boxplotsVariable)) "'xy'" else "FALSE" line <- if("1" == tclvalue(lsLineVariable)) "lm" else "FALSE" smooth <- as.character("1" == tclvalue(smoothLineVariable)) span <- as.numeric(tclvalue(sliderValue)) subset <- tclvalue(subsetVariable) subset <- if (trim.blanks(subset) == gettextRcmdr("")) "" else paste(", subset=", subset, sep="") xlab <- trim.blanks(tclvalue(xlabVar)) xlab <- if(xlab == "") "" else paste(', xlab="', xlab, '"', sep="") ylab <- trim.blanks(tclvalue(ylabVar)) ylab <- if(ylab == "") "" else paste(', ylab="', ylab, '"', sep="") cex <- as.numeric(tclvalue(cexValue)) cex <- if(cex == 1) "" else paste(', cex=', cex, sep="") cex.axis <- as.numeric(tclvalue(cex.axisValue)) cex.axis <- if(cex.axis == 1) "" else paste(', cex.axis=', cex.axis, sep="") cex.lab <- as.numeric(tclvalue(cex.labValue)) cex.lab <- if(cex.lab == 1) "" else paste(', cex.lab=', cex.lab, sep="") pch <- gsub(" ", ",", tclvalue(pchVar)) if ("" == pch) { errorCondition(recall=scatterPlot, message=gettextRcmdr("No plotting characters.")) return() } pch <- if(trim.blanks(pch) == "") "" else paste(", pch=c(", pch, ")", sep="") if (.groups == FALSE) { doItAndPrint(paste(x11(),"scatterplot(", y, "~", x, ", reg.line=", line, ", smooth=", smooth, ", labels=", labels, ", boxplots=", box, ", span=", span/100, jitter, xlab, ylab, cex, cex.axis, cex.lab, pch, ", data=", .activeDataSet, subset, ")", sep="")) } else { doItAndPrint(paste(x11(),"scatterplot(", y, "~", x," | ", .groups, ", reg.line=", line, ", smooth=", smooth, ", labels=", labels, ", boxplots=", box, ", span=", span/100, jitter, xlab, ylab, cex, cex.axis, cex.lab, pch, ", by.groups=", .linesByGroup, ", data=", .activeDataSet, subset, ")", sep="")) } activateMenus() tkfocus(CommanderWindow()) } groupsBox(scatterPlot, plotLinesByGroup=TRUE) OKCancelHelp(helpSubject="scatterplot") tkgrid(getFrame(xBox), getFrame(yBox), sticky="nw") tkgrid(variablesFrame, sticky="w") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Span for smooth")), slider, sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(groupsFrame, sticky="w") tkgrid(labelsFrame, sticky="w") tkgrid(tklabel(top, text=" ")) tkgrid(tklabel(parFrame, text=gettextRcmdr("Plotting Parameters"), fg="blue"), sticky="w") tkgrid(tklabel(parFrame, text=gettextRcmdr("Plotting characters")), pchEntry, stick="w") tkgrid(tklabel(parFrame, text=gettextRcmdr("Point size")), cexSlider, sticky="w") tkgrid(tklabel(parFrame, text=gettextRcmdr("Axis text size")), cex.axisSlider, sticky="w") tkgrid(tklabel(parFrame, text=gettextRcmdr("Axis-labels text size")), cex.labSlider, sticky="w") tkgrid(parFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=8, columns=2) } scatterPlotMatrix <- function(){ require("car") initializeDialog(title=gettextRcmdr("Scatterplot Matrix")) variablesBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Select variables (three or more)"), selectmode="multiple", initialSelection=NULL) checkBoxes(frame="optionsFrame", boxes=c("lsLine", "smoothLine"), initialValues=rep(1,2), labels=gettextRcmdr(c("Least-squares lines", "Smooth lines"))) sliderValue <- tclVar("50") slider <- tkscale(optionsFrame, from=0, to=100, showvalue=TRUE, variable=sliderValue, resolution=5, orient="horizontal") radioButtons(name="diagonal", buttons=c("density", "histogram", "boxplot", "oned", "qqplot", "none"), labels=gettextRcmdr(c("Density plots", "Histograms", "Boxplots", "One-dimensional scatterplots", "Normal QQ plots", "Nothing (empty)")), title=gettextRcmdr("On Diagonal")) subsetBox() onOK <- function(){ variables <- getSelection(variablesBox) closeDialog() if (length(variables) < 3) { errorCondition(recall=scatterPlotMatrix, message=gettextRcmdr("Fewer than 3 variable selected.")) return() } line <- if("1" == tclvalue(lsLineVariable)) "lm" else "FALSE" smooth <- as.character("1" == tclvalue(smoothLineVariable)) span <- as.numeric(tclvalue(sliderValue)) diag <- as.character(tclvalue(diagonalVariable)) subset <- tclvalue(subsetVariable) subset <- if (trim.blanks(subset) == gettextRcmdr("")) "" else paste(", subset=", subset, sep="") .activeDataSet <- ActiveDataSet() if (.groups == FALSE) { command <- paste(x11(),"scatterplot.matrix(~", paste(variables, collapse="+"), ", reg.line=", line, ", smooth=", smooth, ", span=", span/100, ", diagonal = '", diag, "', data=", .activeDataSet, subset, ")", sep="") logger(command) justDoIt(command) } else { command <- paste(x11(),"scatterplot.matrix(~", paste(variables, collapse="+")," | ", .groups, ", reg.line=", line, ", smooth=", smooth, ", span=", span/100, ", diagonal= '", diag, "', by.groups=", .linesByGroup, ", data=", .activeDataSet, subset, ")", sep="") logger(command) justDoIt(command) } activateMenus() tkfocus(CommanderWindow()) } groupsBox(scatterPlot, plotLinesByGroup=TRUE) OKCancelHelp(helpSubject="scatterplot.matrix") tkgrid(getFrame(variablesBox), sticky="nw") tkgrid(optionsFrame, sticky="w") tkgrid(diagonalFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(groupsFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=6, columns=2) } barGraph <- function(){ initializeDialog(title=gettextRcmdr("Bar Graph")) variableBox <- variableListBox(top, Factors(), title=gettextRcmdr("Variable (pick one)")) onOK <- function(){ variable <- getSelection(variableBox) closeDialog() if (length(variable) == 0){ errorCondition(recall=barGraph, message=gettextRcmdr("You must select a variable")) return() } command <- paste(x11(),"barplot(table(", ActiveDataSet(), "$", variable, '), xlab="', variable, '", ylab="Frequency")', sep="") logger(command) justDoIt(command) activateMenus() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="barplot") tkgrid(getFrame(variableBox), sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2, columns=1) } pieChart <- function(){ initializeDialog(title=gettextRcmdr("Pie Chart")) variableBox <- variableListBox(top, Factors(), title=gettextRcmdr("Variable (pick one)")) onOK <- function(){ variable <- getSelection(variableBox) closeDialog() if (length(variable) == 0){ errorCondition(recall=pieChart, message=gettextRcmdr("You must select a variable")) return() } .activeDataSet <- ActiveDataSet() command <- (paste(x11(),"pie(table(", .activeDataSet, "$", variable, "), labels=levels(", .activeDataSet, "$", variable, '), main="', variable, '", col=rainbow(length(levels(', .activeDataSet, "$", variable, "))))", sep="")) logger(command) justDoIt(command) activateMenus() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="pie") tkgrid(getFrame(variableBox), sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=3, columns=1) } linePlot <- function(){ initializeDialog(title=gettextRcmdr("Line Plot")) variablesFrame <- tkframe(top) .numeric <- Numeric() xBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("x variable (pick one)")) yBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("y variables (pick one or more)"), selectmode="multiple", initialSelection=NULL) axisLabelVariable <- tclVar(gettextRcmdr("")) axisLabelFrame <- tkframe(top) axisLabelEntry <- tkentry(axisLabelFrame, width="40", textvariable=axisLabelVariable) axisLabelScroll <- tkscrollbar(axisLabelFrame, orient="horizontal", repeatinterval=5, command=function(...) tkxview(axisLabelEntry, ...)) tkconfigure(axisLabelEntry, xscrollcommand=function(...) tkset(axisLabelScroll, ...)) legendFrame <- tkframe(top) legendVariable <- tclVar("0") legendCheckBox <- tkcheckbutton(legendFrame, variable=legendVariable) onOK <- function(){ y <- getSelection(yBox) x <- getSelection(xBox) closeDialog() if (0 == length(x)) { errorCondition(recall=linePlot, message=gettextRcmdr("No x variable selected.")) return() } if (0 == length(y)) { errorCondition(recall=linePlot, message=gettextRcmdr("No y variables selected.")) return() } if (is.element(x, y)) { errorCondition(recall=linePlot, message=gettextRcmdr("x and y variables must be different.")) return() } .activeDataSet <- ActiveDataSet() .x <- na.omit(eval(parse(text=paste(.activeDataSet, "$", x, sep="")), envir=.GlobalEnv)) if (!identical(order(.x), seq(1:length(.x)))){ response <- tclvalue(RcmdrTkmessageBox(message=gettextRcmdr("x-values are not in order.\nContinue?"), icon="warning", type="okcancel", default="cancel")) if (response == "cancel") { onCancel() return() } } axisLabel <- tclvalue(axisLabelVariable) legend <- tclvalue(legendVariable) == "1" if (axisLabel == gettextRcmdr("")){ axisLabel <- if (legend) "" else if(length(y) == 1) y else paste(paste("(", 1:length(y), ") ", y, sep=""), collapse=", ") } pch <- if (length(y) == 1) ", pch=1" else "" if (legend && length(y) > 1){ mar <- par("mar") top <- 3.5 + length(y) command <- paste(".mar <- par(mar=c(", mar[1], ",", mar[2], ",", top, ",", mar[4], "))", sep="") logger(command) justDoIt(command) } command <- paste(x11(),"matplot(", .activeDataSet, "$", x, ", ", .activeDataSet, "[, ", paste("c(", paste(paste('"', y, '"', sep=""), collapse=","), ")", sep=""), '], type="b", lty=1, ylab="', axisLabel, '"', pch, ")", sep="") logger(command) justDoIt(command) if (legend && length(y) > 1){ n <- length(y) cols <- rep(1:6, 1 + n %/% 6)[1:n] logger(".xpd <- par(xpd=TRUE)") justDoIt(".xpd <- par(xpd=TRUE)") usr <- par("usr") command <- paste("legend(", usr[1], ", ", usr[4] + 1.2*top*strheight("x"), ", legend=", paste("c(", paste(paste('"', y, '"', sep=""), collapse=","), ")", sep=""), ", col=c(", paste(cols, collapse=","), "), lty=1, pch=c(", paste(paste('"', as.character(1:n), '"', sep=""), collapse=","), "))", sep="") logger(command) justDoIt(command) logger("par(mar=.mar)") justDoIt("par(mar=.mar)") logger("par(xpd=.xpd)") justDoIt("par(xpd=.xpd)") } activateMenus() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="matplot") tkgrid(getFrame(xBox), tklabel(variablesFrame, text=" "), getFrame(yBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(tklabel(axisLabelFrame, text=gettextRcmdr("Label for y-axis"), fg="blue"), sticky="w") tkgrid(axisLabelEntry, sticky="w") tkgrid(axisLabelScroll, sticky="ew") tkgrid(axisLabelFrame, sticky="w") tkgrid(tklabel(legendFrame, text=gettextRcmdr("Plot legend")), legendCheckBox, sticky="w") tkgrid(legendFrame, sticky="w") tkgrid(buttonsFrame, stick="w") dialogSuffix(rows=4, columns=1) } QQPlot <- function() # this function modified by Martin Maechler { require("car") initializeDialog(title=gettextRcmdr("Quantile-Comparison (QQ) Plot")) xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)")) onOK <- function(){ x <- getSelection(xBox) closeDialog() if (0 == length(x)) { errorCondition(recall=QQPlot, message=gettextRcmdr("You must select a variable.")) return() } dist <- tclvalue(distVariable) save <- options(warn=-1) on.exit(options=save) retryMe <- function(msg) { Message(message= msg, type="error") QQPlot() } switch(dist, "norm" = { args <- 'dist= "norm"' }, "t" = { df <- tclvalue(tDfVariable) df.num <- as.numeric(df) if (is.na(df.num) || df.num < 1) { retryMe(gettextRcmdr("df for t must be a positive number.")) return() } args <- paste('dist="t", df=', df, sep="") }, "chisq" = { df <- tclvalue(chisqDfVariable) df.num <- as.numeric(df) if (is.na(df.num) || df.num < 1) { retryMe(gettextRcmdr("df for chi-square must be a positive number.")) return() } args <- paste('dist="chisq", df=', df, sep="") }, "f" = { df1 <- tclvalue(FDf1Variable) df2 <- tclvalue(FDf2Variable) df.num1 <- as.numeric(df1) df.num2 <- as.numeric(df2) if (is.na(df.num1) || df.num1 < 1 || is.na(df.num2) || df.num2 < 1) { retryMe(gettextRcmdr("numerator and denominator \ndf for F must be positive numbers.")) return() } args <- paste('dist="f", df1=', df1, ', df2=', df2, sep="") }, ## else -- other `dist' : { dist <- tclvalue(otherNameVariable) params <- tclvalue(otherParamsVariable) args <- paste('dist="', dist,'", ', params, sep="") }) # end{switch} .activeDataSet <- ActiveDataSet() if ("1" == tclvalue(identifyVariable)){ RcmdrTkmessageBox(title="Identify Points", message=gettextRcmdr("Use left mouse button to identify points,\nright button to exit."), icon="info", type="ok") labels <- paste("rownames(", .activeDataSet, ")", sep="") } else labels <- "FALSE" command <- paste(x11(),"qq.plot", "(", .activeDataSet, "$", x, ", ", args, ", labels=", labels, ")", sep="") doItAndPrint(command) activateMenus() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qq.plot") distFrame <- tkframe(top) distVariable <- tclVar("norm") normalButton <- tkradiobutton(distFrame, variable=distVariable, value="norm") tButton <- tkradiobutton(distFrame, variable=distVariable, value="t") chisqButton <- tkradiobutton(distFrame, variable=distVariable, value="chisq") FButton <- tkradiobutton(distFrame, variable=distVariable, value="f") otherButton <- tkradiobutton(distFrame, variable=distVariable, value="other") tDfFrame <- tkframe(distFrame) tDfVariable <- tclVar("") tDfField <- tkentry(tDfFrame, width="6", textvariable=tDfVariable) chisqDfFrame <- tkframe(distFrame) chisqDfVariable <- tclVar("") chisqDfField <- tkentry(chisqDfFrame, width="6", textvariable=chisqDfVariable) FDfFrame <- tkframe(distFrame) FDf1Variable <- tclVar("") FDf1Field <- tkentry(FDfFrame, width="6", textvariable=FDf1Variable) FDf2Variable <- tclVar("") FDf2Field <- tkentry(FDfFrame, width="6", textvariable=FDf2Variable) otherParamsFrame <- tkframe(distFrame) otherParamsVariable <- tclVar("") otherParamsField <- tkentry(otherParamsFrame, width="30", textvariable=otherParamsVariable) otherNameVariable <- tclVar("") otherNameField <- tkentry(otherParamsFrame, width="10", textvariable=otherNameVariable) identifyVariable <- tclVar("0") identifyFrame <- tkframe(top) identifyCheckBox <- tkcheckbutton(identifyFrame, variable=identifyVariable) tkgrid(getFrame(xBox), sticky="nw") tkgrid(tklabel(identifyFrame, text=gettextRcmdr("Identify observations with mouse")), identifyCheckBox, sticky="w") tkgrid(identifyFrame, sticky="w") tkgrid(tklabel(distFrame, text=gettextRcmdr("Distribution"), fg="blue"), columnspan=6, sticky="w") tkgrid(tklabel(distFrame, text=gettextRcmdr("Normal")), normalButton, sticky="w") tkgrid(tklabel(tDfFrame, text=gettextRcmdr("df = ")), tDfField, sticky="w") tkgrid(tklabel(distFrame, text="t"), tButton, tDfFrame, sticky="w") tkgrid(tklabel(chisqDfFrame, text=gettextRcmdr("df = ")), chisqDfField, sticky="w") tkgrid(tklabel(distFrame, text=gettextRcmdr("Chi-square")), chisqButton, chisqDfFrame, sticky="w") tkgrid(tklabel(FDfFrame, text=gettextRcmdr("Numerator df = ")), FDf1Field, tklabel(FDfFrame, text=gettextRcmdr("Denominator df = ")), FDf2Field, sticky="w") tkgrid(tklabel(distFrame, text="F"), FButton, FDfFrame, sticky="w") tkgrid(tklabel(otherParamsFrame, text=gettextRcmdr("Specify: ")), otherNameField, tklabel(otherParamsFrame, text=gettextRcmdr("Parameters: ")), otherParamsField, sticky="w") tkgrid(tklabel(distFrame, text=gettextRcmdr("Other")), otherButton, otherParamsFrame, sticky="w") tkgrid(distFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=5, columns=1) } PlotMeans <- function(){ initializeDialog(title=gettextRcmdr("Plot Means")) groupBox <- variableListBox(top, Factors(), title=gettextRcmdr("Factors (pick one or two)"), selectmode="multiple") responseBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Response Variable (pick one)")) onOK <- function(){ groups <- getSelection(groupBox) response <- getSelection(responseBox) closeDialog() if (0 == length(groups)) { errorCondition(recall=PlotMeans, message=gettextRcmdr("No factors selected.")) return() } if (2 < length(groups)) { errorCondition(recall=PlotMeans, message=gettextRcmdr("More than two factors selected.")) return() } if (0 == length(response)) { errorCondition(recall=PlotMeans, message=gettextRcmdr("No response variable selected.")) return() } .activeDataSet <- ActiveDataSet() error.bars <- tclvalue(errorBarsVariable) level <- if (error.bars == "conf.int") paste(", level=", tclvalue(levelVariable), sep="") else "" if (length(groups) == 1) doItAndPrint(x11(),paste("plotMeans(", .activeDataSet, "$", response, ", ", .activeDataSet, "$", groups[1], ', error.bars="', error.bars, '"', level, ')', sep="")) else { if (eval(parse(text=paste("length(levels(", .activeDataSet, "$", groups[1], ")) < length(levels(", .activeDataSet, "$", groups[2], "))", sep="")))) groups <- rev(groups) doItAndPrint(paste(x11(),"plotMeans(", .activeDataSet, "$", response, ", ", .activeDataSet, "$", groups[1], ", ", .activeDataSet, "$", groups[2], ', error.bars="', error.bars, '"', level, ')', sep="")) } activateMenus() tkfocus(CommanderWindow()) } optionsFrame <- tkframe(top) errorBarsVariable <- tclVar("se") seButton <- tkradiobutton(optionsFrame, variable=errorBarsVariable, value="se") sdButton <- tkradiobutton(optionsFrame, variable=errorBarsVariable, value="sd") confIntButton <- tkradiobutton(optionsFrame, variable=errorBarsVariable, value="conf.int") noneButton <- tkradiobutton(optionsFrame, variable=errorBarsVariable, value="none") levelVariable <- tclVar("0.95") levelEntry <- tkentry(optionsFrame, width="6", textvariable=levelVariable) buttonsFrame <- tkframe(top) OKCancelHelp(helpSubject="plotMeans") tkgrid(getFrame(groupBox), getFrame(responseBox), sticky="nw") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Error Bars", fg="blue")), sticky="w") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Standard errors")), seButton, sticky="w") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Standard deviations")), sdButton, sticky="w") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Confidence intervals")), confIntButton, tklabel(optionsFrame, text=gettextRcmdr(" Level of confidence:")), levelEntry, sticky="w") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("No error bars")), noneButton, sticky="w") tkgrid(optionsFrame, columnspan=2, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=3, columns=2) } Scatter3D <- function(){ use.rgl <- options("Rcmdr")[[1]]$use.rgl if (length(use.rgl) == 0 || use.rgl) { require(rgl) require(mgcv) } initializeDialog(title=gettextRcmdr("3D Scatterplot")) variablesFrame <- tkframe(top) .numeric <- Numeric() xBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("Explanatory variables (pick two)"), selectmode="multiple", initialSelection=NULL) yBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("Response variable (pick one)")) surfacesFrame <- tkframe(top) identifyPoints <- tclVar("0") identifyPointsCheckBox <- tkcheckbutton(surfacesFrame, variable=identifyPoints) axisScales <- tclVar("1") axisScalesCheckBox <- tkcheckbutton(surfacesFrame, variable=axisScales) gridLines <- tclVar("1") gridLinesCheckBox <- tkcheckbutton(surfacesFrame, variable=gridLines) squaredResiduals <- tclVar("0") squaredResidualsCheckBox <- tkcheckbutton(surfacesFrame, variable=squaredResiduals) linearLSSurface <- tclVar("1") linearLSCheckBox <- tkcheckbutton(surfacesFrame, variable=linearLSSurface) quadLSSurface <- tclVar("0") quadLSCheckBox <- tkcheckbutton(surfacesFrame, variable=quadLSSurface) nonparSurface <- tclVar("0") nonparCheckBox <- tkcheckbutton(surfacesFrame, variable=nonparSurface) dfNonparVariable <- tclVar(gettextRcmdr("")) dfNonparField <- tkentry(surfacesFrame, width="6", textvariable=dfNonparVariable) additiveSurface <- tclVar("0") additiveCheckBox <- tkcheckbutton(surfacesFrame, variable=additiveSurface) dfAddVariable <- tclVar(gettextRcmdr("")) dfAddField <- tkentry(surfacesFrame, width="6", textvariable=dfAddVariable) ellipsoid <- tclVar("0") ellipsoidCheckBox <- tkcheckbutton(surfacesFrame, variable=ellipsoid) bgFrame <- tkframe(top) bgVariable <-tclVar("white") whiteButton <- tkradiobutton(bgFrame, variable=bgVariable, value="white") blackButton <- tkradiobutton(bgFrame, variable=bgVariable, value="black") onOK <- function(){ x <- getSelection(xBox) y <- getSelection(yBox) closeDialog() if (length(y) == 0) { errorCondition(recall=Scatter3D, message=gettextRcmdr("You must select a response variable.")) return() } if (2 != length(x)) { errorCondition(recall=Scatter3D, message=gettextRcmdr("You must select 2 explanatory variables.")) return() } if (is.element(y, x)) { errorCondition(recall=Scatter3D, message=gettextRcmdr("Response and explanatory variables must be different.")) return() } scales <- if (tclvalue(axisScales) == 1) "TRUE" else "FALSE" grid <- if (tclvalue(gridLines) == 1) "TRUE" else "FALSE" resids <- if(tclvalue(squaredResiduals) == 1) ', residuals="squares"' else ", residuals=TRUE" lin <- if(tclvalue(linearLSSurface) == 1) '"linear"' quad <- if(tclvalue(quadLSSurface) == 1) '"quadratic"' nonpar <- if (tclvalue(nonparSurface) == 1) '"smooth"' additive <- if (tclvalue(additiveSurface) == 1) '"additive"' surfaces <- c(lin, quad, nonpar, additive) nsurfaces <- length(surfaces) if (nsurfaces > 1) resids <- "" ellips <- if(tclvalue(ellipsoid) == 1) "TRUE" else "FALSE" opts <- options(warn=-1) dfNonpar <- tclvalue(dfNonparVariable) dfNonpar <- if (dfNonpar == gettextRcmdr("")) "" else paste(", df.smooth=", as.numeric(dfNonpar), sep="") dfAdd <- tclvalue(dfAddVariable) dfAdd <- if (dfAdd == gettextRcmdr("")) "" else paste(", df.additive=", as.numeric(dfAdd), sep="") options(opts) fit <- if (nsurfaces == 0) ", surface=FALSE" else if (nsurfaces == 1) paste(", fit=", surfaces, sep="") else paste(", fit=c(", paste(surfaces, collapse=","), ")", sep="") bg <- tclvalue(bgVariable) .activeDataSet <- ActiveDataSet() if (.groups != FALSE){ groups <- paste(", groups=", .activeDataSet, "$", .groups, sep="") parallel <- paste(", parallel=", .linesByGroup, sep="") } else groups <- parallel <- "" command <- paste("scatter3d(", .activeDataSet, "$", x[1], ", ", .activeDataSet, "$", y, ", ", .activeDataSet, "$", x[2], fit, resids, dfNonpar, dfAdd, groups, parallel, ', bg="', bg, '", axis.scales=', scales, ', grid=', grid, ', ellipsoid=', ellips, ', xlab="', x[1], '", ylab="', y, '", zlab="', x[2], '")', sep="") doItAndPrint(command) putRcmdr("rgl", TRUE) command <- paste("identify3d(", .activeDataSet, "$", x[1], ", ", .activeDataSet, "$", y, ", ", .activeDataSet, "$", x[2], groups, ', axis.scales=', scales, ", labels=row.names(", .activeDataSet, "))", sep="") putRcmdr("Identify3d", command) .Tcl("update") if (tclvalue(identifyPoints) == 1){ RcmdrTkmessageBox(title="Identify Points", message=gettextRcmdr("Drag right mouse button to identify points,\nclick right button to exit."), icon="info", type="ok") doItAndPrint(command) } activateMenus() tkfocus(CommanderWindow()) rgl.bringtotop() } groupsBox(Scatter3D, plotLinesByGroup=TRUE, plotLinesByGroupsText=gettextRcmdr("Parallel regression surfaces")) OKCancelHelp(helpSubject="Scatter3DDialog") tkgrid(getFrame(yBox), tklabel(variablesFrame, text=" "), getFrame(xBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(tklabel(surfacesFrame, text=gettextRcmdr("Identify observations\nwith mouse")), identifyPointsCheckBox, sticky="w") tkgrid(tklabel(surfacesFrame, text=gettextRcmdr("Show axis scales")), axisScalesCheckBox, sticky="w") tkgrid(tklabel(surfacesFrame, text=gettextRcmdr("Show surface grid lines")), gridLinesCheckBox, sticky="w") tkgrid(tklabel(surfacesFrame, text=gettextRcmdr("Show squared residuals")), squaredResidualsCheckBox, sticky="w") tkgrid(tklabel(surfacesFrame, text=gettextRcmdr("Surfaces to Fit"), fg="blue"), sticky="w") tkgrid(tklabel(surfacesFrame, text=gettextRcmdr("Linear least-squares")), linearLSCheckBox, sticky="w") tkgrid(tklabel(surfacesFrame, text=gettextRcmdr("Quadratic least-squares")), quadLSCheckBox, sticky="w") dfLabel <- tklabel(surfacesFrame, text=gettextRcmdr("df = ")) tkgrid(tklabel(surfacesFrame, text=gettextRcmdr("Smooth regression")), nonparCheckBox, dfLabel, dfNonparField, sticky="w") tkgrid.configure(dfLabel, sticky="e") tkgrid(tklabel(surfacesFrame, text=gettextRcmdr("Additive regression")), additiveCheckBox, tklabel(surfacesFrame, text=gettextRcmdr("df(each term) = ")), dfAddField, sticky="w") tkgrid(tklabel(surfacesFrame, text=gettextRcmdr("Plot 50% concentration ellipsoid")), ellipsoidCheckBox, sticky="w") tkgrid(surfacesFrame, sticky="w") tkgrid(tklabel(bgFrame, text=gettextRcmdr("Background Color"), fg="blue"), sticky="w", columnspan=2) tkgrid(tklabel(bgFrame, text=gettextRcmdr("Black")), blackButton, sticky="w") tkgrid(tklabel(bgFrame, text=gettextRcmdr("White")), whiteButton, sticky="w") tkgrid(bgFrame, sticky="w") tkgrid(groupsFrame, sticky="w") tkgrid(buttonsFrame, stick="w") dialogSuffix(rows=5, columns=1) } Identify3D <- function(){ if (0 == rgl.cur()) { Message(message=gettextRcmdr("There is no current RGL graphics device."), type="error") return() } RcmdrTkmessageBox(title="Identify Points", message=gettextRcmdr("Drag right mouse button to identify points,\nclick right button to exit."), icon="info", type="ok") command <- getRcmdr("Identify3d") doItAndPrint(command) } saveBitmap <- function(){ if (1 == dev.cur()) { Message(gettextRcmdr("There is no current graphics device to save."), type="error") return() } initializeDialog(title=gettextRcmdr("Save Graph as Bitmap")) radioButtons(name="filetype", buttons=c("png", "jpeg"), labels=c("PNG", "JPEG"), title=gettextRcmdr("Graphics File Type")) sliderFrame <- tkframe(top) widthVariable <- tclVar("500") widthSlider <- tkscale(sliderFrame, from=200, to=1000, showvalue=TRUE, variable=widthVariable, resolution=25, orient="horizontal") heightVariable <- tclVar("500") heightSlider <- tkscale(sliderFrame, from=200, to=1000, showvalue=TRUE, variable=heightVariable, resolution=25, orient="horizontal") onOK <- function(){ closeDialog() width <- tclvalue(widthVariable) height <- tclvalue(heightVariable) type <- tclvalue(filetypeVariable) if (type == "png"){ ext <- "png" filetypes <- gettextRcmdr('{"PNG Files" {".png" ".PNG"}} {"All Files" {"*"}}') initial <- "RGraph.png" } else{ ext <- "jpg" filetypes <- gettextRcmdr('{"JPEG Files" {".jpg" ".JPG" ".jpeg" ".JPEG"}} {"All Files" {"*"}}') initial <- "RGraph.jpg" } filename <- tclvalue(tkgetSaveFile(filetypes=filetypes, defaultextension=ext, initialfile=initial)) if (filename == "") return() command <- paste('dev.print(', type, ', filename="', filename, '", width=', width, ', height=', height, ')', sep="") doItAndPrint(command) Message(paste(gettextRcmdr("Graph saved to file"), filename), type="note") } OKCancelHelp(helpSubject="png") tkgrid(filetypeFrame, sticky="w") tkgrid(tklabel(sliderFrame, text=gettextRcmdr("Width (pixels)")), widthSlider, sticky="sw") tkgrid(tklabel(sliderFrame, text=gettextRcmdr("Height (pixels)")), heightSlider, sticky="sw") tkgrid(sliderFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=3, columns=1) } savePDF <- function(){ if (1 == dev.cur()) { Message(gettextRcmdr("There is no current graphics device to save."), type="error") return() } initializeDialog(title=gettextRcmdr("Save Graph as PDF/Postscript")) radioButtons(name="filetype", buttons=c("pdf", "postscript", "eps"), labels=gettextRcmdr(c("PDF", "Postscript", "Encapsulated Postscript")), title=gettextRcmdr("Graphics File Type")) sliderFrame <- tkframe(top) widthVariable <- tclVar("5") widthSlider <- tkscale(sliderFrame, from=3, to=10, showvalue=TRUE, variable=widthVariable, resolution=0.1, orient="horizontal") heightVariable <- tclVar("5") heightSlider <- tkscale(sliderFrame, from=3, to=10, showvalue=TRUE, variable=heightVariable, resolution=0.1, orient="horizontal") pointSizeVariable <- tclVar("10") pointSizeSlider <- tkscale(sliderFrame, from=6, to=14, showvalue=TRUE, variable=pointSizeVariable, resolution=1, orient="horizontal") onOK <- function(){ closeDialog() width <- tclvalue(widthVariable) height <- tclvalue(heightVariable) type <- tclvalue(filetypeVariable) pointsize <- tclvalue(pointSizeVariable) if (type == "pdf"){ ext <- "pdf" filetypes <- gettextRcmdr('{"PDF Files" {".pdf" ".PDF"}} {"All Files" {"*"}}') initial <- "RGraph.pdf" } else if (type == "postscript") { ext <- "ps" filetypes <- gettextRcmdr('{"Postscript Files" {".ps" ".PS"}} {"All Files" {"*"}}') initial <- "RGraph.ps" } else { ext <- "eps" filetypes <- gettextRcmdr('{"Encapsulated Postscript Files" {".eps" ".EPS"}} {"All Files" {"*"}}') initial <- "RGraph.eps" } filename <- tclvalue(tkgetSaveFile(filetypes=filetypes, defaultextension=ext, initialfile=initial)) if (filename == "") return() command <- if (type == "eps") paste('dev.copy2eps(file="', filename, '", width=', width, ', height=', height, ', pointsize=', pointsize, ')', sep="") else paste('dev.print(', type, ', file="', filename, '", width=', width, ', height=', height, ', pointsize=', pointsize, ')', sep="") doItAndPrint(command) Message(paste(gettextRcmdr("Graph saved to file"), filename), type="note") } OKCancelHelp(helpSubject="pdf") tkgrid(filetypeFrame, sticky="w") tkgrid(tklabel(sliderFrame, text=gettextRcmdr("Width (inches)")), widthSlider, sticky="sw") tkgrid(tklabel(sliderFrame, text=gettextRcmdr("Height (inches)")), heightSlider, sticky="sw") tkgrid(tklabel(sliderFrame, text=gettextRcmdr("Text size (points)")), pointSizeSlider, sticky="sw") tkgrid(sliderFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=3, columns=1) } saveRglGraph <- function(){ if (0 == rgl.cur()) { Message(message=gettextRcmdr("There is no current RGL graphics device to save."), type="error") return() } ext <- "png" filetypes <- gettextRcmdr('{"PNG Bitmap Files" {".png" ".PNG"}} {"All Files" {"*"}}') initial <- "RGLGraph.png" filename <- tclvalue(tkgetSaveFile(filetypes=filetypes, defaultextension=ext, initialfile=initial)) if (filename == "") return() command <- paste('rgl.snapshot("', filename, '")', sep="") doItAndPrint(command) Message(paste(gettextRcmdr("Graph saved to file"), filename), type="note") } # The following function by Richard Heiberger, with small modifications by J. Fox Xyplot <- function() { require("lattice") initializeDialog(title=gettextRcmdr("XY Conditioning Plot")) predictorBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Explanatory variables (pick one or more)"), selectmode="multiple") responseBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Response variables (pick one or more)"), selectmode="multiple") groupsBox <- variableListBox(top, Factors(), title=gettextRcmdr("Groups (pick zero or more)"), selectmode="multiple", initialSelection=FALSE) checkBoxes(frame="optionsFrame", boxes=c("auto.key", "outer"), initialValues=c(1,0), labels=gettextRcmdr(c("Automatically draw key", "Different panels for different responses"))) radioButtons(name="x.relation", buttons=c("same", "free", "sliced"), labels=gettextRcmdr(c("Identical", "Free", "Same range")), title=gettextRcmdr("X-Axis Scales in Different Panels")) radioButtons(name="y.relation", buttons=c("same", "free", "sliced"), labels=gettextRcmdr(c("Identical", "Free", "Same range")), title=gettextRcmdr("Y-Axis Scales in Different Panels")) onOK <- function() { predictor <- getSelection(predictorBox) response <- getSelection(responseBox) groups <- getSelection(groupsBox) closeDialog() if (0 == length(response)) { errorCondition(recall=Xyplot, message=gettextRcmdr("At least one response variable must be selected.")) return() } if (0 == length(predictor)) { errorCondition(recall=Xyplot, message=gettextRcmdr("At least one explanatory variable must be selected.")) return() } auto.key <- ("1" == tclvalue(auto.keyVariable)) outer <- ("1" == tclvalue(outerVariable)) x.relation <- as.character(tclvalue(x.relationVariable)) y.relation <- as.character(tclvalue(y.relationVariable)) .activeDataSet <- ActiveDataSet() xyplot.command <- paste(x11(),"xyplot(", paste(response, collapse=' + '), " ~ ", paste(predictor, collapse=' + '), if (length(groups) > 0) paste(" | ", paste(groups, collapse=' + ') ) else "", if (outer) ", outer=TRUE", if (length(groups)==0) { if (outer) paste(", layout=c(", length(predictor), ",", length(response), ")") } else { ## (length(groups)>0) if (outer) { group.levels <- prod(sapply(groups, d.f=get(.activeDataSet), function(g, d.f) length(levels(d.f[[g]])))) paste(", layout=c(", group.levels, "*", length(predictor), ",", length(response), ")", ## ", between=list(x=c(0,0, 1, 0,0), y=1)", ", between=list(x=c(", paste(rep(c(rep(0, group.levels-1), 1), length=group.levels*length(predictor)-1), collapse=","), "), y=1)") } }, if (auto.key) ", auto.key=TRUE" else "", paste(", scales=list(x=list(relation='", x.relation, "'), y=list(relation='", y.relation, "'))", sep=""), ", data=", .activeDataSet, ')', sep="") doItAndPrint(xyplot.command) activateMenus() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="xyplot") tkgrid(getFrame(predictorBox), getFrame(responseBox), sticky="nw") tkgrid(getFrame(groupsBox), sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(x.relationFrame, sticky="w") tkgrid(y.relationFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=6, columns=2) } # set the colour palette setPalette <- function() { cval <- function(x,y) -sum((x-y)^2) contrasting <- function(x) optim(rep(127, 3),cval,lower=0,upper=255,method="L-BFGS-B",y=x)$par # the following local function from Thomas Lumley via r-help convert <- function (color){ rgb <- col2rgb(color)/255 L <- c(0.2, 0.6, 0) %*% rgb ifelse(L >= 0.2, "#000060", "#FFFFA0") } env <- environment() pal <- palette() pickColor <- function(initialcolor, parent){ tclvalue(.Tcl(paste("tk_chooseColor", .Tcl.args(title = "Select a Color", initialcolor=initialcolor, parent=parent)))) } initializeDialog(title=gettextRcmdr("Set Color Palette")) hexcolor <- colorConverter(toXYZ = function(hex,...) { rgb <- t(col2rgb(hex))/255 colorspaces$sRGB$toXYZ(rgb,...) }, fromXYZ = function(xyz,...) { rgb <- colorspaces$sRGB$fromXYZ(xyz,..) rgb <- round(rgb,5) if (min(rgb) < 0 || max(rgb) > 1) as.character(NA) else rgb(rgb[1],rgb[2],rgb[3])}, white = "D65", name = "#rrggbb") cols <- t(col2rgb(pal)) hex <- convertColor(cols, from="sRGB", to=hexcolor, scale.in=255, scale.out=NULL) for (i in 1:8) assign(paste("hex", i, sep="."), hex[i], envir=env) paletteFrame <- tkframe(top) button1 <- tkbutton(paletteFrame, text=hex[1], bg = hex[1], fg=convert(hex[1]), command=function() { color <- pickColor(hex[1], parent=button1) fg <- convert(color) tkconfigure(button1, bg=color, fg=fg) assign("hex.1", color, envir=env) } ) button2 <- tkbutton(paletteFrame, text=hex[2], bg = hex[2], fg=convert(hex[2]), command=function() { color <- pickColor(hex[2], parent=button2) fg <- convert(color) tkconfigure(button2, bg=color, fg=fg) assign("hex.2", color, envir=env) } ) button3 <- tkbutton(paletteFrame, text=hex[3], bg = hex[3], fg=convert(hex[3]), command=function() { color <- pickColor(hex[3], parent=button3) fg <- convert(color) tkconfigure(button3, bg=color, fg=fg) assign("hex.3", color, envir=env) } ) button4 <- tkbutton(paletteFrame, text=hex[4], bg = hex[4], fg=convert(hex[4]), command=function() { color <- pickColor(hex[4], parent=button4) fg <- convert(color) tkconfigure(button4, bg=color, fg=fg) assign("hex.4", color, envir=env) } ) button5 <- tkbutton(paletteFrame, text=hex[5], bg = hex[5], fg=convert(hex[5]), command=function() { color <- pickColor(hex[5], parent=button5) fg <- convert(color) tkconfigure(button5, bg=color, fg=fg) assign("hex.5", color, envir=env) } ) button6 <- tkbutton(paletteFrame, text=hex[6], bg = hex[6], fg=convert(hex[6]), command=function() { color <- pickColor(hex[6], parent=button6) fg <- convert(color) tkconfigure(button6, bg=color, fg=fg) assign("hex.6", color, envir=env) } ) button7 <- tkbutton(paletteFrame, text=hex[7], bg = hex[7], fg=convert(hex[7]), command=function() { color <- pickColor(hex[7], parent=button7) fg <- convert(color) tkconfigure(button7, bg=color, fg=fg) assign("hex.7", color, envir=env) } ) button8 <- tkbutton(paletteFrame, text=hex[8], bg = hex[8], fg=convert(hex[8]), command=function() { color <- pickColor(hex[8], parent=button8) fg <- convert(color) tkconfigure(button8, bg=color, fg=fg) assign("hex.8", color, envir=env) } ) onOK <- function(){ closeDialog(top) palette(c(hex.1, hex.2, hex.3, hex.4, hex.5, hex.6, hex.7, hex.8)) Message(gettextRcmdr("Color palette reset.", type="note")) } OKCancelHelp(helpSubject="palette") tkgrid(button1, button2, button3, button4, button5, button6, button7, button8) tkgrid(paletteFrame) tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2) } # Model menu dialogs # last modified 16 May 07 by J. Fox selectActiveModel <- function(){ models <- listAllModels() .activeModel <- ActiveModel() if ((length(models) == 1) && !is.null(.activeModel)) { Message(message=gettextRcmdr("There is only one model in memory."), type="warning") tkfocus(CommanderWindow()) return() } if (length(models) == 0){ Message(message=gettextRcmdr("There are no models from which to choose."), type="error") tkfocus(CommanderWindow()) return() } initializeDialog(title=gettextRcmdr("Select Model")) .activeDataSet <- ActiveDataSet() initial <- if (is.null(.activeModel)) NULL else which(.activeModel == models) - 1 modelsBox <- variableListBox(top, models, title=gettextRcmdr("Models (pick one)"), initialSelection=initial) onOK <- function(){ model <- getSelection(modelsBox) closeDialog() if (length(model) == 0) { tkfocus(CommanderWindow()) return() } dataSet <- eval(parse(text=paste("as.character(", model, "$call$data)"))) if (length(dataSet) == 0){ errorCondition(message=gettextRcmdr("There is no dataset associated with this model.")) return() } dataSets <- listDataSets() if (!is.element(dataSet, dataSets)){ errorCondition(message=sprintf(gettextRcmdr("The dataset associated with this model, %s, is not in memory."), dataSet)) return() } if (is.null(.activeDataSet) || (dataSet != .activeDataSet)) activeDataSet(dataSet) activeModel(model) tkfocus(CommanderWindow()) } OKCancelHelp() nameFrame <- tkframe(top) tkgrid(tklabel(nameFrame, fg="blue", text=gettextRcmdr("Current Model: ")), tklabel(nameFrame, text=tclvalue(getRcmdr("modelName"))), sticky="w") tkgrid(nameFrame, sticky="w", columnspan="2") tkgrid(getFrame(modelsBox), columnspan="2", sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=3, columns=2) } summarizeModel <- function(){ .activeModel <- ActiveModel() if (!checkMethod("summary", .activeModel)) return() doItAndPrint(paste("summary(", .activeModel, ", cor=FALSE)", sep="")) } plotModel <- function(){ .activeModel <- ActiveModel() if (!checkMethod("plot", .activeModel)) return() command <- "oldpar <- par(oma=c(0,0,3,0), mfrow=c(2,2))" justDoIt(command) logger(command) doItAndPrint(paste(x11(),"plot(", .activeModel, ")", sep="")) command <- "par(oldpar)" justDoIt(command) logger(command) } CRPlots <- function(){ require("car") .activeModel <- ActiveModel() if (!checkMethod("cr.plot", .activeModel)) return() doItAndPrint(paste(x11(),"cr.plots(", .activeModel, ", ask=FALSE)", sep="")) activateMenus() } AVPlots <- function(){ require("car") .activeModel <- ActiveModel() if (!checkMethod("av.plot", .activeModel)) return() response <- tclvalue(RcmdrTkmessageBox(message=gettextRcmdr("Identify points with mouse?"), icon="question", type="yesno", default="no")) doItAndPrint(paste(x11(),"av.plots(", .activeModel, ", ask=FALSE, identify.points=", response=="yes", ")", sep="")) activateMenus() } anovaTable <- function(){ require("car") .activeModel <- ActiveModel() if (!checkMethod("Anova", .activeModel)) { errorCondition(message=gettextRcmdr("There is no appropriate Anova method for a model of this class.")) return() } doItAndPrint(paste("Anova(", .activeModel, ")", sep="")) } VIF <- function(){ require("car") .activeModel <- ActiveModel() if (!checkMethod("vif", .activeModel)) return() doItAndPrint(paste("vif(", .activeModel, ")", sep="")) } InfluencePlot <- function(){ require("car") .activeModel <- ActiveModel() if (!checkMethod("influencePlot", .activeModel)) return() response <- tclvalue(RcmdrTkmessageBox(message=gettextRcmdr("Identify points with mouse?"), icon="question", type="yesno", default="no")) labels <- if (response == "no") ", labels=FALSE" else "" doItAndPrint(paste(x11(),"influencePlot(", .activeModel, labels, ")", sep="")) } effectPlots <- function(){ require("effects") .activeModel <- ActiveModel() if (!checkMethod("effect", .activeModel)) return() doItAndPrint('trellis.device(theme="col.whitebg")') command <- paste("plot(all.effects(", .activeModel, "), ask=FALSE)", sep="") justDoIt(command) logger(command) activateMenus() NULL } addObservationStatistics <- function(){ addVariable <- function(name){ variable <- paste(.activeModel, ".", name, sep="") if (is.element(variable, .variables)) { ans <- checkReplace(variable) if (tclvalue(ans) == "no") return() } command <- paste(name, "(", .activeModel, ")", sep="") justDoIt(paste(.activeDataSet, "$", variable, " <- ", command, sep="")) logger(paste(.activeDataSet, "$", variable, " <- ", command, sep="")) } if (getRcmdr("modelWithSubset")){ Message(message= gettextRcmdr("Observation statistics not available\nfor a model fit to a subset of the data."), type="error") tkfocus(.commander) return() } initializeDialog(title=gettextRcmdr("Add Observation Statistics to Data")) .activeModel <- ActiveModel() .activeDataSet <- ActiveDataSet() .variables <- Variables() obsNumberExists <- is.element("obsNumber", .variables) activate <- c( checkMethod("fitted", .activeModel, default=TRUE, reportError=FALSE), checkMethod("residuals", .activeModel, default=TRUE, reportError=FALSE), checkMethod("rstudent", .activeModel, reportError=FALSE), checkMethod("hatvalues", .activeModel, reportError=FALSE), checkMethod("cooks.distance", .activeModel, reportError=FALSE)) checkBoxes(frame="selectFrame", boxes=c(c("fitted", "residuals", "rstudent", "hatvalues", "cookd")[activate], "obsNumbers"), initialValues=c(rep(1, sum(activate)), if(obsNumberExists) "0" else "1"), labels=c(gettextRcmdr(c("Fitted values", "Residuals", "Studentized residuals", "Hat-values", "Cook's distances"))[activate], gettextRcmdr("Observation indices"))) onOK <- function(){ closeDialog() if (activate[1] && tclvalue(fittedVariable) == 1) addVariable("fitted") if (activate[2] && tclvalue(residualsVariable) == 1) addVariable("residuals") if (activate[3] && tclvalue(rstudentVariable) == 1) addVariable("rstudent") if (activate[4] && tclvalue(hatvaluesVariable) == 1) addVariable("hatvalues") if (activate[5] && tclvalue(cookdVariable) == 1) addVariable("cooks.distance") if (tclvalue(obsNumbersVariable) == 1){ proceed <- if (obsNumberExists) tclvalue(checkReplace("obsNumber")) else "yes" if (proceed == "yes") { command <- paste(.activeDataSet, "$obsNumber <- 1:nrow(", .activeDataSet, ")", sep="") justDoIt(command) logger(command) } } activeDataSet(.activeDataSet, flushModel=FALSE) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="influence.measures") tkgrid(selectFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=5, columns=1) } residualQQPlot <- function(){ require("car") .activeModel <- ActiveModel() if (!checkMethod("qq.plot", .activeModel)) return() initializeDialog(title=gettextRcmdr("Residual Quantile-Comparison Plot")) selectFrame <- tkframe(top) simulateVar <- tclVar("1") identifyVar <- tclVar("0") simulateCheckBox <- tkcheckbutton(selectFrame, variable=simulateVar) identifyCheckBox <- tkcheckbutton(selectFrame, variable=identifyVar) onOK <- function(){ closeDialog() simulate <- tclvalue(simulateVar) == 1 identify <- if (tclvalue(identifyVar) == 1) paste("names(residuals(", .activeModel, "))", sep="") else "FALSE" command <- paste(x11(),"qq.plot(", .activeModel, ", simulate=", simulate, ", labels=", identify, ")", sep="") doItAndPrint(command) activateMenus() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="qq.plot.lm") tkgrid(tklabel(selectFrame, text=gettextRcmdr("Simulated confidence envelope")), simulateCheckBox, sticky="w") tkgrid(tklabel(selectFrame, text=gettextRcmdr("Identify points with mouse")), identifyCheckBox, sticky="w") tkgrid(selectFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2, columns=1) } testLinearHypothesis <- function(){ require("car") .activeModel <- ActiveModel() if (!checkMethod("linear.hypothesis", .activeModel)) return() env <- environment() initializeDialog(title=gettextRcmdr("Test Linear Hypothesis")) outerTableFrame <- tkframe(top) assign(".tableFrame", tkframe(outerTableFrame), envir=env) setUpTable <- function(...){ tkdestroy(get(".tableFrame", envir=env)) assign(".tableFrame", tkframe(outerTableFrame), envir=env) nrows <- as.numeric(tclvalue(rowsValue)) col.names <- eval(parse(text=paste("names(coef(", .activeModel, "))"))) col.names <- substring(paste(abbreviate(col.names, 12), " "), 1, 12) make.col.names <- "tklabel(.tableFrame, text='')" for (j in 1:ncols) { make.col.names <- paste(make.col.names, ", ", "tklabel(.tableFrame, text='", col.names[j], "')", sep="") } rhsText <- gettextRcmdr("Right-hand side") make.col.names <- paste(make.col.names, ", tklabel(.tableFrame, text=' ')", ", tklabel(.tableFrame, text='", rhsText, "')", sep="") eval(parse(text=paste("tkgrid(", make.col.names, ")", sep="")), envir=env) for (i in 1:nrows){ varname <- paste(".tab.", i, ".1", sep="") rhs.name <- paste(".rhs.", i, sep="") assign(varname, tclVar("0") , envir=env) assign(rhs.name, tclVar("0"), envir=env) make.row <- paste("tklabel(.tableFrame, text=", i, ")") make.row <- paste(make.row, ", ", "tkentry(.tableFrame, width='5', textvariable=", varname, ")", sep="") for (j in 2:ncols){ varname <- paste(".tab.", i, ".", j, sep="") assign(varname, tclVar("0"), envir=env) make.row <- paste(make.row, ", ", "tkentry(.tableFrame, width='5', textvariable=", varname, ")", sep="") } make.row <- paste(make.row, ", tklabel(.tableFrame, text=' '),", "tkentry(.tableFrame, width='5', textvariable=", rhs.name, ")", sep="") eval(parse(text=paste("tkgrid(", make.row, ")", sep="")), envir=env) } tkgrid(get(".tableFrame", envir=env), sticky="w") } ncols <- eval(parse(text=paste("length(coef(", .activeModel, "))"))) rowsFrame <- tkframe(top) rowsValue <- tclVar("1") rowsSlider <- tkscale(rowsFrame, from=1, to=ncols, showvalue=FALSE, variable=rowsValue, resolution=1, orient="horizontal", command=setUpTable) rowsShow <- tklabel(rowsFrame, textvariable=rowsValue, width=2, justify="right") onOK <- function(){ nrows <- as.numeric(tclvalue(rowsValue)) cell <- 0 values <- rep(NA, nrows*ncols) rhs <- rep(NA, nrows) for (i in 1:nrows){ rhs.name <- paste(".rhs.", i, sep="") rhs[i] <- as.numeric(eval(parse(text=paste("tclvalue(", rhs.name,")", sep="")))) for (j in 1:ncols){ cell <- cell+1 varname <- paste(".tab.", i, ".", j, sep="") values[cell] <- as.numeric(eval(parse(text=paste("tclvalue(", varname,")", sep="")))) } } values <- na.omit(values) closeDialog() if (length(values) != nrows*ncols){ Message(message=sprintf(gettextRcmdr("Number of valid entries in hypothesis matrix(%d)\nnot equal to number of rows (%d) * number of columns (%d)."), length(values), nrows, ncols), type="error") testLinearHypothesis() return() } if (qr(matrix(values, nrows, ncols, byrow=TRUE))$rank < nrows) { Message(message=gettextRcmdr("Hypothesis matrix is not of full row rank."), type="error") testLinearHypothesis() return() } rhs <- na.omit(rhs) if (length(rhs) != nrows){ errorCondition(recall=testLinearHypothesis, message=sprintf(gettextRcmdr("Number of valid entries in rhs vector (%d)\nis not equal to number of rows (%d)."), length(rhs), nrows)) return() } command <- paste("matrix(c(", paste(values, collapse=","), "), ", nrows, ", ", ncols, ", byrow=TRUE)", sep="") assign(".Hypothesis", justDoIt(command), envir=.GlobalEnv) logger(paste(".Hypothesis <- ", command, sep="")) command <- paste("c(", paste(rhs, collapse=","), ")", sep="") assign(".RHS", justDoIt(command), envir=.GlobalEnv) logger(paste(".RHS <- ", command, sep="")) command <- paste("linear.hypothesis(", .activeModel, ", .Hypothesis, rhs=.RHS)", sep="") doItAndPrint(command) justDoIt("remove(.Hypothesis, .RHS, envir=.GlobalEnv)") logger("remove(.Hypothesis, .RHS)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="linear.hypothesis") tkgrid(tklabel(rowsFrame, text=gettextRcmdr("Number of Rows:")), rowsSlider, rowsShow, sticky="w") tkgrid(rowsFrame, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Enter hypothesis matrix and right-hand side vector:"), fg="blue"), sticky="w") tkgrid(outerTableFrame, sticky="w") tkgrid(tklabel(top, text="")) tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } compareModels <- function(){ models <- listAllModels() if (length(models) < 2){ Message(message=gettextRcmdr("There are fewer than two models."), type="error") tkfocus(CommanderWindow()) return() } initializeDialog(title=gettextRcmdr("Compare Models")) modelsBox1 <- variableListBox(top, models, title=gettextRcmdr("First model (pick one)")) modelsBox2 <- variableListBox(top, models, title=gettextRcmdr("Second model (pick one)")) onOK <- function(){ model1 <- getSelection(modelsBox1) model2 <- getSelection(modelsBox2) closeDialog() if (length(model1) == 0 || length(model2) == 0) { errorCondition(recall=compareModels, message=gettextRcmdr("You must select two models.")) return() } if (!checkMethod("anova", model1)) { return() } if (!eval(parse(text=paste("class(", model1, ")[1] == class(", model2, ")[1]", sep="")), envir=.GlobalEnv)){ Message(message=gettextRcmdr("Models are not of the same class."), type="error") compareModels() return() } doItAndPrint(paste("anova(", model1, ",", model2, ")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="anova") tkgrid(getFrame(modelsBox1), getFrame(modelsBox2), sticky="nw") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=2, columns=2) } BreuschPaganTest <- function(){ require("lmtest") initializeDialog(title=gettextRcmdr("Breusch-Pagan Test")) tkgrid(tklabel(top, text=gettextRcmdr("Score Test for Nonconstant Error Variance"), fg="blue"), sticky="w") optionsFrame <- tkframe(top) onOK <- function(){ .activeModel <- ActiveModel() var <- tclvalue(varVariable) closeDialog() type <- if (var == "fitted") paste(", varformula = ~ fitted.values(", .activeModel, ")", sep="") else if (var == "predictors") "" else paste(", varformula = ~", tclvalue(rhsVariable), sep="") student <- if (tclvalue(studentVariable) == 1) "TRUE" else "FALSE" model.formula <- as.character(eval(parse(text=paste("formula(", .activeModel, ")", sep="")))) model.formula <- paste(model.formula[2], "~", model.formula[3]) command <- paste("bptest(", model.formula, type, ", studentize=", student, ", data=", ActiveDataSet(), ")", sep="") doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="bptest") studentVariable <- tclVar("0") studentFrame <- tkframe(optionsFrame) studentCheckBox <- tkcheckbutton(studentFrame, variable=studentVariable) tkgrid(tklabel(studentFrame, text=gettextRcmdr("Studentized test statistic"), justify="left"), studentCheckBox, sticky="w") tkgrid(studentFrame, sticky="w") radioButtons(optionsFrame, name="var", buttons=c("fitted", "predictors", "other"), labels=gettextRcmdr(c("Fitted values", "Explanatory variables", "Other (specify)")), title=gettextRcmdr("Variance Formula")) tkgrid(varFrame, sticky="w") modelFormula(optionsFrame, hasLhs=FALSE) tkgrid(formulaFrame, sticky="w") tkgrid(outerOperatorsFrame) tkgrid(getFrame(xBox), sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } DurbinWatsonTest <- function(){ require("lmtest") initializeDialog(title=gettextRcmdr("Durbin-Waton Test")) tkgrid(tklabel(top, text=gettextRcmdr("Test for First-Order Error Autocorrelation"), fg="blue"), sticky="w") onOK <- function(){ altHypothesis <- tclvalue(altHypothesisVariable) closeDialog() model.formula <- as.character(eval(parse(text=paste("formula(", ActiveModel(), ")", sep="")))) model.formula <- paste(model.formula[2], "~", model.formula[3]) command <- paste("dwtest(", model.formula, ', alternative="', altHypothesis, '", data=', ActiveDataSet(), ')', sep="") doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="dwtest") radioButtons(name="altHypothesis", buttons=c("greater", "notequal", "less"), values=c("greater", "two.sided", "less"), labels=c("rho > 0", "rho != 0", "rho < 0"), title=gettextRcmdr("Alternative Hypothesis")) tkgrid(altHypothesisFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=3, columns=1) } RESETtest <- function(){ require("lmtest") initializeDialog(title=gettextRcmdr("RESET Test")) tkgrid(tklabel(top, text=gettextRcmdr("Test for Nonlinearity"), fg="blue"), sticky="w") onOK <- function(){ type <- tclvalue(typeVariable) square <- tclvalue(squareVariable) cube <- tclvalue(cubeVariable) closeDialog() model.formula <- as.character(eval(parse(text=paste("formula(", ActiveModel(), ")", sep="")))) model.formula <- paste(model.formula[2], "~", model.formula[3]) if (square == "0" && cube == "0"){ errorCondition(recall=RESETtest, message=gettextRcmdr("No powers are checked.")) return() } powers <- if (square == "1" && cube == "1") "2:3" else if (square == "1" && cube == "0") "2" else if (square == "0" && cube == "1") "3" command <- paste("resettest(", model.formula, ", power=", powers, ', type="', type, '", data=', ActiveDataSet(), ')', sep="") doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="reset") optionsFrame <- tkframe(top) squareVariable <- tclVar("1") squareCheckBox <- tkcheckbutton(optionsFrame, variable=squareVariable) cubeVariable <- tclVar("1") cubeCheckBox <- tkcheckbutton(optionsFrame, variable=cubeVariable) typeVariable <- tclVar("regressor") radioButtons(optionsFrame, name="type", buttons=c("regressor", "fitted", "princomp"), labels=gettextRcmdr(c("Explanatory variables", "Fitted values", "First principal component")), title=gettextRcmdr("Type of Test")) tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Powers to Include"), fg="blue"), sticky="w") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("2 (squares)")), squareCheckBox, sticky="w") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("3 (cubes) ")), cubeCheckBox, sticky="w") tkgrid(typeFrame, sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=3, columns=1) } outlierTest <- function(){ require("car") .activeModel <- ActiveModel() if (!checkMethod("outlier.test", .activeModel)) { errorCondition(gettextRcmdr("There is no appropriate outlier.test method for a model of this class.")) return() } doItAndPrint(paste("outlier.test(", .activeModel, ")", sep="")) } confidenceIntervals <- function(){ require(MASS) initializeDialog(title=gettextRcmdr("Confidence Intervals")) tkgrid(tklabel(top, text=gettextRcmdr("Confidence Intervals for Individual Coefficients"), fg="blue"), sticky="w") onOK <- function(){ level <- tclvalue(confidenceLevel) opts <- options(warn=-1) lev <- as.numeric(level) options(opts) closeDialog() if ((is.na(lev)) || (lev < 0) || (lev > 1)) { Message(gettextRcmdr("Confidence level must be a number between 0 and 1.")) tkfocus(CommanderWindow()) return() } command <- if (glm) paste("Confint(", .activeModel, ", level=", level, ', type="', tclvalue(typeVariable), '")', sep="") else paste("Confint(", .activeModel, ", level=", level, ")", sep="") doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="Confint") confidenceFrame <- tkframe(top) confidenceLevel <- tclVar(".95") confidenceField <- tkentry(confidenceFrame, width="6", textvariable=confidenceLevel) radioButtons(top, name="type", buttons=c("LR", "Wald"), labels=gettextRcmdr(c("Likelihood-ratio statistic", "Wald statistic")), title=gettextRcmdr("Test Based On")) tkgrid(tklabel(confidenceFrame, text=gettextRcmdr("Confidence Level: ")), confidenceField, sticky="w") tkgrid(confidenceFrame, sticky="w") .activeModel <- ActiveModel() glm <- eval(parse(text=paste("class(", .activeModel, ")")))[1] == "glm" if (glm) tkgrid(typeFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=3 + glm, columns=1) } ordinalRegressionModel <- function(){ require("MASS") initializeDialog(title=gettextRcmdr("Ordinal Regression Model")) .activeModel <- ActiveModel() .activeDataSet <- ActiveDataSet() currentModel <- if (!is.null(.activeModel)) eval(parse(text=paste("class(", .activeModel, ")[1] == 'polr'", sep="")), envir=.GlobalEnv) else FALSE if (currentModel) { currentFields <- formulaFields(eval(parse(text=.activeModel), envir=.GlobalEnv)) if (currentFields$data != .activeDataSet) currentModel <- FALSE } UpdateModelNumber() modelName <- tclVar(paste("OrdRegModel.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- tkentry(modelFrame, width="20", textvariable=modelName) radioButtons(name="modelType", buttons=c("logistic", "probit", "cloglog", "cauchit"), labels=gettextRcmdr(c("Proportional-odds logit", "Ordered probit", "Ordered complementary log-log", "Ordered cauchit")), title=gettextRcmdr("Type of Model")) onOK <- function(){ modelValue <- trim.blanks(tclvalue(modelName)) closeDialog() if (!is.valid.name(modelValue)){ errorCondition(recall=proportionalOddsModel, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE) return() } subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("") || trim.blanks(subset) == ""){ subset <- "" putRcmdr("modelWithSubset", FALSE) } else{ subset <- paste(", subset=", subset, sep="") putRcmdr("modelWithSubset", TRUE) } check.empty <- gsub(" ", "", tclvalue(lhsVariable)) if ("" == check.empty) { errorCondition(recall=proportionalOddsModel, message=gettextRcmdr("Left-hand side of model empty."), model=TRUE) return() } check.empty <- gsub(" ", "", tclvalue(rhsVariable)) if ("" == check.empty) { errorCondition(recall=proportionalOddsModel, message=gettextRcmdr("Right-hand side of model empty."), model=TRUE) return() } if (!is.factor(eval(parse(text=tclvalue(lhsVariable)), envir=eval(parse(text=.activeDataSet), envir=.GlobalEnv)))){ errorCondition(recall=proportionalOddsModel, message=gettextRcmdr("Response variable must be a factor")) return() } if (is.element(modelValue, listProportionalOddsModels())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) proportionalOddsModel() return() } } formula <- paste(tclvalue(lhsVariable), tclvalue(rhsVariable), sep=" ~ ") command <- paste("polr(", formula, ', method="', tclvalue(modelTypeVariable), '", data=', .activeDataSet, subset, ", Hess=TRUE)", sep="") logger(paste(modelValue, " <- ", command, sep="")) assign(modelValue, justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste("summary(", modelValue, ")", sep="")) activeModel(modelValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="polr", model=TRUE) tkgrid(tklabel(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w") tkgrid(modelFrame, sticky="w") modelFormula() subsetBox(model=TRUE) tkgrid(getFrame(xBox), sticky="w") tkgrid(outerOperatorsFrame, sticky="w") tkgrid(formulaFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(modelTypeFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1, focus=lhsEntry, preventDoubleClick=TRUE) } # SciViews specific R Commander code # last modified 19 April 2005 by Ph. Grosjean # small fix to call to list.files() by J. Fox 17 Jan 05 # modifications 18 Feb 06 by J. Fox is.SciViews <- function() { # SciViews defines the option "SciViews.version". # So, we test if we are in SciViews this way: res <- !is.null(getOption("SciViews.version")) res } is.SciViews.TclTk <- function() { # Determine if a TclTk-communicating SciViews client is currently running res <- (!is.null(getOption("SciViews.TclTk")) && getOption("SciViews.TclTk") == TRUE) res } tkfocus <- function(...){ # A call to tcltk:::tkfocus() causes a GPF in SciViews # => replaced by this version that check if we are in SciViews or not if (!is.SciViews()) tcltk:::tkfocus(...) } svCommander <- function(Version = "1.1-0"){ # The SciViews specific Commander() function if (is.SciViews()) { # TO DO: automatically generate the menu from "Rcmdr-menus.txt" # Display the R commander menu #... setOption <- function(option, default, global=TRUE) { opt <- if (is.null(current[[option]])) default else current[[option]] if (global) putRcmdr(option, opt) else opt } etc <- file.path(.path.package(package="Rcmdr")[1], "etc") # Do NOT sink error messages! #assign(".messages.connection", textConnection(".messages", open = "w"), envir=.GlobalEnv) #sink(.messages.connection, type="message") messageTag(reset=TRUE) putRcmdr("RcmdrVersion", Version) #putRcmdr("length.messages", 0) putRcmdr(".activeDataSet", NULL) putRcmdr(".activeModel", NULL) putRcmdr("logFileName", NULL) putRcmdr("outputFileName", NULL) putRcmdr("saveFileName", NULL) putRcmdr("modelNumber", 0) putRcmdr("rgl", FALSE) current <- options("Rcmdr")[[1]] setOption("log.font.size", if (.Platform$OS.type == "windows") 10 else 12) putRcmdr("logFont", tkfont.create(family="courier", size=getRcmdr("log.font.size"))) putRcmdr("operatorFont", tkfont.create(family="courier", size=getRcmdr("log.font.size"))) scale.factor <- current$scale.factor if (!is.null(scale.factor)) .Tcl(paste("tk scaling ", scale.factor, sep="")) if (packageAvailable("car")) { require("car") setOption("contrasts", c("contr.Treatment", "contr.poly")) } else setOption("contrasts", c("contr.treatment", "contr.poly")) setOption("log.commands", TRUE) #assign("logCommands", if (log.commands) tclVar("1") else tclVar("0")) setOption("console.output", TRUE) # Must be set to TRUE for SciViews app! log.height <- as.character(setOption("log.height", if (!getRcmdr("log.commands")) 0 else 10, global=FALSE)) log.width <- as.character(setOption("log.width", 80, global=FALSE)) output.height <- as.character(setOption("output.height", if (getRcmdr("console.output")) 0 else if ((as.numeric(log.height) != 0) || (!getRcmdr("log.commands"))) 2*as.numeric(log.height) else 20, global=FALSE)) setOption("output.height", output.height) putRcmdr("saveOptions", options(warn=1, contrasts=getRcmdr("contrasts"), width=as.numeric(log.width), na.action="na.exclude", graphics.record=TRUE)) setOption("double.click", FALSE) setOption("sort.names", TRUE) setOption("grab.focus", TRUE) setOption("attach.data.set", FALSE) setOption("log.text.color", "black") setOption("command.text.color", "red") setOption("output.text.color", "darkblue") setOption("error.text.color", "red") setOption("warning.text.color", "darkgreen") setOption("multiple.select.mode", "extended") setOption("suppress.X11.warnings", .Platform$GUI == "X11") # to address problem in Linux setOption("showData.threshold", 100) setOption("retain.messages", FALSE) setOption("crisp.dialogs", (.Platform$OS.type == "windows") && (getRversion() >= "2.1.1")) if (.Platform$OS.type != "windows") { putRcmdr("oldPager", options(pager=RcmdrPager)) default.font.size <- as.character(setOption("default.font.size", 12, global=FALSE)) default.font <- setOption("default.font", paste("*helvetica-medium-r-normal-*-", default.font.size, "*", sep=""), global=FALSE) .Tcl(paste("option add *font ", default.font, sep="")) } #if (getRcmdr("crisp.dialogs")) tclServiceMode(on=FALSE) #if (getRcmdr("suppress.X11.warnings")) { # putRcmdr("messages.connection", textConnection(".messages", open = "w", local=FALSE)) # sink(getRcmdr("messages.connection"), type="message") # putRcmdr("length.messages", 0) # } putRcmdr("commanderWindow", NULL) .commander <- NULL placement <- setOption("placement", "-40+20", global=FALSE) # source.files <- list.files(etc, pattern="\\.R$") # duplicate line commented out by J. Fox # .commander.done <<- tclVar("0") # source.files <- list.files(etc, pattern="\\.[Rr]$") # for (file in source.files) { # source(file.path(etc, file)) # cat(paste("Sourced:", file, "\n")) # } # Menus <- read.table(file.path(etc, "Rcmdr-menus.txt"), as.is=TRUE) # TO DO: we need another treatment for this! #for (m in 1:nrow(Menus)){ # if (Menus[m, 1] == "menu") assign(Menus[m, 2], tkmenu(eval(parse(text=Menus[m, 3])), tearoff=FALSE)) # else if (Menus[m, 1] == "item") { # if (Menus[m, 3] == "command") # tkadd(eval(parse(text=Menus[m, 2])),"command", label=Menus[m, 4], command=eval(parse(text=Menus[m, 5]))) # else if (Menus[m, 3] == "cascade") # tkadd(eval(parse(text=Menus[m, 2])),"cascade", label=Menus[m, 4], menu=eval(parse(text=Menus[m, 5]))) # else stop(paste("menu defintion error:", Menus[m, ], collapse=" ")) # } # else stop(paste("menu defintion error:", Menus[m, ], collapse=" ")) # } putRcmdr("Menus", list()) exceptions <- scan(file.path(etc, "log-exceptions.txt"), what="", quiet=TRUE, comment.char="#") putRcmdr("modelClasses", scan(file.path(etc, "model-classes.txt"), what="", quiet=TRUE, comment.char="#")) putRcmdr("dataSetName", tclVar("")) putRcmdr("dataSetLabel", NULL) putRcmdr("logWindow", NULL) putRcmdr("outputWindow", NULL) putRcmdr("messagesWindow", NULL) putRcmdr("modelName", tclVar("")) putRcmdr("modelLabel", NULL) show.edit.button <- options("Rcmdr")[[1]]$show.edit.button show.edit.button <- if (is.null(show.edit.button)) TRUE else show.edit.button if (!packageAvailable("rgl")) Message(gettextRcmdr("The rgl package is absent; 3D plots are unavailable."), type="warning") Message(paste(gettextRcmdr("R Commander Version "), getRcmdr("RcmdrVersion"), ": ", date(), sep="")) } } svlogger <- function(command){ # the SciViews specific logger() function if (is.SciViews()) { # Behaviour is different if it is a TclTk communicating client, # or a plug if (is.SciViews.TclTk()) { # TclTk SciViews client getTemp <- function(x, default = NULL, mode="any") { if (exists(x, envir = TempEnv(), mode = mode, inherits = FALSE)) { return(get(x, envir = TempEnv(), mode = mode, inherits = FALSE)) } else { # Variable not found, return the default value return(default) } } if (getRcmdr("log.commands")) { CmdFun <- getTemp(".guiCmd", mode = "function") if (!is.null(CmdFun)) CmdFun(paste("<<< Rcmdr >", line, "\n")) command } else { # plug SciViews client lines <- strsplit(command, "\n")[[1]] for (line in lines) { cat(paste("<<<>>> ", line, " #[R-cmdr]\n", sep="")) if (getRcmdr("log.commands")) cat(paste("<<< 0) sink(type="output") # Make sure output is not diverted! type <- match.arg(type) type <- type[1] if (type == "note") return() # Currently we display nothing if it is a note! if (type != "note") tkbell() prefix <- switch(type, error="Rcmdr Error", warning="Rcmdr Warning", note="Rcmdr Note", "Rcmdr") if (missing(message)) return() message <- paste(prefix, ": ", message, sep="") lines <- strsplit(message, "\n")[[1]] for (line in lines) cat(line, "\n") return(NULL) } activeDataSetEdit <- function() { # This is SciViews equivalent to onEdit function of Commander() if (activeDataSet() == FALSE) return() .activeDataSet <- ActiveDataSet() command <- paste("fix(", .activeDataSet, ")", sep="") justDoIt(command) svlogger(command) activeDataSet(.activeDataSet) invisible() } activeDataSetView <- function() { # This is SciViews equivalent to onView function of Commander() if (activeDataSet() == FALSE) { return() } view.height <- 30 #max(as.numeric(output.height) + as.numeric(log.height), 10) ncols <- eval(parse(text=paste("ncol(", ActiveDataSet(), ")"))) command <- if (packageAvailable("relimp") && ncols <= getRcmdr("showData.threshold")){ require("relimp") paste("showData(", ActiveDataSet(), ", placement='-20+200', font=getRcmdr('logFont'), maxwidth=", 80, ", maxheight=", view.height, ")", sep="") } else paste("invisible(edit(", ActiveDataSet(), "))", sep="") justDoIt(command) invisible(svlogger(command)) } optionLogCommand <- function() { # Change log option in SciViews response <- tclvalue(tkmessageBox(message="Log R-cmdr commands in a script?", icon="question", type="yesno", default="yes")) val <- if (response == "yes") TRUE else FALSE putRcmdr("log.commands", val) Opts <- options("Rcmdr")[[1]] Opts$log.commands <- val options(Rcmdr=Opts) refreshStatus() } optionAttachDataSet <- function() { # Change attach option in SciViews response <- tclvalue(tkmessageBox(message="Attach active data set?", icon="question", type="yesno", default="yes")) val <- if (response == "yes") TRUE else FALSE putRcmdr("attach.data.set", val) Opts <- options("Rcmdr")[[1]] Opts$attach.data.set <- val options(Rcmdr=Opts) refreshStatus() } optionSortVariables <- function() { # Change sort variable names option response <- tclvalue(tkmessageBox(message="Sort variable names alphabetically?", icon="question", type="yesno", default="yes")) val <- if (response == "yes") TRUE else FALSE putRcmdr("sort.names", val) Opts <- options("Rcmdr")[[1]] Opts$sort.names <- val options(Rcmdr=Opts) refreshStatus() } refreshStatus <- function() { # Refresh dataset and model indication in the status bar of SciViews Client DataSet <- ActiveDataSet() if (is.null(DataSet) || length(DataSet) == 0) DataSet <- "" Model <- ActiveModel() if (is.null(Model) || length(Model) == 0) Model <- "" if (getRcmdr("log.commands")) Opts <- " [log]" else Opts <- " " if (getRcmdr("attach.data.set")) Opts <- paste(Opts, "[attach]", sep="") if (getRcmdr("sort.names")) Opts <- paste(Opts, "[sort]", sep="") # If it is a "SciViews TclTk GUI" client, use it... if (is.SciViews.TclTk()) { cat(paste("Data: ", DataSet, ", Model: ", Model, Opts, sep=""), file = file.path(tempdir(), "svStatus.txt")) # getTemp from SciViews[svMisc] is redefined here to avoid a Depends: svMisc! getTemp <- function(x, default = NULL, mode="any") { if (exists(x, envir = TempEnv(), mode = mode, inherits = FALSE)) { return(get(x, envir = TempEnv(), mode = mode, inherits = FALSE)) } else { # Variable not found, return the default value return(default) } } CmdFun <- getTemp(".guiCmd", mode = "function") if (!is.null(CmdFun)) CmdFun("<<<= 2) print(help("Rcmdr.sciviews-specific")) else help("Rcmdr.sciviews-specific") } # last modified 11 May 2007 by J. Fox .onAttach <- function(...){ Commander() packageStartupMessage(gettext("\nRcmdr Version", domain="R-Rcmdr"), " ", getRcmdr("RcmdrVersion"), "\n") } .onLoad <- function(...){ packagesAvailable <- function(packages){ sapply(sapply(packages, .find.package, quiet=TRUE), function(x) length(x) != 0) } if (!interactive()) return() save.options <- options(warn=-1) on.exit(options(save.options)) tcltk <- require(tcltk) if (!tcltk) stop(gettext("The tcltk package is absent. The R Commander cannot function.", domain="R-Rcmdr")) required.packages <- rev(c("abind", "car", "effects", "foreign", "grid", "lattice", "lmtest", "MASS", "mgcv", "multcomp", "nlme", "nnet", "relimp", "rgl", "RODBC")) packages.to.load <- options("Rcmdr")[[1]]$load.at.startup if (is.null(packages.to.load)) packages.to.load <- "car" for (package in packages.to.load){ if (length(.find.package(package, quiet=TRUE)) != 0) require(package, character.only=TRUE) } check <- options("Rcmdr")[[1]]$check.packages if (length(check) > 0 && !check) return() packages.to.check <- union(required.packages, packages.to.load) available.packages <- packagesAvailable(packages.to.check) missing.packages <- packages.to.check[!available.packages] if (any(!available.packages)) { response <- tkmessageBox(message=paste(gettext("The following packages used by Rcmdr are missing:\n", domain="R-Rcmdr"), paste(missing.packages, collapse=", "), gettext("\nWithout these packages, some features will not be available.", domain="R-Rcmdr"), gettext("\nInstall these packages?", domain="R-Rcmdr")), icon="error", type="yesno") if (tclvalue(response) == "yes") { top <- tktoplevel(borderwidth=10) tkwm.title(top, gettext("Install Missing Packages", domain="R-Rcmdr")) locationFrame <- tkframe(top) locationVariable <- tclVar("CRAN") CRANbutton <- tkradiobutton(locationFrame, variable=locationVariable, value="CRAN") # Note: Bioconductor code not currently necessary # BioconductorButton <- tkradiobutton(locationFrame, variable=locationVariable, value="Bioconductor") localButton <- tkradiobutton(locationFrame, variable=locationVariable, value="local") directoryVariable <- tclVar("") directoryFrame <- tkframe(locationFrame) onBrowse <- function(){ tclvalue(directoryVariable) <- tclvalue(tkchooseDirectory()) } browseButton <- tkbutton(directoryFrame, text=gettext("Browse...", domain="R-Rcmdr"), width="12", command=onBrowse, borderwidth=3) locationField <- tkentry(directoryFrame, width="20", textvariable=directoryVariable) locationScroll <- tkscrollbar(directoryFrame, orient="horizontal", repeatinterval=5, command=function(...) tkxview(locationField, ...)) tkconfigure(locationField, xscrollcommand=function(...) tkset(locationScroll, ...)) tkgrid(tklabel(top, text=gettext("Install Packages From:", domain="R-Rcmdr"), fg="blue"), sticky="nw") tkgrid(tklabel(directoryFrame, text=gettext("Specify package \ndirectory:", domain="R-Rcmdr"), justify="left"), locationField, sticky="w") tkgrid(browseButton, locationScroll, sticky="w") tkgrid(locationScroll, sticky="ew") tkgrid(tklabel(locationFrame, text="CRAN"), CRANbutton, sticky="w") # tkgrid(tklabel(locationFrame, text="Bioconductor"), BioconductorButton, sticky="w") tkgrid(tklabel(locationFrame, text=gettext("Local package directory\n(must include PACKAGES index file)", domain="R-Rcmdr"), justify="left"), localButton, directoryFrame, sticky="nw") tkgrid(locationFrame, sticky="w") tkgrid(tklabel(top, text="")) onOK <- function(){ errorMessage <- function() tkmessageBox(message=paste( gettext("The following packages were not found at the specified location:\n", domain="R-Rcmdr"), paste(missing.packages[!present], collapse=", ")), icon="warning", type="ok") tkgrab.release(top) tkdestroy(top) location <- tclvalue(locationVariable) if (location == "CRAN") { packages <- utils:::CRAN.packages()[,1] present <- missing.packages %in% packages if (!all(present)) errorMessage() if (!any(present)) return() utils:::install.packages(missing.packages[present], dependencies=TRUE, lib=.libPaths()[1]) } # else if (location == "Bioconductor") { # packages <- CRAN.packages(CRAN=getOption("BIOC"))[,1] # present <- missing.packages %in% packages # if (!all(present)) errorMessage() # install.packages(missing.packages[present], lib=.libPaths()[1], # CRAN=getOption("BIOC")) # } else { directory <- paste("file:", tclvalue(directoryVariable), sep="") packages <- utils:::CRAN.packages(contriburl=directory)[,1] present <- missing.packages %in% packages if (!all(present)) errorMessage() if (!any(present)) return() utils:::install.packages(missing.packages[present], contriburl=directory, dependencies=TRUE, lib=.libPaths()[1]) } } onCancel <- function(){ tkgrab.release(top) tkdestroy(top) return() } onHelp <- function() help("install.packages") buttonsFrame <- tkframe(top) OKbutton <- tkbutton(buttonsFrame, text="OK", fg="darkgreen", width="12", command=onOK, default="active", borderwidth=3) cancelButton <- tkbutton(buttonsFrame, text=gettext("Cancel", domain="R-Rcmdr"), fg="red", width="12", command=onCancel, borderwidth=3) helpButton <- tkbutton(buttonsFrame, text=gettext("Help", domain="R-Rcmdr"), width="12", command=onHelp, borderwidth=3) tkgrid(OKbutton, tklabel(buttonsFrame, text=" "), cancelButton, tklabel(buttonsFrame, text=" "), helpButton, sticky="w") tkgrid(buttonsFrame, sticky="w") for (row in 0:2) tkgrid.rowconfigure(top, row, weight=0) tkgrid.columnconfigure(top, 0, weight=0) .Tcl("update idletasks") tkwm.resizable(top, 0, 0) tkbind(top, "", onOK) tkwm.deiconify(top) tkgrab.set(top) tkfocus(top) tkwait.window(top) } } } # Statistics Menu dialogs # last modified 1 July 05 by J. Fox # Dimensional-analysis menu Reliability <- function(){ initializeDialog(title=gettextRcmdr("Scale Reliability")) xBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick three or more)")) onOK <- function(){ x <- getSelection(xBox) closeDialog() if (3 > length(x)) { errorCondition(recall=Reliability, message=gettextRcmdr("Fewer than 3 variables selected.")) return() } x <- paste('"', x, '"', sep="") doItAndPrint(paste("reliability(cov(", ActiveDataSet(), "[,c(", paste(x, collapse=","), ')], use="complete.obs"))', sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="reliability") tkgrid(getFrame(xBox), sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2, columns=1) } principalComponents <- function(){ initializeDialog(title=gettextRcmdr("Principal Components Analysis")) xBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick two or more)")) subsetBox() checkBoxes(frame="optionsFrame", boxes=c("correlations", "screeplot", "addPC"), initialValues=c("1", "0", "0"), labels=gettextRcmdr(c("Analyze correlation matrix", "Screeplot", "Add principal components to data set"))) onOK <- function(){ putRcmdr("ncomponents", 0) x <- getSelection(xBox) nvar <- length(x) correlations <- tclvalue(correlationsVariable) subset <- tclvalue(subsetVariable) screeplot <- tclvalue(screeplotVariable) addPC <- tclvalue(addPCVariable) closeDialog() if (2 > length(x)) { errorCondition(recall=principalComponents, message=gettextRcmdr("Fewer than 2 variables selected.")) return() } subset <- if (trim.blanks(subset) == gettextRcmdr("")) "" else paste(", subset=", subset, sep="") correlations <- if (correlations == "1") "TRUE" else "FALSE" .activeDataSet <- ActiveDataSet() command <- paste("princomp(~", paste(x, collapse="+"), ", cor=", correlations, ", data=", .activeDataSet, subset, ")", sep="") assign(".PC", justDoIt(command), envir=.GlobalEnv) logger(paste(".PC <- ", command, sep="")) doItAndPrint("unclass(loadings(.PC)) # component loadings") doItAndPrint(".PC$sd^2 # component variances") if (screeplot == "1") { justDoIt("screeplot(.PC)") logger("screeplot(.PC)") } if (addPC == "1") { initializeDialog(subdialog, title=gettextRcmdr("Number of Components")) tkgrid(tklabel(subdialog, text=gettextRcmdr("Number of components to retain:"), fg="blue"), sticky="w") sliderFrame <- tkframe(subdialog) sliderValue <- tclVar("1") componentsSlider <- tkscale(sliderFrame, from=1, to=nvar, showvalue=FALSE, variable=sliderValue, resolution=1, orient="horizontal") componentsShow <- tklabel(sliderFrame, textvariable=sliderValue, width=2, justify="right") onOKsub <- function() { closeDialog(subdialog) putRcmdr("ncomponents", as.numeric(tclvalue(sliderValue))) } subOKCancelHelp() tkgrid(componentsSlider, componentsShow, sticky="nw") tkgrid(sliderFrame, sticky="w") tkgrid(subButtonsFrame, sticky="w") dialogSuffix(subdialog, onOK=onOKsub, rows=2, columns=1, focus=subdialog) if ((ncomponents <- getRcmdr("ncomponents")) > 0){ for(i in 1:ncomponents){ var <- paste("PC", i, sep="") if (is.element(var, Variables())) { if ("no" == tclvalue(checkReplace(var))) next } justDoIt(paste(.activeDataSet, "$PC", i, " <- .PC$scores[,", i, "]", sep="")) logger(paste(.activeDataSet, "$PC", i, " <- .PC$scores[,", i, "]", sep="")) } activeDataSet(.activeDataSet) } } remove(.PC, envir=.GlobalEnv) logger("remove(.PC)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="princomp") tkgrid(getFrame(xBox), sticky="nw") tkgrid(subsetFrame, sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } factorAnalysis <- function(){ initializeDialog(title=gettextRcmdr("Factor Analysis")) xBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick three or more)")) subsetBox() optionsFrame <- tkframe(top) checkFrame <- tkframe(top) radioButtons(checkFrame, name="rotation", buttons=c("noRotate", "varimax", "promax"), values=c("none", "varimax", "promax"), initialValue="varimax", labels=gettextRcmdr(c("None", "Varimax", "Promax")), title=gettextRcmdr("Factor Rotation")) radioButtons(checkFrame, name="scores", buttons=c("noScores", "bartlett", "regression"), values=c("none", "Bartlett", "regression"), labels=gettextRcmdr(c("None", "Bartlett's method", "Regression method")), title=gettextRcmdr("Factor Scores")) onOK <- function(){ x <- getSelection(xBox) nvar <- length(x) subset <- tclvalue(subsetVariable) rotation <- tclvalue(rotationVariable) scores <- tclvalue(scoresVariable) closeDialog() if (3 > length(x)) { errorCondition(recall=factorAnalysis, message=gettextRcmdr("Fewer than 3 variables selected.")) return() } f <- function(k, p) ((p - k)^2 - p - k)^2 max.factors <- floor(optimize(f, c(0, nvar), tol=.0001, p=nvar)$minimum) initializeDialog(subdialog, title=gettextRcmdr("Number of Factors")) tkgrid(tklabel(subdialog, text=gettextRcmdr("Number of factors to extract:"), fg="blue"), sticky="w") sliderFrame <- tkframe(subdialog) sliderValue <- tclVar("1") componentsSlider <- tkscale(sliderFrame, from=1, to=max.factors, showvalue=FALSE, variable=sliderValue, resolution=1, orient="horizontal") componentsShow <- tklabel(sliderFrame, textvariable=sliderValue, width=2, justify="right") onOKsub <- function() { closeDialog(subdialog) putRcmdr("nfactors", as.numeric(tclvalue(sliderValue))) } subOKCancelHelp() tkgrid(componentsSlider, componentsShow, sticky="nw") tkgrid(sliderFrame, sticky="w") tkgrid(subButtonsFrame, sticky="w") dialogSuffix(subdialog, onOK=onOKsub, rows=2, columns=1, focus=subdialog) subset <- if (trim.blanks(subset) == gettextRcmdr("")) "" else paste(", subset=", subset, sep="") .activeDataSet <- ActiveDataSet() command <- paste("factanal(~", paste(x, collapse="+"), ", factors=", getRcmdr("nfactors"), ', rotation="', rotation, '", scores="', scores, '", data=', .activeDataSet, subset, ")", sep="") assign(".FA", justDoIt(command), envir=.GlobalEnv) logger(paste(".FA <- ", command, sep="")) doItAndPrint(".FA") if (scores != "none") { for(i in 1:getRcmdr("nfactors")){ var <- paste("F", i, sep="") if (is.element(var, Variables())) { if ("no" == tclvalue(checkReplace(var))) next } justDoIt(paste(.activeDataSet, "$F", i, " <- .FA$scores[,", i, "]", sep="")) logger(paste(.activeDataSet, "$F", i, " <- .FA$scores[,", i, "]", sep="")) } activeDataSet(.activeDataSet) } logger("remove(.FA)") remove(.FA, envir=.GlobalEnv) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="factanal") tkgrid(getFrame(xBox), sticky="nw") tkgrid(subsetFrame, sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(rotationFrame, tklabel(checkFrame, text=" "), scoresFrame, sticky="w") tkgrid(checkFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=5, columns=1) } # Statistics Menu dialogs # last modified 24 May 07 by J. Fox # Means menu independentSamplesTTest <- function(){ initializeDialog(title=gettextRcmdr("Independent Samples t-Test")) variablesFrame <- tkframe(top) groupBox <- variableListBox(variablesFrame, TwoLevelFactors(), title=gettextRcmdr("Groups (pick one)")) responseBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Response Variable (pick one)")) onOK <- function(){ group <- getSelection(groupBox) if (length(group) == 0) { errorCondition(recall=independentSamplesTTest, message=gettextRcmdr("You must select a groups variable.")) return() } response <- getSelection(responseBox) if (length(response) == 0) { errorCondition(recall=independentSamplesTTest, message=gettextRcmdr("You must select a response variable.")) return() } alternative <- as.character(tclvalue(alternativeVariable)) level <- tclvalue(confidenceLevel) variances <- as.character(tclvalue(variancesVariable)) closeDialog() doItAndPrint(paste("t.test(", response, "~", group, ", alternative='", alternative, "', conf.level=", level, ", var.equal=", variances, ", data=", ActiveDataSet(), ")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="t.test") optionsFrame <- tkframe(top) radioButtons(optionsFrame, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"), labels=gettextRcmdr(c("Two-sided", "Difference < 0", "Difference > 0")), title=gettextRcmdr("Alternative Hypothesis")) confidenceFrame <- tkframe(optionsFrame) confidenceLevel <- tclVar(".95") confidenceField <- tkentry(confidenceFrame, width="6", textvariable=confidenceLevel) radioButtons(optionsFrame, name="variances", buttons=c("yes", "no"), values=c("TRUE", "FALSE"), initialValue="FALSE", labels=gettextRcmdr(c("Yes", "No")), title=gettextRcmdr("Assume equal variances?")) tkgrid(getFrame(groupBox), tklabel(variablesFrame, text=" "), getFrame(responseBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(tklabel(confidenceFrame, text=gettextRcmdr("Confidence Level"), fg="blue"),sticky="w") tkgrid(confidenceField, sticky="w") groupsLabel(groupsBox=groupBox) tkgrid(alternativeFrame, tklabel(optionsFrame, text=" "), confidenceFrame, tklabel(optionsFrame, text=" "), variancesFrame, sticky="nw") tkgrid(optionsFrame, sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } pairedTTest <- function(){ initializeDialog(title=gettextRcmdr("Paired t-Test")) .numeric <- Numeric() xBox <- variableListBox(top, .numeric, title=gettextRcmdr("First variable (pick one)")) yBox <- variableListBox(top, .numeric, title=gettextRcmdr("Second variable (pick one)")) onOK <- function(){ x <- getSelection(xBox) y <- getSelection(yBox) if (length(x) == 0 | length(y) == 0){ errorCondition(recall=pairedTTest, message=gettextRcmdr("You must select two variables.")) return() } if (x == y){ errorCondition(recall=pairedTTest, message=gettextRcmdr("Variables must be different.")) return() } alternative <- as.character(tclvalue(alternativeVariable)) level <- tclvalue(confidenceLevel) closeDialog() .activeDataSet <- ActiveDataSet() doItAndPrint(paste("t.test(", .activeDataSet, "$", x, ", ", .activeDataSet, "$", y, ", alternative='", alternative, "', conf.level=", level, ", paired=TRUE)", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="t.test") radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"), labels=gettextRcmdr(c("Two-sided", "Difference < 0", "Difference > 0")), title=gettextRcmdr("Alternative Hypothesis")) confidenceFrame <- tkframe(top) confidenceLevel <- tclVar(".95") confidenceField <- tkentry(confidenceFrame, width="6", textvariable=confidenceLevel) tkgrid(getFrame(xBox), getFrame(yBox), sticky="nw") tkgrid(tklabel(confidenceFrame, text=gettextRcmdr("Confidence Level"), fg="blue")) tkgrid(confidenceField, sticky="w") tkgrid(alternativeFrame, confidenceFrame, sticky="nw") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=3, columns=2) } singleSampleTTest <- function(){ initializeDialog(title=gettextRcmdr("Single-Sample t-Test")) xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)")) onOK <- function(){ x <- getSelection(xBox) if (length(x) == 0){ errorCondition(recall=singleSampleTTest, message=gettextRcmdr("You must select a variable.")) return() } alternative <- as.character(tclvalue(alternativeVariable)) level <- tclvalue(confidenceLevel) mu <- tclvalue(muVariable) closeDialog() doItAndPrint(paste("t.test(", ActiveDataSet(), "$", x, ", alternative='", alternative, "', mu=", mu, ", conf.level=", level, ")", sep="")) tkdestroy(top) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="t.test") radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"), labels=gettextRcmdr(c("Population mean = mu0", "Population mean < mu0", "Population mean > mu0")), title=gettextRcmdr("Alternative Hypothesis")) rightFrame <- tkframe(top) confidenceFrame <- tkframe(rightFrame) confidenceLevel <- tclVar(".95") confidenceField <- tkentry(confidenceFrame, width="6", textvariable=confidenceLevel) muFrame <- tkframe(rightFrame) muVariable <- tclVar("0.0") muField <- tkentry(muFrame, width="8", textvariable=muVariable) tkgrid(getFrame(xBox), sticky="nw") tkgrid(tklabel(rightFrame, text=""), sticky="w") tkgrid(tklabel(muFrame, text=gettextRcmdr("Null hypothesis: mu = ")), muField, sticky="w") tkgrid(muFrame, sticky="w") tkgrid(tklabel(confidenceFrame, text=gettextRcmdr("Confidence Level: ")), confidenceField, sticky="w") tkgrid(confidenceFrame, sticky="w") tkgrid(alternativeFrame, rightFrame, sticky="nw") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(confidenceField, sticky="e") dialogSuffix(rows=4, columns=2) } oneWayAnova <- function(){ require("multcomp") initializeDialog(title=gettextRcmdr("One-Way Analysis of Variance")) groupBox <- variableListBox(top, Factors(), title=gettextRcmdr("Groups (pick one)")) responseBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Response Variable (pick one)")) optionsFrame <- tkframe(top) pairwiseVariable <- tclVar("0") pairwiseCheckBox <- tkcheckbutton(optionsFrame, variable=pairwiseVariable) onOK <- function(){ group <- getSelection(groupBox) response <- getSelection(responseBox) closeDialog() if (length(group) == 0){ errorCondition(recall=oneWayAnova, message=gettextRcmdr("You must select a groups factor.")) return() } if (length(response) == 0){ errorCondition(recall=oneWayAnova, message=gettextRcmdr("You must select a response variable.")) return() } .activeDataSet <- ActiveDataSet() command <- paste(".Anova <- lm(", response, " ~ ", group, ", data=", .activeDataSet, ")", sep="") justDoIt(command) logger(command) doItAndPrint("anova(.Anova)") doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", ", .activeDataSet, "$", group, ", mean, na.rm=TRUE) # means", sep="")) doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", ", .activeDataSet, "$", group, ", sd, na.rm=TRUE) # std. deviations", sep="")) doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", ", .activeDataSet, "$", group, ", function(x) sum(!is.na(x))) # counts", sep="")) pairwise <- tclvalue(pairwiseVariable) if (pairwise == 1) { if (eval(parse(text=paste("length(levels(", .activeDataSet, "$", group, ")) < 3")))) Message(message=gettextRcmdr("Factor has fewer than 3 levels; pairwise comparisons omitted."), type="warning") # the following lines modified by Richard Heiberger and subsequently by J. Fox else { command <- paste(".Pairs <- glht(.Anova, linfct = mcp(", group, ' = "Tukey"))', sep="") justDoIt(command) logger(command) doItAndPrint("confint(.Pairs)") justDoIt("old.oma <- par(oma=c(0,5,0,0))") logger("old.oma <- par(oma=c(0,5,0,0))") justDoIt("plot(confint(.Pairs))") logger("plot(confint(.Pairs))") justDoIt("par(old.oma)") logger("par(old.oma)") logger("remove(.Pairs)") remove(.Pairs, envir=.GlobalEnv) } } logger("remove(.Anova)") remove(.Anova, envir=.GlobalEnv) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="anova") tkgrid(getFrame(groupBox), getFrame(responseBox), sticky="nw") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Pairwise comparisons of means")), pairwiseCheckBox, sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=4, columns=2) } multiWayAnova <- function(){ initializeDialog(title=gettextRcmdr("Multi-Way Analysis of Variance")) groupBox <- variableListBox(top, Factors(), selectmode="multiple", title=gettextRcmdr("Factors (pick one or more)")) responseBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Response Variable (pick one)")) onOK <- function(){ groups <- getSelection(groupBox) response <- getSelection(responseBox) closeDialog() if (length(groups) == 0){ errorCondition(recall=multiWayAnova, message=gettextRcmdr("You must select at least one factor.")) return() } if (length(response) == 0){ errorCondition(recall=multiWayAnova, message=gettextRcmdr("You must select a response variable.")) return() } .activeDataSet <- ActiveDataSet() groups.list <- paste(paste(groups, "=", .activeDataSet, "$", groups, sep=""), collapse=", ") doItAndPrint(paste("Anova(lm(", response, " ~ ", paste(groups, collapse="*"), ", data=", .activeDataSet, "))", sep="")) doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", list(", groups.list, "), mean, na.rm=TRUE) # means", sep="")) doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", list(", groups.list, "), sd, na.rm=TRUE) # std. deviations", sep="")) doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", list(", groups.list, "), function(x) sum(!is.na(x))) # counts", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="Anova") tkgrid(getFrame(groupBox), getFrame(responseBox), sticky="nw") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=3, columns=2) } # Statistics Menu dialogs # last modified 22 May 07 by J. Fox # Models menu linearRegressionModel <- function(){ initializeDialog(title=gettextRcmdr("Linear Regression")) variablesFrame <- tkframe(top) .numeric <- Numeric() xBox <- variableListBox(variablesFrame, .numeric, selectmode="multiple", title=gettextRcmdr("Explanatory variables (pick one or more)")) yBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("Response variable (pick one)")) UpdateModelNumber() modelName <- tclVar(paste("RegModel.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- tkentry(modelFrame, width="20", textvariable=modelName) subsetBox() onOK <- function(){ x <- getSelection(xBox) y <- getSelection(yBox) closeDialog() if (0 == length(y)) { UpdateModelNumber(-1) errorCondition(recall=linearRegressionModel, message=gettextRcmdr("You must select a response variable.")) return() } if (0 == length(x)) { UpdateModelNumber(-1) errorCondition(recall=linearRegressionModel, message=gettextRcmdr("No explanatory variables selected.")) return() } if (is.element(y, x)) { UpdateModelNumber(-1) errorCondition(recall=linearRegressionModel, message=gettextRcmdr("Response and explanatory variables must be different.")) return() } subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("") || trim.blanks(subset) == ""){ subset <- "" putRcmdr("modelWithSubset", FALSE) } else{ subset <- paste(", subset=", subset, sep="") putRcmdr("modelWithSubset", TRUE) } modelValue <- trim.blanks(tclvalue(modelName)) if (!is.valid.name(modelValue)){ UpdateModelNumber(-1) errorCondition(recall=linearRegressionModel, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue)) return() } if (is.element(modelValue, listLinearModels())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) linearRegressionModel() return() } } command <- paste("lm(", y, "~", paste(x, collapse="+"), ", data=", ActiveDataSet(), subset, ")", sep="") logger(paste(modelValue, " <- ", command, sep="")) assign(modelValue, justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste("summary(", modelValue, ")", sep="")) activeModel(modelValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="lm", model=TRUE) tkgrid(tklabel(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w") tkgrid(modelFrame, sticky="w") tkgrid(getFrame(yBox), tklabel(variablesFrame, text=" "), getFrame(xBox), sticky="nw") tkgrid(variablesFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, stick="w") tkgrid.configure(helpButton, sticky="e") dialogSuffix(rows=4, columns=1) } linearModel <- function(){ initializeDialog(title=gettextRcmdr("Linear Model")) .activeModel <- ActiveModel() currentModel <- if (!is.null(.activeModel)) eval(parse(text=paste("class(", .activeModel, ")[1] == 'lm'", sep="")), envir=.GlobalEnv) else FALSE if (currentModel) { currentFields <- formulaFields(eval(parse(text=.activeModel), envir=.GlobalEnv)) if (currentFields$data != ActiveDataSet()) currentModel <- FALSE } UpdateModelNumber() modelName <- tclVar(paste("LinearModel.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- tkentry(modelFrame, width="20", textvariable=modelName) onOK <- function(){ modelValue <- trim.blanks(tclvalue(modelName)) closeDialog() if (!is.valid.name(modelValue)){ errorCondition(recall=linearModel, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE) return() } subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("") || trim.blanks(subset) == ""){ subset <- "" putRcmdr("modelWithSubset", FALSE) } else{ subset <- paste(", subset=", subset, sep="") putRcmdr("modelWithSubset", TRUE) } check.empty <- gsub(" ", "", tclvalue(lhsVariable)) if ("" == check.empty) { errorCondition(recall=linearModel, message=gettextRcmdr("Left-hand side of model empty."), model=TRUE) return() } check.empty <- gsub(" ", "", tclvalue(rhsVariable)) if ("" == check.empty) { errorCondition(recall=linearModel, message=gettextRcmdr("Right-hand side of model empty."), model=TRUE) return() } if (is.element(modelValue, listLinearModels())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) linearModel() return() } } formula <- paste(tclvalue(lhsVariable), tclvalue(rhsVariable), sep=" ~ ") command <- paste("lm(", formula, ", data=", ActiveDataSet(), subset, ")", sep="") logger(paste(modelValue, " <- ", command, sep="")) assign(modelValue, justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste("summary(", modelValue, ")", sep="")) activeModel(modelValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="linearModel", model=TRUE) tkgrid(tklabel(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w") tkgrid(modelFrame, sticky="w") modelFormula() subsetBox(model=TRUE) tkgrid(getFrame(xBox), sticky="w") tkgrid(outerOperatorsFrame, sticky="w") tkgrid(formulaFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1, focus=lhsEntry, preventDoubleClick=TRUE) } generalizedLinearModel <- function(){ families <- c("gaussian", "binomial", "poisson", "Gamma", "inverse.gaussian", "quasibinomial", "quasipoisson") links <- c("identity", "inverse", "log", "logit", "probit", "cloglog", "sqrt", "1/mu^2") availableLinks <- matrix(c( TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, FALSE, FALSE, TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, FALSE, TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, FALSE, FALSE, TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, FALSE), 7, 8, byrow=TRUE) rownames(availableLinks) <- families colnames(availableLinks) <- links canonicalLinks <- c("identity", "logit", "log", "inverse", "1/mu^2", "logit", "log") names(canonicalLinks) <- families initializeDialog(title=gettextRcmdr("Generalized Linear Model")) .activeModel <- ActiveModel() currentModel <- if (!is.null(.activeModel)) eval(parse(text=paste("class(", .activeModel, ")[1] == 'glm'", sep="")), envir=.GlobalEnv) else FALSE if (currentModel) { currentFields <- formulaFields(eval(parse(text=.activeModel), envir=.GlobalEnv), glm=TRUE) if (currentFields$data != ActiveDataSet()) currentModel <- FALSE } modelFormula() UpdateModelNumber() modelName <- tclVar(paste("GLM.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- tkentry(modelFrame, width="20", textvariable=modelName) linkFamilyFrame <- tkframe(top) familyFrame <- tkframe(linkFamilyFrame) familyBox <- tklistbox(familyFrame, height="4", exportselection="FALSE", selectmode="single", background="white") familyScroll <- tkscrollbar(familyFrame, repeatinterval=5, command=function(...) tkyview(familyBox, ...)) tkconfigure(familyBox, yscrollcommand=function(...) tkset(familyScroll, ...)) for (fam in families) tkinsert(familyBox, "end", fam) linkFrame <- tkframe(linkFamilyFrame) linkBox <- tklistbox(linkFrame, height="4", exportselection="FALSE", selectmode="single", background="white") subsetBox(model=TRUE) onFamilySelect <- function(){ family <- families[as.numeric(tkcurselection(familyBox)) + 1] availLinks <- links[availableLinks[family,]] tkdelete(linkBox, "0", "end") for (lnk in availLinks) tkinsert(linkBox, "end", lnk) canLink <- canonicalLinks[family] tkconfigure(linkBox, height=length(availLinks)) tkselection.set(linkBox, which(canLink == availLinks) - 1) } onOK <- function(){ check.empty <- gsub(" ", "", tclvalue(lhsVariable)) if ("" == check.empty) { errorCondition(recall=generalizedLinearModel, model=TRUE, message=gettextRcmdr("Left-hand side of model empty.")) return() } check.empty <- gsub(" ", "", tclvalue(rhsVariable)) if ("" == check.empty) { errorCondition(recall=generalizedLinearModel, model=TRUE, message=gettextRcmdr("Right-hand side of model empty.")) return() } modelValue <- trim.blanks(tclvalue(modelName)) if (!is.valid.name(modelValue)){ errorCondition(recall=generalizedLinearModel, model=TRUE, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue)) return() } if (is.element(modelValue, listGeneralizedLinearModels())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) closeDialog() generalizedLinearModel() return() } } formula <- paste(tclvalue(lhsVariable), tclvalue(rhsVariable), sep=" ~ ") family <- families[as.numeric(tkcurselection(familyBox)) + 1] availLinks <- links[availableLinks[family,]] link <- availLinks[as.numeric(tkcurselection(linkBox)) + 1] subset <- tclvalue(subsetVariable) closeDialog() if (trim.blanks(subset) == gettextRcmdr("") || trim.blanks(subset) == ""){ subset <- "" putRcmdr("modelWithSubset", FALSE) } else{ subset <- paste(", subset=", subset, sep="") putRcmdr("modelWithSubset", TRUE) } command <- paste("glm(", formula, ", family=", family, "(", link, "), data=", ActiveDataSet(), subset, ")", sep="") logger(paste(modelValue, " <- ", command, sep="")) assign(modelValue, justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste("summary(", modelValue, ")", sep="")) activeModel(modelValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="generalizedLinearModel") helpButton <- tkbutton(buttonsFrame, text="Help", width="12", command=onHelp) tkgrid(tklabel(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w") tkgrid(modelFrame, sticky="w") tkgrid(getFrame(xBox), sticky="w") tkgrid(outerOperatorsFrame, sticky="w") tkgrid(formulaFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(tklabel(linkFamilyFrame, text=gettextRcmdr("Family (double-click to select)"), fg="blue"), tklabel(linkFamilyFrame, text=" "), tklabel(linkFamilyFrame, text=gettextRcmdr("Link function"), fg="blue"), sticky="w") tkgrid(familyBox, familyScroll, sticky="nw") tkgrid(linkBox, sticky="nw") tkgrid(familyFrame, tklabel(linkFamilyFrame, text=" "), linkFrame, sticky="nw") tkgrid(linkFamilyFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") tkgrid.configure(familyScroll, sticky="ns") fam <- if (currentModel) which(currentFields$family == families) - 1 else 1 tkselection.set(familyBox, fam) availLinks <- links[availableLinks[fam + 1,]] for (lnk in availLinks) tkinsert(linkBox, "end", lnk) tkconfigure(linkBox, height=length(availLinks)) lnk <- if (currentModel) which(currentFields$link == availLinks) - 1 else 0 tkselection.set(linkBox, lnk) tkbind(familyBox, "", onFamilySelect) dialogSuffix(rows=7, columns=1, focus=lhsEntry, preventDoubleClick=TRUE) } ordinalRegressionModel <- function(){ require("MASS") initializeDialog(title=gettextRcmdr("Ordinal Regression Model")) .activeModel <- ActiveModel() .activeDataSet <- ActiveDataSet() currentModel <- if (!is.null(.activeModel)) eval(parse(text=paste("class(", .activeModel, ")[1] == 'polr'", sep="")), envir=.GlobalEnv) else FALSE if (currentModel) { currentFields <- formulaFields(eval(parse(text=.activeModel), envir=.GlobalEnv)) if (currentFields$data != .activeDataSet) currentModel <- FALSE } UpdateModelNumber() modelName <- tclVar(paste("OrdRegModel.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- tkentry(modelFrame, width="20", textvariable=modelName) radioButtons(name="modelType", buttons=c("logistic", "probit"), labels=gettextRcmdr(c("Proportional-odds logit", "Ordered probit")), title=gettextRcmdr("Type of Model")) onOK <- function(){ modelValue <- trim.blanks(tclvalue(modelName)) closeDialog() if (!is.valid.name(modelValue)){ errorCondition(recall=proportionalOddsModel, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE) return() } subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("") || trim.blanks(subset) == ""){ subset <- "" putRcmdr("modelWithSubset", FALSE) } else{ subset <- paste(", subset=", subset, sep="") putRcmdr("modelWithSubset", TRUE) } check.empty <- gsub(" ", "", tclvalue(lhsVariable)) if ("" == check.empty) { errorCondition(recall=proportionalOddsModel, message=gettextRcmdr("Left-hand side of model empty."), model=TRUE) return() } check.empty <- gsub(" ", "", tclvalue(rhsVariable)) if ("" == check.empty) { errorCondition(recall=proportionalOddsModel, message=gettextRcmdr("Right-hand side of model empty."), model=TRUE) return() } if (!is.factor(eval(parse(text=tclvalue(lhsVariable)), envir=eval(parse(text=.activeDataSet), envir=.GlobalEnv)))){ errorCondition(recall=proportionalOddsModel, message=gettextRcmdr("Response variable must be a factor")) return() } if (is.element(modelValue, listProportionalOddsModels())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) proportionalOddsModel() return() } } formula <- paste(tclvalue(lhsVariable), tclvalue(rhsVariable), sep=" ~ ") command <- paste("polr(", formula, ', method="', tclvalue(modelTypeVariable), '", data=', .activeDataSet, subset, ", Hess=TRUE)", sep="") logger(paste(modelValue, " <- ", command, sep="")) assign(modelValue, justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste("summary(", modelValue, ")", sep="")) activeModel(modelValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="polr", model=TRUE) tkgrid(tklabel(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w") tkgrid(modelFrame, sticky="w") modelFormula() subsetBox(model=TRUE) tkgrid(getFrame(xBox), sticky="w") tkgrid(outerOperatorsFrame, sticky="w") tkgrid(formulaFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(modelTypeFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1, focus=lhsEntry, preventDoubleClick=TRUE) } multinomialLogitModel <- function(){ require("nnet") initializeDialog(title=gettextRcmdr("Multinomial Logit Model")) .activeModel <- ActiveModel() .activeDataSet <- ActiveDataSet() currentModel <- if (!is.null(.activeModel)) eval(parse(text=paste("class(", .activeModel, ")[1] == 'multinom'", sep="")), envir=.GlobalEnv) else FALSE if (currentModel) { currentFields <- formulaFields(eval(parse(text=.activeModel), envir=.GlobalEnv)) if (currentFields$data != .activeDataSet) currentModel <- FALSE } UpdateModelNumber() modelName <- tclVar(paste("MLM.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- tkentry(modelFrame, width="20", textvariable=modelName) onOK <- function(){ modelValue <- trim.blanks(tclvalue(modelName)) closeDialog() if (!is.valid.name(modelValue)){ errorCondition(recall=multinomialLogitModel, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE) return() } subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("") || trim.blanks(subset) == ""){ subset <- "" putRcmdr("modelWithSubset", FALSE) } else{ subset <- paste(", subset=", subset, sep="") putRcmdr("modelWithSubset", TRUE) } check.empty <- gsub(" ", "", tclvalue(lhsVariable)) if ("" == check.empty) { errorCondition(recall=multinomialLogitModel, message=gettextRcmdr("Left-hand side of model empty."), model=TRUE) return() } check.empty <- gsub(" ", "", tclvalue(rhsVariable)) if ("" == check.empty) { errorCondition(recall=multinomialLogitModel, message=gettextRcmdr("Right-hand side of model empty."), model=TRUE) return() } if (!is.factor(eval(parse(text=tclvalue(lhsVariable)), envir=eval(parse(text=.activeDataSet), envir=.GlobalEnv)))){ errorCondition(recall=multinomialLogitModel, message=gettextRcmdr("Response variable must be a factor")) return() } if (is.element(modelValue, listMultinomialLogitModels())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) multinomialLogitModel() return() } } formula <- paste(tclvalue(lhsVariable), tclvalue(rhsVariable), sep=" ~ ") command <- paste("multinom(", formula, ", data=", .activeDataSet, subset, ", trace=FALSE)", sep="") logger(paste(modelValue, " <- ", command, sep="")) assign(modelValue, justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste("summary(", modelValue, ", cor=FALSE, Wald=TRUE)", sep="")) activeModel(modelValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="multinom", model=TRUE) tkgrid(tklabel(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w") tkgrid(modelFrame, sticky="w") modelFormula() subsetBox(model=TRUE) tkgrid(getFrame(xBox), sticky="w") tkgrid(outerOperatorsFrame, sticky="w") tkgrid(formulaFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1, focus=lhsEntry, preventDoubleClick=TRUE) } formulaFields <- function(model, glm=FALSE){ formula <- as.character(model$call$formula) lhs <- formula[2] rhs <- formula[3] data <- as.character(model$call$data) which.subset <- which("subset" == names(model$call)) subset <- if (0 == length(which.subset)) "" else as.character(model$call)[[which.subset]] if (glm) { fam <- as.character(model$call$family) family <- fam[1] link <- fam[2] } else { family <- NULL link <- NULL } list(lhs=lhs, rhs=rhs, data=data, subset=subset, family=family, link=link) } # Statistics Menu dialogs # last modified 1 July 05 by J. Fox # Nonparametric tests menu twoSampleWilcoxonTest <- function(){ initializeDialog(title=gettextRcmdr("Two-Sample Wilcoxon Test")) groupBox <- variableListBox(top, TwoLevelFactors(), title=gettextRcmdr("Groups (pick one)")) responseBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Response Variable (pick one)")) onOK <- function(){ group <- getSelection(groupBox) if (length(group) == 0) { errorCondition(recall=twoSampleWilcoxonTest, message=gettextRcmdr("You must select a groups variable.")) return() } response <- getSelection(responseBox) if (length(response) == 0) { errorCondition(recall=twoSampleWilcoxonTest, message=gettextRcmdr("You must select a response variable.")) return() } alternative <- as.character(tclvalue(alternativeVariable)) test <- as.character(tclvalue(testVariable)) closeDialog() .activeDataSet <- ActiveDataSet() doItAndPrint(paste("tapply(", paste(.activeDataSet,"$", response, sep=""), ", ", paste(.activeDataSet,"$", group, sep=""), ", median, na.rm=TRUE)", sep="")) if (test == "default"){ doItAndPrint(paste("wilcox.test(", response, " ~ ", group, ', alternative="', alternative, '", data=', .activeDataSet, ")", sep="")) } else doItAndPrint(paste("wilcox.test(", response, " ~ ", group, ", alternative='", alternative, "', exact=", test=="exact", ", correct=", test=="correct",", data=", .activeDataSet, ")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="wilcox.test") radioButtons(name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"), labels=gettextRcmdr(c("Two-sided", "Difference < 0", "Difference > 0")), title=gettextRcmdr("Alternative Hypothesis")) radioButtons(name="test", buttons=c("default", "exact", "normal", "correct"), labels=gettextRcmdr(c("Default", "Exact", "Normal approximation", "Normal approximation with\ncontinuity correction")), title=gettextRcmdr("Type of Test")) tkgrid(getFrame(groupBox), getFrame(responseBox), sticky="nw") groupsLabel(groupsBox=groupBox, columnspan=2) tkgrid(alternativeFrame, testFrame, sticky="nw") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=4, columns=2) } pairedWilcoxonTest <- function(){ initializeDialog(title=gettextRcmdr("Paired Wilcoxon Test")) .numeric <- Numeric() xBox <- variableListBox(top, .numeric, title=gettextRcmdr("First variable (pick one)")) yBox <- variableListBox(top, .numeric, title=gettextRcmdr("Second variable (pick one)")) onOK <- function(){ x <- getSelection(xBox) y <- getSelection(yBox) closeDialog() alternative <- as.character(tclvalue(alternativeVariable)) test <- as.character(tclvalue(testVariable)) if (length(x) == 0 | length(y) == 0) { errorCondition(recall=pairedWilcoxonTest, message=gettextRcmdr("You must select two variables.")) return() } if (x == y) { errorCondition(recall=pairedWilcoxonTest, message=gettextRcmdr("The two variables must be different.")) return() } .activeDataSet <- ActiveDataSet() doItAndPrint(paste("median(", .activeDataSet, "$", x, " - ", .activeDataSet, "$", y, ", na.rm=TRUE) # median difference", sep="")) if (test == "default"){ doItAndPrint(paste("wilcox.test(", .activeDataSet, "$", x, ", ", .activeDataSet, "$", y, ", alternative='", alternative, "', paired=TRUE)", sep="")) } else if (test == "exact"){ doItAndPrint(paste("wilcox.test(", .activeDataSet, "$", x, ", ", .activeDataSet, "$", y, ", alternative='", alternative, "', exact=TRUE, paired=TRUE)", sep="")) } else { doItAndPrint(paste("wilcox.test(", .activeDataSet, "$", x, ", ", .activeDataSet, "$", y, ", alternative='", alternative, "', correct=", test=="correct", ", exact=FALSE, paired=TRUE)", sep="")) } tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="wilcox.test") radioButtons(name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"), labels=gettextRcmdr(c("Two-sided", "Difference < 0", "Difference > 0")), title=gettextRcmdr("Alternative Hypothesis")) radioButtons(name="test", buttons=c("default", "exact", "normal", "correct"), labels=gettextRcmdr(c("Default", "Exact", "Normal approximation", "Normal approximation with\ncontinuity correction")), title=gettextRcmdr("Type of Test")) tkgrid(getFrame(xBox), getFrame(yBox), sticky="nw") tkgrid(alternativeFrame, testFrame, sticky="nw") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=3, columns=2) } KruskalWallisTest <- function(){ initializeDialog(title=gettextRcmdr("Kruskal-Wallis Rank Sum Test")) groupBox <- variableListBox(top, Factors(), title=gettextRcmdr("Groups (pick one)")) responseBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Response Variable (pick one)")) onOK <- function(){ group <- getSelection(groupBox) if (length(group) == 0) { errorCondition(recall=KruskalWallisTest, message=gettextRcmdr("You must select a groups variable.")) return() } response <- getSelection(responseBox) closeDialog() if (length(response) == 0) { errorCondition(recall=KruskalWallisTest, message=gettextRcmdr("You must select a response variable.")) return() } .activeDataSet <- ActiveDataSet() doItAndPrint(paste("tapply(", paste(.activeDataSet, "$", response, sep=""), ", ", paste(.activeDataSet, "$", group, sep=""), ", median, na.rm=TRUE)", sep="")) doItAndPrint(paste("kruskal.test(", response, " ~ ", group, ", data=", .activeDataSet, ")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="kruskal.test") tkgrid(getFrame(groupBox), getFrame(responseBox), sticky="nw") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=2, columns=2) } # Statistics Menu dialogs # last modified 24 February 06 by J. Fox # Proportions menu singleProportionTest <- function(){ initializeDialog(title=gettextRcmdr("Single-Sample Proportion Test")) xBox <- variableListBox(top, TwoLevelFactors(), title=gettextRcmdr("Variable (pick one)")) onOK <- function(){ x <- getSelection(xBox) if (length(x) == 0) { errorCondition(recall=singleProportionTest, message=gettextRcmdr("You must select a variable.")) return() } alternative <- as.character(tclvalue(alternativeVariable)) level <- tclvalue(confidenceLevel) test <- as.character(tclvalue(testVariable)) p <- tclvalue(pVariable) closeDialog() command <- paste("xtabs(~", x, ", data=", ActiveDataSet(), ")") logger(paste(".Table <-", command)) assign(".Table", justDoIt(command), envir=.GlobalEnv) doItAndPrint(".Table") if (test == "normal") doItAndPrint(paste("prop.test(rbind(.Table), alternative='", alternative, "', p=", p, ", conf.level=", level, ", correct=FALSE)", sep="")) else if (test == "corrected") doItAndPrint(paste("prop.test(rbind(.Table), alternative='", alternative, "', p=", p, ", conf.level=", level, ", correct=TRUE)", sep="")) else doItAndPrint(paste("binom.test(rbind(.Table), alternative='", alternative, "', p=", p, ", conf.level=", level, ")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="prop.test") radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"), labels=gettextRcmdr(c("Population proportion = p0", "Population proportion < p0", "Population proportion > p0")), title=gettextRcmdr("Alternative Hypothesis")) rightFrame <- tkframe(top) confidenceFrame <- tkframe(rightFrame) confidenceLevel <- tclVar(".95") confidenceField <- tkentry(confidenceFrame, width="6", textvariable=confidenceLevel) pFrame <- tkframe(rightFrame) pVariable <- tclVar(".5") pField <- tkentry(pFrame, width="6", textvariable=pVariable) radioButtons(name="test", buttons=c("normal", "corrected", "exact"), labels=gettextRcmdr(c("Normal approximation", "Normal approximation with\ncontinuity correction", "Exact binomial")), title=gettextRcmdr("Type of Test")) tkgrid(getFrame(xBox), sticky="nw") tkgrid(tklabel(pFrame, text=gettextRcmdr("Null hypothesis: p = "), fg="blue"), pField, sticky="w") tkgrid(pFrame, sticky="w") tkgrid(tklabel(rightFrame, text="")) tkgrid(tklabel(confidenceFrame, text=gettextRcmdr("Confidence Level: "), fg="blue"), confidenceField, sticky="w") tkgrid(confidenceFrame, sticky="w") tkgrid(alternativeFrame, rightFrame, sticky="nw") tkgrid(testFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(confidenceField, sticky="e") dialogSuffix(rows=4, columns=2) } twoSampleProportionsTest <- function(){ require("abind") initializeDialog(title=gettextRcmdr("Two-Sample Proportions Test")) .twoLevelFactors <- TwoLevelFactors() groupsBox <- variableListBox(top, .twoLevelFactors, title=gettextRcmdr("Groups (pick one)")) xBox <- variableListBox(top, .twoLevelFactors, title=gettextRcmdr("Response Variable (pick one)")) onOK <- function(){ groups <- getSelection(groupsBox) if (length(groups) == 0) { errorCondition(recall=twoSampleProportionsTest, message=gettextRcmdr("You must select a groups variable.")) return() } x <- getSelection(xBox) if (length(x) == 0) { errorCondition(recall=twoSampleProportionsTest, message=gettextRcmdr("You must select a response variable.")) return() } if (x == groups) { errorCondition(recall=twoSampleProportionsTest, message=gettextRcmdr("Groups and response variables must be different.")) return() } alternative <- as.character(tclvalue(alternativeVariable)) level <- tclvalue(confidenceLevel) test <- as.character(tclvalue(testVariable)) closeDialog() command <- paste("xtabs(~", groups, "+", x, ", data=", ActiveDataSet(), ")", sep="") logger(paste(".Table <-", command)) assign(".Table", justDoIt(command), envir=.GlobalEnv) doItAndPrint("rowPercents(.Table)") if (test == "normal") doItAndPrint(paste("prop.test(.Table, alternative='", alternative, "', conf.level=", level, ", correct=FALSE)", sep="")) else doItAndPrint(paste("prop.test(.Table, alternative='", alternative, "', conf.level=", level, ", correct=TRUE)", sep="")) logger("remove(.Table)") remove(.Table, envir=.GlobalEnv) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="prop.test") radioButtons(name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"), labels=gettextRcmdr(c("Two-sided", "Difference < 0", "Difference > 0")), title=gettextRcmdr("Alternative Hypothesis")) rightFrame <- tkframe(top) confidenceFrame <- tkframe(rightFrame) confidenceLevel <- tclVar(".95") confidenceField <- tkentry(confidenceFrame, width="6", textvariable=confidenceLevel) radioButtons(name="test", buttons=c("normal", "corrected"), labels=gettextRcmdr(c("Normal approximation", "Normal approximation with\ncontinuity correction")), title=gettextRcmdr("Type of Test")) tkgrid(getFrame(groupsBox), getFrame(xBox), sticky="nw") groupsLabel(columnspan=2) tkgrid(tklabel(confidenceFrame, text=gettextRcmdr("Confidence Level: "), fg="blue"), confidenceField, sticky="w") tkgrid(confidenceFrame, sticky="w") tkgrid(alternativeFrame, rightFrame, sticky="nw") tkgrid(testFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") tkgrid.configure(confidenceField, sticky="e") dialogSuffix(rows=5, columns=2) } # Statistics Menu dialogs # last modified 22 May 07 by J. Fox # Summaries menu summarizeDataSet <- function(){ nvar <- length(Variables()) .activeDataSet <- ActiveDataSet() if (nvar > 10){ response <- RcmdrTkmessageBox(message=sprintf(gettextRcmdr("There are %d variables in the data set %s.\nDo you want to proceed?"), nvar, .activeDataSet), icon="question", type="okcancel", default="cancel") if ("cancel" == tclvalue(response)) { tkfocus(CommanderWindow()) return() } } doItAndPrint(paste("summary(", .activeDataSet, ")", sep="")) } numericalSummaries <- function(){ require(abind) initializeDialog(title=gettextRcmdr("Numerical Summaries")) xBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick one or more)")) checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sd"), initialValues=c("1", "1"), labels=gettextRcmdr(c("Mean", "Standard Deviation"))) quantilesVariable <- tclVar("1") quantilesFrame <- tkframe(top) quantilesCheckBox <- tkcheckbutton(quantilesFrame, variable=quantilesVariable) quantiles <- tclVar("0,.25,.5,.75,1") quantilesEntry <- tkentry(quantilesFrame, width="20", textvariable=quantiles) groupsBox(recall=numericalSummaries, label=gettextRcmdr("Summarize by:"), initialLabel=gettextRcmdr("Summarize by groups")) onOK <- function(){ x <- getSelection(xBox) if (length(x) == 0){ errorCondition(recall=numericalSummaries, message=gettextRcmdr("You must select a variable.")) return() } closeDialog() quants <- paste("c(", gsub(" ", ",", tclvalue(quantiles)), ")") .activeDataSet <- ActiveDataSet() vars <- if (length(x) == 1) paste('"', x, '"', sep="") else paste("c(", paste('"', x, '"', collapse=", ", sep=""), ")", sep="") vars <- paste(.activeDataSet, "[,", vars, "]", sep="") stats <- paste("c(", paste(c('"mean"', '"sd"', '"quantiles"') [c(tclvalue(meanVariable), tclvalue(sdVariable), tclvalue(quantilesVariable)) == 1], collapse=", "), ")", sep="") if (stats == "c()"){ errorCondition(recall=numericalSummaries, message=gettextRcmdr("No statistics selected.")) return() } command <- if (.groups != FALSE) { grps <- paste(.activeDataSet, "$", .groups, sep="") paste("numSummary(", vars, ", groups=", grps, ", statistics=", stats, ")", sep="") } else paste("numSummary(", vars, ", statistics=", stats, ")", sep="") doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="numSummary") tkgrid(getFrame(xBox), sticky="nw") tkgrid(checkBoxFrame, sticky="w") tkgrid(tklabel(quantilesFrame, text=gettextRcmdr("Quantiles")), quantilesCheckBox, tklabel(quantilesFrame, text=gettextRcmdr(" quantiles:")), quantilesEntry, sticky="w") tkgrid(quantilesFrame, sticky="w") tkgrid(groupsFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1) } frequencyDistribution <- function(){ initializeDialog(title=gettextRcmdr("Frequency Distributions")) xBox <- variableListBox(top, Factors(), selectmode="multiple", title=gettextRcmdr("Variables (pick one or more)")) optionsFrame <- tkframe(top) goodnessOfFitVariable <- tclVar("0") goodnessOfFitCheckBox <- tkcheckbutton(optionsFrame, variable=goodnessOfFitVariable) onOK <- function(){ x <- getSelection(xBox) if (length(x) == 0){ errorCondition(recall=frequencyDistribution, message=gettextRcmdr("You must select a variable.")) return() } goodnessOfFit <- tclvalue(goodnessOfFitVariable) if (length(x) > 1 && goodnessOfFit == "1"){ errorCondition(recall=frequencyDistribution, message=gettextRcmdr("Goodness-of-fit test not available when more than one variable is selected.")) return() } closeDialog() .activeDataSet <- ActiveDataSet() for (variable in x){ command <- paste("table(", .activeDataSet, "$", variable, ")", sep="") logger(paste(".Table <-", command)) assign(".Table", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(".Table # counts for", variable)) doItAndPrint(paste("100*.Table/sum(.Table) # percentages for", variable)) } env <- environment() if (goodnessOfFit == 1){ initializeDialog(subwin, title=gettextRcmdr("Goodness-of-Fit Test")) hypothesisFrame <- tkframe(subwin) levs <- eval(parse(text=paste("levels(", .activeDataSet, "$", x, ")", sep=""))) n.levs <- length(levs) assign(".entry.1", tclVar(paste("1/", n.levs, sep="")), envir=env) make.entries <- "tklabel(hypothesisFrame, text='Hypothesized probabilities: ')" make.lev.names <- "tklabel(hypothesisFrame, text='Factor levels:')" for (i in 1:n.levs) { entry.varname <- paste(".entry.", i, sep="") assign(entry.varname, tclVar(paste("1/", n.levs, sep="")), envir=env) make.entries <- paste(make.entries, ", ", "tkentry(hypothesisFrame, width='5', textvariable=", entry.varname, ")", sep="") make.lev.names <- paste(make.lev.names, ", tklabel(hypothesisFrame, text='", levs[i], "')", sep="") } eval(parse(text=paste("tkgrid(", make.lev.names, ", sticky='w')", sep="")), envir=env) eval(parse(text=paste("tkgrid(", make.entries, ", stick='w')", sep="")), envir=env) tkgrid(hypothesisFrame, sticky="w") onOKsub <- function(){ probs <- rep(NA, n.levs) for (i in 1:n.levs){ entry.varname <- paste(".entry.", i, sep="") res <- try( entry <- eval(parse(text=eval(parse(text=paste("tclvalue(", entry.varname,")", sep="")), envir=env))), silent=TRUE) if (class(res) == "try-error"){ errorCondition(subwin, message=gettextRcmdr("Invalid entry.")) return() } if (length(entry) == 0){ errorCondition(subwin, message=gettextRcmdr("Missing entry.")) return() } opts <- options(warn=-1) probs[i] <- as.numeric(entry) options(opts) } probs <- na.omit(probs) if (length(probs) != n.levs){ errorCondition(subwin, message=sprintf(gettextRcmdr("Number of valid entries (%d)\nnot equal to number levels (%d)."), length(probs), n.levs)) return() } if (any(probs < 0)){ errorCondition(subwin, message=gettextRcmdr("Negative probabilities not allowed.")) return() } if (abs(sum(probs) - 1) > 0.001){ Message(message=gettextRcmdr("Probabilities rescaled to sum to 1."), type="warning") probs <- probs/sum(probs) } closeDialog(subwin) command <- paste("c(", paste(probs, collapse=","), ")", sep="") logger(paste(".Probs <-", command)) assign(".Probs", justDoIt(command), envir=.GlobalEnv) doItAndPrint("chisq.test(.Table, p=.Probs)") logger("remove(.Probs)") remove(.Probs, envir=.GlobalEnv) } subOKCancelHelp(subwin) tkgrid(subButtonsFrame, sticky="w") dialogSuffix(subwin, rows=2, columns=1, onOK=onOKsub, focus=subwin) } logger("remove(.Table)") remove(.Table, envir=.GlobalEnv) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="table") tkgrid(getFrame(xBox), sticky="nw") tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Chi-square goodness-of-fit test (for one variable only)")), goodnessOfFitCheckBox, sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=3, columns=2) } statisticsTable <- function(){ initializeDialog(title=gettextRcmdr("Table of Statistics")) variablesFrame <- tkframe(top) groupBox <- variableListBox(variablesFrame, Factors(), selectmode="multiple", title=gettextRcmdr("Factors (pick one or more)")) responseBox <- variableListBox(variablesFrame, Numeric(), selectmode="multiple", title=gettextRcmdr("Response variables (pick one or more)")) radioButtons(name="statistic", buttons=c("mean", "median", "sd"), labels=gettextRcmdr(c("Mean", "Median", "Standard deviation")), title=gettextRcmdr("Statistic")) otherVariable <- tclVar("") otherButton <- tkradiobutton(statisticFrame, variable=statisticVariable, value="other") otherEntry <- tkentry(statisticFrame, width="20", textvariable=otherVariable) tkgrid(tklabel(statisticFrame, text=gettextRcmdr("Other (specify)")), otherButton, otherEntry, sticky="w") onOK <- function(){ groups <- getSelection(groupBox) if (0 == length(groups)) { errorCondition(recall=statisticsTable, message=gettextRcmdr("No factors selected.")) return() } responses <- getSelection(responseBox) if (0 == length(responses)) { errorCondition(recall=statisticsTable, message=gettextRcmdr("You must select a response variable.")) return() } statistic <- tclvalue(statisticVariable) if (statistic == "other") statistic <- tclvalue(otherVariable) closeDialog() .activeDataSet <- ActiveDataSet() groups.list <- paste(paste(groups, "=", .activeDataSet, "$", groups, sep=""), collapse=", ") for (response in responses){ if (length(responses) > 1) doItAndPrint(paste("# Table for ", response, ":", sep="")) doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", list(", groups.list, "), ", statistic, ", na.rm=TRUE)", sep="")) } tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="tapply") tkgrid(getFrame(groupBox), tklabel(variablesFrame, text=" "),getFrame(responseBox), sticky="nw") tkgrid(variablesFrame, sticky="w") tkgrid(statisticFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=3, columns=1, focus=otherEntry) } correlationMatrix <- function(){ initializeDialog(title=gettextRcmdr("Correlation Matrix")) xBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick two or more)")) radioButtons(name="correlations", buttons=c("pearson", "spearman", "partial"), values=c("Pearson", "Spearman", "partial"), labels=gettextRcmdr(c("Pearson product-moment", "Spearman rank-order", "Partial")), title=gettextRcmdr("Type of Correlations")) onOK <- function(){ correlations <- tclvalue(correlationsVariable) x <- getSelection(xBox) if (2 > length(x)) { errorCondition(recall=correlationMatrix, message=gettextRcmdr("Fewer than 2 variables selected.")) return() } if ((correlations == "partial") && (3 > length(x))) { errorCondition(recall=correlationMatrix, message=gettextRcmdr("Fewer than 3 variables selected\nfor partial correlations.")) return() } closeDialog() x <- paste('"', x, '"', sep="") .activeDataSet <- ActiveDataSet() if (correlations == "Pearson") doItAndPrint(paste("cor(", .activeDataSet, "[,c(", paste(x, collapse=","), ')], use="complete.obs")', sep="")) else if (correlations == "Spearman"){ logger("# Spearman rank-order correlations") doItAndPrint(paste("cor(", .activeDataSet, "[,c(", paste(x, collapse=","), ')], use="complete.obs", method="spearman")', sep="")) } else doItAndPrint(paste("partial.cor(", .activeDataSet, "[,c(", paste(x, collapse=","), ')], use="complete.obs")', sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="cor") tkgrid(getFrame(xBox), sticky="nw") tkgrid(correlationsFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=3, columns=1) } # the following dialog contributed by Stefano Calza, modified by J. Fox correlationTest <- function(){ initializeDialog(title=gettextRcmdr("Correlation Test")) xBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick two)")) radioButtons(name="correlations", buttons=c("pearson", "spearman", "kendall"), labels=gettextRcmdr(c("Pearson product-moment", "Spearman rank-order", "Kendall's tau")), title=gettextRcmdr("Type of Correlation")) radioButtons(name="alternative", buttons=c("two.sided", "less", "greater"), values=c("two.sided", "less", "greater"), labels=gettextRcmdr(c("Two-sided", "Correlation < 0", "Correlation > 0")), title=gettextRcmdr("Alternative Hypothesis")) onOK <- function(){ alternative <- as.character(tclvalue(alternativeVariable)) correlations <- as.character(tclvalue(correlationsVariable)) x <- getSelection(xBox) if (2 > length(x)) { errorCondition(recall=correlationTest, message=gettextRcmdr("Fewer than 2 variables selected.")) return() } if(2 < length(x)) { errorCondition(recall=correlationTest, message=gettextRcmdr("More than 2 variables selected.")) return() } closeDialog() .activeDataSet <- ActiveDataSet() command <- paste("cor.test(", .activeDataSet, "$", x[1], ", ", .activeDataSet, "$", x[2], ', alternative="', alternative, '", method="', correlations, '")', sep="") doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="cor.test") tkgrid(getFrame(xBox), sticky="nw") tkgrid(tklabel(top, text="")) tkgrid(correlationsFrame,alternativeFrame, sticky="w") tkgrid(buttonsFrame,columnspan=2,sticky="w") dialogSuffix(rows=4, columns=1) } countMissing <- function(){ command <- paste("sapply(", activeDataSet(), ", function(x)(sum(is.na(x)))) # NA counts", sep="") doItAndPrint(command) invisible(NULL) } ShapiroTest <- function(){ initializeDialog(title=gettextRcmdr("Shapiro-Wilk Test for Normality")) variableBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)")) onOK <- function(){ var <- getSelection(variableBox) if (length(var) == 0) { errorCondition(recall=ShapiroTest, message=gettextRcmdr("You must select a variable.")) return() } closeDialog() doItAndPrint(paste("shapiro.test(",ActiveDataSet(), "$", var, ")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="shapiro.test") tkgrid(getFrame(variableBox), sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2, columns=1) } # Statistics Menu dialogs # last modified 28 July 06 by J. Fox # Tables menu twoWayTable <- function(){ require("abind") initializeDialog(title=gettextRcmdr("Two-Way Table")) variablesFrame <- tkframe(top) .factors <- Factors() rowBox <- variableListBox(variablesFrame, .factors, title=gettextRcmdr("Row variable (pick one)")) columnBox <- variableListBox(variablesFrame, .factors, title=gettextRcmdr("Column variable (pick one)")) subsetBox() onOK <- function(){ row <- getSelection(rowBox) column <- getSelection(columnBox) if (length(row) == 0 || length(column) == 0){ errorCondition(recall=twoWayTable, message=gettextRcmdr("You must select two variables.")) return() } if (row == column) { errorCondition(recall=twoWayTable, message=gettextRcmdr("Row and column variables are the same.")) return() } percents <- as.character(tclvalue(percentsVariable)) chisq <- tclvalue(chisqTestVariable) chisqComp <- tclvalue(chisqComponentsVariable) expected <- tclvalue(expFreqVariable) fisher <- tclvalue(fisherTestVariable) subset <- tclvalue(subsetVariable) subset <- if (trim.blanks(subset) == gettextRcmdr("")) "" else paste(", subset=", subset, sep="") closeDialog() command <- paste("xtabs(~", row, "+", column, ", data=", ActiveDataSet(), subset, ")", sep="") logger(paste(".Table <- ", command, sep="")) assign(".Table", justDoIt(command), envir=.GlobalEnv) doItAndPrint(".Table") if (percents == "row") doItAndPrint("rowPercents(.Table) # Row Percentages") if (percents == "column") doItAndPrint("colPercents(.Table) # Column Percentages") if (percents == "total") doItAndPrint("totPercents(.Table) # Percentage of Total") if (chisq == 1) { command <- "chisq.test(.Table, correct=FALSE)" logger(paste(".Test <- ", command, sep="")) assign(".Test", justDoIt(command), envir=.GlobalEnv) doItAndPrint(".Test") if (expected == 1) doItAndPrint(".Test$expected # Expected Counts") warnText <- NULL if (0 < (nlt1 <- sum(.Test$expected < 1))) warnText <- paste(nlt1, gettextRcmdr("expected frequencies are less than 1")) if (0 < (nlt5 <- sum(.Test$expected < 5))) warnText <- paste(warnText, "\n", nlt5, gettextRcmdr(" expected frequencies are less than 5"), sep="") if (!is.null(warnText)) Message(message=warnText, type="warning") if (chisqComp == 1) { command <- "round(.Test$residuals^2, 2) # Chi-square Components" doItAndPrint(command) } logger("remove(.Test)") remove(.Test, envir=.GlobalEnv) } if (fisher == 1) doItAndPrint("fisher.test(.Table)") logger("remove(.Table)") remove(.Table, envir=.GlobalEnv) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="xtabs") radioButtons(name="percents", buttons=c("rowPercents", "columnPercents", "totalPercents", "nonePercents"), values=c("row", "column", "total", "none"), initialValue="none", labels=gettextRcmdr(c("Row percentages", "Column percentages", "Percentages of total", "No percentages")), title=gettextRcmdr("Compute Percentages")) checkBoxes(frame="testsFrame", boxes=c("chisqTest", "chisqComponents", "expFreq", "fisherTest"), initialValues=c("1", "0", "0", "0"), labels=gettextRcmdr(c("Chi-square test of independence", "Components of chi-square statistic", "Print expected frequencies", "Fisher's exact test"))) tkgrid(getFrame(rowBox), tklabel(variablesFrame, text=" "), getFrame(columnBox), sticky="nw") tkgrid(variablesFrame, sticky="w") tkgrid(percentsFrame, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Hypothesis Tests"), fg="blue"), sticky="w") tkgrid(testsFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1) } multiWayTable <- function(){ require("abind") initializeDialog(title=gettextRcmdr("Multi-Way Table")) variablesFrame <- tkframe(top) .factors <- Factors() rowBox <- variableListBox(variablesFrame, .factors, title=gettextRcmdr("Row variable (pick one)")) columnBox <- variableListBox(variablesFrame, .factors, title=gettextRcmdr("Column variable (pick one)")) controlBox <- variableListBox(variablesFrame, .factors, selectmode="multiple", title=gettextRcmdr("Control variable(s) (pick one or more)")) subsetBox() onOK <- function(){ row <- getSelection(rowBox) column <- getSelection(columnBox) controls <- getSelection(controlBox) if (length(row) == 0 || length(column) == 0 || length(controls) == 0) { errorCondition(recall=multiWayTable, message=gettextRcmdr("You must select row, column, and control variables")) return() } if ((row == column) || is.element(row, controls) || is.element(column, controls)) { errorCondition(recall=multiWayTable, message=gettextRcmdr("Row, column, and control variables must be different.")) return() } percents <- as.character(tclvalue(percentsVariable)) subset <- tclvalue(subsetVariable) subset <- if (trim.blanks(subset) == gettextRcmdr("")) "" else paste(", subset=", subset, sep="") closeDialog() command <- paste("xtabs(~", row, "+", column, "+", paste(controls, collapse="+"), ", data=", ActiveDataSet(), subset, ")", sep="") logger(paste(".Table <- ", command, sep="")) assign(".Table", justDoIt(command), envir=.GlobalEnv) doItAndPrint(".Table") if (percents == "row") doItAndPrint("rowPercents(.Table) # Row Percentages") if (percents == "column") doItAndPrint("colPercents(.Table) # Column Percentages") logger("remove(.Table)") remove(.Table, envir=.GlobalEnv) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="xtabs") radioButtons(name="percents", buttons=c("rowPercents", "columnPercents", "nonePercents"), values=c("row", "column", "none"), initialValue="none", labels=gettextRcmdr(c("Row percentages", "Column percentages", "No percentages")), title=gettextRcmdr("Compute Percentages")) tkgrid(getFrame(rowBox), tklabel(variablesFrame, text=" "), getFrame(columnBox), tklabel(variablesFrame, text=" "), getFrame(controlBox), sticky="nw") tkgrid(variablesFrame, sticky="w") tkgrid(percentsFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } enterTable <- function(){ require("abind") env <- environment() initializeDialog(title=gettextRcmdr("Enter Two-Way Table")) outerTableFrame <- tkframe(top) assign(".tableFrame", tkframe(outerTableFrame), envir=env) setUpTable <- function(...){ tkdestroy(get(".tableFrame", envir=env)) assign(".tableFrame", tkframe(outerTableFrame), envir=env) nrows <- as.numeric(tclvalue(rowsValue)) ncols <- as.numeric(tclvalue(colsValue)) make.col.names <- "tklabel(.tableFrame, text='')" for (j in 1:ncols) { col.varname <- paste(".colname.", j, sep="") assign(col.varname, tclVar(j), envir=env) make.col.names <- paste(make.col.names, ", ", "tkentry(.tableFrame, width='5', textvariable=", col.varname, ")", sep="") } eval(parse(text=paste("tkgrid(", make.col.names, ")", sep="")), envir=env) for (i in 1:nrows){ varname <- paste(".tab.", i, ".1", sep="") assign(varname, tclVar("") , envir=env) row.varname <- paste(".rowname.", i, sep="") assign(row.varname, tclVar(i), envir=env) make.row <- paste("tkentry(.tableFrame, width='5', textvariable=", row.varname, ")", sep="") make.row <- paste(make.row, ", ", "tkentry(.tableFrame, width='5', textvariable=", varname, ")", sep="") for (j in 2:ncols){ varname <- paste(".tab.", i, ".", j, sep="") assign(varname, tclVar(""), envir=env) make.row <- paste(make.row, ", ", "tkentry(.tableFrame, width='5', textvariable=", varname, ")", sep="") } eval(parse(text=paste("tkgrid(", make.row, ")", sep="")), envir=env) } tkgrid(get(".tableFrame", envir=env), sticky="w") } rowColFrame <- tkframe(top) rowsValue <- tclVar("2") rowsSlider <- tkscale(rowColFrame, from=2, to=10, showvalue=FALSE, variable=rowsValue, resolution=1, orient="horizontal", command=setUpTable) rowsShow <- tklabel(rowColFrame, textvariable=rowsValue, width=2, justify="right") colsValue <- tclVar("2") colsSlider <- tkscale(rowColFrame, from=2, to=10, showvalue=FALSE, variable=colsValue, resolution=1, orient="horizontal", command=setUpTable) colsShow <- tklabel(rowColFrame, textvariable=colsValue, width=2, justify="right") onOK <- function(){ nrows <- as.numeric(tclvalue(rowsValue)) ncols <- as.numeric(tclvalue(colsValue)) cell <- 0 counts <- rep(NA, nrows*ncols) row.names <- rep("", nrows) col.names <- rep("", ncols) for (i in 1:nrows) row.names[i] <- eval(parse(text=paste("tclvalue(", paste(".rowname.", i, sep=""),")", sep=""))) for (j in 1:ncols) col.names[j] <- eval(parse(text=paste("tclvalue(", paste(".colname.", j, sep=""),")", sep=""))) for (i in 1:nrows){ for (j in 1:ncols){ cell <- cell+1 varname <- paste(".tab.", i, ".", j, sep="") counts[cell] <- as.numeric(eval(parse(text=paste("tclvalue(", varname,")", sep="")))) } } counts <- na.omit(counts) if (length(counts) != nrows*ncols){ errorCondition(recall=enterTable, message=sprintf(gettextRcmdr("Number of valid entries (%d)\nnot equal to number of rows (%d) * number of columns (%d)."), length(counts), nrows, ncols)) return() } if (length(unique(row.names)) != nrows){ errorCondition(recall=enterTable, message=gettextRcmdr("Row names are not unique.")) return() } if (length(unique(col.names)) != ncols){ errorCondition(recall=enterTable, message=gettextRcmdr("Column names are not unique.")) return() } percents <- as.character(tclvalue(percentsVariable)) chisq <- tclvalue(chisqVariable) chisqComp <- tclvalue(chisqComponentsVariable) expected <- tclvalue(expFreqVariable) fisher <- tclvalue(fisherVariable) closeDialog() command <- paste("matrix(c(", paste(counts, collapse=","), "), ", nrows, ", ", ncols, ", byrow=TRUE)", sep="") assign(".Table", justDoIt(command), envir=.GlobalEnv) logger(paste(".Table <- ", command, sep="")) command <- paste("c(",paste(paste("'", row.names, "'", sep=""), collapse=", "), ")", sep="") justDoIt(paste("rownames(.Table) <- ", command, sep="")) logger(paste("rownames(.Table) <- ", command, sep="")) command <- paste("c(",paste(paste("'", col.names, "'", sep=""), collapse=", "), ")", sep="") justDoIt(paste("colnames(.Table) <- ", command, sep="")) logger(paste("colnames(.Table) <- ", command, sep="")) doItAndPrint(".Table # Counts") if (percents == "row") doItAndPrint("rowPercents(.Table) # Row Percentages") if (percents == "column") doItAndPrint("colPercents(.Table) # Column Percentages") if (percents == "total") doItAndPrint("totPercents(.Table) # Percentage of Total") if (chisq == 1) { command <- "chisq.test(.Table, correct=FALSE)" logger(paste(".Test <- ", command, sep="")) assign(".Test", justDoIt(command), envir=.GlobalEnv) doItAndPrint(".Test") if (expected == 1) doItAndPrint(".Test$expected # Expected Counts") warnText <- NULL if (0 < (nlt1 <- sum(.Test$expected < 1))) warnText <- paste(nlt1, gettextRcmdr("expected frequencies are less than 1")) if (0 < (nlt5 <- sum(.Test$expected < 5))) warnText <- paste(warnText, "\n", nlt5, gettextRcmdr(" expected frequencies are less than 5"), sep="") if (!is.null(warnText)) Message(message=warnText, type="warning") if (chisqComp == 1) { command <- "round(.Test$residuals^2, 2) # Chi-square Components" doItAndPrint(command) } logger("remove(.Test)") remove(.Test, envir=.GlobalEnv) } if (fisher == 1) doItAndPrint("fisher.test(.Table)") logger("remove(.Table)") remove(.Table, envir=.GlobalEnv) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="chisq.test") radioButtons(name="percents", buttons=c("rowPercents", "columnPercents", "totalPercents", "nonePercents"), values=c("row", "column", "total", "none"), initialValue="none", labels=gettextRcmdr(c("Row percentages", "Column percentages", "Percentages of total", "No percentages")), title=gettextRcmdr("Compute Percentages")) checkBoxes(frame="testsFrame", boxes=c("chisq", "chisqComponents", "expFreq", "fisher"), initialValues=c("1", "0", "0", "0"), labels=gettextRcmdr(c("Chi-square test of independence", "Components of chi-square statistic", "Print expected frequencies", "Fisher's exact test"))) tkgrid(tklabel(rowColFrame, text=gettextRcmdr("Number of Rows:")), rowsSlider, rowsShow, sticky="w") tkgrid(tklabel(rowColFrame, text=gettextRcmdr("Number of Columns:")), colsSlider, colsShow, sticky="w") tkgrid(rowColFrame, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Enter counts:"), fg="blue"), sticky="w") tkgrid(outerTableFrame, sticky="w") tkgrid(percentsFrame, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Hypothesis Tests"), fg="blue"), sticky="w") tkgrid(testsFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=7, columns=2) } # Statistics Menu dialogs # last modified 2 July 05 by J. Fox # Variances menu twoVariancesFTest <- function(){ initializeDialog(title=gettextRcmdr("Two Variances F-Test")) variablesFrame <- tkframe(top) groupBox <- variableListBox(variablesFrame, TwoLevelFactors(), title=gettextRcmdr("Groups (pick one)")) responseBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Response Variable (pick one)")) onOK <- function(){ group <- getSelection(groupBox) if (length(group) == 0) { errorCondition(recall=twoVariancesFTest, message=gettextRcmdr("You must select a groups variable.")) return() } response <- getSelection(responseBox) if (length(response) == 0) { errorCondition(recall=twoVariancesFTest, message=gettextRcmdr("You must select a response variable.")) return() } alternative <- as.character(tclvalue(alternativeVariable)) level <- tclvalue(confidenceLevel) closeDialog() .activeDataSet <- ActiveDataSet() doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", ", .activeDataSet, "$", group, ", var, na.rm=TRUE)", sep="")) doItAndPrint(paste("var.test(", response, " ~ ", group, ", alternative='", alternative, "', conf.level=", level, ", data=", .activeDataSet, ")", sep="")) tkfocus(CommanderWindow()) tkdestroy(top) } OKCancelHelp(helpSubject="var.test") radioButtons(name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"), labels=gettextRcmdr(c("Two-sided", "Difference < 0", "Difference > 0")), title=gettextRcmdr("Alternative Hypothesis")) confidenceFrame <- tkframe(top) confidenceLevel <- tclVar(".95") confidenceField <- tkentry(confidenceFrame, width="6", textvariable=confidenceLevel) tkgrid(getFrame(groupBox), tklabel(variablesFrame, text=" "), getFrame(responseBox), sticky="nw") tkgrid(variablesFrame, sticky="w") groupsLabel(groupsBox=groupBox) tkgrid(tklabel(confidenceFrame, text=gettextRcmdr("Confidence Level: "), fg="blue"), confidenceField, sticky="w") tkgrid(alternativeFrame, sticky="w") tkgrid(confidenceFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=5, columns=1) } BartlettTest <- function(){ initializeDialog(title=gettextRcmdr("Bartlett's Test")) variableFrame <- tkframe(top) groupBox <- variableListBox(variableFrame, Factors(), title=gettextRcmdr("Groups (pick one)")) responseBox <- variableListBox(variableFrame, Numeric(), title=gettextRcmdr("Response Variable (pick one)")) onOK <- function(){ group <- getSelection(groupBox) if (length(group) == 0) { errorCondition(recall=BartlettTest, message=gettextRcmdr("You must select a groups variable.")) return() } response <- getSelection(responseBox) if (length(response) == 0) { errorCondition(recall=BartlettTest, message=gettextRcmdr("You must select a response variable.")) return() } closeDialog() .activeDataSet <- ActiveDataSet() doItAndPrint(paste("tapply(", paste(.activeDataSet, "$", response, sep=""), ", ", paste(.activeDataSet, "$", group, sep=""), ", var, na.rm=TRUE)", sep="")) doItAndPrint(paste("bartlett.test(", response, " ~ ", group, ", data=", .activeDataSet, ")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="bartlett.test") tkgrid(getFrame(groupBox), tklabel(variableFrame, text=" "), getFrame(responseBox), sticky="nw") tkgrid(variableFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2, columns=1) } LeveneTest <- function(){ require("car") initializeDialog(title=gettextRcmdr("Levene's Test")) variableFrame <- tkframe(top) groupBox <- variableListBox(variableFrame, Factors(), title=gettextRcmdr("Groups (pick one)")) responseBox <- variableListBox(variableFrame, Numeric(), title=gettextRcmdr("Response Variable (pick one)")) onOK <- function(){ group <- getSelection(groupBox) if (length(group) == 0) { errorCondition(recall=LeveneTest, message=gettextRcmdr("You must select a groups variable.")) return() } response <- getSelection(responseBox) if (length(response) == 0) { errorCondition(recall=LeveneTest, message=gettextRcmdr("You must select a response variable.")) return() } closeDialog() .activeDataSet <- ActiveDataSet() doItAndPrint(paste("tapply(", paste(.activeDataSet, "$", response, sep=""), ", ", paste(.activeDataSet, "$", group, sep=""), ", var, na.rm=TRUE)", sep="")) doItAndPrint(paste("levene.test(", paste(.activeDataSet, "$", response, sep=""), ", ", paste(.activeDataSet, "$", group, sep=""), ")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="levene.test") tkgrid(getFrame(groupBox), tklabel(variableFrame, text=" "), getFrame(responseBox), sticky="nw") tkgrid(variableFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2, columns=1) } # last modified 24 May 2007 by J. Fox + slight changes 12 Aug 04 by Ph. Grosjean # 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(eval(parse(text=.x), envir=envir))))) # + PhG } listLinearModels <- function(envir=.GlobalEnv, ...) { objects <- ls(envir=envir, ...) if (length(objects) == 0) NULL else objects[sapply(objects, function(.x) "lm" == (class(eval(parse(text=.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(eval(parse(text=.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(eval(parse(text=.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(eval(parse(text=.x), envir=envir))[1]))] } listAllModels <- function(envir=.GlobalEnv, ...) { objects <- ls(envir=envir, ...) if (length(objects) == 0) NULL else objects[sapply(objects, function(.x) (class(eval(parse(text=.x), envir=envir))[1])) %in% getRcmdr("modelClasses")] } activeDataSet <- function(dsname, flushModel=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(get(dsname, envir=.GlobalEnv))){ Message(message=paste(dsname, gettextRcmdr(" is not a data frame and cannot be attached."), sep=""), type="error") tkfocus(CommanderWindow()) return() } varnames <- names(eval(parse(text=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("")) } # -PhG tkconfigure(.modelLabel, fg="red") ActiveDataSet(dsname) Message(sprintf(gettextRcmdr("The dataset %s has %d rows and %d columns."), dsname, nrow(eval(parse(text=dsname))), ncol(eval(parse(text=dsname)))), 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") Variables(listVariables()) Numeric(listNumeric()) Factors(listFactors()) TwoLevelFactors(listTwoLevelFactors()) RcmdrTclSet("dataSetName", paste(" ", dsname, " ")) # -PhG tkconfigure(.dataSetLabel, fg="blue") if (!is.SciViews()) tkconfigure(getRcmdr("dataSetLabel"), fg="blue") else refreshStatus() # +PhG if (getRcmdr("attach.data.set")){ attach(get(dsname, envir=.GlobalEnv), name=dsname) logger(paste("attach(", dsname, ")", sep="")) } if (is.SciViews()) refreshStatus() else if (flushModel) tkconfigure(getRcmdr("modelLabel"), fg="red") # +PhG (& J.Fox, 25Dec04) 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, " ")) # -PhG tkconfigure(.modelLabel, fg="blue") if (!is.SciViews()) tkconfigure(getRcmdr("modelLabel"), fg="blue") else refreshStatus() # +PhG activateMenus() model } listVariables <- function(dataSet=ActiveDataSet()) { vars <- eval(parse(text=paste("names(", dataSet,")")), envir=.GlobalEnv) if (getRcmdr("sort.names")) sort(vars) else vars } listFactors <- function(dataSet=ActiveDataSet()) { variables <- if (exists("variables", envir=RcmdrEnv())) getRcmdr("variables") else listVariables(dataSet) variables[sapply(variables, function(.x) is.factor(eval(parse(text=.x), envir=eval(parse(text=dataSet), envir=.GlobalEnv))))] } listTwoLevelFactors <- function(dataSet=ActiveDataSet()){ factors <- listFactors(dataSet) if(length(factors) == 0) return(NULL) factors[sapply(factors, function(.x) 2 == length(levels(eval(parse(text=.x), envir=eval(parse(text=dataSet), envir=.GlobalEnv)))))] } listNumeric <- function(dataSet=ActiveDataSet()) { variables <- if (exists("variables", envir=RcmdrEnv())) getRcmdr("variables") else listVariables(dataSet) variables[sapply(variables,function(.x) is.numeric(eval(parse(text=.x), envir=eval(parse(text=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, ...){ R <- cor(X, ...) RI <- solve(R) D <- 1/sqrt(diag(RI)) R <- - RI * (D %o% D) diag(R) <- 0 rownames(R) <- colnames(R) <- colnames(X) R } Confint <- function(object, parm, level=0.95, ...) UseMethod("Confint") Confint.default <- function(object, parm, level = 0.95, ...) confint(object, parm, level, ...) Confint.glm <- function (object, parm, level=0.95, type=c("LR", "Wald"), ...){ # adapted from stats:::confint.lm type <- match.arg(type) if (type == "LR") return(MASS:::confint.glm(object, parm, level, ...)) 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.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 cf <- coef(object) if (is.vector(cf)) cf <- matrix(cf, nrow=1, dimnames=list(MLM.1$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)) } numSummary <- function(data, statistics=c("mean", "sd", "quantiles"), quantiles=c(0, .25, .5, .75, 1), groups){ if(!require(abind)) stop("abind package missing") data <- as.data.frame(data) if (!missing(groups)) groups <- as.factor(groups) variables <- names(data) statistics <- match.arg(statistics, c("mean", "sd", "quantiles"), several.ok=TRUE) 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")[c("mean", "sd") %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)) 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) NAs <- tapply(data[, variables], groups, function(x) sum(is.na(x))) n <- table(groups) - NAs result$type <- 2 } else if ((ngroups == 1) ){ table <- matrix(0, nvars, nstats) rownames(table) <- if (length(variables) > 1) variables else "" colnames(table) <- stats if ("mean" %in% stats) table[,"mean"] <- mean(data[, variables], na.rm=TRUE) if ("sd" %in% stats) table[,"sd"] <- sd(data[, variables], na.rm=TRUE) 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 ("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){ table <- cbind(table, t(n)) colnames(table)[ncol(table)] <- "n" if (!is.null(NAs)) { table <- cbind(table, t(NAs)) colnames(table)[ncol(table)] <- "NA" } 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) } # wrapper function for histograms Hist <- function(x, scale=c("frequency", "percent", "density"), ...){ xlab <- deparse(substitute(x)) x <- na.omit(x) scale <- match.arg(scale) if (scale == "frequency") hist(x, xlab=xlab, main="", ...) else if (scale == "density") hist(x, freq=FALSE, xlab=xlab, main="", ...) else { n <- length(x) hist(x, axes=FALSE, xlab=xlab, ylab="Percent", main="", ...) 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, col="gray") invisible(NULL) } stem.leaf <- function(data, unit, m, Min, Max, rule.line=c("Dixon", "Velleman", "Sturges"), style=c("Tukey", "bare"), trim.outliers=TRUE, depths=TRUE, reverse.negative.leaves=TRUE){ #Author: Peter Wolf 05/2003 (modified slightly by J. Fox, 20 July 03) rule.line <- match.arg(rule.line) style <- match.arg(style) n <- length(data<-sort(data)) row.max <- floor( c(Dixon =10*log(n,10), Velleman=2*sqrt(n), Sturges =1+log(n,2) ))[rule.line] stats <- boxplot(data, plot=FALSE) if(missing(Min)) Min <- if (trim.outliers) stats$stats[1,1] else min(data, na.rm=TRUE) if(missing(Max)) Max <- if (trim.outliers) stats$stats[5,1] else max(data, na.rm=TRUE) spannweite.red <- Max - Min zeilen.intervall.laenge<-spannweite.red / row.max factor <- if(missing(unit)) 10^ceiling(log(zeilen.intervall.laenge,10)) else 10^round(log(unit*10,10)) z <- zeilen.intervall.laenge/factor # z in (0.1 ,1] delta.tick <- c(.2,.2,.5,1)[sum(z > c(0,.1,.2,.5))] if(missing(m)) m <- round(1/delta.tick) else delta.tick <- 1/m data.tr <- data/factor Min.tr <- Min/factor Max.tr <- Max/factor spannweite.red <- Max.tr - Min.tr sk.min <- floor(Min.tr) sk.max <- ceiling(Max.tr) skala <- seq(sk.min, sk.max, by=delta.tick) if(sk.min < 0) skala <- c(sk.min-delta.tick, skala) if(sk.max < 0) skala <- skala[-length(skala)] lo.limit <- if (trim.outliers) skala[1] else -Inf lo.log <- if(skala[1] < 0) data.tr <= lo.limit else data.tr < lo.limit n.sk <- length(skala) hi.limit <- if (trim.outliers) skala[n.sk] + delta.tick else Inf hi.log <- if(skala[n.sk] >= 0) data.tr >= hi.limit else data.tr > hi.limit n.lower.extr.values <- sum(lo.log); n.upper.extr.values <- sum(hi.log) if(0 < n.lower.extr.values){ lower.line<- paste("LO:", paste(data[lo.log],collapse=" ")) } if(0 < n.upper.extr.values){ upper.line<- paste("HI:", paste(data[hi.log],collapse=" ")) } data.tr.red <-data.tr[(!lo.log)&(!hi.log)] stem <- ifelse(data.tr.red < 0, ceiling(data.tr.red), floor(data.tr.red) ) leaf <- floor(abs(data.tr.red*10 - stem*10)) class.of.data.tr <- unlist(c( sapply(data.tr.red[data.tr.red < 0], function(x, sk) length(sk) - sum(-sk <= -x), skala) ,sapply(data.tr.red[data.tr.red>=0], function(x,sk) sum(sk <= x), skala) )) class.of.data.tr <- c(1:length(skala), class.of.data.tr) class.negative <- skala < 0 leaf.grouped <- split(c(rep(-1, length(skala)), leaf), class.of.data.tr) leaf.grouped <- lapply(leaf.grouped, function(x){ sort(x[-1]) }) if (reverse.negative.leaves){ for (i in seq(class.negative)) if (class.negative[i]) leaf.grouped[[i]] <- rev(leaf.grouped[[i]]) } leaf.grouped.ch <- paste("|",unlist(lapply(leaf.grouped,paste,collapse=""))) class.neg.zero <- floor(skala) == -1 line.names <- skala line.names[class.negative] <- line.names[class.negative] + 1 line.names <- as.character(floor(line.names)) line.names[class.neg.zero] <- "-0" if(style=="Tukey"){ switch(as.character(m), "1"={}, "2"={ h<-round(2*(skala%%1)) #; line.names[h!=0] <- "" line.names<-paste(line.names, ifelse(skala<0,c(".","*")[1+h],c("*",".")[1+h]),sep="") }, "5"={ h<-round(5*(skala%%1)); line.names[h>0 & h<4] <- "" line.names<-paste(line.names, ifelse(skala<0, c(".","s","f","t","*")[1+h], c("*","t","f","s",".")[1+h]), sep="") } ) } ragged.left<-function(ch.lines){ max.n <-max(n.lines<-nchar(ch.lines)) h <-paste(rep(" ",max.n),collapse="") ch.lines <-paste( substring(h,1,1+max.n-n.lines), ch.lines) ch.lines } line.names <- ragged.left(line.names) n.class <- unlist(lapply(leaf.grouped, length)) select <- (cumsum(n.class) > 0) & rev((cumsum(rev(n.class)) > 0)) depth <- cumsum(n.class) + n.lower.extr.values depth.rev <- rev(cumsum(rev(n.class)) + n.upper.extr.values) uplow <- depth >= depth.rev pos.median <- which(uplow)[1] + (-1:0) h <- abs(depth[pos.median]-depth.rev[pos.median]) pos.median <- pos.median[1]+(h[1]>h[2]) depth[uplow] <- depth.rev[uplow] depth <- paste(depth,"") depth[pos.median] <- paste("(",n.class[pos.median],")",sep="") depth[n.class == 0] <- " " depth <- if (depths) ragged.left(depth) else "" info<- c( paste("1 | 2: represents",1.2*factor), paste(" leaf unit:",factor/10), paste(" n:",n ), "") stem <- paste(depth, line.names, leaf.grouped.ch) if ((style != "Tukey") || (m != 5) || (sum(select) > 4)) stem <- stem[select] if(exists("lower.line")) stem <- c(lower=lower.line, stem) if(exists("upper.line")) stem <- c(stem, upper=upper.line) result <- list(info=info, stem=stem) class(result) <- "stem.leaf" result } print.stem.leaf <- function(x, ...){ for(i in seq(x)) cat(x[[i]],sep="\n") invisible(x) } 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) yrange <- if (error.bars != "none") c( min(means - sds), max(means + sds)) else range(means) 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) yrange <- if (error.bars != "none") c( min(means - sds), max(means + sds)) else range(means) levs.1 <- levels(factor1) levs.2 <- levels(factor2) n.levs.1 <- length(levs.1) n.levs.2 <- length(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), 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 + 0.25 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) } 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) 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(min(xx), tapply(xx, KMeans(xx, bins)$cluster, max)) cut(x, breaks, include.lowest=TRUE, labels=labels) } as.factor(x) } # 3D scatterplots and point identification via rgl ellipsoid <- function(center=c(0, 0, 0), radius=1, shape=diag(3), n=30){ # adapted from the shapes3d demo in the rgl package degvec <- seq(0, 2*pi, length=n) ecoord2 <- function(p) c(cos(p[1])*sin(p[2]), sin(p[1])*sin(p[2]), cos(p[2])) v <- t(apply(expand.grid(degvec,degvec), 1, ecoord2)) v <- center + radius * t(v %*% chol(shape)) v <- rbind(v, rep(1,ncol(v))) e <- expand.grid(1:(n-1), 1:n) i1 <- apply(e, 1, function(z) z[1] + n*(z[2] - 1)) i2 <- i1 + 1 i3 <- (i1 + n - 1) %% n^2 + 1 i4 <- (i2 + n - 1) %% n^2 + 1 i <- rbind(i1, i2, i4, i3) qmesh3d(v, i) } scatter3d <- function(x, y, z, xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), axis.scales=TRUE, zlab=deparse(substitute(z)), revolutions=0, bg.col=c("white", "black"), axis.col=if (bg.col == "white") c("darkmagenta", "black", "darkcyan") else c("darkmagenta", "white", "darkcyan"), surface.col=c("blue", "green", "orange", "magenta", "cyan", "red", "yellow", "gray"), neg.res.col="red", pos.res.col="green", square.col=if (bg.col == "white") "black" else "gray", point.col="yellow", text.col=axis.col, grid.col=if (bg.col == "white") "black" else "gray", fogtype=c("exp2", "linear", "exp", "none"), residuals=(length(fit) == 1), surface=TRUE, fill=TRUE, grid=TRUE, grid.lines=26, df.smooth=NULL, df.additive=NULL, sphere.size=1, threshold=0.01, speed=1, fov=60, fit="linear", groups=NULL, parallel=TRUE, ellipsoid=FALSE, level=0.5, model.summary=FALSE){ require(rgl) require(mgcv) if (residuals == "squares"){ residuals <- TRUE squares <- TRUE } else squares <- FALSE summaries <- list() if ((!is.null(groups)) && (nlevels(groups) > length(surface.col))) stop(sprintf(gettextRcmdr("Number of groups (%d) exceeds number of colors (%d)."), nlevels(groups), length(surface.col))) if ((!is.null(groups)) && (!is.factor(groups))) stop(gettextRcmdr("groups variable must be a factor.")) bg.col <- match.arg(bg.col) fogtype <- match.arg(fogtype) if ((length(fit) > 1) && residuals && surface) stop(gettextRcmdr("cannot plot both multiple surfaces and residuals")) xlab # cause these arguments to be evaluated ylab zlab rgl.clear() rgl.viewpoint(fov=fov) rgl.bg(col=bg.col, fogtype=fogtype) valid <- if (is.null(groups)) complete.cases(x, y, z) else complete.cases(x, y, z, groups) x <- x[valid] y <- y[valid] z <- z[valid] minx <- min(x) maxx <- max(x) miny <- min(y) maxy <- max(y) minz <- min(z) maxz <- max(z) if (axis.scales){ lab.min.x <- nice(minx) lab.max.x <- nice(maxx) lab.min.y <- nice(miny) lab.max.y <- nice(maxy) lab.min.z <- nice(minz) lab.max.z <- nice(maxz) minx <- min(lab.min.x, minx) maxx <- max(lab.max.x, maxx) miny <- min(lab.min.y, miny) maxy <- max(lab.max.y, maxy) minz <- min(lab.min.z, minz) maxz <- max(lab.max.z, maxz) min.x <- (lab.min.x - minx)/(maxx - minx) max.x <- (lab.max.x - minx)/(maxx - minx) min.y <- (lab.min.y - miny)/(maxy - miny) max.y <- (lab.max.y - miny)/(maxy - miny) min.z <- (lab.min.z - minz)/(maxz - minz) max.z <- (lab.max.z - minz)/(maxz - minz) } if (!is.null(groups)) groups <- groups[valid] x <- (x - minx)/(maxx - minx) y <- (y - miny)/(maxy - miny) z <- (z - minz)/(maxz - minz) size <- sphere.size*((100/length(x))^(1/3))*0.015 if (is.null(groups)){ if (size > threshold) rgl.spheres(x, y, z, color=point.col, radius=size) else rgl.points(x, y, z, color=point.col) } else { if (size > threshold) rgl.spheres(x, y, z, color=surface.col[as.numeric(groups)], radius=size) else rgl.points(x, y, z, color=surface.col[as.numeric(groups)]) } if (!axis.scales) axis.col[1] <- axis.col[3] <- axis.col[2] rgl.lines(c(0,1), c(0,0), c(0,0), color=axis.col[1]) rgl.lines(c(0,0), c(0,1), c(0,0), color=axis.col[2]) rgl.lines(c(0,0), c(0,0), c(0,1), color=axis.col[3]) rgl.texts(1, 0, 0, xlab, adj=1, color=axis.col[1]) rgl.texts(0, 1.05, 0, ylab, adj=1, color=axis.col[2]) rgl.texts(0, 0, 1, zlab, adj=1, color=axis.col[3]) if (axis.scales){ rgl.texts(min.x, -0.05, 0, lab.min.x, col=axis.col[1]) rgl.texts(max.x, -0.05, 0, lab.max.x, col=axis.col[1]) rgl.texts(0, -0.1, min.z, lab.min.z, col=axis.col[3]) rgl.texts(0, -0.1, max.z, lab.max.z, col=axis.col[3]) rgl.texts(-0.05, min.y, -0.05, lab.min.y, col=axis.col[2]) rgl.texts(-0.05, max.y, -0.05, lab.max.y, col=axis.col[2]) } if (ellipsoid) { dfn <- 3 if (is.null(groups)){ dfd <- length(x) - 1 radius <- sqrt(dfn * qf(level, dfn, dfd)) ellips <- ellipsoid(center=c(mean(x), mean(y), mean(z)), shape=cov(cbind(x,y,z)), radius=radius) if (fill) shade3d(ellips, col=surface.col[1], alpha=0.1, lit=FALSE) if (grid) wire3d(ellips, col=surface.col[1], lit=FALSE) } else{ levs <- levels(groups) for (j in 1:length(levs)){ group <- levs[j] select.obs <- groups == group xx <- x[select.obs] yy <- y[select.obs] zz <- z[select.obs] dfd <- length(xx) - 1 radius <- sqrt(dfn * qf(level, dfn, dfd)) ellips <- ellipsoid(center=c(mean(xx), mean(yy), mean(zz)), shape=cov(cbind(xx,yy,zz)), radius=radius) if (fill) shade3d(ellips, col=surface.col[j], alpha=0.1, lit=FALSE) if (grid) wire3d(ellips, col=surface.col[j], lit=FALSE) coords <- ellips$vb[, which.max(ellips$vb[1,])] if (!surface) rgl.texts(coords[1] + 0.05, coords[2], coords[3], group, col=surface.col[j]) } } } if (surface){ vals <- seq(0, 1, length=grid.lines) dat <- expand.grid(x=vals, z=vals) for (i in 1:length(fit)){ f <- match.arg(fit[i], c("linear", "quadratic", "smooth", "additive")) if (is.null(groups)){ mod <- switch(f, linear = lm(y ~ x + z), quadratic = lm(y ~ (x + z)^2 + I(x^2) + I(z^2)), smooth = if (is.null(df.smooth)) gam(y ~ s(x, z)) else gam(y ~ s(x, z, fx=TRUE, k=df.smooth)), additive = if (is.null(df.additive)) gam(y ~ s(x) + s(z)) else gam(y ~ s(x, fx=TRUE, k=df.additive[1]+1) + s(z, fx=TRUE, k=(rev(df.additive+1)[1]+1))) ) if (model.summary) summaries[[f]] <- summary(mod) yhat <- matrix(predict(mod, newdata=dat), grid.lines, grid.lines) if (fill) rgl.surface(vals, vals, yhat, color=surface.col[i], alpha=0.5, lit=FALSE) if(grid) rgl.surface(vals, vals, yhat, color=if (fill) grid.col else surface.col[i], alpha=0.5, lit=FALSE, front="lines", back="lines") if (residuals){ n <- length(y) fitted <- fitted(mod) colors <- ifelse(residuals(mod) > 0, pos.res.col, neg.res.col) rgl.lines(as.vector(rbind(x,x)), as.vector(rbind(y,fitted)), as.vector(rbind(z,z)), color=as.vector(rbind(colors,colors))) if (squares){ res <- y - fitted xx <- as.vector(rbind(x, x, x + res, x + res)) yy <- as.vector(rbind(y, fitted, fitted, y)) zz <- as.vector(rbind(z, z, z, z)) rgl.quads(xx, yy, zz, color=square.col, alpha=0.5, lit=FALSE) rgl.lines(xx, yy, zz, color=square.col) } } } else{ if (parallel){ mod <- switch(f, linear = lm(y ~ x + z + groups), quadratic = lm(y ~ (x + z)^2 + I(x^2) + I(z^2) + groups), smooth = if (is.null(df.smooth)) gam(y ~ s(x, z) + groups) else gam(y ~ s(x, z, fx=TRUE, k=df.smooth) + groups), additive = if (is.null(df.additive)) gam(y ~ s(x) + s(z) + groups) else gam(y ~ s(x, fx=TRUE, k=df.additive[1]+1) + s(z, fx=TRUE, k=(rev(df.additive+1)[1]+1)) + groups) ) if (model.summary) summaries[[f]] <- summary(mod) levs <- levels(groups) for (j in 1:length(levs)){ group <- levs[j] select.obs <- groups == group yhat <- matrix(predict(mod, newdata=cbind(dat, groups=group)), grid.lines, grid.lines) if (fill) rgl.surface(vals, vals, yhat, color=surface.col[j], alpha=0.5, lit=FALSE) if (grid) rgl.surface(vals, vals, yhat, color=if (fill) grid.col else surface.col[j], alpha=0.5, lit=FALSE, front="lines", back="lines") rgl.texts(1, predict(mod, newdata=data.frame(x=1, z=1, groups=group)), 1, paste(group, " "), adj=1, color=surface.col[j]) if (residuals){ yy <- y[select.obs] xx <- x[select.obs] zz <- z[select.obs] fitted <- fitted(mod)[select.obs] res <- yy - fitted rgl.lines(as.vector(rbind(xx,xx)), as.vector(rbind(yy,fitted)), as.vector(rbind(zz,zz)), col=surface.col[j]) if (squares) { xxx <- as.vector(rbind(xx, xx, xx + res, xx + res)) yyy <- as.vector(rbind(yy, fitted, fitted, yy)) zzz <- as.vector(rbind(zz, zz, zz, zz)) rgl.quads(xxx, yyy, zzz, color=surface.col[j], alpha=0.5, lit=FALSE) rgl.lines(xxx, yyy, zzz, color=surface.col[j]) } } } } else { levs <- levels(groups) for (j in 1:length(levs)){ group <- levs[j] select.obs <- groups == group mod <- switch(f, linear = lm(y ~ x + z, subset=select.obs), quadratic = lm(y ~ (x + z)^2 + I(x^2) + I(z^2), subset=select.obs), smooth = if (is.null(df.smooth)) gam(y ~ s(x, z), subset=select.obs) else gam(y ~ s(x, z, fx=TRUE, k=df.smooth), subset=select.obs), additive = if (is.null(df.additive)) gam(y ~ s(x) + s(z), subset=select.obs) else gam(y ~ s(x, fx=TRUE, k=df.additive[1]+1) + s(z, fx=TRUE, k=(rev(df.additive+1)[1]+1)), subset=select.obs) ) if (model.summary) summaries[[paste(f, ".", group, sep="")]] <- summary(mod) yhat <- matrix(predict(mod, newdata=dat), grid.lines, grid.lines) if (fill) rgl.surface(vals, vals, yhat, color=surface.col[j], alpha=0.5, lit=FALSE) if (grid) rgl.surface(vals, vals, yhat, color=if (fill) grid.col else surface.col[j], alpha=0.5, lit=FALSE, front="lines", back="lines") rgl.texts(1, predict(mod, newdata=data.frame(x=1, z=1, groups=group)), 1, paste(group, " "), adj=1, color=surface.col[j]) if (residuals){ yy <- y[select.obs] xx <- x[select.obs] zz <- z[select.obs] fitted <- fitted(mod) res <- yy - fitted rgl.lines(as.vector(rbind(xx,xx)), as.vector(rbind(yy,fitted)), as.vector(rbind(zz,zz)), col=surface.col[j]) if (squares) { xxx <- as.vector(rbind(xx, xx, xx + res, xx + res)) yyy <- as.vector(rbind(yy, fitted, fitted, yy)) zzz <- as.vector(rbind(zz, zz, zz, zz)) rgl.quads(xxx, yyy, zzz, color=surface.col[j], alpha=0.5, lit=FALSE) rgl.lines(xxx, yyy, zzz, color=surface.col[j]) } } } } } } } if (revolutions > 0) { for (i in 1:revolutions){ for (angle in seq(1, 360, length=360/speed)) rgl.viewpoint(-angle, fov=fov) } } if (model.summary) return(summaries) else return(invisible(NULL)) } # the following function is a slight modification of rgl.select3d() in the rgl package, # altered to pass through arguments (via ...) to rgl.select() Rcmdr.select3d <- function (...) { rgl:::.check3d() rect <- rgl:::rgl.select(...) llx <- rect[1] lly <- rect[2] urx <- rect[3] ury <- rect[4] if (llx > urx) { temp <- llx llx <- urx urx <- temp } if (lly > ury) { temp <- lly lly <- ury ury <- temp } proj <- rgl:::rgl.projection() function(x, y, z) { pixel <- rgl.user2window(x, y, z, proj = proj) apply(pixel, 1, function(p) (llx <= p[1]) && (p[1] <= urx) && (lly <= p[2]) && (p[2] <= ury) && (0 <= p[3]) && (p[3] <= 1)) } } identify3d <- function (x, y, z, axis.scales=TRUE, groups = NULL, labels = 1:length(x), col = c("blue", "green", "orange", "magenta", "cyan", "red", "yellow", "gray"), offset = ((100/length(x))^(1/3)) * 0.02) { valid <- if (is.null(groups)) complete.cases(x, y, z) else complete.cases(x, y, z, groups) labels <- labels[valid] x <- x[valid] y <- y[valid] z <- z[valid] minx <- min(x) maxx <- max(x) miny <- min(y) maxy <- max(y) minz <- min(z) maxz <- max(z) if (axis.scales){ lab.min.x <- nice(minx) lab.max.x <- nice(maxx) lab.min.y <- nice(miny) lab.max.y <- nice(maxy) lab.min.z <- nice(minz) lab.max.z <- nice(maxz) minx <- min(lab.min.x, minx) maxx <- max(lab.max.x, maxx) miny <- min(lab.min.y, miny) maxy <- max(lab.max.y, maxy) minz <- min(lab.min.z, minz) maxz <- max(lab.max.z, maxz) min.x <- (lab.min.x - minx)/(maxx - minx) max.x <- (lab.max.x - minx)/(maxx - minx) min.y <- (lab.min.y - miny)/(maxy - miny) max.y <- (lab.max.y - miny)/(maxy - miny) min.z <- (lab.min.z - minz)/(maxz - minz) max.z <- (lab.max.z - minz)/(maxz - minz) } x <- (x - minx)/(maxx - minx) y <- (y - miny)/(maxy - miny) z <- (z - minz)/(maxz - minz) rgl.bringtotop() identified <- character(0) groups <- if (!is.null(groups)) as.numeric(groups[valid]) else rep(1, length(x)) repeat { f <- Rcmdr.select3d(button="right") which <- f(x, y, z) if (!any(which)) break rgl.texts(x[which], y[which] + offset, z[which], labels[which], color = col[groups][which]) identified <- c(identified, labels[which]) } unique(identified) } # 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() tkwm.title(tt, if (length(title)) title[(i - 1)%%length(title) + 1] else "") txt <- tktext(tt, bg = "white", font = getRcmdr("logFont")) scr <- tkscrollbar(tt, repeatinterval = 5, 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() { if (as.numeric(R.Version()$major) >= 2) print(help("Commander")) else help("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"), "/Getting-Started-with-the-Rcmdr.pdf", sep="")) } # functions for building dialog boxes # the following function is slightly modified 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=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, expr={ buttonsFrame <- tkframe(window, borderwidth=5) OKbutton <- tkbutton(buttonsFrame, text=gettextRcmdr("OK"), fg="darkgreen", width="12", command=onOK, default="active", borderwidth=3) onCancel <- function() { if (model) putRcmdr("modelNumber", getRcmdr("modelNumber") - 1) if (GrabFocus()) tkgrab.release(window) tkdestroy(window) tkfocus(CommanderWindow()) } cancelButton <- tkbutton(buttonsFrame, text=gettextRcmdr("Cancel"), fg="red", width="12", command=onCancel, borderwidth=3) if (!is.null(helpSubject)){ onHelp <- function() { if (GrabFocus() && .Platform$OS.type != "windows") tkgrab.release(window) if (as.numeric(R.Version()$major) >= 2) print(help(helpSubject)) else help(helpSubject) } helpButton <- tkbutton(buttonsFrame, text=gettextRcmdr("Help"), width="12", command=onHelp, borderwidth=3) } tkgrid(OKbutton, tklabel(buttonsFrame, text=" "), cancelButton, tklabel(buttonsFrame, text=" "), if (!is.null(helpSubject)) helpButton, sticky="w") }) subOKCancelHelp <- defmacro(window=subdialog, helpSubject=NULL, expr={ subButtonsFrame <- tkframe(window, borderwidth=5) subOKbutton <- tkbutton(subButtonsFrame, text=gettextRcmdr("OK"), fg="darkgreen", width="12", command=onOKsub, default="active", borderwidth=3) onCancelSub <- function() { if (GrabFocus()) tkgrab.release(window) tkdestroy(window) tkfocus(CommanderWindow()) } subCancelButton <- tkbutton(subButtonsFrame, text=gettextRcmdr("Cancel"), fg="red", width="12", command=onCancelSub, borderwidth=3) if (!is.null(helpSubject)){ onHelpSub <- function(){ if (GradFocus() && .Platform$OS.type != "windows") tkgrab.release(window) if (as.numeric(R.Version()$major) >= 2) print(help(helpSubject)) else help(helpSubject) } subHelpButton <- tkbutton(subButtonsFrame, text=gettextRcmdr("Help"), width="12", command=onHelpSub, borderwidth=3) } tkgrid(subOKbutton, tklabel(subButtonsFrame, text=" "), subCancelButton, tklabel(subButtonsFrame, text=" "), if (!is.null(helpSubject)) subHelpButton, sticky="w") }) 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=FALSE, expr={ if ((!preventCrisp) && getRcmdr("crisp.dialogs")) tclServiceMode(on=FALSE) window <- tktoplevel(borderwidth=10) tkwm.title(window, title) position <- if (is.SciViews()) -1 else commanderPosition() # +PhG position <- if (any(position < 0)) "-50+50" else paste("+", paste(offset + position, collapse="+"), sep="") tkwm.geometry(window, position) } ) closeDialog <- defmacro(window=top, release=TRUE, expr={ if (release && GrabFocus()) tkgrab.release(window) tkdestroy(window) } ) dialogSuffix <- defmacro(window=top, onOK=onOK, rows=1, columns=1, focus=top, bindReturn=TRUE, preventGrabFocus=FALSE, preventDoubleClick=FALSE, preventCrisp=FALSE, expr={ for (row in 0:(rows-1)) tkgrid.rowconfigure(window, row, weight=0) for (col in 0:(columns-1)) tkgrid.columnconfigure(window, col, weight=0) .Tcl("update idletasks") tkwm.resizable(window, 0, 0) if (bindReturn) tkbind(window, "", onOK) if (getRcmdr("double.click") && (!preventDoubleClick)) tkbind(window, "", 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 ((!preventCrisp) && getRcmdr("crisp.dialogs")) tclServiceMode(on=TRUE) } ) variableListBox <- function(parentWindow, variableList=Variables(), bg="white", selectmode="single", export="FALSE", initialSelection=NULL, listHeight=4, title){ if (selectmode == "multiple") selectmode <- getRcmdr("multiple.select.mode") if (length(variableList) == 1 && is.null(initialSelection)) initialSelection <- 0 frame <- tkframe(parentWindow) listbox <- tklistbox(frame, height=min(listHeight, length(variableList)), selectmode=selectmode, background=bg, exportselection=export, width=max(20, nchar(variableList))) scrollbar <- tkscrollbar(frame, repeatinterval=5, command=function(...) tkyview(listbox, ...)) tkconfigure(listbox, yscrollcommand=function(...) tkset(scrollbar, ...)) for (var in variableList) tkinsert(listbox, "end", var) if (is.numeric(initialSelection)) tkselection.set(listbox, initialSelection) 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) tkbind(listbox, "", onClick) tkgrid(tklabel(frame, text=title, fg="blue"), columnspan=2, sticky="w") tkgrid(listbox, scrollbar, sticky="nw") tkgrid.configure(scrollbar, sticky="wns") tkgrid.configure(listbox, sticky="ew") 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 } radioButtons <- defmacro(window=top, name, buttons, values=NULL, initialValue=..values[1], labels, title, 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)) tkgrid(tklabel(eval(parse(text=..frame)), text=title, fg="blue"), columnspan=2, sticky="w") for (i in 1:length(buttons)) { ..button <- paste(buttons[i], "Button", sep="") assign(..button, tkradiobutton(eval(parse(text=..frame)), variable=eval(parse(text=..variable)), value=..values[i])) tkgrid(tklabel(eval(parse(text=..frame)), text=labels[i], justify="left"), eval(parse(text=..button)), sticky="w") } } ) checkBoxes <- defmacro(window=top, frame, boxes, initialValues=NULL, labels, expr={ ..initialValues <- if (is.null(initialValues)) rep("1", length(boxes)) else initialValues assign(frame, tkframe(window)) ..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, tkcheckbutton(eval(parse(text=frame)), variable=eval(parse(text=..variables[i])))) tkgrid(tklabel(eval(parse(text=frame)), text=labels[i]), 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={ if (model) putRcmdr("modelNumber", getRcmdr("modelNumber") - 1) if (GrabFocus()) tkgrab.release(window) tkdestroy(window) Message(message=message, type="error") if (!is.null(recall)) recall() else tkfocus(CommanderWindow()) }) subsetBox <- defmacro(window=top, model=FALSE, expr={ subsetVariable <- if (model){ if (currentModel && currentFields$subset != "") tclVar(currentFields$subset) else tclVar(gettextRcmdr("")) } else tclVar(gettextRcmdr("")) subsetFrame <- tkframe(window) subsetEntry <- tkentry(subsetFrame, width="20", textvariable=subsetVariable) subsetScroll <- tkscrollbar(subsetFrame, orient="horizontal", repeatinterval=5, command=function(...) tkxview(subsetEntry, ...)) tkconfigure(subsetEntry, xscrollcommand=function(...) tkset(subsetScroll, ...)) tkgrid(tklabel(subsetFrame, text=gettextRcmdr("Subset expression"), fg="blue"), sticky="w") tkgrid(subsetEntry, sticky="w") tkgrid(subsetScroll, sticky="ew") }) groupsBox <- defmacro(recall=NULL, label=gettextRcmdr("Plot by:"), initialLabel=gettextRcmdr("Plot by groups"), plotLinesByGroup=FALSE, positionLegend=FALSE, plotLinesByGroupsText=gettextRcmdr("Plot lines by group"), expr={ env <- environment() .groups <- FALSE .linesByGroup <- FALSE .groupsLabel <- tclVar(paste(initialLabel, "...", sep="")) .factors <- Factors() onGroups <- function(){ if (length(.factors) == 0){ errorCondition(recall=recall, message=gettextRcmdr("There are no factors in the active data set.")) return() } initializeDialog(subdialog, title=gettextRcmdr("Groups")) groupsBox <- variableListBox(subdialog, .factors, title=gettextRcmdr("Groups variable (pick one)")) if (plotLinesByGroup){ linesByGroupFrame <- tkframe(subdialog) linesByGroup <- tclVar("1") linesCheckBox <- tkcheckbutton(linesByGroupFrame, variable=linesByGroup) tkgrid(tklabel(linesByGroupFrame, text=plotLinesByGroupsText), linesCheckBox, sticky="w") } onOKsub <- function() { groups <- getSelection(groupsBox) if (length(groups) == 0){ assign(".groups", FALSE, envir=env) tclvalue(.groupsLabel) <- paste(initialLabel, "...", sep="") tkconfigure(groupsButton, fg="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, fg="blue") 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="w") if (positionLegend) tkgrid(tklabel(subdialog, text=gettextRcmdr("Position legend with mouse click"), fg="blue")) dialogSuffix(subdialog, onOK=onOKsub, rows=3+plotLinesByGroup+positionLegend, columns=2, focus=subdialog) } groupsFrame <- tkframe(top) groupsButton <- tkbutton(groupsFrame, textvariable=.groupsLabel, command=onGroups, borderwidth=3) tkgrid(tklabel(groupsFrame, text=" "), groupsButton, sticky="w") }) groupsLabel <- defmacro(frame=top, groupsBox=groupsBox, columnspan=1, expr={ groupsFrame <- tkframe(frame) groupsLabel <- tklabel(groupsFrame, text=gettextRcmdr("")) tkgrid(tklabel(groupsFrame, text=gettextRcmdr("Difference: "), fg="blue"), groupsLabel, sticky="w") tkgrid(groupsFrame, sticky="w", columnspan=columnspan) onSelect <- function(){ group <- getSelection(groupsBox) levels <- eval(parse(text=paste("levels(", ActiveDataSet(), "$", group, ")", sep=""))) tkconfigure(groupsLabel, text=paste(levels[1], "-", levels[2])) } tkbind(groupsBox$listbox, "", 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() variables <- paste(.variables, ifelse(is.element(.variables, Factors()), "[factor]", "")) xBox <- variableListBox(frame, variables, title=gettextRcmdr("Variables (double-click to formula)")) onDoubleClick <- if (!hasLhs){ function(){ var <- getSelection(xBox) if (length(grep("\\[factor\\]", var)) == 1) var <- sub("\\[factor\\]", "", 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) if (length(grep("\\[factor\\]", var)) == 1) var <- sub("\\[factor\\]", "", var) lhs <- tclvalue(lhsVariable) if (lhs == "") tclvalue(lhsVariable) <- var 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, "", onDoubleClick) onPlus <- function(){ rhs <- tclvalue(rhsVariable) if (!checkAddOperator(rhs)) return() tclvalue(rhsVariable) <- paste(rhs, "+ ") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } onTimes <- function(){ rhs <- tclvalue(rhsVariable) if (!checkAddOperator(rhs)) return() tclvalue(rhsVariable) <- paste(rhs, "*", sep="") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } onColon <- function(){ rhs <- tclvalue(rhsVariable) if (!checkAddOperator(rhs)) return() tclvalue(rhsVariable) <- paste(rhs, ":", 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) .operatorFont <- getRcmdr("operatorFont") plusButton <- tkbutton(operatorsFrame, text="+", width="3", command=onPlus, font=.operatorFont) timesButton <- tkbutton(operatorsFrame, text="*", width="3", command=onTimes, font=.operatorFont) colonButton <- tkbutton(operatorsFrame, text=":", width="3", command=onColon, font=.operatorFont) slashButton <- tkbutton(operatorsFrame, text="/", width="3", command=onSlash, font=.operatorFont) inButton <- tkbutton(operatorsFrame, text="%in%", width="3", command=onIn, font=.operatorFont) minusButton <- tkbutton(operatorsFrame, text="-", width="3", command=onMinus, font=.operatorFont) powerButton <- tkbutton(operatorsFrame, text="^", width="3", command=onPower, font=.operatorFont) leftParenButton <- tkbutton(operatorsFrame, text="(", width="3", command=onLeftParen, font=.operatorFont) rightParenButton <- tkbutton(operatorsFrame, text=")", width="3", command=onRightParen, font=.operatorFont) tkgrid(plusButton, timesButton, colonButton, slashButton, inButton, minusButton, powerButton, leftParenButton, rightParenButton, sticky="w") formulaFrame <- tkframe(frame) if (hasLhs){ tkgrid(tklabel(outerOperatorsFrame, text=gettextRcmdr("Model Formula: "), fg="blue"), operatorsFrame) lhsVariable <- if (currentModel) tclVar(currentFields$lhs) else tclVar("") rhsVariable <- if (currentModel) tclVar(currentFields$rhs) else tclVar("") rhsEntry <- tkentry(formulaFrame, width="50", textvariable=rhsVariable) rhsXscroll <- tkscrollbar(formulaFrame, repeatinterval=10, orient="horizontal", command=function(...) tkxview(rhs, ...)) tkconfigure(rhsEntry, xscrollcommand=function(...) tkset(rhsXscroll, ...)) lhsEntry <- tkentry(formulaFrame, width="10", textvariable=lhsVariable) lhsScroll <- tkscrollbar(formulaFrame, repeatinterval=5, orient="horizontal", command=function(...) tkxview(lhsEntry, ...)) tkconfigure(lhsEntry, xscrollcommand=function(...) tkset(lhsScroll, ...)) tkgrid(lhsEntry, tklabel(formulaFrame, text=" ~ "), rhsEntry, sticky="w") tkgrid(lhsScroll, tklabel(formulaFrame, text=""), rhsXscroll, sticky="w") tkgrid.configure(lhsScroll, sticky="ew") } else{ rhsVariable <- tclVar("") rhsEntry <- tkentry(formulaFrame, width="50", textvariable=rhsVariable) rhsXscroll <- tkscrollbar(formulaFrame, repeatinterval=10, orient="horizontal", command=function(...) tkxview(rhs, ...)) tkconfigure(rhsEntry, xscrollcommand=function(...) tkset(rhsXscroll, ...)) tkgrid(tklabel(formulaFrame, text=" ~ "), rhsEntry, sticky="w") tkgrid(tklabel(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, eval(parse(text=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 <- eval(parse(text=paste("class(", 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) } #isS4object <- function(object) { # !(length(object) == 1 && class(object) == "character") && length(slotNames(object)) != 0 # } # the following three functions are slightly adapted with permission from Philippe Grosjean RcmdrEnv <- function() { pos <- match("RcmdrEnv", search()) if (is.na(pos)) { # Must create it RcmdrEnv <- list() attach(RcmdrEnv, pos = length(search()) - 1) rm(RcmdrEnv) pos <- match("RcmdrEnv", search()) } return(pos.to.env(pos)) } putRcmdr <- function(x, value) assign(x, value, envir = RcmdrEnv()) getRcmdr <- function(x, mode="any") get(x, envir = RcmdrEnv(), mode = mode, inherits = FALSE) RcmdrTclSet <- function(name, value){ if (is.SciViews()) return() # + PhG 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) } ActiveDataSet <- function(name){ if (missing(name)) getRcmdr(".activeDataSet") else putRcmdr(".activeDataSet", name) } ActiveModel <- function(name){ if (missing(name)) getRcmdr(".activeModel") 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") putRcmdr("modelNumber", modelNumber + increment) } CommanderWindow <- function() getRcmdr("commanderWindow") LogWindow <- function() getRcmdr("logWindow") OutputWindow <- function() getRcmdr("outputWindow") MessagesWindow <- function() getRcmdr("messagesWindow") # some predicates for the menu system activeDataSetP <- function() !is.null(ActiveDataSet()) dataSetsP <- function() !is.null(listDataSets()) 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() && eval(parse(text=paste("class(", ActiveModel(), ")[1] == 'lm'"))) glmP <- function() activeModelP() && eval(parse(text=paste("class(", ActiveModel(), ")[1] == 'glm'"))) hclustSolutionsP <- function() length(listHclustSolutions()) > 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-Rcmdr") 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()) || (.Platform$OS.type != "windows") ){ 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="blue", question="blue", warning="black", error="red") onOK <- function() { if (GrabFocus()) tkgrab.release(messageBox) tkdestroy(messageBox) tkfocus(CommanderWindow()) tclvalue(result) <- "ok" } OKbutton <- tkbutton(buttonFrame, text=gettextRcmdr("OK"), fg="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 <- tkbutton(buttonFrame, text=gettextRcmdr("Cancel"), fg="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 <- tkbutton(buttonFrame, text=gettextRcmdr("Yes"), fg="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 <- tkbutton(buttonFrame, text=gettextRcmdr("No"), fg="red", width="12", command=onNo, borderwidth=3, default=if (missing(default)) "normal" else if (default == "no") "active" else "normal") tkgrid(tklabel(messageFrame, bitmap=icon, fg=iconColor), tklabel(messageFrame, text=" "), tklabel(messageFrame, text=message)) tkgrid(messageFrame) switch(type, okcancel = { tkgrid(OKbutton, tklabel(buttonFrame, text=" "), cancelButton) if (missing(default) || default == "ok") tkbind(messageBox, "", onOK) else if (default == "cancel") tkbind(messageBox, "", onCancel) }, yesno = { tkgrid(yesButton, tklabel(buttonFrame, text=" "), noButton) if (missing(default) || default == "yes") tkbind(messageBox, "", onYes) else if (default == "no") tkbind(messageBox, "", onNo) }, ok = { tkgrid(OKbutton) if (missing(default) || default == "ok") tkbind(messageBox, "", onOK) } ) tkgrid(buttonFrame) dialogSuffix(messageBox, rows=2, 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 listPlugins <- function(loaded=FALSE){ availablePackages <- if (loaded) sort(.packages(all.available = TRUE)) else sort(setdiff(.packages(all.available = TRUE), .packages())) plugins <- availablePackages[sapply(availablePackages, function(package) file.exists(file.path(.find.package(package), "etc/menus.txt")))] plugins } loadPlugins <- function(){ plugins <- listPlugins() initializeDialog(title=gettextRcmdr("Load Plugins")) 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(rows=1, columns=1) }