R/checkModelList.r

In gragusa/MARSS: Multivariate Autoregressive State-Space Modeling

############################################################################################################################
#   checkModelList()
#   This checks user model list passed to MARSS().
#   The main purpose is to make sure that MARSS.form functions will work not to make sure model is valid
#   Dim checks on matrices are carried out in the MARSS.form functions that translate a model list to marssMODEL object
#   No error checking is done on controls and inits besides checking that it is present (NULL is ok); 
#   is.marssMLE() will error-check controls and inits
##########################################################################################################################
checkModelList = function( model, defaults, this.form.allows)
{
## First deal with case where model is not passed in all
if(is.null(model)) model=defaults

if (!is.list(model)){
  msg=" model must be passed in as a list.\n"
      cat("\n","Errors were caught in checkModelList \n", msg, sep="")
      stop("Stopped in checkModelList() due to specification problem(s).\n", call.=FALSE)
}
model.elem=names(defaults) 
### If some elements are missing from the model list use the defaults    
passed.in = model.elem %in% names(model)
for(el in model.elem[!passed.in] ){
    model[[el]] = defaults[[el]]
}
for(el in model.elem[passed.in] ){
    if(is.null(model[[el]])) model[[el]] = defaults[[el]]
}
#Check model structures (b497)
if( !all(names(model) %in% model.elem ) ){ 
      bad.name = names(model)[!(names(model) %in% model.elem )]
      msg=paste(" Elements ", bad.name," not allowed in model list for this form.\n",sep="")
      cat("\n","Errors were caught in checkModelList \n", msg, sep="")
      stop("Stopped in checkModelList() due to specification problem(s).\n", call.=FALSE)
      }
if( !all(model.elem %in% names(model)) ){ 
  bad.name = model.elem[!(model.elem %in% names(model))]
  msg=paste(" Element ", bad.name, " is missing in the model list passed into MARSS().\n", sep="")
      cat("\n","Errors were caught in checkModelList \n", msg, sep="")
      stop("Stopped in checkModelList() due to specification problem(s).\n", call.=FALSE)
      }

#check that model list doesn't have any duplicate names
  if(any(duplicated(names(model)))){
    bad.name = names(model)[duplicated(names(model))]
      msg=paste(" The elements ", bad.name, " are duplicated in the model list passed into MARSS().\n", sep="")
      cat("\n","Errors were caught in checkModelList \n", msg, sep="")
      stop("Stopped in checkModelList() due to specification problem(s).\n", call.=FALSE)
   }

#Series of checks on the model specification
problem = FALSE
msg=NULL
#check model structures only have allowed cases
  for (el in model.elem) {
    bad.str = FALSE
    #if length=1, then it must be a character or numeric string and that string must be in allowed. vectors length>1 are not allowed

    if(!is.factor(model[[el]]) && !is.array(model[[el]])) {
        if(length(model[[el]])!=1) bad.str=TRUE
        if(!bad.str){
          testit = try(model[[el]] %in% this.form.allows[[el]])
          if(class(testit)=="try-error" ){ bad.str=TRUE
          }else{ if(!testit ) bad.str=TRUE }
        }
    }
    if(bad.str) {
      problem=TRUE
      msg = c(msg, paste(" The model value for ", el, " is not allowed. Check ?MARSS.form \n", sep=""))
      }
    #if factor, must be allowed to be factor
    if(is.factor(model[[el]]) && !(el %in% this.form.allows$factors)) {
      problem=TRUE
      msg = c(msg, paste(" model$",el," is not allowed to be a factor.\n", sep=""))
      }
    #if matrix must be allowed to be matrix
    if(is.array(model[[el]]) && !(el %in% this.form.allows$matrices)){
      problem=TRUE
      msg = c(msg, paste(" model$",el," is not allowed to be a matrix.\n", sep=""))
      }     
    #if matrix then no NAs if character or list; this would be caught in is.marssMODEL but would be hard for user to understand problem
    if(is.array(model[[el]]) && (el %in% this.form.allows$matrices)){
      if( any(is.na(model[[el]])) | any(unlist(lapply(model[[el]],is.infinite))) ){
        problem=TRUE
        msg = c(msg, paste(" model$",el," is a matrix. No NAs or Infs allowed in this case.\n", sep=""))
        }
      if( is.list(model[[el]]) && any(sapply(model[[el]],length)!=1) ){
        problem=TRUE
        msg = c(msg, paste(" model$",el," is a list matrix. Each element must be length 1.\n", sep=""))
        }
      } # is matrix  
    } # end for (el in model.elem)

#If there are errors, then don't proceed with the rest of the checks
  if(problem)  {
          cat("\n","Errors were caught in checkModelList \n", msg, sep="")
          stop("Stopped in checkModelList() due to specification problem(s).\n", call.=FALSE)
        }
        
  #return the updated model list with missing elements filled in with defaults
  model
}