[rkward-cvs] SF.net SVN: rkward-code:[4589] trunk/rkward/rkward/plugins

tfry at users.sf.net tfry at users.sf.net
Wed Mar 13 16:19:33 UTC 2013


Revision: 4589
          http://sourceforge.net/p/rkward/code/4589
Author:   tfry
Date:     2013-03-13 16:19:33 +0000 (Wed, 13 Mar 2013)
Log Message:
-----------
Adding - incomplete - rkwarddev-script for the subsetting plugin.

Added Paths:
-----------
    trunk/rkward/rkward/plugins/rkwarddev_scripts/
    trunk/rkward/rkward/plugins/rkwarddev_scripts/subset_dataframe.R

Added: trunk/rkward/rkward/plugins/rkwarddev_scripts/subset_dataframe.R
===================================================================
--- trunk/rkward/rkward/plugins/rkwarddev_scripts/subset_dataframe.R	                        (rev 0)
+++ trunk/rkward/rkward/plugins/rkwarddev_scripts/subset_dataframe.R	2013-03-13 16:19:33 UTC (rev 4589)
@@ -0,0 +1,219 @@
+# 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 willdat need RKWard >= 0.6.0
+guess.getter <- TRUE
+
+about.info <- rk.XML.about(
+	name="rk.subset",
+	author=c(
+		person(given="Meik", family="Michalke",
+			email="meik.michalke at hhu.de", role=c("aut","cre")),
+		person(given="Thomas", family="Friedrichsmeier",
+			email="tfry at users.sf.net", role=c("aut","cre"))),
+	about=list(desc="RKWard GUI to define subsets of data objects",
+		version="0.02-1", url="http://rkward.sf.net")
+)
+
+############
+## re-usable objects
+############
+
+# for data
+var.select <- rk.XML.varselector(label="Select data")
+var.data <- rk.XML.varslot(label="Data (data.frame)", source=var.select, classes=c("data.frame"), required=TRUE, id.name="var_data")
+
+selected.vars <- rk.XML.varslot(label="Selected variables", source=var.select, multi=TRUE)
+frame.selected.vars <- rk.XML.frame(selected.vars, label="Only use a subset of variables", checkable=TRUE, chk=FALSE)
+
+filter.var <- rk.XML.varslot(label="Filter by", source=var.select)
+sset.filter.drop <- rk.XML.dropdown(label="Keep cases matching rule", options=list(
+		"is one of (%in%)"=c(val="%in%"),
+		"is not one of (!%in%)"=c(val="!%in%"),
+		"is equal (==)"=c(val="==", chk=TRUE),
+		"is not equal (!=)"=c(val="!="),
+		"is in between"=c(val="range"),
+		"is not between"=c(val="!range")
+	), id.name="drp_fltr_all")
+sset.filter.drop.factor <- rk.XML.dropdown(label="Keep cases matching rule", options=list(
+		"is one of (%in%)"=c(val="%in%"),
+		"is not one of (!%in%)"=c(val="!%in%"),
+		"is equal (==)"=c(val="==", chk=TRUE,
+		"is not equal (!=)"=c(val="!="))
+	), id.name="drp_fltr_fct")
+sset.filter.drop.logical <- rk.XML.dropdown(label="Keep cases matching rule", options=list(
+		"is TRUE"=c(val="TRUE", chk=TRUE),
+		"is FALSE"=c(val="FALSE")
+	), id.name="drp_fltr_lgc")
+sset.filter.drop.numeric <- rk.XML.dropdown(label="Keep cases matching rule", options=list(
+		"is equal (==)"=c(val="==", chk=TRUE),
+		"is not equal (!=)"=c(val="!="),
+		"is in between"=c(val="range"),
+		"is not between"=c(val="!range")
+	), id.name="drp_fltr_num")
+lgc.drop.switch <- rk.XML.switch ("case_filter_data_mode", list (
+	case=list (standard="any", dynamic_value=id (sset.filter.drop, ".string", js=FALSE)),
+	case=list (standard="char_factor", dynamic_value=id (sset.filter.drop.factor, ".string", js=FALSE)),
+	case=list (standard="logical", dynamic_value=id (sset.filter.drop.logical, ".string", js=FALSE)),
+	case=list (standard="numeric", dynamic_value=id (sset.filter.drop.numeric, ".string", js=FALSE))))
+lgc.is.range <- rk.XML.switch (lgc.drop.switch, list (
+	case=list (standard="!range", fixed_value="1"),
+	case=list (standard="range", fixed_value="1"),
+	default=list (fixed_value="0")))
+sset.input.filter <- rk.XML.input(label="Value (pasted as-is, use proper quoting!)", required=TRUE)
+
+sset.filter.min <- rk.XML.input(label="Minimum (or empty)")
+sset.filter.min.inc <- rk.XML.checkbox (label="Included (>=)", id.name="mininc")
+sset.filter.max <- rk.XML.input(label="Maximum (or empty)")
+sset.filter.max.inc <- rk.XML.checkbox (label="Included (<=)", id.name="maxinc")	#NOTE: Auto-id bug!
+sset.range.options <- rk.XML.row (
+	rk.XML.col (sset.filter.min, sset.filter.min.inc),
+	rk.XML.col (sset.filter.max, sset.filter.max.inc)
+)
+
+frame.filter.var <- rk.XML.frame(
+	filter.var,
+	sset.filter.drop,
+	sset.filter.drop.factor,
+	sset.filter.drop.logical,
+	sset.filter.drop.numeric,
+	sset.input.filter,
+	sset.range.options,
+	label="Filter rows by variable")
+
+# for logic section
+lgc.filter.script <- rk.comment(id("
+	gui.addChangeCommand(\"", filter.var, ".available\", \"dataChanged()\");
+	// this function is called whenever the data was changed
+	dataChanged = function(){
+			var enableVarInput = \"true\";
+			var dataMode = \"any\";
+			var thisObject = makeRObject(gui.getValue(\"", filter.var, ".available\"));
+			 if(thisObject.classes()){
+				if(thisObject.isDataFactor() || thisObject.isDataCharacter()){
+					dataMode = \"char_factor\";
+				} else if(thisObject.isDataLogical()){
+					dataMode = \"logical\";
+					// NOTE: not hiding VarInput to avoid nasty flicker
+					enableVarInput = \"false\";
+				} else if(thisObject.isDataNumeric()){
+					dataMode=\"numeric\";
+				}
+			} else {}
+			gui.setValue(\"", sset.filter.drop.factor, ".visible\", dataMode == 'char_factor' ? 'true' : 'false');
+			gui.setValue(\"", sset.filter.drop.logical, ".visible\", dataMode == 'logical' ? 'true' : 'false');
+			gui.setValue(\"", sset.filter.drop.numeric, ".visible\", dataMode == 'numeric' ? 'true' : 'false');
+			gui.setValue(\"", sset.filter.drop, ".visible\", dataMode == 'any' ? 'true' : 'false');
+			gui.setValue(\"", sset.input.filter, ".enabled\", enableVarInput);
+			gui.setValue(\"case_filter_data_mode\", dataMode);
+		}
+		dataChanged (); // initialize", js=FALSE))
+
+save.results.sset <- rk.XML.saveobj("Save results to workspace", initial="sset.result", chk=TRUE)
+
+tab.sset.data <- rk.XML.row(
+		var.select,
+		rk.XML.col(
+			var.data,
+			frame.selected.vars,
+			frame.filter.var,
+			rk.XML.stretch(),
+			save.results.sset
+		)
+	)
+
+sset.full.dialog <- rk.XML.dialog(
+	tab.sset.data,
+	label="Subset of data")
+
+## logic section
+lgc.sect.sset <- rk.XML.logic(
+		lgc.filter.script,
+		rk.XML.connect(governor="current_object", client=var.data, set="available"),
+		rk.XML.connect(governor=var.data, client=var.select, get="available", set="root"),
+		sset.gov.data <- rk.XML.convert(sources=list(available=var.data), mode=c(notequals="")),
+		sset.have.filter.var <- rk.XML.convert(sources=list(available=filter.var), mode=c(notequals="")),
+		rk.XML.connect(governor=sset.gov.data, client=frame.selected.vars, set="enabled"),
+		rk.XML.connect(governor=sset.gov.data, client=frame.filter.var, set="enabled"),
+		rk.XML.external(id="case_filter_data_mode", "any"),
+		lgc.drop.switch,
+		lgc.is.range,
+# TODO: Why doesn't this work?
+#		rk.XML.connect(governor=lgc.is.range, client=sset.range.options, set="visible"),
+		rk.XML.connect(governor=sset.range.options, get="visible.not", client=sset.input.filter, set="visible"),
+		rk.XML.connect(governor=sset.have.filter.var, client=sset.input.filter, set="required")
+	)
+
+## JavaScript
+js.frm.filter <- rk.paste.JS (rk.JS.vars(filter.var), "!= \"\"") # see if any variable is selected
+js.frm.subset <- rk.JS.vars(frame.selected.vars, modifiers="checked")
+
+sset.js.calc <- rk.paste.JS(
+	js.selected.vars <- rk.JS.vars(selected.vars, modifiers="shortname", join="\\\", \\\""), # get selected vars
+	js.filter.var <- rk.JS.vars(filter.var, modifiers="shortname", join="\\\", \\\""),
+	js.filter.data.mode <- rk.JS.vars ("case_filter_data_mode"),
+	js.filter.operand <- rk.JS.vars (lgc.drop.switch),
+	js.filter.is.range <- rk.JS.vars (lgc.is.range, getter="getBoolean"),
+	js.filter.min <- rk.JS.vars (sset.filter.min),
+	js.filter.mininc <- rk.JS.vars (sset.filter.min.inc, getter="getBoolean"),
+	js.filter.max <- rk.JS.vars (sset.filter.max),
+	js.filter.maxinc <- rk.JS.vars (sset.filter.max.inc, getter="getBoolean"),
+	echo("\tsset.result <- subset("),
+	ite(var.data, echo("\n\t\t", var.data)),
+	ite(id(js.filter.is.range), rk.paste.JS (
+		"var range_limit = '';",
+		ite (id (js.filter.min, " != ''"), rk.paste.JS ("range_limit += ", id (js.filter.var), " + ' >' + (", id (js.filter.mininc), " ? '= ' : ' ') + ", id (js.filter.min))),
+		ite (id (js.filter.max, " != ''"), rk.paste.JS ("range_limit += (range_limit == '' ? '' : ' && ') + ", id (js.filter.var), " + ' <' + (", id (js.filter.maxinc), " ? '= ' : ' ') + ", id (js.filter.max))),
+		ite (id (js.filter.operand, " == 'range'"),
+			rk.paste.JS (echo(",\n\t\t"), "echo (range_limit)"),
+			rk.paste.JS (echo(",\n\t\t!("), "echo (range_limit + ')')")
+		)),
+		ite (id (js.filter.data.mode, " == 'logical'"),
+			ite(id(js.filter.operand, " == \"TRUE\""),
+				echo(",\n\t\t", js.filter.var),
+				echo(",\n\t\t!", js.filter.var)
+			),
+			ite (id (js.filter.operand, " == '!%in%'"),
+				echo(",\n\t\t!(", js.filter.var, " %in% ", sset.input.filter, ")"),
+				echo(",\n\t\t", js.filter.var, " ", js.filter.operand, " ", sset.input.filter)
+			)
+		)
+	),
+	ite(id(js.frm.subset, " && ", js.selected.vars, " != \"\""), echo(",\n\t\tselect=c(\"", js.selected.vars, "\")")),
+	echo("\n\t)\n\n")
+)
+
+
+#############
+## 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
+
+sset.plugin.dir <<- rk.plugin.skeleton(
+	about.info,
+	path=output.dir,
+	guess.getter=guess.getter,
+	xml=list(
+ 		dialog=sset.full.dialog,
+  		logic=lgc.sect.sset
+		),
+	js=list(results.header=FALSE,
+		calculate=sset.js.calc),
+	pluginmap=list(name="Subset of data.frame", hierarchy=list("data")),
+	dependencies=rk.XML.dependencies (),
+	create=c("pmap", "xml", "js", "desc"),
+	overwrite=overwrite,
+	tests=FALSE,
+#	edit=TRUE,
+	load=TRUE,
+#	show=TRUE,
+	hints=FALSE)
+})





More information about the rkward-tracker mailing list