[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