[Rprotobuf-commits] r708 - in pkg: . R inst/proto inst/unitTests man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Jan 4 03:29:01 CET 2014
Author: jeroenooms
Date: 2014-01-04 03:28:59 +0100 (Sat, 04 Jan 2014)
New Revision: 708
Added:
pkg/R/rexp_obj.R
pkg/R/serialize_pb.R
pkg/inst/proto/rexp.proto
pkg/inst/unitTests/runit.serialize_pb.R
pkg/man/serialize_pb.Rd
Modified:
pkg/NAMESPACE
Log:
Merge serialize_pb from RProtoBufUtils
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2014-01-04 02:19:52 UTC (rev 707)
+++ pkg/NAMESPACE 2014-01-04 02:28:59 UTC (rev 708)
@@ -105,4 +105,7 @@
exportPattern( "^CPPTYPE_" )
exportPattern( "^LABEL_" )
+# copied from RProtoBufUtils
+export( "serialize_pb", "unserialize_pb", "can_serialize_pb" )
+
# export( run_unit_tests )
Added: pkg/R/rexp_obj.R
===================================================================
--- pkg/R/rexp_obj.R (rev 0)
+++ pkg/R/rexp_obj.R 2014-01-04 02:28:59 UTC (rev 708)
@@ -0,0 +1,161 @@
+rexp_obj <- function(obj){
+ sm <- typeof(obj);
+ msg <- switch(sm,
+ "character" = rexp_string(obj),
+ "raw" = rexp_raw(obj),
+ "double" = rexp_double(obj),
+ "complex" = rexp_complex(obj),
+ "integer" = rexp_integer(obj),
+ "list" = rexp_list(obj),
+ "logical" = rexp_logical(obj),
+ "NULL" = rexp_null(),
+ {warning("Unsupported R object type:", sm); rexp_null()}
+ );
+
+ attrib <- attributes(obj)
+ msg$attrName <- names(attrib)
+ msg$attrValue <- lapply(attrib, rexp_obj)
+ msg
+}
+
+rexp_string <- function(obj){
+ xvalue <- lapply(as.list(obj), function(x){
+ new(pb(rexp.STRING), strval=x, isNA=is.na(x))
+ })
+ new(pb(rexp.REXP), rclass = 0, stringValue=xvalue)
+}
+
+rexp_raw <- function(obj){
+ new(pb(rexp.REXP), rclass= 1, rawValue = obj)
+}
+
+rexp_double <- function(obj){
+ new(pb(rexp.REXP), rclass=2, realValue = obj)
+}
+
+rexp_complex <- function(obj){
+ xvalue <- lapply(as.list(obj), function(x){
+ new(pb(rexp.CMPLX), real=Re(x), imag=Im(x))
+ })
+ new(pb(rexp.REXP), rclass=3, complexValue = xvalue)
+}
+
+rexp_integer <- function(obj){
+ new(pb(rexp.REXP), rclass=4, intValue = obj)
+}
+
+rexp_list <- function(obj){
+ xobj <- lapply(obj, rexp_obj)
+ new(pb(rexp.REXP), rclass=5, rexpValue = xobj)
+}
+
+rexp_logical <- function(obj){
+ xobj <- as.integer(obj)
+ xobj[is.na(obj)] <- 2
+ new(pb(rexp.REXP), rclass=6, booleanValue = xobj)
+}
+
+rexp_null <- function(){
+ new(pb(rexp.REXP), rclass=7)
+}
+
+unrexp <- function(msg){
+ stopifnot(is(msg, "Message"))
+ stopifnot(msg at type == "rexp.REXP")
+
+ myrexp <- as.list(msg)
+ xobj <- switch(as.character(myrexp$rclass),
+ "0" = unrexp_string(myrexp),
+ "1" = unrexp_raw(myrexp),
+ "2" = unrexp_double(myrexp),
+ "3" = unrexp_complex(myrexp),
+ "4" = unrexp_integer(myrexp),
+ "5" = unrexp_list(myrexp),
+ "6" = unrexp_logical(myrexp),
+ "7" = unrexp_null(),
+ stop("Unsupported rclass:", myrexp$rclass)
+ )
+
+ if(length(myrexp$attrValue)){
+ attrib <- lapply(myrexp$attrValue, unrexp)
+ names(attrib) <- myrexp$attrName
+ attributes(xobj) <- attrib
+ }
+
+ xobj
+}
+
+unrexp_string <- function(myrexp){
+ mystring <- unlist(lapply(myrexp$stringValue, "[[", "strval"))
+ isNA <- unlist(lapply(myrexp$stringValue, "[[", "isNA"))
+ mystring[isNA] <- NA
+ mystring
+}
+
+unrexp_raw <- function(myrexp){
+ myrexp$rawValue
+}
+
+unrexp_double <- function(myrexp){
+ myrexp$realValue
+}
+
+unrexp_complex <- function(myrexp){
+ xvalue <- lapply(myrexp$complexValue, function(x){
+ complex(real=x$real, imaginary=x$imag)
+ })
+ unlist(xvalue)
+}
+
+unrexp_integer <- function(myrexp){
+ myrexp$intValue
+}
+
+unrexp_list <- function(myrexp){
+ lapply(myrexp$rexpValue, unrexp)
+}
+
+unrexp_logical <- function(myrexp){
+ xvalue <- myrexp$booleanValue
+ xvalue[xvalue==2] <- NA
+ as.logical(xvalue)
+}
+
+unrexp_null <- function(){
+ NULL
+}
+
+#Helper function to lookup a PB descriptor
+pb <- function(name){
+ descriptor <- deparse(substitute(name))
+ if(!exists(descriptor, "RProtoBuf:DescriptorPool")){
+ stop("No ProtoBuf Descriptor for: ", descriptor)
+ }
+ get(descriptor, "RProtoBuf:DescriptorPool")
+}
+
+#Checks if object can be serialized
+can_serialize_pb <- rexp_valid <- function(obj) {
+ valid.types <- c("character", "raw", "double", "complex", "integer",
+ "list", "logical", "NULL")
+ sm <- typeof(obj)
+ if (sm %in% valid.types) {
+ if (sm == "list") {
+ if (any(! unlist(lapply(obj, rexp_valid)))) {
+ return(FALSE)
+ }
+ }
+ } else {
+ return(FALSE)
+ }
+ attrib <- attributes(obj)
+ if (is.null(attrib)) {
+ return(TRUE)
+ }
+ if (rexp_valid(names(attrib))) {
+ if (rexp_valid(unname(attrib))) {
+ return(TRUE)
+ }
+ }
+ return(FALSE)
+}
Added: pkg/R/serialize_pb.R
===================================================================
--- pkg/R/serialize_pb.R (rev 0)
+++ pkg/R/serialize_pb.R 2014-01-04 02:28:59 UTC (rev 708)
@@ -0,0 +1,43 @@
+#' Serialize R object to Protocol Buffer Message.
+#'
+#' This function serializes R objects to a general purpose protobuf message. It
+#' uses the same \code{rexp.proto} descriptor and mapping between R objects and
+#' protobuf messages as RHIPE.
+#'
+#' Third party clients need both the message and the \code{rexp.proto} descriptor
+#' to read serialized R objects. The latter is included in the the package
+#' installation \code{proto} directory:
+#' \code{system.file(package="RProtoBuf", "proto/rexp.proto")}
+#'
+#' Currently, the following storage types are supported:
+#' \code{character}, \code{raw}, \code{double}, \code{complex}, \code{integer},
+#' \code{list}, and \code{NULL}. Objects with other storage types, such as
+#' functions, environments, S4 classes, etc, will be skipped with a warning.
+#' Missing values, attributes and numeric precision will be preserved.
+#'
+#' @param object R object to serialize
+#' @param connection passed on to \code{\link{serialize}}
+#' @param ... additional arguments passed on to \code{\link{serialize}}
+#' @aliases unserialize_pb can_serialize_pb
+#' @export unserialize_pb
+#' @export can_serialize_pb
+#' @export
+#' @examples msg <- tempfile();
+#' serialize_pb(iris, msg);
+#' obj <- unserialize_pb(msg);
+#' identical(iris, obj);
+#'
+serialize_pb <- function(object, connection, ...){
+
+ #convert object to protobuf message
+ msg <- rexp_obj(object);
+
+ #serialize the message
+ serialize(msg, connection = connection, ...);
+}
+
+unserialize_pb <- function(connection){
+
+ #convert object to protobuf message
+ unrexp(read(pb(rexp.REXP), connection));
+}
Added: pkg/inst/proto/rexp.proto
===================================================================
--- pkg/inst/proto/rexp.proto (rev 0)
+++ pkg/inst/proto/rexp.proto 2014-01-04 02:28:59 UTC (rev 708)
@@ -0,0 +1,41 @@
+package rexp;
+
+message REXP {
+ enum RClass {
+ STRING = 0;
+ RAW = 1;
+ REAL = 2;
+ COMPLEX = 3;
+ INTEGER = 4;
+ LIST = 5;
+ LOGICAL = 6;
+ NULLTYPE = 7;
+ }
+ enum RBOOLEAN {
+ F=0;
+ T=1;
+ NA=2;
+ }
+
+ required RClass rclass = 1 ;
+ repeated double realValue = 2 [packed=true];
+ repeated sint32 intValue = 3 [packed=true];
+ repeated RBOOLEAN booleanValue = 4;
+ repeated STRING stringValue = 5;
+
+ optional bytes rawValue = 6;
+ repeated CMPLX complexValue = 7;
+ repeated REXP rexpValue = 8;
+
+ repeated string attrName = 11;
+ repeated REXP attrValue = 12;
+}
+message STRING {
+ optional string strval = 1;
+ optional bool isNA = 2 [default=false];
+}
+message CMPLX {
+ optional double real = 1 [default=0];
+ required double imag = 2;
+}
+
Added: pkg/inst/unitTests/runit.serialize_pb.R
===================================================================
--- pkg/inst/unitTests/runit.serialize_pb.R (rev 0)
+++ pkg/inst/unitTests/runit.serialize_pb.R 2014-01-04 02:28:59 UTC (rev 708)
@@ -0,0 +1,27 @@
+#Jeroen Ooms
+
+test.serialize_pb <- function() {
+ #verify that rexp.proto is loaded
+ RProtoBuf:::pb(rexp.REXP)
+
+ #serialize a nested list
+ x <- list(foo=cars, bar=Titanic)
+ checkEquals(unserialize_pb(serialize_pb(x, NULL)), x)
+
+ #a bit of everything, copied from jsonlite package
+ set.seed('123')
+ myobject <- list(
+ mynull = NULL,
+ mycomplex = lapply(eigen(matrix(-rnorm(9),3)), round, 3),
+ mymatrix = round(matrix(rnorm(9), 3),3),
+ myint = as.integer(c(1,2,3)),
+ mydf = cars,
+ mylist = list(foo='bar', 123, NA, NULL, list('test')),
+ mylogical = c(TRUE,FALSE,NA),
+ mychar = c('foo', NA, 'bar'),
+ somemissings = c(1,2,NA,NaN,5, Inf, 7 -Inf, 9, NA),
+ myrawvec = charToRaw('This is a test')
+ );
+
+ checkEquals(unserialize_pb(serialize_pb(myobject, NULL)), myobject)
+}
Added: pkg/man/serialize_pb.Rd
===================================================================
--- pkg/man/serialize_pb.Rd (rev 0)
+++ pkg/man/serialize_pb.Rd 2014-01-04 02:28:59 UTC (rev 708)
@@ -0,0 +1,45 @@
+\name{serialize_pb}
+\alias{can_serialize_pb}
+\alias{serialize_pb}
+\alias{unserialize_pb}
+\title{Serialize R object to Protocol Buffer Message.}
+\usage{
+ serialize_pb(object, connection, ...)
+}
+\arguments{
+ \item{object}{R object to serialize}
+
+ \item{connection}{passed on to \code{\link{serialize}}}
+
+ \item{...}{additional arguments passed on to
+ \code{\link{serialize}}}
+}
+\description{
+ This function serializes R objects to a general purpose
+ protobuf message. It uses the same \code{rexp.proto}
+ descriptor and mapping between R objects and protobuf
+ messages as RHIPE.
+}
+\details{
+ Third party clients need both the message and the
+ \code{rexp.proto} descriptor to read serialized R
+ objects. The latter is included in the the package
+ installation \code{proto} directory:
+ \code{system.file(package="RProtoBuf",
+ "proto/rexp.proto")}
+
+ Currently, the following storage types are supported:
+ \code{character}, \code{raw}, \code{double},
+ \code{complex}, \code{integer}, \code{list}, and
+ \code{NULL}. Objects with other storage types, such as
+ functions, environments, S4 classes, etc, will be skipped
+ with a warning. Missing values, attributes and numeric
+ precision will be preserved.
+}
+\examples{
+msg <- tempfile();
+serialize_pb(iris, msg);
+obj <- unserialize_pb(msg);
+identical(iris, obj);
+}
+
More information about the Rprotobuf-commits
mailing list