R/Data2fd.R

In fda: Functional Data Analysis

Data2fd <- function(argvals=NULL, y=NULL, basisobj=NULL, nderiv=NULL,
                    lambda=3e-8/diff(as.numeric(range(argvals))),
                    fdnames=NULL, covariates=NULL, method="chol",
                    dfscale=1)
{
  
  argChk <- argvalsySwap(argvals, y, basisobj)
  
  # Change proposed by Spencer Graves 2010.12.08
  # if(is.null(lambda))
  #   lambda <- 1e-9*sd(argChk$y)/diff(range(argChk$argvals))
  #
  # 2020-01-16: 
  # Error in smooth.basis ... argvals is not numeric
  # in R CMD check, cannot replicate line by line.  
  if(!is.numeric(AV <- argChk$argvals)){
    if(is.null(AV))
      stop('is.null(argChk$argvals); should be numeric')
    cat('argChk$argvals is not numeric.\n')
    cat('class(argChk$argvals) = ', class(AV), '\n')
    print(AV)
  }  
  
  smBasis <- smooth.basisPar(argChk$argvals, argChk$y,
                            fdobj=basisobj, Lfdobj=nderiv, lambda=lambda,
                            fdnames=fdnames,
                            covariates=covariates, method="chol", dfscale=dfscale)
  
  # smBasis <- with(argChk, smooth.basisPar(argvals=argvals, y=y,
  #                                         fdobj=basisobj, Lfdobj=nderiv, lambda=lambda,
  #                                         fdnames=fdnames,
  #                                         covariates=covariates, method="chol", dfscale=dfscale) )
  #
  smBasis$fd
}

#  -------------------------------------------------------------------------

## 2020-01-16:  Spencer Graves makes argvalsySwap 
## an internal function
argvalsySwap = function(argvals=NULL, y=NULL, basisobj=NULL)
{
  ##
  ## 1.  if(is.null(y)) ...
  ##
  if(is.null(y)){
    if(is.null(argvals)) stop("'y' is missing with no default")
    #   Store argvals as y
    cat("'y' is missing, using 'argvals'\n") 
    y <- argvals
    argvals <- NULL 
  }
  ##
  ## 2.  if(is.null(argvals))argvals <- seq(basisobj$rangeval, dim(y)[1])
  ##
  dimy <- dim(as.array(y))
  if(is.null(argvals)){
    {
      if(is.null(basisobj)){
        basisobj <- create.bspline.basis(basisobj)
      } else {
        if(is.numeric(basisobj)) {
          if(length(basisobj)>1){
            basisobj <- create.bspline.basis(basisobj)
          } else 
            basisobj <- create.bspline.basis(norder=basisobj)
        }
        else {
          if(inherits(basisobj, 'fd')){
            basisobj <- basisobj$basis
          } else 
            if(inherits(basisobj, 'fdPar'))
              basisobj <- basisobj$fd$basis
        }
      }
    }
    a01 <- basisobj$rangeval
    if(is.null(a01))
      stop('basisobj does not have a required ',
           'rangeval component.')
    #    
    n <- dimy[1]
    cat(paste("'argvals' is missing;  using seq(", a01[1],
              ", ", a01[2], ", length=", n, ")\n"))       
    argvals <- seq(a01[1], a01[2], length=n)
    return(list(argvals=argvals, y=y, basisobj=basisobj))
  }
  ##
  ## 3.  if(length(dim(argvals)) == length(dim(y))) ... 
  ##
  dima <- dim(as.array(argvals))
  {
    if(length(dimy) == length(dima)){
      if(any(dimy != dima))
        stop("dimensions of 'argvals' and 'y' must be compatible;\n",
             "  dim(argvals) = ", paste(dima, collapse=' x '),
             ";  dim(y) = ", paste(dimy, collapse=' x ') )
      #     Check basisobj
      {
        if(inherits(basisobj, 'fd'))basisobj <- basisobj$basis
        else {
          if(inherits(basisobj, 'fdPar'))
            basisobj <- basisobj$fd$basis
          else {
            if(inherits(basisobj, 'array')){
              fd. <- fd(basisobj)
              basisobj <- fd.$basis
            }
            else { 
              if(inherits(basisobj, 'integer'))
                basisobj <- create.bspline.basis(argvals, norder=basisobj)
              else {
                if(is.null(basisobj))
                  basisobj <- create.bspline.basis(argvals)
                else
                  if(!inherits(basisobj, 'basisfd'))
                    stop("'basisobj' is NOT a functional basis",
                         " object (class 'basisfd');  class = ",
                         class(basisobj)[1])
              }
            }
          }
        }
        }
      a01 <- basisobj$rangeval
      arng <- range(argvals)
      if ((a01[1]<=arng[1]) && (arng[2]<=a01[2])) {
        return(list(argvals=argvals, y=y, basisobj=basisobj))
      }
      #
      yrng <- range(y)
      if((a01[1]<=yrng[1]) && (yrng[2]<=a01[2])) {
        cat(paste("'argvals' is NOT contained in basisobj$rangeval",
                  ", but 'y' is;  swapping 'argvals' and 'y'.\n"))
        return(list(argvals=y, y=argvals, basisobj=basisobj)) 
      }
      #      
      stop("Neither 'argvals' nor 'y' are contained in ",
           "basisobj$rangeval")
    }
  }        
  ##
  ## 4.  If(length(dimy) < length(dima)) swap ...
  ##
  if(length(dimy)<length(dima)){
    cat(paste("Swapping 'y' and 'argvals', because 'y' is ",
              "simpler,\n  and 'argvals' should be;  now ",
              "dim(argvals) = ", paste(dimy, collapse=" x "),
              ";  dim(y) = ", paste(dima, collapse=" x "),"\n" )) 
    y. <- argvals
    argvals <- y
    y <- y.
    #
    d. <- dima
    dima <- dimy
    dimy <- d.
  }   
  #
  if(any(dima != dimy[1:length(dima)]))
    stop("A dimension of 'argvals' does not match 'y':\n",
         "  dim(argvals) = ", paste(dima, collapse=" x "),
         ";  dim(y) = ", paste(dimy, collapse=" x ") )      
  ##        
  ## 5.  Check compatibility of argvals with basisobj
  ##        
  {
    if(inherits(basisobj, 'fd'))basisobj <- basisobj$basis
    else {
      if(inherits(basisobj, 'fdPar'))
        basisobj <- basisobj$fd$basis
      else {
        if(inherits(basisobj, 'array')){
          fd. <- fd(basisobj)
          basisobj <- fd.$basis
        }
        else { 
          if(inherits(basisobj, 'integer'))
            basisobj <- create.bspline.basis(argvals, norder=basisobj)
          else {
            if(is.null(basisobj))
              basisobj <- create.bspline.basis(argvals)
            else
              if(!inherits(basisobj, 'basisfd'))
                stop("'basisobj' is NOT a functional basis",
                     " object (class 'basisfd');  class = ",
                     class(basisobj)[1])
          }
        }
      }
    }
    }
  a01 <- basisobj$rangeval
  arng <- range(argvals)
  if((a01[1]<=arng[1]) && (arng[2]<=a01[2])) {
    return(list(argvals=argvals, y=y, basisobj=basisobj))
  }
  #
  stop("'argvals' are not contained in basisobj$rangeval")
}