merge and resolve conflict

functionaldata · Jul 27, 2022 · f727acc · f727acc
2 parents 445741d + bcbdaca
commit f727acc
Show file tree

Hide file tree

Showing 4 changed files with 171 additions and 10 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -5,7 +5,7 @@ URL: https://github.com/functionaldata/tPACE
 BugReports: https://github.com/functionaldata/tPACE/issues
 Version: 0.5.8
 Encoding: UTF-8
-Date: 2021-10-11,
+Date: 2021-11-22,
 Authors@R: c(person("Alvaro", "Gajardo", email="[email protected]", role=c("aut","cre")),
     person("Satarupa","Bhattacharjee", role=c("aut")),
     person("Cody","Carroll", email="[email protected]", role=c("aut"), comment =  c(ORCID = "0000-0003-3525-8653")),
@@ -59,5 +59,5 @@ Suggests:
     minqa,
     testthat
 NeedsCompilation: yes
-RoxygenNote: 7.1.1
+RoxygenNote: 7.1.2
 VignetteBuilder: knitr
diff --git a/NEWS b/NEWS
@@ -1,10 +1,11 @@
-fdapace v0.5.8 (Release date: 11-Oct-2021)
+fdapace v0.5.8 (Release date: 22-Nov-2021)
 =============
 Changes:
 * Option for correlation surface output
 * Option for correlation surface plot
 * Default option for score estimation set to vanilla
 * Minor bug fixes in FPCA
+* Updated FLM documentation and output
 * Added vignette.
 
 fdapace v0.5.7 (Release date: 17-May-2021)

diff --git a/cran-comments.md b/cran-comments.md
@@ -1,18 +1,18 @@
 
 ## Test environments
-* local R installation, R 4.0.2
-* ubuntu 16.04 (on travis-ci), R 4.0.2
+* local R installation, macOS R 4.1.2
+* local ubuntu 20.04, R 4.1.2
 * win-builder (devel and release)
 
 ## R CMD check results
+on macOS:
+0 errors | 0 warnings | 0 notes
 
-0 errors | 0 warnings | 1 notes
-
-Note indicates a change in maintainer from Cody Carroll to Alvaro Gajardo.
+on ubuntu one note is generated regarding installed package size of 1Mb or more in subfolder libs. No notes were generated on windows.
 
 ## Downstream dependencies
-I have run R CMD check on downstream dependencies of fdapace: fdadensity, fdaPOIFD, fgm, frechet, KFPCA, LCox, and WRI.
+I have run R CMD check on ubuntu on downstream dependencies of fdapace: fdadensity,fdapaceShiny, fdaPOIFD, fgm, frechet, ftsa, KFPCA, LCox, mistat, SLFPCA and WRI.
 
 All packages passed.
 
-I have read and agree to all CRAN policies.
+I have read and agree to all CRAN policies.
diff --git a/tests/testthat/test_FLM.R b/tests/testthat/test_FLM.R
@@ -2,6 +2,48 @@ library(MASS)
 library(testthat)
 #devtools::load_all()
 
+test_that('GetBR2 works', {
+
+  set.seed(1)
+  # Scalar Y, scalar X scores with 1 column
+  n <- 20
+  y <- matrix(rnorm(n))
+  x <- lapply(1:1, function(x) cbind(rnorm(n)))
+  res <- GetBR2(y, x)
+  expect_equal(length(res$bList), 1)
+  expect_equal(vapply(res$bList, nrow, 1L), 1L)
+  expect_equal(vapply(res$bList, ncol, 1L), 1L)
+
+  set.seed(1)
+  # Scalar Y, scalar X scores with 2 columns
+  n <- 20
+  y <- matrix(rnorm(n))
+  x <- list(matrix(rnorm(n * 2), n, 2))
+  res <- GetBR2(y, x)
+  expect_equal(length(res$bList), 1)
+  expect_equal(vapply(res$bList, nrow, 1L), 2L)
+  expect_equal(vapply(res$bList, ncol, 1L), 1L)
+
+  # Scalar Y, 2 X scores each with 1 column
+  n <- 20
+  y <- matrix(rnorm(n))
+  x <- lapply(1:2, function(x) cbind(rnorm(n)))
+  res <- GetBR2(y, x)
+  expect_equal(length(res$bList), 2)
+  expect_equal(vapply(res$bList, nrow, 1L), c(1L, 1L))
+  expect_equal(vapply(res$bList, ncol, 1L), c(1L, 1L))
+
+  # Two Y scores, 2 X scores each with 1 column
+  n <- 20
+  y <- matrix(rnorm(n * 2), n, 2)
+  x <- lapply(1:2, function(x) cbind(rnorm(n)))
+  res <- GetBR2(y, x)
+  expect_equal(length(res$bList), 2)
+  expect_equal(vapply(res$bList, nrow, 1L), c(1L, 1L))
+  expect_equal(vapply(res$bList, ncol, 1L), c(2L, 2L))
+
+})
+
 test_that('Dense, scalar response case works', {
   set.seed(1000)
 
@@ -586,3 +628,121 @@ test_that('nRegGrid works', {
 })
 
 
+test_that('A general test', {
+
+  respType <- 'functional'
+  predTypeCounts <- c(functional=0, scalar=2)
+  funcType <- 'sparse' #TODO
+
+# for (ff in 0:2) {
+# for (ss in 0:2) {
+#   if (ff + ss == 0) next
+#   predTypeCounts <- c(functional = ff, scalar = ss)
+  set.seed(1)
+
+  n <- 50
+  M <- 51
+  K <- 2
+  cBeta <- 1
+  sigma <- 1
+  lambdaY <- c(1, 1) # Must have length K
+  basisType <- 'cos'
+
+  domainX <- c(0, 1)
+  domainY <- c(-0.5, 0.5)
+  gridX <- seq(0, 1, length.out=M)
+  gridY <- seq(domainY[1], domainY[2], length.out=M)
+
+  BasisX <- CreateBasis(K, gridX, type=basisType)
+  if (respType == 'scalar') {
+    BasisY <- matrix(1)
+    KY <- 1
+  } else if (respType == 'functional') {
+    BasisY <- BasisX
+    KY <- K
+  }
+
+  muX <- lapply(seq_len(predTypeCounts['functional']), 
+                function(j) {function(x) x^(j -1) * 1})
+  XFunc <- lapply(seq_len(predTypeCounts['functional']),
+                  function(j) {
+                    MakeSparseGP(n, muFun = muX[[j]], sigma=sigma, basisType=basisType)
+                  })
+  # CreatePathPlot(inputData = XFunc[[2]])
+  XTrue <- lapply(seq_along(XFunc), function(j) {
+                    XFunc[[j]]$xi %*% t(BasisX) + 
+                      matrix(muX[[j]](gridX), n, M, byrow=TRUE)
+                  })
+  XScalar <- lapply(seq_len(predTypeCounts['scalar']), 
+                    function(j) {
+                      -j + rnorm(n)
+                    })
+  betaFunc <- lapply(seq_len(predTypeCounts['functional']),
+                     function(j) {
+                       cBeta * BasisX %*% matrix(rnorm(K^2), K, KY) %*% t(BasisY)
+                     })
+  betaScalar <- lapply(seq_len(predTypeCounts['scalar']), 
+                       function(j) {
+                         matrix(rnorm(K), nrow=1) %*% t(BasisY)
+                       })
+  alpha <- gridY ^ 2 * 20
+
+  if (respType == 'scalar') {
+    alpha <- mean(alpha)
+    MY <- 1
+  } else {
+    MY <- M
+  }
+
+  trueYGivenXZ <- matrix(alpha, n, MY, byrow=TRUE) + 
+    Reduce(`+`, 
+           mapply(function(X, beta) {
+             X %*% beta * (gridX[2] - gridX[1])
+           }, XTrue, betaFunc, SIMPLIFY=FALSE),
+           init=matrix(0, n, MY)) +
+    Reduce(`+`,
+           mapply(function(Z, betaZ) {
+             matrix(Z, ncol=1) %*% betaZ
+           }, XScalar, betaScalar, SIMPLIFY=FALSE),
+           init=matrix(0, n, MY))
+
+  # matplot(t(trueYGivenXZ), type='l')
+
+  # Add noise to Y
+  if (respType == 'scalar') {
+    YNoise <- rnorm(n, sd=sigma)
+    Y <- trueYGivenXZ + YNoise
+  } else if (respType == 'functional') {
+    YNoise <- MakeSparseGP(n, sigma=sigma, lambda=lambdaY, basisType=basisType)
+    YNoise$Lt <- lapply(YNoise$Lt, function(tt) tt * diff(domainY) + domainY[1])
+    YNoise$Ly <- lapply(seq_len(n), function(i) {
+                          tt <- YNoise$Lt[[i]]
+                          yy <- YNoise$Ly[[i]] + 
+                            ConvertSupport(gridY, tt, mu=trueYGivenXZ[i, ])
+                          yy
+                        })
+    Y <- YNoise
+  }
+
+  a <- FLM(Y, c(XFunc, XScalar), nPerm=1000)
+  # b <- FLM(Y, XFunc, nPerm=1000)
+
+  plot(c(a$alpha))
+  plot(alpha)
+  matplot(t(a$betaList[[3]]), type='l', ylim=c(-5, 5))
+  matplot(t(do.call(rbind, betaScalar)), type='l', add=TRUE)
+
+  image(a$betaList[[1]])
+  image(a$betaList[[2]])
+  image(betaFunc[[1]])
+  image(betaFunc[[2]])
+
+  matplot(t(a$betaList[[1]]), type='l', ylim=c(-3, 3))
+  matplot(t(do.call(rbind, betaScalar)), type='l', add=TRUE)
+  matplot(t(a$yHat[1:5, ]), type='l')
+  matplot(t(trueYGivenXZ[1:5, ]), type='l', add=TRUE)
+
+  # TODO: add checks
+# }
+# }
+})