inst/rkward/rkwarddev_CA_plugin_script.R
In rkward-community/rk.ClusterAnalysis: RKWard GUI to conduct k-means, model based and hierarchical cluster analyses
# the plugin code was generated by this script
# you should not change the plugin code directly, but this script
# note: this script only creates objects in your workspace,
# *EXCEPT* for the last call, see below.
require(rkwarddev)
rkwarddev.required("0.08-1")
local({
# set the output directory to overwrite the actual plugin
output.dir <- tempdir()
overwrite <- TRUE
# if you set guess.getters to TRUE, the resulting code will need RKWard >= 0.6.0
guess.getter <- TRUE
rk.set.indent(by=" ")
rk.set.empty.e(TRUE)
update.translations <- FALSE
about.info <- rk.XML.about(
name="rk.ClusterAnalysis",
author=c(
person(given="Meik", family="Michalke",
email="meik.michalke@hhu.de", role=c("aut","cre"))),
about=list(desc="RKWard GUI to conduct k-means, model based and hierarchical cluster analyses",
version="0.01-15", url="https://rkward.kde.org")
)
dependencies.info <- rk.XML.dependencies(
dependencies=list(rkward.min=ifelse(isTRUE(guess.getter), "0.6.0", "0.5.6")),
package=list(c(name="mclust"))
)
############
## re-used objects
############
# for plots
generic.plot.options <- rk.plotOptions()
# for data
data <- rk.XML.varselector(label="Select data", id.name="data")
dataSelected <- rk.XML.varslot(
label="Data (data.frame, matrix or dist)",
source=data,
classes=c("data.frame", "matrix", "dist"),
required=TRUE,
id.name="dataSelected"
)
dataSelectedNodist <- rk.XML.varslot(
label="Data (data.frame or matrix)",
source=data,
classes=c("data.frame", "matrix"),
required=TRUE,
id.name="dataSelectedNodist"
)
varsSelected <- rk.XML.varslot(
label="Selected variables",
source=data,
multi=TRUE,
id.name="varsSelected"
)
useSubset <- rk.XML.frame(
varsSelected,
label="Use only a subset of variables",
checkable=TRUE,
chk=FALSE,
id.name="useSubset"
)
# prepare data
omitNA <- rk.XML.cbox("Remove missing values", chk=TRUE, id.name="omitNA")
scaleValues <- rk.XML.cbox("Stadardize values", id.name="scaleValues")
dataPreparation <- rk.XML.frame(
omitNA,
scaleValues,
label="Data preparation"
)
distMethod <- rk.XML.dropdown(label="Computation method", options=list(
"Euclidean"=c(val="euclidean", chk=TRUE),
"Maximum"=c(val="maximum"),
"Manhattan (city block)"=c(val="manhattan"),
"Canberra"=c(val="canberra"),
"Binary"=c(val="binary"),
"Minkowski"=c(val="minkowski")
),
id.name="distMethod"
)
clustMethod <- rk.XML.dropdown(label="Agglomeration method", options=list(
"Ward (incl. clustering criterion)"=c(val="ward.D2"),
"Ward (without clustering criterion)"=c(val="ward.D"),
"Single linkage (nearest neighbor)"=c(val="single"),
"Complete linkage (furthest neighbor)"=c(val="complete", chk=TRUE),
"Average linkage (between groups linkage)"=c(val="average"),
"McQuitty"=c(val="mcquitty"),
"Median clustering"=c(val="median"),
"Centroid clustering"=c(val="centroid")
),
id.name="clustMethod"
)
powerMinkowski <- rk.XML.spinbox(
label="Power of Minkowski distance",
min=1,
initial=2,
real=FALSE,
id.name="powerMinkowski"
)
clust.h.frame.dist <- rk.XML.frame(distMethod, powerMinkowski, label="Distance matrix")
# for logic sections
lgc.df.script <- rk.comment(id("
gui.addChangeCommand(\"", dataSelected, ".available\", \"dataChanged()\");
// this function is called whenever the data was changed
dataChanged = function(){
var prepareFrame = \"true\";
var selectFrame = \"true\";
var thisObject = makeRObject(gui.getValue(\"", dataSelected, ".available\"));
if(thisObject.classes()){
if(!thisObject.isDataFrame()){
selectFrame = \"false\";
if(thisObject.classes().indexOf(\"dist\") != -1){
prepareFrame = \"false\";
} else {}
} else {}
} else {}
gui.setValue(\"", useSubset, ".enabled\", selectFrame);
gui.setValue(\"", dataPreparation, ".enabled\", prepareFrame);
}", js=FALSE))
lgc.current.object <- rk.XML.connect(governor="current_object", client=dataSelected, set="available")
lgc.data.from.selection <- rk.XML.connect(governor=dataSelected, client=data, get="available", set="root")
gov.data <- rk.XML.convert(sources=list(available=dataSelected), mode=c(notequals=""))
lgc.enable.selected <- rk.XML.connect(governor=gov.data, client=useSubset, set="enabled")
# disable distance computation, if dist object given
lgc.isntDistData <- rk.XML.connect(governor=dataPreparation, get="enabled", client=clust.h.frame.dist, set="enabled")
# for JavaScript
js.frm.subset <- rk.JS.vars(useSubset, modifiers="checked") # see if the frame is checked
js.varsSelected <- rk.JS.vars(varsSelected, modifiers="shortname", join="\\\", \\\"") # get selected vars
js.prepare <- rk.JS.vars(dataPreparation, modifiers="enabled") # see if data preparation is off
js.data.preparation <- rk.paste.JS(
js.frm.subset,
js.varsSelected,
js.prepare,
js(
if(js.frm.subset && js.varsSelected != ""){
R.comment("Use subset of variables")
echo("\t", dataSelected, " <- subset(",dataSelected,", select=c(\"", js.varsSelected, "\"))\n")
} else {},
if(js.prepare && omitNA){
R.comment("Listwise removal of missings")
echo("\t", dataSelected, " <- na.omit(", dataSelected, ")\n")
} else {},
if(js.prepare && scaleValues){
R.comment("Standardizing values")
echo("\t", dataSelected, " <- scale(", dataSelected, ")\n")
} else {},
linebreaks=TRUE
)
)
# print selected subsets, if needed
js.prt.subset <- js(
if(js.frm.subset && js.varsSelected != ""){
echo("\n")
rk.JS.header("Subset of variables included the analysis", level=3)
echo("rk.print(list(\"", js.varsSelected, "\"))\n\n")
} else {},
level=3
)
############
## k-means
############
# temporarlily replace dataSelected to exclude dist objects
dataSelectedNodistbackup <- dataSelected
dataSelected <- rk.XML.varslot(
label="Data (data.frame or matrix)",
source=data,
classes=c("data.frame", "matrix"),
required=TRUE,
id.name="dataSelected"
)
numClust <- rk.XML.spinbox(
label="Number of clusters to extract",
min=2,
real=FALSE,
id.name="numClust"
)
kMethod <- rk.XML.dropdown(label="Algorithm", options=list(
"Hartigan & Wong"=c(val="Hartigan-Wong", chk=TRUE),
"Lloyd"=c(val="Lloyd"),
"Forgy"=c(val="Forgy"),
"MacQueen"=c(val="MacQueen")
),
id.name="kMethod"
)
kMaxIter <- rk.XML.spinbox(
label="Maximum number of iterations",
min=1,
initial=10,
real=FALSE,
id.name="kMaxIter"
)
numStart <- rk.XML.spinbox(
label="Initial random set of centers",
min=1,
initial=1,
real=FALSE,
id.name="numStart"
)
kSaveResults <- rk.XML.saveobj("Save results to workspace", initial="clust.k.result", id.name="kSaveResults")
# plot results
plotClustCenters <- rk.XML.cbox("Plot cluster centers", chk=TRUE, id.name="plotClustCenters")
clust.plotk.preview <- rk.XML.preview()
tab.k.data <- rk.XML.row(
data,
rk.XML.col(
dataSelected,
useSubset,
dataPreparation,
rk.XML.stretch(),
kSaveResults
),
rk.XML.col(
rk.XML.frame(numClust),
rk.XML.stretch(),
rk.XML.frame(
kMethod,
kMaxIter,
numStart,
label="Advanced options"),
kPlotResults <- rk.XML.frame(
plotClustCenters,
generic.plot.options,
clust.plotk.preview,
label="Plot results",
checkable=TRUE,
chk=TRUE,
id.name="kPlotResults"
)
)
)
clust.k.full.dialog <- rk.XML.dialog(
tab.k.data,
label="Cluster analysis: K-means partitioning")
lgc.sect.k <- rk.XML.logic(
lgc.current.object,
lgc.data.from.selection,
gov.data,
lgc.enable.selected,
lgc.df.script
)
## JavaScript
clust.k.js.calc <- rk.paste.JS(
js.data.preparation,
echo("\tclust.k.result <- kmeans("),
js(
if(dataSelected){
echo("\n\t\tx=", dataSelected)
} else {}
),
echo(",\n\t\tcenters=", numClust),
js(
if(kMethod != "Hartigan-Wong"){
echo(",\n\t\talgorithm=\"", kMethod,"\"")
} else {},
if(kMaxIter != 10){
echo(",\n\t\titer.max=", kMaxIter)
} else {},
if(numStart != 1){
echo(",\n\t\tnstart=", numStart)
} else {},
linebreaks=TRUE
),
echo("\n\t)\n\n")
)
clust.k.js.plot <- rk.paste.JS(
js.plotk.dend <- rk.JS.vars(kPlotResults, modifiers="checked"),
js.frm.subset,
js.varsSelected,
js(
if(js.plotk.dend){
echo("\n")
rk.paste.JS.graph(
js(
echo("\t\tplot(", dataSelected,",\n\t\t\tcol=clust.k.result$cluster"),
if(id("!", generic.plot.options, ".match(/main\\s*=/)")){
echo(",\n\t\t\tmain=\"K-means partitioning\"")
} else {},
if(id("!", generic.plot.options, ".match(/sub\\s*=/)")){
echo(",\n\t\t\tsub=\"Grouped into ", numClust, " clusters by the ", kMethod, " algorithm\"")
} else {},
# generic plot options go here
id("echo(", generic.plot.options, ".replace(/, /g, \",\\n\\t\\t\\t\"));"),
echo(")"),
if(plotClustCenters){
echo("\n\t\tpoints(clust.k.result$centers, col=1:", numClust, ", pch=8, cex=2)")
} else {},
level=3
),
plotOpts=generic.plot.options,
level=3
)
},
if("!is_preview"){
echo("\nrk.print(clust.k.result)\n")
js.prt.subset
}
)
)
# revert dataSelected from backup
dataSelected <- dataSelectedNodistbackup
############
## hierarchical
############
hSaveResults <- rk.XML.saveobj("Save results to workspace", initial="clust.h.result", id.name="hSaveResults")
# dendrogram
clusterBorder <- rk.XML.spinbox(
label="Draw border around clusters (1 for none)",
min=1,
initial=1,
real=FALSE,
id.name="clusterBorder"
)
hUnit <- rk.XML.cbox("Plot splits at equally-spaced heights (not object height)", chk=FALSE, id.name="hUnit")
hHang <- rk.XML.spinbox(
label="Fraction of height by which labels should hang below plot",
min=0,
initial=0.1,
real=TRUE,
id.name="hHang"
)
hMinHeight <- rk.XML.spinbox(
label="Minimum height (suppress details below)",
min=0,
initial=0,
real=TRUE,
id.name="hMinHeight"
)
clust.dend.preview <- rk.XML.preview()
tab.data <- rk.XML.row(
data,
rk.XML.col(
dataSelected,
useSubset,
dataPreparation,
rk.XML.stretch(),
hSaveResults
),
rk.XML.col(
clust.h.frame.dist,
rk.XML.frame(clustMethod, label="Clustering"),
rk.XML.stretch(),
hDendrogram <- rk.XML.frame(
clusterBorder,
hHang,
hMinHeight,
rk.XML.frame(hUnit),
generic.plot.options,
clust.dend.preview,
label="Draw dendrogram",
checkable=TRUE,
chk=TRUE,
id.name="hDendrogram"
)
)
)
clust.h.full.dialog <- rk.XML.dialog(
tab.data,
label="Cluster analysis: Hierarchical")
## logic section
lgc.sect.h <- rk.XML.logic(
lgc.current.object,
lgc.data.from.selection,
gov.data,
lgc.enable.selected,
lgc.df.script,
CA.gov.dist <- rk.XML.convert(sources=list(string=distMethod), mode=c(equals="minkowski")),
rk.XML.connect(governor=CA.gov.dist, client=powerMinkowski, set="enabled"),
rk.XML.set(generic.plot.options, set="allow_type", to=FALSE),
rk.XML.set(generic.plot.options, set="axistypes.visible", to=FALSE),
rk.XML.set(generic.plot.options, set="scale.visible", to=FALSE),
lgc.isntDistData
)
## JavaScript
clust.h.js.calc <- rk.paste.JS(
# js.varsSelected,
js.data.preparation,
js.prepare,
js(
if(js.prepare){
R.comment("Compute distance matrix")
echo("\tclust.h.distances <- dist(")
if(dataSelected){
echo("\n\t\tx=", dataSelected)
} else {}
echo(",\n\t\tmethod=\"", distMethod, "\"")
if(distMethod == "minkowski"){
echo(",\n\t\tp=", powerMinkowski)
} else {}
echo("\n\t)\n")
R.comment("Hierarchical CA")
echo("\tclust.h.result <- hclust(\n\t\td=clust.h.distances")
echo(",\n\t\tmethod=\"", clustMethod, "\"")
echo("\n\t)\n\n")
} else {
R.comment("Hierarchical CA")
echo("\tclust.h.result <- hclust(")
if(dataSelected){
echo("\n\t\td=", dataSelected)
} else {}
echo(",\n\t\tmethod=\"", clustMethod, "\"")
echo("\n\t)\n\n")
}
)
)
clust.h.js.dend <- rk.paste.JS(
js.ploth.dend <- rk.JS.vars(hDendrogram, modifiers="checked"),
js.frm.subset,
js.varsSelected,
js.prepare,
js(
if(js.ploth.dend){
echo("\n")
rk.paste.JS.graph(
js(
if(id("!", generic.plot.options, ".match(/sub\\s*=/)") && !js.prepare){
echo("\t\t# extract distance computation method from dist object\n\t\tdistance.computation <- attr(", dataSelected, ", \"method\")\n")
} else {},
if(hMinHeight != 0){
echo("\t\t# set minimum height\n\t\tclust.h.result$height <- pmax(clust.h.result$height, ", hMinHeight, ")\n")
} else {},
if(hUnit){
echo("\t\t# set equally spaced heights\n\t\tclust.h.result$height <- rank(clust.h.result$height)\n")
} else {},
echo("\t\tplot(clust.h.result"),
if(id("!", generic.plot.options, ".match(/main\\s*=/)")){
echo(",\n\t\t\tmain=\"Cluster dendrogram\"")
} else {},
if(id("!", generic.plot.options, ".match(/sub\\s*=/)")){
if(js.prepare){
echo(",\n\t\t\tsub=\"Distance computation: ", distMethod, ", agglomeration method: ",clustMethod,"\"")
} else {
echo(",\n\t\t\tsub=paste(\"Distance computation: \", distance.computation, \", agglomeration method: ",clustMethod,"\", sep=\"\")")
}
} else {},
if(id("!", generic.plot.options, ".match(/xlab\\s*=/)")){
echo(",\n\t\t\txlab=\"Data: ", dataSelected, "\"")
} else {},
if(hHang != 0.1){
echo(",\n\t\t\thang=", hHang)
} else {},
# generic plot options go here
id("echo(", generic.plot.options, ".replace(/, /g, \",\\n\\t\\t\\t\"));"),
echo(")"),
if(clusterBorder > 1){
echo("\n\t\trect.hclust(clust.h.result, k=", clusterBorder, ", border=\"red\")")
} else {},
level=3
),
plotOpts=generic.plot.options,
level=3
)
} else {},
if("!is_preview"){
echo("\nrk.print(clust.h.result)\n")
js.prt.subset
} else {}
)
)
## make a whole component
clust.h.component <- rk.plugin.component("Hierarchical CA",
xml=list(
dialog=clust.h.full.dialog,
logic=lgc.sect.h),
js=list(
# require="fcp",
calculate=clust.h.js.calc,
printout=clust.h.js.dend
),
guess.getter=guess.getter,
hierarchy=list("analysis", "Cluster analysis"),
create=c("xml", "js"),
gen.info="$SRC/inst/rkward/rkwarddev_CA_plugin_script.R")
#############
## model based CA
#############
# temporarlily replace dataSelected to exclude dist objects
dataSelectedNodistbackup <- dataSelected
dataSelected <- rk.XML.varslot(
label="Data (data.frame or matrix)",
source=data,
classes=c("data.frame", "matrix"),
required=TRUE,
id.name="dataSelected"
)
mNumClust <- rk.XML.spinbox(
label="Max number of clusters to test",
min=2,
initial=9,
real=FALSE,
id.name="mNumClust"
)
mSaveResults <- rk.XML.saveobj("Save results to workspace", initial="clust.m.result", id.name="mSaveResults")
# dendrogram
mPlotType <- rk.XML.radio("Plot type",
options=list(
"BIC"=c(val="BIC", chk=TRUE),
"Classification"=c(val="classification"),
"Classification uncertainty"=c(val="uncertainty"),
"Density"=c(val="density")
),
id.name="mPlotType"
)
clust.plotm.preview <- rk.XML.preview()
tab.m.data <- rk.XML.row(
data,
rk.XML.col(
dataSelected,
useSubset,
dataPreparation,
rk.XML.stretch(),
mSaveResults
),
rk.XML.col(
rk.XML.frame(
mNumClust,
label="Advanced options"),
clust.plotm.frame.plot <- rk.XML.frame(
mPlotType,
rk.XML.stretch(),
# generic.plot.options,
clust.plotm.preview,
label="Plot results", checkable=TRUE, chk=TRUE)
)
)
clust.m.full.dialog <- rk.XML.dialog(
tab.m.data,
label="Cluster analysis: Model based")
## logic section
lgc.sect.m <- rk.XML.logic(
lgc.current.object,
lgc.data.from.selection,
gov.data,
lgc.enable.selected,
lgc.df.script
)
## JavaScript
clust.m.js.calc <- rk.paste.JS(
js.data.preparation,
R.comment("Model based CA"),
echo("\tclust.m.result <- Mclust(data=", dataSelected),
js(
if(mNumClust != 9){
echo(",\n\t\tG=1:", mNumClust, "\n\t")
} else {}
),
echo(")\n\n")
)
clust.m.js.plot <- rk.paste.JS(
js.plotm.plot <- rk.JS.vars(clust.plotm.frame.plot, modifiers="checked"),
js.frm.subset,
js.varsSelected,
js(
if(js.plotm.plot){
echo("\n")
rk.paste.JS.graph(
js(
echo("\t\tplot(clust.m.result,\n\t\t\tdata=",dataSelected,
",\n\t\t\twhat=\"", mPlotType, "\""),
# # generic plot options go here
# id("echo(", generic.plot.options, ".replace(/, /g, \",\\n\\t\\t\\t\"));"),
echo(")"),
# plotOpts=generic.plot.options,
# printoutObj=generic.plot.options
level=3
),
level=3
)
} else {},
if("!is_preview"){
echo("\nrk.print(clust.m.result)\n")
js.prt.subset
} else {}
)
)
## make a whole component
clust.m.component <- rk.plugin.component("Model based CA",
xml=list(
dialog=clust.m.full.dialog,
logic=lgc.sect.m),
js=list(
require="mclust",
calculate=clust.m.js.calc,
printout=clust.m.js.plot
),
guess.getter=guess.getter,
hierarchy=list("analysis", "Cluster analysis"),
create=c("xml", "js"),
gen.info="$SRC/inst/rkward/rkwarddev_CA_plugin_script.R")
# revert dataSelected from backup
dataSelected <- dataSelectedNodistbackup
#############
## number of clusters
#############
nClustMethod <- rk.XML.radio("Method",
options=list(
"K-means total within sum of sqares"=c(val="kmeans"),
"Hiearchical clustering criterion (Inverse Scree)"=c(val="hclust", chk=TRUE)
),
id.name="nClustMethod"
)
nMaxClust <- rk.XML.spinbox(
label="Maximum number of clusters to exexamine",
min=2,
initial=15,
real=FALSE,
id.name="nMaxClust"
)
clust.num.preview <- rk.XML.preview()
clust.num.full.dialog <- rk.XML.dialog(
rk.XML.row(
data,
rk.XML.col(
dataSelected,
useSubset,
dataPreparation,
rk.XML.stretch(),
rk.XML.frame(generic.plot.options,
clust.num.preview, label="Plot options")),
rk.XML.col(
nMaxClust,
rk.XML.stretch(),
nClustMethod,
nDistMatrix <- rk.XML.frame(
distMethod, powerMinkowski,
label="Distance matrix",
id.name="nDistMatrix"
),
nClustering <- rk.XML.frame(
clustMethod,
label="Clustering",
id.name="nClustering"
)
)
), label="Cluster analysis: Determine number of clusters")
## logic section
lgc.sect.num <- rk.XML.logic(
lgc.current.object,
lgc.data.from.selection,
gov.data,
lgc.enable.selected,
# rewrite content lgc.df.script with additional actions
rk.comment(id("
gui.addChangeCommand(\"", dataSelected, ".available\", \"dataChanged()\");
// this function is called whenever the data was changed
dataChanged = function(){
var prepareFrame = \"true\";
var selectFrame = \"true\";
var thisObject = makeRObject(gui.getValue(\"", dataSelected, ".available\"));
if(thisObject.classes()){
if(!thisObject.isDataFrame()){
selectFrame = \"false\";
if(thisObject.classes().indexOf(\"dist\") != -1){
prepareFrame = \"false\";
gui.setValue(\"", nClustMethod, ".string\", \"hclust\");
} else {}
} else {}
} else {}
gui.setValue(\"", useSubset, ".enabled\", selectFrame);
gui.setValue(\"", dataPreparation, ".enabled\", prepareFrame);
}", js=FALSE)),
CA.gov.dist.num <- rk.XML.convert(sources=list(string=distMethod), mode=c(equals="minkowski")),
rk.XML.connect(governor=CA.gov.dist.num, client=powerMinkowski, set="enabled"),
lgc.isntDistData,
rk.XML.connect(governor=dataPreparation, get="enabled", client=nClustMethod, set="enabled"),
CA.gov.dist.num.type <- rk.XML.convert(sources=list(string=nClustMethod), mode=c(equals="hclust")),
CA.gov.dist.notDistData <- rk.XML.convert(sources=list(CA.gov.dist.num.type, enabled=dataPreparation), mode=c(and="")),
rk.XML.connect(governor=CA.gov.dist.notDistData, client=nDistMatrix, set="enabled"),
rk.XML.connect(governor=CA.gov.dist.num.type, client=nClustering, set="enabled")
)
## JavaScript
# plot of within groups sum of squares x number of clusters
# see http://www.statmethods.net/advstats/cluster.html
clust.num.js.calc <- rk.paste.JS(
js.data.preparation,
js.prepare,
js(
if(nClustMethod == "kmeans" && dataSelected){
echo("\t# Calculate within groups sum of squares",
"\n\tclust.wss <- (nrow(",dataSelected,")-1) * sum(apply(",dataSelected,", 2, var))\n",
"\tfor (i in 2:",nMaxClust,"){\n\t\tclust.wss[i] <- kmeans(",dataSelected,", centers=i)$tot.withinss\n\t}\n\n")
} else {},
if(nClustMethod == "hclust" && dataSelected){
echo("\t# Get clustering criterion")
if(js.prepare){
echo("\n\tclust.from <- nrow(",dataSelected,")-",nMaxClust,
"\n\tclust.to <- nrow(",dataSelected,")-1",
"\n\tclust.wss <- hclust(dist(",dataSelected,", method=\"", distMethod, "\"), method=\"",clustMethod,"\")$height[clust.from:clust.to]\n\n")
} else {
echo("\n\tclust.from <- attr(",dataSelected,", \"Size\")-",nMaxClust,
"\n\tclust.to <- attr(",dataSelected,", \"Size\")-1",
"\n\tclust.wss <- hclust(",dataSelected, ", method=\"",clustMethod,"\")$height[clust.from:clust.to]\n\n")
}
} else {}
)
)
clust.num.js.print <- rk.paste.JS(
js.frm.subset,
js.varsSelected,
js.prepare,
echo("\n"),
rk.paste.JS.graph(
js(
if(id("!", generic.plot.options, ".match(/sub\\s*=/) && !", js.prepare)){
echo("\t# extract distance computation method from dist object\n\tdistance.computation <- attr(", dataSelected, ", \"method\")\n\n")
} else {},
echo("\t\tplot(\n\t\t\t"),
if(nClustMethod == "kmeans" && js.prepare){
echo("1:",nMaxClust,",\n\t\t\tclust.wss")
if(id("!", generic.plot.options, ".match(/type\\s*=/)")){
echo(",\n\t\t\ttype=\"b\"")
} else {}
if(id("!", generic.plot.options, ".match(/xlab\\s*=/)")){
echo(",\n\t\t\txlab=\"Number of Clusters\"")
} else {}
if(id("!", generic.plot.options, ".match(/ylab\\s*=/)")){
echo(",\n\t\t\tylab=\"Within groups sum of squares\"")
} else {}
if(id("!", generic.plot.options, ".match(/main\\s*=/)")){
echo(",\n\t\t\tmain=\"Within sum of squares by clusters\"")
} else {}
if(id("!", generic.plot.options, ".match(/sub\\s*=/)")){
echo(",\n\t\t\tsub=\"Examined ", nMaxClust, " clusters using k-means partitioning\"")
} else {}
# generic plot options go here
id("echo(", generic.plot.options, ".replace(/, /g, \",\\n\\t\\t\\t\"));")
echo(")")
} else {},
if(nClustMethod == "hclust" || !js.prepare){
echo("clust.wss")
if(id("!", generic.plot.options, ".match(/type\\s*=/)")){
echo(",\n\t\t\ttype=\"b\"")
} else {}
if(id("!", generic.plot.options, ".match(/xlab\\s*=/)")){
echo(",\n\t\t\txlab=\"Number of Clusters\"")
} else {}
if(id("!", generic.plot.options, ".match(/ylab\\s*=/)")){
echo(",\n\t\t\tylab=\"Agglomeration criterion\"")
} else {}
if(id("!", generic.plot.options, ".match(/main\\s*=/)")){
echo(",\n\t\t\tmain=\"Inverse Scree plot\"")
} else {}
if(id("!", generic.plot.options, ".match(/sub\\s*=/)")){
if(js.prepare){
echo(",\n\t\t\tsub=\"Examined ", nMaxClust, " clusters (dist: ", distMethod, ", hclust: ",clustMethod,")\"")
} else {
echo(",\n\t\t\tsub=paste(\"Examined ", nMaxClust, " clusters (dist: \", distance.computation, \", hclust: ",clustMethod,")\", sep=\"\")")
}
} else {}
echo(",\n\t\t\txaxt=\"n\"")
# generic plot options go here
id("echo(", generic.plot.options, ".replace(/, /g, \",\\n\\t\\t\\t\"));")
echo(")",
"\n\t\taxis(1, at=1:",nMaxClust,", labels=",nMaxClust, ":1)")
} else {},
level=3
),
plotOpts=generic.plot.options,
level=3
),
js(
if("is_preview"){
js.prt.subset
} else {}
)
)
## make a whole component
clust.num.component <- rk.plugin.component("Determine number of clusters",
xml=list(
dialog=clust.num.full.dialog,
logic=lgc.sect.num),
js=list(
# require="fcp",
calculate=clust.num.js.calc,
printout=clust.num.js.print),
guess.getter=guess.getter,
hierarchy=list("plots", "Cluster analysis"),
create=c("xml", "js"),
gen.info="$SRC/inst/rkward/rkwarddev_CA_plugin_script.R")
#############
## if you run the following function call, files will be written to tempdir!
#############
# this is where it get's serious, that is, here all of the above is put together into one plugin
cluster.plugin.dir <<- rk.plugin.skeleton(
about.info,
path=output.dir,
guess.getter=guess.getter,
xml=list(
dialog=clust.k.full.dialog,
logic=lgc.sect.k),
js=list(results.header="Cluster analysis",
# require="fpc",
calculate=clust.k.js.calc,
printout=clust.k.js.plot),
pluginmap=list(name="K-means partitioning", hierarchy=list("analysis", "Cluster analysis")),
components=list(
clust.h.component,
clust.m.component,
clust.num.component),
dependencies=dependencies.info,
create=c("pmap", "xml", "js", "desc"),
overwrite=overwrite,
tests=FALSE,
# edit=TRUE,
load=TRUE,
# show=TRUE,
gen.info="$SRC/inst/rkward/rkwarddev_CA_plugin_script.R",
hints=FALSE)
if(isTRUE(update.translations)){
rk.updatePluginMessages(file.path(output.dir,"rk.ClusterAnalysis","inst","rkward","rk.ClusterAnalysis.pluginmap"))
} else {}
})
rkward-community/rk.ClusterAnalysis documentation built on May 9, 2022, 3:01 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
# the plugin code was generated by this script
# you should not change the plugin code directly, but this script
# note: this script only creates objects in your workspace,
# *EXCEPT* for the last call, see below.
require(rkwarddev)
rkwarddev.required("0.08-1")
local({
# set the output directory to overwrite the actual plugin
output.dir <- tempdir()
overwrite <- TRUE
# if you set guess.getters to TRUE, the resulting code will need RKWard >= 0.6.0
guess.getter <- TRUE
rk.set.indent(by=" ")
rk.set.empty.e(TRUE)
update.translations <- FALSE
about.info <- rk.XML.about(
name="rk.ClusterAnalysis",
author=c(
person(given="Meik", family="Michalke",
email="meik.michalke@hhu.de", role=c("aut","cre"))),
about=list(desc="RKWard GUI to conduct k-means, model based and hierarchical cluster analyses",
version="0.01-15", url="https://rkward.kde.org")
)
dependencies.info <- rk.XML.dependencies(
dependencies=list(rkward.min=ifelse(isTRUE(guess.getter), "0.6.0", "0.5.6")),
package=list(c(name="mclust"))
)
############
## re-used objects
############
# for plots
generic.plot.options <- rk.plotOptions()
# for data
data <- rk.XML.varselector(label="Select data", id.name="data")
dataSelected <- rk.XML.varslot(
label="Data (data.frame, matrix or dist)",
source=data,
classes=c("data.frame", "matrix", "dist"),
required=TRUE,
id.name="dataSelected"
)
dataSelectedNodist <- rk.XML.varslot(
label="Data (data.frame or matrix)",
source=data,
classes=c("data.frame", "matrix"),
required=TRUE,
id.name="dataSelectedNodist"
)
varsSelected <- rk.XML.varslot(
label="Selected variables",
source=data,
multi=TRUE,
id.name="varsSelected"
)
useSubset <- rk.XML.frame(
varsSelected,
label="Use only a subset of variables",
checkable=TRUE,
chk=FALSE,
id.name="useSubset"
)
# prepare data
omitNA <- rk.XML.cbox("Remove missing values", chk=TRUE, id.name="omitNA")
scaleValues <- rk.XML.cbox("Stadardize values", id.name="scaleValues")
dataPreparation <- rk.XML.frame(
omitNA,
scaleValues,
label="Data preparation"
)
distMethod <- rk.XML.dropdown(label="Computation method", options=list(
"Euclidean"=c(val="euclidean", chk=TRUE),
"Maximum"=c(val="maximum"),
"Manhattan (city block)"=c(val="manhattan"),
"Canberra"=c(val="canberra"),
"Binary"=c(val="binary"),
"Minkowski"=c(val="minkowski")
),
id.name="distMethod"
)
clustMethod <- rk.XML.dropdown(label="Agglomeration method", options=list(
"Ward (incl. clustering criterion)"=c(val="ward.D2"),
"Ward (without clustering criterion)"=c(val="ward.D"),
"Single linkage (nearest neighbor)"=c(val="single"),
"Complete linkage (furthest neighbor)"=c(val="complete", chk=TRUE),
"Average linkage (between groups linkage)"=c(val="average"),
"McQuitty"=c(val="mcquitty"),
"Median clustering"=c(val="median"),
"Centroid clustering"=c(val="centroid")
),
id.name="clustMethod"
)
powerMinkowski <- rk.XML.spinbox(
label="Power of Minkowski distance",
min=1,
initial=2,
real=FALSE,
id.name="powerMinkowski"
)
clust.h.frame.dist <- rk.XML.frame(distMethod, powerMinkowski, label="Distance matrix")
# for logic sections
lgc.df.script <- rk.comment(id("
gui.addChangeCommand(\"", dataSelected, ".available\", \"dataChanged()\");
// this function is called whenever the data was changed
dataChanged = function(){
var prepareFrame = \"true\";
var selectFrame = \"true\";
var thisObject = makeRObject(gui.getValue(\"", dataSelected, ".available\"));
if(thisObject.classes()){
if(!thisObject.isDataFrame()){
selectFrame = \"false\";
if(thisObject.classes().indexOf(\"dist\") != -1){
prepareFrame = \"false\";
} else {}
} else {}
} else {}
gui.setValue(\"", useSubset, ".enabled\", selectFrame);
gui.setValue(\"", dataPreparation, ".enabled\", prepareFrame);
}", js=FALSE))
lgc.current.object <- rk.XML.connect(governor="current_object", client=dataSelected, set="available")
lgc.data.from.selection <- rk.XML.connect(governor=dataSelected, client=data, get="available", set="root")
gov.data <- rk.XML.convert(sources=list(available=dataSelected), mode=c(notequals=""))
lgc.enable.selected <- rk.XML.connect(governor=gov.data, client=useSubset, set="enabled")
# disable distance computation, if dist object given
lgc.isntDistData <- rk.XML.connect(governor=dataPreparation, get="enabled", client=clust.h.frame.dist, set="enabled")
# for JavaScript
js.frm.subset <- rk.JS.vars(useSubset, modifiers="checked") # see if the frame is checked
js.varsSelected <- rk.JS.vars(varsSelected, modifiers="shortname", join="\\\", \\\"") # get selected vars
js.prepare <- rk.JS.vars(dataPreparation, modifiers="enabled") # see if data preparation is off
js.data.preparation <- rk.paste.JS(
js.frm.subset,
js.varsSelected,
js.prepare,
js(
if(js.frm.subset && js.varsSelected != ""){
R.comment("Use subset of variables")
echo("\t", dataSelected, " <- subset(",dataSelected,", select=c(\"", js.varsSelected, "\"))\n")
} else {},
if(js.prepare && omitNA){
R.comment("Listwise removal of missings")
echo("\t", dataSelected, " <- na.omit(", dataSelected, ")\n")
} else {},
if(js.prepare && scaleValues){
R.comment("Standardizing values")
echo("\t", dataSelected, " <- scale(", dataSelected, ")\n")
} else {},
linebreaks=TRUE
)
)
# print selected subsets, if needed
js.prt.subset <- js(
if(js.frm.subset && js.varsSelected != ""){
echo("\n")
rk.JS.header("Subset of variables included the analysis", level=3)
echo("rk.print(list(\"", js.varsSelected, "\"))\n\n")
} else {},
level=3
)
############
## k-means
############
# temporarlily replace dataSelected to exclude dist objects
dataSelectedNodistbackup <- dataSelected
dataSelected <- rk.XML.varslot(
label="Data (data.frame or matrix)",
source=data,
classes=c("data.frame", "matrix"),
required=TRUE,
id.name="dataSelected"
)
numClust <- rk.XML.spinbox(
label="Number of clusters to extract",
min=2,
real=FALSE,
id.name="numClust"
)
kMethod <- rk.XML.dropdown(label="Algorithm", options=list(
"Hartigan & Wong"=c(val="Hartigan-Wong", chk=TRUE),
"Lloyd"=c(val="Lloyd"),
"Forgy"=c(val="Forgy"),
"MacQueen"=c(val="MacQueen")
),
id.name="kMethod"
)
kMaxIter <- rk.XML.spinbox(
label="Maximum number of iterations",
min=1,
initial=10,
real=FALSE,
id.name="kMaxIter"
)
numStart <- rk.XML.spinbox(
label="Initial random set of centers",
min=1,
initial=1,
real=FALSE,
id.name="numStart"
)
kSaveResults <- rk.XML.saveobj("Save results to workspace", initial="clust.k.result", id.name="kSaveResults")
# plot results
plotClustCenters <- rk.XML.cbox("Plot cluster centers", chk=TRUE, id.name="plotClustCenters")
clust.plotk.preview <- rk.XML.preview()
tab.k.data <- rk.XML.row(
data,
rk.XML.col(
dataSelected,
useSubset,
dataPreparation,
rk.XML.stretch(),
kSaveResults
),
rk.XML.col(
rk.XML.frame(numClust),
rk.XML.stretch(),
rk.XML.frame(
kMethod,
kMaxIter,
numStart,
label="Advanced options"),
kPlotResults <- rk.XML.frame(
plotClustCenters,
generic.plot.options,
clust.plotk.preview,
label="Plot results",
checkable=TRUE,
chk=TRUE,
id.name="kPlotResults"
)
)
)
clust.k.full.dialog <- rk.XML.dialog(
tab.k.data,
label="Cluster analysis: K-means partitioning")
lgc.sect.k <- rk.XML.logic(
lgc.current.object,
lgc.data.from.selection,
gov.data,
lgc.enable.selected,
lgc.df.script
)
## JavaScript
clust.k.js.calc <- rk.paste.JS(
js.data.preparation,
echo("\tclust.k.result <- kmeans("),
js(
if(dataSelected){
echo("\n\t\tx=", dataSelected)
} else {}
),
echo(",\n\t\tcenters=", numClust),
js(
if(kMethod != "Hartigan-Wong"){
echo(",\n\t\talgorithm=\"", kMethod,"\"")
} else {},
if(kMaxIter != 10){
echo(",\n\t\titer.max=", kMaxIter)
} else {},
if(numStart != 1){
echo(",\n\t\tnstart=", numStart)
} else {},
linebreaks=TRUE
),
echo("\n\t)\n\n")
)
clust.k.js.plot <- rk.paste.JS(
js.plotk.dend <- rk.JS.vars(kPlotResults, modifiers="checked"),
js.frm.subset,
js.varsSelected,
js(
if(js.plotk.dend){
echo("\n")
rk.paste.JS.graph(
js(
echo("\t\tplot(", dataSelected,",\n\t\t\tcol=clust.k.result$cluster"),
if(id("!", generic.plot.options, ".match(/main\\s*=/)")){
echo(",\n\t\t\tmain=\"K-means partitioning\"")
} else {},
if(id("!", generic.plot.options, ".match(/sub\\s*=/)")){
echo(",\n\t\t\tsub=\"Grouped into ", numClust, " clusters by the ", kMethod, " algorithm\"")
} else {},
# generic plot options go here
id("echo(", generic.plot.options, ".replace(/, /g, \",\\n\\t\\t\\t\"));"),
echo(")"),
if(plotClustCenters){
echo("\n\t\tpoints(clust.k.result$centers, col=1:", numClust, ", pch=8, cex=2)")
} else {},
level=3
),
plotOpts=generic.plot.options,
level=3
)
},
if("!is_preview"){
echo("\nrk.print(clust.k.result)\n")
js.prt.subset
}
)
)
# revert dataSelected from backup
dataSelected <- dataSelectedNodistbackup
############
## hierarchical
############
hSaveResults <- rk.XML.saveobj("Save results to workspace", initial="clust.h.result", id.name="hSaveResults")
# dendrogram
clusterBorder <- rk.XML.spinbox(
label="Draw border around clusters (1 for none)",
min=1,
initial=1,
real=FALSE,
id.name="clusterBorder"
)
hUnit <- rk.XML.cbox("Plot splits at equally-spaced heights (not object height)", chk=FALSE, id.name="hUnit")
hHang <- rk.XML.spinbox(
label="Fraction of height by which labels should hang below plot",
min=0,
initial=0.1,
real=TRUE,
id.name="hHang"
)
hMinHeight <- rk.XML.spinbox(
label="Minimum height (suppress details below)",
min=0,
initial=0,
real=TRUE,
id.name="hMinHeight"
)
clust.dend.preview <- rk.XML.preview()
tab.data <- rk.XML.row(
data,
rk.XML.col(
dataSelected,
useSubset,
dataPreparation,
rk.XML.stretch(),
hSaveResults
),
rk.XML.col(
clust.h.frame.dist,
rk.XML.frame(clustMethod, label="Clustering"),
rk.XML.stretch(),
hDendrogram <- rk.XML.frame(
clusterBorder,
hHang,
hMinHeight,
rk.XML.frame(hUnit),
generic.plot.options,
clust.dend.preview,
label="Draw dendrogram",
checkable=TRUE,
chk=TRUE,
id.name="hDendrogram"
)
)
)
clust.h.full.dialog <- rk.XML.dialog(
tab.data,
label="Cluster analysis: Hierarchical")
## logic section
lgc.sect.h <- rk.XML.logic(
lgc.current.object,
lgc.data.from.selection,
gov.data,
lgc.enable.selected,
lgc.df.script,
CA.gov.dist <- rk.XML.convert(sources=list(string=distMethod), mode=c(equals="minkowski")),
rk.XML.connect(governor=CA.gov.dist, client=powerMinkowski, set="enabled"),
rk.XML.set(generic.plot.options, set="allow_type", to=FALSE),
rk.XML.set(generic.plot.options, set="axistypes.visible", to=FALSE),
rk.XML.set(generic.plot.options, set="scale.visible", to=FALSE),
lgc.isntDistData
)
## JavaScript
clust.h.js.calc <- rk.paste.JS(
# js.varsSelected,
js.data.preparation,
js.prepare,
js(
if(js.prepare){
R.comment("Compute distance matrix")
echo("\tclust.h.distances <- dist(")
if(dataSelected){
echo("\n\t\tx=", dataSelected)
} else {}
echo(",\n\t\tmethod=\"", distMethod, "\"")
if(distMethod == "minkowski"){
echo(",\n\t\tp=", powerMinkowski)
} else {}
echo("\n\t)\n")
R.comment("Hierarchical CA")
echo("\tclust.h.result <- hclust(\n\t\td=clust.h.distances")
echo(",\n\t\tmethod=\"", clustMethod, "\"")
echo("\n\t)\n\n")
} else {
R.comment("Hierarchical CA")
echo("\tclust.h.result <- hclust(")
if(dataSelected){
echo("\n\t\td=", dataSelected)
} else {}
echo(",\n\t\tmethod=\"", clustMethod, "\"")
echo("\n\t)\n\n")
}
)
)
clust.h.js.dend <- rk.paste.JS(
js.ploth.dend <- rk.JS.vars(hDendrogram, modifiers="checked"),
js.frm.subset,
js.varsSelected,
js.prepare,
js(
if(js.ploth.dend){
echo("\n")
rk.paste.JS.graph(
js(
if(id("!", generic.plot.options, ".match(/sub\\s*=/)") && !js.prepare){
echo("\t\t# extract distance computation method from dist object\n\t\tdistance.computation <- attr(", dataSelected, ", \"method\")\n")
} else {},
if(hMinHeight != 0){
echo("\t\t# set minimum height\n\t\tclust.h.result$height <- pmax(clust.h.result$height, ", hMinHeight, ")\n")
} else {},
if(hUnit){
echo("\t\t# set equally spaced heights\n\t\tclust.h.result$height <- rank(clust.h.result$height)\n")
} else {},
echo("\t\tplot(clust.h.result"),
if(id("!", generic.plot.options, ".match(/main\\s*=/)")){
echo(",\n\t\t\tmain=\"Cluster dendrogram\"")
} else {},
if(id("!", generic.plot.options, ".match(/sub\\s*=/)")){
if(js.prepare){
echo(",\n\t\t\tsub=\"Distance computation: ", distMethod, ", agglomeration method: ",clustMethod,"\"")
} else {
echo(",\n\t\t\tsub=paste(\"Distance computation: \", distance.computation, \", agglomeration method: ",clustMethod,"\", sep=\"\")")
}
} else {},
if(id("!", generic.plot.options, ".match(/xlab\\s*=/)")){
echo(",\n\t\t\txlab=\"Data: ", dataSelected, "\"")
} else {},
if(hHang != 0.1){
echo(",\n\t\t\thang=", hHang)
} else {},
# generic plot options go here
id("echo(", generic.plot.options, ".replace(/, /g, \",\\n\\t\\t\\t\"));"),
echo(")"),
if(clusterBorder > 1){
echo("\n\t\trect.hclust(clust.h.result, k=", clusterBorder, ", border=\"red\")")
} else {},
level=3
),
plotOpts=generic.plot.options,
level=3
)
} else {},
if("!is_preview"){
echo("\nrk.print(clust.h.result)\n")
js.prt.subset
} else {}
)
)
## make a whole component
clust.h.component <- rk.plugin.component("Hierarchical CA",
xml=list(
dialog=clust.h.full.dialog,
logic=lgc.sect.h),
js=list(
# require="fcp",
calculate=clust.h.js.calc,
printout=clust.h.js.dend
),
guess.getter=guess.getter,
hierarchy=list("analysis", "Cluster analysis"),
create=c("xml", "js"),
gen.info="$SRC/inst/rkward/rkwarddev_CA_plugin_script.R")
#############
## model based CA
#############
# temporarlily replace dataSelected to exclude dist objects
dataSelectedNodistbackup <- dataSelected
dataSelected <- rk.XML.varslot(
label="Data (data.frame or matrix)",
source=data,
classes=c("data.frame", "matrix"),
required=TRUE,
id.name="dataSelected"
)
mNumClust <- rk.XML.spinbox(
label="Max number of clusters to test",
min=2,
initial=9,
real=FALSE,
id.name="mNumClust"
)
mSaveResults <- rk.XML.saveobj("Save results to workspace", initial="clust.m.result", id.name="mSaveResults")
# dendrogram
mPlotType <- rk.XML.radio("Plot type",
options=list(
"BIC"=c(val="BIC", chk=TRUE),
"Classification"=c(val="classification"),
"Classification uncertainty"=c(val="uncertainty"),
"Density"=c(val="density")
),
id.name="mPlotType"
)
clust.plotm.preview <- rk.XML.preview()
tab.m.data <- rk.XML.row(
data,
rk.XML.col(
dataSelected,
useSubset,
dataPreparation,
rk.XML.stretch(),
mSaveResults
),
rk.XML.col(
rk.XML.frame(
mNumClust,
label="Advanced options"),
clust.plotm.frame.plot <- rk.XML.frame(
mPlotType,
rk.XML.stretch(),
# generic.plot.options,
clust.plotm.preview,
label="Plot results", checkable=TRUE, chk=TRUE)
)
)
clust.m.full.dialog <- rk.XML.dialog(
tab.m.data,
label="Cluster analysis: Model based")
## logic section
lgc.sect.m <- rk.XML.logic(
lgc.current.object,
lgc.data.from.selection,
gov.data,
lgc.enable.selected,
lgc.df.script
)
## JavaScript
clust.m.js.calc <- rk.paste.JS(
js.data.preparation,
R.comment("Model based CA"),
echo("\tclust.m.result <- Mclust(data=", dataSelected),
js(
if(mNumClust != 9){
echo(",\n\t\tG=1:", mNumClust, "\n\t")
} else {}
),
echo(")\n\n")
)
clust.m.js.plot <- rk.paste.JS(
js.plotm.plot <- rk.JS.vars(clust.plotm.frame.plot, modifiers="checked"),
js.frm.subset,
js.varsSelected,
js(
if(js.plotm.plot){
echo("\n")
rk.paste.JS.graph(
js(
echo("\t\tplot(clust.m.result,\n\t\t\tdata=",dataSelected,
",\n\t\t\twhat=\"", mPlotType, "\""),
# # generic plot options go here
# id("echo(", generic.plot.options, ".replace(/, /g, \",\\n\\t\\t\\t\"));"),
echo(")"),
# plotOpts=generic.plot.options,
# printoutObj=generic.plot.options
level=3
),
level=3
)
} else {},
if("!is_preview"){
echo("\nrk.print(clust.m.result)\n")
js.prt.subset
} else {}
)
)
## make a whole component
clust.m.component <- rk.plugin.component("Model based CA",
xml=list(
dialog=clust.m.full.dialog,
logic=lgc.sect.m),
js=list(
require="mclust",
calculate=clust.m.js.calc,
printout=clust.m.js.plot
),
guess.getter=guess.getter,
hierarchy=list("analysis", "Cluster analysis"),
create=c("xml", "js"),
gen.info="$SRC/inst/rkward/rkwarddev_CA_plugin_script.R")
# revert dataSelected from backup
dataSelected <- dataSelectedNodistbackup
#############
## number of clusters
#############
nClustMethod <- rk.XML.radio("Method",
options=list(
"K-means total within sum of sqares"=c(val="kmeans"),
"Hiearchical clustering criterion (Inverse Scree)"=c(val="hclust", chk=TRUE)
),
id.name="nClustMethod"
)
nMaxClust <- rk.XML.spinbox(
label="Maximum number of clusters to exexamine",
min=2,
initial=15,
real=FALSE,
id.name="nMaxClust"
)
clust.num.preview <- rk.XML.preview()
clust.num.full.dialog <- rk.XML.dialog(
rk.XML.row(
data,
rk.XML.col(
dataSelected,
useSubset,
dataPreparation,
rk.XML.stretch(),
rk.XML.frame(generic.plot.options,
clust.num.preview, label="Plot options")),
rk.XML.col(
nMaxClust,
rk.XML.stretch(),
nClustMethod,
nDistMatrix <- rk.XML.frame(
distMethod, powerMinkowski,
label="Distance matrix",
id.name="nDistMatrix"
),
nClustering <- rk.XML.frame(
clustMethod,
label="Clustering",
id.name="nClustering"
)
)
), label="Cluster analysis: Determine number of clusters")
## logic section
lgc.sect.num <- rk.XML.logic(
lgc.current.object,
lgc.data.from.selection,
gov.data,
lgc.enable.selected,
# rewrite content lgc.df.script with additional actions
rk.comment(id("
gui.addChangeCommand(\"", dataSelected, ".available\", \"dataChanged()\");
// this function is called whenever the data was changed
dataChanged = function(){
var prepareFrame = \"true\";
var selectFrame = \"true\";
var thisObject = makeRObject(gui.getValue(\"", dataSelected, ".available\"));
if(thisObject.classes()){
if(!thisObject.isDataFrame()){
selectFrame = \"false\";
if(thisObject.classes().indexOf(\"dist\") != -1){
prepareFrame = \"false\";
gui.setValue(\"", nClustMethod, ".string\", \"hclust\");
} else {}
} else {}
} else {}
gui.setValue(\"", useSubset, ".enabled\", selectFrame);
gui.setValue(\"", dataPreparation, ".enabled\", prepareFrame);
}", js=FALSE)),
CA.gov.dist.num <- rk.XML.convert(sources=list(string=distMethod), mode=c(equals="minkowski")),
rk.XML.connect(governor=CA.gov.dist.num, client=powerMinkowski, set="enabled"),
lgc.isntDistData,
rk.XML.connect(governor=dataPreparation, get="enabled", client=nClustMethod, set="enabled"),
CA.gov.dist.num.type <- rk.XML.convert(sources=list(string=nClustMethod), mode=c(equals="hclust")),
CA.gov.dist.notDistData <- rk.XML.convert(sources=list(CA.gov.dist.num.type, enabled=dataPreparation), mode=c(and="")),
rk.XML.connect(governor=CA.gov.dist.notDistData, client=nDistMatrix, set="enabled"),
rk.XML.connect(governor=CA.gov.dist.num.type, client=nClustering, set="enabled")
)
## JavaScript
# plot of within groups sum of squares x number of clusters
# see http://www.statmethods.net/advstats/cluster.html
clust.num.js.calc <- rk.paste.JS(
js.data.preparation,
js.prepare,
js(
if(nClustMethod == "kmeans" && dataSelected){
echo("\t# Calculate within groups sum of squares",
"\n\tclust.wss <- (nrow(",dataSelected,")-1) * sum(apply(",dataSelected,", 2, var))\n",
"\tfor (i in 2:",nMaxClust,"){\n\t\tclust.wss[i] <- kmeans(",dataSelected,", centers=i)$tot.withinss\n\t}\n\n")
} else {},
if(nClustMethod == "hclust" && dataSelected){
echo("\t# Get clustering criterion")
if(js.prepare){
echo("\n\tclust.from <- nrow(",dataSelected,")-",nMaxClust,
"\n\tclust.to <- nrow(",dataSelected,")-1",
"\n\tclust.wss <- hclust(dist(",dataSelected,", method=\"", distMethod, "\"), method=\"",clustMethod,"\")$height[clust.from:clust.to]\n\n")
} else {
echo("\n\tclust.from <- attr(",dataSelected,", \"Size\")-",nMaxClust,
"\n\tclust.to <- attr(",dataSelected,", \"Size\")-1",
"\n\tclust.wss <- hclust(",dataSelected, ", method=\"",clustMethod,"\")$height[clust.from:clust.to]\n\n")
}
} else {}
)
)
clust.num.js.print <- rk.paste.JS(
js.frm.subset,
js.varsSelected,
js.prepare,
echo("\n"),
rk.paste.JS.graph(
js(
if(id("!", generic.plot.options, ".match(/sub\\s*=/) && !", js.prepare)){
echo("\t# extract distance computation method from dist object\n\tdistance.computation <- attr(", dataSelected, ", \"method\")\n\n")
} else {},
echo("\t\tplot(\n\t\t\t"),
if(nClustMethod == "kmeans" && js.prepare){
echo("1:",nMaxClust,",\n\t\t\tclust.wss")
if(id("!", generic.plot.options, ".match(/type\\s*=/)")){
echo(",\n\t\t\ttype=\"b\"")
} else {}
if(id("!", generic.plot.options, ".match(/xlab\\s*=/)")){
echo(",\n\t\t\txlab=\"Number of Clusters\"")
} else {}
if(id("!", generic.plot.options, ".match(/ylab\\s*=/)")){
echo(",\n\t\t\tylab=\"Within groups sum of squares\"")
} else {}
if(id("!", generic.plot.options, ".match(/main\\s*=/)")){
echo(",\n\t\t\tmain=\"Within sum of squares by clusters\"")
} else {}
if(id("!", generic.plot.options, ".match(/sub\\s*=/)")){
echo(",\n\t\t\tsub=\"Examined ", nMaxClust, " clusters using k-means partitioning\"")
} else {}
# generic plot options go here
id("echo(", generic.plot.options, ".replace(/, /g, \",\\n\\t\\t\\t\"));")
echo(")")
} else {},
if(nClustMethod == "hclust" || !js.prepare){
echo("clust.wss")
if(id("!", generic.plot.options, ".match(/type\\s*=/)")){
echo(",\n\t\t\ttype=\"b\"")
} else {}
if(id("!", generic.plot.options, ".match(/xlab\\s*=/)")){
echo(",\n\t\t\txlab=\"Number of Clusters\"")
} else {}
if(id("!", generic.plot.options, ".match(/ylab\\s*=/)")){
echo(",\n\t\t\tylab=\"Agglomeration criterion\"")
} else {}
if(id("!", generic.plot.options, ".match(/main\\s*=/)")){
echo(",\n\t\t\tmain=\"Inverse Scree plot\"")
} else {}
if(id("!", generic.plot.options, ".match(/sub\\s*=/)")){
if(js.prepare){
echo(",\n\t\t\tsub=\"Examined ", nMaxClust, " clusters (dist: ", distMethod, ", hclust: ",clustMethod,")\"")
} else {
echo(",\n\t\t\tsub=paste(\"Examined ", nMaxClust, " clusters (dist: \", distance.computation, \", hclust: ",clustMethod,")\", sep=\"\")")
}
} else {}
echo(",\n\t\t\txaxt=\"n\"")
# generic plot options go here
id("echo(", generic.plot.options, ".replace(/, /g, \",\\n\\t\\t\\t\"));")
echo(")",
"\n\t\taxis(1, at=1:",nMaxClust,", labels=",nMaxClust, ":1)")
} else {},
level=3
),
plotOpts=generic.plot.options,
level=3
),
js(
if("is_preview"){
js.prt.subset
} else {}
)
)
## make a whole component
clust.num.component <- rk.plugin.component("Determine number of clusters",
xml=list(
dialog=clust.num.full.dialog,
logic=lgc.sect.num),
js=list(
# require="fcp",
calculate=clust.num.js.calc,
printout=clust.num.js.print),
guess.getter=guess.getter,
hierarchy=list("plots", "Cluster analysis"),
create=c("xml", "js"),
gen.info="$SRC/inst/rkward/rkwarddev_CA_plugin_script.R")
#############
## if you run the following function call, files will be written to tempdir!
#############
# this is where it get's serious, that is, here all of the above is put together into one plugin
cluster.plugin.dir <<- rk.plugin.skeleton(
about.info,
path=output.dir,
guess.getter=guess.getter,
xml=list(
dialog=clust.k.full.dialog,
logic=lgc.sect.k),
js=list(results.header="Cluster analysis",
# require="fpc",
calculate=clust.k.js.calc,
printout=clust.k.js.plot),
pluginmap=list(name="K-means partitioning", hierarchy=list("analysis", "Cluster analysis")),
components=list(
clust.h.component,
clust.m.component,
clust.num.component),
dependencies=dependencies.info,
create=c("pmap", "xml", "js", "desc"),
overwrite=overwrite,
tests=FALSE,
# edit=TRUE,
load=TRUE,
# show=TRUE,
gen.info="$SRC/inst/rkward/rkwarddev_CA_plugin_script.R",
hints=FALSE)
if(isTRUE(update.translations)){
rk.updatePluginMessages(file.path(output.dir,"rk.ClusterAnalysis","inst","rkward","rk.ClusterAnalysis.pluginmap"))
} else {}
})
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.