R/simplify.R

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

simplify <- function(x, simplifyVector = TRUE, simplifyDataFrame = TRUE, simplifyMatrix = TRUE,
  simplifyDate = simplifyVector, homoList = TRUE, flatten = FALSE, columnmajor = FALSE,
  simplifySubMatrix = simplifyMatrix) {

  #This includes '[]' and '{}')
  if (!is.list(x) || !length(x)) {
    return(x)
  }

  # list can be a dataframe recordlist
  if (isTRUE(simplifyDataFrame) && is.recordlist(x)) {
    mydf <- simplifyDataFrame(x, flatten = flatten, simplifyMatrix = simplifySubMatrix)
    if(isTRUE(simplifyDate) && is.data.frame(mydf) && is.datelist(mydf)){
      return(parse_date(mydf[["$date"]]))
    }
    return(mydf)
  }

  # or a scalar list (atomic vector)
  if (isTRUE(simplifyVector) && is.null(names(x)) && is.scalarlist(x)) {
    return(list_to_vec(x))
  }

  # apply recursively
  out <- lapply(x, simplify, simplifyVector = simplifyVector, simplifyDataFrame = simplifyDataFrame,
    simplifyMatrix = simplifySubMatrix, columnmajor = columnmajor, flatten = flatten)

  # fix for mongo style dates turning into scalars *after* simplifying
  # only happens when simplifyDataframe=FALSE
  if(isTRUE(simplifyVector) && is.scalarlist(out) && all(vapply(out, inherits, logical(1), "POSIXt"))){
    return(structure(list_to_vec(out), class=c("POSIXct", "POSIXt")))
  }

  # test for matrix. Note that we have to take another look at x (before
  # list_to_vec on its elements) to differentiate between matrix and vector.
  if (isTRUE(simplifyMatrix) && isTRUE(simplifyVector) && is.matrixlist(out) && all(unlist(vapply(x, is.scalarlist, logical(1))))) {
    if(isTRUE(columnmajor)){
      return(do.call(cbind, out))
    } else {
      #this is currently the default
      return(do.call(rbind, out))
    }
  }

  # Simplify higher arrays
  if (isTRUE(simplifyMatrix) && is.arraylist(out)){
    if(isTRUE(columnmajor)){
      return(array(
        data = do.call(cbind, out),
        dim = c(dim(out[[1]]), length(out))
      ));
    } else {
      #this is currently the default
      return(array(
        data = do.call(rbind, lapply(out, as.vector)),
        dim = c(length(out), dim(out[[1]]))
      ));
    }
  }

  # try to enfoce homoList on unnamed lists
  if (isTRUE(homoList) && is.null(names(out))) {
    # coerse empty lists, caused by the ambiguous fromJSON('[]')
    isemptylist <- vapply(out, identical, logical(1), list())
    if (any(isemptylist) & !all(isemptylist)) {
      # if all the others look like data frames, coerse to data frames!
      if (all(vapply(out[!isemptylist], is.data.frame, logical(1)))) {
        for (i in which(isemptylist)) {
        out[[i]] <- data.frame()
        }
        return(out)
      }

      # if all others look like atomic vectors, unlist all
      if (all(vapply(out[!isemptylist], function(z) {
        isTRUE(is.vector(z) && is.atomic(z))
      }, logical(1)))) {
        for (i in which(isemptylist)) {
        out[[i]] <- vector(mode = typeof(out[[which(!isemptylist)[1]]]))
        }
        return(out)
      }
    }
  }

  # convert date object
  if( isTRUE(simplifyDate) && is.datelist(out) ){
    return(parse_date(out[["$date"]]))
  }

  # return object
  return(out)
}

is.matrixlist <- function(x) {
  isTRUE(is.list(x)
    && length(x)
    && is.null(names(x))
    && all(vapply(x, is.atomic, logical(1)))
    && all_identical(vapply(x, length, integer(1)))
    #&& all_identical(vapply(x, mode, character(1))) #this fails for: [ [ 1, 2 ], [ "NA", "NA" ] ]
  );
}

is.arraylist <- function(x) {
  isTRUE(is.list(x)
    && length(x)
    && is.null(names(x))
    && all(vapply(x, is.array, logical(1)))
    && all_identical(vapply(x, function(y){paste(dim(y), collapse="-")}, character(1)))
  );
}

is.datelist <- function(x){
  isTRUE(is.list(x)
     && identical(names(x), "$date")
     && (is.numeric(x[["$date"]]) || is.character(x[["$date"]]))
  );
}

parse_date <- function(x){
  if(is.numeric(x)){
    return(structure(x/1000, class=c("POSIXct", "POSIXt")))
  } else if(is.character(x)) {
    #tz is not vectorized, so assume all() are the same
    is_utc <- ifelse(all(grepl("Z$", x)), "UTC", "")
    return(as.POSIXct(strptime(x, format = '%Y-%m-%dT%H:%M:%OS', tz = is_utc)))
  } else {
    return(x)
  }
}

all_identical <- function(x){
  if(!length(x)) return(FALSE)
  for(i in x){
    if(x[1] != i) return(FALSE)
  }
  return(TRUE)
}