[Sciviews-commits] r383 - in komodo/SciViews-K-dev: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Aug 8 22:47:14 CEST 2011
Author: prezez
Date: 2011-08-08 22:47:13 +0200 (Mon, 08 Aug 2011)
New Revision: 383
Added:
komodo/SciViews-K-dev/R/
komodo/SciViews-K-dev/R/.Rprofile
komodo/SciViews-K-dev/R/captureAll.R
komodo/SciViews-K-dev/R/compile_json.tcl
komodo/SciViews-K-dev/R/objList.R
komodo/SciViews-K-dev/R/objSearch.R
komodo/SciViews-K-dev/R/parseText.R
komodo/SciViews-K-dev/R/rserver.R
komodo/SciViews-K-dev/R/rserver.tcl
komodo/SciViews-K-dev/R/sv-basedir
Log:
SciViews-K dev version: new starting directory for R, with source files, all essential code is included there (.R and .tcl), no additional packages needed (minimal R-Komodo interface).
Property changes on: komodo/SciViews-K-dev/R
___________________________________________________________________
Added: svn:ignore
+ init.R
Added: komodo/SciViews-K-dev/R/.Rprofile
===================================================================
--- komodo/SciViews-K-dev/R/.Rprofile (rev 0)
+++ komodo/SciViews-K-dev/R/.Rprofile 2011-08-08 20:47:13 UTC (rev 383)
@@ -0,0 +1,154 @@
+options(json.method="R")
+
+if("komodoConnection" %in% search()) detach("komodoConnection")
+attach(new.env(), name="komodoConnection")
+
+if(existsFunction("stopAllServers")) stopAllServers()
+if(existsFunction("stopAllConnections")) stopAllConnections()
+
+with(as.environment("komodoConnection"), {
+
+ #`svOption` <- function (arg.name, default = NA, as.type = as.character, ...) {
+ # args <- gsub("\\b-\\b", ".", commandArgs(trailingOnly=TRUE))
+ #
+ # pfx <- paste("^--", arg.name, "=", sep = "")
+ # x <- args[grep(pfx, args)]
+ #
+ # x <- if (!length(x)) default else sub(pfx, "", x)
+ # x <- as.type(x, ...)
+ # x <- structure(list(x), names = arg.name)
+ # do.call("options", x)
+ # return(x)
+ #}
+
+ `svPager` <- function (files, header, title, delete.file) {
+ files <- gsub("\\", "\\\\", files[1], fixed = TRUE)
+ tryCatch(koCmd(sprintf('sv.r.pager("%1$s", "%2$s", %3$s)',
+ files, title, if (delete.file) 'true' else 'false')),
+ error=function(e) browseURL(files, NULL))
+ }
+
+ `svBrowser` <- function(url) {
+ url <- gsub("\\", "\\\\", url, fixed = TRUE)
+ ## If the URL starts with '/', assume a file path
+ ## on Unix or Mac and prepend 'file://'
+ url <- sub("^/", "file:///", url)
+ tryCatch(koCmd(sprintf("sv.command.openHelp(\"%s\")", url)),
+ warning=function(e) browseURL(url, NULL)
+ )
+ }
+
+ local({
+ require(utils)
+ `readline` <- function (prompt = "")
+ paste(koCmd(sprintf("ko.dialogs.prompt('%s', '', '', 'R asked a question', 'R-readline')", prompt),
+ timeout=0), collapse=" ")
+ unlockBinding("readline", env=baseenv())
+ bindingIsLocked("readline", env=baseenv())
+ assign("readline", value=readline, envir = baseenv())
+ utils::assignInNamespace("readline", value=readline, ns="base")
+ lockBinding("readline", env=baseenv())
+ })
+
+ options(browser = svBrowser, pager = svPager)
+
+ # a way round to get the url:
+ #getHelpURL(help("anova")) <- old syntax
+ #getHelpURL("anova") <- new syntax
+ `getHelpURL` <- function(..., help_type = "html") {
+ if(tools:::httpdPort == 0) suppressMessages(tools:::startDynamicHelp(TRUE))
+ help_type <- "html"
+ ret <- NULL
+ oBrowser <- options(browser=function(url) ret <<- url)
+ on.exit(options(oBrowser))
+ if(mode((cl <- match.call())[[2]][[1]]) == "name") { # handle old syntax
+ cl <- cl[[2]]
+ cl$help_type <- help_type
+ print(eval(cl, .GlobalEnv))
+ } else {
+ print(utils::help(..., help_type = help_type))
+ }
+ ret
+ }
+
+ require(utils)
+ require(stats)
+
+
+ env <- as.environment("komodoConnection")
+ src <- dir(pattern="\\.R$")
+ lapply(src[src != "init.R"], sys.source, envir=env)
+ invisible()
+})
+
+
+
+#svOption("ko.port", as.type=as.numeric)
+#svOption("ko.host", default="localhost")
+
+.Last <- function() {
+ try({
+ stopAllServers()
+ stopAllConnections()
+ })
+}
+
+
+local({
+
+port <- 1111L
+while((port < 1115L) && (as.character(startServer(port)) == "0")) port <- port + 1L
+
+cwd0 <- normalizePath(".")
+
+#cat("cwd0 is ", sQuote(getwd()), "\n")
+
+if(file.exists("init.R")) source("init.R")
+
+Rservers <- enumServers()
+if(is.numeric(getOption("ko.port")) && length(Rservers) > 0) {
+ cat("Server started at port", Rservers, "\n")
+ invisible(koCmd(paste(
+ "sv.cmdout.append('R is started')",
+ "sv.command.updateRStatus(true)",
+ sprintf("sv.pref.setPref('sciviews.r.port', %s)", tail(Rservers, 1)),
+ sep = ";")))
+}
+
+cat("cwd is now ", sQuote(getwd()), "\n")
+
+## Do we have a .Rprofile file to source?
+#rprofile <- file.path(c(getwd(), Sys.getenv("R_USER")), ".Rprofile")
+cwd <- normalizePath(getwd())
+isBaseDir <- file.exists(file.path(cwd, "sv-basedir")) || (cwd == cwd0)
+rprofile <- file.path(c(if(!isBaseDir) getwd(), Sys.getenv("R_USER")), ".Rprofile")
+rprofile <- rprofile[file.exists(rprofile)][1]
+
+if (!is.na(rprofile)) {
+ source(rprofile)
+ cat("Loaded file:", rprofile, "\n")
+}
+
+
+if(!any(c("--vanilla", "--no-restore", "--no-restore-data") %in% commandArgs())
+ && file.exists(".RData")) {
+ #sys.load.image(".RData", FALSE)
+}
+if(file.exists(".Rhistory")) loadhistory(".Rhistory")
+
+
+#obj <- ls(.GlobalEnv)
+#conflictObjs <- obj[obj %in% ls("komodoConnection")]
+#
+#if(length(conflictObjs) > 0) {
+# cat("Following objects in .GlobalEnv were conflicting and should be removed: \n")
+# cat(sQuote(conflictObjs), "\n")
+# rm(list=conflictObjs, envir=.GlobalEnv, inherits=FALSE)
+#}
+
+
+})
+
+#with(as.environment("komodoConnection"), {
+#rm(getHelpURL, envir=.GlobalEnv)
+#})
Added: komodo/SciViews-K-dev/R/captureAll.R
===================================================================
--- komodo/SciViews-K-dev/R/captureAll.R (rev 0)
+++ komodo/SciViews-K-dev/R/captureAll.R 2011-08-08 20:47:13 UTC (rev 383)
@@ -0,0 +1,215 @@
+## Inspired by 'capture.output' and utils:::.try_silent
+## Requires: R >= 2.13.0 [??]
+`captureAll` <- function (expr, split = TRUE, echo = TRUE, file = NULL,
+markStdErr = FALSE) {
+ if (!is.expression(expr))
+ if (is.na(expr)) return(NA) else
+ stop("expr must be an expression or NA")
+
+ ## TODO: support for 'file'
+ ## markStdErr: if TRUE, stderr is separated from sddout by STX/ETX character
+
+ last.warning <- list()
+ Traceback <- list()
+ NframeOffset <- sys.nframe() + 19L # frame of reference (used in traceback) +
+ # length of the call stack when a condition
+ # occurs
+ # Note: if 'expr' is a call not expression, 'NframeOffset' is lower by 2
+ # (i.e. 21): -1 for lapply, -1 for unwrapping 'expression()'
+
+
+ getWarnLev <- function() options('warn')[[1L]] # This may change in course
+ # of evaluation, so must be
+ # retrieved dynamically
+ rval <- NULL
+ tconn <- textConnection("rval", "w", local = TRUE)
+ split <- isTRUE(split)
+ if (split) {
+ ## This is required to print error messages when we are, say, in a
+ ## browser() environment
+ sink(stdout(), type = "message")
+ } else {
+ ## This is the conventional way to do it
+ sink(tconn, type = "message")
+ }
+ sink(tconn, type = "output", split = split)
+ #sink(tconn, type = "message")
+ on.exit({
+ sink(type = "message")
+ sink(type = "output")
+ close(tconn)
+ })
+
+ inStdOut <- TRUE
+ marks <- list()
+
+ if (isTRUE(markStdErr)) {
+ putMark <- function (toStdout, id) {
+
+ do.mark <- FALSE
+ if (inStdOut) {
+ if (!toStdout) {
+ cat("\x03")
+ inStdOut <<- FALSE
+ do.mark <- TRUE
+ }} else { # in StdErr stream
+ if (to.stdout) {
+
+ cat("\x02")
+ inStdOut <<- TRUE
+ do.mark <- TRUE
+ }}
+
+ if(do.mark)
+ marks <<- c(marks, list(c(pos = sum(nchar(rval)), stream = to.stdout)))
+ #cat("<", id, inStdOut, ">")
+ }
+ } else {
+ putMark <- function (toStdout, id) {}
+ }
+
+ evalVis <- function (x) {
+ ## Do we print the command? (note that it is reformatted here)
+ if (isTRUE(echo)) {
+ ## Reformat long commands... and possibly abbreviate them
+ cmd <- deparse(x)
+ l <- length(cmd)
+ if (l > 7) cmd <- c(cmd[1:3], "[...]", cmd[(l-2):l])
+ cat(":> ", paste(cmd, collapse = "\n:+ "), "\n", sep = "")
+ }
+ res <- withVisible(eval(x, .GlobalEnv))
+ ## Do we have result to print?
+ if (inherits(res, "list") && res$visible)
+ print(res$value)
+
+ return(res)
+ }
+
+ `restartError` <- function(e, calls, off) {
+ # remove call (eval(expr, envir, enclos)) from the message
+
+ ncls <- length(calls)
+
+ #DEBUG
+ #cat("n calls: ", ncls, "NframeOffset: ", NframeOffset, "\n")
+ #print(e$call)
+ #print(off)
+ #print(calls[[NframeOffset]])
+ #print(calls[[NframeOffset+ off]])
+ #browser()
+
+ if(isTRUE(all.equal(calls[[NframeOffset + off]], e$call, check.attributes=FALSE)))
+
+ e$call <- NULL
+
+ Traceback <<- rev(calls[-c(seq.int(NframeOffset + off), (ncls - 1L):ncls)])
+
+#> cat(captureAll(expression(1:10, log(-1),log(""),1:10)), sep="\n")
+
+ putMark(FALSE, 1L)
+ cat(formatMsg(e))
+ if (getWarnLev() == 0L && length(last.warning) > 0L)
+ cat(ngettext(1, "In addition: ", "In addition: ", domain = "R"))
+ }
+
+ if(!exists("show", mode="function")) show <- base::print
+
+ res <- tryCatch(withRestarts(withCallingHandlers({
+ ## TODO: allow for multiple expressions and calls (like in
+ ## 'capture.output'). The problem here is how to tell 'expression'
+ ## from 'call' without evaluating it?
+ ##list(evalVis(expr))
+
+ for(i in expr) {
+ off <- 0L # TODO: better way to find the right sys.call...
+ res1 <- evalVis(i)
+ #cat('---\n')
+ # this will catch also 'print' errors
+ off <- -3L
+ if(res1$visible) show(res1$value)
+ }
+ },
+
+ error = function(e) invokeRestart("grmbl", e, sys.calls(), off),
+ warning = function(e) {
+ # remove call (eval(expr, envir, enclos)) from the message
+ if(isTRUE(all.equal(sys.call(NframeOffset), e$call, check.attributes=FALSE)))
+
+ e$call <- NULL
+
+ last.warning <<- c(last.warning, structure(list(e$call),
+ names = e$message))
+
+ if (getWarnLev() != 0L) {
+ putMark(FALSE, 2L)
+ .Internal(.signalCondition(e, conditionMessage(e),
+ conditionCall(e)))
+ .Internal(.dfltWarn(conditionMessage(e), conditionCall(e)))
+ putMark(TRUE, 3L)
+ }
+ invokeRestart("muffleWarning")
+ }),
+ ## Restarts:
+
+ # Handling user interrupts. Currently it works only from within R.
+ # TODO: how to trigger interrupt remotely?
+ abort = function(...) {
+ putMark(FALSE, 4L)
+ cat("Execution aborted.\n") #DEBUG
+ },
+
+
+ muffleWarning = function() NULL,
+ grmbl = restartError),
+ error = function(e) { #XXX: this is called if warnLevel=2
+ putMark(FALSE, 5L)
+ cat(.makeMessage(e))
+ e #identity
+ }, finally = { }
+
+ )
+
+ #lapply(res, function(x) {
+ # if(inherits(x, "list") && x$visible) {
+ # print(x$value)
+ # } #else { cat('<invisible>\n') }
+ #})
+
+ if(getWarnLev() == 0L) {
+
+ nwarn <- length(last.warning)
+ assign("last.warning", last.warning, envir = baseenv())
+
+ if(nwarn > 0L) putMark(FALSE, 6L)
+ if(nwarn <= 10L) {
+
+ print.warnings(last.warning)
+ } else if (nwarn < 50L) {
+ ## This is buggy and does not retrieve a translation of the message!
+ #cat(gettextf("There were %d warnings (use warnings() to see them)\n",
+ # nwarn, domain = "R"))
+ msg <- ngettext(1,
+ "There were %d warnings (use warnings() to see them)\n",
+ "There were %d warnings (use warnings() to see them)\n",
+ domain = "R")
+ cat(sprintf(msg, nwarn))
+ } else {
+ cat(ngettext(1,
+ "There were 50 or more warnings (use warnings() to see the first 50)\n",
+ "There were 50 or more warnings (use warnings() to see the first 50)\n",
+ domain = "R"))
+ }
+ }
+ putMark(TRUE, 7L)
+
+ sink(type = "message")
+ sink(type = "output")
+ close(tconn)
+ on.exit()
+
+ ## Allow for tracebacks of this call stack:
+ assign(".Traceback", lapply(Traceback, deparse), envir = baseenv())
+
+ attr(rval, "marks") <- marks
+ return(rval)
+}
Property changes on: komodo/SciViews-K-dev/R/captureAll.R
___________________________________________________________________
Added: svn:special
+ *
Added: komodo/SciViews-K-dev/R/compile_json.tcl
===================================================================
--- komodo/SciViews-K-dev/R/compile_json.tcl (rev 0)
+++ komodo/SciViews-K-dev/R/compile_json.tcl 2011-08-08 20:47:13 UTC (rev 383)
@@ -0,0 +1,67 @@
+proc compile_json {spec data} {
+ while [llength $spec] {
+ set type [lindex $spec 0]
+ set spec [lrange $spec 1 end]
+
+ switch -- $type {
+ dict {
+ lappend spec * string
+
+ set json {}
+ foreach {key val} $data {
+ foreach {keymatch valtype} $spec {
+ if {[string match $keymatch $key]} {
+ lappend json [subst {"$key":[compile_json $valtype $val]}]
+ break
+ }
+ }
+ }
+ return "{[join $json ,]}"
+ }
+ list {
+ if {![llength $spec]} {
+ set spec string
+ } else {
+ set spec [lindex $spec 0]
+ }
+ set json {}
+ foreach {val} $data {
+ lappend json "[compile_json $spec $val]"
+ }
+ return "\[[join $json ,]\]"
+ }
+ string {
+ if {[string is double -strict $data]} {
+ return $data
+ } else {
+ return \"[escape_nonprintable $data]\"
+ }
+ }
+ num { return "$data" }
+ default {error "Invalid type"}
+ }
+ }
+}
+
+#Convert all low-Ascii characters into \u escape sequences by using regsub and subst in combination:
+proc escape_nonprintable {str} {
+
+ set str [string map [list \\ \\\\ \" \\" \n \\n \b \\b \r \\r \t \\t ] $str]
+
+ # meaningful Tcl characters must be escaped too
+ #set RE {[\[\]\{\};#\$\u0000-\u001f]}
+ set RE {[\[\{\};#\$\u0000-\u001f]}
+
+ # We will substitute with a fragment of Tcl script in brackets
+ set substitution {[format \\\\u%04x [scan "\\&" %c]]}
+
+ # Now we apply the substitution to get a subst-string that
+ # will perform the computational parts of the conversion.
+
+
+ #return [subst -nobackslashes -novariables [regsub -all $RE $str $substitution]]
+ return [string map {\\u005b [ \\u007b \{} \
+ [subst -nobackslashes -novariables [regsub -all $RE $str $substitution]]]
+ #return [regsub -all $RE $str $substitution]
+
+}
Added: komodo/SciViews-K-dev/R/objList.R
===================================================================
--- komodo/SciViews-K-dev/R/objList.R (rev 0)
+++ komodo/SciViews-K-dev/R/objList.R 2011-08-08 20:47:13 UTC (rev 383)
@@ -0,0 +1,276 @@
+objList <- function (id = "default", envir = .GlobalEnv, object = NULL,
+all.names = FALSE, pattern = "", group = "", all.info = FALSE, sep = "\t",
+path = NULL, compare = TRUE, ...)
+{
+ ## Make sure that id is character
+ id <- as.character(id)[1]
+ if (id == "") id <- "default"
+ ename <- NA
+
+ ## Format envir as character (use only first item provided!)
+ if (!is.environment(envir)){
+ if(is.numeric(envir) && envir > 0)
+ envir <- search()[envir]
+
+ if (is.character(envir)) {
+ ename <- envir
+ envir <- tryCatch(as.environment(envir), error = function(e) NULL)
+ if (is.null(envir) || inherits(envir, "error")) {
+ envir <- NULL
+ ename <- ""
+ }
+ }
+ }
+
+ # base and .GlobalEnv do not have name attribute
+ if (!is.null(attr(envir, "name"))) ename <- attr(envir, "name")
+ else if (is.na(ename)) ename <- deparse(substitute(envir))
+ if (ename %in% c("baseenv()", ".BaseNamespaceEnv"))
+ ename <- "package:base"
+
+
+ ## Object to return in case of empty data
+ # This is ~15x faster than data.frame...
+ Nothing <- structure(list(Name = character(0),
+ Dims = character(0), Group = character(0), Class = character(0),
+ Recursive = logical(0), stringsAsFactors = FALSE),
+ class=c("objList", "data.frame"),
+ all.info= all.info, envir=ename, object=object
+ )
+ if (isTRUE(all.info)) Nothing <- cbind(Envir = character(0), Nothing)
+
+
+ if (is.null(envir)) return(Nothing)
+
+ if (!missing(object) && is.character(object) && object != "") {
+ res <- .lsObj(envir = envir, objname = object)
+ } else {
+ ## Get the list of objects in this environment
+ Items <- ls(envir = envir, all.names = all.names, pattern = pattern)
+ if (length(Items) == 0) return(Nothing)
+
+ res <- data.frame(Items, t(vapply(Items, function(x) .objDescr(envir[[x]]),
+ character(4))), stringsAsFactors = FALSE, check.names = FALSE)
+ colnames(res) <- c("Name", "Dims", "Group", "Class", "Recursive")
+
+ # Quote non-syntactic names
+ nsx <- res$Name != make.names(res$Name)
+ res$Full.name[!nsx] <- res$Name[!nsx]
+ res$Full.name[nsx] <- paste("`", res$Name[nsx], "`", sep = "")
+ res <- res[, c(1, 6, 2:5)]
+ }
+
+ if (NROW(res) == 0) return(Nothing)
+
+ if (isTRUE(all.info)) res <- cbind(Envir = ename, res)
+
+ vMode <- Groups <- res$Group
+ vClass <- res$Class
+
+ ## Recalculate groups into meaningful ones for the object explorer
+ ## 1) Correspondance of typeof() and group depicted in the browser
+ Groups[Groups %in% c("name", "environment", "promise", "language", "char",
+ "...", "any", "(", "call", "expression", "bytecode", "weakref",
+ "externalptr")] <- "language"
+
+ Groups[Groups == "pairlist"] <- "list"
+
+ ## 2) All Groups not being language, function or S4 whose class is
+ ## different than typeof are flagged as S3 objects
+ Groups[!(Groups %in% c("language", "function", "S4")) &
+ vMode != vClass] <- "S3"
+
+ ## 3) Integers of class factor become factor in group
+ Groups[vClass == "factor"] <- "factor"
+
+ ## 4) Objects of class 'data.frame' are also group 'data.frame'
+ Groups[vClass == "data.frame"] <- "data.frame"
+
+ ## 5) Objects of class 'Date' or 'POSIXt' are of group 'DateTime'
+ Groups[vClass == "Date" | vClass == "POSIXt"] <- "DateTime"
+
+ ## Reaffect groups
+ res$Group <- Groups
+
+ ## Possibly filter according to group
+ if (!is.null(group) && group != "")
+ res <- res[Groups == group, ]
+
+ ## Determine if it is required to refresh something
+ Changed <- TRUE
+ if (isTRUE(compare)) {
+ allList <- getTemp(".guiObjListCache", default = list())
+
+ if (identical(res, allList[[id]])) Changed <- FALSE else {
+ ## Keep a copy of the last version in TempEnv
+ allList[[id]] <- res
+ assignTemp(".guiObjListCache", allList)
+ }
+ }
+
+ ## Create the 'objList' object
+ attr(res, "all.info") <- all.info
+ attr(res, "envir") <- ename
+ attr(res, "object") <- object
+ attr(res, "class") <- c("objList", "data.frame")
+
+ if (is.null(path)) { # Return results or "" if not changed
+ return(if (Changed) res else Nothing)
+ } else if (Changed) { # Write to files in this path
+ return(write.objList(res, path = path, sep = sep, ...))
+ } else {
+ return(Nothing) # Not changed
+ }
+}
+
+write.objList <- function (x, path, sep = "\t", ...)
+{
+ id <- attr(x, "id")
+ ListF <- file.path(path, sprintf("List_%s.txt", id))
+ ParsF <- file.path(path, sprintf("Pars_%s.txt", id))
+
+ write.table(as.data.frame(x), row.names = FALSE, col.names = FALSE,
+ sep = sep, quote = FALSE, file = ListF)
+
+ ## Write also in the Pars_<id>.txt file in the same directory
+ cat(sprintf("envir=%s\nall.names=%s\npattern=%s\ngroup=%s",
+ attr(x, "envir"), attr(x, "all.names"), attr(x, "pattern"),
+ attr(x, "group")), file = ParsF, append = FALSE)
+
+ return(invisible(ListF))
+}
+
+print.objList <- function (x, sep = NA, eol = "\n",
+header = !attr(x, "all.info"), raw.output = !is.na(sep), ...)
+{
+ if (!inherits(x, "objList"))
+ stop("x must be an 'objList' object")
+
+ empty <- NROW(x) == 0
+
+ if (!raw.output)
+ cat(if (empty) "An empty objects list\n" else "Objects list:\n")
+
+ if (header) {
+ header.fmt <- if (raw.output) "Env=%s\nObj=%s\n" else
+ "\tEnvironment: %s\n\tObject: %s\n"
+
+ objname <- if (is.null(attr(x, "object"))) {
+ if (raw.output) "" else "<All>"
+ } else attr(x, "object")
+
+ cat(sprintf(header.fmt, attr(x, "envir"), objname))
+ }
+
+ if (!empty) {
+ if (is.na(sep)) {
+ print(as.data.frame(x))
+ } else if (!is.null(nrow(x)) && nrow(x) > 0) {
+ utils::write.table(x, row.names = FALSE, col.names = FALSE, sep = sep,
+ eol = eol, quote = FALSE)
+ }
+ }
+ return(invisible(x))
+}
+
+## Called by objList() when object is provided
+.lsObj <- function (objname, envir, ...)
+{
+ obj <- try(eval(parse(text = objname), envir = as.environment(envir)),
+ silent = TRUE)
+ if (inherits(obj, "try-error")) return(NULL)
+
+ if (is.environment(obj)) obj <- as.list(obj)
+
+ if (mode(obj) == "S4") {
+ ret <- .lsObjS4(obj, objname)
+ } else if (is.function(obj)) {
+ ret <- .lsObjFunction(obj, objname)
+ } else { # S3
+ if (!(mode(obj) %in% c("list", "pairlist")) || length(obj) == 0)
+ return(NULL)
+
+ itemnames <- fullnames <- names(obj)
+ if (is.null(itemnames)) {
+ itemnames <- seq_along(obj)
+ fullnames <- paste(objname, "[[", itemnames, "]]", sep = "")
+ } else {
+ w.names <- itemnames != ""
+ .names <- itemnames[w.names]
+ nsx <- .names != make.names(.names) # Non-syntactic names
+ .names[nsx] <- paste("`", .names[nsx], "`", sep = "")
+ fullnames[w.names] <- paste (objname, "$", .names, sep = "")
+ fullnames[!w.names] <- paste(objname, "[[",
+ seq_along(itemnames)[!w.names], "]]", sep = "")
+ }
+
+ ret <- data.frame(itemnames, fullnames,
+ t(vapply(seq_along(obj), function (i) .objDescr(obj[[i]]), character(4))),
+ stringsAsFactors = FALSE, check.names = FALSE)
+ }
+ if (!is.null(ret))
+ names(ret) <- c("Name", "Full.name", "Dims/default", "Group", "Class",
+ "Recursive")
+ return(ret)
+}
+
+# Called by .lsObj for functions
+.lsObjFunction <- function (obj, objname = deparse(substitute(obj)))
+{
+ ## formals(obj) returns NULL if only arg is ..., try: formals(expression)
+ obj <- formals(args(obj))
+ objname <- paste("formals(args(", objname, "))", sep = "")
+
+ if(length(obj) == 0) return(NULL)
+
+ itemnames <- fullnames <- names(obj)
+ nsx <- itemnames != make.names(itemnames) # non-syntactic names
+ itemnames[nsx] <- paste("`", itemnames[nsx], "`", sep = "")
+ fullnames <- paste(objname, "$", itemnames, sep = "")
+
+ ret <- t(sapply (seq_along(obj), function (i) {
+ x <- obj[[i]]
+ lang <- is.language(obj[[i]])
+ o.class <- class(obj[[i]])[1]
+ o.mode <- mode(obj[[i]])
+
+ d <- deparse(obj[[i]])
+ if (lang && o.class == "name") {
+ o.class <- ""
+ o.mode <- ""
+ }
+
+ ret <- c(paste(d, collapse = "x"), o.class, o.mode, FALSE)
+ return(ret)
+ }))
+
+ ret <- data.frame(itemnames, fullnames, ret, stringsAsFactors = FALSE)
+ return(ret)
+}
+
+## Called by .lsObj in S4 case
+.lsObjS4 <- function (obj, objname = deparse(substitute(obj)))
+{
+ itemnames <- fullnames <- slotNames(obj)
+ nsx <- itemnames != make.names(itemnames)
+ itemnames[nsx] <- paste("`", itemnames[nsx], "`", sep = "")
+ fullnames <- paste(objname, "@", itemnames, sep = "")
+
+ ret <- t(vapply(itemnames, function (i) .objDescr(slot(obj, i)), character(4)))
+ ret <- data.frame(itemnames, fullnames, ret, stringsAsFactors = FALSE, check.names = FALSE)
+ return(ret)
+}
+
+## Returns a *character* vector with elements: dims, mode, class, rec(ursive)
+.objDescr <- function (x) {
+ d <- dim(x)
+ if (is.null(d)) d <- length(x)
+
+ return(c(dims = paste(d, collapse = "x"),
+ mode = mode(x), class = class(x)[1],
+ rec = mode(x) == "S4" || is.function(x) ||
+ (is.recursive(x)
+ && (class(x) != 'POSIXlt')
+ && !is.language(x)
+ && sum(d) != 0)))
+}
Added: komodo/SciViews-K-dev/R/objSearch.R
===================================================================
--- komodo/SciViews-K-dev/R/objSearch.R (rev 0)
+++ komodo/SciViews-K-dev/R/objSearch.R 2011-08-08 20:47:13 UTC (rev 383)
@@ -0,0 +1,26 @@
+objSearch <- function(sep = "\t", path = NULL, compare = TRUE)
+{
+ Search <- search()
+ if (isTRUE(compare)) {
+ oldSearch <- getTemp(".guiObjSearchCache", default = "")
+ ## Compare both versions
+ if (length(Search) != length(oldSearch) || !all(Search == oldSearch)) {
+ ## Keep a copy of the last version in TempEnv
+ assignTemp(".guiObjSearchCache", Search)
+ Changed <- TRUE
+ } else Changed <- FALSE
+ } else Changed <- TRUE
+ if (is.null(path)) { # Return result, as a single character string with sep
+ if (Changed) {
+ if (!is.null(sep)) Search <- paste(Search, collapse = sep)
+ return(Search)
+ } else return("")
+ } else { # Write to a file called 'Search.txt' in this path
+ file <- file.path(path, "Search.txt")
+ if (Changed) {
+ if (is.null(sep)) sep <- "\n"
+ cat(Search, sep = sep, file = file)
+ }
+ return(invisible(Changed))
+ }
+}
Added: komodo/SciViews-K-dev/R/parseText.R
===================================================================
--- komodo/SciViews-K-dev/R/parseText.R (rev 0)
+++ komodo/SciViews-K-dev/R/parseText.R 2011-08-08 20:47:13 UTC (rev 383)
@@ -0,0 +1,57 @@
+`Parse` <- function (text)
+{
+ ## Deprecated, in favor of parseText()
+ .Deprecated("parseText")
+ return(parseText(text))
+}
+
+
+`parseText` <- function (text) {
+
+ ## Parse R instructions provided as a string and return the expression if it
+ ## is correct, or a 'try-error' object if it is an incorrect code, or NA if
+ ## the (last) instruction is incomplete
+
+ #text <- " <- aaaaa(ddd+)"
+
+ res <- tryCatch(parse(text=text), error=identity)
+
+
+ if(inherits(res, "error")) {
+ # Check if this is incomplete code
+
+ msg <- conditionMessage(res)
+ rxUEOI <- sprintf(gsub("%d", "\\\\d+", gettext("%s%d:%d: %s", domain="R")),
+ if(getOption("keep.source")) "<text>:" else "",
+ gettextf("unexpected %s", gettext("end of input", domain="R"),
+ domain="R"))
+
+
+ if(regexpr(rxUEOI, msg, perl=TRUE) == 1) return(NA)
+
+ # This reformats the message as it would appear in the CLI:
+ #msg <- conditionMessage(res)
+ errinfo <-
+ strsplit(sub("(?:<text>:)?(\\d+):(\\d+): +([^\n]+)\n([\\s\\S]*)$", "\\1\n\\2\n\\3\n\\4", msg, perl=T), "\n", fixed=TRUE)[[1]]
+
+ errpos <- as.numeric(errinfo[1:2])
+ err <- errinfo[-(1:3)]
+ rx <- sprintf("^%d:", errpos[1])
+ errcode <- sub(rx, "", err[grep(rx, err)])
+ #errcode <- substr(strsplit(text, "(\r?\n|\r)")[[1]][errpos[1]], start = 0, stop = errpos[2])
+ res <- simpleError(sprintf("%s in \"%s\"", errinfo[3], errcode))
+
+ #e <- res <- simpleError(msg, NULL)
+ e <- res
+
+ # for legacy uses, make it a try-error
+ res <- .makeMessage(res)
+
+ class(res) <- "try-error"
+ attr(res, 'error') <- err
+ }
+
+ return(res)
+}
+
+assign("parseText", parseText, "komodoConnection")
Property changes on: komodo/SciViews-K-dev/R/parseText.R
___________________________________________________________________
Added: svn:special
+ *
Added: komodo/SciViews-K-dev/R/rserver.R
===================================================================
--- komodo/SciViews-K-dev/R/rserver.R (rev 0)
+++ komodo/SciViews-K-dev/R/rserver.R 2011-08-08 20:47:13 UTC (rev 383)
@@ -0,0 +1,263 @@
+#
+# Simple communication between R and a client through a socket connection
+# (c) 2011 Kamil Barton
+#
+# Files: 'rserver.R' 'rserver.tcl' 'captureAll.R' (or package svMisc)
+# Result is evaluated in R and sent back in JSON format
+# Client should format the data in a following way:
+# - escape newline, carriage returns, formfeeds and backslashes with a backslash
+# - if the first character is ASCII #1, then the next character is interpreted
+# as evaluation mode specifier [currently mode is ignored].
+# - command ends with a newline.
+# Old format ("<<<xxx>>>>" marks) is also accepted, but ignored.
+# The result returned is an object with two components "result" and "message".
+# The "message" can be one of: "Want more" (incomplete code, waiting for
+# continuation), "Parse error" or "Done".
+# In the "result", element 'stdout' and 'stdin' streams are delimited by ASCII
+# 03 and 02.
+#
+# Multiple servers can be started (on different ports), and each can
+# simultanously accept multiple connections.
+# The connection can be permanent.
+# TODO: how to send user interrupt?
+
+options(json.method="R")
+
+require(tcltk)
+
+# 'imports'
+.Tcl <- tcltk::.Tcl
+tcl <- tcltk::tcl
+.Tcl.callback <- tcltk::.Tcl.callback
+###
+
+# # Example: make a R function return a value in Tcl:
+# # first, R function should set assign the result to some Tcl value
+# .Tcl("set retval") # <- retval is set locally within the function scope
+# funTest <- function(x) tcl("set", "retval", round(runif(as.numeric(x)), 3))
+# # then, include it the 'retval' argument
+# tclfun(funTest, retval="retval")
+# .Tcl("funTest 5")
+`tclfun` <- function(f, fname=deparse(substitute(f)),
+ retval=NA, body="%s") {
+ cmd <- .Tcl.callback(f)
+ if (is.character(retval))
+ body <- paste("%s; return $", retval, sep="")
+ cmd2 <- sprintf(paste("proc %s {%s} {", body, "}"),
+ fname,
+ paste(names(formals(f)), collapse=" "),
+ gsub("%", "$", cmd, fixed=TRUE))
+ .Tcl(cmd2)
+ cmd2
+}
+
+#-------------------------------------------------------------------------------
+
+if(!file.exists("rserver.tcl")) stop("Cannot find file 'rserver.tcl'")
+tcl('source', "rserver.tcl")
+tcl('source', "compile_json.tcl")
+
+
+#-------------------------------------------------------------------------------
+
+`TempEnv` <- function() {
+ srch <- search()
+ if (is.na(match("TempEnv", srch)))
+ attach(NULL, name="TempEnv", pos = length(srch) - 1L)
+ as.environment("TempEnv")
+}
+
+`assignTemp` <- function (x, value, replace.existing = TRUE)
+ if (replace.existing || !exists(x, envir = TempEnv(), mode = "any",
+ inherits = FALSE))
+ assign(x, value, envir = TempEnv())
+
+`existsTemp` <- function (x, mode = "any")
+ exists(x, envir = TempEnv(), mode = mode, inherits = FALSE)
+
+
+`getTemp` <- function (x, default = NULL, mode = "any", item = NULL) {
+ if (is.null(item)) Mode <- mode else Mode <- "any"
+ if (exists(x, envir = TempEnv(), mode = Mode, inherits = FALSE)) {
+ dat <- get(x, envir = TempEnv(), mode = Mode, inherits = FALSE)
+ if (is.null(item)) return(dat) else {
+ item <- as.character(item)[1]
+ if (inherits(dat, "list") && item %in% names(dat)) {
+ dat <- dat[[item]]
+ if (mode != "any" && mode(dat) != mode) dat <- default
+ return(dat)
+ } else {
+ return(default)
+ }
+ }
+ } else { # Variable not found, return the default value
+ return(default)
+ }
+}
+
+#-------------------------------------------------------------------------------
+`TclReval` <- function(x, id, mode) {
+
+ #command format "\x01.[eHhuQq][<uid>][ESC] code to be evaluated....\r\n"
+ ## DEBUG
+ #cl <- match.call()
+ #cl[[1]] <- as.name("TclReval")
+ #cl <- deparse(cl)
+ #Encoding(cl) <- "UTF-8"
+ #cat(cl, "\n")
+ ## DEBUG
+
+ if (x != "") {
+ Encoding(x) <- "UTF-8"
+ # This is now done by Tcl (DoServe)
+ #if(substr(x, 1L, 1L) == '\x01') {
+ #xmode <- substr(x, 2L, 2L)
+ # x <- substr(x, 3L, nchar(x))
+ #} else {
+ # x <- gsub("^((<<<[\\w=]+>>>)+)", "", x, perl=TRUE) # TODO: mode handling
+ # x <- gsub("<<<n>>>", "\n", x, fixed=TRUE)
+ # xmode <- 'e'
+ #}
+
+ prevcodeVarName <- paste("part", id, sep=".")
+ .tempEnv <- TempEnv()
+
+ prevcode <- if(exists(prevcodeVarName, .tempEnv, inherits = FALSE))
+ get(prevcodeVarName, .tempEnv, inherits = FALSE) else NULL
+
+ # check for ESCape character at the beginning. If one, break multiline
+ if(substr(x, 1L, 1L) == "\x1b") {
+ x <- substr(x, 2L, nchar(x))
+ prevcode <- NULL
+ }
+
+ if (mode != "h") cat(":> ", c(prevcode, x), "\n") # if mode in [e,u]
+
+ expr <- parseText(c(prevcode, x))
+ if(!is.expression(expr) && is.na(expr)) {
+ ret <- ''
+ msg <- 'Want more'
+ assign(prevcodeVarName, c(prevcode, x), .tempEnv)
+ } else {
+ if(inherits(expr, "try-error")) {
+ ret <- c('\x03', c(expr), '\x02')
+ msg <- 'Parse error'
+ } else {
+ ret <- captureAll(expr, markStdErr=TRUE)
+ msg <- 'Done'
+ # TODO: later
+ #lapply(unlist(strsplit(c(prevcode, x), "(\r?\n|\r)")), function(entry)
+ # .Internal(addhistory(entry)))
+ }
+
+ if(exists(prevcodeVarName, .tempEnv, inherits = FALSE))
+ rm(list=prevcodeVarName, envir=.tempEnv)
+ }
+ ###########
+
+ if (identical(getOption("json.method"), "R")) {
+ tcl("set", "retval", simpsON(list(result=c(ret), message=msg)))
+ } else {
+ tcl(if(length(ret) == 1) "lappend" else "set", "result", ret)
+ .Tcl("set result {}")
+ .Tcl("set retval [dict create]")
+ .Tcl("dict set retval result $result")
+ tcl("dict", "set", "retval", "message", msg)
+ .Tcl("set retval [compile_json {dict result list message string} $retval]")
+ }
+ } else {
+ tcl("set", "retval", "") # is set in the function scope
+ }
+}
+tclfun(TclReval, "Rserver::Reval", retval="retval")
+
+
+tcJSON <- function(x, msg = "Done") {
+ .Tcl("set result {}")
+ tcl(if(length(x) == 1) "lappend" else "set", "result", x)
+ .Tcl("set retval [dict create]")
+ .Tcl("dict set retval result $result")
+ tcl("dict", "set", "retval", "message", msg)
+ .Tcl("set retval [compile_json {dict result list message string} $retval]")
+}
+tclfun(tcJSON, "TestJSON", retval="retval")
+
+#-------------------------------------------------------------------------------
+
+`enumServers` <-
+function() as.character(.Tcl("array names Rserver::Server"))
+
+#-------------------------------------------------------------------------------
+
+`TclRprint` <- function(x, debug=0) {
+ if(debug < getOption('warn')) {
+ Encoding(x) <- "UTF-8"
+ cat(sprintf("[[ %s ]]", x), "\n")
+ }
+ invisible(x)
+}
+tclfun(TclRprint, 'Rserver::Rprint')
+#-------------------------------------------------------------------------------
+
+`startServer` <-
+function(port) tcl("Rserver::Start", port)
+
+`listServers` <-
+function() as.numeric(.Tcl("array names Rserver::Server"))
+
+`stopAllServers` <- function() {
+ num <- as.numeric(.Tcl("array size Rserver::Server"))
+ .Tcl('foreach {name} [array names Rserver::Server] { Rserver::Stop $name }')
+ return(num)
+}
+
+`listConnections` <-
+function() as.character(.Tcl("array names Rserver::Connection"))
+
+`stopAllConnections` <- function() {
+ num <- as.numeric(.Tcl("array size Rserver::Connection"))
+ .Tcl('Rserver::CloseAllConnections')
+ return(num)
+}
+
+`koCmd` <- function (cmd, data = NULL, async = FALSE, host = getOption("ko.host"),
+ port = getOption("ko.port"), timeout = 1, type = c("js",
+ "rjsonp", "output"), pad = NULL, ...) {
+
+ if(is.na(port) || !is.numeric(port)) stop("Invalid port: ", port)
+
+ type <- match.arg(type)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/sciviews -r 383
More information about the Sciviews-commits
mailing list