From noreply at r-forge.r-project.org Tue Dec 31 06:19:16 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 31 Dec 2013 06:19:16 +0100 (CET) Subject: [Rpad-commits] r2 - in pkg: . Rpad Rpad/R Rpad/inst Rpad/inst/basehtml Rpad/inst/tcl Rpad/man Message-ID: <20131231051916.257321856D4@r-forge.r-project.org> 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 +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("", + "_[EPS]", + "\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("", 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

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

+ 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) #
+ +"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("\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