inst/rkward/rkwarddev_MPT_plugin_script.R

In rkward-community/rk.MPT: RKWard GUI for multinomial processing tree (MPT) models

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

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

about.info <- rk.XML.about(
	name="rk.MPT",
	author=c(
		person(given="Meik", family="Michalke",
			email="meik.michalke@hhu.de", role=c("aut","cre"))),
	about=list(desc="RKWard GUI for multinomial processing tree (MPT) models",
		version="0.01-3", 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="mpt"), c(name="MPTinR2"))
	package=list(c(name="MPTinR2"))
)

############
## MPTinR2
############
var.select <- rk.XML.varselector(label="Select data")

var.data <- rk.XML.varslot(label="Data (vector, matrix or data.frame)", source=var.select, classes=c("vector", "data.frame", "matrix"), required=TRUE)

MPTinR2.model.format <- rk.XML.dropdown(label="Model format", options=list(
		"Read model from file"=c(val="file", chk=TRUE),
		"Object of class bmpt.model or mpt.model"=c(val="object")
	))
MPTinR2.model.obj <- rk.XML.varslot(label="Model (bmpt.model or mpt.model)", source=var.select, classes=c("bmpt.model","mpt.model"), required=TRUE)
MPTinR2.model.file <- rk.XML.browser(label="Model file")
MPTinR2.model.type <- rk.XML.dropdown(label="Model type", options=list(
		"Easy"=c(val="easy", chk=TRUE),
		"EQN"=c(val="eqn"),
		"EQN2"=c(val="eqn2")
	))
MPTinR2.restr <- rk.XML.browser(label="Restrictions file", required=FALSE)

MPTinR2.optim <- rk.XML.spinbox(label="Number of optimization runs", min=1, initial=5, real=FALSE)
MPTinR2.optim.output <- rk.XML.cbox(label="Full optim results in output", value="true")
MPTinR2.conf <- rk.XML.spinbox(label="Confidence interval", min=0, max=100, initial=95, real=FALSE)

save.results <- rk.XML.saveobj("Save results to workspace", initial="MPTinR2.result")

# show options
MPTinR2.show.par <- rk.XML.cbox(label="Parameters", value="true", chk=TRUE)
MPTinR2.show.gof <- rk.XML.cbox(label="Goodness of fit", value="true", chk=TRUE)
MPTinR2.show.inf <- rk.XML.cbox(label="Information criteria", value="true", chk=TRUE)

tab.main <- rk.XML.row(
		var.select,
		rk.XML.col(
			var.data,
			MPTinR2.model.format,
			MPTinR2.model.obj,
			MPTinR2.model.file,
			MPTinR2.model.type,
			MPTinR2.restr,
			rk.XML.stretch(),
			save.results
		)
	)

tab.options <- rk.XML.row(
		rk.XML.col(
			rk.XML.frame(
				rk.XML.row(
					rk.XML.col(MPTinR2.optim),
					rk.XML.col(MPTinR2.conf)
				)
			),
			rk.XML.frame(
				MPTinR2.show.par,
				MPTinR2.show.gof,
				MPTinR2.show.inf,
				label="Show in output"),
			rk.XML.stretch()
		)
	)

MPTinR2.full.dialog <- rk.XML.dialog(
	rk.XML.tabbook(tabs=list(
		"Model"=tab.main,
		"Options"=tab.options
	)),
	label="Multinomial Processing Trees: MPTinR2")

## JavaScript
MPTinR2.js.calc <- rk.paste.JS(
	echo("\tMPTinR2.result <- fit.mpt("),
	ite(id(MPTinR2.model.format, " == \"file\" && ", MPTinR2.model.file), echo("\n\t\tmodel=\"", MPTinR2.model.file, "\"")),
	ite(id(MPTinR2.model.format, " == \"object\" && ", MPTinR2.model.obj), echo("\n\t\tmodel=", MPTinR2.model.obj)),
	ite(var.data, echo(",\n\t\tdata=", var.data)),
	ite(MPTinR2.restr, echo(",\n\t\trestrictions.filename=\"", MPTinR2.restr, "\"")),
	ite(id(MPTinR2.model.format, " == \"file\" && ", MPTinR2.model.type, " != \"easy\""), echo(",\n\t\tmodel.type=\"", MPTinR2.model.type, "\"")),
	ite(id(MPTinR2.conf, " != 95"), echo(",\n\t\tci=", MPTinR2.conf)),
	ite(id(MPTinR2.optim, " != 5"), echo(",\n\t\tn.optim=", MPTinR2.optim)),
	echo("\n\t)\n"),
	ite(MPTinR2.show.par, echo("\t# Get parameters\n\tMPTinR2.par <- parameters(MPTinR2.result)\n")),
	ite(MPTinR2.show.gof, echo("\t# Goodness of fit\n\tMPTinR2.gof <- goodness.of.fit(MPTinR2.result)\n")),
	ite(MPTinR2.show.inf, echo("\t# Information criteria\n\tMPTinR2.inf <- information.criteria(MPTinR2.result)\n")),
	echo("\n")
)

