[Rpad-commits] r2 - in pkg: . Rpad Rpad/R Rpad/inst Rpad/inst/basehtml Rpad/inst/tcl Rpad/man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Dec 31 06:19:16 CET 2013
Author: jedick
Date: 2013-12-31 06:19:15 +0100 (Tue, 31 Dec 2013)
New Revision: 2
Added:
pkg/Rpad/
pkg/Rpad/.Rbuildignore
pkg/Rpad/DESCRIPTION
pkg/Rpad/NAMESPACE
pkg/Rpad/R/
pkg/Rpad/R/Graphing.R
pkg/Rpad/R/HtmlTree.R
pkg/Rpad/R/LocalVersion.R
pkg/Rpad/R/Rpad-internal.R
pkg/Rpad/R/Util.R
pkg/Rpad/R/json.R
pkg/Rpad/inst/
pkg/Rpad/inst/ChangeLog
pkg/Rpad/inst/LICENSE.dojo
pkg/Rpad/inst/NEWS
pkg/Rpad/inst/README
pkg/Rpad/inst/app.profile.js
pkg/Rpad/inst/basehtml/
pkg/Rpad/inst/basehtml/BasicDocumentation.html
pkg/Rpad/inst/basehtml/Counter.js
pkg/Rpad/inst/basehtml/DojoTest.html
pkg/Rpad/inst/basehtml/Example1.Rpad
pkg/Rpad/inst/basehtml/InputExamples.Rpad
pkg/Rpad/inst/basehtml/LocalDefault.Rpad
pkg/Rpad/inst/basehtml/Rpad.css
pkg/Rpad/inst/basehtml/RpadTest.Rpad
pkg/Rpad/inst/basehtml/Rpad_body.js
pkg/Rpad/inst/basehtml/Rpad_head.js
pkg/Rpad/inst/basehtml/ServerNotes.html
pkg/Rpad/inst/basehtml/dojo.js
pkg/Rpad/inst/basehtml/myModule.js
pkg/Rpad/inst/tcl/
pkg/Rpad/inst/tcl/TCLHTTPD.license.terms
pkg/Rpad/inst/tcl/mini1.1.tcl
pkg/Rpad/inst/tcl/minihttpd.tcl
pkg/Rpad/man/
pkg/Rpad/man/Rpad-internal.Rd
pkg/Rpad/man/RpadGraphing.Rd
pkg/Rpad/man/RpadHTML.Rd
pkg/Rpad/man/RpadLocalServer.Rd
pkg/Rpad/man/RpadUtil.Rd
pkg/Rpad/man/json.Rd
Log:
initial import
Added: pkg/Rpad/.Rbuildignore
===================================================================
--- pkg/Rpad/.Rbuildignore (rev 0)
+++ pkg/Rpad/.Rbuildignore 2013-12-31 05:19:15 UTC (rev 2)
@@ -0,0 +1,3 @@
+src
+dist/dojo
+dist/dijit
Added: pkg/Rpad/DESCRIPTION
===================================================================
--- pkg/Rpad/DESCRIPTION (rev 0)
+++ pkg/Rpad/DESCRIPTION 2013-12-31 05:19:15 UTC (rev 2)
@@ -0,0 +1,17 @@
+Package: Rpad
+Title: Workbook-style, web-based interface to R
+Version: 1.3.99.0
+Author: Tom Short (EPRI), Philippe Grosjean (UMH EcoNum), Jeffrey Dick
+Description: A workbook-style user interface to R through a web
+ browser. Provides convenient interaction with an R process
+ through HTML input elements, and plotting and other HTML output
+ routines. Uses the Dojo toolkit (http://dojotoolkit.org) to
+ help build responsive web pages with Javascript. Can be used
+ with R in standalone mode or with a webserver to serve Rpad
+ pages to other users.
+Depends: graphics, utils, grDevices
+Suggests: tcltk, R2HTML
+LazyLoad: no
+Maintainer: Jeffrey Dick <j3ffdick at gmail.com>
+License: GPL (>= 2)
+URL: http://rpad.r-forge.r-project.org
Added: pkg/Rpad/NAMESPACE
===================================================================
--- pkg/Rpad/NAMESPACE (rev 0)
+++ pkg/Rpad/NAMESPACE 2013-12-31 05:19:15 UTC (rev 2)
@@ -0,0 +1,57 @@
+import(graphics)
+import(utils)
+
+export(processRpadCommands,
+ Rpad,
+ startRpadServer,
+ stopRpadServer,
+ ROutputFormat,
+ Html,
+ H,
+ HtmlTree,
+ HfromHTML,
+ BR,
+ HTMLon,
+ HTMLoff,
+ HTMLh1,
+ HTMLh2,
+ HTMLh3,
+ HTMLh4,
+ HTMLh5,
+ HTMLargs,
+ HTMLtag,
+ HTMLetag,
+ HTMLradio,
+ HTMLcheckbox,
+ HTMLselect,
+ HTMLinput,
+ HTMLlink,
+ HTMLimg,
+ HTMLembed,
+ graphoptions,
+ newgraph,
+ showgraph,
+ RpadPlotName,
+ RpadURL,
+ RpadBaseURL,
+ RpadBaseFile,
+ RpadIsLocal,
+ json
+)
+
+S3method(json, default)
+S3method(json, data.frame)
+S3method(json, list)
+S3method(json, NULL)
+S3method(json, character)
+S3method(json, logical)
+S3method(json, numeric)
+S3method(Html, data.frame)
+S3method(Html, matrix)
+S3method(Html, numeric)
+S3method(Html, integer)
+S3method(Html, default)
+S3method(HtmlTree, HtmlTree)
+S3method(HtmlTree, default)
+S3method(print, HtmlTree)
+S3method(print, json)
Added: pkg/Rpad/R/Graphing.R
===================================================================
--- pkg/Rpad/R/Graphing.R (rev 0)
+++ pkg/Rpad/R/Graphing.R 2013-12-31 05:19:15 UTC (rev 2)
@@ -0,0 +1,198 @@
+# Rpad graphing functions
+
+"graphoptions" <- function (..., reset = FALSE, override.check = TRUE) {
+ # set various Rpad graph options
+ # modified based on code from ps.options
+ l... <- length(new <- list(...))
+ old <- check.options(new = new, envir = .RpadEnv, name.opt = ".RpadGraphOptions",
+ reset = as.logical(reset), assign.opt = l... > 0, override.check = override.check)
+ if (reset || l... > 0)
+ invisible(old)
+ else old
+}
+
+"newRpadPlotName" <- function(name = "") {
+ # Create a new Rpad plot name
+ # Updates the plot counter and name
+ if (name == "") {
+ Counter <- get("Rpad.plot.counter", envir = .RpadEnv)
+ assign("Rpad.plot.counter", Counter + 1, envir = .RpadEnv)
+ name <- paste("Rpad_plot", Counter, sep="")
+ }
+ assign("Rpad.plot.name", name, envir = .RpadEnv)
+ name
+}
+
+"RpadPlotName" <- function()
+ get("Rpad.plot.name", envir = .RpadEnv)
+
+
+
+"closeCurrentDevice" <- function() {
+ # Closes the current device and if the current device is postscript,
+ # process the output with ghostscript to generate the desired output.
+ if (exists("RpadPlotParams", envir = .RpadEnv))
+ p <- get("RpadPlotParams", envir = .RpadEnv)
+ else
+ return()
+ dev.set(p$dev)
+ if (.Device == "postscript") {
+ dev.off()
+ if (.Platform$OS.type == "windows") {
+ gsexe <- Sys.getenv("R_GSCMD")
+ if (is.null(gsexe) || nchar(gsexe) == 0)
+ gsexe <- ifelse(.Platform$OS.type == "windows", "gswin32c.exe", "gs")
+
+ gshelp <- system(paste(gsexe, "-help"), intern = TRUE, invisible = TRUE)
+ st <- grep("^Available", gshelp)
+ en <- grep("^Search", gshelp)
+ gsdevs <- gshelp[(st + 1):(en - 1)]
+ devs <- c(strsplit(gsdevs, " "), recursive = TRUE)
+ if (match(p$type, devs, 0) == 0)
+ stop(paste(paste("Device ", p$type, "is not available"),
+ "Available devices are", paste(gsdevs, collapse = "\n"),
+ sep = "\n"))
+ cmd <- paste(gsexe, " -dNOPAUSE -dBATCH -q -sDEVICE=", p$type,
+ " -r", p$res, " -g", ceiling(p$res * p$width), "x",
+ ceiling(p$res * p$height), " -sOutputFile=", p$name,
+ "-%03d.", p$extension, " ", p$name, ".eps", sep = "")
+ system(cmd, intern = TRUE, invisible = TRUE)
+ }
+ for (fun in getHook("closeRpadDevice")) try(fun())
+ } else if (.Device != "null device") {
+ dev.off()
+ for (fun in getHook("closeRpadDevice")) try(fun())
+ }
+ assign("RpadPlotParams", NULL, envir = .RpadEnv)
+}
+
+"newDevice" <- function(name, extension, type, res, width, height, deviceUsesPixels, pointsize, ...) {
+ # Open a new device. If it's a ghostscript-based device, set up the
+ # ghostscript handling.
+ # If it's an R graphics device, initiate it.
+ name <- newRpadPlotName(name)
+ assign("Rpad.plot.type", type, envir = .RpadEnv)
+ if (is.character(type) && type == "Rpng") { # for builtin png support
+ unlink(grep(paste(name,".*\\.png",sep=""), dir(), value=T))
+ png(filename = paste(name,"-%03d.png",sep=""), width = width*res, height = height*res)
+ assign("RpadPlotParams", list(dev=dev.cur(), extension="png"), envir = .RpadEnv)
+ } else if (is.function(type)) {
+ # for an arbitrary R graphics device
+ unlink(grep(paste(name,".*\\.", extension, sep=""), dir(), value=T))
+ funargs <- formals(type)
+ callargs <- list(file = paste(name, "-%03d.", extension, sep=""))
+ if (deviceUsesPixels) {
+ height <- height * res
+ width <- width * res
+ }
+ extraargs <- c(list(res = res, width = width, height = height, pointsize = pointsize),
+ list(...))
+ if ("..." %in% names(funargs)) {
+ # the device function has a ..., so we (probably) can pass everything
+ callargs <- c(callargs, extraargs)
+ } else {
+ # remove arguments not used by this device function
+ callargs <- c(callargs, extraargs[intersect(names(extraargs), names(funargs))])
+ }
+ do.call("type", callargs)
+ assign("RpadPlotParams", list(dev=dev.cur(), extension=extension), envir = .RpadEnv)
+ } else {
+ # for a ghostscript device using bitmap
+ unlink(grep(paste(name,".*\\.", extension,sep=""), dir(), value=T))
+ if (.Platform$OS.type == "windows") {
+ cmd <- NULL
+ } else {
+ gsexe <- Sys.getenv("R_GSCMD")
+ if (is.null(gsexe) || nchar(gsexe) == 0)
+ gsexe <- ifelse(.Platform$OS.type == "windows", "gswin32c.exe", "gs")
+ gshelp <- system(paste(gsexe, "-help"), intern = TRUE)
+ st <- grep("^Available", gshelp)
+ en <- grep("^Search", gshelp)
+ gsdevs <- gshelp[(st + 1):(en - 1)]
+ devs <- c(strsplit(gsdevs, " "), recursive = TRUE)
+ if (match(type, devs, 0) == 0)
+ stop(paste(paste("Device ", type, "is not available"),
+ "Available devices are", paste(gsdevs, collapse = "\n"),
+ sep = "\n"))
+ cmd <- paste(gsexe, " -dNOPAUSE -dBATCH -q -sDEVICE=", type,
+ " -r", res, " -g", ceiling(res * width), "x", ceiling(res *
+ height), " -sOutputFile=", name, "-%03d.", extension, " ", sep = "")
+ }
+ postscript(file = paste(name,".eps",sep=""), width = width, height = height,
+ pointsize = pointsize,
+ paper = "special", horizontal = FALSE, print.it = !is.null(cmd),
+ command = cmd, ...)
+ assign("RpadPlotParams",
+ list(dev=dev.cur(), name=name, type=type, width=width,
+ height=height, res=res, extension=extension), envir = .RpadEnv)
+ }
+}
+
+"newgraph" <- function(name = "", extension = graphoptions()$extension,
+ type = graphoptions()$type, res = graphoptions()$res,
+ width = graphoptions()$width, height = graphoptions()$height,
+ deviceUsesPixels = graphoptions()$deviceUsesPixels,
+ pointsize = graphoptions()$pointsize, sublines = graphoptions()$sublines,
+ toplines = graphoptions()$toplines, ratio = graphoptions()$ratio,
+ leftlines = graphoptions()$leftlines, lwd = graphoptions()$lwd, ...) {
+# Start a new Rpad graph.
+# uses code from bitmap and from Frank Harrell's Hmisc routine setps
+
+ if (width == 0 & height == 0)
+ width <- 3.5
+ if (width > 0 & height == 0)
+ height <- width/ratio
+ if (width == 0 & height > 0)
+ width <- height * ratio
+ closeCurrentDevice()
+ newDevice(name, extension, type, res, width, height, deviceUsesPixels, pointsize, ...)
+
+ par(lwd = lwd, mgp = c(2.5, 0.6, 0),
+ mar = c(3 + sublines + 0.25 * (sublines > 0) +
+ 0.5, 3 + leftlines + 0.5, toplines+.4, 1) + 0.1,
+ cex.main=1,font.main=1,las=1)
+ #require(lattice)
+
+# lattice::lset(lattice::canonical.theme("postscript", color = TRUE))
+
+# if (exists('xyplot')) {
+# trellis.device(col=T)
+# lset(list(axis.line=list(col="gray50"),axis.text=list(col="black"),
+# strip.background=list(col="white"),strip.shingle=list(col="gray70")))
+# }
+ for (fun in getHook("newgraph")) try(fun())
+ invisible()
+}
+
+# Start a new Rpad graph, and show the existing graph(s).
+"showgraph" <- function(name = RpadPlotName(), link = FALSE, ...) {
+ name
+ newgraph()
+ for (n in dir(pattern = paste(name, ".*", get("RpadPlotParams", envir = .RpadEnv)$extension, sep="")))
+ print(HTMLimg(n))
+ if (link && # show a link to an EPS file if specified and if using the ghostscript graphics
+ get("Rpad.plot.type", envir = .RpadEnv) != "Rpng" &&
+ !is.function(get("Rpad.plot.type", envir = .RpadEnv)))
+ cat("<span contentEditable='false'>",
+ "<sub><a href='", RpadURL(name), ".eps'>[EPS]</a></sub>",
+ "</span>\n",
+ sep="")
+ invisible()
+}
+
+
+# Here's an example hook that you could use to add an EPS preview to eps files (requires epstool)
+
+#eps.add.preview <- function(fname) system(paste("epstool -n1 -b -t6p -zbmp256 -r200 -g\"gswin32c\" -o",fname,".eps ",fname,".eps",sep=""),show.output.on.console = TRUE)
+#
+#setHook("closeRpadDevice", function() { # add a tiff preview to an eps file
+# name = RpadPlotName()
+# if (length(dir(pattern=paste(name,".eps",sep=""))) == 1)
+# eps.add.preview(name)
+#})
+
+### This will set the default graphics option to the GDD device:
+# library(GDD)
+# graphoptions(type = GDD)
+### This is how you could change the pointsize on a GDD device:
+# newgraph(ps = 10) # the default is 12
Added: pkg/Rpad/R/HtmlTree.R
===================================================================
--- pkg/Rpad/R/HtmlTree.R (rev 0)
+++ pkg/Rpad/R/HtmlTree.R 2013-12-31 05:19:15 UTC (rev 2)
@@ -0,0 +1,316 @@
+#
+#
+#
+#
+#
+#
+
+"Html" <- function(x,...) {
+ UseMethod("Html")
+}
+
+"Html.default" <- function(x, ...) as.character(x)
+
+"Html.integer" <- "Html.numeric" <- function(x, ...) paste(format(x), collapse = ", ")
+
+
+"HtmlTree" <- function(tagName, ...) {
+ UseMethod("HtmlTree")
+}
+
+"H" <- HtmlTree
+
+"HtmlTree.HtmlTree" <- function(tagName, ..., standaloneTag = FALSE, collapseContents = TRUE) tagName
+
+"jsQuote" <- function(string) {
+ # uses code from shQuote
+ # wraps strings in quotes, with priority to single quotes
+ # cat(jsQuote("asdf")) -> 'asdf'
+ # cat(jsQuote('asdf')) -> 'asdf'
+ # cat(jsQuote('alert("hello")')) #-> 'alert("hello")'
+ # cat(jsQuote("alert('hello')")) #-> "alert('hello')"
+ # cat(jsQuote("alert(\"he\'l'lo\")")) #-> 'alert("he\'l\'lo")'
+ has_single_quote <- grep("'", string)
+ if (!length(has_single_quote))
+ return(paste("'", string, "'", sep = ""))
+ has_double_quote <- grep('"', string)
+ if (!length(has_double_quote))
+ return(paste('"', string, '"', sep = ""))
+ # default - single-quote emphasis
+ paste("'", gsub("'", "\\\\\'", string), "'", sep = "")
+}
+
+"HTMLargs" <- function(x) {
+ # returns a string with the arguments as a="arg1", b="arg2", and so on
+ names <- names(x)
+ if (length(x) > 0) str <- " " else str <- ""
+ for (i in seq(along = x))
+ str <- paste(str, names[i], "=", jsQuote(x[[i]]), " ", sep = "")
+ return(str)
+}
+
+"print.HtmlTree" <- function(x, file = "", ...)
+ cat(file=file, x, "\n")
+
+"HtmlTree.default" <- function(tagName, ..., standaloneTag = FALSE, collapseContents = TRUE) {
+ # named arguments are attributes; unnamed are content
+ args <- list(...)
+ methodsOfHtml <- setdiff(c(gsub("^Html.","",(methods("Html"))), "HtmlTree"), "character")
+ # if we can apply "html" to tagName, and it's by itself, do it (for non-character classes)
+ if (length(args) == 0 && !is.character(tagName) && class(tagName) %in% methodsOfHtml)
+ return(Html(tagName))
+ if (length(names(args)) > 0) {
+ tagContents <- args[names(args) == ""] # unnamed arguments
+ tagAttributes <- args[names(args) != ""] # named arguments
+ } else {
+ tagContents <- args
+ tagAttributes <- NULL
+ }
+ pasteList <- function(x) {
+ str <- ""
+ for (i in seq(along=x)) {
+ str <- paste(str, Html(x[[i]]), sep = " ")
+ }
+ str
+ }
+ if (is.null(tagName)) {
+ startTag <- ""
+ contents <- pasteList(tagContents)
+ endTag <- ""
+ } else if (standaloneTag) {
+ startTag <- paste("<", tagName, HTMLargs(tagAttributes), "/>", sep = "")
+ contents <- ""
+ endTag <- ""
+ } else { # default case:
+ startTag <- paste("<", tagName, HTMLargs(tagAttributes), ">", sep = "")
+ contents <- paste(" ",pasteList(tagContents), "")
+ endTag <- paste("</", tagName, ">", sep = "")
+ }
+ str <- paste(startTag, contents, endTag,
+ sep = "", collapse = if (collapseContents) "" else NULL)
+ class(str) <- "HtmlTree"
+ str
+}
+
+"Html.data.frame" <- "Html.matrix" <- function(x, ...) {
+##
+## Make an HtmlTree out of a data frame.
+## First "format" then convert to a matrix.
+## "..." arguments are passed directly to format.
+##
+
+ x.formatted <- as.matrix(format(x, ...))
+ x.formatted[is.na(x)] <- " "
+ x.formatted[grep("^ *(NA|NaN) *$", x.formatted)] <- " "
+
+ H("div", class = "RpadTableHolder",
+ H("table",
+ H("tbody",
+ H("tr", # HEADER ROW
+ H("th",
+ H("div", class = "tableheaderrow",
+ colnames(x), collapseContents = FALSE))), # collapseContents keeps the <th><div></div></th><th><div></div></th> nested pair
+ H(NULL, # NULL groups consecutive tags together
+ apply(x.formatted, MARGIN = 1, # MAIN BODY - sweep the rows
+ FUN = function (x)
+ H("tr",
+ H("td", x)))))))
+}
+
+
+# broken:
+#"HtmlTree.list" <- "Html.list" <- function (x, first = TRUE, ...) {
+# res = rep(H("dum"), length = 2*length(x))
+# res[seq(1, 2*length(x), by = 2)] = H(NULL, names(x), collapseContents = FALSE)
+# res[seq(2, 2*length(x), by = 2)] = sapply(x, FUN = function(x)
+# H("ul",
+# Html(x, first = FALSE)))
+# if (first) # IE needs contenteditable off
+# H("div", contentEditable='false',
+# H("ul",
+# H("li",
+# H(NULL, res))))
+# else
+# H("li",
+# H(NULL, res))
+#}
+
+"HTMLbutton" <- function(label = "Calculate", js = "rpad.calculatePage()", ...)
+ # Other useful js parameters:
+ # js = "rpad.calculateNext(this)" # calculate the next Rpad block
+ # js = "rpad.send('put commands here')"
+ H("input", onclick = paste("javascript:", js, sep=""),
+ value = label, type = "button", ...)
+
+"HTMLradio" <- function(variableName, commonName = "radio", text = "", ...)
+ # outputs an HTML radio button wrapped in a contentEditable=false
+ H("span", contentEditable="false",
+ H("input", type = 'radio', name = commonName, value = variableName, id = variableName, ...),
+ H("label", "for" = variableName,
+ text))
+
+"HTMLcheckbox" <- function(name, text = "", ...)
+ H("span", contentEditable="false",
+ H("input", type = 'checkbox', name = name, id = name, ...),
+ H("label", "for" = name,
+ text))
+
+"HTMLinput" <- function(name, value = "", rpadType = "Rvariable", contenteditablewrapper = TRUE, ...) {
+ res <- H("input", name = name, value = value, rpadType = rpadType, standaloneTag = TRUE, ...)
+ if (contenteditablewrapper)
+ H("span", contentEditable = "false",
+ res)
+ else
+ res
+}
+
+"HTMLselect" <- function(name, text, default=1, size=1, id=name, contenteditablewrapper=TRUE,
+ optionvalue=text, ...) {
+# generate a select box
+
+ options =
+ H("option", value = optionvalue,
+ text, collapseContents = FALSE)
+
+ if (default > 1 & default <= length(text))
+ options[default] =
+ H("option", value = optionvalue[default], selected = "selected",
+ text[default])
+
+ res =
+ H("select", name = name, size = size, id = id, ...,
+ H(NULL, options))
+
+ if (contenteditablewrapper)
+ H("span", contentEditable = "false",
+ res)
+ else
+ res
+}
+
+"HTMLlink" <- function(url, text, ...)
+ H("span", contentEditable="false",
+ H("a", href = url, ...,
+ text))
+
+"HTMLimg" <- function(filename = RpadPlotName(), ...)
+ H("img", src = RpadURL(filename), ...)
+
+"HTMLembed" <- function(filename, width = 600, height = 600, ...)
+ H("embed", src = filename, width = width, height = height, ...)
+
+"HTMLjs" <- function(js)
+ # Runs a javascript snippet. HTML must be enabled.
+ # doesn't work because scripts won't get executed when inserted via innerHTML
+ H("script", type="text/javascript",
+ js)
+
+"HTMLjs" <- function(js)
+ # Runs a javascript snippet by attaching it to an error handler for an image.
+ # HTML must be enabled.
+ # see also: # http://24ways.org/advent/have-your-dom-and-script-it-too
+ # <img src="g.gif?randomnum" alt=""
+ # onload="alert('Now that I have your attention...');this.parentNode.removeChild(this);" />
+ H("img", src = "", alt = "", style = "display:none",
+ onerror = paste(js, ";this.parentNode.removeChild(this);"))
+
+"HTMLSetInnerHtml" <- function(id, html)
+ # Sets the innerHTML of the element "id" to "html".
+ # Runs a bit of javascript to do it. HTML must be enabled.
+ # It's probably better to do this sort of thing on the javascript side.
+ HTMLjs(paste("dojo.byId('", id, "').innerHTML = '", html, "'", sep=""))
+
+"BR" = function()
+ H("br", standaloneTag = TRUE) # <br/>
+
+"HTMLh1" <- function(text) {
+ H("h1", text)
+}
+"HTMLh2" <- function(text) {
+ H("h2", text)
+}
+"HTMLh3" <- function(text) {
+ H("h3", text)
+}
+"HTMLh4" <- function(text) {
+ H("h4", text)
+}
+"HTMLh5" <- function(text) {
+ H("h5", text)
+}
+
+"HTMLon" <- function()
+ H("htmlon", standaloneTag = TRUE)
+
+"HTMLoff" <- function()
+ H("htmloff", standaloneTag = TRUE)
+
+"ROutputFormat" <- function(Format)
+ options(R.output.format = Format)
+
+"HTMLtag" <- function(tagName, ...) {
+ # outputs the given HTML tagName with arguments supplied in ...
+ str <- paste("<", tagName, HTMLargs(list(...)), ">", sep = "", collapse = "")
+ class(str) <- "HtmlTree"
+ str
+}
+
+"HTMLetag" <- function(tagName) {
+ str <- paste("</", tagName, ">\n", sep = "")
+ class(str) <- "HtmlTree"
+ str
+}
+
+"print.condition" <- function (x, ...) {
+ # redefine this to get rid of the <> brackets around error messages
+
+ msg <- conditionMessage(x)
+ call <- conditionCall(x)
+ cl <- class(x)[1]
+ if (!is.null(call)) {
+ cat("** ", cl, " in ", deparse(call), ": ", msg, " **\n", sep = "")
+ } else {
+ cat("** ", cl, ": ", msg, " **\n", sep = "")
+ }
+}
+
+"HfromHTML" <- function(x) {
+ if(require("R2HTML")) {
+ res <- capture.output({HTML(x);cat("\n")}) # the \n makes sure to get a complete line
+ class(res) <- "HtmlTree"
+ res
+ } else {
+ Html(x)
+ }
+}
+
+"dojoTree" <- function(x, first = TRUE, ...) {
+ x <- as.list(x)
+ res <- sapply(seq(len = length(x)),
+ function(i)
+ H("div", dojoType="TreeNodeV3", ...,
+ title = names(x)[i],
+ if (is.list(x[[i]]) && !(any(class(x[[i]]) %in% gsub("^Html.","",methods(Html)))))
+ dojoTree(x[[i]], first = FALSE)
+ else
+ H("div", dojoType="TreeNodeV3", title = Html(x[[i]]))))
+ res <- paste(res, collapse="") # combine the list elements
+ if (first) {
+ H(NULL,
+ H("div", dojoType = "TreeBasicControllerV3", widgetId="controller"),
+ H("div", dojoType="TreeV3", listeners="controller",
+ res))
+ } else {
+ res
+ }
+}
+
+## ##tests for dojoTree
+## x = list(a = 1:2, 44, b = list(a = 3:4, b = 6:5), c = data.frame(a=1:5, b = 11:15))
+## HTMLon()
+## H("p", "A simple tree:")
+## dojoTree(x)
+## H("p", "An expanded version:")
+## dojoTree(x, expandLevel = 2)
+## H("p", "A bigger tree:")
+## dojoTree(as.list(lm(1:10 ~ rnorm(10))))
Added: pkg/Rpad/R/LocalVersion.R
===================================================================
--- pkg/Rpad/R/LocalVersion.R (rev 0)
+++ pkg/Rpad/R/LocalVersion.R 2013-12-31 05:19:15 UTC (rev 2)
@@ -0,0 +1,84 @@
+# Rpad utility functions for running Rpad locally.
+
+# Here we use a local Tcl httpd server to receive Rpad commands.
+"processRpadCommands" <-
+function() {
+ require("tcltk")
+ commands <- tclvalue(.Tcl("set user(R_commands)"))
+ textcommands <- textConnection(commands)
+ .dev.active <- dev.cur()
+ if (exists("RpadPlotParams", envir = .RpadEnv))
+ dev.set( get("RpadPlotParams", envir = .RpadEnv)$dev )
+
+ results <- tryCatch({
+ tc <- textConnection("textfromconnection",open="w")
+ sink(file=tc)
+ guiSource(textcommands)
+ sink()
+ close(tc)
+ # the result is R result text
+ get("textfromconnection")
+ }, error=function(e) {
+ sink()
+ close(tc)
+ cat('ERROR1:')
+ print(e)
+ # the result is an error message
+ etext <- paste(paste(get("textfromconnection"), "\n", collapse=""), '\n', e)
+ etext
+ }, finally=close(textcommands))
+ dev.set(.dev.active)
+ formattedresults <- paste(results,"\n",sep="",collapse="")
+# cat(formattedresults)
+ escapeBrackets <- function(x) gsub("(\\{|\\})", "\\\\\\1", x)
+ .Tcl(paste("set RpadTclResults {", escapeBrackets(formattedresults), "}", sep=""))
+}
+
+
+"Rpad" <-
+function(file = "", defaultfile = "LocalDefault.Rpad", port = 8079) {
+ startRpadServer(defaultfile, port)
+ browseURL(paste("http://127.0.0.1:", port, "/", file, sep = ""))
+}
+
+"startRpadServer" <-
+function(defaultfile = "LocalDefault.Rpad", port = 8079) {
+ require("tcltk")
+ # This is the main function that starts the server
+ # This function implements a basic http server on 'port'
+ # The server is written in Tcl.
+ # This way it is not blocking the R command-line!
+
+ if (!require("tcltk")) stop("package tcltk required for the local Rpad http server")
+ assign("RpadLocal", TRUE, envir = .RpadEnv)
+ assign("RpadDir", ".", envir = .RpadEnv)
+ assign("RpadPort", port, envir = .RpadEnv)
+ graphoptions(type = "Rpng")
+ tclfile <- file.path(find.package(package = "Rpad"), "tcl", "mini1.1.tcl")
+ htmlroot <- file.path(find.package(package = "Rpad"), "basehtml")
+ tcl("source", tclfile)
+ tcl("Httpd_Server", htmlroot, port, defaultfile)
+ # delete the Rpad graphics files in the dir
+ unlink(dir(pattern="Rpad_plot.*\\.png"))
+ unlink(dir(pattern="Rpad_plot.*\\.eps"))
+ # turn on the interactive plotting device so as not to confuse the command-line user if they later plot
+ # ... but it's kind of distracting when Rpad starts so leave it off for now
+ #if(interactive() && .Device == "null device") x11()
+ #dev <- dev.cur()
+ # this initializes the png device for Rpad
+ newgraph()
+ # switch back to the existing device to not confuse the user
+ #dev.set(dev)
+ return(TRUE)
+}
+
+"stopRpadServer" <-
+function() {
+ require("tcltk")
+ assign("RpadLocal", FALSE, envir = .RpadEnv)
+ # delete the Rpad graphics files in the dir
+ unlink(dir(pattern="Rpad_plot.*\\.png"))
+ unlink(dir(pattern="Rpad_plot.*\\.eps"))
+ .Tcl("close $Httpd(listen)")
+ .Tcl("unset Httpd")
+}
Added: pkg/Rpad/R/Rpad-internal.R
===================================================================
--- pkg/Rpad/R/Rpad-internal.R (rev 0)
+++ pkg/Rpad/R/Rpad-internal.R 2013-12-31 05:19:15 UTC (rev 2)
@@ -0,0 +1,51 @@
+.RpadEnv <- new.env()
+
+".onLoad" <-
+function(lib, pkg) {
+ isR2HMTLAvailable <- length(find.package("R2HTML", quiet = TRUE)) != 0
+ if (isR2HMTLAvailable) {
+ options(R2HTML.sortableDF = TRUE)
+ options(R2HTML.format.digits = 3)
+ options(R2HTML.format.nsmall = 0)
+ options(R2HTML.format.big.mark = "")
+ options(R2HTML.format.big.interval = 3)
+ options(R2HTML.format.decimal.mark = Sys.localeconv()[["decimal_point"]])
+ .HTML.file <<- ""
+ }
+ # The following uses the environment variable DOCUMENT_ROOT with apache to find
+ # the directory of the R process. Change may be required for another server.
+ if (Sys.getenv("DOCUMENT_ROOT") != "") { # works for Apache 1.3 linux & win
+ RpadDir <- gsub(Sys.getenv("DOCUMENT_ROOT"), "",
+ getwd(), ignore.case = TRUE) # strip off the document root
+ } else if (Sys.getenv("SCRIPT_NAME") != "") { # for Apache 2.0
+ RpadDir <- paste(gsub("R_process.pl", "", Sys.getenv("SCRIPT_NAME"), ignore.case = TRUE),
+ gsub(".*/", "", getwd()),
+ sep="")
+ } else if (Sys.getenv("PATH_INFO") != "") { # for microsoft IIS
+ RpadDir <- paste(gsub("R_process.pl", "", Sys.getenv("PATH_INFO"), ignore.case = TRUE),
+ gsub(".*/", "", getwd()),
+ sep="")
+ } else {
+ .rootdir = ifelse(.Platform$OS.type == "windows", "C:/www", "/var/www")
+ RpadDir <- gsub(.rootdir, "", getwd(), ignore.case = TRUE)
+ }
+
+ options(R.output.format = "text") # do we need or want this anymore? If we do, why don't we put it in .RpadEnv?
+
+
+ assign(".RpadGraphOptions",
+ list(type = "pngalpha", extension = "png",
+ res = 120, width = 0, height = 0, deviceUsesPixels = TRUE, pointsize = 10,
+ sublines = 0, toplines = .6, ratio = 4/3, leftlines = 0, lwd = 0.6),
+ envir = .RpadEnv)
+ assign("RpadLocal", FALSE, envir = .RpadEnv)
+ assign("RpadDir", RpadDir, envir = .RpadEnv)
+ assign("Rpad.plot.counter", 0, envir = .RpadEnv)
+}
+
+".onUnload" <-
+function(libpath) {
+ if (interactive()) stopRpadServer()
+}
+
+".packageName" <- "Rpad"
Added: pkg/Rpad/R/Util.R
===================================================================
--- pkg/Rpad/R/Util.R (rev 0)
+++ pkg/Rpad/R/Util.R 2013-12-31 05:19:15 UTC (rev 2)
@@ -0,0 +1,124 @@
+# Rpad utility functions.
+
+# this function is used to parse and evaluate the commands from an Rpad input block
+"guiSource" <-
+function (file, out.form = getOption("R.output.format"), local = FALSE,
+ echo = verbose, print.eval = TRUE,
+ verbose = getOption("verbose"), prompt.echo = getOption("prompt"),
+ max.deparse.length = 150, chdir = FALSE)
+{
+ eval.with.vis <- function(expr, envir = parent.frame(), enclos = if (is.list(envir) ||
+ is.pairlist(envir))
+ parent.frame()) withVisible(eval(expr, envir,
+ enclos))
+ envir <- if (local)
+ parent.frame()
+ else .GlobalEnv
+ if (!missing(echo)) {
+ if (!is.logical(echo))
+ stop("echo must be logical")
+ if (!echo && verbose) {
+ warning(paste("verbose is TRUE, echo not; ... coercing",
+ sQuote("echo <- TRUE")))
+ echo <- TRUE
+ }
+ }
+ if (verbose) {
+ cat(sQuote("envir"), "chosen:")
+ print(envir)
+ }
+ Ne <- length(exprs <- parse(n = -1, file = file))
+ if (verbose)
+ cat("--> parsed", Ne, "expressions; now eval(.)ing them:\n")
+ if (Ne == 0)
+ return(invisible())
+ if (chdir && (path <- dirname(file)) != ".") {
+ owd <- getwd()
+ on.exit(setwd(owd))
+ setwd(path)
+ }
+ if (echo) {
+ sd <- "\""
+ nos <- "[^\"]*"
+ oddsd <- paste("^", nos, sd, "(", nos, sd, nos, sd, ")*",
+ nos, "$", sep = "")
+ }
+ for (i in 1:Ne) {
+ if (verbose)
+ cat("\n>>>> eval(expression_nr.", i, ")\n\t\t =================\n")
+ ei <- exprs[i]
+ if (echo) {
+ dep <- substr(paste(deparse(ei), collapse = "\n"),
+ 12, 1e+06)
+ nd <- nchar(dep) - 1
+ do.trunc <- nd > max.deparse.length
+ dep <- substr(dep, 1, if (do.trunc)
+ max.deparse.length
+ else nd)
+ cat("\n", prompt.echo, dep, if (do.trunc)
+ paste(if (length(grep(sd, dep)) && length(grep(oddsd,
+ dep)))
+ " ...\" ..."
+ else " ....", "[TRUNCATED] "), "\n", sep = "")
+ }
+ yy <- eval.with.vis(ei, envir)
+ i.symbol <- mode(ei[[1]]) == "name"
+ if (!i.symbol) {
+ curr.fun <- ei[[1]][[1]]
+ if (verbose) {
+ cat("curr.fun:")
+ str(curr.fun)
+ }
+ }
+ if (verbose >= 2) {
+ cat(".... mode(ei[[1]])=", mode(ei[[1]]), "; paste(curr.fun)=")
+ str(paste(curr.fun))
+ }
+ if ( yy$visible ) {
+ # always print, even if not shown for side effects
+ printoutput = capture.output(print(yy$value))
+ if (out.form == "html" && exists("HTML"))
+ HTML(yy$value)
+ else if (out.form != "none")
+ cat(paste(printoutput,collapse="\n"),"\n")
+ }
+ if (verbose)
+ cat(" .. after ", sQuote(deparse(ei)), "\n", sep = "")
+ }
+ invisible(yy)
+}
+
+
+"RpadURL" <- function(filename = "") {
+ # returns the URL for the given filename
+ # "./filename" for the local version
+ # "/Rpad/server/dd????????/filename" for the server version
+ # use this to output HTML links for the user
+ paste(get("RpadDir", envir = .RpadEnv), "/", filename, sep="")
+}
+
+"RpadBaseURL" <- function(filename = "") {
+ # returns the base URL
+ # "filename" for the local version
+ # "/Rpad/filename" for the server version
+ # use this to read in data files or save data files somewhere permanent
+ if ( RpadIsLocal() )
+ filename
+ else
+ paste("../../", filename, sep="")
+}
+
+"RpadBaseFile" <- function(filename = "") {
+ # returns the file name relative to the base R directory
+ # "filename" for the local version
+ # "../../filename" for the server version
+ # use this to read in data files or save data files somewhere permanent
+ if ( RpadIsLocal() )
+ paste("./", filename, sep="")
+ else
+ paste("../../", filename, sep="")
+}
+
+"RpadIsLocal" <- function()
+ get("RpadLocal", envir = .RpadEnv)
+
Added: pkg/Rpad/R/json.R
===================================================================
--- pkg/Rpad/R/json.R (rev 0)
+++ pkg/Rpad/R/json.R 2013-12-31 05:19:15 UTC (rev 2)
@@ -0,0 +1,100 @@
+json <- function (x, ...)
+ UseMethod("json")
+
+json.list <- function(x, ...) {
+ res <- array("", length(x))
+ for (i in seq(len=length(x)))
+ res[i] <- json(x[[i]])
+ nms <- names(x)
+ if (is.null(nms)) nms = seq(from = 0, len = length(x))
+ idx <- which(nms == "")
+ nms[idx] <- seq(from = 0, along = idx)
+ result <- paste('{', paste('"', nms, '":', res, collapse = ',', sep = ''), '}', sep = '')
+ class(result) <- "json"
+ result
+}
+
+json.numeric <- function(x, ...) {
+ if (!is.null(names(x)))
+ result <- paste('{',
+ paste('"', names(x), '":', ifelse(is.na(x), 'NaN', x), sep = '', collapse = ','),
+ '}', sep = '')
+ else if (length(x) > 1)
+ result <- paste('[', paste(ifelse(is.na(x), 'NaN', x), collapse = ',' ), ']', sep = '')
+ else
+ result <- paste(ifelse(is.na(x), 'NaN', x))
+ class(result) <- "json"
+ result
+}
+
+json.logical <- function(x, ...) {
+ if (!is.null(names(x)))
+ result <- paste('{',
+ paste('"', names(x), '" : ', ifelse(x, 'true', 'false'), sep = '', collapse = ','),
+ '}', sep = '')
+ else if (length(x) > 1)
+ result <- paste('[', paste(ifelse(x, 'true', 'false'), collapse = ',' ), ']', sep = '')
+ else
+ result <- paste(ifelse(x, 'true', 'false'))
+ class(result) <- "json"
+ result
+}
+
+escapeStrings <- function(s) {
+ s <- gsub('/', '\\\\/', s)
+ s <- gsub('"', '\\\\"', s)
+ s <- gsub('\\\\', '\\\\', s)
+ s <- gsub('\b', '\\\\b', s)
+ s <- gsub('\f', '\\\\f', s)
+ s <- gsub('\n', '\\\\n', s)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rpad -r 2
More information about the Rpad-commits
mailing list