R/pack.R

In jsonlite: A Simple and Robust JSON Parser and Generator for R

# Note: For S4, the value is the class defintion. The slots (data) are in the
# attributes.
pack <- function(obj, ...) {
  # encode by storage mode
  encoding.mode <- typeof(obj)

  # null may not have attributes
  if (encoding.mode == "NULL" || identical(obj, as.name('\001NULL\001'))) {
    return(list(type = as.scalar("NULL")))
  }

  # needed because formals become attributes, etc
  if (encoding.mode == "closure") {
    obj <- as.list(obj)
  }

  # special exception
  if (encoding.mode == "environment" && isNamespace(obj)) {
    encoding.mode <- "namespace"
  }

  # Strip off 'class' from S4 attributes
  attrib <- attributes(obj)
  if (isS4(obj)) {
    encoding.mode <- "S4"
    if (".Data" %in% slotNames(obj)) {
      attrib[[".Data"]] = obj@.Data
    }
    attrib <- attrib[slotNames(obj)]
    names(attrib) <- slotNames(obj)
  }

  # encode recursively
  list(
    type = as.scalar(encoding.mode),
    attributes = givename(lapply(attrib, pack, ...)),
    value = switch(
      encoding.mode,
      environment = NULL,
      externalptr = NULL,
      namespace = lapply(as.list(getNamespaceInfo(obj, "spec")), as.scalar),
      S4 = list(class = as.scalar(class(obj)), package = as.scalar(attr(class(obj), "package"))),
      raw = as.scalar(base64_enc(unclass(obj))),
      logical = as.vector(unclass(obj), mode = "logical"),
      integer = as.vector(unclass(obj), mode = "integer"),
      numeric = as.vector(unclass(obj), mode = "numeric"),
      double = as.vector(unclass(obj), mode = "double"),
      character = as.vector(unclass(obj), mode = "character"),
      complex = as.vector(unclass(obj), mode = "complex"),
      list = unname(lapply(unclass(obj), pack, ...)),
      pairlist = unname(lapply(as.vector(obj, mode = "list"), pack, ...)),
      closure = unname(lapply(obj, pack, ...)),
      builtin = as.scalar(base64_enc(serialize(unclass(obj), NULL))),
      special = as.scalar(base64_enc(serialize(unclass(obj), NULL))),
      language = deparse(unclass(obj)),
      name = deparse(unclass(obj)),
      symbol = deparse(unclass(obj)),
      expression = deparse(obj[[1]]),
      warning("No encoding has been defined for objects with storage mode ", encoding.mode, " and will be skipped.")
    )
  )
}

unpack <- function(obj) {
  encoding.mode <- obj$type

  # functions are special
  if (encoding.mode == "NULL") {
    return(NULL)
  }

  if (identical(encoding.mode, "S4")) {
    obj_class <- load_s4_class(obj$value$class, package = obj$value$package)
    obj_data <- lapply(obj$attributes, unpack)
    if (!length(obj_class)) obj_class <- obj$value$class
    return(do.call(new, c(Class = obj_class, obj_data)))
  }

  newdata <- c(
    list(
      .Data = switch(
        encoding.mode,
        environment = new.env(parent = emptyenv()),
        namespace = getNamespace(obj$value$name),
        externalptr = NULL,
        raw = base64_dec(obj$value),
        logical = as.logical(list_to_vec(obj$value)),
        integer = as.integer(list_to_vec(obj$value)),
        numeric = as.numeric(list_to_vec(obj$value)),
        double = as.double(list_to_vec(obj$value)),
        character = as.character(list_to_vec(obj$value)),
        complex = as.complex(list_to_vec(obj$value)),
        list = lapply(obj$value, unpack),
        pairlist = lapply(obj$value, unpack),
        symbol = makesymbol(x = unlist(obj$value)),
        name = makesymbol(x = unlist(obj$value)),
        expression = parse(text = obj$value),
        language = as.call(parse(text = unlist(obj$value)))[[1]],
        special = unserialize(base64_dec(obj$value)),
        builtin = unserialize(base64_dec(obj$value)),
        closure = lapply(obj$value, unpack),
        stop("Switch falling through for encode.mode: ", encoding.mode)
      )
    ),
    lapply(obj$attributes, unpack)
  )

  # this is for serializing functions arguments: as.list(lm)$data
  if (identical(newdata[[1]], substitute())) {
    return(substitute())
  }

  # build the output object
  output <- do.call("structure", newdata, quote = TRUE)

  # functions are special
  if (encoding.mode == "closure") {
    myfn <- as.function(output)
    environment(myfn) <- globalenv()
    return(myfn)
  }

  # functions are special
  if (encoding.mode == "pairlist") {
    return(as.pairlist(output))
  }

  # try to fix native symbols
  if (is(output, "NativeSymbolInfo")) {
    try(output <- fixNativeSymbol(output))
  }

  # return
  return(output)
}

load_s4_class <- function(name, package) {
  cls <- tryCatch(
    {
      getClassDef(name, package = package)
    },
    error = function(e) {
      stop(sprintf("Failed to load S4 class definition '%s' from '%s' (%s)", name, package, e$message), call. = FALSE)
    }
  )
}