R/createS4ObjectFromList.R

In Sage-Bionetworks/rSynapseClient: Synapse R Client from Sage Bionetworks

# given the content represented in list form and the type,
# construct and return the object using the auto-generated S4 classes
# 
# Author: brucehoff
###############################################################################

createS4ObjectFromList<-function(content, className) {
  if (is.null(content)) return(NULL)
  if (!is.list(content) && (length(content)>1 || length(names(content))>0)) {
    # it's a vector.  Coerce to a list
    content<-as.list(content)
  }
  # if the list specifies a concrete type, then use it instead of the given class name
  if (is.list(content)) {
    concreteTypeSchemaName<-content$concreteType
    if (!is.null(concreteTypeSchemaName)) {
      concreteTypeClassName<-getS4ClassNameFromSchemaName(concreteTypeSchemaName)
      if (!extends(concreteTypeClassName, className)) {
        stop(sprintf("concreteType %s specified for class %s", concreteTypeClassName, className))
      }
      className<-concreteTypeClassName
    }
  }
  
  constructorArgs<-list()   
  slotTypes<-getSlots(className)
  extra<-list()
  for (slotName in names(content)) {
    slotValue <- content[[slotName]]
    s4SlotType <- slotTypes[slotName]
    if (is.na(s4SlotType)) {
      # this allows the client to function in the face of an 'additive' API change, i.e.
      # the client carries along the unexpected values and will return them if the object
	  # is updated (PUT) to the server
	  extra[[slotName]]<-slotValue
    } else if (isPrimitiveType(s4SlotType)) {
      # not sure why empty lists are mapped to "AsIs" types, but it's the behavior of RJSONIO
      if (is(slotValue, "list") || is(slotValue, "AsIs")) {
        slotValue<-unlist(slotValue) 
      }
      if (s4SlotType=="integer") {
        # a value may come in as 'numeric'
        slotValue<-as.integer(slotValue)
      }
      if (!is.null(slotValue)) {
        constructorArgs[[slotName]]<-slotValue
      }
    } else {
      if (!isNullableType(s4SlotType)) {
        # something has gone wrong.  Non-primitive slots should extend a nullable type
        stop("%s is not a 'nullable' type.", s4SlotType)
      }
      # want to make one of these:
      s4SlotType <- getNonNullableType(s4SlotType)
      if (extends(s4SlotType, "TypedList")) {
        constructorArgs[[slotName]]<-createTypedListFromList(slotValue, s4SlotType)
      } else {
        constructorArgs[[slotName]]<-createS4ObjectFromList(slotValue, s4SlotType)
      }
    }
  }
  created<-do.call(className, constructorArgs)
  created@autoGeneratedExtra<-extra
  created
}

createTypedListFromList<-function(content, className) {
  if (!extends(className, "TypedList")) 
    stop(sprintf("Expected TypedList subclass but found %s", className))
  result<-new(className)
  listElementType <- result@type
  isPrimitive<-isPrimitiveType(listElementType)
  isTypedList<-extends(listElementType, "TypedList")
  
  for (elem in content) {
    value<-NULL
    if (isPrimitive) {
      value<-elem
    } else if (isTypedList) {
      value<-createTypedListFromList(elem, listElementType)
    } else {
      value<-createS4ObjectFromList(elem, listElementType)
    }
    result<-append(result, value)
  }
  result
}