MPTinR2.js.print <- rk.paste.JS(
	rk.JS.vars(MPTinR2.show.par, MPTinR2.show.gof, MPTinR2.show.inf),
	echo("\trk.header(\"Multinomial Processing Trees (MPTinR2)\",
	parameters=list(
		\"Number of trees\"=MPTinR2.result@model@check$n.trees,
		\"Number of categories\"=MPTinR2.result@model@check$n.categories,
		\"Number of free parameters\"=MPTinR2.result@model@check$n.free.parameters,
		\"Number of fixed parameters\"=MPTinR2.result@model@check$n.fixed.parameters),
	level=1)\n"),
	echo("\trk.header(\"Degrees of freedom\", level=4)\n"),
	echo("\trk.results(data.frame(t(MPTinR2.result@model@check$df)))\n"),
	ite(MPTinR2.show.gof, rk.paste.JS(
		echo("\n\trk.header(\"Goodness of fit\", level=4)\n"),
		echo("\trk.print(\"Individual:\")\n"),
		echo("\trk.results(data.frame(MPTinR2.gof$individual), print.rownames=TRUE)\n"),
		echo("\trk.print(\"<br />Sum:\")\n"),
		echo("\trk.results(data.frame(t(MPTinR2.gof$sum)))\n"),
		echo("\trk.print(\"<br />Aggregated:\")\n"),
		echo("\trk.results(data.frame(t(MPTinR2.gof$aggregated)))\n"), level=3)),
	ite(MPTinR2.show.inf, rk.paste.JS(
		echo("\n\trk.header(\"Information criteria\", level=4)\n"),
		echo("\trk.print(\"Individual:\")\n"),
		echo("\trk.results(data.frame(MPTinR2.inf$individual), print.rownames=TRUE)\n"),
		echo("\trk.print(\"<br />Sum:\")\n"),
		echo("\trk.results(data.frame(t(MPTinR2.inf$sum)))\n"),
		echo("\trk.print(\"<br />Aggregated:\")\n"),
		echo("\trk.results(data.frame(t(MPTinR2.inf$aggregated)))\n"), level=3)),
	ite(MPTinR2.show.par, rk.paste.JS(
		echo("\n\trk.header(\"Parameter estimates\", level=4)\n"),
		echo("\trk.print(\"Individual:\")\n"),
		echo("\trk.results(data.frame(MPTinR2.result@estimates), print.rownames=TRUE)\n"),
		echo("\trk.print(\"<br />Mean values:\")\n"),
		echo("\trk.results(data.frame(MPTinR2.par$mean))\n"),
		echo("\trk.print(\"<br />Aggregated data:\")\n"),
		echo("\trk.results(data.frame(MPTinR2.par$aggregated))\n\n"), level=3))
)

MPTinR2.logic <- rk.XML.logic(
	govModelFromFile <- rk.XML.convert(sources=list(string=MPTinR2.model.format), mode=c(equals="file")),
	rk.XML.connect(governor=govModelFromFile, client=MPTinR2.model.file, set="visible"),
	rk.XML.connect(governor=govModelFromFile, client=MPTinR2.model.type, set="visible"),
	rk.XML.connect(governor=govModelFromFile, client=MPTinR2.model.obj, set="visible", not=TRUE),
	# some JavaScript magic to set model type to EQN automatically
	rk.comment(id("
		gui.addChangeCommand(\"", MPTinR2.model.file, ".selection\", \"modelChanged()\");
		// this function is called whenever the model file name was changed
		modelChanged = function(){
				var modelName = gui.getValue(\"", MPTinR2.model.file, ".selection\");
				if(modelName.match(/.*\\.eqn|.*\\.EQN/)){
					gui.setValue(\"", MPTinR2.model.type, ".string\", \"eqn\");
				} else {}
			}", js=FALSE))
)

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

rk.plugin.skeleton(
	about.info,
	path=output.dir,
	guess.getter=guess.getter,
	xml=list(
		dialog=MPTinR2.full.dialog,
		logic=MPTinR2.logic),
	js=list(results.header=NULL,
		require="MPTinR2",
 		calculate=MPTinR2.js.calc,
 		printout=MPTinR2.js.print),
	pluginmap=list(name="MPTinR2", hierarchy=list("analysis", "MPT")),
	dependencies=dependencies.info,
	create=c("pmap", "xml", "js", "desc"),
	overwrite=overwrite,
	tests=FALSE,
#	edit=TRUE,
	load=TRUE,
#	show=TRUE,
	hints=FALSE)
})