#' BrowserViz: a base class providing simple, extensible message passing between
#' your R session and your web browser, for interactive data visualization.
#'
#' @docType package
#'
#' @name BrowserViz-class
#' @rdname BrowserViz-class
#' @aliases BrowserViz-class
#'
#' @import BiocGenerics
#' @import methods
#' @importFrom utils browseURL
#'
#' @import httpuv
#' @import jsonlite
#'
#' @exportClass BrowserViz
#'
#----------------------------------------------------------------------------------------------------
#' @description
#' Many of the best interactive graphics capabilities available today are written in Javascript and
#' run in a web browser. BrowserViz makes these capabilities available in R, using websockets
#' for message passing back and forth between R and the browser. This class connects your R session to your web browser via websockets,
#' using the R httupv library, which in turn uses the Rook webserver.
#'
#' BrowserViz is a concrete base class, in that instances can be constructed and run - which we do for testing.
#' The primary use of this BrowserViz is to be subclassed: to facilitate the creation of new
#' browser-based, R-connected interactive graphics capabilities embodied in R packages, written by
#' programmers with some skill in both R and Javascript. Two examples of this can
#' be found in these Bioconductor packages \url{https://bioconductor.org/packages/devel/bioc/html/igvR.html}
#' and \url{https://bioconductor.org/packages/devel/bioc/html/RCyjs.html}.
#' @seealso \code{\link{BrowserViz}}
#'
#----------------------------------------------------------------------------------------------------
#' An S4 class to create and manage a modest webserver for websocket message passing between R and Javascript
#' running in your web browser
#'
#' @slot uri The http location at which this modest webserver runs
#' @slot port An integer port number for the http connection
#' @slot websocketConnection An environment managed by the httpuv library on our behalf
#' @slot quiet Logical varaible controlling verbosity during execution
#'
.BrowserViz <- setClass ("BrowserViz",
representation = representation (
uri="character",
port="numeric",
websocketConnection="environment",
quiet="logical"),
prototype = prototype (uri="http://localhost", 9000)
)
#----------------------------------------------------------------------------------------------------
setGeneric('wait', signature='obj', function(obj, msecs) standardGeneric('wait'))
setGeneric('port', signature='obj', function(obj) standardGeneric('port'))
setGeneric('ready', signature='obj', function(obj) standardGeneric('ready'))
setGeneric('getBrowserInfo', signature='obj', function(obj) standardGeneric('getBrowserInfo'))
setGeneric('send', signature='obj', function(obj, msg) standardGeneric('send'))
setGeneric('browserResponseReady', signature='obj', function(obj) standardGeneric('browserResponseReady'))
setGeneric('getBrowserResponse', signature='obj', function(obj) standardGeneric('getBrowserResponse'))
setGeneric('closeWebSocket', signature='obj', function(obj) standardGeneric('closeWebSocket'))
setGeneric('getBrowserWindowTitle', signature='obj', function(obj) standardGeneric('getBrowserWindowTitle'))
setGeneric('setBrowserWindowTitle', signature='obj', function(obj, newTitle) standardGeneric('setBrowserWindowTitle'))
setGeneric('roundTripTest', signature='obj', function (obj, ...) standardGeneric('roundTripTest'))
setGeneric('getBrowserWindowSize', signature='obj', function(obj) standardGeneric('getBrowserWindowSize'))
setGeneric('displayHTMLInDiv', signature='obj', function(obj, htmlText, div.id) standardGeneric('displayHTMLInDiv'))
#----------------------------------------------------------------------------------------------------
log <- function(...)
{
params <- list(...)
arg.count <- length(params)
# printf("params length: %d", arg.count)
if(arg.count == 0) return(invisible())
if(arg.count == 1) {
print(params[[1]])
return(invisible())
}
if(arg.count > 1 && is.character(params[[1]])){
print(noquote(sprintf(...)))
}
} # log
#----------------------------------------------------------------------------------------------------
# some global variables:
BrowserViz.state <- new.env(parent=emptyenv())
BrowserViz.state$onOpenCall <- 0
# this maps from incoming json commands to function calls
dispatchMap <- new.env(parent=emptyenv())
# status is global variable at file scope, invisible outside the package.
# it keeps track of web sockect connection state, and -- crucially --
# holds the result variable. this solves the latency problem: when we make
# a request to the code running in the browser, the browser later (though
# often very quickly) sends a JSON message back to R. If we are, for instance,
# asking for the current browser window title (see 'getBrowserWindowTitle' below), that
# result is sent to the call back we have registered, "handleResponse")
# to make this seem like a synchronous call, the caller sits in a tight sleep loop,
# waiting until status$result is no longer NULL. getBrowserWindowTitle will then
# parse that JSON response into an R variable.
# the checking of status$result, and its retrieval when ready (no longer null)
# is accomplished by exported methods browserResponseReady and getBrowserResponse,
# to be used by subclasses as well.
status <- new.env(parent=emptyenv())
status$result <- NULL
#----------------------------------------------------------------------------------------------------
setupMessageHandlers <- function()
{
log("--- BrowserViz-class, setupMessageHanlders")
addRMessageHandler("handleResponse", "handleResponse")
} # setupMessageHandlers
#----------------------------------------------------------------------------------------------------
#' Constructor for BrowserViz
#'
#' @name BrowserViz constructor
#' @rdname BrowserViz
#'
#' @description
#'
#' This constructor function:
#'
#' \itemize{
#' \item creates the BrowserViz object
#' \item initializes the httpuv web server
#' \item prepares that web server to additionally handle websocket traffic
#' \item loads a "browserFile" - an html/javascript/css web page to communicate with in your web browser
#' \item opens websocket communication between your R session and your browser
#' \item installs an optional "httpQueryProcessingFunction" to handle http (non-websocket) requests.
#' }
#'
#'
#' @param host character The constructor will open an http/websocket port here for web browsers to connect to. localhost by default
#' @param portRange The constructor looks for a free websocket port in this range. 10000:10100 by default
#' @param title Used for the web browser window, "igvR" by default
#' @param browserFile The full path to the bundled html, js and libraries, and css which constitute the browser app
#' @param quiet A logical variable controlling verbosity during execution
#' @param httpQueryProcessingFunction a function, default NULL, provides subclasses with the
#' opportunity to execute code on the http server created here.
#'
#' @examples
#' library(BrowserViz)
#' browserVizBrowserFile <- system.file(package="BrowserViz", "browserCode", "dist", "bvDemoApp.html")
#' if(BrowserViz::webBrowserAvailableForTesting()){
#' bvApp <- BrowserViz(browserFile=browserVizBrowserFile, quiet=TRUE)
#' data <- list(lowercase=letters, uppercase=LETTERS)
#' json.returned <- roundTripTest(bvApp, data)
#' data.returned <- fromJSON(json.returned)
#' stopifnot(identical(data, data.returned))
#' html <- sprintf("<h3>round trip of json-encoded data, %d chars</h3>",
#' nchar(json.returned))
#' displayHTMLInDiv(bvApp, html, "bvDemoDiv")
#' closeWebSocket(bvApp)
#' }
#'
#' @return An object of the BrowserViZ class
#'
#' @export
#'
#'
BrowserViz = function(host="localhost", portRange=10000:10100, title="BrowserViz", browserFile, quiet=TRUE,
httpQueryProcessingFunction=NULL)
{
if(!quiet){
log("BrowserViz constructor starting with html file '%s'", browserFile)
log(" html file exists? %s", file.exists(browserFile))
}
stopifnot(file.exists(browserFile))
wsCon <- new.env(parent=emptyenv())
wsCon <- .setupWebSocketHandlers(wsCon, browserFile, quiet)
result <- .startServerOnFirstAvailableLocalHostPort(portRange, wsCon)
actualPort <- result$port
wsCon$server <- result$server
if(is.null(actualPort))
stop(sprintf("no available ports in range %d:%d", min(portRange), max(portRange)))
uri = sprintf("http://%s:%s", host, actualPort)
if(!quiet){
log("summoning default browser to get %s", uri)
}
sleepTime <- 2
Sys.sleep(sleepTime);
browseURL(uri, browser=.getBrowser())
if(!quiet)
log("starting daemonized server on port %s", actualPort)
setupMessageHandlers()
obj <- .BrowserViz(uri=uri, websocketConnection=wsCon, port=actualPort, quiet=quiet)
BrowserViz.state[["httpQueryProcessingFunction"]] <- httpQueryProcessingFunction
totalWait <- 0.0
sleepTime <- 100
while(!wsCon$open){
wait(obj, sleepTime)
totalWait <- totalWait + (sleepTime/1000)
}
log("BrowserViz websocket ready after %6.2f seconds", totalWait);
obj
} # BrowserViz: constructor
#----------------------------------------------------------------------------------------------------
.startServerOnFirstAvailableLocalHostPort <- function(portRange, wsCon)
{
done <- FALSE
port <- portRange[1]
server <- NULL
while(!done){
if(port > max(portRange))
done <- TRUE
else{
log("attempting to open websocket connection on port %d", port)
server <- tryCatch(startServer("0.0.0.0", port, wsCon),
error=function(m){sprintf("port not available: %d", port)})
}
if("WebServer" %in% class(server)) # will be character if the port is already claimed
done <- TRUE
else
port <- port + 1;
} # while
actualPort <- server$getPort()
list(server=server, port=actualPort)
} # .startServerOnFirstAvailableLocalHostPort
#----------------------------------------------------------------------------------------------------
#' Pause for the specified number of milliseconds
#'
#' @rdname wait
#' @aliases wait
#'
#' @param obj An object of class BrowserViz
#' @param msecs Numeric
#'
#' @examples
#' library(BrowserViz)
#' browserVizBrowserFile <- system.file(package="BrowserViz", "browserCode", "dist", "bvDemoApp.html")
#' if(BrowserViz::webBrowserAvailableForTesting()){
#' bvApp <- BrowserViz(browserFile=browserVizBrowserFile, quiet=TRUE)
#' wait(bvApp, 100)
#' closeWebSocket(bvApp)
#' }
#'
#' @export
#'
setMethod('wait', 'BrowserViz',
function (obj, msecs) {
service(msecs) # an httpuv function
}) # wait
#----------------------------------------------------------------------------------------------------
#' Display the core attributes of the BrowserViz object to stdout
#'
#' @rdname show
#' @aliases show
#'
#' @param object An object of class BrowserViz
#'
#' @examples
#' library(BrowserViz)
#' browserVizBrowserFile <- system.file(package="BrowserViz", "browserCode", "dist", "bvDemoApp.html")
#' if(BrowserViz::webBrowserAvailableForTesting()){
#' bvApp <- BrowserViz(browserFile=browserVizBrowserFile, quiet=TRUE)
#' show(bvApp)
#' closeWebSocket(bvApp)
#' }
#'
#' @export
setMethod('show', 'BrowserViz',
function (object) {
msg <- sprintf("BrowserViz object");
cat(msg, '\n', sep='')
msg <- sprintf("ready? %s", ready(object))
cat(msg, '\n', sep='')
msg <- sprintf("port: %d", port(object))
cat(msg, '\n', sep='')
}) # show
#----------------------------------------------------------------------------------------------------
#' Get the port number
#'
#' @rdname port
#' @aliases port
#'
#' @param obj An object of class BrowserViz
#'
#' @examples
#' library(BrowserViz)
#' browserVizBrowserFile <- system.file(package="BrowserViz", "browserCode", "dist", "bvDemoApp.html")
#' if(BrowserViz::webBrowserAvailableForTesting()){
#' bvApp <- BrowserViz(browserFile=browserVizBrowserFile, quiet=TRUE)
#' port(bvApp)
#' closeWebSocket(bvApp)
#' }
#'
#'
#' @return the port number use in the websocket connection, a numeric value.
#'
#' @export
#'
setMethod('port', 'BrowserViz',
function (obj) {
obj@port
})
#----------------------------------------------------------------------------------------------------
#' Close the websocket connection - between your R session and your web browser.
#'
#' @rdname closeWebSocket
#' @aliases closeWebSocket
#'
#' @param obj An object of class BrowserViz
#'
#' @examples
#' library(BrowserViz)
#' browserVizBrowserFile <- system.file(package="BrowserViz", "browserCode", "dist", "bvDemoApp.html")
#' if(BrowserViz::webBrowserAvailableForTesting()){
#' bvApp <- BrowserViz(browserFile=browserVizBrowserFile, quiet=TRUE)
#' show(bvApp)
#' closeWebSocket(bvApp)
#' }
#'
#'
#' @export
#'
setMethod('closeWebSocket', 'BrowserViz',
function (obj) {
if(!obj@websocketConnection$open){
warning("websocket server is not open, cannot close");
return()
}
obj@websocketConnection$open <- FALSE
obj@websocketConnection$server$stop()
obj@websocketConnection$ws <- NULL
obj@websocketConnection$ws <- -1
invisible(obj)
})
#----------------------------------------------------------------------------------------------------
#' Is the websocket connection to the browser ready for use?
#'
#' @rdname ready
#' @aliases ready
#'
#' @param obj An object of class BrowserViz
#'
#' @examples
#' library(BrowserViz)
#' browserVizBrowserFile <- system.file(package="BrowserViz", "browserCode", "dist", "bvDemoApp.html")
#' if(BrowserViz::webBrowserAvailableForTesting()){
#' bvApp <- BrowserViz(browserFile=browserVizBrowserFile, quiet=TRUE)
#' ready(bvApp)
#' closeWebSocket(bvApp)
#' }
#'
#' @export
#'
setMethod('ready', 'BrowserViz',
function (obj) {
if(!is.environment(obj@websocketConnection)){
log("--- obj@websocketConnection not an environment")
return(FALSE)
}
if(!obj@websocketConnection$open){
log("--- obj@websocketConnection not open")
return(FALSE)
}
TRUE;
})
#----------------------------------------------------------------------------------------------------
#' browserResponseReady
#'
#' @rdname browserResponseReady
#' @aliases browserResponseReady
#'
#' @param obj An object of class BrowserViz
#'
#' @examples
#' library(BrowserViz)
#' browserVizBrowserFile <- system.file(package="BrowserViz", "browserCode", "dist", "bvDemoApp.html")
#' if(BrowserViz::webBrowserAvailableForTesting()){
#' bvApp <- BrowserViz(browserFile=browserVizBrowserFile, quiet=TRUE)
#' browserResponseReady(bvApp)
#' closeWebSocket(bvApp)
#' }
#'
#' @export
#'
setMethod('browserResponseReady', 'BrowserViz',
function (obj) {
return(!is.null(status$result))
})
#----------------------------------------------------------------------------------------------------
#' Retrieve the response sent by the browser
#'
#' @rdname getBrowserResponse
#' @aliases getBrowserResponse
#'
#' @param obj An object of class BrowserViz
#'
#' @examples
#' library(BrowserViz)
#' browserVizBrowserFile <- system.file(package="BrowserViz", "browserCode", "dist", "bvDemoApp.html")
#' if(BrowserViz::webBrowserAvailableForTesting()){
#' bvApp <- BrowserViz(browserFile=browserVizBrowserFile, quiet=TRUE)
#' data <- list(lowercase=letters, uppercase=LETTERS)
#' json.returned <- roundTripTest(bvApp, data)
#' data.returned <- fromJSON(json.returned)
#' stopifnot(identical(data, data.returned))
#' closeWebSocket(bvApp)
#' }
#'
#' @export
#'
setMethod('getBrowserResponse', 'BrowserViz',
function (obj) {
if(!obj@quiet){
log("BrowserViz getBrowserResponse, length %d", length(status$result))
}
x <- status$result
return(x)
})
#----------------------------------------------------------------------------------------------------
.setupWebSocketHandlers <- function(wsCon, browserFile, quiet)
{
if(!quiet){
log("--- entering BrowserViz .setupWebSocketHandlers");
log(" browserFile: %s (%s)", browserFile, file.exists(browserFile));
}
wsCon$open <- FALSE
wsCon$ws <- NULL
wsCon$result <- NULL
# process http requests
wsCon$call = function(req) {
qs <- req$QUERY_STRING
if(nchar(qs) > 0){
if(!quiet) print("--- bv$call, about to call dynamically assigned queryProcessor");
fields <- ls(req)
queryProcessorFunction <- BrowserViz.state[["httpQueryProcessingFunction"]]
if(!is.null(queryProcessorFunction)){
queryResult <- queryProcessorFunction(qs)
body <- queryResult$body
contentType <- queryResult$contentType
}
else{
body <- "no query processor registered"
contentType <- "text/html"
}
return(list(status=200L, headers=list('Content-Type'=contentType), body=body))
} # the request had a query string
wsUrl = paste(sep='', '"', "ws://",
ifelse(is.null(req$HTTP_HOST), req$SERVER_NAME, req$HTTP_HOST),
'"')
list(
status = 200L,
headers = list('Content-Type' = 'text/html'),
body = c(file=browserFile))
}
# called whenever a websocket connection is opened
wsCon$onWSOpen = function(ws) {
BrowserViz.state$onOpenCall <- BrowserViz.state$onOpenCall + 1
if(!quiet)
print("BrowserViz.setupWebSocketHandlers, wsCon$onWSOpen");
wsCon$ws <- ws # crucial assignment: this provides later calls to e.g., wsCon$ws$send
ws$onMessage(function(binary, rawMessage) {
print("BrowserViz.setupWebSocketHandlers, onMessage, message received");
message <- as.list(fromJSON(rawMessage))
status$message <- message
wsCon$lastMessage <- message
if(!is(message, "list")){
message("message: new websocket message is not a list");
return;
}
if (! "cmd" %in% names(message)){
message("error: new websocket message has no 'cmd' field");
return;
}
cmd <- message$cmd
if(!quiet)
log("BrowserViz dispatching on msg$cmd: %s", message$cmd);
dispatchMessage(ws, message, quiet);
}) # onMessage
wsCon$open <- TRUE
} # onWSOpen
wsCon
} # .setupWebSocketHandlers
#--------------------------------------------------------------------------------
#' Supply the name of a function to call, identified by its key
#'
#' @rdname addRMessageHandler
#' @aliases addRMessageHandler
#'
#' @param key A character string
#' @param functionName A character string
#'
#' @export
#'
addRMessageHandler <- function(key, functionName)
{
dispatchMap[[key]] <- functionName
log("--- added new R message handler: %s", key)
} # addRMessagHandler
#---------------------------------------------------------------------------------------------------
#' Route the message coming in from the browser to the appropriate R function.
#'
#' @rdname dispatchMessage
#' @aliases dispatchMessage
#'
#' @param ws a websocket connectin
#' @param msg the JSON-encoded message from the browser
#' @param quiet logical TRUE or FALSE
#'
#'
dispatchMessage <- function(ws, msg, quiet)
{
if(!msg$cmd %in% ls(dispatchMap)){
log("dispatchMessage error! the incoming cmd '%s' is not recognized", msg$cmd)
return()
}
function.name <- dispatchMap[[msg$cmd]]
success <- TRUE
if(is.null(function.name)){
log("dispatchMessage error! cmd ('%s') not recognized", msg$cmd)
success <- FALSE
return()
}
tryCatch(func <- get(function.name), error=function(m) func <<- NULL)
if(is.null(func)){
log("dispatchMessage error! cmd ('%s' recognized but no corresponding function", msg$cmd)
success <- FALSE
}
if(success){
if(!quiet)
log("BrowserViz.dispatchMessage calling function '%s'", function.name)
do.call(func, list(ws, msg))
}
} # dispatchMessage
#---------------------------------------------------------------------------------------------------
#' Send the specified message to the browser
#'
#' @rdname send
#' @aliases send
#'
#' @param obj An object of class BrowserViz
#' @param msg A list with four fields: {cmd: "someCommand", status: "request",
#' callback: "someFunction", payload: "someData"}
#' @export
#'
setMethod('send', 'BrowserViz',
function(obj, msg) {
msg.json <- toJSON(msg)
if(!obj@quiet){
log("BrowserViz-class send, msg: ")
log(msg.json)
log(toJSON(msg))
}
obj@websocketConnection$ws$send(toJSON(msg))
status$result <- NULL
})
#--------------------------------------------------------------------------------
#' Retrieve basic attributes of the attached web browser.
#'
#' @rdname getBrowserInfo
#' @aliases getBrowserInfo
#'
#' @param obj An object of class BrowserViz
#'
#' @examples
#' library(BrowserViz)
#' browserVizBrowserFile <- system.file(package="BrowserViz", "browserCode", "dist", "bvDemoApp.html")
#' if(BrowserViz::webBrowserAvailableForTesting()){
#' bvApp <- BrowserViz(browserFile=browserVizBrowserFile, quiet=TRUE)
#' getBrowserInfo(bvApp)
#' closeWebSocket(bvApp)
#' }
#'
#' @export
#'
setMethod('getBrowserInfo', 'BrowserViz',
function (obj) {
send(obj, list(cmd="getBrowserInfo", callback="handleResponse", status="request", payload=""))
while (!browserResponseReady(obj)){
wait(obj, 100)
}
getBrowserResponse(obj);
})
#--------------------------------------------------------------------------------
#' Send data to the browser, ensure that it is returned accurately.
#'
#' @rdname roundTripTest
#' @aliases roundTripTest
#'
#' @param obj An object of class BrowserViz
#' @param ... other arguments
#'
#' @examples
#' library(BrowserViz)
#' browserVizBrowserFile <- system.file(package="BrowserViz", "browserCode", "dist", "bvDemoApp.html")
#' if(BrowserViz::webBrowserAvailableForTesting()){
#' bvApp <- BrowserViz(browserFile=browserVizBrowserFile, quiet=TRUE)
#' data <- list(lowercase=letters, uppercase=LETTERS)
#' json.returned <- roundTripTest(bvApp, data)
#' data.returned <- fromJSON(json.returned)
#' stopifnot(identical(data, data.returned))
#' closeWebSocket(bvApp)
#' }
#'
#' @export
#'
setMethod('roundTripTest', 'BrowserViz',
function (obj, ...) {
payload <- toJSON(...)
send(obj, list(cmd="roundTripTest", callback="handleResponse", status="request", payload=payload))
while (!browserResponseReady(obj)){
wait(obj, 100)
}
getBrowserResponse(obj);
})
#----------------------------------------------------------------------------------------------------
#' Supply the name of a function to call, identified by its key
#'
#' @rdname getBrowserWindowTitle
#' @aliases getBrowserWindowTitle
#'
#' @param obj An object of class BrowserViz
#'
#' @examples
#' library(BrowserViz)
#' browserVizBrowserFile <- system.file(package="BrowserViz", "browserCode", "dist", "bvDemoApp.html")
#' if(BrowserViz::webBrowserAvailableForTesting()){
#' bvApp <- BrowserViz(browserFile=browserVizBrowserFile, quiet=TRUE)
#' getBrowserWindowTitle(bvApp)
#' closeWebSocket(bvApp)
#' }
#'
#' @export
#'
setMethod('getBrowserWindowTitle', 'BrowserViz',
function (obj) {
send(obj, list(cmd="getWindowTitle", callback="handleResponse", status="request", payload=""))
#browser()
while (!browserResponseReady(obj)){
wait(obj, 100)
}
getBrowserResponse(obj);
})
#----------------------------------------------------------------------------------------------------
#' Supply the name of a function to call, identified by its key
#'
#' @rdname setBrowserWindowTitle
#' @aliases setBrowserWindowTitle
#'
#' @param obj An object of class BrowserViz
#' @param newTitle A character string
#'
#' @examples
#' library(BrowserViz)
#' browserVizBrowserFile <- system.file(package="BrowserViz", "browserCode", "dist", "bvDemoApp.html")
#' if(BrowserViz::webBrowserAvailableForTesting()){
#' bvApp <- BrowserViz(browserFile=browserVizBrowserFile, quiet=TRUE)
#' getBrowserWindowTitle(bvApp)
#' setBrowserWindowTitle(bvApp, "testBrowser")
#' getBrowserWindowTitle(bvApp)
#' closeWebSocket(bvApp)
#' }
#'
#' @export
#'
setMethod('setBrowserWindowTitle', 'BrowserViz',
function (obj, newTitle) {
payload = list(title=newTitle)
log("setBrowserWindow, new title: %s", newTitle)
send(obj, list(cmd="setWindowTitle", callback="handleResponse", status="request",
payload=payload))
while (!browserResponseReady(obj)){
wait(obj, 100)
}
invisible(getBrowserResponse(obj))
})
#----------------------------------------------------------------------------------------------------
#' Supply the name of a function to call, identified by its key
#'
#' @rdname getBrowserWindowSize
#' @aliases getBrowserWindowSize
#'
#' @param obj An object of class BrowserViz
#'
#' @examples
#' library(BrowserViz)
#' browserVizBrowserFile <- system.file(package="BrowserViz", "browserCode", "dist", "bvDemoApp.html")
#' if(BrowserViz::webBrowserAvailableForTesting()){
#' bvApp <- BrowserViz(browserFile=browserVizBrowserFile, quiet=TRUE)
#' getBrowserWindowSize(bvApp)
#' closeWebSocket(bvApp)
#' }
#'
#'
#' @export
#'
setMethod('getBrowserWindowSize', 'BrowserViz',
function (obj) {
send(obj, list(cmd="getWindowSize", callback="handleResponse", status="request", payload=""))
while (!browserResponseReady(obj)){
wait(obj, 100)
}
as.list(fromJSON(getBrowserResponse(obj)))
})
#----------------------------------------------------------------------------------------------------
#' Ask the browser to display html markup in the specified div
#'
#' @rdname displayHTMLInDiv
#' @aliases displayHTMLInDiv
#'
#' @param obj An object of class BrowserViz
#' @param htmlText A character string with HTML markup
#' @param div.id A character string
#'
#' @examples
#' library(BrowserViz)
#' browserVizBrowserFile <- system.file(package="BrowserViz", "browserCode", "dist", "bvDemoApp.html")
#' if(BrowserViz::webBrowserAvailableForTesting()){
#' bvApp <- BrowserViz(browserFile=browserVizBrowserFile, quiet=TRUE)
#' data <- list(lowercase=letters, uppercase=LETTERS)
#' json.returned <- roundTripTest(bvApp, data)
#' html <- sprintf("<h3>round trip of json-encoded data, %d chars</h3>",
#' nchar(json.returned))
#' displayHTMLInDiv(bvApp, html, "bvDemoDiv")
#' closeWebSocket(bvApp)
#' }
#'
#' @export
#'
setMethod('displayHTMLInDiv', 'BrowserViz',
function (obj, htmlText, div.id) {
payload = list(htmlText=htmlText, divID=div.id)
send(obj, list(cmd="displayHTMLInDiv", callback="handleResponse", status="request", payload=payload))
while (!browserResponseReady(obj)){
wait(obj, 100)
}
#as.list(fromJSON(getBrowserResponse(obj)))
})
#----------------------------------------------------------------------------------------------------
#' Is there a web browser available for testing?
#'
#' @description
#' This package's unit tests require a web browser to connect to. our heuristic, though not bullet
#' proof, is that one of three conditions must be met
#' Supply the name of a function to call, identified by its key
#'
#' @name webBrowserAvailableForTesting
#' @rdname webBrowserAvailableForTesting
#' @aliases webBrowserAvailableForTesting
#'
#' @examples
#' library(BrowserViz)
#' browserVizBrowserFile <- system.file(package="BrowserViz", "browserCode", "dist", "bvDemoApp.html")
#' if(BrowserViz::webBrowserAvailableForTesting()){
#' bvApp <- BrowserViz(browserFile=browserVizBrowserFile, quiet=TRUE)
#' data <- list(lowercase=letters, uppercase=LETTERS)
#' json.returned <- roundTripTest(bvApp, data)
#' html <- sprintf("<h3>round trip of json-encoded data, %d chars</h3>",
#' nchar(json.returned))
#' displayHTMLInDiv(bvApp, html, "bvDemoDiv")
#' closeWebSocket(bvApp)
#' }
#'
#' @return Logical TRUE or FALSE
#'
#' @export
#'
webBrowserAvailableForTesting <- function()
{
authorsDevelopmentMachine <- grepl("hagfish", Sys.info()["nodename"])
bioconductorBuildSystem.linux <- with(as.list(Sys.info()), sysname == "Linux")
interactiveUse <- interactive()
return(authorsDevelopmentMachine || interactiveUse)
} # webBrowserAvailableForTesting
#----------------------------------------------------------------------------------------------------
#' handleResponse
#'
#' @rdname handleResponse
#' @aliases handleResponse
#'
#' @param ws websocket connection
#' @param msg the JSON-encoded character string returned by the browser
#'
#' @return NULL
#'
#' @export
#'
handleResponse <- function(ws, msg)
{
if(msg$status == "success" || msg$status == "failure"){
log("-------- BrowserViz handleResponse")
#log(msg$payload)
status$result <- msg$payload
#log(" status$result: ")
#log(status$result)
}
else{
#log(msg$payload)
status$result <- NULL
}
NULL
} # handleResponse
#----------------------------------------------------------------------------------------------------
.getBrowser <- function()
{
getOption("browser")
}
#----------------------------------------------------------------------------------------------------
#' Transform an R data structure into JSON
#'
#' @description
#'
#' The semantics of toJSON changed between RJSONIO and jsonlite: in the latter, scalars are
#' promoted to arrays of length 1. rather than change our javascript code, and since such
#' promotion -- while sensible in the context of R -- strikes me as gratuitous, I follow
#' jeroen ooms suggestion, creating this wrapper
#'
#' @rdname toJSON
#'
#' @param ... Extra arguments passed to this function
#' @param auto_unbox Logical
#'
#' @return a character string with the JSON representation of the R object
#'
#' @export
#'
#' @examples
#'
#' toJSON(data.frame(a=8:10, b=LETTERS[8:10], stringsAsFactors=FALSE))
#'
toJSON <- function(..., auto_unbox = TRUE)
{
jsonlite::toJSON(..., auto_unbox = auto_unbox)
}
#----------------------------------------------------------------------------------------------------
#' Transform JSON string into a native R object
#'
#' @rdname fromJSON
#'
#' @param ... Extra arguments passed to this function
#'
#' @return a native R data structure
#'
#' @export
#'
#' @examples
#'
#' fromJSON(toJSON(data.frame(a=8:10, b=LETTERS[8:10], stringsAsFactors=FALSE)))
#'
fromJSON <- function(...)
{
jsonlite::fromJSON(...)
}
#----------------------------------------------------------------------------------------------------
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.