[rkward-cvs] SF.net SVN: rkward-code:[4776] trunk/rkward/packages/rkwarddev/R
m-eik at users.sf.net
m-eik at users.sf.net
Thu Mar 6 14:40:11 UTC 2014
Revision: 4776
http://sourceforge.net/p/rkward/code/4776
Author: m-eik
Date: 2014-03-06 14:40:08 +0000 (Thu, 06 Mar 2014)
Log Message:
-----------
rkwarddev: code cosmetics, replaced tabs by spaces
Modified Paths:
--------------
trunk/rkward/packages/rkwarddev/R/echo.R
trunk/rkward/packages/rkwarddev/R/id.R
trunk/rkward/packages/rkwarddev/R/ite.R
trunk/rkward/packages/rkwarddev/R/join.R
trunk/rkward/packages/rkwarddev/R/qp.R
trunk/rkward/packages/rkwarddev/R/rk-internal.R
trunk/rkward/packages/rkwarddev/R/rk.JS.arr-class.R
trunk/rkward/packages/rkwarddev/R/rk.JS.array.R
trunk/rkward/packages/rkwarddev/R/rk.JS.doc.R
trunk/rkward/packages/rkwarddev/R/rk.JS.ite-class.R
trunk/rkward/packages/rkwarddev/R/rk.JS.opt-class.R
trunk/rkward/packages/rkwarddev/R/rk.JS.options.R
trunk/rkward/packages/rkwarddev/R/rk.JS.saveobj.R
trunk/rkward/packages/rkwarddev/R/rk.JS.scan.R
trunk/rkward/packages/rkwarddev/R/rk.JS.var-class.R
trunk/rkward/packages/rkwarddev/R/rk.JS.vars.R
trunk/rkward/packages/rkwarddev/R/rk.XML.about.R
trunk/rkward/packages/rkwarddev/R/rk.XML.attribute.R
trunk/rkward/packages/rkwarddev/R/rk.XML.browser.R
trunk/rkward/packages/rkwarddev/R/rk.XML.cbox.R
trunk/rkward/packages/rkwarddev/R/rk.XML.code.R
trunk/rkward/packages/rkwarddev/R/rk.XML.col.R
trunk/rkward/packages/rkwarddev/R/rk.XML.component.R
trunk/rkward/packages/rkwarddev/R/rk.XML.components.R
trunk/rkward/packages/rkwarddev/R/rk.XML.connect.R
trunk/rkward/packages/rkwarddev/R/rk.XML.context.R
trunk/rkward/packages/rkwarddev/R/rk.XML.convert.R
trunk/rkward/packages/rkwarddev/R/rk.XML.copy.R
trunk/rkward/packages/rkwarddev/R/rk.XML.dependencies.R
trunk/rkward/packages/rkwarddev/R/rk.XML.dependency_check.R
trunk/rkward/packages/rkwarddev/R/rk.XML.dialog.R
trunk/rkward/packages/rkwarddev/R/rk.XML.dropdown.R
trunk/rkward/packages/rkwarddev/R/rk.XML.embed.R
trunk/rkward/packages/rkwarddev/R/rk.XML.entry.R
trunk/rkward/packages/rkwarddev/R/rk.XML.external.R
trunk/rkward/packages/rkwarddev/R/rk.XML.formula.R
trunk/rkward/packages/rkwarddev/R/rk.XML.frame.R
trunk/rkward/packages/rkwarddev/R/rk.XML.help.R
trunk/rkward/packages/rkwarddev/R/rk.XML.hierarchy.R
trunk/rkward/packages/rkwarddev/R/rk.XML.include.R
trunk/rkward/packages/rkwarddev/R/rk.XML.input.R
trunk/rkward/packages/rkwarddev/R/rk.XML.insert.R
trunk/rkward/packages/rkwarddev/R/rk.XML.logic.R
trunk/rkward/packages/rkwarddev/R/rk.XML.matrix.R
trunk/rkward/packages/rkwarddev/R/rk.XML.menu.R
trunk/rkward/packages/rkwarddev/R/rk.XML.optioncolumn.R
trunk/rkward/packages/rkwarddev/R/rk.XML.optiondisplay.R
trunk/rkward/packages/rkwarddev/R/rk.XML.optionset.R
trunk/rkward/packages/rkwarddev/R/rk.XML.page.R
trunk/rkward/packages/rkwarddev/R/rk.XML.plugin.R
trunk/rkward/packages/rkwarddev/R/rk.XML.pluginmap.R
trunk/rkward/packages/rkwarddev/R/rk.XML.preview.R
trunk/rkward/packages/rkwarddev/R/rk.XML.radio.R
trunk/rkward/packages/rkwarddev/R/rk.XML.require.R
trunk/rkward/packages/rkwarddev/R/rk.XML.row.R
trunk/rkward/packages/rkwarddev/R/rk.XML.saveobj.R
trunk/rkward/packages/rkwarddev/R/rk.XML.set.R
trunk/rkward/packages/rkwarddev/R/rk.XML.snippet.R
trunk/rkward/packages/rkwarddev/R/rk.XML.snippets.R
trunk/rkward/packages/rkwarddev/R/rk.XML.spinbox.R
trunk/rkward/packages/rkwarddev/R/rk.XML.stretch.R
trunk/rkward/packages/rkwarddev/R/rk.XML.switch.R
trunk/rkward/packages/rkwarddev/R/rk.XML.tabbook.R
trunk/rkward/packages/rkwarddev/R/rk.XML.text.R
trunk/rkward/packages/rkwarddev/R/rk.XML.vars.R
trunk/rkward/packages/rkwarddev/R/rk.XML.varselector.R
trunk/rkward/packages/rkwarddev/R/rk.XML.varslot.R
trunk/rkward/packages/rkwarddev/R/rk.XML.wizard.R
trunk/rkward/packages/rkwarddev/R/rk.build.plugin.R
trunk/rkward/packages/rkwarddev/R/rk.comment.R
trunk/rkward/packages/rkwarddev/R/rk.paste.JS.R
trunk/rkward/packages/rkwarddev/R/rk.paste.JS.graph.R
trunk/rkward/packages/rkwarddev/R/rk.plotOptions.R
trunk/rkward/packages/rkwarddev/R/rk.plug.comp-class.R
trunk/rkward/packages/rkwarddev/R/rk.plugin.component.R
trunk/rkward/packages/rkwarddev/R/rk.plugin.skeleton.R
trunk/rkward/packages/rkwarddev/R/rk.rkh.caption.R
trunk/rkward/packages/rkwarddev/R/rk.rkh.doc.R
trunk/rkward/packages/rkwarddev/R/rk.rkh.link.R
trunk/rkward/packages/rkwarddev/R/rk.rkh.related.R
trunk/rkward/packages/rkwarddev/R/rk.rkh.scan.R
trunk/rkward/packages/rkwarddev/R/rk.rkh.section.R
trunk/rkward/packages/rkwarddev/R/rk.rkh.setting.R
trunk/rkward/packages/rkwarddev/R/rk.rkh.settings.R
trunk/rkward/packages/rkwarddev/R/rk.rkh.summary.R
trunk/rkward/packages/rkwarddev/R/rk.rkh.technical.R
trunk/rkward/packages/rkwarddev/R/rk.rkh.title.R
trunk/rkward/packages/rkwarddev/R/rk.rkh.usage.R
trunk/rkward/packages/rkwarddev/R/rk.testsuite.doc.R
trunk/rkward/packages/rkwarddev/R/rk.uniqueIDs.R
trunk/rkward/packages/rkwarddev/R/rkwarddev-desc-internal.R
trunk/rkward/packages/rkwarddev/R/show-methods.R
trunk/rkward/packages/rkwarddev/R/tf.R
trunk/rkward/packages/rkwarddev/R/zzz.rk.plot.opts-class.R
Modified: trunk/rkward/packages/rkwarddev/R/echo.R
===================================================================
--- trunk/rkward/packages/rkwarddev/R/echo.R 2014-03-06 12:23:58 UTC (rev 4775)
+++ trunk/rkward/packages/rkwarddev/R/echo.R 2014-03-06 14:40:08 UTC (rev 4776)
@@ -5,34 +5,34 @@
#' From those, it will generate a ready-to-run JavaScript \code{echo();} call from it.
#'
#' @param ... One or several character strings and/or \code{XiMpLe.node} objects with plugin nodes,
-#' and/or objects of classes \code{rk.JS.arr} or \code{rk.JS.opt}, simply separated by comma.
+#' and/or objects of classes \code{rk.JS.arr} or \code{rk.JS.opt}, simply separated by comma.
#' @param newline Character string, can be set to e.g. \code{"\n"} to force a newline after the call.
#' @return A character string.
#' @seealso \code{\link[rkwarddev:rk.JS.vars]{rk.JS.vars}},
-#' \code{\link[rkwarddev:rk.JS.array]{rk.JS.array}},
-#' \code{\link[rkwarddev:rk.JS.options]{rk.JS.options}},
-#' \code{\link[rkwarddev:ite]{ite}},
-#' \code{\link[rkwarddev:id]{id}},
-#' \code{\link[rkwarddev:id]{qp}},
-#' and the \href{help:rkwardplugins}{Introduction to Writing Plugins for RKWard}
+#' \code{\link[rkwarddev:rk.JS.array]{rk.JS.array}},
+#' \code{\link[rkwarddev:rk.JS.options]{rk.JS.options}},
+#' \code{\link[rkwarddev:ite]{ite}},
+#' \code{\link[rkwarddev:id]{id}},
+#' \code{\link[rkwarddev:id]{qp}},
+#' and the \href{help:rkwardplugins}{Introduction to Writing Plugins for RKWard}
#' @export
#' @examples
#' cbox1 <- rk.XML.cbox(label="foo", value="foo1", id.name="CheckboxFoo.ID")
#' echo("bar <- \"", cbox1, "\"")
echo <- function(..., newline=""){
- ID.content <- qp(...)
- result <- paste0("echo(", ID.content, ");", newline)
- return(result)
+ ID.content <- qp(...)
+ result <- paste0("echo(", ID.content, ");", newline)
+ return(result)
}
## internal class rk.JS.echo
# this is a quick fix to be able to add values into echo() without quotes
setClass("rk.JS.echo",
- representation=representation(
- value="character"
- ),
- prototype(
- value=character()
- )
+ representation=representation(
+ value="character"
+ ),
+ prototype(
+ value=character()
+ )
)
Modified: trunk/rkward/packages/rkwarddev/R/id.R
===================================================================
--- trunk/rkward/packages/rkwarddev/R/id.R 2014-03-06 12:23:58 UTC (rev 4775)
+++ trunk/rkward/packages/rkwarddev/R/id.R 2014-03-06 14:40:08 UTC (rev 4776)
@@ -7,73 +7,73 @@
#' replacements with character strings.
#'
#' @param ... One or several character strings and/or \code{XiMpLe.node} objects with plugin nodes,
-#' and/or objects of classes \code{rk.JS.arr}, \code{rk.JS.opt} or \code{rk.JS.var}, simply separated by comma.
+#' and/or objects of classes \code{rk.JS.arr}, \code{rk.JS.opt} or \code{rk.JS.var}, simply separated by comma.
#' @param quote Logical, it the character strings sould be deparsed, so they come out "as-is" when
-#' written to files, e.g. by \code{cat}.
+#' written to files, e.g. by \code{cat}.
#' @param collapse Character string, defining if and how the individual elements should be glued together.
#' @param js Logical, if \code{TRUE} returns JavaScript varaible names for \code{XiMpLe.node} objects.
-#' Otherwise their actual ID is returned.
+#' Otherwise their actual ID is returned.
#' @return A character string.
#' @export
#' @seealso \code{\link[rkwarddev:rk.JS.vars]{rk.JS.vars}},
-#' \code{\link[rkwarddev:rk.JS.array]{rk.JS.array}},
-#' \code{\link[rkwarddev:rk.JS.options]{rk.JS.options}},
-#' \code{\link[rkwarddev:echo]{echo}},
-#' \code{\link[rkwarddev:qp]{qp}} (a shortcut for \code{id} with different defaults),
-#' and the \href{help:rkwardplugins}{Introduction to Writing Plugins for RKWard}
+#' \code{\link[rkwarddev:rk.JS.array]{rk.JS.array}},
+#' \code{\link[rkwarddev:rk.JS.options]{rk.JS.options}},
+#' \code{\link[rkwarddev:echo]{echo}},
+#' \code{\link[rkwarddev:qp]{qp}} (a shortcut for \code{id} with different defaults),
+#' and the \href{help:rkwardplugins}{Introduction to Writing Plugins for RKWard}
#' @examples
#' # an example checkbox XML node
#' cbox1 <- rk.XML.cbox(label="foo", value="foo1", id.name="CheckboxFoo.ID")
#' id("The variable name is: ", cbox1, "!")
id <- function(..., quote=FALSE, collapse="", js=TRUE){
- full.content <- list(...)
- ID.content <- sapply(full.content, function(this.part){
- # if this is a plot options object, by default only paste the printout slot
- # and discard the rest
- this.part <- stripCont(this.part, get="printout")
+ full.content <- list(...)
+ ID.content <- sapply(full.content, function(this.part){
+ # if this is a plot options object, by default only paste the printout slot
+ # and discard the rest
+ this.part <- stripCont(this.part, get="printout")
- if(is.XiMpLe.node(this.part)){
- if(identical(XMLName(this.part), "optioncolumn")){
- # optionsets are more difficult to identify automatically
- if(isTRUE(js)){
- node.id <- camelCode(get.IDs(check.optionset.tags(this.part), relevant.tags="optioncolumn")[,"abbrev"])
- } else {
- node.id <- get.IDs(check.optionset.tags(this.part), relevant.tags="optioncolumn")[,"id"]
- }
- } else {
- node.id <- XMLAttrs(this.part)[["id"]]
- if(isTRUE(js)){
- node.id <- camelCode(node.id)
- } else {}
- }
- return(node.id)
- } else if(inherits(this.part, "rk.JS.arr")){
- node.id <- this.part at opt.name
- return(node.id)
- } else if(inherits(this.part, "rk.JS.opt")){
- node.id <- this.part at var.name
- return(node.id)
- } else if(inherits(this.part, "rk.JS.var")){
- # can hold multiple IDs, but we'll only return the first valid one
- node.id <- paste.JS.var(this.part, names.only=TRUE)
- if(length(node.id) > 1){
- node.id <- node.id[1]
- warning(paste0("Object contained more than one ID, only the first one was used: ", node.id), call.=FALSE)
- } else {}
- return(node.id)
- } else if(inherits(this.part, "rk.JS.echo")){
- node.id <- slot(this.part, "value")
- return(node.id)
- } else {
- if(isTRUE(quote)){
- text.part <- deparse(this.part)
- } else {
- text.part <- this.part
- }
- return(text.part)
- }
- })
- result <- paste(ID.content, collapse=collapse)
- return(result)
+ if(is.XiMpLe.node(this.part)){
+ if(identical(XMLName(this.part), "optioncolumn")){
+ # optionsets are more difficult to identify automatically
+ if(isTRUE(js)){
+ node.id <- camelCode(get.IDs(check.optionset.tags(this.part), relevant.tags="optioncolumn")[,"abbrev"])
+ } else {
+ node.id <- get.IDs(check.optionset.tags(this.part), relevant.tags="optioncolumn")[,"id"]
+ }
+ } else {
+ node.id <- XMLAttrs(this.part)[["id"]]
+ if(isTRUE(js)){
+ node.id <- camelCode(node.id)
+ } else {}
+ }
+ return(node.id)
+ } else if(inherits(this.part, "rk.JS.arr")){
+ node.id <- this.part at opt.name
+ return(node.id)
+ } else if(inherits(this.part, "rk.JS.opt")){
+ node.id <- this.part at var.name
+ return(node.id)
+ } else if(inherits(this.part, "rk.JS.var")){
+ # can hold multiple IDs, but we'll only return the first valid one
+ node.id <- paste.JS.var(this.part, names.only=TRUE)
+ if(length(node.id) > 1){
+ node.id <- node.id[1]
+ warning(paste0("Object contained more than one ID, only the first one was used: ", node.id), call.=FALSE)
+ } else {}
+ return(node.id)
+ } else if(inherits(this.part, "rk.JS.echo")){
+ node.id <- slot(this.part, "value")
+ return(node.id)
+ } else {
+ if(isTRUE(quote)){
+ text.part <- deparse(this.part)
+ } else {
+ text.part <- this.part
+ }
+ return(text.part)
+ }
+ })
+ result <- paste(ID.content, collapse=collapse)
+ return(result)
}
Modified: trunk/rkward/packages/rkwarddev/R/ite.R
===================================================================
--- trunk/rkward/packages/rkwarddev/R/ite.R 2014-03-06 12:23:58 UTC (rev 4775)
+++ trunk/rkward/packages/rkwarddev/R/ite.R 2014-03-06 14:40:08 UTC (rev 4776)
@@ -1,22 +1,22 @@
#' Generate JavaScript if/then/else constructs
#'
#' @param ifjs Either a character string to be placed in the brackets if an \code{if()} statement,
-#' or an object of class \code{XiMpLe.node}. \code{rk.JS.arr} or \code{rk.JS.opt} (whose identifier will be used).
+#' or an object of class \code{XiMpLe.node}. \code{rk.JS.arr} or \code{rk.JS.opt} (whose identifier will be used).
#' @param thenjs Either a character string, the code to be executed in case the \code{if()} statement is true,
-#' or an object of class \code{XiMpLe.node}. \code{rk.JS.arr} or \code{rk.JS.opt} (whose identifier will be used).
-#' The latter is especially useful in combination with \code{\link[rkwarddev:rk.JS.options]{rk.JS.options}}.
-#' You can also give another object of class \code{rk.JS.ite}.
+#' or an object of class \code{XiMpLe.node}. \code{rk.JS.arr} or \code{rk.JS.opt} (whose identifier will be used).
+#' The latter is especially useful in combination with \code{\link[rkwarddev:rk.JS.options]{rk.JS.options}}.
+#' You can also give another object of class \code{rk.JS.ite}.
#' @param elsejs Like \code{thenjs}, the code to be executed in case the \code{if()} statement is not true.
#' @return An object of class \code{rk.JS.ite}
#' @include rk.JS.ite-class.R
#' @seealso \code{\link[rkwarddev:rk.paste.JS]{rk.paste.JS}},
-#' \code{\link[rkwarddev:rk.JS.vars]{rk.JS.vars}},
-#' \code{\link[rkwarddev:rk.JS.array]{rk.JS.array}},
-#' \code{\link[rkwarddev:rk.JS.options]{rk.JS.options}},
-#' \code{\link[rkwarddev:echo]{echo}},
-#' \code{\link[rkwarddev:id]{id}},
-#' \code{\link[rkwarddev:qp]{qp}},
-#' and the \href{help:rkwardplugins}{Introduction to Writing Plugins for RKWard}
+#' \code{\link[rkwarddev:rk.JS.vars]{rk.JS.vars}},
+#' \code{\link[rkwarddev:rk.JS.array]{rk.JS.array}},
+#' \code{\link[rkwarddev:rk.JS.options]{rk.JS.options}},
+#' \code{\link[rkwarddev:echo]{echo}},
+#' \code{\link[rkwarddev:id]{id}},
+#' \code{\link[rkwarddev:qp]{qp}},
+#' and the \href{help:rkwardplugins}{Introduction to Writing Plugins for RKWard}
#' @export
#' @examples
#' # first create an example checkbox XML node
@@ -25,28 +25,28 @@
#' ite(cbox1, echo("bar <- \"", cbox1, "\""), echo("bar <- NULL"))
ite <- function(ifjs, thenjs, elsejs=NULL){
- #check for recursion
- if(inherits(thenjs, "rk.JS.ite")){
- thenifJS <- list(thenjs)
- thenjs <- ""
- } else {
- thenifJS <- list()
- }
- if(inherits(elsejs, "rk.JS.ite")){
- elifJS <- list(elsejs)
- elsejs <- ""
- } else {
- elifJS <- list()
- if(is.null(elsejs)){
- elsejs <- ""
- } else {}
- }
- result <- new("rk.JS.ite",
- ifJS=id(ifjs, js=TRUE),
- thenJS=id(thenjs, js=TRUE),
- thenifJS=thenifJS,
- elseJS=elsejs,
- elifJS=elifJS
- )
- return(result)
+ #check for recursion
+ if(inherits(thenjs, "rk.JS.ite")){
+ thenifJS <- list(thenjs)
+ thenjs <- ""
+ } else {
+ thenifJS <- list()
+ }
+ if(inherits(elsejs, "rk.JS.ite")){
+ elifJS <- list(elsejs)
+ elsejs <- ""
+ } else {
+ elifJS <- list()
+ if(is.null(elsejs)){
+ elsejs <- ""
+ } else {}
+ }
+ result <- new("rk.JS.ite",
+ ifJS=id(ifjs, js=TRUE),
+ thenJS=id(thenjs, js=TRUE),
+ thenifJS=thenifJS,
+ elseJS=elsejs,
+ elifJS=elifJS
+ )
+ return(result)
}
Modified: trunk/rkward/packages/rkwarddev/R/join.R
===================================================================
--- trunk/rkward/packages/rkwarddev/R/join.R 2014-03-06 12:23:58 UTC (rev 4775)
+++ trunk/rkward/packages/rkwarddev/R/join.R 2014-03-06 14:40:08 UTC (rev 4776)
@@ -6,30 +6,30 @@
#' needs to be joined in as R code output (e.g., an \code{<optioncolumn>}).
#'
#' @param var Either a character string (the name of the variable to combine to a vector or list),
-#' or an object of class \code{XiMpLe.node} (whose ID will be extracted and used). Also
-#' accepts objects of class \code{rk.JS.arr}.
+#' or an object of class \code{XiMpLe.node} (whose ID will be extracted and used). Also
+#' accepts objects of class \code{rk.JS.arr}.
#' @param by Character string by which the values ought to be joined.
#' @return An object of class \code{rk.JS.echo}.
#' @export
#' @seealso \code{\link[rkwarddev:rk.paste.JS]{rk.paste.JS}},
-#' \code{\link[rkwarddev:rk.JS.options]{rk.JS.options}},
-#' \code{\link[rkwarddev:rk.JS.vars]{rk.JS.vars}},
-#' \code{\link[rkwarddev:echo]{echo}},
-#' \code{\link[rkwarddev:id]{id}},
-#' and the \href{help:rkwardplugins}{Introduction to Writing Plugins for RKWard}
+#' \code{\link[rkwarddev:rk.JS.options]{rk.JS.options}},
+#' \code{\link[rkwarddev:rk.JS.vars]{rk.JS.vars}},
+#' \code{\link[rkwarddev:echo]{echo}},
+#' \code{\link[rkwarddev:id]{id}},
+#' and the \href{help:rkwardplugins}{Introduction to Writing Plugins for RKWard}
# @examples
join <- function(var, by="\", \""){
- if(inherits(var, "rk.JS.arr")){
- arr.name <- slot(object, "opt.name")
- } else {
- arr.name <- id(var)
- }
+ if(inherits(var, "rk.JS.arr")){
+ arr.name <- slot(object, "opt.name")
+ } else {
+ arr.name <- id(var)
+ }
- JS.join <- new("rk.JS.echo",
- value=paste0(camelCode(arr.name), ".join(", qp(by) ,")")
- )
+ JS.join <- new("rk.JS.echo",
+ value=paste0(camelCode(arr.name), ".join(", qp(by) ,")")
+ )
- return(JS.join)
+ return(JS.join)
}
Modified: trunk/rkward/packages/rkwarddev/R/qp.R
===================================================================
--- trunk/rkward/packages/rkwarddev/R/qp.R 2014-03-06 12:23:58 UTC (rev 4775)
+++ trunk/rkward/packages/rkwarddev/R/qp.R 2014-03-06 14:40:08 UTC (rev 4776)
@@ -4,21 +4,21 @@
#' (\code{quote=TRUE, collapse=" + ", js=TRUE}). The abbreviation stands for "quote + plus".
#'
#' @param ... One or several character strings and/or \code{XiMpLe.node} objects with plugin nodes,
-#' and/or objects of classes \code{rk.JS.arr} or \code{rk.JS.opt}, simply separated by comma.
+#' and/or objects of classes \code{rk.JS.arr} or \code{rk.JS.opt}, simply separated by comma.
#' @return A character string.
#' @export
#' @seealso \code{\link[rkwarddev:rk.JS.vars]{rk.JS.vars}},
-#' \code{\link[rkwarddev:rk.JS.array]{rk.JS.array}},
-#' \code{\link[rkwarddev:rk.JS.options]{rk.JS.options}},
-#' \code{\link[rkwarddev:echo]{echo}},
-#' \code{\link[rkwarddev:id]{id}},
-#' and the \href{help:rkwardplugins}{Introduction to Writing Plugins for RKWard}
+#' \code{\link[rkwarddev:rk.JS.array]{rk.JS.array}},
+#' \code{\link[rkwarddev:rk.JS.options]{rk.JS.options}},
+#' \code{\link[rkwarddev:echo]{echo}},
+#' \code{\link[rkwarddev:id]{id}},
+#' and the \href{help:rkwardplugins}{Introduction to Writing Plugins for RKWard}
#' @examples
#' # an example checkbox XML node
#' cbox1 <- rk.XML.cbox(label="foo", value="foo1", id.name="CheckboxFoo.ID")
#' qp("The variable name is: ", cbox1, "!")
qp <- function(...){
- result <- id(..., quote=TRUE, collapse=" + ", js=TRUE)
- return(result)
+ result <- id(..., quote=TRUE, collapse=" + ", js=TRUE)
+ return(result)
}
Modified: trunk/rkward/packages/rkwarddev/R/rk-internal.R
===================================================================
--- trunk/rkward/packages/rkwarddev/R/rk-internal.R 2014-03-06 12:23:58 UTC (rev 4775)
+++ trunk/rkward/packages/rkwarddev/R/rk-internal.R 2014-03-06 14:40:08 UTC (rev 4776)
@@ -2,39 +2,39 @@
## wrapper for paste0() needed?
if(isTRUE(R_system_version(getRversion()) < 2.15)){
- # if this is an older R version, we need a wrapper function for paste0()
- # which was introduced with R 2.15 as a more efficient shortcut to paste(..., sep="")
- paste0 <- function(..., collapse=NULL){
- return(paste(..., sep="", collapse=collapse))
- }
+ # if this is an older R version, we need a wrapper function for paste0()
+ # which was introduced with R 2.15 as a more efficient shortcut to paste(..., sep="")
+ paste0 <- function(..., collapse=NULL){
+ return(paste(..., sep="", collapse=collapse))
+ }
} else {}
# info message
generator.info <- rk.comment(paste0("this code was generated using the rkwarddev package.\n",
- "perhaps don't make changes here, but in the rkwarddev script instead!"))
+ "perhaps don't make changes here, but in the rkwarddev script instead!"))
## function auto.ids()
auto.ids <- function(identifiers, prefix=NULL, suffix=NULL, chars=8){
- identifiers <- gsub("[[:space:]]*[^[:alnum:]]*", "", identifiers)
- id.names <- ifelse(nchar(identifiers) > 8, abbreviate(identifiers, minlength=chars), identifiers)
- # check for uniqueness
- if(any(duplicated(id.names))){
- warning("IDs are not unique, please check!")
- } else {}
- ids <- paste0(prefix, id.names, suffix)
- return(ids)
+ identifiers <- gsub("[[:space:]]*[^[:alnum:]]*", "", identifiers)
+ id.names <- ifelse(nchar(identifiers) > 8, abbreviate(identifiers, minlength=chars), identifiers)
+ # check for uniqueness
+ if(any(duplicated(id.names))){
+ warning("IDs are not unique, please check!")
+ } else {}
+ ids <- paste0(prefix, id.names, suffix)
+ return(ids)
} ## end function auto.ids()
## function stripCont()
# get slots out of certain container objects
stripCont <- function(obj, get="printout"){
- if(inherits(obj, "rk.plot.opts")){
- # if this is a plot options object, extract the XML slot
- # and discard the rest
- obj <- slot(obj, get)
- } else {}
- return(obj)
+ if(inherits(obj, "rk.plot.opts")){
+ # if this is a plot options object, extract the XML slot
+ # and discard the rest
+ obj <- slot(obj, get)
+ } else {}
+ return(obj)
}
## end function stripCont()
@@ -42,7 +42,7 @@
## function stripXML()
# get XML node out of container objects
stripXML <- function(obj){
- return(stripCont(obj, get="XML"))
+ return(stripCont(obj, get="XML"))
}
## end function stripXML()
@@ -52,72 +52,72 @@
# 'empty' can be used to make sure a tag is non-empty without actual value
# this function also reduces rk.plot.opts objects to their XiMpLe.node slot
child.list <- function(children, empty=TRUE){
- if(is.XiMpLe.node(children)){
- children <- list(children)
- } else {
- # if already a list, check if it's a list in a list and get it out
- if(inherits(children, "list") & length(children) == 1){
- if(inherits(children[[1]], "list")){
- children <- children[[1]]
- } else {}
- } else if(identical(children, list()) & !isTRUE(empty)){
- children <- list("")
- } else {}
- children <- lapply(children, function(this.child){
- stripXML(this.child)
- })
- }
- return(children)
+ if(is.XiMpLe.node(children)){
+ children <- list(children)
+ } else {
+ # if already a list, check if it's a list in a list and get it out
+ if(inherits(children, "list") & length(children) == 1){
+ if(inherits(children[[1]], "list")){
+ children <- children[[1]]
+ } else {}
+ } else if(identical(children, list()) & !isTRUE(empty)){
+ children <- list("")
+ } else {}
+ children <- lapply(children, function(this.child){
+ stripXML(this.child)
+ })
+ }
+ return(children)
} ## end function child.list()
## function trim()
# cuts off space at start and end of a character string
trim <- function(char){
- char <- gsub("^[[:space:]]*", "", char)
- char <- gsub("[[:space:]]*$", "", char)
- return(char)
+ char <- gsub("^[[:space:]]*", "", char)
+ char <- gsub("[[:space:]]*$", "", char)
+ return(char)
} ## end function trim()
## function indent()
# will create tabs to format the output
indent <- function(level, by="\t"){
- paste(rep(by, level-1), collapse="")
+ paste(rep(by, level-1), collapse="")
} ## end function indent()
## function checkCreateFiles()
# used by rk.plugin.skeleton()
checkCreateFiles <- function(file.name, ow, action=NULL){
- if(all(file.exists(file.name), as.logical(ow)) | !file.exists(file.name)){
- return(TRUE)
- } else {
- if(!is.null(action)){
- action <- paste0(action, ": ")
- } else {}
- warning(paste0(action, "Skipping existing file ", file.name, "."), call.=FALSE)
- return(FALSE)
- }
+ if(all(file.exists(file.name), as.logical(ow)) | !file.exists(file.name)){
+ return(TRUE)
+ } else {
+ if(!is.null(action)){
+ action <- paste0(action, ": ")
+ } else {}
+ warning(paste0(action, "Skipping existing file ", file.name, "."), call.=FALSE)
+ return(FALSE)
+ }
} ## end function checkCreateFiles()
## function get.single.tags()
get.single.tags <- function(XML.obj, drop=NULL){
- # determine if we need to read a file or process an XiMpLe object
- if(is.XiMpLe.doc(XML.obj)){
- single.tags <- trim(unlist(strsplit(pasteXMLTree(XML.obj, shine=1, indent.by=""), split="\n")))
- } else if(is.XiMpLe.node(XML.obj)){
- single.tags <- trim(unlist(strsplit(pasteXML(XML.obj, shine=1, indent.by=""), split="\n")))
- } else if(!is.null(XML.obj)){
- xml.raw <- paste(readLines(XML.obj), collapse=" ")
- single.tags <- XiMpLe:::XML.single.tags(xml.raw, drop=drop)
- } else {
- return(NULL)
- }
- names(single.tags) <- NULL
+ # determine if we need to read a file or process an XiMpLe object
+ if(is.XiMpLe.doc(XML.obj)){
+ single.tags <- trim(unlist(strsplit(pasteXMLTree(XML.obj, shine=1, indent.by=""), split="\n")))
+ } else if(is.XiMpLe.node(XML.obj)){
+ single.tags <- trim(unlist(strsplit(pasteXML(XML.obj, shine=1, indent.by=""), split="\n")))
+ } else if(!is.null(XML.obj)){
+ xml.raw <- paste(readLines(XML.obj), collapse=" ")
+ single.tags <- XiMpLe:::XML.single.tags(xml.raw, drop=drop)
+ } else {
+ return(NULL)
+ }
+ names(single.tags) <- NULL
- return(single.tags)
+ return(single.tags)
} ## end function get.single.tags()
@@ -127,93 +127,93 @@
# 'single.tags' can also contain XiMpLe.node objects
get.IDs <- function(single.tags, relevant.tags, add.abbrev=FALSE, tag.names=FALSE, only.checkable=FALSE){
- # filter for relevant tags
- cleaned.tags <- list()
- for(this.tag in child.list(single.tags)){
- if(is.XiMpLe.node(this.tag)){
- this.tag.name <- XMLName(this.tag)
- if(this.tag.name %in% relevant.tags & "id" %in% names(XMLAttrs(this.tag))){
- if(isTRUE(only.checkable) & this.tag.name %in% "frame"){
- if("checkable" %in% names(XMLAttrs(this.tag))){
- if(identical(XMLAttrs(this.tag)[["checkable"]], "true")){
- cleaned.tags[length(cleaned.tags)+1] <- this.tag
- } else {}
- } else {}
- } else {
- cleaned.tags[length(cleaned.tags)+1] <- this.tag
- }
- } else {}
- } else {
- this.tag.name <- tolower(XiMpLe:::XML.tagName(this.tag))
- # we're only interested in entries with an ID
- if(this.tag.name %in% relevant.tags){
- if("id" %in% names(XiMpLe:::parseXMLAttr(this.tag))){
- if(isTRUE(only.checkable) & this.tag.name %in% "frame"){
- if("checkable" %in% names(XiMpLe:::parseXMLAttr(this.tag))){
- if(identical(XiMpLe:::parseXMLAttr(this.tag)[["checkable"]], "true")){
- cleaned.tags[length(cleaned.tags)+1] <- this.tag
- } else {}
- } else {}
- } else {
- cleaned.tags[length(cleaned.tags)+1] <- this.tag
- }
- } else {}
- } else {}
- }
- }
+ # filter for relevant tags
+ cleaned.tags <- list()
+ for(this.tag in child.list(single.tags)){
+ if(is.XiMpLe.node(this.tag)){
+ this.tag.name <- XMLName(this.tag)
+ if(this.tag.name %in% relevant.tags & "id" %in% names(XMLAttrs(this.tag))){
+ if(isTRUE(only.checkable) & this.tag.name %in% "frame"){
+ if("checkable" %in% names(XMLAttrs(this.tag))){
+ if(identical(XMLAttrs(this.tag)[["checkable"]], "true")){
+ cleaned.tags[length(cleaned.tags)+1] <- this.tag
+ } else {}
+ } else {}
+ } else {
+ cleaned.tags[length(cleaned.tags)+1] <- this.tag
+ }
+ } else {}
+ } else {
+ this.tag.name <- tolower(XiMpLe:::XML.tagName(this.tag))
+ # we're only interested in entries with an ID
+ if(this.tag.name %in% relevant.tags){
+ if("id" %in% names(XiMpLe:::parseXMLAttr(this.tag))){
+ if(isTRUE(only.checkable) & this.tag.name %in% "frame"){
+ if("checkable" %in% names(XiMpLe:::parseXMLAttr(this.tag))){
+ if(identical(XiMpLe:::parseXMLAttr(this.tag)[["checkable"]], "true")){
+ cleaned.tags[length(cleaned.tags)+1] <- this.tag
+ } else {}
+ } else {}
+ } else {
+ cleaned.tags[length(cleaned.tags)+1] <- this.tag
+ }
+ } else {}
+ } else {}
+ }
+ }
- ids <- t(sapply(cleaned.tags, function(this.tag){
- if(is.XiMpLe.node(this.tag)){
- this.tag.name <- XMLName(this.tag)
- this.tag.id.abbrev <- this.tag.id <- XMLAttrs(this.tag)["id"]
- # take care of one special case: optionsets
- # they need the set ID to access the value from the dialog,
- # but to be able to use only the optioncolumn in rkwaddev scripts
- # as reference, the JavaScript variable must be generated from the
- # column ID alone.
- if(identical(this.tag.name, "optioncolumn")){
- this.tag.setid <- XMLAttrs(this.tag)[["setid"]]
- if(!is.null(this.tag.setid)){
- this.tag.id <- paste(this.tag.setid, this.tag.id, sep=".")
- } else {}
- # for safety, prefix the column ID with a constant
- this.tag.id.abbrev <- paste0("ocol_", this.tag.id.abbrev)
- } else {}
- } else {
- this.tag.name <- XiMpLe:::XML.tagName(this.tag)
- this.tag.id.abbrev <- this.tag.id <- XiMpLe:::parseXMLAttr(this.tag)[["id"]]
- # see comment above for the next part
- if(identical(this.tag.name, "optioncolumn")){
- this.tag.setid <- XiMpLe:::parseXMLAttr(this.tag)[["setid"]]
- if(!is.null(this.tag.setid)){
- this.tag.id <- paste(this.tag.setid, this.tag.id, sep=".")
- } else {}
- # for safety, prefix the column ID with a constant
- this.tag.id.abbrev <- paste0("ocol_", this.tag.id.abbrev)
- } else {}
- }
+ ids <- t(sapply(cleaned.tags, function(this.tag){
+ if(is.XiMpLe.node(this.tag)){
+ this.tag.name <- XMLName(this.tag)
+ this.tag.id.abbrev <- this.tag.id <- XMLAttrs(this.tag)["id"]
+ # take care of one special case: optionsets
+ # they need the set ID to access the value from the dialog,
+ # but to be able to use only the optioncolumn in rkwaddev scripts
+ # as reference, the JavaScript variable must be generated from the
+ # column ID alone.
+ if(identical(this.tag.name, "optioncolumn")){
+ this.tag.setid <- XMLAttrs(this.tag)[["setid"]]
+ if(!is.null(this.tag.setid)){
+ this.tag.id <- paste(this.tag.setid, this.tag.id, sep=".")
+ } else {}
+ # for safety, prefix the column ID with a constant
+ this.tag.id.abbrev <- paste0("ocol_", this.tag.id.abbrev)
+ } else {}
+ } else {
+ this.tag.name <- XiMpLe:::XML.tagName(this.tag)
+ this.tag.id.abbrev <- this.tag.id <- XiMpLe:::parseXMLAttr(this.tag)[["id"]]
+ # see comment above for the next part
+ if(identical(this.tag.name, "optioncolumn")){
+ this.tag.setid <- XiMpLe:::parseXMLAttr(this.tag)[["setid"]]
+ if(!is.null(this.tag.setid)){
+ this.tag.id <- paste(this.tag.setid, this.tag.id, sep=".")
+ } else {}
+ # for safety, prefix the column ID with a constant
+ this.tag.id.abbrev <- paste0("ocol_", this.tag.id.abbrev)
+ } else {}
+ }
- if(isTRUE(add.abbrev)){
- this.tag.id.abbrev <- paste0(ID.prefix(this.tag.name), this.tag.id.abbrev)
- } else {}
- if(isTRUE(tag.names)){
- return(c(id=this.tag.id, abbrev=this.tag.id.abbrev, tag=this.tag.name))
- } else {
- return(c(id=this.tag.id, abbrev=this.tag.id.abbrev))
- }
- }
- ))
- rownames(ids) <- NULL
+ if(isTRUE(add.abbrev)){
+ this.tag.id.abbrev <- paste0(ID.prefix(this.tag.name), this.tag.id.abbrev)
+ } else {}
+ if(isTRUE(tag.names)){
+ return(c(id=this.tag.id, abbrev=this.tag.id.abbrev, tag=this.tag.name))
+ } else {
+ return(c(id=this.tag.id, abbrev=this.tag.id.abbrev))
+ }
+ }
+ ))
+ rownames(ids) <- NULL
- # do a check if all IDs are really unique
- if("id" %in% names(ids)){
- multiple.id <- duplicated(ids[,"id"])
- if(any(multiple.id)){
- warning(paste0("IDs are not unique:\n ", paste(ids[multiple.id,"id"], collapse=", "), "\n Expect errors!"))
- } else {}
- }
+ # do a check if all IDs are really unique
+ if("id" %in% names(ids)){
+ multiple.id <- duplicated(ids[,"id"])
+ if(any(multiple.id)){
+ warning(paste0("IDs are not unique:\n ", paste(ids[multiple.id,"id"], collapse=", "), "\n Expect errors!"))
+ } else {}
+ }
- return(ids)
+ return(ids)
} ## end function get.IDs()
## function check.optionset.tags()
@@ -225,32 +225,32 @@
# set is discarded.
# this extra attribute is evaluated by get.IDs().
check.optionset.tags <- function(XML.obj, drop=NULL){
- # if this is not a XiMpLe object, transform the file into one
- if(!is.XiMpLe.node(XML.obj) && !is.XiMpLe.doc(XML.obj)){
- XML.obj <- parseXMLTree(XML.obj, drop=drop)
- } else {}
- # first get a list of all optionsets
- optionset.nodes <- child.list(XMLScan(XML.obj, "optionset"))
- # are there any?
- if(is.null(optionset.nodes)){
- result <- get.single.tags(XML.obj=XML.obj, drop=drop)
- } else {
- # now go through all sets and combine setID with the IDs of optioncolumns
- optioncolumnNewIDs <- unlist(sapply(optionset.nodes, function(thisNode){
- thisCols <- child.list(XMLScan(thisNode, "optioncolumn"))
- thisSetID <- XMLAttrs(thisNode)[["id"]]
- thisNewCols <- unlist(sapply(thisCols, function(thisCol){
- XMLAttrs(thisCol)[["setid"]] <- thisSetID
- pastedTag <- get.single.tags(XML.obj=thisCol, drop=drop)
- return(pastedTag)
- }, USE.NAMES=FALSE))
- return(thisNewCols)
- }, USE.NAMES=FALSE))
- # we don't need the set nodes any longer
- XMLScan(XML.obj, "optionset") <- NULL
- result <- c(optioncolumnNewIDs, get.single.tags(XML.obj=XML.obj, drop=drop))
- }
- return(result)
+ # if this is not a XiMpLe object, transform the file into one
+ if(!is.XiMpLe.node(XML.obj) && !is.XiMpLe.doc(XML.obj)){
+ XML.obj <- parseXMLTree(XML.obj, drop=drop)
+ } else {}
+ # first get a list of all optionsets
+ optionset.nodes <- child.list(XMLScan(XML.obj, "optionset"))
+ # are there any?
+ if(is.null(optionset.nodes)){
+ result <- get.single.tags(XML.obj=XML.obj, drop=drop)
+ } else {
+ # now go through all sets and combine setID with the IDs of optioncolumns
+ optioncolumnNewIDs <- unlist(sapply(optionset.nodes, function(thisNode){
+ thisCols <- child.list(XMLScan(thisNode, "optioncolumn"))
+ thisSetID <- XMLAttrs(thisNode)[["id"]]
+ thisNewCols <- unlist(sapply(thisCols, function(thisCol){
+ XMLAttrs(thisCol)[["setid"]] <- thisSetID
+ pastedTag <- get.single.tags(XML.obj=thisCol, drop=drop)
+ return(pastedTag)
+ }, USE.NAMES=FALSE))
+ return(thisNewCols)
+ }, USE.NAMES=FALSE))
+ # we don't need the set nodes any longer
+ XMLScan(XML.obj, "optionset") <- NULL
+ result <- c(optioncolumnNewIDs, get.single.tags(XML.obj=XML.obj, drop=drop))
+ }
+ return(result)
} ## end function check.optionset.tags()
## function camelCode()
@@ -258,20 +258,20 @@
# (except for the first one) to upper case
camelCode <- function(words){
- words <- as.vector(unlist(sapply(words, function(cur.word){
- unlist(strsplit(cur.word, split="[._]"))
- })))
+ words <- as.vector(unlist(sapply(words, function(cur.word){
+ unlist(strsplit(cur.word, split="[._]"))
+ })))
- new.words <- sapply(words[-1], function(cur.word){
- word.vector <- unlist(strsplit(cur.word, split=""))
- word.vector[1] <- toupper(word.vector[1])
- word.new <- paste(word.vector, collapse="")
- return(word.new)
- })
+ new.words <- sapply(words[-1], function(cur.word){
+ word.vector <- unlist(strsplit(cur.word, split=""))
+ word.vector[1] <- toupper(word.vector[1])
+ word.new <- paste(word.vector, collapse="")
+ return(word.new)
+ })
- results <- paste0(words[1], paste(new.words, collapse=""))
+ results <- paste0(words[1], paste(new.words, collapse=""))
- return(results)
+ return(results)
} ## end function camelCode()
@@ -279,61 +279,61 @@
# try to set useful default getter functions to query the values from XML nodes
# will only be used if "guess.getter" is true
JS.getters.default <- list(
- "browser"="getString",
- "checkbox"="getBoolean",
- "dropdown"="getString",
- "frame"="getBoolean",
- "input"="getString",
- "matrix"="getList",
- "optioncolumn"="getList",
- "radio"="getString",
- "saveobject"="getString",
- "spinbox"="getString",
- "varslot"="getString"
+ "browser"="getString",
+ "checkbox"="getBoolean",
+ "dropdown"="getString",
+ "frame"="getBoolean",
+ "input"="getString",
+ "matrix"="getList",
+ "optioncolumn"="getList",
+ "radio"="getString",
+ "saveobject"="getString",
+ "spinbox"="getString",
+ "varslot"="getString"
)
# we can also guess some fitting getter functions by the modifier set
JS.getters.modif.default <- list(
-# "active",
-# "available",
-# "calculate",
- "checked"="getBoolean",
- "checked.not"="getBoolean",
- "checked.numeric"="getBoolean",
- "dependent"="getString",
- "enabled"="getBoolean",
- "enabled.not"="getBoolean",
- "enabled.numeric"="getBoolean",
-# "false",
- "fixed_factors"="getString",
-# "int",
- "label"="getString",
- "labels"="getString",
- "model"="getString",
-# "not",
-# "number",
-# "numeric",
- "objectname"="getString",
- "parent"="getString",
- "preprocess"="getString",
- "preview"="getBoolean",
- "printout"="getString",
-# "real",
- "required"="getBoolean",
-# "root",
-# "selected",
-# "selection",
- "shortname"="getString",
- "source"="getString",
- "state"="getBoolean",
- "state.not"="getBoolean",
- "state.numeric"="getBoolean",
- "string"="getString",
-# "table",
- "text"="getString",
-# "true",
- "visible"="getBoolean",
- "visible.not"="getBoolean",
- "visible.numeric"="getBoolean"
+# "active",
+# "available",
+# "calculate",
+ "checked"="getBoolean",
+ "checked.not"="getBoolean",
+ "checked.numeric"="getBoolean",
+ "dependent"="getString",
+ "enabled"="getBoolean",
+ "enabled.not"="getBoolean",
+ "enabled.numeric"="getBoolean",
+# "false",
+ "fixed_factors"="getString",
+# "int",
+ "label"="getString",
+ "labels"="getString",
+ "model"="getString",
+# "not",
+# "number",
+# "numeric",
+ "objectname"="getString",
+ "parent"="getString",
+ "preprocess"="getString",
+ "preview"="getBoolean",
+ "printout"="getString",
+# "real",
+ "required"="getBoolean",
+# "root",
+# "selected",
+# "selection",
+ "shortname"="getString",
+ "source"="getString",
+ "state"="getBoolean",
+ "state.not"="getBoolean",
+ "state.numeric"="getBoolean",
+ "string"="getString",
+# "table",
+ "text"="getString",
+# "true",
+ "visible"="getBoolean",
+ "visible.not"="getBoolean",
+ "visible.numeric"="getBoolean"
)
## function get.JS.vars()
@@ -341,186 +341,186 @@
# in XML will become
# var my.id = getValue("my.id");
get.JS.vars <- function(JS.var, XML.var=NULL, tag.name=NULL, JS.prefix="", names.only=FALSE, modifiers=NULL, default=FALSE, join="",
- getter="getValue", guess.getter=FALSE, check.modifiers=TRUE){
- # check for XiMpLe nodes
- JS.var <- check.ID(JS.var)
- have.XiMpLe.var <- FALSE
- if(!is.null(XML.var)){
- if(is.XiMpLe.node(XML.var)){
- have.XiMpLe.var <- TRUE
- tag.name <- XMLName(XML.var)
- } else if(is.null(tag.name)){
- # hm, not a XiMpLe object and no known tag name :-/
- # if this is simply a character string, the tag name will become ""
- tag.name <- XMLName(XMLChildren(parseXMLTree(XML.var, object=TRUE))[[1]])
- } else {}
+ getter="getValue", guess.getter=FALSE, check.modifiers=TRUE){
+ # check for XiMpLe nodes
+ JS.var <- check.ID(JS.var)
+ have.XiMpLe.var <- FALSE
+ if(!is.null(XML.var)){
+ if(is.XiMpLe.node(XML.var)){
+ have.XiMpLe.var <- TRUE
+ tag.name <- XMLName(XML.var)
+ } else if(is.null(tag.name)){
+ # hm, not a XiMpLe object and no known tag name :-/
+ # if this is simply a character string, the tag name will become ""
+ tag.name <- XMLName(XMLChildren(parseXMLTree(XML.var, object=TRUE))[[1]])
+ } else {}
- # check validity of modifiers value
- if(!is.null(modifiers)){
- if(identical(modifiers, "all")){
- if(tag.name %in% names(all.valid.modifiers)){
- modifiers <- all.valid.modifiers[[tag.name]]
- } else {
- modifiers <- NULL
- }
- } else {
- if(identical(tag.name, "")){
- modif.tag.name <- "all"
- } else {
- modif.tag.name <- tag.name
- }
- if(isTRUE(check.modifiers)){
- modifiers <- modifiers[modif.validity(modif.tag.name,
- modifier=child.list(modifiers), warn.only=TRUE, bool=TRUE)]
- } else {}
- }
- } else {}
+ # check validity of modifiers value
+ if(!is.null(modifiers)){
+ if(identical(modifiers, "all")){
+ if(tag.name %in% names(all.valid.modifiers)){
+ modifiers <- all.valid.modifiers[[tag.name]]
+ } else {
+ modifiers <- NULL
+ }
+ } else {
+ if(identical(tag.name, "")){
+ modif.tag.name <- "all"
+ } else {
+ modif.tag.name <- tag.name
+ }
+ if(isTRUE(check.modifiers)){
+ modifiers <- modifiers[modif.validity(modif.tag.name,
+ modifier=child.list(modifiers), warn.only=TRUE, bool=TRUE)]
+ } else {}
+ }
+ } else {}
- # check for getter guessing
- if(isTRUE(guess.getter)){
- if(tag.name %in% names(JS.getters.default)){
- # special case: is a <checkbox> has a value other than
- # "true" or "false", it's probably supposed to be fetched
- # as string, not boolean
- if(isTRUE(have.XiMpLe.var) && identical(tag.name, "checkbox") &&
- any(!c(XMLAttrs(XML.var)[["value"]], XMLAttrs(XML.var)[["value_unchecked"]]) %in% c("true","false"))){
- getter <- "getString"
- } else {
- # check if a modifier is given and we have a default for it
- # modifiers were probably checked already
- ## TODO: currently this only works for one modifier of if all
- ## modifiers are fine with the same getter; maybe "getter"
- ## should become a vector like "modifiers"
- if(!is.null(modifiers) && any(modifiers %in% names(JS.getters.modif.default))){
- # find all matching modifiers
- getter.modifs <- modifiers[modifiers %in% names(JS.getters.modif.default)]
- all.getters <- unique(unlist(JS.getters.modif.default[getter.modifs]))
- if(length(all.getters) > 1){
- warning("For the modifiers you specified, different getter functions were found. Only using the first one!", call.=FALSE)
- getter <- all.getters[1]
- } else {
- getter <- all.getters
- }
- } else {
- getter <- JS.getters.default[[tag.name]]
- }
- }
- } else {}
- } else {
- # if guess.getters is off but we're dealing with <matrix> or <optionset>,
- # throw in a warning:
- if(tag.name %in% c("matrix", "optioncolumn") && identical(getter, "getValue")){
- warning(paste0("Your plugin contains the <", tag.name, "> element, but 'guess.getter' is off. ",
- "Using the default getValue() on this node might cause problems!"), call.=FALSE)
- } else {}
- }
- XML.var <- check.ID(XML.var)
- } else {
- XML.var <- check.ID(JS.var)
- }
+ # check for getter guessing
+ if(isTRUE(guess.getter)){
+ if(tag.name %in% names(JS.getters.default)){
+ # special case: is a <checkbox> has a value other than
+ # "true" or "false", it's probably supposed to be fetched
+ # as string, not boolean
+ if(isTRUE(have.XiMpLe.var) && identical(tag.name, "checkbox") &&
+ any(!c(XMLAttrs(XML.var)[["value"]], XMLAttrs(XML.var)[["value_unchecked"]]) %in% c("true","false"))){
+ getter <- "getString"
+ } else {
+ # check if a modifier is given and we have a default for it
+ # modifiers were probably checked already
+ ## TODO: currently this only works for one modifier of if all
+ ## modifiers are fine with the same getter; maybe "getter"
+ ## should become a vector like "modifiers"
+ if(!is.null(modifiers) && any(modifiers %in% names(JS.getters.modif.default))){
+ # find all matching modifiers
+ getter.modifs <- modifiers[modifiers %in% names(JS.getters.modif.default)]
+ all.getters <- unique(unlist(JS.getters.modif.default[getter.modifs]))
+ if(length(all.getters) > 1){
+ warning("For the modifiers you specified, different getter functions were found. Only using the first one!", call.=FALSE)
+ getter <- all.getters[1]
+ } else {
+ getter <- all.getters
+ }
+ } else {
+ getter <- JS.getters.default[[tag.name]]
+ }
+ }
+ } else {}
+ } else {
+ # if guess.getters is off but we're dealing with <matrix> or <optionset>,
+ # throw in a warning:
+ if(tag.name %in% c("matrix", "optioncolumn") && identical(getter, "getValue")){
+ warning(paste0("Your plugin contains the <", tag.name, "> element, but 'guess.getter' is off. ",
+ "Using the default getValue() on this node might cause problems!"), call.=FALSE)
+ } else {}
+ }
+ XML.var <- check.ID(XML.var)
+ } else {
+ XML.var <- check.ID(JS.var)
+ }
- if(is.null(JS.prefix)){
- JS.prefix <- ""
- } else {}
+ if(is.null(JS.prefix)){
+ JS.prefix <- ""
+ } else {}
- if(isTRUE(names.only)){
- results <- c()
- if(is.null(modifiers) || isTRUE(default)){
- results <- camelCode(c(JS.prefix, JS.var))
- } else {}
- if(!is.null(modifiers)){
- results <- c(results,
- sapply(modifiers, function(this.modif){camelCode(c(JS.prefix, JS.var, this.modif))})
- )
- } else {}
- } else {
- if(is.null(modifiers)){
- modifiers <- list()
- } else {}
- results <- new("rk.JS.var",
- JS.var=JS.var,
- XML.var=XML.var,
- prefix=JS.prefix,
- modifiers=as.list(modifiers),
- default=default,
- join=join,
- getter=getter)
- }
+ if(isTRUE(names.only)){
+ results <- c()
+ if(is.null(modifiers) || isTRUE(default)){
+ results <- camelCode(c(JS.prefix, JS.var))
+ } else {}
+ if(!is.null(modifiers)){
+ results <- c(results,
+ sapply(modifiers, function(this.modif){camelCode(c(JS.prefix, JS.var, this.modif))})
+ )
+ } else {}
+ } else {
+ if(is.null(modifiers)){
+ modifiers <- list()
+ } else {}
+ results <- new("rk.JS.var",
+ JS.var=JS.var,
+ XML.var=XML.var,
+ prefix=JS.prefix,
+ modifiers=as.list(modifiers),
+ default=default,
+ join=join,
+ getter=getter)
+ }
- return(results)
+ return(results)
} ## end function get.JS.vars()
## function ID.prefix()
ID.prefix <- function(initial, abbr=TRUE, length=3, dot=FALSE){
- if(isTRUE(abbr)){
- prfx <- abbreviate(initial, minlength=length, strict=TRUE)
- } else {
- # currently empty, but can later be used to define fixed abbreviations
- prfx <- NULL
- }
- if(isTRUE(dot)){
- prfx <- paste0(prfx, ".")
- } else {
- prfx <- paste0(prfx, "_")
- }
- return(prfx)
+ if(isTRUE(abbr)){
+ prfx <- abbreviate(initial, minlength=length, strict=TRUE)
+ } else {
+ # currently empty, but can later be used to define fixed abbreviations
+ prfx <- NULL
+ }
+ if(isTRUE(dot)){
+ prfx <- paste0(prfx, ".")
+ } else {
+ prfx <- paste0(prfx, "_")
+ }
+ return(prfx)
} ## end function ID.prefix()
## function node.soup()
# pastes the nodes as XML, only alphanumeric characters, e.g. to generate auto-IDs
node.soup <- function(nodes){
- the.soup <- paste0(unlist(sapply(child.list(nodes), function(this.node){
- if(is.XiMpLe.node(this.node)){
- return(gsub("[^[:alnum:]]", "", pasteXML(this.node, shine=0)))
- } else {
- stop(simpleError("Nodes must be of class XiMpLe.node!"))
- }
- })), collapse="")
- return(the.soup)
+ the.soup <- paste0(unlist(sapply(child.list(nodes), function(this.node){
+ if(is.XiMpLe.node(this.node)){
+ return(gsub("[^[:alnum:]]", "", pasteXML(this.node, shine=0)))
+ } else {
+ stop(simpleError("Nodes must be of class XiMpLe.node!"))
+ }
+ })), collapse="")
+ return(the.soup)
} ## end function node.soup()
## function XML2person()
# extracts the person/author info from XML "about" nodes
XML2person <- function(node, eval=FALSE){
- if(is.XiMpLe.node(node)){
- # check if this is *really* a about section, otherwise die of boredom
- if(!identical(XMLName(node), "about")){
- stop(simpleError("I don't know what this is, but 'about' is not an about section!"))
- } else {}
- } else {
- stop(simpleError("'about' must be a XiMpLe.node, see ?rk.XML.about()!"))
- }
- make.vector <- function(value){
- if(grepl(",", value)){
- value <- paste0("c(\"", paste(trim(unlist(strsplit(value, ","))), collapse="\", \""), "\")")
- } else {
- value <- paste0("\"", value, "\"")
- }
- return(value)
- }
- all.authors <- c()
- for (this.child in XMLChildren(node)){
- if(identical(XMLName(this.child), "author")){
- attrs <- XMLAttrs(this.child)
- given <- make.vector(attrs[["given"]])
- family <- make.vector(attrs[["family"]])
- email <- make.vector(attrs[["email"]])
- role <- make.vector(attrs[["role"]])
- this.author <- paste0("person(given=", given, ", family=", family, ", email=", email, ", role=", role, ")")
- all.authors[length(all.authors) + 1] <- this.author
- } else {}
- }
- if(length(all.authors) > 1){
- all.authors <- paste0("c(", paste(all.authors, collapse=", "), ")")
- } else {}
- if(isTRUE(eval)){
- all.authors <- eval(parse(text=all.authors))
- } else {}
- return(all.authors)
+ if(is.XiMpLe.node(node)){
+ # check if this is *really* a about section, otherwise die of boredom
+ if(!identical(XMLName(node), "about")){
+ stop(simpleError("I don't know what this is, but 'about' is not an about section!"))
+ } else {}
+ } else {
+ stop(simpleError("'about' must be a XiMpLe.node, see ?rk.XML.about()!"))
+ }
+ make.vector <- function(value){
+ if(grepl(",", value)){
+ value <- paste0("c(\"", paste(trim(unlist(strsplit(value, ","))), collapse="\", \""), "\")")
+ } else {
+ value <- paste0("\"", value, "\"")
+ }
+ return(value)
+ }
+ all.authors <- c()
+ for (this.child in XMLChildren(node)){
+ if(identical(XMLName(this.child), "author")){
+ attrs <- XMLAttrs(this.child)
+ given <- make.vector(attrs[["given"]])
+ family <- make.vector(attrs[["family"]])
+ email <- make.vector(attrs[["email"]])
+ role <- make.vector(attrs[["role"]])
+ this.author <- paste0("person(given=", given, ", family=", family, ", email=", email, ", role=", role, ")")
+ all.authors[length(all.authors) + 1] <- this.author
+ } else {}
+ }
+ if(length(all.authors) > 1){
+ all.authors <- paste0("c(", paste(all.authors, collapse=", "), ")")
+ } else {}
+ if(isTRUE(eval)){
+ all.authors <- eval(parse(text=all.authors))
+ } else {}
+ return(all.authors)
} ## end function XML2person()
@@ -530,116 +530,116 @@
# suggest=TRUE: Depends: R & RKWard; Suggests: packages
# suggest=FALSE: Depends: R & RKWard & packages; suggests: none
XML2dependencies <- function(node, suggest=TRUE, mode="suggest"){
- if(!isTRUE(suggest) && identical(mode, "suggest")){
- return("")
- } else {}
- if(is.XiMpLe.node(node)){
- # check if this is *really* a about section, otherwise die of boredom
- if(!XMLName(node) %in% c("about", "dependencies")){
- stop(simpleError("Please provide a valid about or dependencies section!"))
- } else {}
- } else {
- stop(simpleError("'about' and/or 'dependencies' must be XiMpLe.nodes, see ?rk.XML.about() and ?rk.XML.dependencies()!"))
- }
- got.deps <- XMLScan(node, "dependencies")
- if(!is.null(got.deps)){
- deps.packages <- list()
- # first see if RKWard and R versions are given
- deps.RkR <- XMLAttrs(got.deps)
- deps.RkR.options <- names(deps.RkR)
- R.min <- ifelse("R_min_version" %in% deps.RkR.options, paste0(">= ", deps.RkR[["R_min_version"]]), "")
- R.max <- ifelse("R_max_version" %in% deps.RkR.options, paste0("< ", deps.RkR[["R_max_version"]]), "")
- R.version.indices <- sum(!identical(R.min, ""), !identical(R.max, ""))
- if(R.version.indices > 0 & identical(mode, "depends")){
- deps.packages[[length(deps.packages) + 1]] <- paste0("R (", R.min, ifelse(R.version.indices > 1, ", ", ""), R.max, ")")
- } else {}
- Rk.min <- ifelse("rkward_min_version" %in% deps.RkR.options, paste0(">= ", deps.RkR[["rkward_min_version"]]), "")
- Rk.max <- ifelse("rkward_max_version" %in% deps.RkR.options, paste0("< ", deps.RkR[["rkward_max_version"]]), "")
- Rk.version.indices <- sum(!identical(Rk.min, ""), !identical(Rk.max, ""))
- if(Rk.version.indices > 0 && identical(mode, "depends")){
- deps.packages[[length(deps.packages) + 1]] <- paste0("rkward (", Rk.min, ifelse(Rk.version.indices > 1, ", ", ""), Rk.max, ")")
- } else {}
- check.deps.pckg <- sapply(XMLChildren(got.deps), function(this.child){identical(XMLName(this.child), "package")})
- if(any(check.deps.pckg) && ((isTRUE(suggest) && identical(mode, "suggest")) | !isTRUE(suggest))){
- deps.packages[[length(deps.packages) + 1]] <- paste(sapply(which(check.deps.pckg), function(this.pckg){
- this.pckg.dep <- XMLAttrs(XMLChildren(got.deps)[[this.pckg]])
- pckg.options <- names(this.pckg.dep)
- pckg.name <- this.pckg.dep[["name"]]
- pckg.min <- ifelse("min" %in% pckg.options, paste0(">= ", this.pckg.dep[["min"]]), "")
- pckg.max <- ifelse("max" %in% pckg.options, paste0("< ", this.pckg.dep[["max"]]), "")
- version.indices <- sum(!identical(pckg.min, ""), !identical(pckg.max, ""))
- if(version.indices > 0){
- pckg.version <- paste0(" (", pckg.min, ifelse(version.indices > 1, ", ", ""), pckg.max, ")")
- } else {
- pckg.version <- ""
- }
- return(paste0(pckg.name, pckg.version))
- }), collapse=", ")
- } else {}
- results <- paste(unlist(deps.packages), collapse=", ")
- } else {
- results <- ""
- }
- return(results)
+ if(!isTRUE(suggest) && identical(mode, "suggest")){
+ return("")
+ } else {}
+ if(is.XiMpLe.node(node)){
+ # check if this is *really* a about section, otherwise die of boredom
+ if(!XMLName(node) %in% c("about", "dependencies")){
+ stop(simpleError("Please provide a valid about or dependencies section!"))
+ } else {}
+ } else {
+ stop(simpleError("'about' and/or 'dependencies' must be XiMpLe.nodes, see ?rk.XML.about() and ?rk.XML.dependencies()!"))
+ }
+ got.deps <- XMLScan(node, "dependencies")
+ if(!is.null(got.deps)){
+ deps.packages <- list()
+ # first see if RKWard and R versions are given
+ deps.RkR <- XMLAttrs(got.deps)
+ deps.RkR.options <- names(deps.RkR)
+ R.min <- ifelse("R_min_version" %in% deps.RkR.options, paste0(">= ", deps.RkR[["R_min_version"]]), "")
+ R.max <- ifelse("R_max_version" %in% deps.RkR.options, paste0("< ", deps.RkR[["R_max_version"]]), "")
+ R.version.indices <- sum(!identical(R.min, ""), !identical(R.max, ""))
+ if(R.version.indices > 0 & identical(mode, "depends")){
+ deps.packages[[length(deps.packages) + 1]] <- paste0("R (", R.min, ifelse(R.version.indices > 1, ", ", ""), R.max, ")")
+ } else {}
+ Rk.min <- ifelse("rkward_min_version" %in% deps.RkR.options, paste0(">= ", deps.RkR[["rkward_min_version"]]), "")
+ Rk.max <- ifelse("rkward_max_version" %in% deps.RkR.options, paste0("< ", deps.RkR[["rkward_max_version"]]), "")
+ Rk.version.indices <- sum(!identical(Rk.min, ""), !identical(Rk.max, ""))
+ if(Rk.version.indices > 0 && identical(mode, "depends")){
+ deps.packages[[length(deps.packages) + 1]] <- paste0("rkward (", Rk.min, ifelse(Rk.version.indices > 1, ", ", ""), Rk.max, ")")
+ } else {}
+ check.deps.pckg <- sapply(XMLChildren(got.deps), function(this.child){identical(XMLName(this.child), "package")})
+ if(any(check.deps.pckg) && ((isTRUE(suggest) && identical(mode, "suggest")) | !isTRUE(suggest))){
+ deps.packages[[length(deps.packages) + 1]] <- paste(sapply(which(check.deps.pckg), function(this.pckg){
+ this.pckg.dep <- XMLAttrs(XMLChildren(got.deps)[[this.pckg]])
+ pckg.options <- names(this.pckg.dep)
+ pckg.name <- this.pckg.dep[["name"]]
+ pckg.min <- ifelse("min" %in% pckg.options, paste0(">= ", this.pckg.dep[["min"]]), "")
+ pckg.max <- ifelse("max" %in% pckg.options, paste0("< ", this.pckg.dep[["max"]]), "")
+ version.indices <- sum(!identical(pckg.min, ""), !identical(pckg.max, ""))
+ if(version.indices > 0){
+ pckg.version <- paste0(" (", pckg.min, ifelse(version.indices > 1, ", ", ""), pckg.max, ")")
+ } else {
+ pckg.version <- ""
+ }
+ return(paste0(pckg.name, pckg.version))
+ }), collapse=", ")
+ } else {}
+ results <- paste(unlist(deps.packages), collapse=", ")
+ } else {
+ results <- ""
+ }
+ return(results)
} ## end function XML2dependencies()
## function get.by.role()
# filters a vector with person objects by roles
get.by.role <- function(persons, role="aut"){
- role.filter <- function(x){is.null(r <- x$role) | role %in% r}
- filtered.persons <- Filter(role.filter, persons)
- return(filtered.persons)
+ role.filter <- function(x){is.null(r <- x$role) | role %in% r}
+ filtered.persons <- Filter(role.filter, persons)
+ return(filtered.persons)
} ## end function get.by.role()
## function check.ID()
check.ID <- function(node){
- if(is.list(node)){
- return(sapply(node, check.ID))
- } else {}
+ if(is.list(node)){
+ return(sapply(node, check.ID))
+ } else {}
- if(is.XiMpLe.node(node)){
- node.ID <- XMLAttrs(node)[["id"]]
- } else if(is.character(node)){
- node.ID <- node
- } else {
- stop(simpleError("Can't find an ID!"))
- }
+ if(is.XiMpLe.node(node)){
+ node.ID <- XMLAttrs(node)[["id"]]
+ } else if(is.character(node)){
+ node.ID <- node
+ } else {
+ stop(simpleError("Can't find an ID!"))
+ }
- if(is.null(node.ID)){
- warning("ID is NULL!")
- } else {}
+ if(is.null(node.ID)){
+ warning("ID is NULL!")
+ } else {}
- names(node.ID) <- NULL
+ names(node.ID) <- NULL
- return(node.ID)
+ return(node.ID)
} ## end function check.ID()
## list with valid modifiers
all.valid.modifiers <- list(
- all=c("", "visible", "visible.not", "visible.numeric", "enabled", "enabled.not", "enabled.numeric",
- "required", "true", "false", "not", "numeric", "preprocess", "calculate", "printout", "preview"),
- browser=c("selection"),
- checkbox=c("state", "state.not", "state.numeric"),
- dropdown=c("string", "number"),
+ all=c("", "visible", "visible.not", "visible.numeric", "enabled", "enabled.not", "enabled.numeric",
+ "required", "true", "false", "not", "numeric", "preprocess", "calculate", "printout", "preview"),
+ browser=c("selection"),
+ checkbox=c("state", "state.not", "state.numeric"),
+ dropdown=c("string", "number"),
# removed embed, can be all sorts of stuff, see e.g. generic plot options
-# embed=c("code"),
+# embed=c("code"),
# for the same reason external is not listed here
- frame=c("checked", "checked.not", "checked.numeric"),
- input=c("text"),
- formula=c("model", "table", "labels", "fixed_factors", "dependent"),
- matrix=c("rows", "columns", "tsv", "cbind"), # TODO: missing a solution for 1,2,3,... here
- # option=c(),
- optionset=c("row_count", "current_row", "optioncolumn_ids"),
- preview=c("state", "state.not", "state.numeric"),
- radio=c("string", "number"),
- saveobject=c("selection", "parent", "objectname", "active"),
- spinbox=c("int", "real"),
- text=c("text"),
- varselector=c("selected", "root"),
- varslot=c("available", "selected", "source", "shortname", "label")
+ frame=c("checked", "checked.not", "checked.numeric"),
+ input=c("text"),
+ formula=c("model", "table", "labels", "fixed_factors", "dependent"),
+ matrix=c("rows", "columns", "tsv", "cbind"), # TODO: missing a solution for 1,2,3,... here
+ # option=c(),
+ optionset=c("row_count", "current_row", "optioncolumn_ids"),
+ preview=c("state", "state.not", "state.numeric"),
+ radio=c("string", "number"),
+ saveobject=c("selection", "parent", "objectname", "active"),
+ spinbox=c("int", "real"),
+ text=c("text"),
+ varselector=c("selected", "root"),
+ varslot=c("available", "selected", "source", "shortname", "label")
) ## end list with valid modifiers
@@ -647,59 +647,59 @@
# checks if a modifier is valid for an XML node, if source is XiMpLe.node
# if bool=FALSE, returns the modifier or ""
modif.validity <- function(source, modifier, ignore.empty=TRUE, warn.only=TRUE, bool=TRUE){
- if(identical(modifier, "") & isTRUE(ignore.empty)){
- if(isTRUE(bool)){
- return(TRUE)
- } else {
- return(modifier)
- }
- } else {}
+ if(identical(modifier, "") & isTRUE(ignore.empty)){
+ if(isTRUE(bool)){
+ return(TRUE)
+ } else {
+ return(modifier)
+ }
+ } else {}
- if(is.XiMpLe.node(source)){
- tag.name <- XMLName(source)
- # certain elemens/embedded plugins can have all sorts of modifiers
- if(tag.name %in% c("embed", "external", "switch")){
- if(isTRUE(bool)){
- return(TRUE)
- } else {
- return(modifier)
- }
- } else {}
- } else if(identical(source, "all")){
- tag.name <- "<any tag>"
- } else {
- tag.name <- source
- }
+ if(is.XiMpLe.node(source)){
+ tag.name <- XMLName(source)
+ # certain elemens/embedded plugins can have all sorts of modifiers
+ if(tag.name %in% c("embed", "external", "switch")){
+ if(isTRUE(bool)){
+ return(TRUE)
+ } else {
+ return(modifier)
+ }
+ } else {}
+ } else if(identical(source, "all")){
+ tag.name <- "<any tag>"
+ } else {
+ tag.name <- source
+ }
- if(tag.name %in% names(all.valid.modifiers)){
- valid.modifs <- c(all.valid.modifiers[["all"]], all.valid.modifiers[[tag.name]])
- } else if(identical(tag.name, "<any tag>")){
- valid.modifs <- unique(unlist(all.valid.modifiers))
- } else {
- valid.modifs <- c(all.valid.modifiers[["all"]])
- }
+ if(tag.name %in% names(all.valid.modifiers)){
+ valid.modifs <- c(all.valid.modifiers[["all"]], all.valid.modifiers[[tag.name]])
+ } else if(identical(tag.name, "<any tag>")){
+ valid.modifs <- unique(unlist(all.valid.modifiers))
+ } else {
+ valid.modifs <- c(all.valid.modifiers[["all"]])
+ }
- invalid.modif <- !unlist(modifier) %in% valid.modifs
- if(any(invalid.modif)){
- if(isTRUE(warn.only)){
- warning(paste0("Some modifier you provided is invalid for '",tag.name,"' and was ignored: ",
- paste(modifier[invalid.modif], collapse=", ")), call.=FALSE)
- if(isTRUE(bool)){
- return(!invalid.modif)
- } else {
- return("")
- }
- } else {
- stop(simpleError(paste0("Some modifier you provided is invalid for '",tag.name,"' and was ignored: ",
- paste(modifier[invalid.modif], collapse=", "))))
- }
- } else {
- if(isTRUE(bool)){
- return(!invalid.modif)
- } else {
- return(modifier)
- }
- }
+ invalid.modif <- !unlist(modifier) %in% valid.modifs
+ if(any(invalid.modif)){
+ if(isTRUE(warn.only)){
+ warning(paste0("Some modifier you provided is invalid for '",tag.name,"' and was ignored: ",
+ paste(modifier[invalid.modif], collapse=", ")), call.=FALSE)
+ if(isTRUE(bool)){
+ return(!invalid.modif)
+ } else {
+ return("")
+ }
+ } else {
+ stop(simpleError(paste0("Some modifier you provided is invalid for '",tag.name,"' and was ignored: ",
+ paste(modifier[invalid.modif], collapse=", "))))
+ }
+ } else {
+ if(isTRUE(bool)){
+ return(!invalid.modif)
+ } else {
+ return(modifier)
+ }
+ }
} ## end function modif.validity()
@@ -707,31 +707,31 @@
# important for certain parent nodes, as long as
# XiMpLe doesn't interpret doctypes
all.valid.children <- list(
- # 'as' is not a node, but an attribute of <copy>
- as=c("browser", "checkbox", "column", "copy",
- "dropdown", "formula", "frame", "input", "page", "radio", "row", "saveobject",
- "spinbox", "stretch", "tabbook", "text", "varselector", "varslot"),
- component=c("dependencies"),
- components=c("component"),
- context=c("menu", "!--"),
- dialog=c("browser", "checkbox", "column", "copy",
- "dropdown", "embed", "formula", "frame", "include", "input", "insert", "matrix",
- "optionset", "preview", "radio", "row", "saveobject", "spinbox", "stretch", "tabbook",
- "text", "varselector", "varslot", "!--"),
- hierarchy=c("menu", "!--"),
- logic=c("connect", "convert", "dependency_check", "external", "include", "insert",
- "script", "set", "switch"),
- menu=c("entry", "menu", "!--"),
- optionset=c("content", "logic", "optioncolumn"),
- page=c("browser", "checkbox", "column", "copy",
- "dropdown", "formula", "frame", "input", "matrix", "optionset", "page", "radio",
- "row", "saveobject", "spinbox", "stretch", "tabbook", "text", "varselector",
- "varslot", "!--"),
- settings=c("setting", "caption", "!--"),
- wizard=c("browser", "checkbox", "column", "copy",
- "dropdown", "embed", "formula", "frame", "include", "input", "insert", "matrix",
- "optionset", "page", "preview", "radio", "row", "saveobject", "spinbox", "stretch",
- "tabbook", "text", "varselector", "varslot", "!--")
+ # 'as' is not a node, but an attribute of <copy>
+ as=c("browser", "checkbox", "column", "copy",
+ "dropdown", "formula", "frame", "input", "page", "radio", "row", "saveobject",
+ "spinbox", "stretch", "tabbook", "text", "varselector", "varslot"),
+ component=c("dependencies"),
+ components=c("component"),
+ context=c("menu", "!--"),
+ dialog=c("browser", "checkbox", "column", "copy",
+ "dropdown", "embed", "formula", "frame", "include", "input", "insert", "matrix",
+ "optionset", "preview", "radio", "row", "saveobject", "spinbox", "stretch", "tabbook",
+ "text", "varselector", "varslot", "!--"),
+ hierarchy=c("menu", "!--"),
+ logic=c("connect", "convert", "dependency_check", "external", "include", "insert",
+ "script", "set", "switch"),
+ menu=c("entry", "menu", "!--"),
+ optionset=c("content", "logic", "optioncolumn"),
+ page=c("browser", "checkbox", "column", "copy",
+ "dropdown", "formula", "frame", "input", "matrix", "optionset", "page", "radio",
+ "row", "saveobject", "spinbox", "stretch", "tabbook", "text", "varselector",
+ "varslot", "!--"),
+ settings=c("setting", "caption", "!--"),
+ wizard=c("browser", "checkbox", "column", "copy",
+ "dropdown", "embed", "formula", "frame", "include", "input", "insert", "matrix",
+ "optionset", "page", "preview", "radio", "row", "saveobject", "spinbox", "stretch",
+ "tabbook", "text", "varselector", "varslot", "!--")
) ## end list with valid child nodes
@@ -743,33 +743,33 @@
# (if it shouldn't be the parent name)
# - node names: can alternatively be given instead of 'children', as character vector
valid.child <- function(parent, children, warn=FALSE, section=parent, node.names=NULL){
- if(is.null(node.names)){
- # check the node names and allow only valid ones
- node.names <- sapply(child.list(children), function(this.child){
- # if this is a plot options object, by default extract the XML slot
- # and discard the rest
- this.child <- stripXML(this.child)
+ if(is.null(node.names)){
+ # check the node names and allow only valid ones
+ node.names <- sapply(child.list(children), function(this.child){
+ # if this is a plot options object, by default extract the XML slot
+ # and discard the rest
+ this.child <- stripXML(this.child)
- if(is.XiMpLe.node(this.child)){
- return(XMLName(this.child))
- } else {
- stop(simpleError(paste0("Invalid object for ", section, " section, must be of class XiMpLe.node, but got class ", class(this.child), "!")))
- }
- })
- } else {}
+ if(is.XiMpLe.node(this.child)){
+ return(XMLName(this.child))
+ } else {
+ stop(simpleError(paste0("Invalid object for ", section, " section, must be of class XiMpLe.node, but got class ", class(this.child), "!")))
+ }
+ })
+ } else {}
- invalid.sets <- !node.names %in% all.valid.children[[parent]]
- if(any(invalid.sets)){
- return.message <- paste0("Invalid XML nodes for ", section, " section: ", paste(node.names[invalid.sets], collapse=", "))
- if(isTRUE(warn)){
- warning(return.message)
- return(FALSE)
- } else {
- stop(simpleError(return.message))
- }
- } else {
- return(TRUE)
- }
+ invalid.sets <- !node.names %in% all.valid.children[[parent]]
+ if(any(invalid.sets)){
+ return.message <- paste0("Invalid XML nodes for ", section, " section: ", paste(node.names[invalid.sets], collapse=", "))
+ if(isTRUE(warn)){
+ warning(return.message)
+ return(FALSE)
+ } else {
+ stop(simpleError(return.message))
+ }
+ } else {
+ return(TRUE)
+ }
} ## end function valid.child()
@@ -780,321 +780,321 @@
# - warn: warning or stop?
# - see: name of the function to check docs for
valid.parent <- function(parent, node, warn=FALSE, see=NULL){
- if(is.XiMpLe.node(node)){
- node.name <- XMLName(node)
- if(identical(node.name, parent)){
- return(TRUE)
- } else {
- return.message <- paste0("I don't know what this is, but '", parent, "' is not a <", parent, "> section!")
- if(isTRUE(warn)){
- warning(return.message)
- return(FALSE)
- } else {
- stop(simpleError(return.message))
- }
- }
- } else {
- stop(simpleError(
- paste0("'", parent, "' must be a XiMpLe.node",
- if(!is.null(see)){paste0(", see ?", see)},
- "!"))
- )
- }
+ if(is.XiMpLe.node(node)){
+ node.name <- XMLName(node)
+ if(identical(node.name, parent)){
+ return(TRUE)
+ } else {
+ return.message <- paste0("I don't know what this is, but '", parent, "' is not a <", parent, "> section!")
+ if(isTRUE(warn)){
+ warning(return.message)
+ return(FALSE)
+ } else {
+ stop(simpleError(return.message))
+ }
+ }
+ } else {
+ stop(simpleError(
+ paste0("'", parent, "' must be a XiMpLe.node",
+ if(!is.null(see)){paste0(", see ?", see)},
+ "!"))
+ )
+ }
} ## end function valid.parent()
## function check.type()
check.type <- function(value, type, var.name, warn.only=TRUE){
- if(inherits(value, type)){
- return(invisible(NULL))
- } else {
- msg.text <- paste0(sQuote(var.name), " should be of type ", type, "!")
- if(isTRUE(warn.only)){
- warning(msg.text)
- } else {
- stop(simpleError(msg.text))
- }
- }
+ if(inherits(value, type)){
+ return(invisible(NULL))
+ } else {
+ msg.text <- paste0(sQuote(var.name), " should be of type ", type, "!")
+ if(isTRUE(warn.only)){
+ warning(msg.text)
+ } else {
+ stop(simpleError(msg.text))
+ }
+ }
} ## end function check.type()
## function clean.name()
clean.name <- function(name, message=TRUE){
- name.orig <- name
- name <- gsub("[[:space:]]*[^[:alnum:]_.]*", "", name)
- if(!identical(name.orig, name)){
- if(isTRUE(message)){
- message(paste0("For file names ", sQuote(name.orig), " was renamed to ", sQuote(name), "."))
- } else {}
- } else {}
- return(name)
+ name.orig <- name
+ name <- gsub("[[:space:]]*[^[:alnum:]_.]*", "", name)
+ if(!identical(name.orig, name)){
+ if(isTRUE(message)){
+ message(paste0("For file names ", sQuote(name.orig), " was renamed to ", sQuote(name), "."))
+ } else {}
+ } else {}
+ return(name)
} ## end function clean.name()
## function paste.JS.ite()
paste.JS.ite <- function(object, level=1, indent.by="\t", recurse=FALSE, empty.e=FALSE){
- stopifnot(inherits(object, "rk.JS.ite"))
- # check indentation
- main.indent <- indent(level, by=indent.by)
- scnd.indent <- indent(level+1, by=indent.by)
+ stopifnot(inherits(object, "rk.JS.ite"))
+ # check indentation
+ main.indent <- indent(level, by=indent.by)
+ scnd.indent <- indent(level+1, by=indent.by)
- # if this is not a single "if" but an "else if", do not indent
- if(isTRUE(recurse)){
- ifJS <- paste0("if(", slot(object, "ifJS"), ") {\n")
- } else {
- ifJS <- paste0(main.indent, "if(", slot(object, "ifJS"), ") {\n")
- }
+ # if this is not a single "if" but an "else if", do not indent
+ if(isTRUE(recurse)){
+ ifJS <- paste0("if(", slot(object, "ifJS"), ") {\n")
+ } else {
+ ifJS <- paste0(main.indent, "if(", slot(object, "ifJS"), ") {\n")
+ }
- if(nchar(slot(object, "thenJS")) > 0) {
- # chop off beginning indent strings, otherwiese they ruin the code layout
- thenJS.clean <- gsub(paste0("^", indent.by, "*"), "", slot(object, "thenJS"))
- thenJS <- paste0(scnd.indent, thenJS.clean, "\n", main.indent, "}")
- } else {
- # if there is another rk.JS.ite object, call with recursion
- if(length(slot(object, "thenifJS")) == 1){
- thenJS <- paste0(paste.JS.ite(slot(object, "thenifJS")[[1]], level=level+1, indent.by=indent.by), "\n", main.indent, "}")
- } else {}
- }
+ if(nchar(slot(object, "thenJS")) > 0) {
+ # chop off beginning indent strings, otherwiese they ruin the code layout
+ thenJS.clean <- gsub(paste0("^", indent.by, "*"), "", slot(object, "thenJS"))
+ thenJS <- paste0(scnd.indent, thenJS.clean, "\n", main.indent, "}")
+ } else {
+ # if there is another rk.JS.ite object, call with recursion
+ if(length(slot(object, "thenifJS")) == 1){
+ thenJS <- paste0(paste.JS.ite(slot(object, "thenifJS")[[1]], level=level+1, indent.by=indent.by), "\n", main.indent, "}")
+ } else {}
+ }
- if(nchar(slot(object, "elseJS")) > 0) {
- # chop off beginning indent strings, otherwiese they ruin the code layout
- elseJS.clean <- gsub(paste0("^", indent.by, "*"), "", slot(object, "elseJS"))
- elseJS <- paste0(" else {\n", scnd.indent, elseJS.clean, "\n", main.indent, "}")
- } else {
- # if there is another rk.JS.ite object, call with recursion
- if(length(slot(object, "elifJS")) == 1){
- elseJS <- paste0(" else ", paste.JS.ite(slot(object, "elifJS")[[1]], level=level, indent.by=indent.by, recurse=TRUE))
- } else {
- if(isTRUE(empty.e)){
- # close for sure with an empty "else"
- elseJS <- " else {}"
- } else {
- elseJS <- NULL
- }
- }
- }
+ if(nchar(slot(object, "elseJS")) > 0) {
+ # chop off beginning indent strings, otherwiese they ruin the code layout
+ elseJS.clean <- gsub(paste0("^", indent.by, "*"), "", slot(object, "elseJS"))
+ elseJS <- paste0(" else {\n", scnd.indent, elseJS.clean, "\n", main.indent, "}")
+ } else {
+ # if there is another rk.JS.ite object, call with recursion
+ if(length(slot(object, "elifJS")) == 1){
+ elseJS <- paste0(" else ", paste.JS.ite(slot(object, "elifJS")[[1]], level=level, indent.by=indent.by, recurse=TRUE))
+ } else {
+ if(isTRUE(empty.e)){
+ # close for sure with an empty "else"
+ elseJS <- " else {}"
+ } else {
+ elseJS <- NULL
+ }
+ }
+ }
- result <- paste0(ifJS, thenJS, elseJS, collapse="")
+ result <- paste0(ifJS, thenJS, elseJS, collapse="")
- return(result)
+ return(result)
} ## end function paste.JS.ite()
## function paste.JS.array()
paste.JS.array <- function(object, level=2, indent.by="\t", funct=NULL){
- stopifnot(inherits(object, "rk.JS.arr"))
- # check indentation
- main.indent <- indent(level, by=indent.by)
- scnd.indent <- indent(level+1, by=indent.by)
+ stopifnot(inherits(object, "rk.JS.arr"))
+ # check indentation
+ main.indent <- indent(level, by=indent.by)
+ scnd.indent <- indent(level+1, by=indent.by)
- arr.name <- slot(object, "arr.name")
- opt.name <- slot(object, "opt.name")
- variables <- slot(object, "variables")
- quote <- slot(object, "quote")
- option <- slot(object, "option")
- if(is.null(funct)){
- funct <- slot(object, "funct")
- } else {}
- if(is.null(funct) | identical(funct, "")){
- funct.start <- ""
- funct.end <- ""
- } else {
- funct.start <- paste0(funct, "(")
- funct.end <- ")"
- }
-
- JS.array <- paste0(
- main.indent, "// define the array ", arr.name, " for values of R option \"", option, "\"\n",
- main.indent, "var ", arr.name, " = new Array();\n",
- main.indent, arr.name, ".push(",
- paste(variables, collapse=", "), ");\n",
- main.indent, "// clean array ", arr.name, " from empty strings\n",
- main.indent, arr.name, " = ", arr.name, ".filter(String);\n",
- main.indent, "// set the actual variable ", opt.name,
- ifelse(identical(option, ""), "", paste0(" for R option \"", option)),
- ifelse(identical(funct, ""), "\"", paste0("=", funct, "()\"")), "\n",
- main.indent, "if(", arr.name, ".length > 0) {\n",
- scnd.indent, "var ", opt.name, " = \", ",
- ifelse(identical(option, ""), "", paste0(option, "=")),
- ifelse(isTRUE(quote),
- paste0(funct.start, "\\\"\" + ", arr.name, ".join(\"\\\", \\\"\") + \"\\\"",funct.end,"\";\n"),
- paste0(funct.start, "\" + ", arr.name, ".join(\", \") + \"",funct.end,"\";\n")
- ),
- main.indent, "} else {\n",
- scnd.indent, "var ", opt.name, " = \"\";\n",
- main.indent, "}\n")
+ arr.name <- slot(object, "arr.name")
+ opt.name <- slot(object, "opt.name")
+ variables <- slot(object, "variables")
+ quote <- slot(object, "quote")
+ option <- slot(object, "option")
+ if(is.null(funct)){
+ funct <- slot(object, "funct")
+ } else {}
+ if(is.null(funct) | identical(funct, "")){
+ funct.start <- ""
+ funct.end <- ""
+ } else {
+ funct.start <- paste0(funct, "(")
+ funct.end <- ")"
+ }
+
+ JS.array <- paste0(
+ main.indent, "// define the array ", arr.name, " for values of R option \"", option, "\"\n",
+ main.indent, "var ", arr.name, " = new Array();\n",
+ main.indent, arr.name, ".push(",
+ paste(variables, collapse=", "), ");\n",
+ main.indent, "// clean array ", arr.name, " from empty strings\n",
+ main.indent, arr.name, " = ", arr.name, ".filter(String);\n",
+ main.indent, "// set the actual variable ", opt.name,
+ ifelse(identical(option, ""), "", paste0(" for R option \"", option)),
+ ifelse(identical(funct, ""), "\"", paste0("=", funct, "()\"")), "\n",
+ main.indent, "if(", arr.name, ".length > 0) {\n",
+ scnd.indent, "var ", opt.name, " = \", ",
+ ifelse(identical(option, ""), "", paste0(option, "=")),
+ ifelse(isTRUE(quote),
+ paste0(funct.start, "\\\"\" + ", arr.name, ".join(\"\\\", \\\"\") + \"\\\"",funct.end,"\";\n"),
+ paste0(funct.start, "\" + ", arr.name, ".join(\", \") + \"",funct.end,"\";\n")
+ ),
+ main.indent, "} else {\n",
+ scnd.indent, "var ", opt.name, " = \"\";\n",
+ main.indent, "}\n")
- return(JS.array)
+ return(JS.array)
} ## end function paste.JS.array()
## function paste.JS.options()
paste.JS.options <- function(object, level=2, indent.by="\t", array=NULL, funct=NULL){
- stopifnot(inherits(object, "rk.JS.opt"))
- # check indentation
- main.indent <- indent(level, by=indent.by)
- scnd.indent <- indent(level+1, by=indent.by)
+ stopifnot(inherits(object, "rk.JS.opt"))
+ # check indentation
+ main.indent <- indent(level, by=indent.by)
+ scnd.indent <- indent(level+1, by=indent.by)
- variable <- slot(object, "var.name")
- option <- slot(object, "opt.name")
- arr.name <- camelCode(c("arr", variable))
- collapse <- slot(object, "collapse")
- ifs <- slot(object, "ifs")
- if(is.null(array)){
- array <- slot(object, "array")
- } else {}
- if(is.null(funct)){
- funct <- slot(object, "funct")
- } else {}
- if(is.null(funct) | identical(funct, "")){
- funct.start <- ""
- funct.end <- ""
- } else {
- funct.start <- paste0(funct, "(")
- funct.end <- ")"
- }
+ variable <- slot(object, "var.name")
+ option <- slot(object, "opt.name")
+ arr.name <- camelCode(c("arr", variable))
+ collapse <- slot(object, "collapse")
+ ifs <- slot(object, "ifs")
+ if(is.null(array)){
+ array <- slot(object, "array")
+ } else {}
+ if(is.null(funct)){
+ funct <- slot(object, "funct")
+ } else {}
+ if(is.null(funct) | identical(funct, "")){
+ funct.start <- ""
+ funct.end <- ""
+ } else {
+ funct.start <- paste0(funct, "(")
+ funct.end <- ")"
+ }
- # a function to add the object stuff to ite objects
- add.opts <- function(this.ite, collapse, array){
- if(isTRUE(array)){
- slot(this.ite, "thenJS") <- paste0(arr.name, ".push(", slot(this.ite, "thenJS"),");")
- } else {
- slot(this.ite, "thenJS") <- paste0(variable, " += ", collapse, slot(this.ite, "thenJS"),";")
- }
- if(length(slot(this.ite, "elifJS")) == 1){
- slot(this.ite, "elifJS") <- list(add.opts(slot(this.ite, "elifJS")[[1]]))
- } else {}
- return(this.ite)
- }
+ # a function to add the object stuff to ite objects
+ add.opts <- function(this.ite, collapse, array){
+ if(isTRUE(array)){
+ slot(this.ite, "thenJS") <- paste0(arr.name, ".push(", slot(this.ite, "thenJS"),");")
+ } else {
+ slot(this.ite, "thenJS") <- paste0(variable, " += ", collapse, slot(this.ite, "thenJS"),";")
+ }
+ if(length(slot(this.ite, "elifJS")) == 1){
+ slot(this.ite, "elifJS") <- list(add.opts(slot(this.ite, "elifJS")[[1]]))
+ } else {}
+ return(this.ite)
+ }
- # the object class makes sure this is a list of rk.JS.ite objects
- ifs.pasted <- sapply(1:length(ifs), function(thisIf.num){
- thisIf <- ifs[[thisIf.num]]
- # skip the first collapse
- if(thisIf.num > 1){
- this.collapse <- collapse
- } else {
- this.collapse <- ""
- }
- paste.JS.ite(add.opts(thisIf, collapse=this.collapse, array=array), level=level+1, indent.by=indent.by)
- })
+ # the object class makes sure this is a list of rk.JS.ite objects
+ ifs.pasted <- sapply(1:length(ifs), function(thisIf.num){
+ thisIf <- ifs[[thisIf.num]]
+ # skip the first collapse
+ if(thisIf.num > 1){
+ this.collapse <- collapse
+ } else {
+ this.collapse <- ""
+ }
+ paste.JS.ite(add.opts(thisIf, collapse=this.collapse, array=array), level=level+1, indent.by=indent.by)
+ })
#return(ifs.pasted)
- JS.options <- paste0(
- if(isTRUE(array)){
- paste0(
- main.indent, "// define the array ", arr.name, " for values of R option \"", option, "\"\n",
- main.indent, "var ", arr.name, " = new Array();\n")
- } else {
- paste0(main.indent, "var ", variable, " = \"\";\n")
- },
- paste0(ifs.pasted, collapse="\n"), "\n",
- if(isTRUE(array)){
- paste0(
- main.indent, "// clean array ", arr.name, " from empty strings\n",
- main.indent, arr.name, " = ", arr.name, ".filter(String);\n",
- main.indent, "// set the actual variable ", variable, " with all values for R option \"", option, "\"\n",
- main.indent, "if(", arr.name, ".length > 0) {\n",
- scnd.indent, "var ", variable, " = \"", collapse,
- ifelse(identical(option, ""), "", paste0(option, "=")),
- funct.start, "\" + ", arr.name, ".join(\", \") + \"",funct.end,"\";\n",
- main.indent, "} else {\n",
- scnd.indent, "var ", variable, " = \"\";\n",
- main.indent, "}\n")
- } else {})
+ JS.options <- paste0(
+ if(isTRUE(array)){
+ paste0(
+ main.indent, "// define the array ", arr.name, " for values of R option \"", option, "\"\n",
+ main.indent, "var ", arr.name, " = new Array();\n")
+ } else {
+ paste0(main.indent, "var ", variable, " = \"\";\n")
+ },
+ paste0(ifs.pasted, collapse="\n"), "\n",
+ if(isTRUE(array)){
+ paste0(
+ main.indent, "// clean array ", arr.name, " from empty strings\n",
+ main.indent, arr.name, " = ", arr.name, ".filter(String);\n",
+ main.indent, "// set the actual variable ", variable, " with all values for R option \"", option, "\"\n",
+ main.indent, "if(", arr.name, ".length > 0) {\n",
+ scnd.indent, "var ", variable, " = \"", collapse,
+ ifelse(identical(option, ""), "", paste0(option, "=")),
+ funct.start, "\" + ", arr.name, ".join(\", \") + \"",funct.end,"\";\n",
+ main.indent, "} else {\n",
+ scnd.indent, "var ", variable, " = \"\";\n",
+ main.indent, "}\n")
+ } else {})
- return(JS.options)
+ return(JS.options)
} ## end function paste.JS.options()
## function paste.JS.var()
paste.JS.var <- function(object, level=2, indent.by="\t", JS.prefix=NULL, modifiers=NULL, default=NULL, join=NULL,
- getter=NULL, names.only=FALSE, check.modifiers=FALSE){
- # paste several objects
- results <- unlist(sapply(slot(object, "vars"), function(this.obj){
- paste.JS.var(this.obj,
- level=level,
- indent.by=indent.by,
- JS.prefix=JS.prefix,
- modifiers=modifiers,
- default=default,
- join=join,
- getter=getter,
- names.only=names.only)}))
- if(!isTRUE(names.only) & !is.null(results)){
- results <- paste(results, collapse="\n")
- }
- if(!isTRUE(names.only)){
- results <- paste(results, collapse="")
- } else {}
+ getter=NULL, names.only=FALSE, check.modifiers=FALSE){
+ # paste several objects
+ results <- unlist(sapply(slot(object, "vars"), function(this.obj){
+ paste.JS.var(this.obj,
+ level=level,
+ indent.by=indent.by,
+ JS.prefix=JS.prefix,
+ modifiers=modifiers,
+ default=default,
+ join=join,
+ getter=getter,
+ names.only=names.only)}))
+ if(!isTRUE(names.only) & !is.null(results)){
+ results <- paste(results, collapse="\n")
+ }
+ if(!isTRUE(names.only)){
+ results <- paste(results, collapse="")
+ } else {}
- stopifnot(inherits(object, "rk.JS.var"))
- # check indentation
- main.indent <- indent(level, by=indent.by)
+ stopifnot(inherits(object, "rk.JS.var"))
+ # check indentation
+ main.indent <- indent(level, by=indent.by)
- JS.var <- slot(object, "JS.var")
- XML.var <- slot(object, "XML.var")
- if(is.null(JS.prefix)){
- JS.prefix <- slot(object, "prefix")
- } else {}
- if(is.null(modifiers)){
- modifiers <- slot(object, "modifiers")
- } else {}
- if(is.null(default)){
- default <- slot(object, "default")
- } else {}
- if(is.null(join)){
- join <- slot(object, "join")
- } else {}
- if(is.null(getter)){
- getter <- slot(object, "getter")
- } else {}
+ JS.var <- slot(object, "JS.var")
+ XML.var <- slot(object, "XML.var")
+ if(is.null(JS.prefix)){
+ JS.prefix <- slot(object, "prefix")
+ } else {}
+ if(is.null(modifiers)){
+ modifiers <- slot(object, "modifiers")
+ } else {}
+ if(is.null(default)){
+ default <- slot(object, "default")
+ } else {}
+ if(is.null(join)){
+ join <- slot(object, "join")
+ } else {}
+ if(is.null(getter)){
+ getter <- slot(object, "getter")
+ } else {}
- if(!identical(join, "")){
- join.code <- paste0(".split(\"\\n\").join(\"", join, "\")")
- } else {
- join.code <- ""
- }
+ if(!identical(join, "")){
+ join.code <- paste0(".split(\"\\n\").join(\"", join, "\")")
+ } else {
+ join.code <- ""
+ }
- # only paste something if there's variables outside the 'vars' slot
- if(length(nchar(JS.var)) > 0 & length(nchar(XML.var)) > 0){
- if(length(modifiers) == 0 | isTRUE(default)){
- if(isTRUE(names.only)){
- results <- c(results, camelCode(c(JS.prefix, JS.var)))
- } else {
- results <- paste0(main.indent, "var ", camelCode(c(JS.prefix, JS.var)), " = ", getter, "(\"", XML.var, "\")", join.code, ";")
- }
- } else {}
- if(length(modifiers) > 0){
- if(isTRUE(check.modifiers)){
- # check modifiers
- modifiers <- modifiers[modif.validity(source="all", modifier=modifiers, ignore.empty=TRUE, warn.only=TRUE, bool=TRUE)]
- } else {}
- modif.results <- sapply(modifiers, function(this.modif){
- if(isTRUE(names.only)){
- return(camelCode(c(JS.prefix, JS.var, this.modif)))
- } else {
- return(paste0(main.indent, "var ", camelCode(c(JS.prefix, JS.var, this.modif)),
- " = ", getter, "(\"", XML.var, ".", this.modif, "\")", join.code, ";"))
- }
- })
- if(identical(results, "")){
- results <- modif.results
- } else {
- results <- c(results, modif.results)
- }
- }
- } else {}
+ # only paste something if there's variables outside the 'vars' slot
+ if(length(nchar(JS.var)) > 0 & length(nchar(XML.var)) > 0){
+ if(length(modifiers) == 0 | isTRUE(default)){
+ if(isTRUE(names.only)){
+ results <- c(results, camelCode(c(JS.prefix, JS.var)))
+ } else {
+ results <- paste0(main.indent, "var ", camelCode(c(JS.prefix, JS.var)), " = ", getter, "(\"", XML.var, "\")", join.code, ";")
+ }
+ } else {}
+ if(length(modifiers) > 0){
+ if(isTRUE(check.modifiers)){
+ # check modifiers
+ modifiers <- modifiers[modif.validity(source="all", modifier=modifiers, ignore.empty=TRUE, warn.only=TRUE, bool=TRUE)]
+ } else {}
+ modif.results <- sapply(modifiers, function(this.modif){
+ if(isTRUE(names.only)){
+ return(camelCode(c(JS.prefix, JS.var, this.modif)))
+ } else {
+ return(paste0(main.indent, "var ", camelCode(c(JS.prefix, JS.var, this.modif)),
+ " = ", getter, "(\"", XML.var, ".", this.modif, "\")", join.code, ";"))
+ }
+ })
+ if(identical(results, "")){
+ results <- modif.results
+ } else {
+ results <- c(results, modif.results)
+ }
+ }
+ } else {}
- if(isTRUE(names.only)){
- results <- c(results)
- } else {
- results <- paste(results, collapse="\n")
- }
-
- return(results)
+ if(isTRUE(names.only)){
+ results <- c(results)
+ } else {
+ results <- paste(results, collapse="\n")
+ }
+
+ return(results)
} ## end function paste.JS.var()
@@ -1103,38 +1103,38 @@
# this wrapper takes both, "about" and "dependencies" arguments,
# splits dependencies off and returns both in a list
dependenciesCompatWrapper <- function(dependencies, about, hints=FALSE){
- if(!is.null(about)){
- # check if this is *really* a about section
- valid.parent("about", node=about, see="rk.XML.about")
- # check for <dependencies> in <about>; is NULL if not found
- # this will only be used if dependencies is NULL
- deps.in.about <- XMLScan(about, "dependencies")
- if(!is.null(deps.in.about)){
- warning("<dependencies> inside <about> is deprecated, use the 'dependencies' argument instead!")
- # remove the misplaced node
- XMLScan(about, "dependencies") <- NULL
- }
- } else {
- if(isTRUE(hints)){
- about <- XMLNode("!--", XMLNode("about", ""))
- } else {}
- deps.in.about <- NULL
- }
+ if(!is.null(about)){
+ # check if this is *really* a about section
+ valid.parent("about", node=about, see="rk.XML.about")
+ # check for <dependencies> in <about>; is NULL if not found
+ # this will only be used if dependencies is NULL
+ deps.in.about <- XMLScan(about, "dependencies")
+ if(!is.null(deps.in.about)){
+ warning("<dependencies> inside <about> is deprecated, use the 'dependencies' argument instead!")
+ # remove the misplaced node
+ XMLScan(about, "dependencies") <- NULL
+ }
+ } else {
+ if(isTRUE(hints)){
+ about <- XMLNode("!--", XMLNode("about", ""))
+ } else {}
+ deps.in.about <- NULL
+ }
- # initialize results list
- results <- list(about=about)
+ # initialize results list
+ results <- list(about=about)
- if(!is.null(dependencies)){
- # check if this is *really* a dependencies section
- valid.parent("dependencies", node=dependencies, see="rk.XML.dependencies")
- results[["dependencies"]] <- dependencies
- } else if(is.XiMpLe.node(deps.in.about)){
- results[["dependencies"]] <- deps.in.about
- } else if(isTRUE(hints)){
- dependencies.XML <- XMLNode("!--", XMLNode("dependencies", ""))
- results[["dependencies"]] <- dependencies.XML
- } else {
- results[["dependencies"]] <- NULL
- }
- return(results)
+ if(!is.null(dependencies)){
+ # check if this is *really* a dependencies section
+ valid.parent("dependencies", node=dependencies, see="rk.XML.dependencies")
+ results[["dependencies"]] <- dependencies
+ } else if(is.XiMpLe.node(deps.in.about)){
+ results[["dependencies"]] <- deps.in.about
+ } else if(isTRUE(hints)){
+ dependencies.XML <- XMLNode("!--", XMLNode("dependencies", ""))
+ results[["dependencies"]] <- dependencies.XML
+ } else {
+ results[["dependencies"]] <- NULL
+ }
+ return(results)
} ## end function dependenciesCompatWrapper()
Modified: trunk/rkward/packages/rkwarddev/R/rk.JS.arr-class.R
===================================================================
--- trunk/rkward/packages/rkwarddev/R/rk.JS.arr-class.R 2014-03-06 12:23:58 UTC (rev 4775)
+++ trunk/rkward/packages/rkwarddev/R/rk.JS.arr-class.R 2014-03-06 14:40:08 UTC (rev 4776)
@@ -4,22 +4,22 @@
# produced by rk.JS.array()
setClass("rk.JS.arr",
- representation=representation(
- arr.name="character",
- opt.name="character",
- IDs="vector",
- variables="vector",
- funct="character",
- quote="logical",
- option="character"
- ),
- prototype(
- arr.name=character(),
- opt.name=character(),
- IDs=c(),
- variables=c(),
- funct="c",
- quote=FALSE,
- option=character()
- )
+ representation=representation(
+ arr.name="character",
+ opt.name="character",
+ IDs="vector",
+ variables="vector",
+ funct="character",
+ quote="logical",
+ option="character"
+ ),
+ prototype(
+ arr.name=character(),
+ opt.name=character(),
+ IDs=c(),
+ variables=c(),
+ funct="c",
+ quote=FALSE,
+ option=character()
+ )
)
Modified: trunk/rkward/packages/rkwarddev/R/rk.JS.array.R
===================================================================
--- trunk/rkward/packages/rkwarddev/R/rk.JS.array.R 2014-03-06 12:23:58 UTC (rev 4775)
+++ trunk/rkward/packages/rkwarddev/R/rk.JS.array.R 2014-03-06 14:40:08 UTC (rev 4776)
@@ -5,22 +5,22 @@
#' then joined into the desired argument type.
#'
#' @param option A character string, naming, e.g., an option of an R function which should be
-#' constructed from several variables.
+#' constructed from several variables.
#' @param variables A list with either character strings (the names of the variables to combine to a vector or list),
-#' or objects of class \code{XiMpLe.node} with plugin XML nodes (whose ID will be extracted and used).
+#' or objects of class \code{XiMpLe.node} with plugin XML nodes (whose ID will be extracted and used).
#' @param funct Character string, name of the R function to be called to combine the options, e.g. "list" for \code{list()},
-#' or "c" for \code{c()}.
+#' or "c" for \code{c()}.
#' @param var.prefix A character string. sets a global string to be used as a prefix for the JS variable names.
#' @param quote Logical, if \code{TRUE}, the values will be quoted in the resulting R code (might be neccessary
-#' for character values).
+#' for character values).
#' @return An object of class \code{rk.JS.arr}.
#' @export
#' @seealso \code{\link[rkwarddev:rk.paste.JS]{rk.paste.JS}},
-#' \code{\link[rkwarddev:rk.JS.options]{rk.JS.options}},
-#' \code{\link[rkwarddev:rk.JS.vars]{rk.JS.vars}},
-#' \code{\link[rkwarddev:echo]{echo}},
-#' \code{\link[rkwarddev:id]{id}},
-#' and the \href{help:rkwardplugins}{Introduction to Writing Plugins for RKWard}
+#' \code{\link[rkwarddev:rk.JS.options]{rk.JS.options}},
+#' \code{\link[rkwarddev:rk.JS.vars]{rk.JS.vars}},
+#' \code{\link[rkwarddev:echo]{echo}},
+#' \code{\link[rkwarddev:id]{id}},
+#' and the \href{help:rkwardplugins}{Introduction to Writing Plugins for RKWard}
#' @examples
#' # create three checkboxes for independent options
#' checkA <- rk.XML.cbox(label="Run Test A", value="A")
@@ -30,22 +30,22 @@
#' rk.JS.array("run.tests", variables=list(checkA, checkB, checkC), funct="list")
rk.JS.array <- function(option, variables=list(), funct="c", var.prefix=NULL, quote=FALSE){
- arr.name <- camelCode(c("arr", option))
- opt.name <- camelCode(c("opt", option))
+ arr.name <- camelCode(c("arr", option))
+ opt.name <- camelCode(c("opt", option))
- JS.array <- new("rk.JS.arr",
- arr.name=arr.name,
- opt.name=opt.name,
- IDs=check.ID(variables),
- variables=unlist(sapply(child.list(variables), function(this.var){get.JS.vars(
- JS.var=this.var,
- JS.prefix=var.prefix,
- names.only=TRUE)
- })),
- funct=funct,
- quote=quote,
- option=option
- )
+ JS.array <- new("rk.JS.arr",
+ arr.name=arr.name,
+ opt.name=opt.name,
+ IDs=check.ID(variables),
+ variables=unlist(sapply(child.list(variables), function(this.var){get.JS.vars(
+ JS.var=this.var,
+ JS.prefix=var.prefix,
+ names.only=TRUE)
+ })),
+ funct=funct,
+ quote=quote,
+ option=option
+ )
- return(JS.array)
+ return(JS.array)
}
Modified: trunk/rkward/packages/rkwarddev/R/rk.JS.doc.R
===================================================================
--- trunk/rkward/packages/rkwarddev/R/rk.JS.doc.R 2014-03-06 12:23:58 UTC (rev 4775)
+++ trunk/rkward/packages/rkwarddev/R/rk.JS.doc.R 2014-03-06 14:40:08 UTC (rev 4776)
@@ -4,148 +4,148 @@
#'
#' @param require A character vector with names of R packages that the dialog depends on.
#' @param variables Either a character string to be included to read in all needed variables from the dialog (see \code{\link{rk.JS.scan}}),
-#' or an object of class \code{rk.JS.var} which will be coerced into character. These variables will be defined in
-#' the \code{calculate()} and/or \code{doPrintout()} functions.
+#' or an object of class \code{rk.JS.var} which will be coerced into character. These variables will be defined in
+#' the \code{calculate()} and/or \code{doPrintout()} functions.
#' @param globals Like \code{variables}, but these variables will be defined globally. If \code{variables} is set as well,
-#' the function tries to remove duplicate definitions.
+#' the function tries to remove duplicate definitions.
#' @param results.header A character string to headline the printed results. Include escapes quotes (\\") if needed.
-#' Set to \code{FALSE} or \code{""} if you need more control and want to define the header section in \code{printout}.
+#' Set to \code{FALSE} or \code{""} if you need more control and want to define the header section in \code{printout}.
#' @param preprocess A character string to be included in the \code{preprocess()} function. This string will be
-#' pasted as-is, after \code{require} has been evaluated.
+#' pasted as-is, after \code{require} has been evaluated.
#' @param calculate A character string to be included in the \code{calculate()} function. This string will be
-#' pasted as-is, after \code{variables} has been evaluated.
+#' pasted as-is, after \code{variables} has been evaluated.
#' @param printout A character string to be included in the \code{printout()} function. This string will be
-#' pasted as-is, after \code{results.header} has been evaluated. Ignored if \code{doPrintout} is set.
+#' pasted as-is, after \code{results.header} has been evaluated. Ignored if \code{doPrintout} is set.
#' @param doPrintout A character string to be included in the \code{doPrintout()} function. This string will be
-#' pasted as-is. You don't need to define a \code{preview()} function, as this will be added automatically.
-#' Use \code{ite("full", ...)} style JavaScript code to include headers etc.
+#' pasted as-is. You don't need to define a \code{preview()} function, as this will be added automatically.
+#' Use \code{ite("full", ...)} style JavaScript code to include headers etc.
#' @param load.silencer Either a character string (ID of probably a checkbox), or an object of class \code{XiMpLe.node}.
-#' This defines a switch you can add to your plugin, to set the \code{require()} call inside \code{suppressMessages()},
-#' hence suppressing all load messages (except for warnings and errors) of required packages in the output.
+#' This defines a switch you can add to your plugin, to set the \code{require()} call inside \code{suppressMessages()},
+#' hence suppressing all load messages (except for warnings and errors) of required packages in the output.
#' @param gen.info Logical, if \code{TRUE} a comment note will be written into the document,
-#' that it was generated by \code{rkwarddev} and changes should be done to the script.
+#' that it was generated by \code{rkwarddev} and changes should be done to the script.
#' @param indent.by A character string defining how indentation should be done.
#' @return A character string.
#' @seealso \code{\link[rkwarddev:rk.paste.JS]{rk.paste.JS}},
-#' \code{\link[rkwarddev:rk.JS.vars]{rk.JS.vars}},
-#' \code{\link[rkwarddev:rk.JS.array]{rk.JS.array}},
-#' \code{\link[rkwarddev:ite]{ite}},
-#' \code{\link[rkwarddev:echo]{echo}},
-#' \code{\link[rkwarddev:id]{id}},
-#' and the \href{help:rkwardplugins}{Introduction to Writing Plugins for RKWard}
+#' \code{\link[rkwarddev:rk.JS.vars]{rk.JS.vars}},
+#' \code{\link[rkwarddev:rk.JS.array]{rk.JS.array}},
+#' \code{\link[rkwarddev:ite]{ite}},
+#' \code{\link[rkwarddev:echo]{echo}},
+#' \code{\link[rkwarddev:id]{id}},
+#' and the \href{help:rkwardplugins}{Introduction to Writing Plugins for RKWard}
#' @export
rk.JS.doc <- function(require=c(), variables=NULL, globals=NULL, results.header=NULL,
- preprocess=NULL, calculate=NULL, printout=NULL, doPrintout=NULL, load.silencer=NULL, gen.info=TRUE, indent.by="\t"){
+ preprocess=NULL, calculate=NULL, printout=NULL, doPrintout=NULL, load.silencer=NULL, gen.info=TRUE, indent.by="\t"){
- # some data transformation
- if(inherits(variables, "rk.JS.var")){
- variables <- rk.paste.JS(variables)
- } else {}
- if(inherits(globals, "rk.JS.var")){
- globals <- rk.paste.JS(globals, level=1)
- } else {}
+ # some data transformation
+ if(inherits(variables, "rk.JS.var")){
+ variables <- rk.paste.JS(variables)
+ } else {}
+ if(inherits(globals, "rk.JS.var")){
+ globals <- rk.paste.JS(globals, level=1)
+ } else {}
- js.gen.info <- ifelse(isTRUE(gen.info), rk.paste.JS(generator.info, level=1), "")
+ js.gen.info <- ifelse(isTRUE(gen.info), rk.paste.JS(generator.info, level=1), "")
- if(!is.null(globals)){
- js.globals <- paste(
- "// define variables globally\n",
- paste0(globals, collapse=""))
- if(!is.null(variables)){
- # remove globals from variables, if duplicate
- # we'll split them by semicolon
- split.globs <- unlist(strsplit(rk.paste.JS(globals), ";"))
- split.vars <- unlist(strsplit(rk.paste.JS(variables), ";"))
- # for better comparison, remove all spaces
- stripped.globs <- gsub("[[:space:]]", "", split.globs)
- stripped.vars <- gsub("[[:space:]]", "", split.vars)
- # leave only variables *not* found in globals
- ok.vars <- split.vars[!stripped.vars %in% stripped.globs]
- # finally, glue back the semicolon and make one string again
- variables <- gsub("^\n*", "", paste(paste0(ok.vars, ";"), collapse=""))
- } else {}
- } else {
- js.globals <- NULL
- }
+ if(!is.null(globals)){
+ js.globals <- paste(
+ "// define variables globally\n",
+ paste0(globals, collapse=""))
+ if(!is.null(variables)){
+ # remove globals from variables, if duplicate
+ # we'll split them by semicolon
+ split.globs <- unlist(strsplit(rk.paste.JS(globals), ";"))
+ split.vars <- unlist(strsplit(rk.paste.JS(variables), ";"))
+ # for better comparison, remove all spaces
+ stripped.globs <- gsub("[[:space:]]", "", split.globs)
+ stripped.vars <- gsub("[[:space:]]", "", split.vars)
+ # leave only variables *not* found in globals
+ ok.vars <- split.vars[!stripped.vars %in% stripped.globs]
+ # finally, glue back the semicolon and make one string again
+ variables <- gsub("^\n*", "", paste(paste0(ok.vars, ";"), collapse=""))
+ } else {}
+ } else {
+ js.globals <- NULL
+ }
- js.require <- unlist(sapply(require, function(this.req){
- if(is.null(load.silencer)){
- req.result <- rk.paste.JS(echo(id("require(", this.req, ")\n")), level=2, indent.by=indent.by)
- } else {
- # get the ID, if it's a XiMpLe.node
- req.result <- rk.paste.JS(
- jsChkSuppress <- rk.JS.vars(load.silencer),
- # somehow "quietly=TRUE" doens't always do the trick
- ite(jsChkSuppress, echo("suppressMessages(require(", this.req, "))\n"), echo("require(", this.req, ")\n"))
- )
- }
- return(req.result)
- }))
- js.preprocess <- paste0("function preprocess(){\n",
- indent(2, by=indent.by), "// add requirements etc. here\n",
- paste(js.require, collapse=""),
- "\n",
- ifelse(is.null(preprocess), "", paste0("\n", preprocess, "\n")),
- "}")
+ js.require <- unlist(sapply(require, function(this.req){
+ if(is.null(load.silencer)){
+ req.result <- rk.paste.JS(echo(id("require(", this.req, ")\n")), level=2, indent.by=indent.by)
+ } else {
+ # get the ID, if it's a XiMpLe.node
+ req.result <- rk.paste.JS(
+ jsChkSuppress <- rk.JS.vars(load.silencer),
+ # somehow "quietly=TRUE" doens't always do the trick
+ ite(jsChkSuppress, echo("suppressMessages(require(", this.req, "))\n"), echo("require(", this.req, ")\n"))
+ )
+ }
+ return(req.result)
+ }))
+ js.preprocess <- paste0("function preprocess(){\n",
+ indent(2, by=indent.by), "// add requirements etc. here\n",
+ paste(js.require, collapse=""),
+ "\n",
+ ifelse(is.null(preprocess), "", paste0("\n", preprocess, "\n")),
+ "}")
- js.calculate <- paste0("function calculate(){\n",
- # for plots we only need something here if calculate is not empty
- if(is.null(doPrintout) | !is.null(calculate)){paste0(
- ifelse(is.null(variables), "", paste0(
- indent(2, by=indent.by), "// read in variables from dialog\n",
- paste(variables, collapse=""), "\n\n")),
- ifelse(is.null(calculate),
- paste0(indent(2, by=indent.by), "// generate the R code to be evaluated here\n"),
- paste0(indent(2, by=indent.by), "// the R code to be evaluated\n",calculate, "\n")))
- } else {}, "}")
-
@@ Diff output truncated at 100000 characters. @@
More information about the rkward-tracker
mailing list