re-committing files

Author: JamesRamsay5

.github/workflows/R-CMD-check.yaml

@@ -1,4 +1,5 @@
-# Workflow derived from https://github.com/r-lib/actions/tree/master/examples
+# fda
+# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
 # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
 on:
   push:
@@ -18,7 +19,7 @@ jobs:
       fail-fast: false
       matrix:
         config:
-          - {os: macOS-latest,   r: 'release'}
+          - {os: macos-latest,   r: 'release'}
           - {os: windows-latest, r: 'release'}
           - {os: ubuntu-latest,   r: 'devel', http-user-agent: 'release'}
           - {os: ubuntu-latest,   r: 'release'}
@@ -29,18 +30,21 @@ jobs:
       R_KEEP_PKG_SOURCE: yes
 
     steps:
-      - uses: actions/checkout@v2
-      - uses: r-lib/actions/setup-tinytex@v2
-      - uses: r-lib/actions/setup-pandoc@v1
+      - uses: actions/checkout@v3
 
-      - uses: r-lib/actions/setup-r@v1
+      - uses: r-lib/actions/setup-pandoc@v2
+
+      - uses: r-lib/actions/setup-r@v2
         with:
           r-version: ${{ matrix.config.r }}
           http-user-agent: ${{ matrix.config.http-user-agent }}
           use-public-rspm: true
 
-      - uses: r-lib/actions/setup-r-dependencies@v1
+      - uses: r-lib/actions/setup-r-dependencies@v2
         with:
-          extra-packages: rcmdcheck
+          extra-packages: any::rcmdcheck
+          needs: check
 
-      - uses: r-lib/actions/check-r-package@v1
+      - uses: r-lib/actions/check-r-package@v2
+        with:
+          upload-snapshots: true

R/.DS_Store

@@ -92,6 +92,9 @@ eval.surp <- function(evalarg, Wfdobj, nderiv=0) {
     return(Smat)
   }
 
