Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
#------------------------------------------------------------------------------
#
# This is a library for storing arbitrary R objects in Excel workbook files.
# It requires the "XML" library -- install that from the shell using
#
# > install.packages( "XML" )
#
# selecting a CRAN mirror if necessary.
#
# Modern Excel files (meaning xlsx, xlsm and xlsb, but NOT xls) can include
# arbitrary data in "Custom XML Parts". These are XML documents that are
# included in the larger file (xlsx and the other files are just zip files
# containing xml documents).
#
# We can serialize arbitrary R objects to these XML documents and use them
# as storage that persists in the workbook file. The API here includes
# methods for storing, retrieving, listing and removing objects.
#
# This is based on a particular root node in the XML document; there is no
# concept of security or integrity, although you could layer that on top.
# It's also not very efficient; objects are serialized to ASCII and stored
# as CDATA.
#
# Example:
#
# > BERT.Storage$store.object("junk", c(1,2,3));
# > BERT.Storage$list.objects()
# [1] "junk"
# > BERT.Storage$get.object("junk")
# [1] 1 2 3
# > BERT.Storage$delete.object("junk")
# [1] TRUE
#
#------------------------------------------------------------------------------
library(XML);
#
# put these functions in an environment so they're not exposed to Excel
#
if( !exists( "BERT.Storage", envir=.GlobalEnv )){
assign( "BERT.Storage", new.env(), envir=.GlobalEnv );
}
with( BERT.Storage, {
#------------------------------------------------------------------------------
#
# constants
#
#------------------------------------------------------------------------------
NS = "http://bert-toolkit.org/xmlstorage";
ROOT.NODE = "RObjectStore";
VERSION = 1;
#------------------------------------------------------------------------------
#
# methods
#
#------------------------------------------------------------------------------
#
# find an object by name, returning the XML part. this is used
# in get and replace operations. you can use it externally but
# the operational methods are more useful.
#
find.storage.part <- function(name, workbook=EXCEL$Application$get_ActiveWorkbook()){
parts <- workbook$get_CustomXMLParts();
count <- parts$get_Count();
for(i in 1:count){
part = parts$get_Item(i);
x = xmlParseDoc( part$get_XML(), asText=TRUE )
root = xmlRoot(x);
if((xmlName(root) == ROOT.NODE) && (xmlAttrs(root)['name'] == name)){
return(part);
}
}
NULL;
}
#
# list objects in the current document. returns a list of names.
#
list.objects <- function(workbook=EXCEL$Application$get_ActiveWorkbook()){
parts <- workbook$get_CustomXMLParts();
count <- parts$get_Count();
result <- list();
for(i in 1:count){
xml = parts$get_Item(i)$get_XML();
x = xmlParseDoc( xml, asText=TRUE )
root = xmlRoot(x);
if( xmlName(root) == ROOT.NODE ){
result <- c( result, as.character( xmlAttrs(root)['name'] ));
}
}
unlist( result );
}
#
# get an object by name, or NULL if not found
#
get.object <- function(name, workbook=EXCEL$Application$get_ActiveWorkbook()){
part <- find.storage.part(name, workbook);
if( !is.null(part)){
x = xmlParseDoc( part$get_XML(), asText=TRUE )
root = xmlRoot(x);
return( unserialize( charToRaw( xmlValue(xmlChildren(root)$data))));
}
NULL;
}
#
# delete an object by name. returns True if the object existed (and has
# been deleted), otherwise False.
#
delete.object <- function(name, workbook=EXCEL$Application$get_ActiveWorkbook()){
part <- find.storage.part(name, workbook);
if(!is.null(part)){
part$Delete();
return(TRUE);
}
FALSE;
}
#
# store an object in the workbook. if replace is False, and the name
# exists, this method will throw an error.
#
store.object <- function( name, object, workbook=EXCEL$Application$get_ActiveWorkbook(), replace=T ){
tree = xmlTree(ROOT.NODE, attrs = list(name=name, version=VERSION),
dtd=NULL, namespaces=list(), doc = newXMLDoc(NS));
tree$addTag("data", close=FALSE)
tree$addCData(rawToChar(serialize( object, NULL, ascii=T )));
tree$closeTag();
xml <- tree$value();
part <- find.storage.part(name, workbook);
if(!is.null(part)){
if( !replace ){
stop( "Not replacing" );
}
part$Delete();
}
parts <- workbook$get_CustomXMLParts();
part <- parts$Add();
part$LoadXML(saveXML(xml));
}
}); # end with
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment