# R DOM API
# In javascript, we deal in pointers to javascript objects representing
# elements both within and outside of the DOM
# In R, we deal with HTML code for objects not yet in the DOM
# and CSS selectors to refer to objects within the DOM.
# When the javascript code returns a DOM object, we can ask for
# it to be HTML code OR a CSS selector.
dblog <- function(...) {
if (getOption("DOM.debug"))
cat("-- RDOM R : ", ...)
}
# Tracking requests to execute callbacks on response
# Blocking requests until response received
DOMclosure <- function() {
# request IDs
id <- 0
getID <- function() {
id <<- id + 1
as.character(id)
}
requests <- list()
## For debugging
ls <- function() {
requests
}
add <- function(tag, async, callback, returnType, pageID) {
req <- requests[[tag]]
if (!is.null(req)) {
stop(paste0("Request ", tag, " already registered",
" (add failed)"))
} else {
requests[[tag]] <<- list(async=async,
callback=callback,
returnType=returnType,
pageID=pageID,
state="pending")
dblog("Adding request", tag, "\n")
}
}
remove <- function(tag) {
req <- requests[[tag]]
if (is.null(req)) {
stop(paste0("Request ", tag, " not registered",
" (remove failed)"))
} else {
requests[[tag]] <<- NULL
dblog("Removing request", tag, "\n")
}
}
state <- function(tag) {
req <- requests[[tag]]
if (is.null(req)) {
stop(paste0("Request ", tag, " not registered",
" (get state failed)"))
} else {
req$state
}
}
async <- function(tag) {
req <- requests[[tag]]
if (is.null(req)) {
stop(paste0("Request ", tag, " not registered",
" (get async failed)"))
} else {
req$async
}
}
callback <- function(tag) {
req <- requests[[tag]]
if (is.null(req)) {
stop(paste0("Request ", tag, " not registered",
" (get callback failed)"))
} else {
req$callback
}
}
type <- function(tag) {
req <- requests[[tag]]
if (is.null(req)) {
stop(paste0("Request ", tag, " not registered",
" (get responseType failed)"))
} else {
req$returnType
}
}
pageID <- function(tag) {
req <- requests[[tag]]
if (is.null(req)) {
stop(paste0("Request ", tag, " not registered",
" (get responseType failed)"))
} else {
req$pageID
}
}
setValue <- function(tag, value) {
req <- requests[[tag]]
if (is.null(req)) {
stop(paste0("Request ", tag, " not registered",
" (setValue failed)"))
} else {
dblog("Setting value for request", tag, "\n")
requests[[tag]]$value <<- value
requests[[tag]]$state <<- "complete"
}
}
getValue <- function(tag) {
req <- requests[[tag]]
if (is.null(req)) {
stop(paste0("Request ", tag, " not registered",
" (getValue failed)"))
} else {
requests[[tag]]$value
}
}
pending <- function(tag) {
req <- requests[[tag]]
if (is.null(req)) {
stop(paste0("Request ", tag, " not registered",
" (pending test failed)"))
} else {
requests[[tag]]$state != "complete"
}
}
list(getID=getID,
ls=ls,
add=add,
remove=remove,
state=state,
async=async,
callback=callback,
type=type,
pageID=pageID,
setValue=setValue,
getValue=getValue,
pending=pending)
}
DOMfunctions <- DOMclosure()
getRequestID <- DOMfunctions$getID
listRequests <- DOMfunctions$ls
addRequest <- DOMfunctions$add
removeRequest <- DOMfunctions$remove
getRequestState <- DOMfunctions$state
getRequestAsync <- DOMfunctions$async
getRequestCallback <- DOMfunctions$callback
getRequestResponseType <- DOMfunctions$type
getRequestPageID <- DOMfunctions$pageID
setRequestValue <- DOMfunctions$setValue
getRequestValue <- DOMfunctions$getValue
requestPending <- DOMfunctions$pending
DOMresponse <- function(x, type, pageID) {
# When a request is expected to return a DOM node, but returns null
# (e.g., getElementById() finds no match)
if (is.null(x) && type != "NULL")
x <- character()
switch(type,
# Requests that have no return value
"NULL"=NULL,
# Requests that return a JSON object
JSON=x,
# Requests that return a DOM node of some sort
DOM_node_HTML=,
DOM_node_SVG=new(type, as.character(x)),
DOM_node_CSS=,
DOM_node_XPath=,
DOM_node_ptr=,
DOM_CSSStyleSheet_ptr=,
DOM_CSSRule_ptr=,
DOM_CSSStyleDeclaration_ptr=,
DOM_obj_ptr=new(type, as.character(x), pageID=pageID),
# Requests that return a basic value
DOM_number=as.numeric(x),
DOM_string=as.character(x),
DOM_boolean=as.logical(x))
}
# Handling messages
# RECEIVE either REQUEST or RESPONSE
handleMessage <- function(msgJSON, ws) {
# Assume content is character vector JSON
msg <- fromJSON(msgJSON)
if (msg$type == "ALIVE") {
## Page is waiting for this to know that browser has opened web socket
setRequestValue(msg$tag, TRUE)
} else if (msg$type == "DEAD") {
## Page is waiting for browser to die
setRequestValue(msg$tag, msg$body)
} else if (msg$type == "RENDERED") {
## Page is waiting for browser to render
setRequestValue(msg$tag, TRUE)
} else if (msg$type == "PAGECONTENT") {
setRequestValue(msg$tag, msg$body)
} else if (msg$type == "ERROR") {
## A request has failed
## (so set the request value)
## (so any code waiting for this request will terminate)
result <- paste0("Request ", msg$tag, " failed: ", msg$body)
## Warning message will be the result of the request
setRequestValue(msg$tag, new("DOM_error", result))
## Warning message will also print to screen
message(result)
} else if (msg$type == "RESPONSE") {
## Get response value
## If request response type differs from message body type
## then the browser has determined the type of response, so use that
if (getRequestResponseType(msg$tag) != msg$body$type) {
responseType <- msg$body$type
} else {
responseType <- getRequestResponseType(msg$tag)
}
value <- DOMresponse(msg$body$value, responseType,
getRequestPageID(msg$tag))
## When this is a response to a getElement* request, 'null'
## means no elements were found; turn this into character(0)
if (grepl("getElement", msg$body$fn)) {
if (is.null(value)) {
value <- DOMresponse(character(),
responseType,
getRequestPageID(msg$tag))
}
}
## Find the request that generated this response
state <- getRequestState(msg$tag)
if (state == "pending") {
async <- getRequestAsync(msg$tag)
if (!async) {
## Record response value (someone will be waiting for it)
setRequestValue(msg$tag, value)
}
callback <- getRequestCallback(msg$tag)
if (!is.null(callback)) {
## Run callback
callback(value)
}
if (async) {
## Deregister request
removeRequest(msg$tag)
}
} else {
stop(paste("Already handling response", msg$tag))
}
} else if (msg$type == "REQUEST") {
dblog(capture.output(msg$body), sep="\n")
args <- mapply(DOMresponse, msg$body$args, msg$body$argsType,
MoreArgs=list(pageID=msg$pageID),
SIMPLIFY=FALSE, USE.NAMES=FALSE)
callback <- getRegisteredCallback(msg$body$fn)
result <- do.call(callback, c(args, list(pageID=msg$pageID)))
msg <- list(type="RESPONSE",
tag=msg$tag,
body=result)
msgJSON <- toJSON(msg, null="null")
ws$send(msgJSON)
} else {
stop("Unknown message type")
}
}
## Block until response with 'tag' is received
## (if 'limit' is exceeded, error out)
waitForResponse <- function(tag, limit=getOption("DOM.limit"), onTimeout=NULL) {
ptm <- proc.time()
while (requestPending(tag)) {
## Sys.sleep(.1)
## Make sure that requests are service while we are waiting
service(100)
if ((proc.time() - ptm)[3] > limit) {
## Give up on this request
removeRequest(tag)
if (!is.null(onTimeout))
onTimeout()
stop("Exceeded wait time")
}
}
value <- getRequestValue(tag)
## Deregister request
removeRequest(tag)
value
}
# SEND either REQUEST or RESPONSE
# IF 'async' is TRUE, the request is asynchronous and the callback
# will be called when a response with 'tag' is received
# IF 'async' is FALSE, the request is synchronous and R will block until
# a response with 'tag' is received AND the response value will be returned
sendRequest <- function(pageID, msg, tag, async, callback, returnType) {
sock <- pageInfo(pageID)$socket
if (is.null(sock))
stop("No socket open")
msgJSON <- toJSON(msg, null="null")
## Register request (do it before send in case send returns instantly)
addRequest(tag, async, callback, returnType, pageID)
sock$send(msgJSON)
if (!async) {
return(waitForResponse(tag))
}
}
# Function to check validity of DOM objects passed to API functions
# Default is to do nothing
setGeneric("checkDOMobj",
function(object, ...) {})
# For _ptr objects, check that the pageID matches
setMethod("checkDOMobj",
signature(object="DOM_obj_ptr"),
function(object, pageID, ...) {
if (object@pageID != pageID) {
stop("Invalid object pointer")
}
})
################################################################################
## The main API
createElement <- function(pageID, tagName, response=nodePtr(),
async=FALSE, callback=NULL, tag=getRequestID()) {
responseType <- class(response)
msg <- list(type="REQUEST", tag=tag,
body=list(fun="createElement",
tagName=as.character(tagName),
responseType=responseType))
sendRequest(pageID, msg, tag, async, callback, responseType)
}
createElementNS <- function(pageID, namespace, tagName, response=nodePtr(),
async=FALSE, callback=NULL, tag=getRequestID()) {
responseType <- class(response)
msg <- list(type="REQUEST", tag=tag,
body=list(fun="createElementNS",
namespace=as.character(namespace),
tagName=as.character(tagName),
responseType=responseType))
sendRequest(pageID, msg, tag, async, callback, responseType)
}
appendChildCore <- function(pageID, child, parent, response,
ns, async, callback, tag) {
checkDOMobj(child, pageID)
checkDOMobj(parent, pageID)
responseType <- class(response)
msg <- list(type="REQUEST", tag=tag,
body=list(fun="appendChild",
child=as.character(child),
childType=class(child),
parent=as.character(parent),
parentType=class(parent),
ns=ns,
responseType=responseType))
sendRequest(pageID, msg, tag, async, callback, responseType)
}
setGeneric("appendChild",
function(pageID, child, parent, ...) {
standardGeneric("appendChild")
},
valueClass="DOM_node_OR_error_OR_NULL")
setMethod("appendChild",
signature(pageID="numeric",
child="DOM_node",
parent="missing"),
function(pageID, child, parent, response=htmlNode(),
ns=FALSE, async=FALSE, callback=NULL, tag=getRequestID()) {
appendChildCore(pageID, child, parent=css("body"), response,
ns, async, callback, tag)
})
setMethod("appendChild",
signature(pageID="numeric",
child="DOM_node",
parent="DOM_node_ref"),
function(pageID, child, parent, response=htmlNode(),
ns=FALSE, async=FALSE, callback=NULL, tag=getRequestID()) {
appendChildCore(pageID, child, parent, response,
ns, async, callback, tag)
})
removeChildCore <- function(pageID, child, parent, response,
async, callback, tag) {
checkDOMobj(child, pageID)
checkDOMobj(parent, pageID)
responseType <- class(response)
msg <- list(type="REQUEST", tag=tag,
body=list(fun="removeChild",
child=as.character(child),
childType=class(child),
parent=as.character(parent),
parentType=class(parent),
responseType=responseType))
sendRequest(pageID, msg, tag, async, callback, responseType)
}
setGeneric("removeChild",
function(pageID, child, parent, ...) {
standardGeneric("removeChild")
},
valueClass="DOM_node_OR_error_OR_NULL")
setMethod("removeChild",
signature(pageID="numeric",
child="DOM_node_ref",
parent="missing"),
function(pageID, child, parent, response=htmlNode(),
async=FALSE, callback=NULL, tag=getRequestID()) {
removeChildCore(pageID, child, parent=NULL, response,
async, callback, tag)
})
setMethod("removeChild",
signature(pageID="numeric",
child="DOM_node_ref",
parent="DOM_node_ref"),
function(pageID, child, parent, response=htmlNode(),
async=FALSE, callback=NULL, tag=getRequestID()) {
removeChildCore(pageID, child, parent, response,
async, callback, tag)
})
replaceChildCore <- function(pageID, newChild, oldChild, parent, response,
ns, async, callback, tag) {
checkDOMobj(newChild, pageID)
checkDOMobj(oldChild, pageID)
checkDOMobj(parent, pageID)
responseType <- class(response)
msg <- list(type="REQUEST", tag=tag,
body=list(fun="replaceChild",
newChild=as.character(newChild),
newChildType=class(newChild),
oldChild=as.character(oldChild),
oldChildType=class(oldChild),
parent=as.character(parent),
parentType=class(parent),
ns=ns,
responseType=responseType))
sendRequest(pageID, msg, tag, async, callback, responseType)
}
setGeneric("replaceChild",
function(pageID, newChild, oldChild, parent, ...) {
standardGeneric("replaceChild")
},
valueClass="DOM_node_OR_error_OR_NULL")
setMethod("replaceChild",
signature(pageID="numeric",
newChild="DOM_node",
oldChild="DOM_node_ref",
parent="missing"),
function(pageID, newChild, oldChild, parent, response=htmlNode(),
ns=FALSE, async=FALSE, callback=NULL, tag=getRequestID()) {
replaceChildCore(pageID, newChild, oldChild, parent=NULL,
response, ns, async, callback, tag)
})
setMethod("replaceChild",
signature(pageID="numeric",
newChild="DOM_node",
oldChild="DOM_node_ref",
parent="DOM_node_ref"),
function(pageID, newChild, oldChild, parent, response=htmlNode(),
ns=FALSE, async=FALSE, callback=NULL, tag=getRequestID()) {
replaceChildCore(pageID, newChild, oldChild, parent,
response, ns, async, callback, tag)
})
getAttributeCore <- function(pageID, elt, attrName, response,
async, callback, tag) {
checkDOMobj(elt, pageID)
if (length(elt) == 0) {
stop("No elt to get property for")
} else if (length(elt) > 1) {
warning("More than one elt; only using first")
elt <- elt[1]
}
responseType <- class(response)
msg <- list(type="REQUEST", tag=tag,
body=list(fun="getAttribute",
elt=as.character(elt),
eltType=class(elt),
attrName=attrName,
responseType=responseType))
sendRequest(pageID, msg, tag, async, callback, responseType)
}
setGeneric("getAttribute",
function(pageID, elt, attrName, ...) {
standardGeneric("getAttribute")
},
valueClass="DOM_value_OR_error_OR_NULL")
setMethod("getAttribute",
signature(pageID="numeric",
elt="DOM_node_ref",
attrName="character"),
function(pageID, elt, attrName, response=NULL,
async=FALSE, callback=NULL, tag=getRequestID()) {
getAttributeCore(pageID, elt, attrName, response,
async, callback, tag)
})
setAttributeCore <- function(pageID, elt, attrName, attrValue,
async, callback, tag) {
checkDOMobj(elt, pageID)
msg <- list(type="REQUEST", tag=tag,
body=list(fun="setAttribute",
elt=as.character(elt),
eltType=class(elt),
attrName=attrName,
attrValue=attrValue))
sendRequest(pageID, msg, tag, async, callback, "NULL")
}
setGeneric("setAttribute",
function(pageID, elt, attrName, attrValue, ...) {
standardGeneric("setAttribute")
},
valueClass="NULL")
setMethod("setAttribute",
signature(pageID="numeric",
elt="DOM_node_ref",
attrName="character",
attrValue="character"),
function(pageID, elt, attrName, attrValue,
async=FALSE, callback=NULL, tag=getRequestID()) {
setAttributeCore(pageID, elt, attrName, attrValue,
async, callback, tag)
})
getElementByIdCore <- function(pageID, id, response,
async, callback, tag) {
responseType <- class(response)
msg <- list(type="REQUEST", tag=tag,
body=list(fun="getElementById",
id=id,
responseType=responseType))
sendRequest(pageID, msg, tag, async, callback, responseType)
}
setGeneric("getElementById",
function(pageID, id, ...) {
standardGeneric("getElementById")
},
valueClass="DOM_node_OR_error_OR_NULL")
setMethod("getElementById",
signature(pageID="numeric",
id="character"),
function(pageID, id, response=htmlNode(),
async=FALSE, callback=NULL, tag=getRequestID()) {
getElementByIdCore(pageID, id, response,
async, callback, tag)
})
getElementsByTagNameCore <- function(pageID, name, response,
async, callback, tag) {
responseType <- class(response)
msg <- list(type="REQUEST", tag=tag,
body=list(fun="getElementsByTagName",
name=name,
responseType=responseType))
sendRequest(pageID, msg, tag, async, callback, responseType)
}
setGeneric("getElementsByTagName",
function(pageID, name, ...) {
standardGeneric("getElementsByTagName")
},
valueClass="DOM_node_OR_error_OR_NULL")
setMethod("getElementsByTagName",
signature(pageID="numeric",
name="character"),
function(pageID, name, response=htmlNode(),
async=FALSE, callback=NULL, tag=getRequestID()) {
getElementsByTagNameCore(pageID, name, response,
async, callback, tag)
})
getElementsByClassNameCore <- function(pageID, name, root, response,
async, callback, tag) {
responseType <- class(response)
msg <- list(type="REQUEST", tag=tag,
body=list(fun="getElementsByClassName",
name=name,
root=as.character(root),
rootType=class(root),
responseType=responseType))
sendRequest(pageID, msg, tag, async, callback, responseType)
}
setGeneric("getElementsByClassName",
function(pageID, name, root, ...) {
standardGeneric("getElementsByClassName")
},
valueClass="DOM_node_OR_error_OR_NULL")
setMethod("getElementsByClassName",
signature(pageID="numeric",
name="character",
root="missing"),
function(pageID, name, root, response=htmlNode(),
async=FALSE, callback=NULL, tag=getRequestID()) {
getElementsByClassNameCore(pageID, name, root=NULL, response,
async, callback, tag)
})
setMethod("getElementsByClassName",
signature(pageID="numeric",
name="character",
root="DOM_node_ref"),
function(pageID, name, root, response=htmlNode(),
async=FALSE, callback=NULL, tag=getRequestID()) {
getElementsByClassNameCore(pageID, name, root, response,
async, callback, tag)
})
## See property.R for getProperty() and setProperty()
## This request is ALWAYS asynchronous
## Mostly for headless browser testing (?)
setGeneric("click",
function(pageID, elt, ...) {
standardGeneric("click")
},
valueClass="NULL")
setMethod("click",
signature(pageID="numeric",
elt="DOM_node_ref"),
function(pageID, elt,
callback=NULL, tag=getRequestID()) {
checkDOMobj(elt, pageID)
msg <- list(type="REQUEST", tag=tag,
body=list(fun="click",
elt=as.character(elt),
eltType=class(elt)))
sendRequest(pageID, msg, tag, TRUE, callback, "NULL")
})
################################################################################
## Some extra utilities
## For stopping a headless browser (PhantomJS)
kill <- function(pageID) {
tag <- getRequestID()
msg <- list(type="PREPARETODIE", tag=tag)
result <- sendRequest(pageID, msg, tag, FALSE, NULL, "NULL")
msg <- list(type="DIE")
# Do not wait for browser response because browser will die before
# it sends a response
sendRequest(pageID, msg, getRequestID(), TRUE, NULL, "NULL")
result
}
## Deliberately internal functions, so have to call with, e.g., DOM:::debug()
render <- function(pageID, outfile) {
tag <- getRequestID()
msg <- list(type="RENDER", tag=tag, outfile=outfile)
sendRequest(pageID, msg, tag, FALSE, NULL, "NULL")
}
getPage <- function(pageID) {
tag <- getRequestID()
msg <- list(type="GETPAGE", tag=tag)
sendRequest(pageID, msg, tag, FALSE, NULL, "NULL")
}
debug <- function(pageID) {
options(DOM.debug=TRUE)
msg <- list(type="DEBUG")
sendRequest(pageID, msg, getRequestID(), TRUE, NULL, "NULL")
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.