+  # Note:  derivative values computed using Pmat rather than Bmat
+  # This needs correcting
+  
   #  First derivative:
 
   if (nderiv == 1) {

R/eval.surp.R

@@ -25,18 +25,23 @@ smooth.pos <- function(argvals, y, WfdParobj, wtvec=rep(1,n), conv=1e-4,
   #               an N by NCURVE matrix, where N is the number of observed
   #               curve values for each curve and NCURVE is the number of
   #               curves observed.
-  #               If the functional data are muliivariate, this array will be
+  #               If the functional data are multivariate, this array will be
   #               an N by NCURVE by NVAR matrix, where NVAR the number of
   #               functions observed per case.  For example, for the gait
   #               data, NVAR = 2, since we observe knee and hip angles.
-  #  WFDPAROBJ... A functional parameter or fdPar object.  This object
+  #  WFDPAROBJ... An fd or an fdPar object.  This object
   #               contains the specifications for the functional data
   #               object to be estimated by smoothing the data.  See
   #               comment lines in function fdPar for details.
   #               The functional data object WFD in WFDPAROBJ is used
   #               to initialize the optimization process.
   #               Its coefficient array contains the starting values for
-  #               the iterative minimization of mean squared error.
+  #               the iterative minimization of mean squared error, and
+  #               this coefficient array must be either a K by NCURVE
+  #               matrix or a K by NUCRVE by NVAR array,  where K
+  #               is the number of basis functions.
+  #               If WFDPAROBJ is NULL, it will be initialized to
+  #               a matrix or array of zeros.
   #  WTVEC   ...  a vector of weights, a vector of N one's by default.
   #  CONV    ...  convergence criterion, 0.0001 by default
   #  ITERLIM ...  maximum number of iterations, 50 by default.
@@ -60,7 +65,7 @@ smooth.pos <- function(argvals, y, WfdParobj, wtvec=rep(1,n), conv=1e-4,
   #  FLIST objects are indexed linear with curves varying inside
   #  variables.
 
-  #  Last modified 16 November 2021 by Jim Ramsay
+  #  Last modified 17 January 2023 by Jim Ramsay
 
   #  check ARGVALS
 
@@ -76,7 +81,7 @@ smooth.pos <- function(argvals, y, WfdParobj, wtvec=rep(1,n), conv=1e-4,
 
   #  check Y
 
-  y = as.matrix(y)
+  y      <- as.matrix(y)
   ychk   <- ycheck(y, n)
   y      <- ychk$y
   ncurve <- ychk$ncurve
@@ -85,19 +90,18 @@ smooth.pos <- function(argvals, y, WfdParobj, wtvec=rep(1,n), conv=1e-4,
 
   #  check WfdParobj and get LAMBDA
 
-  WfdParobj <- fdParcheck(WfdParobj,curve)
-  lambda    <- WfdParobj$lambda
-  
-  #  the starting values for the coefficients are in FD object WFDOBJ
-  
+  if (inherits(WfdParobj, "fdPar") || inherits(WfdParobj, "fd")) {
+    if (inherits(WfdParobj, "fd")) WfdParobj <- fdPar(WfdParobj)
+  } else {
+    stop(paste("Argument WFDPAROBJ is neither an fdPar object",
+               "or an fd object."))
+  }
   Wfdobj   <- WfdParobj$fd
   Lfdobj   <- WfdParobj$Lfd
-  basisobj <- Wfdobj$basis     #  basis for W(argvals)
-  nbasis   <- basisobj$nbasis  #  number of basis functions
-  
-  #  set up initial coefficient array
-  
+  basisobj <- Wfdobj$basis     
+  nbasis   <- basisobj$nbasis  
   coef0    <- Wfdobj$coefs
+  lambda   <- WfdParobj$lambda
 
   #  check WTVEC
 

R/smooth.pos.R

@@ -1,6 +1,6 @@
-smooth.surp <- function(argvals, Wbin, Bmat0, WfdPar, wtvec=NULL, conv=1e-4,
+smooth.surp <- function(argvals, y, Bmat0, WfdPar, wtvec=NULL, conv=1e-4,
                        iterlim=50, dbglev=0) {
-  #  Smooths the relationship of Y to ARGVALS using weights in WTVEC by fitting 
+    #  Smooths the relationship of Y to ARGVALS using weights in WTVEC by fitting 
   #     surprisal functions to a set of surprisal transforms of choice 
   #     probabilities, where the surprisal transformation of each probability is 
   #                      W(p_m) = -log_M (p_m), m=1, ..., M,
@@ -20,7 +20,7 @@ smooth.surp <- function(argvals, Wbin, Bmat0, WfdPar, wtvec=NULL, conv=1e-4,
   #               surprisal values for each curve.  It is assumed that
   #               that these argument values are common to all observed
   #               curves.  
-  #  WBIN    ...  A matrix containingg the values to be fit.
+  #  Y       ...  A matrix containing the values to be fit.
   #               This will be an NBIN by M matrix, where NBIN is the 
   #               number of bins containing choice probabilities and M is
   #               the number of options in a specific question or rating
@@ -70,15 +70,14 @@ smooth.surp <- function(argvals, Wbin, Bmat0, WfdPar, wtvec=NULL, conv=1e-4,
   n       <- length(argvals)
   onesobs <- matrix(1,n,1)
 
-  #  Check Wbin, an n by M-1 matrix of surprisal values.  
+  #  Check y, an n by M-1 matrix of surprisal values.  
   #  It may not contain negative values.
 
-  Wbin <- as.matrix(Wbin)
-  Wbindim <- dim(Wbin)
-  M <- Wbindim[2]
-  if (Wbindim[1] != n) 
-      stop("The length of ARGVALS  and the number of rows of WBIN differ.")
-  # if (min(Wbin) < 0) stop("WBIN contains negative values.")
+  y    <- as.matrix(y)
+  ydim <- dim(y)
+  M    <- ydim[2]
+  if (ydim[1] != n) 
+      stop("The length of ARGVALS  and the number of rows of Y differ.")
 
   #  Check WfdPar and extract WBASIS, WNBASIS, Wlambda and WPENALTY.  
   #  Note that the coefficient matrix is not used.
@@ -134,7 +133,7 @@ smooth.surp <- function(argvals, Wbin, Bmat0, WfdPar, wtvec=NULL, conv=1e-4,
 
   #  Set up list object for data required by PENSSEfun
 
-  surpList <- list(argvals=argvals, Wbin=Wbin, wtvec=wtvec, Kmat=Kmat,
+  surpList <- list(argvals=argvals, y=y, wtvec=wtvec, Kmat=Kmat,
                    Zmat=Zmat, Phimat=Phimat, M=M)
   #  --------------------------------------------------------------------
   #              loop through variables and curves
@@ -248,12 +247,13 @@ smooth.surp <- function(argvals, Wbin, Bmat0, WfdPar, wtvec=NULL, conv=1e-4,
   D2SSE    <- surpResult$D2SSE
   DvecSmatDvecB <- surpResult$DvecSmatDvecB
 
-  result <- list(Wfd=Wfd, Bmat=Bmat, f=f, gvec=gvec, hmat=hmat,
+  surpFd <- list(Wfd=Wfd, Bmat=Bmat, f=f, gvec=gvec, hmat=hmat,
                  PENSSE=PENSSE, DPENSSE=DPENSSE, D2PENSSE=D2PENSSE,
                  SSE=SSE, DSSE=DSSE, D2SSE=D2SSE,
                  DvecSmatDvecB=DvecSmatDvecB)
+  class(surpFd) <- 'surpfd'
 
-  return(result)
+  return(surpFd)
 }
 
 # ------------------------------------------------------------------
@@ -266,7 +266,7 @@ surp.fit <- function(x, surpList) {
   #  extract objects from surpList
 
   argvals <- surpList$argvals 
-  Wbin    <- surpList$Wbin 
+  y       <- surpList$y 
   wtvec   <- surpList$wtvec 
   Kmat    <- surpList$Kmat
   Zmat    <- surpList$Zmat 
@@ -288,7 +288,7 @@ surp.fit <- function(x, surpList) {
   sumexpXmat <- as.matrix(apply(expXmat,1,sum))
   Pmat     <- expXmat/(sumexpXmat %*% matrix(1,1,M))
   Smat     <- -Xmat + (log(sumexpXmat) %*% matrix(1,1,M))/logM
-  Rmat     <- Wbin - Smat
+  Rmat     <- y - Smat
   vecBmat  <- matrix(Bmat,K*(M-1),1,byrow=TRUE)
   vecRmat  <- matrix(Rmat,n*M,    1,byrow=TRUE)
   vecKmat  <- kronecker(diag(rep(1,M-1)),Kmat)