R/interpPairs.list.R

In Ecfun: Functions for 'Ecdat'

interpPairs.list <- function(object, .proportion, 
        envir=list(), 
        pairs=c('1'='\\.0$', '2'='\\.1$', replace0='', 
                replace1='.2', replace2='.3'),     
        validProportion=0:1, message0=character(0), ...){
##
## 1.  Setup:  ALL.OUT, etc.    
##
# 1.1.  message0 
  if(sum(nchar(message0))<1){
    message0 <- deparse(substitute(object), 25)[1]
  }
  if((ns <- length(message0))>1){
    warning('length(message0) = ', ns, "; message0[1:2] = ", 
            paste(message0[1:2], collapse='; '), 
            ';  using the first non-null')
    message0 <- message0[nchar(message0)>0][1]
  }  
# 1.2.  check .proportion     
  if(!is.numeric(.proportion)){
    stop(message0, ': .proportion is not numeric; ', 
         ' class = ', class(.proportion))
  }  
# 1.3.  length(.proportion)>0 
  if(length(.proportion)<1){
    stop(message0, ': length(.proportion)==0')
  }
# 1.4.  is.na? 
  oops.na <- which(is.na(.proportion))
  if(length(oops.na)>0){
    stop(message0, ':  .proportion[', oops.na[1], 
         '] = NA')
  }
# 1.5.  class(validProportion)
  if(!is.numeric(validProportion)){
    stop(message0, ':  validProportion is not numeric;', 
         '  class = ', class(validProportion))
  }
# 1.6.  length(validProportion)
  if(length(validProportion)!=2){
    stop(message0, ': length(validProportion) must be 2;', 
         '  is ', length(validProportion))
  }
# 1.7.  is.na(validProportion)
  oops <- which(is.na(validProportion))
  if(length(oops)>0){
    stop(message0, ': is.na(validProportion[', oops[1], 
         '])')
  }
# 1.8.  Rows to keep 
  In <- ((validProportion[1] <= .proportion) & 
           (.proportion <= validProportion[2]) )
# 1.9.  if none, return a no op   
  if(!any(In)){
    return(list(fun='return', value=NULL))
  }  
##
## 2.  find pairs
##
  Names <- checkNames(object, 
              avoid=pairs[c(1, 4, 2, 5)])
  Chgd <- rep(FALSE, length(Names))
  names(Chgd) <- Names
#
  suf1 <- grep(pairs[1], Names, value=TRUE)
  suf2 <- grep(pairs[2], Names, value=TRUE)
  len.suf1 <- rep(NA, length(suf1))
  len.suf2 <- rep(NA, length(suf2))
  names(len.suf1) <- Names[suf1]
  names(len.suf2) <- Names[suf2]
##
## 3.  Convert identified names to common names
##
  suf1. <- sub(pairs[1], pairs[3], suf1)
  suf2. <- sub(pairs[2], pairs[3], suf2)
  suf. <- unique(c(suf1., suf2.))
  len.suf <- rep(NA, length(suf.))
  names(len.suf) <- suf. 
##
## 4.  Envir[[..]] <- eval(object) 
##
  Envir <- envir 
#  interpObj <- object
  nel <- length(object)
  Envir$.proportion <- .proportion 
#  ne <- length(Envir)
  for(j in seq(length=nel)){
#   eval(interpObj[[j]])    
#   Is this a symbol to which to assign?      
# *** I don't understand this line
#     and don't have time to figure it out now
#     it generates length > 1 error     
#    if((j==2) && (as.character(object[[1]])=='<-')){
#     Fix like this for now:      
     if((j==2) && all(as.character(object[[1]])=='<-')){
        Envir[[Names[j]]] <- object[[j]]
      next 
    }
    Nj <- eval(object[[j]], Envir) 
    if(is.null(Nj)){
      oj <- object[[j]]
      ojc <- deparse(oj, width.cutoff=25) 
      stop('NULL returned from eval(', Names[j], 
           ' = ', ojc, ', ...)')
    }    
    if(length(Nj)<1){
      oj <- object[[j]]
      ojc <- deparse(oj, width.cutoff=25)
      stop('eval(', Names[j], ' = ', ojc, ')\n',
           '   returned ', class(Nj), "(0)")      
    }
    Envir[[Names[j]]] <- Nj 
#   Is this a pair name? 
    s1 <- which(suf1 == Names[j])
    s2 <- which(suf2 == Names[j])
    k1 <- length(s1)
    k2 <- length(s2)
    k12 <- k1+k2
#   k12 = 0 or 1; can't be 2 
    if(k12>0){
      if(k1>0){
        len.suf1[s1] <- NROW(Nj)
#       suf1[s1];  look for match in suf2 
        j2 <- which(suf2. == suf1.[s1])
        if(length(j2)>0){
          if(suf2[j2] %in% Names[1:j]){
#         Both suf1[s1] and suf2[j2] have been eval'ed
#         Add the interpolation 
#            N12 <- (interpObj[[suf1[s1]]]*() 
#                    + interpObj[[suf2[j2]]]*proportion ) 
            argNms <- c(suf1[s1], suf2[j2], message0)
            N12 <- interpChar(Envir[c(suf1[s1], suf2[j2])], 
                      .proportion=.proportion, argnames=argNms)
            Envir[[suf2.[j2]]] <- N12 
            len.suf[suf2.[j2]] <- NROW(N12)
          } 
#         match found but not processed yet
          next
        } else {
#         match not found:
#          if(is.numeric(interpObj[[j]])){ 
#           If numeric, store interpObj[[j]] as the match 
#           with a warning     
          argNms <- c(Names[j], '.proportion', message0)
          N1 <- interpChar(x=Envir[[Names[j]]], 
                  .proportion=.proportion, argnames=argNms) 
          Envir[[suf1.[s1]]] <- N1
          len.suf[suf1.[s1]] <- NROW(N1)
        }
      } else {
        len.suf2[s2] <- NROW(Nj)
#       k2=1, because k1=0         
#       suf2[s2];  look for match in suf1 
        j1 <- which(suf1. == suf2.[s2])
        if(length(j1)>0){
          if(suf1[j1] %in% Names[1:j]){
#         Both suf1[s1] and suf2[j2] have been eval'ed
#         Add the interpolation 
#            N21 <- (interpObj[[suf1[j1]]]*(1-proportion) 
#                    + interpObj[[suf2[s2]]]*proportion ) 
            argNms <- c(suf1[j1], suf2[s2], message0)
            N21 <- interpChar(Envir[c(suf1[j1], suf2[s2])], 
                              .proportion=.proportion, argnames=argNms)
            Envir[[suf1.[j1]]] <- N21 
            len.suf[suf1.[j1]] <- NROW(N21)
          } 
#         match found but not processed yet
          next
        } else {
#         match not found;  store interpObj[[j]] as the match           
          argNms <- c(Names[j], '.proportion', message0) 
          N2 <- interpChar(Nj, 
                        .proportion=.proportion, argnames=argNms) 
          Envir[[suf2.[s2]]] <- N2
          len.suf[suf2.[s2]] <-NROW(N2)
          next 
        }     
      }
    }
  }
##
## 5.  Other vectors or data.frames 
##     with the same number of rows?  
##
  Drop <- (Names %in% c(suf1, suf2))
  Keep. <- c(Names[!Drop], suf.)
  interpOut <- Envir[Keep.]  
  if(length(interpOut)>0){
    objLen <- sapply(interpOut, NROW)
  } else objLen <- integer(0)
#
  nSuf <- length(suf.)
  if(nSuf>0){
    ln <- max(objLen[suf.])
  } else ln <- (-Inf)
#  lp <- length(.proportion)
  lp <- length(In)
  if(lp < ln) {
#    .proportion <- rep(.proportion, length=ln)
    In <- rep(In, length=ln)
    N <- ln
  } else {      
    N <- lp 
    if((lp>ln) && (ln>1)){
      msg <- paste0('length(.proportion) = ', lp, 
              ' > max length(pairs) = ', ln, 
              ';\n  pairs found for ', 
              paste(suf., collapse=', '))
      warning(msg)
    }
  }
# Cols to trim? 
  cols2trim <- ((objLen==N) & (N>1))
# trim   
  for(s. in names(interpOut)[cols2trim]){
#   Retain only "In" in s.
    S. <- interpOut[[s.]]
    sub. <- any(is.language(S.) | is.function(S.))
    if(sub.)next 
#    
    ndim <- length(dim(S.))
    if(ndim<2){
      Subset <- ((!is.null(S.)) && !is.function(S.))
      if(Subset){
          S. <- S.[In]
      }
    } else {     
      sub2 <- (is.data.frame(S.) || (is.matrix(S.)))
      if(sub2){
          S. <- S.[In,, drop=FALSE]
      } 
    }
    interpOut[[s.]] <- S.
    Chgd[s.] <- TRUE 
  }
##
## 6.  Restore object[!Chgd]
## 
  Nam3 <- names(Chgd)
  Nout <- (Nam3 %in% names(interpOut))
  noChg <- (Nout & !Chgd)  
  noC <- Nam3[noChg]
  for(nc in noC){
#   in case is.null(names(object))
    nc. <- which(Names==nc)
    interpOut[[nc]] <- object[[nc.]]
  }
  interpOut
}