BERT.Storage.R

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