Nothing
# Created on 26Sep2010 by Dan Putler
# Last modified on 02Sep2014 by Dan Putler
if (getRversion() >= "2.15.1")
globalVariables(c('.grab.focus', 'boxplotsVariable', 'buttonsFrame',
'criteriaFrame', 'criteriaVariable', 'diagonalFrame', 'diagonalVariable',
'directionVariable', 'distanceTypeFrame', 'distanceTypeVariable',
'entry1', 'formulaFrame', 'generalizedLinearModel', 'GenerializedLinearModel',
'groupsFrame', 'hclustSummary', 'hierarchicalCluster', 'identifyVariable',
'jitterXVariable', 'jitterYVariable', 'kmeansClustering', 'leafVariable',
'lhsEntry', 'lhsVariable', 'logXVariable', 'logYVariable', 'lsLineVariable',
'methodFrame', 'methodVariable', 'onHelp', 'optionsFrame', 'outerOperatorsFrame',
'psprintf', 'relableFactor', 'rhsVariable', 'scatterPlot', 'scatterPlotMatrix',
'smoothLineVariable', 'spreadVariable', 'subButtonsFrame', 'subdialog',
'subsetFrame', 'subsetVariable', 'top', 'typeFrame', 'typeVariable', 'xBox'))
# .onAttach function to place .subset, .targetLevel, and .trueResp into the
# Rcmdr environment. Hopefully this works. This is done to deal with R2.14.0
.onAttach <- function(libname, pkgname){
if (!interactive()) return()
Rcmdr <- options()$Rcmdr
plugins <- Rcmdr$plugins
if ((!pkgname %in% plugins) && !getRcmdr("autoRestart")) {
Rcmdr$plugins <- c(plugins, pkgname)
options(Rcmdr=Rcmdr)
closeCommander(ask=FALSE, ask.save=TRUE)
putRcmdr(".subset", gettextRcmdr("<all valid cases>"))
putRcmdr(".Sample", NULL)
putRcmdr(".targetLevel", NULL)
putRcmdr(".trueResp", NULL)
Commander()
}
palette(c("#0072B2","#D55E00","#000000","#F0E442","#2B9F78","#E69F00","#5684E9","#CC79A7"))
invisible(dev.off())
}
# The subsetBox with the subset expression as an Rcmdr environment variable
subsetBoxBCA <- defmacro(window=top, model=FALSE,
expr={
subsetVariable <- if (model){
if (currentModel && currentFields$subset != "")
tclVar(currentFields$subset) else tclVar(getRcmdr(".subset"))
}
else tclVar(getRcmdr(".subset"))
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")
})
# DBF IMPORT/EXPORT FUNCTIONS. The data input options should expand to
# allow for other DBMS options
importDBF <- function() {
initializeDialog(title=gettextRcmdr("Import dBase (dbf) Data Set"))
dsname <- tclVar(gettextRcmdr("Dataset"))
entryDsname <- tkentry(top, width="20", textvariable=dsname)
asFactor <- tclVar("0")
asFactorCheckBox <- tkcheckbutton(top, variable=asFactor)
onOK <- function(){
closeDialog()
dsnameValue <- trim.blanks(tclvalue(dsname))
if (dsnameValue == ""){
errorCondition(recall=importDBF,
message=gettextRcmdr("You must enter the name of a data set."))
return()
}
if (!is.valid.name(dsnameValue)){
errorCondition(recall=importDBF, message=
sprintf(gettextRcmdr('"%s" is not a valid name.'), dsnameValue))
return()
}
if (is.element(dsnameValue, listDataSets())) {
if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){
importDBF()
return()
}
}
file <- tclvalue(tkgetOpenFile(
filetypes=gettextRcmdr('{"dBase datasets" {".dbf" ".DBF"}} {"All Files" {"*"}}')))
if (file == "") {
tkfocus(CommanderWindow())
return()
}
factor <- tclvalue(asFactor) == "1"
command <- paste('read.dbf("', file,'", as.is=', factor,')', sep="")
## The command below is not for this case, but it the way to avoid the use of an assign() call to .GlobalEnv
doItAndPrint(paste(dsnameValue, "<-", command))
activeDataSet(dsnameValue)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="read.dbf")
tkgrid(tklabel(top, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w")
tkgrid(tklabel(top, text=gettextRcmdr("Do not convert character\nvariables to factors"), justify="left"),
asFactorCheckBox, sticky="w")
tkgrid(buttonsFrame, columnspan="2", sticky="w")
tkgrid.configure(entryDsname, sticky="w")
tkgrid.configure(asFactorCheckBox, sticky="w")
dialogSuffix(rows=4, columns=2, focus=entryDsname)
}
exportDBF <- function() {
dsname <- activeDataSet()
saveFile <- tclvalue(tkgetSaveFile(filetypes=gettextRcmdr('{"DBF Files" {".dbf" ".DBF"}} {"All Files" {"*"}}'),
defaultextension="dbf", initialfile=paste(dsname, ".dbf", sep="")))
if (saveFile == "") {
tkfocus(CommanderWindow())
return()
}
command <- paste("write.dbf(", dsname, ', "', saveFile, '")', sep="")
justDoIt(command)
logger(command)
Message(paste(gettextRcmdr("Active dataset exported to file"), saveFile), type="note")
tkfocus(CommanderWindow())
}
# DATA MENU
createSamples <- function(){
.activeDataSet <- ActiveDataSet()
initializeDialog(title=gettextRcmdr("Create Samples"))
optionsFrame <- tkframe(top)
estPercent <- tclVar("34")
estPctSlider <- tkscale(optionsFrame, from=20, to=80, showvalue=TRUE,
variable=estPercent, resolution=1, orient="horizontal")
valPercent <- tclVar("33")
valPctSlider <- tkscale(optionsFrame, from=10, to=70, showvalue=TRUE,
variable=valPercent, resolution=1, orient="horizontal")
seedVal <- tclVar("1")
seedField <- tkentry(optionsFrame, width="3", textvariable=seedVal)
assignName <- tclVar("Sample")
assignField <- tkentry(optionsFrame, width="15",
textvariable=assignName)
onOK <- function(){
prctEst <- paste("0.", tclvalue(estPercent), sep="")
prctVal <- paste("0.", tclvalue(valPercent), sep="")
if((as.numeric(prctEst) + as.numeric(prctVal)) > 1) {
errorCondition(recall=createSamples,
message=gettextRcmdr("The estimation and validation samples exceed 100%."))
return()
}
randSeed <- trim.blanks(tclvalue(seedVal))
assignVar <- trim.blanks(tclvalue(assignName))
if(!is.valid.name(assignVar)) {
errorCondition(recall=createSamples, message=
sprintf(gettextRcmdr('"%s" is not a valid name.'), assignVar))
return()
}
closeDialog()
command <- paste(.activeDataSet, "$", assignVar," <- create.samples(",
.activeDataSet, ", est = ", prctEst, ", val = ", prctVal,
", rand.seed = ", randSeed, ")", sep="")
justDoIt(command)
logger(command)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="ls")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Estimation sample percent:")),
estPctSlider, sticky="sw")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Validation sample percent:")),
valPctSlider, sticky="sw")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Random seed: ")),
seedField, sticky="w")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Assignment variable: ")),
assignField, sticky="w")
tkgrid(optionsFrame, sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=2, columns=2)
}
variableSummary <- function() {
command <- paste("variable.summary(", ActiveDataSet(), ")", sep="")
doItAndPrint(command)
}
relabelFactor <- function(){
.activeDataSet <- ActiveDataSet()
initializeDialog(title=gettextRcmdr("Relabel a Factor"))
variableBox <- variableListBox(top, Factors(), title=gettextRcmdr("Factor (pick one)"))
factorName <- tclVar(gettextRcmdr("<same as original>"))
factorNameField <- tkentry(top, width="20", textvariable=factorName)
onOK <- function(){
variable <- getSelection(variableBox)
closeDialog()
if (length(variable) == 0) {
errorCondition(recall=relabelFactor,
message=gettextRcmdr("You must select a variable."))
return()
}
name <- trim.blanks(tclvalue(factorName))
if (name == gettextRcmdr("<same as original>")) name <- variable
if (!is.valid.name(name)){
errorCondition(recall=relabelFactor, message=
sprintf(gettextRcmdr('"%s" is not a valid name.'), name))
return()
}
if (is.element(name, Variables())) {
if ("no" == tclvalue(checkReplace(name))){
if (.grab.focus) tkgrab.release(top)
tkdestroy(top)
relabelFactor()
return()
}
}
old.labels <- eval(parse(text=paste("levels(", .activeDataSet,
"$", variable, ")",
sep="")), envir=.GlobalEnv)
nvalues <- length(old.labels)
if (nvalues > 30) {
errorCondition(recall=relabelFactor,
message=psprintf(gettextRcmdr("Number of levels (%d) is too large."),
nvalues))
return()
}
initializeDialog(subdialog, title=gettextRcmdr("New Labels"))
labels <- rep("", nvalues)
onOKsub <- function() {
closeDialog(subdialog)
for (i in 1:nvalues){
labels[i] <-
eval(parse(text=paste("tclvalue(levelLabel", i, ")", sep="")))
}
if (any(labels == "")){
errorCondition(recall=relabelFactor,
message=gettextRcmdr("All factor levels must be given a label."))
relableFactor()
return()
}
command <- paste("relabel.factor(", .activeDataSet, "$", variable,
", new.labels=c(", paste(paste("'", labels, "'", sep=""),
collapse=","), "))", sep="")
justDoIt(paste(.activeDataSet, "$", name, " <- ", command, sep=""))
logger(paste(.activeDataSet,"$", name," <- ", command, sep=""))
activeDataSet(.activeDataSet)
tkfocus(CommanderWindow())
}
subOKCancelHelp()
tkgrid(tklabel(subdialog, text=gettextRcmdr("Old Labels"), fg="blue"),
tklabel(subdialog, text=gettextRcmdr("New Labels"), fg="blue"), sticky="w")
for (i in 1:nvalues){
valVar <- paste("levelLabel", i, sep="")
assign(valVar, tclVar(""))
assign(paste("entry", i, sep=""), tkentry(subdialog, width="12",
textvariable=eval(parse(text=valVar))))
tkgrid(tklabel(subdialog, text=old.labels[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="relabel.factor")
tkgrid(getFrame(variableBox), sticky="nw")
tkgrid(tklabel(top, text=gettextRcmdr("Name for factor")), sticky="w")
tkgrid(factorNameField, sticky="w")
tkgrid(buttonsFrame, sticky="w")
dialogSuffix(rows=4, columns=1, preventGrabFocus=TRUE)
}
## Clustering
# kmeans menu corrected for the subsetBox
# This function needs to be worked on. It currently does things that the R
# kmeans function already does
kmeansClusteringBCA <- function(){
.activeDataSet <- ActiveDataSet()
initializeDialog(title=gettextRcmdr("KMeans Clustering"))
dataFrame <- tkframe(top)
xBox <- variableListBox(dataFrame, Numeric(), selectmode="multiple",
title=gettextRcmdr("Variables (pick one or more)"))
subsetBoxBCA(dataFrame)
assignFrame <- tkframe(dataFrame)
assignClusters <- tclVar("0")
assignCB <- tkcheckbutton(assignFrame)
tkconfigure(assignCB, variable=assignClusters)
assignName <- tclVar("KMeans")
assignField <- tkentry(assignFrame, width="15",
textvariable=assignName)
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)
plotCls2d <- tclVar("1")
plot2dCB <- tkcheckbutton(optionsFrame)
tkconfigure(plot2dCB, variable=plotCls2d)
plotCls3d <- tclVar("0")
plot3dCB <- tkcheckbutton(optionsFrame)
tkconfigure(plot3dCB, variable=plotCls3d)
plotFrame <- tkframe(optionsFrame)
plotPts <- tclVar("1")
plotPtsCB <- tkcheckbutton(plotFrame)
tkconfigure(plotPtsCB, variable=plotPts)
plotCnt <- tclVar("0")
plotCntCB <- tkcheckbutton(plotFrame)
tkconfigure(plotCntCB, variable=plotCnt)
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)
clsPlot2d <- tclvalue(plotCls2d)
clsPlot3d <- tclvalue(plotCls3d)
ptsPlot <- tclvalue(plotPts)
cntPlot <- tclvalue(plotCnt)
clusterAssign <- tclvalue(assignClusters)
clusterVariable <- trim.blanks(tclvalue(assignName))
if (clusterAssign == "1" & !is.valid.name(clusterVariable)){
errorCondition(recall=kmeansClustering, message=
sprintf(gettextRcmdr('"%s" is not a valid name.'),
clusterVariable))
return()
}
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("<all valid cases>")) .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="")
doItAndPrint(paste(".cluster", "<-", command))
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((clsPlot2d=="1" | clsPlot3d=="1") & ptsPlot=="0" & cntPlot=="0") {
Message(gettextRcmdr("Bi-plot(s) contains no points or centroids."),
type="warning")
}
ptsOpt <- "FALSE"
if(ptsPlot == "1") ptsOpt <- "TRUE"
cntOpt <- "FALSE"
if(cntPlot == "1") cntOpt <- "TRUE"
if (clsPlot2d == "1") {
plotCmd2d <- paste("bpCent(prcomp(", xmat,
"), .cluster$cluster, data.pts = ", ptsOpt, ", centroids = ",
cntOpt, ", xlabs = as.character(.cluster$cluster))", sep="")
justDoIt(plotCmd2d)
logger(plotCmd2d)
}
if (clsPlot3d == "1") {
if (requireNamespace("rgl", quietly = TRUE)) {
plotCmd3d <- paste("bpCent3d(prcomp(", xmat,
"), .cluster$cluster, data.pts = ", ptsOpt, ", centroids = ",
cntOpt, ", xlabs = as.character(.cluster$cluster))", sep="")
justDoIt(plotCmd3d)
logger(plotCmd3d)
.Tcl("update")
activateMenus()
rgl::rgl.bringtotop()
} else {
warning("The rgl package is not available so a three dimensional bi-plot was not created")
}
}
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)"))
activateMenus()
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="KMeans")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(subsetFrame, sticky="w")
tkgrid(tklabel(assignFrame,
text=gettextRcmdr("Assign clusters to\nthe data set ")),
assignCB, sticky="w")
tkgrid(tklabel(assignFrame, text=gettextRcmdr("Assignment variable: ")),
assignField, sticky="w")
tkgrid(assignFrame, 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("2D bi-plot of clusters")), plot2dCB, sticky="w")
tkgrid(tklabel(optionsFrame,
text=gettextRcmdr("3D bi-plot of clusters")), plot3dCB, sticky="w")
tkgrid(tklabel(plotFrame, text=gettextRcmdr("Plot points")), plotPtsCB,
tklabel(plotFrame, text=gettextRcmdr("Plot centroids")), plotCntCB,
sticky="w")
tkgrid(plotFrame, columnspan=2, sticky="w")
tkgrid(dataFrame, tklabel(top, text=" "), optionsFrame,
sticky="nw")
tkgrid(buttonsFrame, columnspan=3, sticky="w")
dialogSuffix(rows=3, columns=3)
}
# The SD Index plot functions for k-means
SDIndexPlot <- function(){
.activeDataSet <- ActiveDataSet()
initializeDialog(title=gettextRcmdr("SD Index Plot"))
dataFrame <- tkframe(top)
xBox <- variableListBox(dataFrame, Numeric(), selectmode="multiple",
title=gettextRcmdr("Variables (pick one or more)"))
subsetBoxBCA(dataFrame)
optionsFrame <- tkframe(top)
minCluster <- tclVar("2")
minClusterSlider <- tkscale(optionsFrame, from=2, to=8, showvalue=TRUE,
variable=minCluster, resolution=1, orient="horizontal")
maxCluster <- tclVar("4")
maxClusterSlider <- tkscale(optionsFrame, from=4, to=10, showvalue=TRUE,
variable=maxCluster, resolution=1, orient="horizontal")
iterNumber <- tclVar("10")
iterNumSlider <- tkscale(optionsFrame, from=5, to=30, showvalue=TRUE,
variable=iterNumber, resolution=5, orient="horizontal")
seedNumber <- tclVar("10")
seedNumSlider <- tkscale(optionsFrame, from=1, to=20, showvalue=TRUE,
variable=seedNumber, resolution=1, orient="horizontal")
.activeDataset <- ActiveDataSet()
onOK <- function(){
x <- getSelection(xBox)
nvar <- length(x)
subset <- tclvalue(subsetVariable)
minClus <- tclvalue(minCluster)
maxClus <- tclvalue(maxCluster)
seeds <- tclvalue(seedNumber)
iters <- tclvalue(iterNumber)
closeDialog()
if (length(x)==0) {
errorCondition(recall=SDIndexPlot,
message=gettextRcmdr("No variables selected."))
return()
}
if (as.numeric(minClus) > as.numeric(maxClus)) {
errorCondition(recall=SDIndexPlot, message=gettextRcmdr(
"The minimum number of clusters selected exceeds the maximum."))
return()
}
varFormula <- paste(x, collapse=" + ")
vars <- paste(x, collapse=",", sep="")
dset <- if (subset == gettextRcmdr("<all valid cases>")) .activeDataSet
else {paste(.activeDataSet, "[", .activeDataSet, "$", subset, ", ]",
sep="")}
xmat <- paste("model.matrix(~-1 + ", varFormula, ", ", dset, ")",
sep="")
command <- paste("SDIndex(", xmat, ", minClus = ", minClus,
", maxClus = ", maxClus, ", iter.max = ", iters,
", num.seeds=", seeds, ")", sep="")
justDoIt(command)
logger(command)
activateMenus()
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="SDIndex")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(subsetFrame, sticky="w")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Minimum number of clusters:")),
minClusterSlider, sticky="sw")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Maximum number of clusters:")),
maxClusterSlider, sticky="sw")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Maximum iterations:")),
iterNumSlider, sticky="sw")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Number of random seeds:")),
seedNumSlider, sticky="sw")
tkgrid(dataFrame, tklabel(top, text=" "), optionsFrame, sticky="w")
tkgrid(buttonsFrame, columnspan=3, sticky="w")
dialogSuffix(rows=3, columns=3)
}
# K-Centroids Clustering
kcentroidsClustering <- function(){
.activeDataSet <- ActiveDataSet()
initializeDialog(title=gettextRcmdr("K-Centroids Clustering"))
dataFrame <- tkframe(top)
xBox <- variableListBox(dataFrame, Numeric(), selectmode="multiple",
title=gettextRcmdr("Variables (pick one or more)"))
subsetBoxBCA(dataFrame)
assignFrame <- tkframe(dataFrame)
assignClusters <- tclVar("0")
assignCB <- tkcheckbutton(assignFrame)
tkconfigure(assignCB, variable=assignClusters)
assignName <- tclVar("KCentroids")
assignField <- tkentry(assignFrame, width="15",
textvariable=assignName)
radioButtons(name="method", buttons=c("kmn", "kmd", "neuralgas"),
labels=gettextRcmdr(c("K-Means", "K-Medians", "Neural Gas")),
title=gettextRcmdr("Clustering Method"))
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)
plotCls2d <- tclVar("1")
plot2dCB <- tkcheckbutton(optionsFrame)
tkconfigure(plot2dCB, variable=plotCls2d)
plotCls3d <- tclVar("0")
plot3dCB <- tkcheckbutton(optionsFrame)
tkconfigure(plot3dCB, variable=plotCls3d)
plotFrame <- tkframe(optionsFrame)
plotPts <- tclVar("1")
plotPtsCB <- tkcheckbutton(plotFrame)
tkconfigure(plotPtsCB, variable=plotPts)
plotCnt <- tclVar("0")
plotCntCB <- tkcheckbutton(plotFrame)
tkconfigure(plotCntCB, variable=plotCnt)
onOK <- function(){
x <- getSelection(xBox)
nvar <- length(x)
subset <- trim.blanks(tclvalue(subsetVariable))
clusMethod <- tclvalue(methodVariable)
nClusters <- tclvalue(clusterNumber)
seeds <- tclvalue(seedNumber)
#iters <- tclvalue(iterNumber)
clusterSummary <- tclvalue(summaryClusters)
clsPlot2d <- tclvalue(plotCls2d)
clsPlot3d <- tclvalue(plotCls3d)
ptsPlot <- tclvalue(plotPts)
cntPlot <- tclvalue(plotCnt)
clusterAssign <- tclvalue(assignClusters)
clusterVariable <- trim.blanks(tclvalue(assignName))
if (clusterAssign == "1" & !is.valid.name(clusterVariable)){
errorCondition(recall=kcentroidsClustering, message=
sprintf(gettextRcmdr('"%s" is not a valid name.'),
clusterVariable))
return()
}
closeDialog()
if (clusterAssign == "1"){
if (is.element(clusterVariable, Variables())) {
if ("no" == tclvalue(checkReplace(clusterVariable))){
kcentroidsClustering()
return()
}
}
}
if (length(x)==0) {
errorCondition(recall=kcentroidsClustering,
message==gettextRcmdr("No variables selected."))
return()
}
varFormula <- paste(x, collapse=" + ")
vars <- paste(x, collapse=",", sep="")
.activeDataSet <- ActiveDataSet()
dset <- if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) .activeDataSet
else {paste(.activeDataSet, "[", .activeDataSet, "$", subset, ", ]",
sep="")}
xmat <- paste("model.matrix(~-1 + ", varFormula, ", ", dset, ")",
sep="")
details <- 'FUN = kcca, family = kccaFamily("kmeans")'
if(clusMethod == "kmd") {
details <- 'FUN = kcca, family = kccaFamily("kmedians")'
}
else if(clusMethod == "neuralgas") {
details <- 'FUN = cclust, dist = "euclidean", method = "neuralgas"'
}
command <- paste("stepFlexclust(", xmat, ", k = ", nClusters,
", nrep = ", seeds, ", ", details, ")", sep="")
doItAndPrint(paste(".cluster", "<-", command))
if (clusterSummary == "1") {
doItAndPrint("summary(.cluster)")
doItAndPrint("print(.cluster@centers) # Cluster Centroids")
}
if((clsPlot2d=="1" | clsPlot3d=="1") & ptsPlot=="0" & cntPlot=="0") {
Message(gettextRcmdr("Bi-plot(s) contains no points or centroids."),
type="warning")
}
ptsOpt <- "FALSE"
if(ptsPlot == "1") ptsOpt <- "TRUE"
cntOpt <- "FALSE"
if(cntPlot == "1") cntOpt <- "TRUE"
if (clsPlot2d == "1") {
plotCmd2d <- paste("bpCent(prcomp(", xmat,
"), clusters(.cluster), data.pts = ", ptsOpt, ", centroids = ",
cntOpt, ", xlabs = as.character(clusters(.cluster)))", sep="")
justDoIt(plotCmd2d)
logger(plotCmd2d)
}
if (clsPlot3d == "1") {
plotCmd3d <- paste("bpCent3d(prcomp(", xmat,
"), clusters(.cluster), data.pts = ", ptsOpt, ", centroids = ",
cntOpt, ", xlabs = as.character(clusters(.cluster)))", sep="")
justDoIt(plotCmd3d)
logger(plotCmd3d)
.Tcl("update")
activateMenus()
rgl::rgl.bringtotop()
}
if (clusterAssign == "1") {
# assignCommand <- paste(.activeDataSet, "$", clusterVariable,
# " <- assignCluster(", xmat, ", ", .activeDataSet,
# ", clusters(.cluster))", sep="")
assignCommand <- paste(.activeDataSet, "$", clusterVariable,
" <- as.factor(clusters(.cluster))", sep="")
justDoIt(assignCommand)
logger(assignCommand)
activeDataSet(.activeDataSet)
}
justDoIt(paste("remove(.cluster)"))
logger(paste("remove(.cluster)"))
activateMenus()
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="kcca")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(subsetFrame, sticky="w")
tkgrid(tklabel(assignFrame,
text=gettextRcmdr("Assign clusters to\nthe data set ")),
assignCB, sticky="w")
tkgrid(tklabel(assignFrame, text=gettextRcmdr("Assignment variable: ")),
assignField, sticky="w")
tkgrid(assignFrame, 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("2D bi-plot of clusters")), plot2dCB, sticky="w")
tkgrid(tklabel(optionsFrame,
text=gettextRcmdr("3D bi-plot of clusters")), plot3dCB, sticky="w")
tkgrid(tklabel(plotFrame, text=gettextRcmdr("Plot points")), plotPtsCB,
tklabel(plotFrame, text=gettextRcmdr("Plot centroids")), plotCntCB,
sticky="w")
tkgrid(plotFrame, columnspan=2, sticky="w")
tkgrid(dataFrame, tklabel(top, text=" "), methodFrame, optionsFrame,
sticky="nw")
tkgrid(buttonsFrame, columnspan=3, sticky="w")
dialogSuffix(rows=3, columns=4)
}
# The bootstrap replicate diagnostic testing for K-Centroids
bootDiagnostics <- function(){
initializeDialog(title=gettextRcmdr("K-Centroids Clustering Diagnostics"))
dataFrame <- tkframe(top)
xBox <- variableListBox(dataFrame, Numeric(), selectmode="multiple",
title=gettextRcmdr("Variables (pick one or more)"))
subsetBoxBCA(dataFrame)
radioButtons(name="method", buttons=c("kmn", "kmd", "neuralgas"),
labels=gettextRcmdr(c("K-Means", "K-Medians", "Neural Gas")),
title=gettextRcmdr("Clustering Method"))
optionsFrame <- tkframe(top)
minCluster <- tclVar("2")
minClusterSlider <- tkscale(optionsFrame, from=2, to=8, showvalue=TRUE,
variable=minCluster, resolution=1, orient="horizontal")
maxCluster <- tclVar("4")
maxClusterSlider <- tkscale(optionsFrame, from=3, to=10, showvalue=TRUE,
variable=maxCluster, resolution=1, orient="horizontal")
bootRep <- tclVar("100")
bootRepSlider <- tkscale(optionsFrame, from=50, to=200, showvalue=TRUE,
variable=bootRep, resolution=10, orient="horizontal")
seedNumber <- tclVar("3")
seedNumSlider <- tkscale(optionsFrame, from=1, to=5, showvalue=TRUE,
variable=seedNumber, resolution=1, orient="horizontal")
.activeDataSet <- ActiveDataSet()
onOK <- function(){
x <- getSelection(xBox)
nvar <- length(x)
subset <- tclvalue(subsetVariable)
clusMethod <- tclvalue(methodVariable)
minClus <- tclvalue(minCluster)
maxClus <- tclvalue(maxCluster)
bReps <- tclvalue(bootRep)
seeds <- tclvalue(seedNumber)
closeDialog()
if (length(x)==0) {
errorCondition(recall=bootDiagnostics,
message=gettextRcmdr("No variables selected."))
return()
}
if (as.numeric(minClus) > as.numeric(maxClus)) {
errorCondition(recall=SDIndexPlot, message=gettextRcmdr(
"The minimum number of clusters selected exceeds the maximum."))
return()
}
varFormula <- paste(x, collapse=" + ")
vars <- paste(x, collapse=",", sep="")
dset <- if (subset == gettextRcmdr("<all valid cases>")) .activeDataSet
else {paste(.activeDataSet, "[", .activeDataSet, "$", subset, ", ]",
sep="")}
xmat <- paste("model.matrix(~-1 + ", varFormula, ", ", dset, ")",
sep="")
details <- 'FUN = cclust, dist = "euclidean", method = "kmeans"'
if(clusMethod == "kmd") {
details <- 'FUN = kcca, family = kccaFamily("kmedians")'
}
else if(clusMethod == "neuralgas") {
details <- 'FUN = cclust, dist = "euclidean", method = "neuralgas"'
}
command <- paste("bootCVD(", xmat, ", k = ", minClus, ":", maxClus,
", nboot = ", bReps, ", nrep = ", seeds, ', method = "', clusMethod,
'", col1 = 1, col2 = 2, dsname = "', .activeDataSet, '")', sep="")
doItAndPrint(command)
activateMenus()
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="bootCVD")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(subsetFrame, sticky="w")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Minimum number of clusters:")),
minClusterSlider, sticky="sw")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Maximum number of clusters:")),
maxClusterSlider, sticky="sw")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Bootstrap replicates:")),
bootRepSlider, sticky="sw")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Number of random seeds:")),
seedNumSlider, sticky="sw")
tkgrid(dataFrame, tklabel(top, text=" "), methodFrame, optionsFrame, sticky="nw")
tkgrid(buttonsFrame, columnspan=3, sticky="w")
dialogSuffix(rows=3, columns=4)
}
# List hierachical clustering solutions
listHclustSolutions <- function(envir=.GlobalEnv, ...) {
objects <- ls(envir=envir, ...)
if (length(objects) == 0) NULL
else objects[sapply(objects,
function(.x) "hclust" == class(get(.x, envir=envir))[1]) ]
# function(.x) "hclust" == (class(eval(parse(text=.x), envir=envir))[1]))]
}
# Hierarchical clustering dialog box with the subsetBox correction
hCluster <- function(){
solutionNumber=length(listHclustSolutions())
initializeDialog(title=gettextRcmdr("Hierarchical Clustering"))
solutionFrame <- tkframe(top)
solutionName <- tclVar(paste("HClust.", (solutionNumber+1),
sep=""))
solutionField <- ttkentry(solutionFrame, width="20",
textvariable=solutionName)
dataFrame <- tkframe(top)
xBox <- variableListBox(dataFrame, Numeric(), selectmode="multiple",
title=gettextRcmdr("Variables (pick one or more)"))
subsetBoxBCA(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")), initialValue="euc2",
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("<all valid cases>")) .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="")
doItAndPrint(paste(solution, "<-", command))
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(labelRcmdr(top, text=gettextRcmdr("Clustering solution name:")),
solutionFrame, sticky="w")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(subsetFrame, sticky="w")
tkgrid(distanceTypeFrame, sticky="w")
tkgrid(labelRcmdr(checkFrame, text=" "), sticky="w")
tkgrid(labelRcmdr(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)
}
hclustSummaryBCA <- 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)
plotCls2d <- tclVar("1")
plot2dCB <- tkcheckbutton(optionsFrame)
tkconfigure(plot2dCB, variable=plotCls2d)
plotCls3d <- tclVar("0")
plot3dCB <- tkcheckbutton(optionsFrame)
tkconfigure(plot3dCB, variable=plotCls3d)
plotFrame <- tkframe(optionsFrame)
plotPts <- tclVar("1")
plotPtsCB <- tkcheckbutton(plotFrame)
tkconfigure(plotPtsCB, variable=plotPts)
plotCnt <- tclVar("0")
plotCntCB <- tkcheckbutton(plotFrame)
tkconfigure(plotCntCB, variable=plotCnt)
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)
clsPlot2d <- tclvalue(plotCls2d)
clsPlot3d <- tclvalue(plotCls3d)
ptsPlot <- tclvalue(plotPts)
cntPlot <- tclvalue(plotCnt)
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("apply(", xmat, ", 2, function(x) tapply(x, as.factor(", clusterVar, "), mean)) # Cluster Centroids", sep = "")
centroidsCommand <- paste("by(", xmat, ", as.factor(", clusterVar,
"), colMeans) # Cluster Centroids", sep="")
doItAndPrint(centroidsCommand)
}
if((clsPlot2d=="1" | clsPlot3d=="1") & ptsPlot=="0" & cntPlot=="0") {
Message(gettextRcmdr("Bi-plot(s) contains no points or centroids."),
type="warning")
}
ptsOpt <- "FALSE"
if(ptsPlot == "1") ptsOpt <- "TRUE"
cntOpt <- "FALSE"
if(cntPlot == "1") cntOpt <- "TRUE"
if (clsPlot2d == "1") {
plotCmd2d <- paste("bpCent(prcomp(", xmat,
"), ", clusterVar, ", data.pts = ", ptsOpt, ", centroids = ",
cntOpt, ", xlabs = as.character(", clusterVar, "))", sep="")
justDoIt(plotCmd2d)
logger(plotCmd2d)
}
if (clsPlot3d == "1") {
plotCmd3d <- paste("bpCent3d(prcomp(", xmat,
"), ", clusterVar, ", data.pts = ", ptsOpt, ", centroids = ",
cntOpt, ", xlabs = as.character(", clusterVar, "))", sep="")
justDoIt(plotCmd3d)
logger(plotCmd3d)
.Tcl("update")
activateMenus()
rgl::rgl.bringtotop()
}
activateMenus()
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("2D bi-plot of clusters")), plot2dCB, sticky="w")
tkgrid(tklabel(optionsFrame,
text=gettextRcmdr("3D bi-plot of clusters")), plot3dCB, sticky="w")
tkgrid(tklabel(plotFrame, text=gettextRcmdr("Plot points")), plotPtsCB,
tklabel(plotFrame, text=gettextRcmdr("Plot centroids")), plotCntCB,
sticky="w")
tkgrid(plotFrame, columnspan=2, sticky="w")
tkgrid(getFrame(hclustBox), optionsFrame, sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=2, columns=3)
}
# STATISTICS-MODELS MENU
# GLM changes to add the McFadden R^2 value to the model summary
generalizedLinearModelBCA <- 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))
class(get(.activeModel, envir=.GlobalEnv))[1] == "glm"
# eval(parse(text=paste("class(", .activeModel, ")[1] == 'glm'", sep="")),
# envir=.GlobalEnv)
else FALSE
if (currentModel) {
currentFields <- formulaFields(get(.activeModel, envir=.GlobalEnv), glm=TRUE)
# 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 <- ttkentry(modelFrame, width="20", textvariable=modelName)
linkFamilyFrame <- tkframe(top)
familyFrame <- tkframe(linkFamilyFrame)
familyBox <- tklistbox(familyFrame, height="4", exportselection="FALSE",
selectmode="single", background="white")
familyScroll <- ttkscrollbar(familyFrame,
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()
# The five lines below added to address the "=" vs "==" problem
if(is.equality.prob(trim.blanks(subset))) {
errorCondition(recall=GenerializedLinearModel,
message=gettextRcmdr('Use "==" not "=" for equalties in subsetting.'))
return()
}
if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || 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="")
doItAndPrint(paste(modelValue, "<-", command))
doItAndPrint(paste("summary(", modelValue, ")", sep=""))
# The McFadden R^2 computation added by Dan Putler 29Sep06
doItAndPrint(paste("1 - (", modelValue, "$deviance/",
modelValue, "$null.deviance) # McFadden R2", sep=""))
activeModel(modelValue)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="generalizedLinearModel")
helpButton <- buttonRcmdr(buttonsFrame, text="Help", width="12", command=onHelp)
tkgrid(labelRcmdr(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(labelRcmdr(linkFamilyFrame, text=gettextRcmdr("Family (double-click to select)"), fg="blue"),
labelRcmdr(linkFamilyFrame, text=" "), labelRcmdr(linkFamilyFrame, text=gettextRcmdr("Link function"), fg="blue"), sticky="w")
tkgrid(familyBox, familyScroll, sticky="nw")
tkgrid(linkBox, sticky="nw")
tkgrid(familyFrame, labelRcmdr(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, "<Double-ButtonPress-1>", onFamilySelect)
dialogSuffix(rows=7, columns=1, focus=lhsEntry, preventDoubleClick=TRUE)
}
# Helper functions for the added nnet and rpart models
listNnetModels <- function(envir=.GlobalEnv, ...) {
objects <- ls(envir=envir, ...)
if (length(objects) == 0) NULL
else objects[sapply(objects,
function(.x) "nnet.formula" ==
(class(eval(parse(text=.x), envir=envir))[1]))]
}
nnetP <- function() length(listNnetModels()) > 0
listRpartModels <- function(envir=.GlobalEnv, ...) {
objects <- ls(envir=envir, ...)
if (length(objects) == 0) NULL
else objects[sapply(objects,
function(.x) "rpart" == (class(eval(parse(text=.x), envir=envir))[1]))]
}
rpartP <- function() length(listRpartModels()) > 0
activeRpartP <- function() activeModelP() && eval(parse(text=paste("class(",
ActiveModel(), ")[1] == 'rpart'")))
# The neural network functions
nnetModel <- function(){
initializeDialog(title=gettextRcmdr("Neural Network Model"))
.activeModel <- ActiveModel()
.activeDataSet <- ActiveDataSet()
currentModel <- if (!is.null(.activeModel))
class(get(.activeModel, envir=.GlobalEnv))[1] == "nnet.formula"
# eval(parse(text=paste("class(", .activeModel, ")[1] == 'nnet.formula'",
# sep="")), envir=.GlobalEnv)
else FALSE
if (currentModel) {
currentFields <- formulaFields(get(.activeModel, envir=.GlobalEnv))
# currentFields <- formulaFields(eval(parse(text=.activeModel),
# envir=.GlobalEnv))
if (currentFields$data != ActiveDataSet()) currentModel <- FALSE
}
UpdateModelNumber()
modelName <- tclVar(paste("NNET.", getRcmdr("modelNumber"), sep=""))
modelFrame <- tkframe(top)
model <- ttkentry(modelFrame, width="20", textvariable=modelName)
# model <- tkentry(modelFrame, width="20", textvariable=modelName)
# subsetBox(model=TRUE)
subsetBoxBCA(model=TRUE)
optionsFrame <- tkframe(top)
sizeNumber <- tclVar("1")
sizeNumSlider <- tkscale(optionsFrame, from=1, to=10, showvalue=TRUE,
variable=sizeNumber, resolution=1, orient="horizontal")
decayValue <- tclVar("0")
decayValSlider <- tkscale(optionsFrame, from=0, to=1, showvalue=TRUE,
variable=decayValue, resolution=0.05, orient="horizontal")
onOK <- function(){
check.empty <- gsub(" ", "", tclvalue(lhsVariable))
modelValue <- trim.blanks(tclvalue(modelName))
closeDialog()
if (!is.valid.name(modelValue)){
errorCondition(recall=nnetModel, message=
sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue),
model=TRUE)
return()
}
subset <- tclvalue(subsetVariable)
if(is.equality.prob(trim.blanks(subset))) {
errorCondition(recall=nnetModel,
message=gettextRcmdr('Use "==" not "=" for equalties in subsetting.'))
return()
}
if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){
subset <- ""
putRcmdr("modelWithSubset", FALSE)
}
else{
putRcmdr(".subset", subset)
subset <- paste(", subset='",subset, "'", sep="")
# subset <- paste(", subset=", subset, sep="")
putRcmdr("modelWithSubset", TRUE)
}
check.empty <- gsub(" ", "", tclvalue(lhsVariable))
if ("" == check.empty) {
errorCondition(recall=nnetModel, message=gettextRcmdr("Left-hand side of model empty."), model=TRUE)
return()
}
check.empty <- gsub(" ", "", tclvalue(rhsVariable))
if ("" == check.empty) {
errorCondition(recall=nnetModel, 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=nnetModel, message=gettextRcmdr("Response variable must be a factor"))
return()
}
if (is.element(modelValue, listNnetModels())) {
if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){
UpdateModelNumber(-1)
nnetModel()
return()
}
}
formula <- paste(trim.blanks(tclvalue(lhsVariable)),
trim.blanks(tclvalue(rhsVariable)), sep=" ~ ")
sizeNum <- tclvalue(sizeNumber)
decayVal <- tclvalue(decayValue)
# command <- paste("Nnet(", formula, ", data=", .activeDataSet,
# command <- paste("nnet(", formula, ", data=", .activeDataSet,
# ", decay=", decayVal, ", size=", sizeNum, subset, ")", sep="")
if(subset=="") {
command <- paste("Nnet(", formula, ", data=", .activeDataSet,
", decay=", decayVal, ", size=", sizeNum, ")", sep="")
}
else {
command <- paste("Nnet(", formula, ", data=", .activeDataSet,
", decay=", decayVal, ", size=", sizeNum, subset, ")", sep="")
}
doItAndPrint(paste(modelValue, "<-", command))
doItAndPrint(paste(modelValue,"$value # Final Objective Function Value",
sep=""))
doItAndPrint(paste("summary(", modelValue, ")", sep=""))
activeModel(modelValue)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="Nnet")
# This is new and seems to control the styling of the help button
helpButton <- buttonRcmdr(buttonsFrame, text="Help", width="12", command=onHelp)
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(formulaFrame, sticky="w")
tkgrid(subsetFrame, sticky="w")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Hidden layer units:")),
sizeNumSlider, sticky="w")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Decay weight parameter:")),
decayValSlider, sticky="w")
tkgrid(optionsFrame, sticky="w")
tkgrid(buttonsFrame, sticky="w")
dialogSuffix(rows=4, columns=1, focus=lhsEntry, preventDoubleClick=TRUE)
}
# These are no longer in use
#Printcp <- function(rpartObj) {
# printcp(rpartObj)
# invisible()
# }
#Print <- function(rpartObj) {
# print(rpartObj)
# invisible()
# }
# The rpart functions
rpartModel <- function(){
initializeDialog(title=gettextRcmdr("rpart Tree"))
.activeModel <- ActiveModel()
.activeDataSet <- ActiveDataSet()
currentModel <- if (!is.null(.activeModel))
class(get(.activeModel, envir=.GlobalEnv))[1] == "rpart"
# eval(parse(text=paste("class(", .activeModel, ")[1] == 'rpart'",
# sep="")), envir=.GlobalEnv)
else FALSE
if (currentModel) {
currentFields <- formulaFields(get(.activeModel, envir=.GlobalEnv))
# currentFields <- formulaFields(eval(parse(text=.activeModel),
# envir=.GlobalEnv))
if (currentFields$data != .activeDataSet) currentModel <- FALSE
}
UpdateModelNumber()
modelName <- tclVar(paste("RPART.", getRcmdr("modelNumber"), sep=""))
modelFrame <- tkframe(top)
# model <- tkentry(modelFrame, width="20", textvariable=modelName)
model <- ttkentry(modelFrame, width="20", textvariable=modelName)
# subsetBox(model=TRUE)
subsetBoxBCA(model=TRUE)
optionsFrame <- tkframe(top)
complexParam <- tclVar("0.01")
comParField <- tkentry(optionsFrame, width="6", textvariable=complexParam)
printTree <- tclVar("1")
printTreeCB <- tkcheckbutton(optionsFrame)
tkconfigure(printTreeCB, variable=printTree)
printPrune <- tclVar("1")
printCB <- tkcheckbutton(optionsFrame)
tkconfigure(printCB, variable=printPrune)
plotPrune <- tclVar("1")
plotCB <- tkcheckbutton(optionsFrame)
tkconfigure(plotCB, variable=plotPrune)
onOK <- function(){
check.empty <- gsub(" ", "", tclvalue(lhsVariable))
closeDialog()
if ("" == check.empty) {
errorCondition(recall=rpartModel, model=TRUE,
message=gettextRcmdr("Left-hand side of model empty."))
return()
}
check.empty <- gsub(" ", "", tclvalue(rhsVariable))
if ("" == check.empty) {
errorCondition(recall=rpartModel, model=TRUE,
message=gettextRcmdr("Right-hand side of model empty."))
return()
}
modelValue <- trim.blanks(tclvalue(modelName))
if (!is.valid.name(modelValue)){
errorCondition(recall=rpartModel, model=TRUE,
message=sprintf(gettextRcmdr('"%s" is not a valid name.'),
modelValue))
return()
}
subset <- tclvalue(subsetVariable)
if(is.equality.prob(trim.blanks(subset))) {
errorCondition(recall=rpartModel,
message=gettextRcmdr('Use "==" not "=" for equalties in subsetting.'))
return()
}
if (is.element(modelValue, listRpartModels())) {
if ("no" == tclvalue(checkReplace(modelValue,
type=gettextRcmdr("Model")))){
UpdateModelNumber(-1)
rpartModel()
return()
}
}
formula <- paste(trim.blanks(tclvalue(lhsVariable)),
trim.blanks(tclvalue(rhsVariable)), sep=" ~ ")
if (trim.blanks(subset) ==
gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){
subset <- ""
putRcmdr("modelWithSubset", FALSE)
}
else{
putRcmdr(".subset", subset)
subset <- paste(", subset=", subset, sep="")
putRcmdr("modelWithSubset", TRUE)
}
complexPar <- tclvalue(complexParam)
treePrint <- tclvalue(printTree)
prunePrint <- tclvalue(printPrune)
prunePlot <- tclvalue(plotPrune)
command <- paste("rpart(", formula, ", data=", .activeDataSet,
", cp=" , complexPar, subset,")", sep="")
# if(subset=="") {
# command <- paste("rpart(", formula, ", data=", .activeDataSet,
# ", cp=" , complexPar, ")", sep="")
# }
# else {
# command <- paste("rpart(", formula, ", data=", .activeDataSet,
# subset, ", cp=" , complexPar, ")", sep="")
# }
doItAndPrint(paste(modelValue, "<-", command))
if(prunePlot == "1") {
logger(paste("plotcp(", modelValue, ")", sep=""))
justDoIt(paste("plotcp(", modelValue, ")", sep=""))
}
if(prunePrint == "1") {
# doItAndPrint(paste("Printcp(", modelValue, ") # Pruning Table",
# sep=""))
doItAndPrint(paste("printcp(", modelValue, ") # Pruning Table",
sep=""))
}
if(treePrint == "1") {
# doItAndPrint(paste("Print(", modelValue, ") # Tree Leaf Summary",
# sep=""))
# doItAndPrint(paste("print(", modelValue, ") # Tree Leaf Summary",
# sep=""))
doItAndPrint(paste(modelValue, " # Tree Leaf Summary", sep=""))
}
activeModel(modelValue)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="rpart")
helpButton <- buttonRcmdr(buttonsFrame, text="Help", width="12", command=onHelp)
tkgrid(tklabel(modelFrame, text=gettextRcmdr("Enter name for model:")),
model, sticky="w")
tkgrid(modelFrame, sticky="w")
modelFormula()
tkgrid(getFrame(xBox), sticky="w")
tkgrid(formulaFrame, sticky="w")
tkgrid(subsetFrame, sticky="w")
tkgrid(tklabel(optionsFrame, text=" "), sticky="w")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Complexity parameter:")),
comParField, sticky="w")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Print pruning table:")),
printCB, tklabel(optionsFrame, text=gettextRcmdr("Plot pruning table:")),
plotCB,tklabel(optionsFrame, text=gettextRcmdr(
"Print tree leaf summary:")), printTreeCB, sticky="w")
tkgrid(optionsFrame, sticky="w")
tkgrid(buttonsFrame, sticky="w")
dialogSuffix(rows=4, columns=1, focus=lhsEntry, preventDoubleClick=TRUE)
}
rpartPlot <- function(){
rpartMod <- ActiveModel()
initializeDialog(title=gettextRcmdr("Plot an rpart Tree"))
leafFrame <- tkframe(top)
radioButtons(name="leaf", buttons=c("counts", "proportions"),
labels=gettextRcmdr(c("Counts", "Proportions")), title=gettextRcmdr("Leaf Summary"))
optionsFrame <- tkframe(top)
uniform <- tclVar("1")
uniformCB <- tkcheckbutton(optionsFrame)
tkconfigure(uniformCB, variable=uniform)
onOK <- function(){
leafSum <- tclvalue(leafVariable)
uniformOp <- tclvalue(uniform)
closeDialog()
if(uniformOp == 1) uniformStr <- ", uniform = TRUE, fallen.leaves = FALSE)"
else uniformStr <- ", uniform = FALSE, fallen.leaves = TRUE)"
if(leafSum == "counts") leafStr <- "extra = 2"
else leafStr <- "extra = 4"
plotCom <- paste("rpart.plot(", rpartMod, ", type = 0, ", leafStr, uniformStr, sep="")
logger(plotCom)
justDoIt(plotCom)
activateMenus()
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="rpart.plot")
tkgrid(leafFrame, sticky="w")
tkgrid(tklabel(optionsFrame,
text=gettextRcmdr("Uniform branch distances")), uniformCB, sticky="w")
tkgrid(optionsFrame, sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=4, columns=2)
}
# MODELS MENU
summarizeModelBCA <- function(){
.activeModel <- ActiveModel()
if (!checkMethod("summary", .activeModel)) return()
modClass <- eval(parse(text=paste("class(",.activeModel,")[1]", sep="")))
if(modClass == "rpart") {
doItAndPrint(paste("summary(", .activeModel, ")", sep=""))
}
else doItAndPrint(paste("summary(", .activeModel, ", cor=FALSE)", sep=""))
if(modClass == "glm") {
doItAndPrint(paste("1 - (", .activeModel, "$deviance/",
.activeModel, "$null.deviance) # McFadden R^2", sep=""))
}
}
stepwiseBCA <- function(){
initializeDialog(title=gettextRcmdr("Stepwise Variable Selection"))
modelFrame <- tkframe(top)
modelType <- eval(parse(text=paste("class(", ActiveModel(), ")[1]", sep="")))
if(modelType=="lm") {
modelName <- tclVar(paste("LinearModel.", getRcmdr("modelNumber"), sep=""))
}
else if(modelType=="glm") {
modelName <- tclVar(paste("GLM.", getRcmdr("modelNumber"), sep=""))
}
else {
modelName <- tclVar(paste("Step.", getRcmdr("modelNumber"), sep=""))
}
modelField <- tkentry(modelFrame, width="20", textvariable=modelName)
directionFrame <- tkframe(top)
radioButtons(name="direction",
buttons=c("both", "backward", "forward"), labels=gettextRcmdr(c("Both",
"Backward", "Foward")), title=gettextRcmdr("Search Direction"))
optionsFrame <- tkframe(top)
radioButtons(optionsFrame, name="criteria", buttons=c("aic", "bic"),
labels=gettextRcmdr(c("AIC", "BIC")), title=gettextRcmdr("Selection Criteria"))
checkFrame <- tkframe(optionsFrame)
printSum <- tclVar("1")
printCB <- tkcheckbutton(checkFrame)
tkconfigure(printCB, variable=printSum)
onOK <- function(){
searchDir <- tclvalue(directionVariable)
selectCrit <- tclvalue(criteriaVariable)
sumPrint <- tclvalue(printSum)
modelValue <- trim.blanks(tclvalue(modelName))
if (!is.valid.name(modelValue)){
UpdateModelNumber(-1)
errorCondition(recall=stepwise, message=
sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue),
model=TRUE)
return()
}
closeDialog()
if(selectCrit=="aic") {
kVal <- 2
}
else {
nob <- eval(parse(text=paste("length(", ActiveModel(), "$residuals)", sep="")))
kVal <- paste("log(", nob, ")", sep="")
}
command <- paste("step(", ActiveModel(), ", direction=", '"', searchDir, '"',
", k=", kVal, ")", sep="")
doItAndPrint(paste(modelValue, "<-", command))
if(sumPrint=="1") {
doItAndPrint(paste("summary(", modelValue, ")", sep=""))
if(modelType == "glm") {
doItAndPrint(paste("1 - (", modelValue, "$deviance/",
modelValue, "$null.deviance) # McFadden R^2", sep=""))
}
}
activeModel(modelValue)
activateMenus()
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="step")
tkgrid(modelField, sticky="w")
tkgrid(tklabel(top, text=gettextRcmdr("Enter the name of the new model:")),
modelFrame, sticky="w")
tkgrid(criteriaFrame, sticky="w")
tkgrid(tklabel(checkFrame, text=gettextRcmdr("Print Summary ")), printCB,
sticky="w")
tkgrid(checkFrame, sticky="w")
tkgrid(directionFrame, optionsFrame, sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=3, columns=2)
}
## Lift charts and scoring
liftChart <- function() {
dataSets <- listDataSets()
parseDataSetGlm <- function(x) {
y <- eval(parse(text=paste(x, "$call", sep="")))
out <- unlist(strsplit(as.character(y), "="))[4]
return(out)
}
parseDataSetOther <- function(x) {
y <- eval(parse(text=paste(x, "$call", sep="")))
out <- unlist(strsplit(as.character(y), "="))[3]
return(out)
}
.activeDataSet <- ActiveDataSet()
if(length(listGeneralizedLinearModels()>0)) {
glmObjects <- listGeneralizedLinearModels()
testDataSetGlm <- tapply(glmObjects, as.factor(1:length(glmObjects)),
parseDataSetGlm)
validGlmObjects <- glmObjects[testDataSetGlm==.activeDataSet]
}
else {validGlmObjects <- character(0)}
if(length(listRpartModels()) > 0 | length(listNnetModels()) > 0) {
otherObjects <- c(listRpartModels(), listNnetModels())
testDataSetOther <- tapply(otherObjects,
as.factor(1:length(otherObjects)), parseDataSetOther)
validOtherObjects <- otherObjects[testDataSetOther==.activeDataSet]
}
else {validOtherObjects <- character(0)}
validModelObjects <- c(validGlmObjects, validOtherObjects)
initializeDialog(title="Lift Chart")
modelBox <- variableListBox(top, validModelObjects, selectmode="multiple",
title=gettextRcmdr("Select One or More Models"))
dataSetBox <- variableListBox(top, dataSets, selectmode="single",
title=gettextRcmdr("Select a Single Data Set"),
initialSelection=if (is.null(.activeDataSet)) NULL else which(.activeDataSet == dataSets) - 1)
subsetBoxBCA()
radioButtons(name="type", buttons=c("cumulative", "incremental"),
labels=gettextRcmdr(c("Total Cumulative Response",
"Incremental Response Rate")),
title=gettextRcmdr("Select the Lift Chart Type"))
responseFrame <- tkframe(top)
if(is.null(getRcmdr(".trueResp"))) trueResp <- tclVar("")
else trueResp <- tclVar(getRcmdr(".trueResp"))
trueRespField <- tkentry(responseFrame, width="6", textvariable=trueResp)
if(is.null(getRcmdr(".targetLevel"))) targLevel <- tclVar("")
else targLevel <- tclVar(getRcmdr(".targetLevel"))
targLevelField <- tkentry(responseFrame, width="10", textvariable=targLevel)
sampNameFrame <- tkframe(top)
if(is.null(getRcmdr(".Sample"))) sampName <- tclVar("")
else sampName <- tclVar(getRcmdr(".Sample"))
sampNameField <- tkentry(sampNameFrame, width="15", textvariable=sampName)
onOK <- function() {
modelObjcts <- getSelection(modelBox)
dataSet <- getSelection(dataSetBox)
subset <- tclvalue(subsetVariable)
chartType <- tclvalue(typeVariable)
trueRespRate <- tclvalue(trueResp)
targLabel <- tclvalue(targLevel)
sampLabel <- tclvalue(sampName)
closeDialog()
if(length(modelObjcts)==0) {
errorCondition(recall=liftChart,
message=gettextRcmdr("No model objects have been selected."))
return()
}
if(length(dataSet)==0) {
errorCondition(recall=liftChart,
message=gettextRcmdr("No comparison data set has been selected."))
return()
}
if(trueRespRate=="") {
errorCondition(recall=liftChart,
message=gettextRcmdr("A true sample response rate must be provided."))
return()
}
if(targLabel=="") {
errorCondition(recall=liftChart,
message=gettextRcmdr("A target level label must be provided."))
return()
}
if(is.equality.prob(trim.blanks(subset))) {
errorCondition(recall=liftChart,
message=gettextRcmdr('Use "==" not "=" for equalties in subsetting.'))
return()
}
if(length(modelObjcts) == 1) {
modList <- paste('"', modelObjcts, '"', sep="")
}
else {
modList <- paste('"', modelObjcts[1], '"', sep="")
for(i in 2:length(modelObjcts)) {
modList <- paste(modList, ', "', modelObjcts[i], '"', sep="")
}
}
modList <- paste("c(", modList, ")", sep="")
if((trim.blanks(subset) == gettextRcmdr("<all valid cases>")) |
(trim.blanks(subset) == "")) {
dataSet <- dataSet
}
else {
dataSet <- paste(dataSet, "[", dataSet, "$",
trim.blanks(subset),",]", sep="")
putRcmdr(".subset", trim.blanks(subset))
}
putRcmdr(".targetLevel", targLabel)
putRcmdr(".trueResp", trueRespRate)
putRcmdr(".Sample", sampLabel)
command1 <- paste(modList, ", ", dataSet, ", ", '"', targLabel, '"',
", ", trueRespRate, ", ", '"', chartType, '"',
", ", '"', sampLabel, '"', sep="")
command <- paste("lift.chart(", command1, ")", sep="")
justDoIt(command)
logger(command)
activateMenus()
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="lift.chart")
tkgrid(getFrame(modelBox), getFrame(dataSetBox), sticky="nw")
tkgrid(typeFrame, subsetFrame, sticky="nw")
tkgrid(tklabel(top, text=""), sticky="w")
tkgrid(tklabel(responseFrame, text=gettextRcmdr("True Response Rate: ")),
trueRespField, sticky="w")
tkgrid(tklabel(responseFrame, text=gettextRcmdr("Target Level: ")),
targLevelField, sticky="w")
tkgrid(tklabel(sampNameFrame, text=gettextRcmdr("Sample Name: ")),
sampNameField, sticky="w")
tkgrid(responseFrame, sampNameFrame, sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=2, columns=2)
invisible()
}
liftChartP <- function() {
parseDataSetGlm <- function(x) {
y <- eval(parse(text=paste(x, "$call", sep="")))
out <- unlist(strsplit(as.character(y), "="))[4]
return(out)
}
parseDataSetOther <- function(x) {
y <- eval(parse(text=paste(x, "$call", sep="")))
out <- unlist(strsplit(as.character(y), "="))[3]
return(out)
}
.activeDataSet <- ActiveDataSet()
if(length(listGeneralizedLinearModels()>0)) {
glmObjects <- listGeneralizedLinearModels()
testDataSetGlm <- tapply(glmObjects, as.factor(1:length(glmObjects)),
parseDataSetGlm)
validGlmObjects <- glmObjects[testDataSetGlm==.activeDataSet]
}
else {validGlmObjects <- character(0)}
if(length(listRpartModels()) > 0 | length(listNnetModels()) > 0) {
otherObjects <- c(listRpartModels(), listNnetModels())
testDataSetOther <- tapply(otherObjects,
as.factor(1:length(otherObjects)), parseDataSetOther)
validOtherObjects <- otherObjects[testDataSetOther==.activeDataSet]
}
else {validOtherObjects <- character(0)}
validModelObjects <- c(validGlmObjects, validOtherObjects)
test <- length(validModelObjects) > 0
return(test)
}
rankScoreGUI <- function() {
parseDataSetGlm <- function(x) {
y <- eval(parse(text=paste(x, "$call", sep="")))
out <- unlist(strsplit(as.character(y), "="))[4]
return(out)
}
parseDataSetOther <- function(x) {
y <- eval(parse(text=paste(x, "$call", sep="")))
out <- unlist(strsplit(as.character(y), "="))[3]
return(out)
}
.activeDataSet <- ActiveDataSet()
if(length(listGeneralizedLinearModels()>0)) {
glmObjects <- listGeneralizedLinearModels()
testDataSetGlm <- tapply(glmObjects, as.factor(1:length(glmObjects)),
parseDataSetGlm)
validGlmObjects <- glmObjects[testDataSetGlm==.activeDataSet]
}
else {validGlmObjects <- character(0)}
if(length(listRpartModels()) > 0 | length(listNnetModels()) > 0) {
otherObjects <- c(listRpartModels(), listNnetModels())
testDataSetOther <- tapply(otherObjects,
as.factor(1:length(otherObjects)), parseDataSetOther)
validOtherObjects <- otherObjects[testDataSetOther==.activeDataSet]
}
else {validOtherObjects <- character(0)}
validModelObjects <- c(validGlmObjects, validOtherObjects)
initializeDialog(title="Rank Order Records Based on Expected Response")
modelBox <- variableListBox(top, validModelObjects, selectmode="single",
title=gettextRcmdr("Select a Single Model"))
dataSetBox <- variableListBox(top, listDataSets(), selectmode="single",
title=gettextRcmdr("Select a Single Data Set"))
targetFrame <- tkframe(top)
if(is.null(getRcmdr(".targetLevel"))) targLevel <- tclVar("")
else targLevel <- tclVar(getRcmdr(".targetLevel"))
targLevelField <- tkentry(targetFrame, width="10", textvariable=targLevel)
varNameFrame<-tkframe(top)
varName <- tclVar("Score")
varNameField <- tkentry(varNameFrame, width="10", textvariable=varName)
onOK <- function() {
modObj <- getSelection(modelBox)
dataSet <- getSelection(dataSetBox)
targLabel <- tclvalue(targLevel)
varLabel <- tclvalue(varName)
closeDialog()
if(length(modObj)==0) {
errorCondition(recall=rankScoreGUI,
message=gettextRcmdr("No model has been selected."))
return()
}
if(length(dataSet)==0) {
errorCondition(recall=rankScoreGUI,
message=gettextRcmdr("No data set to score has been selected."))
return()
}
if(targLabel=="") {
errorCondition(recall=rankScoreGUI,
message=gettextRcmdr("A target level label must be provided."))
return()
}
if (!is.valid.name(varLabel)){
errorCondition(recall=rankScoreGUI, message=
paste('"', varLabel, '" ',
gettextRcmdr("is not a valid name."), sep=""))
return()
}
c1 <- paste('"', modObj, '", ', dataSet, ', "', targLabel,'"', sep="")
command <- paste(dataSet, "$", varLabel, " <- rankScore(", c1, ")", sep="")
justDoIt(command)
logger(command)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="score")
tkgrid(getFrame(modelBox), getFrame(dataSetBox), sticky="nw")
tkgrid(tklabel(targetFrame, text=gettextRcmdr("Target Level:")),
targLevelField, sticky="w")
tkgrid(tklabel(varNameFrame, text=gettextRcmdr("Score Variable Name: ")),
varNameField, sticky="w")
tkgrid(targetFrame, varNameFrame, sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=2, columns=2)
return(invisible())
}
rawProbScoreGUI <- function() {
parseDataSetGlm <- function(x) {
y <- eval(parse(text=paste(x, "$call", sep="")))
out <- unlist(strsplit(as.character(y), "="))[4]
return(out)
}
parseDataSetOther <- function(x) {
y <- eval(parse(text=paste(x, "$call", sep="")))
out <- unlist(strsplit(as.character(y), "="))[3]
return(out)
}
.activeDataSet <- ActiveDataSet()
if(length(listGeneralizedLinearModels()>0)) {
glmObjects <- listGeneralizedLinearModels()
testDataSetGlm <- tapply(glmObjects, as.factor(1:length(glmObjects)),
parseDataSetGlm)
validGlmObjects <- glmObjects[testDataSetGlm==.activeDataSet]
}
else {validGlmObjects <- character(0)}
if(length(listRpartModels()) > 0 | length(listNnetModels()) > 0) {
otherObjects <- c(listRpartModels(), listNnetModels())
testDataSetOther <- tapply(otherObjects,
as.factor(1:length(otherObjects)), parseDataSetOther)
validOtherObjects <- otherObjects[testDataSetOther==.activeDataSet]
}
else {validOtherObjects <- character(0)}
validModelObjects <- c(validGlmObjects, validOtherObjects)
initializeDialog(title="Score Records Based on Sample Probabilities")
modelBox <- variableListBox(top, validModelObjects, selectmode="single",
title=gettextRcmdr("Select a Single Model"))
dataSetBox <- variableListBox(top, listDataSets(), selectmode="single",
title=gettextRcmdr("Select a Single Data Set"))
targetFrame <- tkframe(top)
if(is.null(getRcmdr(".targetLevel"))) targLevel <- tclVar("")
else targLevel <- tclVar(getRcmdr(".targetLevel"))
targLevelField <- tkentry(targetFrame, width="10", textvariable=targLevel)
varNameFrame<-tkframe(top)
varName <- tclVar("Score")
varNameField <- tkentry(varNameFrame, width="10", textvariable=varName)
onOK <- function() {
modObj <- getSelection(modelBox)
dataSet <- getSelection(dataSetBox)
targLabel <- tclvalue(targLevel)
varLabel <- tclvalue(varName)
closeDialog()
if(length(modObj)==0) {
errorCondition(recall=rawProbScoreGUI,
message=gettextRcmdr("No model has been selected."))
return()
}
if(length(dataSet)==0) {
errorCondition(recall=rawProbScoreGUI,
message=gettextRcmdr("No data set to score has been selected."))
return()
}
if(targLabel=="") {
errorCondition(recall=rawProbScoreGUI,
message=gettextRcmdr("A target level label must be provided."))
return()
}
if (!is.valid.name(varLabel)){
errorCondition(recall=rawProbScoreGUI, message=
paste('"', varLabel, '" ',
gettextRcmdr("is not a valid name."), sep=""))
return()
}
c1 <- paste('"', modObj, '", ', dataSet, ', "', targLabel,'"', sep="")
command <- paste(dataSet, "$", varLabel, " <- rawProbScore(", c1, ")", sep="")
justDoIt(command)
logger(command)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="score")
tkgrid(getFrame(modelBox), getFrame(dataSetBox), sticky="nw")
tkgrid(tklabel(targetFrame, text=gettextRcmdr("Target Level:")),
targLevelField, sticky="w")
tkgrid(tklabel(varNameFrame, text=gettextRcmdr("Score Variable Name: ")),
varNameField, sticky="w")
tkgrid(targetFrame, varNameFrame, sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=2, columns=2)
return(invisible())
}
adjProbScoreGUI <- function() {
parseDataSetGlm <- function(x) {
y <- eval(parse(text=paste(x, "$call", sep="")))
out <- unlist(strsplit(as.character(y), "="))[4]
return(out)
}
parseDataSetOther <- function(x) {
y <- eval(parse(text=paste(x, "$call", sep="")))
out <- unlist(strsplit(as.character(y), "="))[3]
return(out)
}
.activeDataSet <- ActiveDataSet()
if(length(listGeneralizedLinearModels()>0)) {
glmObjects <- listGeneralizedLinearModels()
testDataSetGlm <- tapply(glmObjects, as.factor(1:length(glmObjects)),
parseDataSetGlm)
validGlmObjects <- glmObjects[testDataSetGlm==.activeDataSet]
}
else {validGlmObjects <- character(0)}
if(length(listRpartModels()) > 0 | length(listNnetModels()) > 0) {
otherObjects <- c(listRpartModels(), listNnetModels())
testDataSetOther <- tapply(otherObjects,
as.factor(1:length(otherObjects)), parseDataSetOther)
validOtherObjects <- otherObjects[testDataSetOther==.activeDataSet]
}
else {validOtherObjects <- character(0)}
validModelObjects <- c(validGlmObjects, validOtherObjects)
initializeDialog(title="Score Records Based on Adjusted Probabilities")
modelBox <- variableListBox(top, validModelObjects, selectmode="single",
title=gettextRcmdr("Select a Single Model"))
dataSetBox <- variableListBox(top, listDataSets(), selectmode="single",
title=gettextRcmdr("Select a Single Data Set"))
targetFrame <- tkframe(top)
trueResp <- tclVar("")
trueRespField <- tkentry(targetFrame, width="6", textvariable=trueResp)
if(is.null(getRcmdr(".targetLevel"))) targLevel <- tclVar("")
else targLevel <- tclVar(getRcmdr(".targetLevel"))
targLevelField <- tkentry(targetFrame, width="10", textvariable=targLevel)
varNameFrame<-tkframe(top)
varName <- tclVar("Score")
varNameField <- tkentry(varNameFrame, width="10", textvariable=varName)
onOK <- function() {
modObj <- getSelection(modelBox)
dataSet <- getSelection(dataSetBox)
trueRespRate <- tclvalue(trueResp)
targLabel <- tclvalue(targLevel)
varLabel <- tclvalue(varName)
closeDialog()
if(length(modObj)==0) {
errorCondition(recall=adjProbScoreGUI,
message=gettextRcmdr("No model has been selected."))
return()
}
if(length(dataSet)==0) {
errorCondition(recall=adjProbScoreGUI,
message=gettextRcmdr("No data set to score has been selected."))
return()
}
if(targLabel=="") {
errorCondition(recall=adjProbScoreGUI,
message=gettextRcmdr("A target level label must be provided."))
return()
}
if (!is.valid.name(varLabel)){
errorCondition(recall=adjProbScoreGUI, message=
paste('"', varLabel, '" ',
gettextRcmdr("is not a valid name."), sep=""))
return()
}
c1 <- paste('"', modObj, '", ', dataSet, ', "', targLabel,'", ', trueRespRate, sep="")
command <- paste(dataSet, "$", varLabel, " <- adjProbScore(", c1, ")", sep="")
justDoIt(command)
logger(command)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="score")
tkgrid(getFrame(modelBox), getFrame(dataSetBox), sticky="nw")
tkgrid(tklabel(targetFrame, text=gettextRcmdr("True Response Rate: ")),
trueRespField, sticky="w")
tkgrid(tklabel(targetFrame, text=gettextRcmdr("Target Level:")),
targLevelField, sticky="w")
tkgrid(tklabel(varNameFrame, text=gettextRcmdr("Score Variable Name: ")),
varNameField, sticky="w")
tkgrid(targetFrame, varNameFrame, sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=2, columns=2)
return(invisible())
}
variablesP <- function(n=1) activeDataSetP() && length(listVariables()) >= n
# rglSaveP <- function() {
# if(any(loadedNamespaces()!="rgl")) chk <- FALSE
# else if(rgl.cur() == 0) chk <- FALSE
# else chk <- TRUE
# return(chk)
# }
is.equality.prob <- function(subset) {
problem <- FALSE
chkString <- unlist(strsplit(subset, "="))
if(length(chkString) == 2 & is.valid.name(trim.blanks(chkString[1]))) {
problem <- TRUE
}
return(problem)
}
# The "about" page for the plug-in
helpAboutBCA <- function() {
if (as.numeric(R.Version()$major) >= 3) print(help("RcmdrPlugin.BCA"))
else help("RcmdrPlugin.BCA")
}
# The change to the scatterPlot and scatterPlotMatrix functions to set the value
# of loess.threshold parameter to 2 from the default of 5. This allows for the
# plotting of discrete variables.
scatterPlotBCA <- function () {
defaults <- list(initial.x = NULL, initial.y = NULL, initial.jitterx = 0, initial.jittery = 0,
initial.logstringx = 0, initial.logstringy = 0, initial.log = 0, initial.box = 1,
initial.line = 1, initial.smooth = 1, initial.spread = 1, initial.span = 50,
initial.subset = gettextRcmdr ("<all valid cases>"), initial.ylab = gettextRcmdr ("<auto>"),
initial.xlab = gettextRcmdr("<auto>"), initial.pch = gettextRcmdr("<auto>"),
initial.cexValue = 1, initial.cex.axisValue = 1, initial.cex.labValue = 1, initialGroup=NULL, initial.lines.by.group=1)
dialog.values <- getDialog("scatterPlot", defaults)
initial.group <- dialog.values$initial.group
.linesByGroup <- if (dialog.values$initial.lines.by.group == 1) TRUE else FALSE
.groups <- if (is.null(initial.group)) FALSE else initial.group
initializeDialog(title = gettextRcmdr("Scatterplot"))
.numeric <- Numeric()
variablesFrame <- tkframe(top)
xBox <- variableListBox(variablesFrame, .numeric, title = gettextRcmdr("x-variable (pick one)"),
initialSelection = varPosn (dialog.values$initial.x, "numeric"))
yBox <- variableListBox(variablesFrame, .numeric, title = gettextRcmdr("y-variable (pick one)"),
initialSelection = varPosn (dialog.values$initial.y, "numeric"))
optionsParFrame <- tkframe(top)
checkBoxes(window = optionsParFrame, frame = "optionsFrame",
boxes = c("identify", "jitterX", "jitterY", "logX", "logY",
"boxplots", "lsLine", "smoothLine", "spread"), initialValues = c(dialog.values$initial.log,
dialog.values$initial.jitterx, dialog.values$initial.jittery,
dialog.values$initial.logstringx, dialog.values$initial.logstringy,
dialog.values$initial.box, dialog.values$initial.line, dialog.values$initial.smooth,
dialog.values$initial.spread),labels = gettextRcmdr(c("Identify points",
"Jitter x-variable", "Jitter y-variable", "Log x-axis",
"Log y-axis", "Marginal boxplots", "Least-squares line",
"Smooth line", "Show spread")), title = "Options")
sliderValue <- tclVar(dialog.values$initial.span)
slider <- tkscale(optionsFrame, from = 0, to = 100, showvalue = TRUE,
variable = sliderValue, resolution = 5, orient = "horizontal")
subsetBox(subset.expression = dialog.values$initial.subset)
labelsFrame <- tkframe(top)
xlabVar <- tclVar(dialog.values$initial.xlab)
ylabVar <- tclVar(dialog.values$initial.ylab)
xlabFrame <- tkframe(labelsFrame)
xlabEntry <- ttkentry(xlabFrame, width = "25", textvariable = xlabVar)
xlabScroll <- ttkscrollbar(xlabFrame, orient = "horizontal",
command = function(...) tkxview(xlabEntry, ...))
tkconfigure(xlabEntry, xscrollcommand = function(...) tkset(xlabScroll,
...))
tkgrid(labelRcmdr(xlabFrame, text = gettextRcmdr("x-axis label"),
fg = "blue"), sticky = "w")
tkgrid(xlabEntry, sticky = "w")
tkgrid(xlabScroll, sticky = "ew")
ylabFrame <- tkframe(labelsFrame)
ylabEntry <- ttkentry(ylabFrame, width = "25", textvariable = ylabVar)
ylabScroll <- ttkscrollbar(ylabFrame, orient = "horizontal",
command = function(...) tkxview(ylabEntry, ...))
tkconfigure(ylabEntry, xscrollcommand = function(...) tkset(ylabScroll,
...))
tkgrid(labelRcmdr(ylabFrame, text = gettextRcmdr("y-axis label"),
fg = "blue"), sticky = "w")
tkgrid(ylabEntry, sticky = "w")
tkgrid(ylabScroll, sticky = "ew")
tkgrid(xlabFrame, labelRcmdr(labelsFrame, text = " "),
ylabFrame, sticky = "w")
parFrame <- tkframe(optionsParFrame)
pchVar <- tclVar(dialog.values$initial.pch)
pchEntry <- ttkentry(parFrame, width = 25, textvariable = pchVar)
cexValue <- tclVar(dialog.values$initial.cexValue)
cex.axisValue <- tclVar(dialog.values$initial.cex.axisValue)
cex.labValue <- tclVar(dialog.values$initial.cex.labValue)
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)
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 ""
logstring <- ""
if ("1" == tclvalue(logXVariable))
logstring <- paste(logstring, "x", sep = "")
if ("1" == tclvalue(logYVariable))
logstring <- paste(logstring, "y", sep = "")
log <- tclvalue(identifyVariable)
box <- tclvalue(boxplotsVariable)
line <- tclvalue(lsLineVariable)
smooth <- tclvalue(smoothLineVariable)
spread <- tclvalue(spreadVariable)
span <- as.numeric(tclvalue(sliderValue))
initial.subset <- subset <- tclvalue(subsetVariable)
subset <- if (trim.blanks(subset) == gettextRcmdr("<all valid cases>"))
""
else paste(", subset=", subset, sep = "")
cex.axis <- as.numeric(tclvalue(cex.axisValue))
cex <- as.numeric(tclvalue(cexValue))
cex.lab <- as.numeric(tclvalue(cex.labValue))
xlab <- trim.blanks(tclvalue(xlabVar))
xlab <- if (xlab == gettextRcmdr("<auto>"))
""
else paste(", xlab=\"", xlab, "\"", sep = "")
ylab <- trim.blanks(tclvalue(ylabVar))
ylab <- if (ylab == gettextRcmdr("<auto>"))
""
else paste(", ylab=\"", ylab, "\"", sep = "")
pch <- gsub(" ", ",", tclvalue(pchVar))
putDialog ("scatterPlot", list (initial.x = x, initial.y = y, initial.jitterx = tclvalue(jitterXVariable),
initial.jittery = tclvalue(jitterYVariable), initial.logstringx = tclvalue(logXVariable),
initial.logstringy = tclvalue(logYVariable), initial.log = log, initial.box = box,
initial.line = line, initial.smooth = smooth, initial.spread = spread,
initial.span = span, initial.subset = initial.subset, initial.xlab = tclvalue(xlabVar),
initial.ylab = tclvalue(ylabVar), initial.cexValue = tclvalue(cexValue),
initial.cex.axisValue = tclvalue(cex.axisValue), initial.cex.labValue = tclvalue(cex.labValue),
initial.pch = pch, initial.group=if (.groups == FALSE) NULL else .groups,
initial.lines.by.group=if (.linesByGroup) 1 else 0))
closeDialog()
if ("" == pch) {
errorCondition(recall = scatterPlot, message = gettextRcmdr("No plotting characters."))
return()
}
pch <- if (trim.blanks(pch) == gettextRcmdr("<auto>"))
""
else paste(", pch=c(", pch, ")", sep = "")
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()
log <- if (logstring != "")
paste(", log=\"", logstring, "\"", sep = "")
else ""
if ("1" == tclvalue(identifyVariable)) {
RcmdrTkmessageBox(title = "Identify Points", message = paste(gettextRcmdr("Use left mouse button to identify points,\n"),
gettextRcmdr(if (MacOSXP())
"esc key to exit."
else "right button to exit."), sep = ""), icon = "info",
type = "ok")
idtext <- ", id.method=\"identify\""
}
else idtext <- ""
box <- if ("1" == tclvalue(boxplotsVariable))
"'xy'"
else "FALSE"
line <- if ("1" == tclvalue(lsLineVariable))
"lm"
else "FALSE"
smooth <- as.character("1" == tclvalue(smoothLineVariable))
spread <- as.character("1" == tclvalue(spreadVariable))
cex <- if (cex == 1)
""
else paste(", cex=", cex, sep = "")
cex.axis <- if (cex.axis == 1)
""
else paste(", cex.axis=", cex.axis, sep = "")
cex.lab <- if (cex.lab == 1)
""
else paste(", cex.lab=", cex.lab, sep = "")
if (.groups == FALSE) {
doItAndPrint(paste("scatterplot(", y, "~", x, log,
", reg.line=", line, ", smooth=", smooth,
", loess.threshold=2, spread=",
spread, idtext, ", boxplots=", box, ", span=",
span/100, jitter, xlab, ylab, cex, cex.axis,
cex.lab, pch, ", data=", .activeDataSet, subset,
")", sep = ""))
}
else {
doItAndPrint(paste("scatterplot(", y, "~", x, " | ",
.groups, ", reg.line=", line, ", smooth=", smooth,
", loess.threshold=2, spread=", spread, idtext,
", 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, initialGroup=initial.group, initialLinesByGroup=dialog.values$initial.lines.by.group,
initialLabel=if (is.null(initial.group)) gettextRcmdr("Plot by groups") else paste(gettextRcmdr("Plot by:"), initial.group))
OKCancelHelp(helpSubject = "scatterplot", reset = "scatterPlot")
tkgrid(getFrame(xBox), getFrame(yBox), sticky = "nw")
tkgrid(variablesFrame, sticky = "w")
tkgrid(labelRcmdr(optionsFrame, text = gettextRcmdr("Span for smooth")),
slider, sticky = "w")
tkgrid(labelRcmdr(parFrame, text = gettextRcmdr("Plotting Parameters"),
fg = "blue"), sticky = "w")
tkgrid(labelRcmdr(parFrame, text = gettextRcmdr("Plotting characters")),
pchEntry, stick = "w")
tkgrid(labelRcmdr(parFrame, text = gettextRcmdr("Point size")),
cexSlider, sticky = "w")
tkgrid(labelRcmdr(parFrame, text = gettextRcmdr("Axis text size")),
cex.axisSlider, sticky = "w")
tkgrid(labelRcmdr(parFrame, text = gettextRcmdr("Axis-labels text size")),
cex.labSlider, sticky = "w")
tkgrid(optionsFrame, parFrame, sticky = "nw")
tkgrid(optionsParFrame, sticky = "w")
tkgrid(labelsFrame, sticky = "w")
tkgrid(subsetFrame, sticky = "w")
tkgrid(groupsFrame, sticky = "w")
tkgrid(labelRcmdr(top, text = " "))
tkgrid(buttonsFrame, columnspan = 2, sticky = "w")
dialogSuffix(rows = 8, columns = 2)
}
scatterPlotMatrixBCA <- function () {
defaults <- list(initial.variables = NULL, initial.line = 1, initial.smooth = 1, initial.spread = 0,
initial.span = 50, initial.diag = "density", initial.subset = gettextRcmdr ("<all valid cases>"),
initialGroup=NULL, initial.lines.by.group=1)
dialog.values <- getDialog("scatterPlotMatrix", defaults)
initial.group <- dialog.values$initial.group
.linesByGroup <- if (dialog.values$initial.lines.by.group == 1) TRUE else FALSE
.groups <- if (is.null(initial.group)) FALSE else initial.group
initializeDialog(title = gettextRcmdr("Scatterplot Matrix"))
variablesBox <- variableListBox(top, Numeric(), title = gettextRcmdr("Select variables (three or more)"),
selectmode = "multiple", initialSelection = varPosn (dialog.values$initial.variables, "numeric"))
checkBoxes(frame = "optionsFrame", boxes = c("lsLine", "smoothLine",
"spread"), initialValues = c(dialog.values$initial.line, dialog.values$initial.smooth,
dialog.values$initial.spread), labels = gettextRcmdr(c("Least-squares lines",
"Smooth lines", "Show spread")))
sliderValue <- tclVar(dialog.values$initial.span)
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"),
initialValue = dialog.values$initial.diag)
subsetBox(subset.expression = dialog.values$initial.subset)
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))
spread <- as.character("1" == tclvalue(spreadVariable))
span <- as.numeric(tclvalue(sliderValue))
diag <- as.character(tclvalue(diagonalVariable))
initial.subset <- subset <- tclvalue(subsetVariable)
subset <- if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) ""
else paste(", subset=", subset, sep="")
putDialog("scatterPlotMatrix", list(initial.variables = variables, initial.line = tclvalue (lsLineVariable),
initial.smooth = tclvalue(smoothLineVariable),initial.spread = tclvalue (spreadVariable),
initial.span = span, initial.diag = diag, initial.subset = initial.subset,
initial.group=if (.groups == FALSE) NULL else .groups,
initial.lines.by.group=if (.linesByGroup) 1 else 0))
.activeDataSet <- ActiveDataSet()
if (.groups == FALSE) {
command <- paste("scatterplotMatrix(~", paste(variables,
collapse = "+"), ", reg.line=", line, ", smooth=",
smooth, ", loess.threshold=2, spread=", spread, ", span=", span/100,
", diagonal = '", diag, "', data=", .activeDataSet,
subset, ")", sep = "")
logger(command)
justDoIt(command)
}
else {
command <- paste("scatterplotMatrix(~", paste(variables,
collapse = "+"), " | ", .groups, ", reg.line=",
line, ", smooth=", smooth, ", loess.threshold=2, spread=", spread,
", span=", span/100, ", diagonal= '", diag, "', by.groups=",
.linesByGroup, ", data=", .activeDataSet, subset,
")", sep = "")
logger(command)
justDoIt(command)
}
activateMenus()
tkfocus(CommanderWindow())
}
groupsBox(scatterPlot, plotLinesByGroup = TRUE, initialGroup=initial.group, initialLinesByGroup=dialog.values$initial.lines.by.group,
initialLabel=if (is.null(initial.group)) gettextRcmdr("Plot by groups") else paste(gettextRcmdr("Plot by:"), initial.group))
OKCancelHelp(helpSubject = "scatterplotMatrix", reset = "scatterPlotMatrix")
tkgrid(getFrame(variablesBox), sticky = "nw")
tkgrid(labelRcmdr(optionsFrame, text = gettextRcmdr("Span for smooth")),
slider, sticky = "w")
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)
}
## Added as a workaround for R CMD check --as-cran to allow for an *.RD file
## example that would allow the package to not issue a warning for "No examples,
## no tests, no vignette"
# The neural network functions
nnSub <- function(data, subset) {
rowInd <- 1:nrow(data)
if(length(unlist(strsplit(subset, "=="))) == 2) {
compType <- "Equal"
subSplit <- unlist(strsplit(subset, "=="))
subVar <- trim.blanks(subSplit[1])
subVal <- eval(parse(text=trim.blanks(subSplit[2])))
}
else if(length(unlist(strsplit(subset, "!="))) == 2) {
compType <- "NotEqual"
subSplit <- unlist(strsplit(subset, "!="))
subVar <- trim.blanks(subSplit[1])
subVal <- eval(parse(text=trim.blanks(subSplit[2])))
}
else if(length(unlist(strsplit(subset, ">="))) == 2) {
compType <- "GrtrEqual"
subSplit <- unlist(strsplit(subset, ">="))
subVar <- trim.blanks(subSplit[1])
subVal <- eval(parse(text=trim.blanks(subSplit[2])))
}
else if(length(unlist(strsplit(subset, "<="))) == 2) {
compType <- "LessEqual"
subSplit <- unlist(strsplit(subset, "<="))
subVar <- trim.blanks(subSplit[1])
subVal <- eval(parse(text=trim.blanks(subSplit[2])))
}
else if(length(unlist(strsplit(subset, ">"))) == 2) {
compType <- "Grtr"
subSplit <- unlist(strsplit(subset, ">"))
subVar <- trim.blanks(subSplit[1])
subVal <- eval(parse(text=trim.blanks(subSplit[2])))
}
else if(length(unlist(strsplit(subset, "<"))) == 2) {
compType <- "Less"
subSplit <- unlist(strsplit(subset, "<"))
subVar <- trim.blanks(subSplit[1])
subVal <- eval(parse(text=trim.blanks(subSplit[2])))
}
else stop("No appropriate comparison operator was found.")
subSet <- data[[subVar]]
if(compType=="Equal") rowInd <- rowInd[subSet==subVal]
else if(compType=="NotEqual") rowInd <- rowInd[subSet!=subVal]
else if(compType=="GrtrEqual") rowInd <- rowInd[subSet>=subVal]
else if(compType=="LessEqual") rowInd <- rowInd[subSet<=subVal]
else if(compType=="Grtr") rowInd <- rowInd[subSet>subVal]
else rowInd <- rowInd[subSet<subVal]
rowInd <- rowInd[!is.na(rowInd)]
return(rowInd)
}
Nnet <- function (formula, data, decay, size, subset="") {
set.seed(1)
if(subset=="") {
nnetObj <- nnet(formula=formula, data=data, decay=decay, size=size,
maxit=400)
for(i in 2:10) {
set.seed(i)
newNnet <- nnet(formula=formula, data=data, decay=decay, size=size,
maxit=400)
if(newNnet$value < nnetObj$value) nnetObj <- newNnet
}
}
else {
selectRow <- nnSub(data, subset)
nData <- data[selectRow,]
nnetObj <- nnet(formula=formula, data=nData, decay=decay, size=size,
maxit=400)
for(i in 2:10) {
set.seed(i)
newNnet <- nnet(formula=formula, data=nData, decay=decay, size=size,
maxit=400)
if(newNnet$value < nnetObj$value) nnetObj <- newNnet
}
}
nnetObj$call <- call("Nnet", formula=formula, data=substitute(data), decay=decay,
size=size, subset=subset)
return(nnetObj)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.