R/spmFormRead.r

In SemiPar: Semiparametic Regression

########## S function: spmFormRead ##########

# For reading in a formula for spm() and
# constructing a list of all information
# required for the fit.

# Last changed: 18 JAN 2005

spmFormRead <- function(form,omit.missing=FALSE)
{
   char.vec <- as.character(form)

   resp.name <- char.vec[2]

   resp.val <- eval(parse(text=resp.name))

   rhs <- paste(break.string(char.vec[3]),collapse="")

   # Remove spurious characters.

   rhs <- rm.char(rhs,"\n")
   rhs <- rm.char(rhs,"\t")

   # Break up into constituent terms

   rhs <- break.string(rhs,"+")

   lin <- list()
   pen <- list()
   krige <- list()
   off.set <- NULL

   lin$names <- NULL  
   lin$x <- NULL 

   pen$name <- NULL
   pen$x <- NULL
   pen$adf <- list()        
   pen$degree <- NULL 
   pen$knots <- list()   
   pen$spar <- list()
   pen$basis <- NULL

   krige$name <- NULL
   krige$x <- NULL
   krige$adf <- NULL
   krige$knots <- list()
   krige$spar <- NULL
   krige$bdry <- NULL
   krige$degree <- NULL
   krige$num.knots <- NULL

   if (rhs[1]=="1")
   {
      lin <- NULL
      pen <- NULL
      krige <- NULL
   }
 
   if (rhs[1]!="1")
   {
   for (i in 1:length(rhs))
   {  
      term <- rhs[i]
      type <- spmTermType(term)

      if (type=="offset")
         off.set <- eval(parse(text=term))
      
      if (type=="lin")
      {
         lin$name <- c(lin$name,term)
         lin$x <- cbind(lin$x,eval(parse(text=term)))
      }

      if (type=="pen")
      {
         out <- spmPenRead(term)
         pen$name <- c(pen$name,out$name)
         pen$x <- cbind(pen$x,out$var)    
         pen$adf <- c(pen$adf,list(out$adf))
         pen$degree <- c(pen$degree,out$degree)
         pen$knots <- c(pen$knots,list(out$knots))
         pen$spar <- c(pen$spar,list(out$spar))
         pen$basis <-  c(pen$basis,out$basis)
      }

      if(!is.null(pen$name))
      {   
         trunc.poly.basis <- sum(pen$basis=="trunc.poly")

         if (trunc.poly.basis > 0)
            pen$basis <- "trunc.poly"
         else
            pen$basis <- "tps"
     }

     if (type=="krige")
     {
         out <- spmKrigeRead(term)
         krige$name <- out$name
         krige$x <- out$var    
         krige$adf <- out$adf
         krige$knots <- out$knots
         krige$spar <- out$spar
         krige$bdry <- out$bdry
         krige$degree <- out$degree
         krige$num.knots <- out$num.knots
      }  
   }
   }

   # Handle single predictor case df differently

   if((is.null(lin$x))&(is.null(krige$x)))
   {
      if (length(pen$name)==1)
      {
         if (pen$adf[[1]]=="miss")
         {
            term <- rhs[1]
            arg.list <- substring(term,3,(nchar(term)-1))

            out <- arg.search(arg.list,"df=")
            present <- out$present
            arg <- out$arg

            if (present==FALSE)
               pen$adf[[1]] <- "miss"

            if (present==TRUE)
              pen$adf[[1]] <- spmArgRead(arg)$val-1
         }
      }
   }

   if (is.null(lin$x)) lin <- NULL
   if (is.null(pen$x)) pen <- NULL   
   if (is.null(krige$x)) krige <- NULL   

   spm.info <- list(formula=form,y=resp.val,intercept=TRUE,
                    lin=lin,pen=pen,krige=krige,off.set=off.set)

   datmat <- spm.info$y
   
   if (!is.null(spm.info$lin))
      datmat <- cbind(datmat,spm.info$lin$x)
   
   if (!is.null(spm.info$pen))
      datmat <- cbind(datmat,spm.info$pen$x)
   
   if (!is.null(spm.info$krige))
      datmat <- cbind(datmat,spm.info$krige$x)
   
   if (is.null(omit.missing))
       if (sum(is.na(datmat))>0)
          stop("Missing data present and omit.missing not true")

   if (!is.null(omit.missing))
   {
      if (omit.missing==TRUE)
      {
         indNA <- NULL
         for (j in 1:ncol(datmat))
            indNA <- union(indNA,(1:nrow(datmat))[is.na(datmat[,j]==TRUE)])
   
         if (length(indNA)>0)
         {
            spm.info$y <- spm.info$y[-indNA]
            if (!is.null(spm.info$lin))          
               spm.info$lin$x <- spm.info$lin$x[-indNA,]
   
            if (!is.null(spm.info$pen))
               spm.info$pen$x <- spm.info$pen$x[-indNA,]
   
            if (!is.null(spm.info$krige))
              spm.info$krige$x <- spm.info$krige$x[-indNA,]
         }
      }
   }

   return(spm.info)

}

########## End of spmFormRead ##########