inst/rkward/rkwarddev_MDS_plugin_script.R

In rkward-community/rk.MultidimensionalScaling: RKWard GUI for multidimensional scaling

# 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 <- TRUE

about.info <- rk.XML.about(
  name="rk.MultidimensionalScaling",
  author=c(
    person(given="Meik", family="Michalke",
      email="meik.michalke@hhu.de", role=c("aut","cre"))),
  about=list(desc="RKWard GUI for multidimensional scaling",
    version="0.01-12", 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="MASS"))
)

############
## prepare data
############
omitNA <- rk.XML.cbox("Remove missing values", value="true", chk=TRUE, id.name="omitNA")
scale <- rk.XML.cbox("Stadardize values", value="true", id.name="scale")
frameDataPrep <- rk.XML.frame(
  rk.XML.row(
    rk.XML.col(omitNA),
    rk.XML.col(scale)
  ),
  label="Data preparation",
  id.name="frameDataPrep")

genPlotOptions <- rk.plotOptions(id.name="genPlotOptions")
textCol <- rk.plotOptions(embed="rkward::color_chooser", button=FALSE, id.name="textCol")

############
## classical multidimensional scaling
############
varSelect <- rk.XML.varselector(label="Select data", id.name="varSelect")
data <- rk.XML.varslot(label="Data (data.frame, matrix or dist)", source=varSelect, classes=c("data.frame", "matrix", "dist"), required=TRUE, id.name="data")
selectedVars <- rk.XML.varslot(label="Selected variables", source=varSelect, multi=TRUE, id.name="selectedVars")
frameSelectedVars <- rk.XML.frame(selectedVars, label="Use only a subset of variables", checkable=TRUE, chk=FALSE, id.name="frameSelectedVars")

ndim <- rk.XML.spinbox(label="Maximum dimensions", min=2, real=FALSE, id.name="ndim")

scaleMethod <- rk.XML.dropdown(label="Scaling method", options=list(
    "Classical (metric)"=c(val="cmdscale", chk=TRUE),
    "Kruskal (non-metric)"=c(val="isoMDS"),
    "Sammon (non-linear)"=c(val="sammon")
  ),
  id.name="scaleMethod"
)

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"
)
pwrMinkowski <- rk.XML.spinbox(label="Power of Minkowski distance", min=1, initial=2, real=FALSE, id.name="pwrMinkowski")

maxIter <- rk.XML.spinbox(label="Maximum number of iterations", min=1, initial=50, real=FALSE, id.name="maxIter")
#mds.spin.nstart <- rk.XML.spinbox(label="Initial random set of centers", min=1, initial=1, real=FALSE)

saveResults <- rk.XML.saveobj("Save results to workspace", initial="mds.result", id.name="saveResults")

# plot results
plotResults <- rk.XML.cbox("Plot results", val="true", chk=TRUE, id.name="plotResults")
textSize <- rk.XML.spinbox("Text size", initial=0.8, id.name="textSize")
textPos <- rk.XML.dropdown(label="Text position", options=list(
    "Instead of point"=c(val=0),
    "Below point"=c(val=1, chk=TRUE),
    "Left to point"=c(val=2),
    "Above point"=c(val=3),
    "Right to point"=c(val=4)
  ),
  id.name="textPos"
)
framePlotLabels <- rk.XML.frame(
  textCol,
  textSize,
  textPos,
  label="Plot labels (from row names of data)",
  checkable=TRUE,
  chk=TRUE,
  id.name="framePlotLabels"
)

mds.plot.preview <- rk.XML.preview()

tab.mds.data <- rk.XML.row(
    varSelect,
    rk.XML.col(
      data,
      frameSelectedVars,
      frameDataPrep,
      rk.XML.stretch(),
      saveResults
    ),
    rk.XML.col(
      rk.XML.frame(ndim),
      rk.XML.stretch(),
      mds.frame.dist <- rk.XML.frame(distMethod, pwrMinkowski, label="Distance matrix"),
      rk.XML.frame(
        scaleMethod,
        rk.XML.row(
          maxIter
#           rk.XML.col(maxIter),
#           rk.XML.col(mds.spin.nstart)
        ),
        plotResults,
        label="Advanced options")
    )
  )

tab.mds.plot <- rk.XML.row(
    rk.XML.col(
      framePlotLabels,
      rk.XML.stretch(),
      genPlotOptions,
      mds.plot.preview)
  )

mds.full.dialog <- rk.XML.dialog(
  rk.XML.tabbook(tabs=list(
    "Data"=tab.mds.data,
    "Plot"=tab.mds.plot
  )),
  label="Multidimensional scaling")

lgc.sect.mds <- rk.XML.logic(
    lgc.current.object <- rk.XML.connect(governor="current_object", client=data, set="available"),
    lgc.data.from.selection <- rk.XML.connect(governor=data, client=varSelect, get="available", set="root"),
    gov.data <- rk.XML.convert(sources=list(available=data), mode=c(notequals="")),
    lgc.enable.selected <- rk.XML.connect(governor=gov.data, client=frameSelectedVars, set="enabled"),
  lgc.df.script <- rk.comment(id("
    gui.addChangeCommand(", idq(data, modifiers="available", js=FALSE), ", \"dataChanged()\");
    // this function is called whenever the data was changed
    dataChanged = function(){
        var prepareFrame = \"true\";
        var selectFrame = \"true\";
        var thisObject = makeRObject(gui.getValue(", idq(data, modifiers="available", js=FALSE), "));
        if(thisObject.classes()){
          if(!thisObject.isDataFrame()){
            selectFrame = \"false\";
            if(thisObject.classes().indexOf(\"dist\") != -1){
              prepareFrame = \"false\";
            } else {}
          } else {}
        } else {}
        gui.setValue(", idq(frameSelectedVars, modifiers="enabled", js=FALSE), ", selectFrame);
        gui.setValue(", idq(frameDataPrep, modifiers="enabled", js=FALSE), ", prepareFrame);
      }", js=FALSE)),
  MDS.gov.dist <- rk.XML.convert(sources=list(string=distMethod), mode=c(equals="minkowski")),
  rk.XML.connect(governor=MDS.gov.dist, client=pwrMinkowski, set="enabled"),
  rk.XML.connect(governor=plotResults, client=tab.mds.plot, set="enabled"),
  MDS.gov.meth <- rk.XML.convert(sources=list(string=scaleMethod), mode=c(notequals="cmdscale")),
  rk.XML.connect(governor=MDS.gov.meth, client=maxIter, set="enabled"),
  # disable distance computation, if dist object given
  lgc.isntDistData <- rk.XML.connect(governor=frameDataPrep, get="enabled", client=mds.frame.dist, set="enabled"),
  # set label text color to red
  rk.XML.set(textCol, set="color.string", to="red")
)

## JavaScript
js.frm.subset <- rk.JS.vars(frameSelectedVars, modifiers="checked") # see if the frame is checked
js.selectedVars <- rk.JS.vars(selectedVars, modifiers="shortname", join="\\\", \\\"") # get selected vars
js.prepare <- rk.JS.vars(frameDataPrep, modifiers="enabled") # see if data preparation is off

js.global.vars <- list(js.frm.subset, js.selectedVars, js.prepare)

mds.js.calc <- rk.paste.JS(
  js.frm.subset, # see if the frame is checked
  js.selectedVars, # get selected vars
  js.prepare, # see if data preparation is off
  js(
    if(js.frm.subset && js.selectedVars != ""){
      R.comment("Use subset of variables")
      echo("\t", data, " <- subset(",data,", select=c(\"", js.selectedVars, "\"))\n")
    },
    if(js.prepare && omitNA){
      R.comment("Listwise removal of missings")
      echo("\t", data, " <- na.omit(", data, ")\n")
    },
    if(js.prepare && scale){
      R.comment("Standardizing values")
      echo("\t", data, " <- scale(", data, ")\n")
    }
  ),
  js(
    if(js.prepare){
      R.comment("Compute distance matrix")
      echo("\tmds.distances <- dist(")
      if(data){
        echo("\n\t\tx=", data)
      } else {}
      echo(",\n\t\tmethod=\"", distMethod, "\"")
      if(distMethod == "minkowski"){
        echo(",\n\t\tp=", pwrMinkowski)
      } else {}
      echo("\n\t)\n")
      R.comment("The actual multidimensional scaling")
      echo("\tmds.result <- ", scaleMethod,"(")
      if(data){
        echo("\n\t\td=mds.distances")
      } else {}
      echo(",\n\t\tk=", ndim)
      if(scaleMethod == "isoMDS"){
        echo(",\n\t\tmaxit=", maxIter)
      } else if(scaleMethod == "sammon"){
          echo(",\n\t\tniter=", maxIter)
      } else {}
      echo("\n\t)\n\n")
    } else {
      R.comment("The actual multidimensional scaling")
      echo("\tmds.result <- ", scaleMethod,"(")
      if(data){
        echo("\n\t\td=", data)
      }
      echo(",\n\t\tk=", ndim)
      if(scaleMethod == "isoMDS"){
        echo(",\n\t\tmaxit=", maxIter)
      } else if(scaleMethod == "sammon"){
        echo(",\n\t\tniter=", maxIter)
      } else {}
      echo("\n\t)\n\n")
    }
  )
)

mds.js.plot <- rk.paste.JS(
  js.frm.labels <- rk.JS.vars(framePlotLabels, modifiers="checked"),
  js(
    if(plotResults){
      echo("\n")
      rk.paste.JS(textCol, level=1)
      rk.paste.JS.graph(
        rk.comment("label text color:"),
        echo("\t\tplot(mds.result"),
        js(
          if(scaleMethod == "isoMDS" || scaleMethod == "sammon"){
            echo("[[\"points\"]]")
          } else {},
          if(id("!", genPlotOptions, ".match(/main\\s*=/)")){
            echo(",\n\t\t\tmain=\"Multidimensional scaling\"")
          } else {},
          if(id("!", genPlotOptions, ".match(/sub\\s*=/)")){
            echo(",\n\t\t\tsub=\"Solution with ", ndim, " dimensions (", scaleMethod, ")\"")
          } else {},
          # turn off points if labels should replace them
          if(js.frm.labels && textPos == 0){
            echo(",\n\t\t\ttype=\"n\"")
          } else {},
          # generic plot options go here
          id("echo(", genPlotOptions, ".replace(/, /g, \",\\n\\t\\t\\t\"));"),
          echo(")"),
          if(js.frm.labels){
            echo("\n\t\ttext(mds.result")
            if(scaleMethod == "isoMDS" || scaleMethod == "sammon"){
              echo("[[\"points\"]],\n\t\t\trownames(mds.result[[\"points\"]])")
            } else {
              echo(",\n\t\t\trownames(mds.result)")
            }
            if(textSize != 1){
              echo(",\n\t\t\tcex=", textSize)
            } else {}
            if(textPos != 0){
              echo(",\n\t\t\tpos=", textPos)
            } else {}
            echo(textCol, ")")
          } else {},
          level=3
        ),
        plotOpts=genPlotOptions,
        level=3
      )
    } else {},
    if("!is_preview"){
      echo("\nrk.print(mds.result)\n")
      # print selected subsets, if needed
        if(js.frm.subset && js.selectedVars != ""){
          rk.JS.header("Subset of variables included the analysis", level=3)
          echo("rk.print(list(\"", js.selectedVars, "\"))\n\n")
        } else {}
    } else {}
  )
)



#############
## 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

mds.plugin.dir <<- rk.plugin.skeleton(
  about.info,
  path=output.dir,
  guess.getter=guess.getter,
  xml=list(
    dialog=mds.full.dialog,
    logic=lgc.sect.mds),
  js=list(results.header="Multidimensional scaling",
    globals=js.global.vars,
    require="MASS",
    calculate=mds.js.calc,
    printout=mds.js.plot),
  pluginmap=list(name="Multidimensional scaling", hierarchy=list("analysis")),
  dependencies=dependencies.info,
  create=c("pmap", "xml", "js", "desc"),
  overwrite=overwrite,
  tests=FALSE,
#  edit=TRUE,
  load=TRUE,
#  show=TRUE,
  hints=FALSE)

  if(isTRUE(update.translations)){
    rk.updatePluginMessages(file.path(output.dir,"rk.MultidimensionalScaling","inst","rkward","rk.MultidimensionalScaling.pluginmap"))
  } else {}
})