├── data └── medfly25.RData ├── tests ├── testthat │ ├── RData │ ├── test_all.R │ ├── test_mapX1d.R │ ├── test_trapzRcpp.R │ ├── test_minb.R │ ├── test_cumtrapzRcpp.R │ ├── test_CreateBasis.R │ ├── test_IsRegular.R │ ├── test_gcvlwls1d1.R │ ├── test_wiener.R │ ├── test_RcppPseudoApprox.R │ ├── test_cvlwls1d.R │ ├── test_ConvertSupport.R │ ├── test_createDesignPlot.R │ ├── test_useBin.R │ ├── test_CreateDiagnosticPlot.R │ ├── test_FVEdataset.R │ ├── test_SetOptions.R │ ├── test_plotFPCA.R │ ├── test_rotateLwls2dV2.R │ ├── test_BwNN.R │ ├── test_getCrCorYX.R │ ├── test_BinRawCov.R │ ├── test_CheckData.R │ ├── test_GetNormalisedSample.R │ ├── test_GetBinnedCurve.R │ ├── test_GetBinnedDataset.R │ ├── test_getMinb.R │ ├── test_FCCor.R │ ├── test_MakeSparseGP.R │ ├── test_fitted.R │ ├── test_GetSmoothedMeanCurve.R │ ├── test_RmullwlskUniversal.R │ ├── test_CreatePathPlot.R │ ├── test_GetEigenAnalysisResults.R │ ├── test_FitEigenValues.R │ ├── test_CreateTrueMean.R │ ├── test_GetCovDense.R │ ├── test_FClust.R │ ├── test_CreateFolds.R │ ├── test_MakeFPCAInputs.R │ ├── test_GetRawCov.R │ ├── test_GetRawCrCovFuncScal.R │ ├── test_CreateStringingPlot.R │ └── test_GetRho.R ├── AAAtestthat.R └── testthat_slow.R ├── CRAN-SUBMISSION ├── inst ├── testdata │ ├── dataForGcvLwls.RData │ ├── dataForGetRawCov.RData │ ├── dataForGcvLwlsTest.RData │ ├── InputFormMllwlskInCpp.RData │ ├── 200curvesByExampleSeed123.RData │ ├── InputForRotatedMllwlskInCpp.RData │ ├── YmatFromWFPCAexample_rng123.RData │ ├── dataGeneratedByExampleSeed123.RData │ └── datasetToTestRrotatedSmoother.RData └── CITATION ├── LICENSE ├── .Rbuildignore ├── src ├── RCPPvar.cpp ├── RCPPmean.cpp ├── Rcppsort.cpp ├── trapzRcpp.cpp ├── cumtrapzRcpp.cpp ├── GetIndCEScoresCPP.cpp ├── dropZeroElementsXYWin.cpp ├── RcppPseudoApprox.cpp └── GetIndCEScoresCPPnewInd.cpp ├── R ├── CreateTrueMean.R ├── str.FPCA.R ├── CreateDiagnosticsPlot.R ├── SubsetFPCA.R ├── GetCount.R ├── TruncateObs.R ├── IsRegular.R ├── GetUserMeanCurve.R ├── List2Mat.R ├── RotateLwls2DV2.R ├── print.WFDA.R ├── CheckSVDOptions.R ├── CompFntCent.R ├── print.FPCA.R ├── NormCurveToArea.R ├── GetRawCrCovFuncScal.R ├── print.FSVD.R ├── Minb.R ├── GenerateFunctionalData.R ├── medfly25.R ├── GetBinNum.R ├── ScaleKernel.R ├── GetMeanDense.R ├── MapX1D.R ├── BestDes_SR.R ├── FitEigenValues.R ├── SetDerOptions.R ├── GetUserCov.R ├── DesignPlotCount.R ├── BinData.R ├── HandleNumericsAndNAN.R ├── CondProjection.R ├── BestDes_TR.R ├── NormKernel.R ├── demeanFuc.R ├── CreateScreePlot.R ├── Lwls1D.R ├── GetMinb.R ├── NWMgnReg.R ├── GetBinnedDataset.R ├── BwNN.R ├── GetCrCorYX.R ├── GetINScores.R ├── CreateFolds.R ├── BinRawCov.R ├── GetCrCorYZ.R ├── Wiener.R ├── ConvertSupport.R ├── GetNormalisedSample.R ├── GenBSpline.R ├── MakeLNtoZscore02y.R ├── CheckData.R ├── MakeHCtoZscore02y.R ├── MakeGPFunctionalData.R └── CreateBasis.R ├── man ├── print.FSVD.Rd ├── print.WFDA.Rd ├── trapzRcpp.Rd ├── str.FPCA.Rd ├── cumtrapzRcpp.Rd ├── CheckData.Rd ├── CheckOptions.Rd ├── print.FPCA.Rd ├── MakeBWtoZscore02y.Rd ├── MakeLNtoZscore02y.Rd ├── SetOptions.Rd ├── MakeHCtoZscore02y.Rd ├── GetCrCorYX.Rd ├── GetCrCorYZ.Rd ├── BwNN.Rd ├── NormCurvToArea.Rd ├── CreateScreePlot.Rd ├── CreateBasis.Rd ├── Wiener.Rd ├── Lwls1D.Rd ├── ConvertSupport.Rd ├── medfly25.Rd ├── MakeFPCAInputs.Rd ├── Sparsify.Rd ├── fitted.FPCAder.Rd ├── MakeGPFunctionalData.Rd ├── CreateBWPlot.Rd ├── GetNormalisedSample.Rd ├── SelectK.Rd ├── MakeSparseGP.Rd ├── CreateModeOfVarPlot.Rd ├── plot.FPCA.Rd ├── FVPA.Rd ├── GetMeanCI.Rd ├── CreateCovPlot.Rd ├── DynCorr.Rd ├── CreateDesignPlot.Rd ├── CreateStringingPlot.Rd ├── Lwls2D.Rd ├── CreateFuncBoxPlot.Rd ├── Lwls2DDeriv.Rd ├── CreatePathPlot.Rd ├── GetCrCovYZ.Rd ├── predict.FPCA.Rd ├── FCCor.Rd ├── Dyn_test.Rd └── FLMCI.Rd ├── .travis.yml ├── ISSUE_TEMPLATE.md ├── README.md ├── cran-comments.md └── .gitignore /data/medfly25.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/functionaldata/tPACE/HEAD/data/medfly25.RData -------------------------------------------------------------------------------- /tests/testthat/RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/functionaldata/tPACE/HEAD/tests/testthat/RData -------------------------------------------------------------------------------- /CRAN-SUBMISSION: -------------------------------------------------------------------------------- 1 | Version: 0.6.0 2 | Date: 2024-07-03 05:35:10 UTC 3 | SHA: 2290825844a10285198a480e2e649f69d37666d4 4 | -------------------------------------------------------------------------------- /inst/testdata/dataForGcvLwls.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/functionaldata/tPACE/HEAD/inst/testdata/dataForGcvLwls.RData -------------------------------------------------------------------------------- /inst/testdata/dataForGetRawCov.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/functionaldata/tPACE/HEAD/inst/testdata/dataForGetRawCov.RData -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2019 2 | COPYRIGHT HOLDER: Hans-Georg Mueller and Jane-Ling Wang 3 | ORGANIZATION: University of California, Davis 4 | -------------------------------------------------------------------------------- /inst/testdata/dataForGcvLwlsTest.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/functionaldata/tPACE/HEAD/inst/testdata/dataForGcvLwlsTest.RData -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^\.travis\.yml$ 2 | ^inst/testdata$ 3 | ^ISSUE_TEMPLATE\.md$ 4 | ^tests$ 5 | ^cran-comments\.md$ 6 | ^CRAN-SUBMISSION$ 7 | -------------------------------------------------------------------------------- /inst/testdata/InputFormMllwlskInCpp.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/functionaldata/tPACE/HEAD/inst/testdata/InputFormMllwlskInCpp.RData -------------------------------------------------------------------------------- /inst/testdata/200curvesByExampleSeed123.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/functionaldata/tPACE/HEAD/inst/testdata/200curvesByExampleSeed123.RData -------------------------------------------------------------------------------- /inst/testdata/InputForRotatedMllwlskInCpp.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/functionaldata/tPACE/HEAD/inst/testdata/InputForRotatedMllwlskInCpp.RData -------------------------------------------------------------------------------- /inst/testdata/YmatFromWFPCAexample_rng123.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/functionaldata/tPACE/HEAD/inst/testdata/YmatFromWFPCAexample_rng123.RData -------------------------------------------------------------------------------- /inst/testdata/dataGeneratedByExampleSeed123.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/functionaldata/tPACE/HEAD/inst/testdata/dataGeneratedByExampleSeed123.RData -------------------------------------------------------------------------------- /inst/testdata/datasetToTestRrotatedSmoother.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/functionaldata/tPACE/HEAD/inst/testdata/datasetToTestRrotatedSmoother.RData -------------------------------------------------------------------------------- /src/RCPPvar.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | 4 | // [[Rcpp::export]] 5 | double RCPPvar(const Rcpp::NumericVector X){ 6 | return ( var(X) ) ; 7 | } 8 | -------------------------------------------------------------------------------- /src/RCPPmean.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | 4 | // [[Rcpp::export]] 5 | double RCPPmean(const Rcpp::NumericVector X){ 6 | return ( mean(X) ) ; 7 | } 8 | -------------------------------------------------------------------------------- /R/CreateTrueMean.R: -------------------------------------------------------------------------------- 1 | CreateTrueMean = function(tt,optns){ 2 | # old mu_true 3 | 4 | tt[!(tt >= 0 & tt <= optns)] = 0 5 | mu = (tt+sin(tt)) 6 | return(mu[!is.na(mu)]) 7 | 8 | } 9 | -------------------------------------------------------------------------------- /src/Rcppsort.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | // [[Rcpp::export]] 4 | NumericVector Rcppsort(NumericVector v) { 5 | NumericVector sv(clone(v)); 6 | std::sort(sv.begin(), sv.end()); 7 | return sv; 8 | } 9 | 10 | -------------------------------------------------------------------------------- /R/str.FPCA.R: -------------------------------------------------------------------------------- 1 | #' Compactly display the structure of an FPCA object 2 | #' 3 | #' @param object An FPCA object 4 | #' @param ... Not used 5 | #' 6 | #' @export 7 | str.FPCA <- function(object, ...) { 8 | fpcaObj <- object 9 | NextMethod(max.level=1) 10 | } 11 | -------------------------------------------------------------------------------- /tests/testthat/test_all.R: -------------------------------------------------------------------------------- 1 | devtools::load_all("../../") 2 | devtools::document("../../") 3 | data=list.files(path="./",pattern="*.R") 4 | data=data[-(which(data=="test_CreateStringingPlot.R"))] 5 | data=data[-(which(data=="test_all.R"))] 6 | for(i in 1:length(data)) { 7 | cat("Running test file: ", data[i], "\n") 8 | source(paste0("./",data[i])) 9 | } 10 | -------------------------------------------------------------------------------- /tests/testthat/test_mapX1d.R: -------------------------------------------------------------------------------- 1 | cat("\ntests for 'MapX1D'") 2 | 3 | test_that("basic arguments do not return any errors ", { 4 | xn = c(1:4,16) 5 | y = matrix(1:30, 15,2) 6 | x = c(1:14,16) 7 | expect_equal( MapX1D(x,y,xn), matrix(c(1,2,3,4,15,16,17,18,19,30), 5,2)) 8 | expect_equal( MapX1D(1:14, seq(0,1,length.out=14),1:4 ), seq(0,1,length.out=14)[1:4]) 9 | } 10 | ) 11 | 12 | -------------------------------------------------------------------------------- /man/print.FSVD.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/print.FSVD.R 3 | \name{print.FSVD} 4 | \alias{print.FSVD} 5 | \title{Print an FSVD object} 6 | \usage{ 7 | \method{print}{FSVD}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{An FSVD object.} 11 | 12 | \item{...}{Not used.} 13 | } 14 | \description{ 15 | Print a simple description of an FSVD object 16 | } 17 | -------------------------------------------------------------------------------- /man/print.WFDA.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/print.WFDA.R 3 | \name{print.WFDA} 4 | \alias{print.WFDA} 5 | \title{Print a WFDA object} 6 | \usage{ 7 | \method{print}{WFDA}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{A WFDA object.} 11 | 12 | \item{...}{Not used.} 13 | } 14 | \description{ 15 | Print a simple description of a WFDA object 16 | } 17 | -------------------------------------------------------------------------------- /R/CreateDiagnosticsPlot.R: -------------------------------------------------------------------------------- 1 | #' Functional Principal Component Analysis Diagnostics plot 2 | #' 3 | #' Deprecated. Use \code{plot.FPCA} instead. 4 | #' @param ... passed into \code{plot.FPCA}. 5 | #' @export 6 | #' @rdname plot.FPCA 7 | 8 | CreateDiagnosticsPlot <-function(...){ 9 | message('Deprecated and will be removed in the next version. Use plot.FPCA() instead.') 10 | plot.FPCA(...) 11 | } 12 | 13 | -------------------------------------------------------------------------------- /tests/testthat/test_trapzRcpp.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | library(testthat) 3 | 4 | test_that('trapzRcpp works on a trivial example', { 5 | x = c(0,2) 6 | y = c(0,2) 7 | expect_equal( trapzRcpp(x,y), 2 ) 8 | }) 9 | 10 | test_that('trapzRcpp works on a nearly trivial example', { 11 | x = seq(0,4, length.out=100) 12 | y = x + sin(x); 13 | expect_equal(trapzRcpp(x,y), 9.653418652171286) 14 | }) 15 | -------------------------------------------------------------------------------- /man/trapzRcpp.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{trapzRcpp} 4 | \alias{trapzRcpp} 5 | \title{Trapezoid Rule Numerical Integration} 6 | \usage{ 7 | trapzRcpp(X, Y) 8 | } 9 | \arguments{ 10 | \item{X}{Sorted vector of X values} 11 | 12 | \item{Y}{Vector of Y values.} 13 | } 14 | \description{ 15 | Trapezoid Rule Numerical Integration using Rcpp 16 | } 17 | -------------------------------------------------------------------------------- /tests/testthat/test_minb.R: -------------------------------------------------------------------------------- 1 | cat("\nTests for 'Minb'") 2 | 3 | test_that("basic vector arguments do not return any errors ", { 4 | expect_equal( Minb(c(1,2,3,4.1), -1), NaN) 5 | expect_equal( Minb(c(1,2,3,4.1), 1), 2* 0.55) 6 | expect_equal( Minb(c(11,2,3,4.1), -1), NaN) 7 | expect_equal( Minb(c(11,2,3,4.1), 2), 8) 8 | expect_equal( Minb(c(1,2,3,4.1), 6), NaN) 9 | }) 10 | 11 | # cat("Done") 12 | -------------------------------------------------------------------------------- /R/SubsetFPCA.R: -------------------------------------------------------------------------------- 1 | ### subset the FPCA object with a specified number of components K 2 | ### and return the subsetted fpcaObj 3 | 4 | SubsetFPCA <- function(fpcaObj, K){ 5 | fpcaObj$lambda <- fpcaObj$lambda[1:K] 6 | fpcaObj$phi <- fpcaObj$phi[,1:K, drop=FALSE] 7 | fpcaObj$xiEst <- fpcaObj$xiEst[,1:K, drop=FALSE] 8 | fpcaObj$FVE <- fpcaObj$cumFVE[K] 9 | fpcaObj$cumFVE <- fpcaObj$cumFVE[1:K] 10 | return(fpcaObj) 11 | } 12 | -------------------------------------------------------------------------------- /man/str.FPCA.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/str.FPCA.R 3 | \name{str.FPCA} 4 | \alias{str.FPCA} 5 | \title{Compactly display the structure of an FPCA object} 6 | \usage{ 7 | \method{str}{FPCA}(object, ...) 8 | } 9 | \arguments{ 10 | \item{object}{An FPCA object} 11 | 12 | \item{...}{Not used} 13 | } 14 | \description{ 15 | Compactly display the structure of an FPCA object 16 | } 17 | -------------------------------------------------------------------------------- /tests/testthat/test_cumtrapzRcpp.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | library(testthat) 3 | 4 | test_that('cumtrapzRcpp works on a trivial example', { 5 | x = c(0,2) 6 | y = c(0,2) 7 | expect_equal( cumtrapzRcpp(x,y), c(0,2) ) 8 | }) 9 | 10 | test_that('trapzRcpp works on a nearly trivial example', { 11 | x = seq(0,4, length.out=100) 12 | y = x + sin(x); 13 | expect_equal(sum( cumtrapzRcpp(x,y)) , 3.865524746134088e+02) 14 | }) 15 | -------------------------------------------------------------------------------- /tests/testthat/test_CreateBasis.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all('../../RPACE/tPACE') 2 | 3 | test_that('legendre basis works', { 4 | M <- 20000 5 | pts <- seq(0, 1, length.out=M) 6 | K <- 10 7 | 8 | tmp <- CreateBasis(K, pts, 'legendre01') 9 | expect_equal(crossprod(tmp) / M, diag(K), scale=1, tol=1e-3) 10 | 11 | K <- 1 12 | tmp <- CreateBasis(K, pts, 'legendre01') 13 | expect_equal(crossprod(tmp) / M, matrix(1), scale=1, tol=1e-3) 14 | }) 15 | -------------------------------------------------------------------------------- /man/cumtrapzRcpp.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{cumtrapzRcpp} 4 | \alias{cumtrapzRcpp} 5 | \title{Cumulative Trapezoid Rule Numerical Integration} 6 | \usage{ 7 | cumtrapzRcpp(X, Y) 8 | } 9 | \arguments{ 10 | \item{X}{Sorted vector of X values} 11 | 12 | \item{Y}{Vector of Y values.} 13 | } 14 | \description{ 15 | Cumulative Trapezoid Rule Numerical Integration using Rcpp 16 | } 17 | -------------------------------------------------------------------------------- /R/GetCount.R: -------------------------------------------------------------------------------- 1 | # get the count number of time pairs output by GetRawCov 2 | # Output: a data.frame of three columns: t1, t2, count 3 | GetCount <- function(tpairs) { 4 | # browser() 5 | tab <- table(tpairs[, 1], tpairs[, 2]) 6 | pts <- sort(unique(as.numeric(tpairs))) 7 | ret <- data.frame(expand.grid(pts, pts), as.numeric(tab)) 8 | names(ret) <- c('t1', 't2', 'count') 9 | ret <- ret[ret$count != 0, ] 10 | 11 | return(ret) 12 | } 13 | 14 | 15 | 16 | -------------------------------------------------------------------------------- /man/CheckData.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/CheckData.R 3 | \name{CheckData} 4 | \alias{CheckData} 5 | \title{Check data format} 6 | \usage{ 7 | CheckData(y, t) 8 | } 9 | \arguments{ 10 | \item{y}{is a n-by-1 list of vectors} 11 | 12 | \item{t}{is a n-by-1 list of vectors} 13 | } 14 | \description{ 15 | Check if there are problems with the form and basic structure of the functional data 'y' and the recorded times 't'. 16 | } 17 | -------------------------------------------------------------------------------- /tests/AAAtestthat.R: -------------------------------------------------------------------------------- 1 | # # Based on https://github.com/hadley/testthat#integration-with-r-cmd-check 2 | # splitting test files into multiple ones so that each one runs within 10 mins, 3 | # which is the limit on travis CI. 4 | # This file contains the "fast" checks. 5 | 6 | library(testthat) 7 | library(fdapace) 8 | test_check("fdapace", filter='_(?!FPCA)(?!FCReg)(?!FOptDes)(?!FClust)(?!FSVD)(?!FVPA)(?!GetCrCovYX)(?!selectK)(?!MultiFAM)(?!VCAM)(?!WFDA)', perl=TRUE) 9 | # test_check("fdapace") 10 | 11 | -------------------------------------------------------------------------------- /tests/testthat/test_IsRegular.R: -------------------------------------------------------------------------------- 1 | cat("\ntests for 'IsRegular'") 2 | 3 | test_that("basic valid lists arguments do not return any errors", { 4 | expect_equal(IsRegular(list(c(1:10), c(1:10), c(1:10))), 'Dense') 5 | expect_equal(IsRegular(list(c(1,2,3 ), c(1,2,3,4), c(1,2,3,4))), 'DenseWithMV') 6 | expect_equal(IsRegular(list(c(1,2 ), c(1,2,3 ), c(1,2,3,4))), 'Sparse') 7 | } 8 | ) 9 | 10 | cat("\nexcept for dense but irregular case") 11 | IsRegular(list(c(1,2,3,5),c(1,2,3,5),c(1,2,3,5))) 12 | -------------------------------------------------------------------------------- /tests/testthat/test_gcvlwls1d1.R: -------------------------------------------------------------------------------- 1 | cat("\nTests for 'GCVLwls1D1.R'") 2 | 3 | load(system.file('testdata', 'dataForGcvLwlsTest.RData', package='fdapace')) 4 | 5 | test_that("basic optimal bandwidth choice for the mean function use GCV method matches MATLAB for Sparse data", { 6 | 7 | A <- GCVLwls1D1(y,t,'epan',1,0,'Sparse') 8 | expect_equal( A$bOpt, 2.071354057811459 ) 9 | 10 | B <- GCVLwls1D1(y,t,'rect',1,0,'Sparse') 11 | expect_equal( B$bOpt, 2.238990337557121, 0.04 ) 12 | 13 | } ) 14 | 15 | -------------------------------------------------------------------------------- /man/CheckOptions.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/CheckOptions.R 3 | \name{CheckOptions} 4 | \alias{CheckOptions} 5 | \title{Check option format} 6 | \usage{ 7 | CheckOptions(t, optns, n) 8 | } 9 | \arguments{ 10 | \item{t}{is a n-by-1 list of vectors} 11 | 12 | \item{optns}{is an initialized option list} 13 | 14 | \item{n}{is a total number of sample curves} 15 | } 16 | \description{ 17 | Check if the options structure is valid and set the NULL options 18 | } 19 | -------------------------------------------------------------------------------- /tests/testthat/test_wiener.R: -------------------------------------------------------------------------------- 1 | # source('.../Wiener.R') 2 | 3 | pts <- seq(0, 1, length=20) 4 | tmp <- Wiener(50, pts) 5 | tmp1 <- Sparsify(tmp, pts, c(2, 4, 6)) 6 | 7 | sapply(tmp1$Lt, length) 8 | sapply(tmp1$Ly, length) 9 | 10 | set.seed(1) 11 | tmp2 <- Wiener(10, pts=seq(0, 1, by=0.1)) 12 | set.seed(1) 13 | tmp3 <- Wiener(10, pts=seq(0, 1, by=0.1), sparsify=2) 14 | 15 | pts <- seq(0, 1, by=0.02) 16 | tmp <- Wiener(1000, pts) 17 | tmp1 <- Sparsify(tmp, pts, 1:5, fragment=0.2) 18 | CreateDesignPlot(tmp1[['Lt']], pts, TRUE, FALSE) -------------------------------------------------------------------------------- /R/TruncateObs.R: -------------------------------------------------------------------------------- 1 | # Roxygen 2 | 3 | TruncateObs <- function(Ly, Lt, obsGrid, buff=.Machine$double.eps * max(abs(obsGrid)) * 3) { 4 | tmpInd <- mapply(function(yVec, tVec) { 5 | ind <- (tVec >= min(obsGrid) - buff & tVec <= max(obsGrid) + buff) 6 | return(ind) 7 | }, Ly, Lt, SIMPLIFY=FALSE) 8 | Ly <- mapply(function(yVec, ind) yVec[ind], Ly, tmpInd, SIMPLIFY = FALSE) 9 | Lt <- mapply(function(tVec, ind) tVec[ind], Lt, tmpInd, SIMPLIFY = FALSE) 10 | 11 | return(list(Ly=Ly, Lt=Lt)) 12 | } 13 | -------------------------------------------------------------------------------- /tests/testthat/test_RcppPseudoApprox.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | library(testthat) 3 | 4 | test_that('RcppPseudoApprox works on a nearly trivial example', { 5 | set.seed(111) 6 | z = runif(44); 7 | expect_equal( RcppPseudoApprox(X = c(0,1), Y = c(0,2) , X_target = z), 2*z, tolerance = 1e-7) 8 | 9 | }) 10 | 11 | test_that('RcppPseudoApprox errs on obviously wrong data.', { 12 | 13 | expect_error( RcppPseudoApprox(X = c(0,1), Y = c(0,2,4) , X_target = 0), 14 | "Problem with unequal vector sizes when doing linear interpolation.") 15 | 16 | }) -------------------------------------------------------------------------------- /tests/testthat/test_cvlwls1d.R: -------------------------------------------------------------------------------- 1 | cat("\ntests for 'CVLwls1D'") 2 | 3 | test_that("basic arguments match MATLAB output ", { 4 | 5 | try(silent=TRUE, load(system.file('testdata', 'dataGeneratedByExampleSeed123.RData', package='fdapace'))) 6 | try(silent=TRUE, load(system.file('testdata', 'dataGeneratedByExampleSeed123.RData', package='fdapace'))) 7 | 8 | a_result = CVLwls1D(y, t=t, kernel='epan', npoly=1, nder=0, dataType='Sparse') 9 | expect_equal( a_result, 4.172873877723954, tol = 0.6) # High tolerance because we have different implementation 10 | 11 | } 12 | ) 13 | 14 | -------------------------------------------------------------------------------- /R/IsRegular.R: -------------------------------------------------------------------------------- 1 | IsRegular = function(t){ 2 | 3 | # Check the data type in terms of dense-sparse. Classification is dense (2), or data with missing values (1) or sparse (0) data 4 | # t : n-by-1 list of vectors 5 | 6 | tt = unlist(t); 7 | f = length(tt)/length(unique(tt))/length(t); 8 | if (f == 1){ 9 | if(length(unique(tt))<8){ #In case of low number of observations per subject 10 | return('Sparse'); 11 | } 12 | else{ 13 | return('Dense'); # for either regular and irregular data 14 | } 15 | } else if(f > 0.80){ 16 | return('DenseWithMV'); 17 | } else { 18 | return('Sparse'); 19 | } 20 | } 21 | -------------------------------------------------------------------------------- /tests/testthat/test_ConvertSupport.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | library(testthat) 3 | 4 | fromGrid <- seq(0, pi / 2, 0.1) 5 | toGrid <- fromGrid + 0.001 6 | toGrid[length(toGrid)] <- toGrid[length(toGrid)] - 0.002 7 | mu <- sin(fromGrid) 8 | phi <- cbind(sin(fromGrid), cos(fromGrid)) 9 | phi1 <- matrix(phi[, 1], ncol=1) 10 | Cov <- tcrossprod(phi) 11 | 12 | test_that('ConvertSupport works', { 13 | expect_equal(mu, ConvertSupport(fromGrid, toGrid, mu=mu), tolerance=2e-3) 14 | expect_equal(phi, ConvertSupport(fromGrid, toGrid, phi=phi), tolerance=2e-3) 15 | expect_equal(Cov, ConvertSupport(fromGrid, toGrid, Cov=Cov), tolerance=1e-3) 16 | }) 17 | -------------------------------------------------------------------------------- /man/print.FPCA.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/print.FPCA.R 3 | \name{print.FPCA} 4 | \alias{print.FPCA} 5 | \title{Print an FPCA object} 6 | \usage{ 7 | \method{print}{FPCA}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{An FPCA object.} 11 | 12 | \item{...}{Not used.} 13 | } 14 | \description{ 15 | Print a simple description of an FPCA object 16 | } 17 | \examples{ 18 | \donttest{ 19 | set.seed(1) 20 | n <- 20 21 | pts <- seq(0, 1, by=0.05) 22 | sampWiener <- Wiener(n, pts) 23 | sampWiener <- Sparsify(sampWiener, pts, 10) 24 | res <- FPCA(sampWiener$Ly, sampWiener$Lt) 25 | res 26 | } 27 | 28 | } 29 | -------------------------------------------------------------------------------- /tests/testthat/test_createDesignPlot.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | # devtools::load_all() 3 | 4 | # Uniform time points 5 | ## a speed test 6 | set.seed(1) 7 | n <- 1e3 8 | sparsity <- 1:5 9 | Lt <- replicate(n, runif(sample(sparsity, 1)), simplify=FALSE) 10 | obsGrid <- sort(unique(unlist(Lt))) 11 | system.time( 12 | CreateDesignPlot(Lt, obsGrid, isColorPlot=TRUE) 13 | ) 14 | 15 | # ... are passed in 16 | set.seed(1) 17 | n <- 5e2 18 | sparsity <- 1:5 19 | Lt <- replicate(n, round(runif(sample(sparsity, 1)), 2), simplify=FALSE) 20 | obsGrid <- sort(unique(unlist(Lt))) 21 | CreateDesignPlot(Lt, obsGrid, isColorPlot=TRUE, pch=1, cex=1, xlab='XX', ylab='YY') 22 | -------------------------------------------------------------------------------- /tests/testthat/test_useBin.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | library(testthat) 3 | 4 | test_that('The binned version is exactly the same as the unbinned version.', { 5 | set.seed(1) 6 | pts <- seq(0, 1, by=0.05) 7 | samp3 <- Wiener(300, pts, sparsify=5) 8 | y <- samp3$Ly 9 | t <- samp3$Lt 10 | 11 | resNoBin <- FPCA(y, t, list(dataType='Sparse', useBinnedData='OFF', useBinnedCov=FALSE)) 12 | resBin <- FPCA(y, t, list(dataType='Sparse', useBinnedData='OFF', useBinnedCov=TRUE)) 13 | 14 | resBin$timings= NULL; 15 | resNoBin$timings=NULL; 16 | 17 | expect_equal(resNoBin[names(resNoBin) != 'optns'], resBin[names(resBin) != 'optns']) 18 | }) 19 | -------------------------------------------------------------------------------- /tests/testthat/test_CreateDiagnosticPlot.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | 3 | viewPdf <- FALSE 4 | set.seed(1) 5 | n <- 100 6 | M <- 51 7 | pts <- seq(0, 1, length.out=M) 8 | mu <- rep(0, length(pts)) 9 | sampDense <- Wiener(n, pts) 10 | samp <- Sparsify(sampDense, pts, M) 11 | res <- FPCA(samp$Ly, samp$Lt, list(error=TRUE, FVEthreshold=1, dataType='Dense', plot=TRUE)) 12 | 13 | if (viewPdf) { 14 | pdf('tmp.pdf') 15 | } 16 | 17 | plot(res) 18 | CreateDesignPlot(samp$Lt) 19 | plot(res, addLegend=FALSE) 20 | CreateDesignPlot(samp$Lt, addLegend=FALSE) 21 | 22 | if (viewPdf) { 23 | dev.off() 24 | system('open tmp.pdf') 25 | file.remove('tmp.pdf') 26 | } 27 | -------------------------------------------------------------------------------- /tests/testthat/test_FVEdataset.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | 3 | 4 | 5 | # 6 | #FVEdata <- read.table("http://www.hsph.harvard.edu/fitzmaur/ala2e/fev1.txt", col.names=c('SubjectID', 'Height', 'Age', 'InitialHeight', 'InitialAge', 'LogFEV1'), skip=42 ); 7 | # 8 | #mySample = MakeFPCAInputs(IDs= FVEdata$SubjectID, tVec=FVEdata$Age, yVec=FVEdata$LogFEV1); 9 | # 10 | #y= mySample$Ly 11 | #t= mySample$Lt 12 | # 13 | ## optns = CreateOptions() 14 | ## system.time(tmp <- FPCA(y, t, optns)) 15 | ## tmp$sigma2 16 | # 17 | # 18 | #optns1 <- list(kernel='rect') 19 | #system.time(tmp1 <- FPCA(y, t, optns1)) 20 | ## plot(tmp1$phi[, 1]) # off 21 | ## CreateCovPlot(tmp1, 'Smoothed', TRUE) 22 | -------------------------------------------------------------------------------- /man/MakeBWtoZscore02y.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/MakeBWtoZscore02y.R 3 | \name{MakeBWtoZscore02y} 4 | \alias{MakeBWtoZscore02y} 5 | \title{Z-score body-weight for age 0 to 24 months based on WHO standards} 6 | \usage{ 7 | MakeBWtoZscore02y(sex, age, bw) 8 | } 9 | \arguments{ 10 | \item{sex}{A character 'M' or 'F' indicating the sex of the child.} 11 | 12 | \item{age}{A vector of time points of size Q.} 13 | 14 | \item{bw}{A vector of body-weight readings of size Q.} 15 | } 16 | \value{ 17 | A vector of Z-scores of size Q. 18 | } 19 | \description{ 20 | Make vector of age and body-weight to z-scores based on WHO standards using LMS 21 | } 22 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: r 2 | #os: 3 | #- osx 4 | cache: packages 5 | sudo: false 6 | services: 7 | - xvfb 8 | 9 | latex: false 10 | 11 | latex: false 12 | 13 | before_install: 14 | - export DISPLAY=:99.0 15 | - sudo apt-get update 16 | - sudo apt-get install libglu1-mesa-dev freeglut3-dev mesa-common-dev 17 | 18 | r_packages: 19 | - survival 20 | 21 | addons: 22 | apt: 23 | packages: 24 | - tcl-dev # - tcl-dev 25 | - tk-dev # - tk-dev 26 | - texlive-latex-extra 27 | 28 | warnings_are_errors: false 29 | 30 | 31 | #before_script: 32 | # - R -e 'install.packages("http://cran.r-project.org/src/contrib/Archive/Rcpp/Rcpp_0.12.7.tar.gz", repos = NULL)' 33 | 34 | -------------------------------------------------------------------------------- /tests/testthat/test_SetOptions.R: -------------------------------------------------------------------------------- 1 | cat("\nTests for 'SetOptions'") 2 | 3 | library(testthat) 4 | 5 | 6 | optns = list(methodXi = NULL) 7 | 8 | test_that("SetOptions test: optns$method = NULL 'IN' for Dense case, 'CE' for Sparse case, 'CE' for other cases with warning", { 9 | expect_equal(SetOptions(list(c(1,3,5), c(2,4)),list(c(1,3,5), c(2,4)), optns)$methodXi, 'CE') 10 | expect_equal(SetOptions(list(c(1:10), c(1:10)),list(c(1:10), c(1:10)), optns)$methodXi, 'IN') 11 | expect_equal(SetOptions(list(c(1:10), c(1:10)),list(c(1:10), c(1:10)), optns)$kernel, 'epan') 12 | expect_equal(SetOptions(list(c(1,2,3,4,5), c(1,2,3,4)),list(c(1,2,3,4,5), c(1,2,3,4)), optns)$methodXi, 'CE') 13 | }) 14 | -------------------------------------------------------------------------------- /tests/testthat/test_plotFPCA.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | 3 | viewPdf <- FALSE 4 | set.seed(2) 5 | n <- 100 6 | M <- 51 7 | pts <- seq(0, 1, length.out=M) 8 | mu <- rep(0, length(pts)) 9 | sampDense <- Wiener(n, pts) 10 | samp <- Sparsify(sampDense, pts, M) 11 | res <- FPCA(samp$Ly, samp$Lt, list(error=TRUE, FVEthreshold=1, dataType='Dense', plot=TRUE)) 12 | 13 | if (viewPdf) { 14 | pdf('tmp.pdf') 15 | } 16 | 17 | plot(res) 18 | 19 | test_that("inner product of eigenfunctions and mean shall be non-negative", { 20 | inprod.mu.and.phi <- res$mu %*% res$phi / M #compute inner product by simple Riemann sum 21 | expect_true( all(inprod.mu.and.phi>=0) ) #absolute difference 22 | 23 | }) 24 | -------------------------------------------------------------------------------- /R/GetUserMeanCurve.R: -------------------------------------------------------------------------------- 1 | GetUserMeanCurve <- function (optns, obsGrid, regGrid, buff) { 2 | # For the case where a user provides a mean function 3 | 4 | userMu = optns$userMu 5 | rangeUser <- range(optns$userMu$t) 6 | rangeObs <- range(obsGrid) 7 | if( rangeUser[1] > rangeObs[1] + buff || 8 | rangeUser[2] < rangeObs[2] - buff ) { 9 | stop('The range defined by the user provided mean does not cover the support of the data.') 10 | } 11 | 12 | mu = spline(userMu$t, userMu$mu, xout= obsGrid)$y 13 | muDense = spline(obsGrid,mu, xout=regGrid)$y 14 | bw_mu = NULL 15 | 16 | result <- list( 'mu' = mu, 'muDense'= muDense, 'bw_mu' = bw_mu) 17 | class(result) <- "SMC" 18 | return(result) 19 | } 20 | -------------------------------------------------------------------------------- /man/MakeLNtoZscore02y.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/MakeLNtoZscore02y.R 3 | \name{MakeLNtoZscore02y} 4 | \alias{MakeLNtoZscore02y} 5 | \title{Z-score height for age 0 to 24 months based on WHO standards} 6 | \usage{ 7 | MakeLNtoZscore02y(sex, age, ln) 8 | } 9 | \arguments{ 10 | \item{sex}{A character 'M' or 'F' indicating the sex of the child.} 11 | 12 | \item{age}{A vector of time points of size Q.} 13 | 14 | \item{ln}{A vector of body-length readings of size Q (in cm).} 15 | } 16 | \value{ 17 | A vector of Z-scores of size Q. 18 | } 19 | \description{ 20 | Convert vector of age and height measurement to z-scores based on WHO standards using mu and sigma (not LMS) 21 | } 22 | -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | bibentry( 2 | bibtype = "manual", 3 | title = "{fdapace: Functional Data Analysis and Empirical Dynamics}", 4 | author = c(person("Yidong", "Zhou"), person("Han", "Chen"), person("Su I", "Iao"), person("Poorbita", "Kundu"), person("Hang", "Zhou"), person("Satarupa", "Bhattacharjee"), person("Cody", "Carroll"), person("Yaqing", "Chen"), person("Xiongtao", "Dai"), person("Jianing", "Fan"), person("Alvaro", "Gajardo"), person("Pantelis Z.", "Hadjipantelis"), person("Kyunghee", "Han"), person("Hao", "Ji"), person("Changbo", "Zhu"), person("Hans-Georg", "Müller"), person("Jane-Ling", "Wang")), 5 | year = "2024", 6 | note = "R package version 0.6.0", 7 | url = "https://CRAN.R-project.org/package=fdapace" 8 | ) 9 | -------------------------------------------------------------------------------- /man/SetOptions.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/SetOptions.R 3 | \name{SetOptions} 4 | \alias{SetOptions} 5 | \title{Set the PCA option list} 6 | \usage{ 7 | SetOptions(y, t, optns) 8 | } 9 | \arguments{ 10 | \item{y}{A list of \emph{n} vectors containing the observed values for each individual.} 11 | 12 | \item{t}{A list of \emph{n} vectors containing the observation time points for each individual corresponding to y.} 13 | 14 | \item{optns}{A list of options control parameters specified by \code{list(name=value)}. See `Details'. 15 | 16 | See '?FPCA for more details. Casual users are not advised to tamper with this function.} 17 | } 18 | \description{ 19 | Set the PCA option list 20 | } 21 | -------------------------------------------------------------------------------- /ISSUE_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | If you are filing an enhancement/feature request, make sure you: 2 | 3 | - Provide at least one reference about it, or 4 | - Provide at least one particular user case. 5 | 6 | If you are filing a bug, make sure these steps are followed before submitting your issue - it will help us help you more efficiently! 7 | 8 | - Start a new R session 9 | - Make sure you are using the latest version of `fdapace` (eg. `update.packages(oldPkgs="fdapace", ask=FALSE)`) 10 | - [Write a minimal reproducible example](http://stackoverflow.com/a/5963610) 11 | - Run `sessionInfo()` 12 | 13 | If you are having a general question about using `fdapace` or its design: 14 | 15 | - Email us at first instance; we are happy to help new users of fdapace. :D 16 | -------------------------------------------------------------------------------- /man/MakeHCtoZscore02y.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/MakeHCtoZscore02y.R 3 | \name{MakeHCtoZscore02y} 4 | \alias{MakeHCtoZscore02y} 5 | \title{Z-score head-circumference for age 0 to 24 months based on WHO standards} 6 | \usage{ 7 | MakeHCtoZscore02y(sex, age, hc) 8 | } 9 | \arguments{ 10 | \item{sex}{A character 'M' or 'F' indicating the sex of the child.} 11 | 12 | \item{age}{A vector of time points of size Q.} 13 | 14 | \item{hc}{A vector of head circumference readings of size Q (in cm).} 15 | } 16 | \value{ 17 | A vector of Z-scores of size Q. 18 | } 19 | \description{ 20 | Convert vector of age and height measurement to z-scores based on WHO standards using mu and sigma (not LMS) 21 | } 22 | -------------------------------------------------------------------------------- /man/GetCrCorYX.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/GetCrCorYX.R 3 | \name{GetCrCorYX} 4 | \alias{GetCrCorYX} 5 | \title{Create cross-correlation matrix from auto- and cross-covariance matrix} 6 | \usage{ 7 | GetCrCorYX(ccXY, ccXX, ccYY) 8 | } 9 | \arguments{ 10 | \item{ccXY}{The cross-covariance matrix between variables X and Y.} 11 | 12 | \item{ccXX}{The auto-covariance matrix of variable X or the diagonal of that matrix.} 13 | 14 | \item{ccYY}{The auto-covariance matrix of variable Y or the diagonal of that matrix.} 15 | } 16 | \value{ 17 | A cross-correlation matrix between variables X and Y. 18 | } 19 | \description{ 20 | Create cross-correlation matrix from auto- and cross-covariance matrix 21 | } 22 | -------------------------------------------------------------------------------- /man/GetCrCorYZ.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/GetCrCorYZ.R 3 | \name{GetCrCorYZ} 4 | \alias{GetCrCorYZ} 5 | \title{Create cross-correlation matrix from auto- and cross-covariance matrix} 6 | \usage{ 7 | GetCrCorYZ(ccYZ, acYY, covZ) 8 | } 9 | \arguments{ 10 | \item{ccYZ}{The cross-covariance vector between variables Y and Z (n-by-1).} 11 | 12 | \item{acYY}{The auto-covariance n-by-n matrix of variable Y or the (n-by-1) diagonal of that matrix.} 13 | 14 | \item{covZ}{The (scalar) covariance of variable Z.} 15 | } 16 | \value{ 17 | A cross-correlation matrix between variables Y (functional) and Z (scalar). 18 | } 19 | \description{ 20 | Create cross-correlation matrix from auto- and cross-covariance matrix 21 | } 22 | -------------------------------------------------------------------------------- /R/List2Mat.R: -------------------------------------------------------------------------------- 1 | # This function converts dense regular functional input lists 2 | # to a matrix for easier dense case implementation 3 | ########################################################################## 4 | # Input: - y: list of n dense regular observed p-dim functional objects 5 | ########################################################################## 6 | # Output: - ymat: n by p matrix containing all functional data 7 | ########################################################################## 8 | 9 | List2Mat <- function(y,t){ 10 | n = length(y) 11 | obsGrid = sort(unique(unlist(t))) 12 | ymat = matrix( rep(NA, n * length(obsGrid)), nrow = n, byrow = TRUE) 13 | 14 | for (i in 1:n){ 15 | ymat[i, is.element(obsGrid, t[[i]])] = y[[i]] 16 | } 17 | return(ymat) 18 | } 19 | -------------------------------------------------------------------------------- /R/RotateLwls2DV2.R: -------------------------------------------------------------------------------- 1 | # Rotate the data and then smooth the diagonal elements. We use quadratic terms on either direction, rather than only orthogonal to the diagonal. 2 | # xout: a matrix of two columns containing the diagonal elements. 3 | 4 | RotateLwls2DV2 <- function(bw, kern='epan', xin, yin, win=NULL, xout) { 5 | 6 | if (length(bw) == 1){ 7 | bw <- c(bw, bw) 8 | } 9 | 10 | if (missing(win) || is.null(win)){ 11 | win <- rep(1, length(xin)) 12 | } 13 | 14 | if ( is.vector(xout)){ 15 | xout = matrix(c(xout,xout),ncol= 2) 16 | } 17 | 18 | fit <- Rrotatedmullwlsk(bw, kern, t(xin), yin, win, t(xout), npoly=1, bwCheck=FALSE) 19 | 20 | if (any(is.nan(fit))) 21 | stop('Something wrong with the rotate smoothed results') 22 | 23 | return(fit) 24 | } 25 | -------------------------------------------------------------------------------- /tests/testthat/test_rotateLwls2dV2.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | set.seed(1) 3 | n <- 100 4 | pts <- seq(0, 1, by=0.05) 5 | outPts <- seq(0, 1, by=0.1) 6 | samp3 <- Wiener(n, pts) + rnorm(n * length(pts), sd=0.5) 7 | samp3 <- Sparsify(samp3, pts, 5:10) 8 | rcov3 <- GetRawCov(samp3$Ly, samp3$Lt, pts, rep(0, length(pts)), 'Sparse', error=TRUE) 9 | brcov3 <- BinRawCov(rcov3) 10 | 11 | gcv3b <- GCVLwls2DV2(pts, outPts, kern='epan', rcov=brcov3, t=samp3$Lt) 12 | 13 | test_that('RotateLwls2dV2.R interface is correct', { 14 | expect_equal(Rrotatedmullwlsk(c(gcv3b$h, gcv3b$h) , 'epan', t(brcov3$tPairs), brcov3$meanVals, brcov3$count, rbind(outPts, outPts), npoly=1, bwCheck=FALSE), RotateLwls2DV2( gcv3b$h, 'epan', xin=brcov3$tPairs, yin=brcov3$meanVals, win=brcov3$count, xout=cbind(outPts, outPts))) 15 | }) 16 | -------------------------------------------------------------------------------- /R/print.WFDA.R: -------------------------------------------------------------------------------- 1 | #' Print a WFDA object 2 | #' 3 | #' Print a simple description of a WFDA object 4 | #' 5 | #' @param x A WFDA object. 6 | #' @param ... Not used. 7 | #' 8 | #' @method print WFDA 9 | #' @export 10 | print.WFDA <- function(x, ...){ 11 | obj = x; 12 | 13 | cat(paste0("Warped Functional Data Analysis object for ", length(obj$costs), " curves.\n\n")) 14 | cat(paste0("The penalty parameter used was: ", signif(obj$lambda,6), ", the warping functions ", 15 | ifelse(obj$optns$isPWL,"are ", "are not"), "piece-wise linear \n", 16 | "and the pairwise warping was done using the ", obj$optns$choice, " averages of the warped curves.\n" )) 17 | } 18 | 19 | -------------------------------------------------------------------------------- /R/CheckSVDOptions.R: -------------------------------------------------------------------------------- 1 | ### CheckSVDOptions 2 | 3 | CheckSVDOptions <- function(Ly1, Lt1, Ly2, Lt2, SVDoptns){ 4 | 5 | if( (SVDoptns[['dataType1']]=='Sparse' && is.null(SVDoptns[['userMu1']])) || 6 | (SVDoptns[['dataType2']]=='Sparse' && is.null(SVDoptns[['userMu2']])) ){ 7 | stop('User specified mean function required for sparse functional data for cross covariance estimation.') 8 | } 9 | if(is.numeric(SVDoptns$methodSelectK)){ 10 | if(SVDoptns$methodSelectK != round(SVDoptns$methodSelectK) || 11 | SVDoptns$methodSelectK <= 0){ 12 | stop("FSVD is aborted: 'methodSelectK' is invalid!\n") 13 | } 14 | } 15 | if( !(SVDoptns$regulRS %in% c('sigma2','rho') ) ){ 16 | stop("FSVD is aborted: Unknown regularization option. The argument 'regulRS' should be 'rho' or 'sigma2'!") 17 | } 18 | } -------------------------------------------------------------------------------- /man/BwNN.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/BwNN.R 3 | \name{BwNN} 4 | \alias{BwNN} 5 | \title{Minimum bandwidth based on kNN criterion.} 6 | \usage{ 7 | BwNN(Lt, k = 3, onlyMean = FALSE, onlyCov = FALSE) 8 | } 9 | \arguments{ 10 | \item{Lt}{n-by-1 list of vectors} 11 | 12 | \item{k}{number of unique neighbors for cov and mu (default = 3)} 13 | 14 | \item{onlyMean}{Indicator to return only the minimum bandwidth for the mean} 15 | 16 | \item{onlyCov}{Indicator to return only the minimum bandwidth for the covariance} 17 | } 18 | \description{ 19 | Input a list of time points Lt, and the number of unique neighbors k. Obtain the minimum bandwidth guaranteeing k unique neighbours. 20 | } 21 | \examples{ 22 | tinyGrid = list(c(1,7), c(2,3), 6, c(2,4), c(4,5)) 23 | BwNN(tinyGrid, k = 2) # c(3,2) 24 | } 25 | -------------------------------------------------------------------------------- /tests/testthat/test_BwNN.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all(); library(testthat) 2 | 3 | 4 | library(testthat) 5 | test_that('FindNN is correct', { 6 | tPairs <- matrix(c(0, 0, 7 | 1, 1, 8 | 0, 1, 9 | 1, 0, 10 | 0, 0.2, 11 | 0.2, 0, 12 | 0.2, 0.2, 13 | 0.2, 1, 14 | 1, 0.2), byrow=TRUE, ncol=2) 15 | expect_equal(FindNN(tPairs), 0.8) 16 | }) 17 | 18 | 19 | 20 | test_that('BWNN works for large sample', { 21 | library(fdapace) 22 | set.seed(1) 23 | n <- 100 24 | pts <- seq(0, 1, length.out=100) 25 | sparsity <- 2:5 26 | samp <- Wiener(n, pts, sparsity) 27 | bw <- BwNN(samp[[1]]) # Lt or Lt 28 | expect_true(bw['cov'] >= 0.01 && bw['cov'] < 0.1 && bw['mu'] <= bw['cov']) 29 | }) 30 | 31 | -------------------------------------------------------------------------------- /man/NormCurvToArea.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/NormCurveToArea.R 3 | \name{NormCurvToArea} 4 | \alias{NormCurvToArea} 5 | \title{Normalize a curve to a particular area, by multiplication with a factor} 6 | \usage{ 7 | NormCurvToArea(y, x = seq(0, 1, length.out = length(y)), area = 1) 8 | } 9 | \arguments{ 10 | \item{y}{values of curve at time-points \code{x}} 11 | 12 | \item{x}{design time-points (default: \code{seq(0,1, length.out=length(y))})} 13 | 14 | \item{area}{value to normalize the curve onto (default: 1)} 15 | } 16 | \value{ 17 | values of curve at times \code{x} such that its integration over \code{x} equals \code{area}. 18 | } 19 | \description{ 20 | Normalize a curve such that its integration over the design time-points equals a particular value (according to trapezoid integration). 21 | } 22 | -------------------------------------------------------------------------------- /tests/testthat/test_getCrCorYX.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | 3 | test_that('GetCrCorYX works on a trivial example', { 4 | 5 | set.seed(123) 6 | A = matrix(rnorm(10*7), ncol=7); 7 | B = matrix(rnorm(10*4), ncol=4); 8 | 9 | covA = cov(A) 10 | covB = cov(B) 11 | covAB = cov(A,B) 12 | 13 | expect_equal(GetCrCorYX(covAB, covA, covB),cor(A,B)) 14 | 15 | expect_equal(GetCrCorYX(covAB, diag(covA), diag(covB)),cor(A,B)) 16 | 17 | }) 18 | 19 | test_that('GetCrCorYX works on a trivial example with a scalar', { 20 | 21 | set.seed(123) 22 | A = matrix(rnorm(101*7), ncol=7); 23 | B = rnorm(101); 24 | 25 | covA = cov(A) 26 | covB = var(B) 27 | covAB = cov(A,B) 28 | 29 | expect_equal(GetCrCorYX(covAB, covA, covB),cor(A,B)) 30 | 31 | expect_equal(GetCrCorYX(covAB, diag(covA), covB),cor(A,B)) 32 | 33 | }) 34 | 35 | -------------------------------------------------------------------------------- /man/CreateScreePlot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/CreateScreePlot.R 3 | \name{CreateScreePlot} 4 | \alias{CreateScreePlot} 5 | \title{Create the scree plot for the fitted eigenvalues} 6 | \usage{ 7 | CreateScreePlot(fpcaObj, ...) 8 | } 9 | \arguments{ 10 | \item{fpcaObj}{A object of class FPCA returned by the function FPCA().} 11 | 12 | \item{...}{Additional arguments for the 'plot' function.} 13 | } 14 | \description{ 15 | This function will open a new device if not instructed otherwise. 16 | } 17 | \examples{ 18 | set.seed(1) 19 | n <- 20 20 | pts <- seq(0, 1, by=0.05) 21 | sampWiener <- Wiener(n, pts) 22 | sampWiener <- Sparsify(sampWiener, pts, 10) 23 | res <- FPCA(sampWiener$Ly, sampWiener$Lt, 24 | list(dataType='Sparse', error=FALSE, kernel='epan', verbose=TRUE)) 25 | CreateScreePlot(res) 26 | } 27 | -------------------------------------------------------------------------------- /R/CompFntCent.R: -------------------------------------------------------------------------------- 1 | ##### 2 | ##### centering component functions by using the marginal mean 3 | ##### 4 | 5 | ##### input variables: 6 | ##### f: evaluated values of component functions at estimation grid (N*d matrix) 7 | ##### j: index of centering for the j-th component function (scalar) 8 | ##### x: estimation grid (N*d matrix) 9 | ##### MgnJntDensity: evaluated values of marginal and 2-dim. joint densities (2-dim. list, referred to the output of 'MgnJntDensity') 10 | 11 | ##### output: 12 | ##### NW marginal regression function kernel estimators at estimation grid (N*d matrix) 13 | 14 | 15 | # centering 16 | CompFntCent <- function(f,j,x,MgnJntDens){ 17 | 18 | fj <- f[,j] 19 | xj <- x[,j] 20 | 21 | pMatMgn <- MgnJntDens$pMatMgn 22 | 23 | tmp1 <- pMatMgn[,j] 24 | tmp <- fj-trapzRcpp(sort(xj),(fj*tmp1)[order(xj)]) 25 | 26 | return(tmp) 27 | 28 | } 29 | 30 | -------------------------------------------------------------------------------- /tests/testthat_slow.R: -------------------------------------------------------------------------------- 1 | # # Based on https://github.com/hadley/testthat#integration-with-r-cmd-check 2 | 3 | # Splitting test files into multiple ones so that each one runs within 10 mins, 4 | # which is the limit on travis CI. 5 | # This file contains the slow running tests. 6 | 7 | library(testthat) 8 | library(fdapace) 9 | 10 | if (Sys.getenv('TRAVIS') != 'true') { 11 | test_check("fdapace", filter='FClust', perl=TRUE) # 12 | test_check("fdapace", filter='FSVD', perl=TRUE) # over 10 min 13 | test_check("fdapace", filter='FPCA', perl=TRUE) # over 10 min 14 | test_check("fdapace", filter='FVPA', perl=TRUE) # over 10 min 15 | test_check("fdapace", filter='FCReg', perl=TRUE) # over 10 min 16 | test_check("fdapace", filter='FOptDes', perl=TRUE) # 17 | test_check("fdapace", filter='GetCrCovYX', perl=TRUE) # over 10 min 18 | test_check("fdapace", filter='selectK', perl=TRUE) # 19 | test_check("fdapace", filter='WFDA', perl=TRUE) # 20 | } 21 | -------------------------------------------------------------------------------- /man/CreateBasis.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/CreateBasis.R 3 | \name{CreateBasis} 4 | \alias{CreateBasis} 5 | \title{Create an orthogonal basis of K functions in [0, 1], with nGrid points.} 6 | \usage{ 7 | CreateBasis( 8 | K, 9 | pts = seq(0, 1, length.out = 50), 10 | type = c("cos", "sin", "fourier", "legendre01", "poly") 11 | ) 12 | } 13 | \arguments{ 14 | \item{K}{A positive integer specifying the number of eigenfunctions to generate.} 15 | 16 | \item{pts}{A vector specifying the time points to evaluate the basis functions.} 17 | 18 | \item{type}{A string for the type of orthogonal basis.} 19 | } 20 | \value{ 21 | A K by nGrid matrix, each column containing an basis function. 22 | } 23 | \description{ 24 | Create an orthogonal basis of K functions in [0, 1], with nGrid points. 25 | } 26 | \examples{ 27 | basis <- CreateBasis(3, type='fourier') 28 | head(basis) 29 | 30 | } 31 | -------------------------------------------------------------------------------- /R/print.FPCA.R: -------------------------------------------------------------------------------- 1 | #' Print an FPCA object 2 | #' 3 | #' Print a simple description of an FPCA object 4 | #' 5 | #' @param x An FPCA object. 6 | #' @param ... Not used. 7 | #' 8 | #' @examples 9 | #' \donttest{ 10 | #' set.seed(1) 11 | #' n <- 20 12 | #' pts <- seq(0, 1, by=0.05) 13 | #' sampWiener <- Wiener(n, pts) 14 | #' sampWiener <- Sparsify(sampWiener, pts, 10) 15 | #' res <- FPCA(sampWiener$Ly, sampWiener$Lt) 16 | #' res 17 | #' } 18 | #' 19 | #' @method print FPCA 20 | #' @export 21 | print.FPCA <- function(x, ...){ 22 | obj = x; 23 | cat(paste0("Functional Principal Components Object for ", tolower(obj$optns$dataType), " data.\n\n")) 24 | cat(paste0("The optimal number of components selected is: ", length(obj$lambda), ", and \nthe first K (<=3) eigenvalues are: ")) 25 | if ( length(obj$lambda) < 4) { 26 | cat(paste0( round(obj$lambda,3) ,"\n")) 27 | } else { 28 | cat(paste0( round(obj$lambda[1:3],3) ,"\n")) 29 | } 30 | } 31 | 32 | 33 | 34 | -------------------------------------------------------------------------------- /R/NormCurveToArea.R: -------------------------------------------------------------------------------- 1 | #' Normalize a curve to a particular area, by multiplication with a factor 2 | #' 3 | #' Normalize a curve such that its integration over the design time-points equals a particular value (according to trapezoid integration). 4 | #' 5 | #' @param y values of curve at time-points \code{x} 6 | #' @param x design time-points (default: \code{seq(0,1, length.out=length(y))}) 7 | #' @param area value to normalize the curve onto (default: 1) 8 | #' 9 | #' @return values of curve at times \code{x} such that its integration over \code{x} equals \code{area}. 10 | #' @export 11 | 12 | NormCurvToArea <- function(y, x = seq(0, 1, length.out = length(y)), area = 1){ 13 | 14 | if( length(x) != length(y)){ 15 | stop("'x' and 'y' must have the same length.") 16 | } 17 | if( length(y) < 2 ){ 18 | stop("No area is defined for a single measurement.") 19 | } 20 | yNew = area * y / trapzRcpp(X = x, Y = y); 21 | return(yNew) 22 | } 23 | 24 | -------------------------------------------------------------------------------- /man/Wiener.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Wiener.R 3 | \name{Wiener} 4 | \alias{Wiener} 5 | \title{Simulate a standard Wiener processes (Brownian motions)} 6 | \usage{ 7 | Wiener(n = 1, pts = seq(0, 1, length = 50), sparsify = NULL, K = 50) 8 | } 9 | \arguments{ 10 | \item{n}{Sample size.} 11 | 12 | \item{pts}{A vector of points in [0, 1] specifying the support of the processes.} 13 | 14 | \item{sparsify}{A vector of integers. The number of observations per curve will be uniform distribution on sparsify.} 15 | 16 | \item{K}{The number of components.} 17 | } 18 | \value{ 19 | If \code{sparsify} is not specified, a matrix with \code{n} rows corresponding to the samples are returned. Otherwise the sparsified sample is returned. 20 | } 21 | \description{ 22 | Simulate \code{n} standard Wiener processes on [0, 1], possibly 23 | sparsifying the results. 24 | } 25 | \details{ 26 | The algorithm is based on the Karhunen-Loève expansion of the Wiener process 27 | } 28 | \seealso{ 29 | Sparsify 30 | } 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | PACE package for Functional Data Analysis and Empirical Dynamics 3 | ==== 4 | 5 | [![Build Status](https://app.travis-ci.com/functionaldata/tPACE.svg?branch=master)](https://app.travis-ci.com/functionaldata/tPACE) 6 | [![cran version](https://CRAN.R-project.org/package=fdapace)](https://CRAN.R-project.org/package=fdapace) 7 | [![downloads](https://cranlogs.r-pkg.org:443/badges/fdapace)](https://cranlogs.r-pkg.org:443/badges/fdapace) 8 | [![total downloads](https://cranlogs.r-pkg.org:443/badges/grand-total/fdapace)](https://cranlogs.r-pkg.org:443/badges/grand-total/fdapace) 9 | 10 | ## Installation of the current development version 11 | You can install the development version of the package in R using: 12 | ``` 13 | devtools::install_github("functionaldata/tPACE") 14 | ``` 15 | 16 | ## Installation of the latest CRAN release 17 | You can install the package in R using: 18 | ``` 19 | install.packages("fdapace") 20 | ``` 21 | 22 | ## Load Package and Data 23 | Once installed you can load the package with: 24 | ``` 25 | library(fdapace) 26 | ``` 27 | -------------------------------------------------------------------------------- /R/GetRawCrCovFuncScal.R: -------------------------------------------------------------------------------- 1 | GetRawCrCovFuncScal <- function(Ly, Lt = NULL, Ymu, Z, Zmu ){ 2 | # Sparse case if Ly and Lt are both lists 3 | if( is.list(Ly) && is.list(Lt) ){ 4 | ulLt = unlist(Lt) 5 | if (length(Ymu) != length(unique(ulLt))){ 6 | stop("Ymu and Lt are of the same size.") 7 | } else { 8 | zstar = Z - Zmu; 9 | RCC <- list(tpairn = ulLt, 10 | rawCCov = rep(zstar, times = unlist( lapply(Ly, length))) * 11 | (unlist(Ly) - approx(x= sort(unique(ulLt)), y = Ymu, xout = ulLt)$y ) ) 12 | return(RCC) 13 | } 14 | # Dense case if Ly is a matrix and Lt is empty 15 | } else if ( is.matrix(Ly) && is.null(Lt)) { 16 | if( length(Z) != dim(Ly)[1] ) { 17 | stop("Ly and Z are not compatible (possibly different number of subjects).") 18 | } 19 | RCC <- list( tpairn = NULL, 20 | rawCCov = cov( Ly, Z, use="pairwise.complete.obs" )) 21 | } else { 22 | stop("It appears you do no refine a valid cross-covariance type.") 23 | } 24 | } 25 | 26 | -------------------------------------------------------------------------------- /R/print.FSVD.R: -------------------------------------------------------------------------------- 1 | #' Print an FSVD object 2 | #' 3 | #' Print a simple description of an FSVD object 4 | #' 5 | #' @param x An FSVD object. 6 | #' @param ... Not used. 7 | #' 8 | #' @method print FSVD 9 | #' @export 10 | print.FSVD <- function(x, ...){ 11 | obj = x; 12 | thisDataType <- NULL 13 | if(obj$optns$SVDopts$dataType1 == 'Dense' && obj$optns$SVDopts$dataType2 == 'Dense'){ 14 | thisDataType <- 'Dense' 15 | } else { 16 | thisDataType <- 'Sparse' 17 | } 18 | if(obj$optns$SVDopts$dataType1 == 'DenseWithMV' && obj$optns$SVDopts$dataType2 == 'DenseWithMV'){ 19 | thisDataType <- 'DenseWithMV' 20 | } 21 | 22 | cat(paste0("Functional Singular Value Decomposition object for ", tolower(thisDataType), " data.\n\n")) 23 | cat(paste0("The optimal number of components selected is: ", length(obj$sValues)," and \nthe first K (<=3) singular values are: ")) 24 | if ( length(obj$sValues) < 4) { 25 | cat(paste0( round(obj$sValues,3) ,"\n")) 26 | } else { 27 | cat(paste0(round(obj$sValues[1:3],3) ,"\n")) 28 | } 29 | } 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /R/Minb.R: -------------------------------------------------------------------------------- 1 | # This function is used to find the minimum bandwidth choice 2 | # where the local window contains at least "numPoints" points 3 | # Input x : n x 1 vector 4 | # Input numPoints: an integer specifying the number of points in a local window 5 | # for local weighted constant, numPoints is at least 1 6 | # for local weighted linear, numPoints is at least 2 7 | # Output b: the minimum bandwidth choice for vector x 8 | 9 | Minb <- function(x, numPoints){ 10 | 11 | n = length(x); 12 | if( (numPoints<1) || (numPoints > n) ){ 13 | warning("Invalid number of minimum points specified\n") 14 | return(NaN) 15 | } 16 | 17 | if('legacyCode' == TRUE){ 18 | x = sort(unique(x)); # Unique is added to ensure that we do not have a degenerate design 19 | if(numPoints > 1){ 20 | return( max(x[numPoints:n]-x[1:(n-numPoints+1)]) ) 21 | }else{ 22 | return( max( (x[2:n]-x[1:(n-1)])/2) ) 23 | } 24 | } 25 | 26 | gridPts <- sort(unique(x)) 27 | distNN1 <- max(diff(gridPts, lag=numPoints)) 28 | 29 | return(distNN1) 30 | } 31 | -------------------------------------------------------------------------------- /tests/testthat/test_BinRawCov.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | library(testthat) 3 | 4 | # GMeanAndGCV 5 | 6 | set.seed(1) 7 | pts <- c(0, 1, 3:100) / 100 8 | regGrid <- seq(0, 1, by=0.1) 9 | samp3 <- Wiener(200, pts, sparsify=2:7) 10 | p0 <- SetOptions(samp3$Ly, samp3$Lt, optns=list(dataType='Sparse', error=TRUE, kernel='epan')) 11 | mu3 <- rep(0, length(pts)) 12 | rcov3 <- GetRawCov(samp3$Ly, samp3$Lt, pts, mu3, p0$dataType, error=p0$error) 13 | 14 | brcov3 <- BinRawCov(rcov3) 15 | 16 | test_that('BinRawCov works', { 17 | tPairs <- matrix(c(1, 1, 2, 1, 2, 1, 2, 2, 1, 2, 1, 2, 1, 2), ncol=2, byrow=TRUE) 18 | rcov <- list(tPairs=tPairs, cxxn=1:nrow(tPairs), error=FALSE) 19 | brcov <- BinRawCov(rcov) 20 | expect_equal(brcov$tPairs, matrix(c(1, 1, 2, 1, 1, 2, 2, 2), ncol=2, byrow=TRUE)) 21 | expect_equal(brcov$meanVals, c(1, 2.5, 6, 4)) 22 | 23 | rcov <- list(tPairs=tPairs, cxxn=1:nrow(tPairs), error=TRUE) 24 | brcov <- BinRawCov(rcov) 25 | expect_equal(brcov$tPairs, matrix(c(1, 1, 2, 1, 1, 2, 2, 2), ncol=2, byrow=TRUE)) 26 | expect_equal(brcov$meanVals, c(1, 2.5, 6, 4)) 27 | }) -------------------------------------------------------------------------------- /R/GenerateFunctionalData.R: -------------------------------------------------------------------------------- 1 | GenerateFunctionalData <-function(N, M, mu=NULL, lambda=NULL, k = 2, basisType='cos'){ 2 | 3 | if(N <2){ 4 | stop("Sampes of size 1 are irrelevant.") 5 | } 6 | if(M <20){ 7 | stop("Dense samples with less than 20 observations per subject are irrelevant.") 8 | } 9 | s <- seq(0,1,length.out = M) 10 | if(is.null(mu)){ 11 | mu = rep(0,M); 12 | } 13 | if(length(mu) != M){ 14 | stop("Make sure that 'M' and the number of points over which 'mu' is evaluated is the same.") 15 | } 16 | if(is.null(lambda)){ 17 | lambda = seq(k,1,-1) 18 | } 19 | if(k != length(lambda)){ 20 | stop("Make sure you provide 'lambda's for all 'k' modes of variation.") 21 | } 22 | if( !(basisType %in% c('cos','sin','fourier'))){ 23 | stop("Make sure you provide a valid parametric basis.") 24 | } 25 | 26 | Ksi <- apply(matrix(rnorm(N*k), ncol=k), 2, scale) %*% diag(lambda, k) 27 | Phi <- CreateBasis(pts= s, type= basisType, K = k) 28 | 29 | yTrue <- t(matrix(rep(mu,N), nrow=M)) + Ksi %*% t(Phi) 30 | return(list(Y = yTrue, Phi = Phi) ) 31 | } 32 | 33 | -------------------------------------------------------------------------------- /tests/testthat/test_CheckData.R: -------------------------------------------------------------------------------- 1 | cat("\nTests for 'CheckData'") 2 | 3 | test_that("basic valid lists arguments do not return any errors ", { 4 | CheckData(y = list(c(1,2,3), c(1,2)), t = list(c(1,2,3), c(1,2))) 5 | CheckData(t = list(c(1,2,3), c(1,2)), y = list(runif(3), runif(2))) 6 | }) 7 | 8 | 9 | test_that("basic invalid nolists arguments do return errors ", { 10 | # expect_equal(CheckData( runif(4), list(c(1,2,NA), c(1,2)) ), TRUE) # We handle NA now 11 | # expect_equal(CheckData( list(c(1,2,3), c(1,NA)), runif(3) ), TRUE) # We handle NA now 12 | expect_error(CheckData( matrix(1:6,2,3), list(c(1,2,3), c(1,2)) ), 'y should be list') 13 | expect_error(CheckData( list(c(1,2,3), c(1,2)), matrix(1:6,2,3) ), 't should be list') 14 | }) 15 | 16 | 17 | test_that("basic checks where input data has an additional arbitray value works (issue #9) ", { 18 | data(medfly25) 19 | Flies1 <- MakeFPCAInputs(medfly25$ID, medfly25$Days, medfly25$nEggs) 20 | class(Flies1$Ly[[1]]) <- append(Flies1$Ly[[1]], "some") 21 | expect_s3_class(FPCA(Ly= Flies1$Ly[1:100], Lt= Flies1$Lt[1:100] ), 'FPCA') 22 | }) 23 | 24 | -------------------------------------------------------------------------------- /tests/testthat/test_GetNormalisedSample.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | 3 | test_that('GetNormalisedSample output a homoscadestic sample', { 4 | set.seed(1) 5 | n <- 100 6 | M <- 51 7 | pts <- seq(0, 1, length.out=M) 8 | mu <- rep(0, length(pts)) 9 | sampDense <- MakeGPFunctionalData(n, M, mu, K=1, basisType='sin', sigma=0.01) 10 | samp4 <- MakeFPCAInputs(tVec=sampDense$pts, yVec=sampDense$Yn) 11 | res4E <- FPCA(samp4$Ly, samp4$Lt, list(error=TRUE)) 12 | sampN <- GetNormalisedSample(res4E, errorSigma=TRUE) 13 | sampN0 <- GetNormalisedSample(res4E, errorSigma=FALSE) 14 | 15 | # Cross-sectional standard deviation 16 | sdCr <- apply(simplify2array(sampN$Ly), 1, sd) 17 | sdCr0 <- apply(simplify2array(sampN0$Ly), 1, sd) 18 | expect_equal(sdCr[-c(1:2, (M-1):M)], rep(1, M - 4), tolerance=1e-4) 19 | expect_equal(sdCr0[-c(1:2, (M-1):M)], rep(1, M - 4), tolerance=1e-3) 20 | 21 | # CreatePathPlot(subset=1:20, inputData=samp4, obsOnly=TRUE, showObs=FALSE) 22 | # CreatePathPlot(subset=1:20, inputData=sampN, obsOnly=TRUE, showObs=FALSE) 23 | # CreatePathPlot(subset=1:20, inputData=sampN0, obsOnly=TRUE, showObs=FALSE) 24 | }) 25 | -------------------------------------------------------------------------------- /man/Lwls1D.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Lwls1D.R 3 | \name{Lwls1D} 4 | \alias{Lwls1D} 5 | \title{One dimensional local linear kernel smoother} 6 | \usage{ 7 | Lwls1D( 8 | bw, 9 | kernel_type, 10 | win = rep(1L, length(xin)), 11 | xin, 12 | yin, 13 | xout, 14 | npoly = 1L, 15 | nder = 0L 16 | ) 17 | } 18 | \arguments{ 19 | \item{bw}{Scalar holding the bandwidth} 20 | 21 | \item{kernel_type}{Character holding the kernel type (see ?FPCA for supported kernels)} 22 | 23 | \item{win}{Vector of length N with weights} 24 | 25 | \item{xin}{Vector of length N with measurement points} 26 | 27 | \item{yin}{Vector of length N with measurement values} 28 | 29 | \item{xout}{Vector of length M with output measurement points} 30 | 31 | \item{npoly}{Scalar (integer) degree of polynomial fitted (default 1)} 32 | 33 | \item{nder}{Scalar (integer) degree of derivative fitted (default 0)} 34 | } 35 | \value{ 36 | Vector of length M with measurement values at the the point specified by 'xout' 37 | } 38 | \description{ 39 | One dimensional local linear kernel smoother for longitudinal data. 40 | } 41 | -------------------------------------------------------------------------------- /R/medfly25.R: -------------------------------------------------------------------------------- 1 | #' Number of eggs laid daily from medflies 2 | #' 3 | #' A dataset containing the eggs laid from 789 medflies (Mediterranean fruit flies, 4 | #' Ceratitis capitata) during the first 25 days of their lives. This is a subset of 5 | #' the dataset used by Carey at al. (1998); only flies that lived at least 25 days 6 | #' are included, i.e, at the end of the recording period [0,25] all flies are still alive. 7 | #' 8 | #' @name medfly25 9 | #' @docType data 10 | #' @format A data frame with 19725 rows and 3 variables: 11 | #' \describe{ 12 | #' \item{ID}{: Medfly ID according to the original dataset} 13 | #' \item{Days}{: Day of measurement} 14 | #' \item{nEggs}{: Number of eggs laid at that particular day} 15 | #' \item{nEggsRemain}{: Remaining total number of eggs laid} 16 | #' } 17 | #' @source \url{https://anson.ucdavis.edu/~mueller/data/medfly1000.html} 18 | #' @references 19 | #' {Carey, J.R., Liedo, P., Müller, H.G., Wang, J.L., Chiou, J.M. (1998). Relationship of age patterns of fecundity to mortality, longevity, and lifetime reproduction in a large cohort of Mediterranean fruit fly females. J. of Gerontology --Biological Sciences 53, 245-251. } 20 | NULL 21 | -------------------------------------------------------------------------------- /R/GetBinNum.R: -------------------------------------------------------------------------------- 1 | GetBinNum = function(n, m, dataType, verbose ){ 2 | 3 | # Get the number of bins 4 | # n : number of curves 5 | # m : median or max value of number of time-points 6 | # dataType : indicator about structure of the data 7 | # (dense (2), or dataType data with missing values (1) or sparse (0)) 8 | # verbose : outpit diagnostics/progress 9 | 10 | numBin = NULL; 11 | if (m <= 20){ 12 | if (dataType =='Sparse'){ 13 | str = 'Median of ni'; 14 | } else { 15 | str = 'Maximum of ni'; 16 | } 17 | if (verbose){ 18 | message(paste0(str, 'is no more than 20! No binning is performed!\n')) 19 | } 20 | return(NULL) 21 | } 22 | 23 | 24 | if (m >400){ 25 | numBin = 400; 26 | } 27 | 28 | if (n > 5000){ 29 | mstar = max(20,(((5000-n)*19)/2250)+400); 30 | if (mstar < m){ 31 | numBin = ceiling(mstar); 32 | } else { 33 | if (verbose){ 34 | message('No binning is needed!\n'); 35 | } 36 | return(NULL) 37 | } 38 | } 39 | 40 | if( verbose && is.null(numBin) ) { 41 | message('No binning is needed!\n'); 42 | } 43 | 44 | return(numBin) 45 | } 46 | -------------------------------------------------------------------------------- /man/ConvertSupport.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ConvertSupport.R 3 | \name{ConvertSupport} 4 | \alias{ConvertSupport} 5 | \title{Convert support of a mu/phi/cov etc. to and from obsGrid and workGrid} 6 | \usage{ 7 | ConvertSupport( 8 | fromGrid, 9 | toGrid, 10 | mu = NULL, 11 | Cov = NULL, 12 | phi = NULL, 13 | isCrossCov = FALSE 14 | ) 15 | } 16 | \arguments{ 17 | \item{fromGrid}{vector of points with input grid to interpolate from} 18 | 19 | \item{toGrid}{vector of points with the target grid to interpolate on} 20 | 21 | \item{mu}{any vector of function to be interpolated} 22 | 23 | \item{Cov}{a square matrix supported on fromGrid * fromGrid, to be interpolated to toGrid * toGrid.} 24 | 25 | \item{phi}{any matrix, each column containing a function to be interpolated} 26 | 27 | \item{isCrossCov}{logical, indicating whether the input covariance is a cross-covariance. If so then the output is not made symmetric.} 28 | } 29 | \description{ 30 | Convert the support of a given function 1-D or 2-D function from \code{fromGrid} to \code{toGrid}. 31 | Both grids need to be sorted. This is an interpolation/convenience function. 32 | } 33 | -------------------------------------------------------------------------------- /tests/testthat/test_GetBinnedCurve.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | library(testthat) 3 | 4 | test_that('GetBinnedCurve() works on trivial examples', { 5 | x = 1:100 6 | y = 2*x 7 | A = GetBinnedCurve(x,y,M=50) 8 | expect_equal( sum(diff(A$midpoint) ) , diff(range(x)) ) 9 | expect_equal( sd(A$newy), sd(y), tolerance=0.05) 10 | B = GetBinnedCurve(x,y,M=33) 11 | expect_equal( sum(diff(B$midpoint) ) , diff(range(x))) 12 | expect_equal( sd(B$newy), sd(y), tolerance=0.05) 13 | }) 14 | 15 | test_that('GetBinnedCurve() works on a nearly trivial example', { 16 | x = seq(0,4, length.out=100) 17 | y = x + sin(x); 18 | A = GetBinnedCurve(x,y, 32, TRUE, TRUE, c(1,2.5)) 19 | expect_equal( sum(diff(A$midpoint) ), 1.5, tolerance=0.05 ) 20 | expect_equal( sd(A$newy), 0.38, tolerance=0.05) 21 | }) 22 | 23 | test_that('GetBinnedCurve() works for large case',{ 24 | x <- 1:2000 25 | y <- 2 * x 26 | A = GetBinnedCurve(x, y, 400, TRUE, TRUE, c(1, 1999)) 27 | expect_equal( A$binWidth, 4.995 ) 28 | expect_lte( sd(A$count), 0.2) 29 | expect_equal( sd(A$newy), sd(y), tolerance=0.03) 30 | expect_equal( sd(A$midpoint), sd(x), tolerance=0.03) 31 | }) 32 | 33 | 34 | 35 | 36 | 37 | 38 | -------------------------------------------------------------------------------- /tests/testthat/test_GetBinnedDataset.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | library(testthat) 3 | 4 | test_that('GetBinnedDataset() works on trivial examples', { 5 | 6 | y = list( c(1:1000), c(3:1012)) 7 | t = list( seq(0,1,length.out=1000), seq(0,1,length.out=1010)) 8 | A = GetBinnedDataset(y,t, optns=SetOptions(y,t,NULL)) 9 | 10 | expect_equal( length(A$newt[[2]]), 400) 11 | expect_equal( A$newt[[2]][113] , 0.2807, tolerance=0.01, scale=1) 12 | expect_equal( mean( A$newt[[1]]), mean( A$newt[[2]]) ) 13 | expect_equal( A$newy[[1]][313] , 782, tolerance=0.01, scale=1) 14 | expect_equal( mean( A$newy[[1]]), 5.005000000000000e+02 ) 15 | 16 | }) 17 | 18 | test_that('GetBinnedDataset() works on binned examples, with the first individual being singleton', { 19 | 20 | y = list(1, seq(0, 1000, length.out=1000), seq(3, 1012, length.out=1010)) 21 | t = list(0.5, seq(0,1,length.out=1000), seq(0,1,length.out=1010)) 22 | A = GetBinnedDataset(y,t, optns=SetOptions(y,t, list(numBins=20))) 23 | 24 | expect_equal( length(A$newt[[3]]), 20) 25 | expect_true(abs(A$newt[[2]][10] - A$newy[[2]][10] / 1000) < 1e-3) 26 | expect_equal( mean( A$newt[[3]]), mean( A$newt[[2]]) ) 27 | 28 | }) 29 | -------------------------------------------------------------------------------- /R/ScaleKernel.R: -------------------------------------------------------------------------------- 1 | ##### 2 | ##### scaling of compactly supported kernel 3 | ##### 4 | 5 | ##### input variables 6 | ##### x: estimation points (N-dim. vector) 7 | ##### X: covariate observation points (n-dim. vector) 8 | ##### h: bandwidth (scalar) 9 | ##### K: kernel function (function object, default is the Epanechnikov kernel) 10 | ##### supp: support of stimation interested (2-dim. vector, default is a closed interval [0,1]) 11 | 12 | ##### output variable: 13 | ##### evaluated values of scaled kernel at estimation points near observation points (N by n matrix) 14 | 15 | 16 | ### scaled kernel 17 | ScaleKernel <- function(x, X, h=NULL, K='epan',supp=NULL){ 18 | 19 | N <- length(x) 20 | n <- length(X) 21 | 22 | if (K!='epan') { 23 | message('Epanechnikov kernel is only supported currently. It uses Epanechnikov kernel automatically') 24 | } 25 | if (is.null(supp)==TRUE) { 26 | supp <- c(0,1) 27 | } 28 | if (is.null(h)==TRUE) { 29 | h <- 0.25*n^(-1/5)*(supp[2]-supp[1]) 30 | } 31 | 32 | xTmp <- matrix(rep(x,n),nrow=N) 33 | XTmp <- matrix(rep(X,N),ncol=n,byrow=TRUE) 34 | 35 | Tmp <- xTmp-XTmp 36 | 37 | KhTmp <- (3/4)*(1-(Tmp/h)^2)*dunif(Tmp/h,-1,1)*2/h 38 | 39 | return(KhTmp) 40 | } -------------------------------------------------------------------------------- /R/GetMeanDense.R: -------------------------------------------------------------------------------- 1 | # This function obtains the cross sectional mean function at observed grid 2 | # for dense regular functional data 3 | 4 | ###### 5 | # Input: 6 | ###### 7 | # ymat: matrix of dense regular functional data 8 | # optns: options for FPCA function 9 | ###### 10 | # Output: 11 | ###### 12 | # a SMC object containing: 13 | # - mu: p-dim vector of mean function estimation, i.e. on observed grid 14 | # - NULL for other entries 15 | ########################################################################## 16 | 17 | GetMeanDense <- function(ymat, obsGrid, optns){ 18 | # Check optns 19 | if(!(optns$dataType %in% c('Dense', 'DenseWithMV'))){ 20 | stop('Cross sectional mean is only applicable for option: dataType = "Dense" or "DenseWithMV"!') 21 | } 22 | 23 | if ( is.null(optns$userMu) ){ 24 | mu = colMeans(ymat, na.rm = TRUE) # use non-missing data only 25 | } else { 26 | mu = spline(optns$userMu$t, optns$userMu$mu, xout= obsGrid)$y; 27 | } 28 | 29 | if(any(is.na(mu))){ 30 | stop('The cross sectional mean appears to have NaN! Consider setting your dataType to \'Sparse\' manually') 31 | } 32 | 33 | ret = list('mu' = mu, 'muDense' = NULL, 'mu_bw' = NULL) 34 | class(ret) = "SMC" 35 | return(ret) 36 | } 37 | -------------------------------------------------------------------------------- /src/trapzRcpp.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include // to get NaN 3 | using namespace Rcpp; 4 | 5 | template bool is_sorted (iter begin, iter end) 6 | { 7 | if (begin==end) return true; 8 | iter next = begin; 9 | while (++next!=end) { 10 | if (*next<*begin) 11 | return false; 12 | ++begin; 13 | } 14 | return true; 15 | } 16 | 17 | //' Trapezoid Rule Numerical Integration 18 | //' 19 | //' Trapezoid Rule Numerical Integration using Rcpp 20 | //' @param X Sorted vector of X values 21 | //' @param Y Vector of Y values. 22 | //' @export 23 | // [[Rcpp::export]] 24 | double trapzRcpp(const Rcpp::NumericVector X, const Rcpp::NumericVector Y){ 25 | 26 | if( Y.size() != X.size()){ 27 | Rcpp::stop("The input Y-grid does not have the same number of points as input X-grid."); 28 | } 29 | if(is_sorted(X.begin(),X.end())){ 30 | double trapzsum = 0; 31 | for (unsigned int ind = 0; ind != X.size()-1; ++ind){ 32 | trapzsum += 0.5 * (X[ind + 1] - X[ind]) *(Y[ind] + Y[ind + 1]); 33 | } 34 | return trapzsum; 35 | } else { 36 | Rcpp::stop("The input X-grid is not sorted."); 37 | return std::numeric_limits::quiet_NaN(); 38 | } 39 | return std::numeric_limits::quiet_NaN(); 40 | } 41 | -------------------------------------------------------------------------------- /tests/testthat/test_getMinb.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | library(testthat) 3 | load(system.file('testdata', 'dataForGcvLwlsTest.RData', package='fdapace')) 4 | # rcov <- GetRawCov(y,t, sort(unlist(t)), mu,'Sparse',FALSE) #Matches ML output 5 | test_that('2D min bandwidth is similar to Matlab', { 6 | # expect_equal(GetMinb(rcov, sort(unique(unlist(t)))), 4.1427, tolerance=diff(range(unlist(t))) / 1000) 7 | 8 | # We break strict compatibility with MATLAB when we used quantile( diff(b[ids]), 0.95)/2 instead of max(diff(b[ids])/2) 9 | # expect_equal(GetMinb(t, sort(unique(unlist(t)))), 4.1427, tolerance=diff(range(unlist(t))) / 1000) 10 | 11 | expect_equal( GetMinb(legacyCode = TRUE,t, sort(unique(unlist(t)))), 4.1427, tolerance= 4.1427 * 0.0175) 12 | expect_equal( as.numeric(GetMinb(t, sort(unique(unlist(t))))), 4.1427, tolerance= 4.1427 * 0.0195 ) 13 | }) 14 | 15 | test_that('2D min bandwidth for binned and unbinned rcov is the same', { 16 | # expect_equal(GetMinb(BinRawCov(rcov), sort(unique(unlist(t)))), GetMinb(rcov, sort(unique(unlist(t))))) 17 | }) 18 | 19 | 20 | set.seed(1) 21 | pts <- seq(0, 1, length=10) 22 | samp2 <- Wiener(100, pts, sparsify=2:5) 23 | rcov2 <- GetRawCov(samp2$Ly, samp2$Lt, pts, rep(0, length(pts)), 'Sparse', FALSE) 24 | GetMinb(samp2$Lt, pts) 25 | -------------------------------------------------------------------------------- /man/medfly25.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/medfly25.R 3 | \docType{data} 4 | \name{medfly25} 5 | \alias{medfly25} 6 | \title{Number of eggs laid daily from medflies} 7 | \format{ 8 | A data frame with 19725 rows and 3 variables: 9 | \describe{ 10 | \item{ID}{: Medfly ID according to the original dataset} 11 | \item{Days}{: Day of measurement} 12 | \item{nEggs}{: Number of eggs laid at that particular day} 13 | \item{nEggsRemain}{: Remaining total number of eggs laid} 14 | } 15 | } 16 | \source{ 17 | \url{https://anson.ucdavis.edu/~mueller/data/medfly1000.html} 18 | } 19 | \description{ 20 | A dataset containing the eggs laid from 789 medflies (Mediterranean fruit flies, 21 | Ceratitis capitata) during the first 25 days of their lives. This is a subset of 22 | the dataset used by Carey at al. (1998); only flies that lived at least 25 days 23 | are included, i.e, at the end of the recording period [0,25] all flies are still alive. 24 | } 25 | \references{ 26 | {Carey, J.R., Liedo, P., Müller, H.G., Wang, J.L., Chiou, J.M. (1998). Relationship of age patterns of fecundity to mortality, longevity, and lifetime reproduction in a large cohort of Mediterranean fruit fly females. J. of Gerontology --Biological Sciences 53, 245-251. } 27 | } 28 | -------------------------------------------------------------------------------- /R/MapX1D.R: -------------------------------------------------------------------------------- 1 | # Map (x,y) to (newx,newy) 2 | # x : a vector of 1 * n 3 | # y : a vector of 1 * n or a n * p matrix 4 | # newx : vector of 1 * m 5 | # newy : vector of 1 * m or a matrix of m * optns$ 6 | 7 | # if( is.vector(y) ){ 8 | # return(y[is.element(x,newx)]) 9 | # }else if(is.matrix(y)){ 10 | # return(y[is.element(x,newx),]) 11 | # }else{ 12 | # warning('y cannot be empty!\n') 13 | # return(NaN) 14 | # } 15 | # } 16 | 17 | MapX1D <- function(x, y, newx) { 18 | # if (!all(newx %in% x)) 19 | # warning('Interpolation occured: you might want to increase the obsGrid coverage') 20 | 21 | # if (min(newx) + 100 * .Machine$double.eps < min(x) || max(newx) > max(x) + 100 * .Machine$double.eps) 22 | # warning('Extrapolation occured') 23 | if (is.vector(y)){ 24 | # newy <- approxExtrap(x, y, newx, method='linear')$y 25 | newy <- approx(x, y, newx, method='linear')$y 26 | } else { 27 | # newy <- apply(y, 2, function(yy) approxExtrap(x, yy, newx, method='linear')$y) 28 | newy <- apply(y, 2, function(yy) approx(x, yy, newx, method='linear')$y) 29 | } 30 | if (any(is.nan(newy))){ 31 | stop('NA \'s during the mapping from(x,y) to (newx,newy)') 32 | } 33 | 34 | return(newy) 35 | } 36 | -------------------------------------------------------------------------------- /tests/testthat/test_FCCor.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | # devtools::load_all('.') 3 | 4 | test_that('FCCor works', { 5 | set.seed(4) 6 | 7 | n <- 200 8 | nGridIn <- 50 9 | sparsity <- 1:5 # must have length > 1 10 | bw <- 0.1 11 | kern <- 'epan' 12 | T <- matrix(seq(0.5, 1, length.out=nGridIn)) 13 | 14 | ## Corr(X(t), Y(t)) = 1/2 15 | A <- Wiener(n, T) 16 | B <- Wiener(n, T) 17 | C <- Wiener(n, T) + matrix((1:nGridIn) , n, nGridIn, byrow=TRUE) 18 | X <- A + B 19 | Y <- A + C 20 | indEach <- lapply(1:n, function(x) sort(sample(nGridIn, sample(sparsity, 1)))) 21 | tAll <- lapply(1:n, function(i) T[indEach[[i]]]) 22 | Xsp <- lapply(1:n, function(i) X[i, indEach[[i]]]) 23 | Ysp <- lapply(1:n, function(i) Y[i, indEach[[i]]]) 24 | 25 | expect_equal(sapply(Xsp, length), sapply(Ysp, length)) 26 | expect_equal(sapply(Xsp, length), sapply(tAll, length)) 27 | 28 | # Perfect correlation case 29 | expect_equal(mean(FCCor(Xsp, Xsp, tAll, bw)[['corr']], na.rm=TRUE), 1) 30 | 31 | # Consistency 32 | expect_true(mean((FCCor(Xsp, Ysp, tAll, bw, kern)[['corr']] - 0.5)^2, na.rm=TRUE) < 1e-2) 33 | 34 | # Gauss and epan kernels are similar 35 | expect_equal(FCCor(Xsp, Ysp, tAll, bw, 'epan')[['corr']], FCCor(Xsp, Ysp, tAll, bw, 'gauss')[['corr']], 0.1) 36 | }) 37 | 38 | 39 | -------------------------------------------------------------------------------- /R/BestDes_SR.R: -------------------------------------------------------------------------------- 1 | # Find optimal designs for scalar response prediction 2 | BestDes_SR <- function(p, ridge, workGrid, Cov, CCov, isSequential=FALSE){ 3 | # select optimal designs for regression case, sequential method available 4 | if(isSequential == FALSE){ 5 | comblist <- utils::combn(1:length(workGrid), p) 6 | temps <- rep(0,ncol(comblist)) 7 | for(i in 1:ncol(comblist)){ temps[i] <- SRCri(comblist[,i], ridge, Cov, CCov) } 8 | best <- sort(comblist[,min(which(temps==max(temps)))]) 9 | return(list(best=best)) 10 | } else{ # sequential selection 11 | optdes <- c() 12 | for(iter in 1:p){ 13 | candidx <- which(!((1:length(workGrid)) %in% optdes)) 14 | seqcri <- rep(NA, length(candidx)) 15 | for(i in 1:length(candidx)){ 16 | tempdes <- sort(c(optdes,candidx[i])) 17 | seqcri[i] <- SRCri(tempdes, ridge, Cov, CCov) 18 | } 19 | optdes <- sort(c(optdes, candidx[min(which(seqcri == max(seqcri)))])) 20 | } 21 | return(list(best=optdes,med=NULL)) 22 | } 23 | } 24 | 25 | SRCri <- function(design,ridge,Cov,CCov){ 26 | # Optimization criterion for SR 27 | design <- sort(design) 28 | ridgeCov <- Cov + diag(ridge,nrow(Cov)) 29 | srcri <- t(CCov[design]) %*% solve(ridgeCov[design,design]) %*% CCov[design] 30 | return(srcri) 31 | } 32 | -------------------------------------------------------------------------------- /man/MakeFPCAInputs.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/MakeFPCAInputs.R 3 | \name{MakeFPCAInputs} 4 | \alias{MakeFPCAInputs} 5 | \title{Format FPCA input} 6 | \usage{ 7 | MakeFPCAInputs( 8 | IDs = NULL, 9 | tVec, 10 | yVec, 11 | na.rm = FALSE, 12 | sort = FALSE, 13 | deduplicate = FALSE 14 | ) 15 | } 16 | \arguments{ 17 | \item{IDs}{np-by-1 vector of subject IDs (Default: NULL)} 18 | 19 | \item{tVec}{Either an np-by-1 vector of measurement times, or a p-by-1 vector corresponding to the common time support} 20 | 21 | \item{yVec}{n-by-1 vector of measurements from the variable of interest, or a n-by-p matrix with each row corresponding to the dense observations.} 22 | 23 | \item{na.rm}{logical indicating if NA should be omitted (Default: FALSE)} 24 | 25 | \item{sort}{logical indicating if Lt (and the correspoding Ly values) should be ensured to be sorted (Default: FALSE)} 26 | 27 | \item{deduplicate}{logical indicating if the Lt should be ensured not to have within-subject duplicated values; the Ly values of repeated Lt values are averaged (Default: FALSE)} 28 | } 29 | \value{ 30 | L list containing 3 lists each of length 'm', 'm' being the number of unique subject IDs 31 | } 32 | \description{ 33 | Turn vector inputs to the list so they can be used in FPCA 34 | } 35 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | ## Resubmission 2 | This is a resubmission. In this version I have: 3 | * Removed the old FLM function 4 | * Updated FLM1 function and its documentation, which is now the FLM function 5 | * Added FLMCI function to construct confidence intervals for functional linear models 6 | * Changed @docType package to _PACKAGE in R/pkgname.R 7 | * Added title and legend to CreateModeOfVarPlot function 8 | * Updated figure titles in several plot functions (capitalize only the first word) 9 | 10 | 11 | ## Test environments 12 | * local R installation, macOS R 4.4.1 13 | * win-builder (devel and release) 14 | 15 | ## R CMD check results 16 | on macOS: 17 | 0 errors | 0 warnings | 0 notes 18 | 19 | on windows: 20 | 0 errors | 0 warnings | 0 notes 21 | 22 | ## Downstream dependencies 23 | I have run R CMD check on macOS on downstream dependencies of fdapace: fdaconcur, fdadensity,fdapaceShiny, fdaPOIFD, fdarep, fgm, frechet, ftsa, KFPCA, longke, longsurr, MJMbamlss, mrct, SLFPCA and WRI. 24 | 25 | All packages passed except fdaconcur, which produced an error due to the replacement of FLM1 with FLM. I have informed the maintainer of fdaconcur (we are in the same research group) about this change, and he will update the package to call `fdapace::FLM` in the next version. 26 | 27 | I have read and agree to all CRAN policies. 28 | -------------------------------------------------------------------------------- /src/cumtrapzRcpp.cpp: -------------------------------------------------------------------------------- 1 | 2 | #include 3 | using namespace Rcpp; 4 | 5 | template bool is_sorted (ForwardIterator first, ForwardIterator last) 6 | { 7 | if (first==last) return true; 8 | ForwardIterator next = first; 9 | while (++next!=last) { 10 | if (*next<*first) 11 | return false; 12 | ++first; 13 | } 14 | return true; 15 | } 16 | //' Cumulative Trapezoid Rule Numerical Integration 17 | //' 18 | //' Cumulative Trapezoid Rule Numerical Integration using Rcpp 19 | //' @param X Sorted vector of X values 20 | //' @param Y Vector of Y values. 21 | //' @export 22 | // [[Rcpp::export]] 23 | Rcpp::NumericVector cumtrapzRcpp(const Rcpp::NumericVector X,const Rcpp::NumericVector Y){ 24 | 25 | // Basic check 26 | if( Y.size() != X.size()){ 27 | Rcpp::stop("The input Y-grid does not have the same number of points as input X-grid."); 28 | } 29 | if(is_sorted(X.begin(),X.end())){ 30 | Rcpp::NumericVector ctrapzsum(X.size()); 31 | ctrapzsum[0] = 0.0; 32 | for (unsigned int ind = 0; ind != X.size()-1; ++ind){ 33 | ctrapzsum[ind+1] = 0.5 * (X[ind + 1] - X[ind]) *(Y[ind] + Y[ind + 1]) + ctrapzsum[ind]; 34 | } 35 | return ctrapzsum; 36 | } else { 37 | Rcpp::stop("The input X-grid is not sorted."); 38 | return 1; 39 | } 40 | } 41 | -------------------------------------------------------------------------------- /R/FitEigenValues.R: -------------------------------------------------------------------------------- 1 | FitEigenValues <- function(rcov, phiGrid, phi, noEig) { 2 | buff <- .Machine$double.eps * max(abs(phiGrid)) * 3 3 | 4 | if (is.null(noEig)) 5 | noEig <- ncol(phi) 6 | 7 | # Get design matrix X: 8 | X <- apply(phi[, 1:noEig], 2, function(y) 9 | approx(phiGrid, y, rcov$tPairs[, 1])$y * approx(phiGrid, y, rcov$tPairs[, 2])$y 10 | ) 11 | 12 | if (toString(class(rcov)) == 'RawCov') { 13 | dat <- cbind(y=rcov[['cxxn']], X) 14 | dat <- dat[rcov$tPairs[, 1] > min(phiGrid) - buff & 15 | rcov$tPairs[, 1] < max(phiGrid) + buff & 16 | rcov$tPairs[, 2] > min(phiGrid) - buff & 17 | rcov$tPairs[, 2] < max(phiGrid) + buff, ] 18 | mod <- lm(y ~ . - 1, data.frame(dat)) 19 | } else if (toString(class(rcov)) == 'BinnedRawCov') { 20 | dat <- cbind(y=rcov[['meanVals']], X) 21 | dat <- dat[rcov$tPairs[, 1] > min(phiGrid) - buff & 22 | rcov$tPairs[, 1] < max(phiGrid) + buff & 23 | rcov$tPairs[, 2] > min(phiGrid) - buff & 24 | rcov$tPairs[, 2] < max(phiGrid) + buff, ] 25 | mod <- lm(y ~ . - 1, data.frame(dat), weights=rcov[['count']]) 26 | } 27 | 28 | lam <- unname(mod[['coefficients']]) 29 | 30 | if (any(lam <= 0)) 31 | warning('Fit method produces negative estimates of eigenvalues') 32 | 33 | return(lam) 34 | } 35 | -------------------------------------------------------------------------------- /R/SetDerOptions.R: -------------------------------------------------------------------------------- 1 | SetDerOptions <- function(fpcaObject = NULL, derOptns = list()) { 2 | if (is.null(derOptns)) { 3 | derOptns <- list() 4 | } 5 | # These are relevant for fitted.FPCA 6 | derOptns$method <- ifelse (is.null(derOptns$method), 'FPC', 7 | derOptns$method) 8 | #derOptns$k <- ifelse (is.null(derOptns$k), length(fpcaObject$lambda), derOptns$k) 9 | # derOptns$GCV <- ifelse (is.null(derOptns$GCV), FALSE, TRUE) 10 | 11 | derOptns$p <- ifelse (is.null(derOptns$p), 1, derOptns$p) 12 | derOptns$kernelType <- ifelse(is.null(derOptns$kernelType), 'gauss', 13 | derOptns$kernelType) 14 | if (is.null(derOptns$bwMu) && is.null(derOptns$bwCov)) { 15 | if (is.null(derOptns$bw)) { 16 | derOptns$bw <- 17 | if (!is.null(fpcaObject[['sigma2']]) && (fpcaObject$sigma2 / sum(fpcaObject$lambda)) >= 0.01) { 18 | derOptns$p * 0.10 * diff(range(fpcaObject$workGrid)) 19 | } else { 20 | derOptns$p * 0.05 * diff(range(fpcaObject$workGrid)) 21 | } 22 | } 23 | derOptns$bwCov <- derOptns$bwMu <- derOptns$bw 24 | } else if (!is.null(derOptns$bwMu) && !is.null(derOptns$bwCov)) { 25 | # OK 26 | } else { 27 | stop('need to specify neither or both bwMu and bwCov') 28 | } 29 | 30 | return(derOptns) 31 | } 32 | -------------------------------------------------------------------------------- /man/Sparsify.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Sparsify.R 3 | \name{Sparsify} 4 | \alias{Sparsify} 5 | \title{Sparsify densely observed functional data} 6 | \usage{ 7 | Sparsify(samp, pts, sparsity, aggressive = FALSE, fragment = FALSE) 8 | } 9 | \arguments{ 10 | \item{samp}{A matrix of densely observed functional data, with each row containing one sample.} 11 | 12 | \item{pts}{A vector of grid points corresponding to the columns of \code{samp}.} 13 | 14 | \item{sparsity}{A vector of integers. The number of observation per sample is chosen to be one of the elements in sparsity with equal chance.} 15 | 16 | \item{aggressive}{Sparsify in an "aggressive" manner making sure that near-by readings are excluded.} 17 | 18 | \item{fragment}{Sparsify the observations into fragments, which are (almost) uniformly distributed in the time domain. Default to FALSE as not fragmenting. Otherwise a positive number specifying the approximate length of each fragment.} 19 | } 20 | \value{ 21 | A list of length 2, containing the following fields: 22 | \item{Lt}{A list of observation time points for each sample.} 23 | \item{Ly}{A list of values for each sample, corresponding to the time points.} 24 | } 25 | \description{ 26 | Given a matrix of densely observed functional data, create a sparsified sample for experimental purposes 27 | } 28 | -------------------------------------------------------------------------------- /tests/testthat/test_MakeSparseGP.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | library(testthat) 3 | 4 | test_that('MakeSparseGP works', { 5 | set.seed(1) 6 | n <- 100 7 | r1 <- MakeSparseGP(n) 8 | r2 <- MakeSparseGP(n, function(ni) rbeta(ni, 2/3, 1)) 9 | r3 <- MakeSparseGP(n, sparsity=1) 10 | r31 <- MakeSparseGP(n, sparsity=3) 11 | r4 <- MakeSparseGP(n, muFun=identity, lambda=1e-2) 12 | r5 <- MakeSparseGP(n, K=1) 13 | r6 <- MakeSparseGP(n, K=10) 14 | r7 <- MakeSparseGP(n, lambda=3:1) 15 | r8 <- MakeSparseGP(n, sigma=1) 16 | r9 <- MakeSparseGP(n, basisType='sin') 17 | r10 <- MakeSparseGP(2, CovFun=function(x) matrix(1, length(x), length(x))) 18 | 19 | expect_equal(length(r1$Ly), length(r1$Lt)) 20 | # hist(unlist(r2$Lt)) 21 | t2 <- unlist(r2$Lt) 22 | expect_true(sum(t2 < 0.1) > 1.5 * sum(t2 > 0.9)) 23 | expect_true(all(r3$Ni == 1)) 24 | expect_true(all(r31$Ni == 3)) 25 | expect_true(cor(unlist(r4$Lt), unlist(r4$Ly)) > 0.9) 26 | expect_equal(ncol(r5$xi), 1) 27 | expect_equal(ncol(r6$xi), 10) 28 | expect_equal(ncol(r7$xi), 3) 29 | expect_equal(sd(unlist(r7$Ly)), sqrt(sum(3:1)), tolerance=0.1) 30 | expect_equal(sd(unlist(r8$Ly) - unlist(r8$LyTrue)), 1, tolerance=0.1) 31 | expect_equal(mean(abs(unlist(r9$Ly)[unlist(r9$Lt) < 0.05])), 0, scale=1, tolerance=0.5) 32 | expect_equal(max(abs(sapply(r10$yCurve, diff))), 0, scale=1, tolerance=1e-6) 33 | }) 34 | -------------------------------------------------------------------------------- /man/fitted.FPCAder.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fitted.FPCAder.R 3 | \name{fitted.FPCAder} 4 | \alias{fitted.FPCAder} 5 | \title{Fitted functional data for derivatives from the FPCAder object} 6 | \usage{ 7 | \method{fitted}{FPCAder}(object, K = NULL, ...) 8 | } 9 | \arguments{ 10 | \item{object}{A object of class FPCA returned by the function FPCA().} 11 | 12 | \item{K}{The integer number of the first K components used for the representation. (default: length(derObj$lambda ))} 13 | 14 | \item{...}{Additional arguments} 15 | } 16 | \value{ 17 | An \code{n} by \code{length(workGrid)} matrix, each row of which contains a sample. 18 | } 19 | \description{ 20 | Combines the zero-meaned fitted values and the mean derivative to get the fitted values for the derivative trajectories. 21 | Estimates are given on the work-grid, not on the observation grid. Use ConvertSupport to map the 22 | estimates to your desired domain. 23 | } 24 | \examples{ 25 | set.seed(1) 26 | n <- 20 27 | pts <- seq(0, 1, by=0.05) 28 | sampWiener <- Wiener(n, pts) 29 | sampWiener <- Sparsify(sampWiener, pts, 10) 30 | } 31 | \references{ 32 | \cite{Liu, Bitao, and Hans-Georg Müller. "Estimating derivatives for samples of sparsely observed functions, with application to online auction dynamics." Journal of the American Statistical Association 104, no. 486 (2009): 704-717. (Sparse data FPCA)} 33 | } 34 | -------------------------------------------------------------------------------- /tests/testthat/test_fitted.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | library(testthat) 3 | set.seed(222) 4 | n <- 201 5 | pts <- seq(0, 1, by=0.015) 6 | sampWienerD <- Wiener(n, pts) 7 | sampWiener <- Sparsify(sampWienerD, pts, 10) 8 | res <- FPCA(sampWiener$Ly, sampWiener$Lt ) 9 | 10 | test_that("fitted with QUO and FPC give similar results", { 11 | 12 | fittedY <- fitted(res) 13 | fittedYe <- fitted(res, K=3, derOptns = list(p=1, method='FPC')) 14 | fittedYq <- fitted(res, K=3, derOptns = list(p=1, method='QUO')) 15 | 16 | if(1==3){ 17 | par(mfrow=c(1,3)) 18 | matplot(t(fittedY[1:3,]),t='l') 19 | matplot(t(fittedYe[1:3,]),t='l') 20 | matplot(t(fittedYq[1:3,]),t='l') 21 | } 22 | 23 | expect_warning(fitted(res, k=3, derOptns = list(p=1, method='FPC')), "specifying 'k' is deprecated. Use 'K' instead!") 24 | expect_equal( fittedYe, fittedYq, tolerance =0.01, scale= 1 ) #absolute difference 25 | 26 | }) 27 | 28 | test_that("fitted and real data are extremely correlated", { 29 | 30 | fittedY <- fitted(res) 31 | 32 | if(1==3){ 33 | par(mfrow=c(1,2)) 34 | matplot(t(fittedY[1:5,]),t='l') 35 | matplot(t(sampWienerD[1:5,]),t='l') 36 | } 37 | 38 | expect_true( cor(fittedY[,19], sampWienerD[,19] ) > 0.85 ) 39 | expect_true( cor(fittedY[,29], sampWienerD[,29] ) > 0.85 ) 40 | expect_true( cor(fittedY[,39], sampWienerD[,39] ) > 0.85 ) 41 | 42 | }) 43 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Compiled source # 2 | ################### 3 | *.com 4 | *.class 5 | *.dll 6 | *.exe 7 | *.o 8 | *.so 9 | 10 | # Packages # 11 | ############ 12 | # it's better to unpack these files and commit the raw source 13 | # git has its own built in compression methods 14 | *.7z 15 | *.dmg 16 | *.gz 17 | *.iso 18 | *.jar 19 | *.rar 20 | *.tar 21 | *.zip 22 | 23 | # Logs and databases # 24 | ###################### 25 | *.log 26 | *.sql 27 | *.sqlite 28 | ..Rcheck 29 | 30 | # OS generated files # 31 | ###################### 32 | .DS_Store 33 | .DS_Store? 34 | ._* 35 | .Spotlight-V100 36 | .Trashes 37 | ehthumbs.db 38 | Thumbs.db 39 | 40 | # Specific to this repo 41 | symbols.rds 42 | .RData 43 | .RDataTmp 44 | *.swp 45 | *.swo 46 | *.mat 47 | *.Rapp.history 48 | *.Rhistory 49 | *~ 50 | *.bak 51 | *.o 52 | *.so 53 | *.gcda 54 | *.gcno 55 | #RcppExports.R 56 | #RcppExports.cpp 57 | tmp.R 58 | ObsoleteFunctions 59 | notesXiongtao.txt 60 | # 61 | # Vignette files 62 | #vignettes/Sweave.sty 63 | cache/ 64 | vignettes/fdapaceVignette-concordance.tex 65 | vignettes/fdapaceVignette.bbl 66 | vignettes/fdapaceVignette.tex 67 | #vignettes/framed.sty 68 | vignettes/fdapaceVignetteKnitr-concordance.tex 69 | vignettes/fdapaceVignetteKnitr.tex 70 | vignettes/fdapaceVignetteKnitr.R 71 | vignettes/fdapaceVignetteKnitr.bbl 72 | vignettes/.build.timestamp 73 | 74 | # inst folder 75 | inst/doc 76 | 77 | # Development 78 | experiment/ 79 | -------------------------------------------------------------------------------- /R/GetUserCov.R: -------------------------------------------------------------------------------- 1 | GetUserCov <- function(optns, obsGrid, cutRegGrid, buff, ymat) { 2 | # Is used for the case where the covariance function is provided by the user 3 | 4 | optns$userCov$t <- as.numeric(optns$userCov$t) 5 | optns$userCov$cov <- as.numeric(optns$userCov$cov) 6 | 7 | rangeUser <- range(optns$userCov$t) 8 | rangeCut <- range(cutRegGrid) 9 | if( rangeUser[1] > rangeCut[1] + buff || 10 | rangeUser[2] < rangeCut[2] - buff ) { 11 | stop('The range defined by the user provided covariance does not cover the support of the data.') 12 | } 13 | 14 | bwCov = NULL 15 | smoothCov = ConvertSupport(fromGrid = optns$userCov$t, cutRegGrid, Cov = optns$userCov$cov) 16 | 17 | if (optns$error) { # error == TRUE 18 | if (!is.null(optns[['userSigma2']])) { 19 | sigma2 <- optns[['userSigma2']] 20 | } else if (optns$dataType %in% c('Dense', 'DenseWithMV')) { 21 | ord <- 2 22 | sigma2 <- mean(diff(t(ymat), differences=ord)^2, na.rm=TRUE) / choose(2 * ord, ord) 23 | } else { 24 | stop('Use GetSmoothedCovarSurface instead!') 25 | } 26 | } else { # error == FALSE 27 | sigma2 <- NULL 28 | } 29 | 30 | res <- list(rawCov = NULL, 31 | smoothCov = (smoothCov + t(smoothCov)) / 2, 32 | bwCov = NULL, 33 | sigma2 = sigma2, 34 | outGrid = cutRegGrid) 35 | class(res) <- "SmoothCov" 36 | return(res) 37 | } 38 | -------------------------------------------------------------------------------- /tests/testthat/test_GetSmoothedMeanCurve.R: -------------------------------------------------------------------------------- 1 | cat("\nTests for 'GetSmoothedMeanCurve.R'") 2 | library(testthat) 3 | load(system.file('testdata', 'dataGeneratedByExampleSeed123.RData', package='fdapace')) 4 | 5 | p = list(kernel='epan') 6 | optns = SetOptions(y,t,p) 7 | out1 = sort(unique( c(unlist(t), optns$newdata))); 8 | out21 = seq(min(out1), max(out1),length.out = 30); 9 | 10 | test_that("basic that the Epan. kernel gives the same results as MATLAB", { 11 | 12 | smcObj = GetSmoothedMeanCurve(y=y, t=t, obsGrid = out1, regGrid = out21, optns = optns) 13 | #expect_equal( sum(smcObj$mu) , 1.176558873333339e+02,tolerance = 1e-13, scale = 1 ) # Original 14 | 15 | expect_equal( sum(smcObj$mu) , 1.176558873333339e+02,tolerance = 4, scale = 1 ) # New 16 | } ) 17 | 18 | test_that("basic that the Rect. kernel gives the same results as MATLAB", { 19 | 20 | optns$kernel = 'rect'; 21 | smcObj = GetSmoothedMeanCurve(y=y, t=t, obsGrid = out1, regGrid = out21, optns = optns) 22 | expect_equal( sum(smcObj$mu) , 1.186398254457767e+02,tolerance = 6, scale = 1 )# New 23 | 24 | } ) 25 | 26 | 27 | 28 | test_that("basic that the Gaussian kernel gives the same results as MATLAB", { 29 | 30 | optns$kernel = 'gauss'; 31 | smcObj = GetSmoothedMeanCurve(y=y, t=t, obsGrid = out1, regGrid = out21, optns = optns) 32 | expect_equal( sum(smcObj$mu) , 1.206167514696777e+02,tolerance =4 , scale = 1 )# New 33 | 34 | } ) 35 | 36 | 37 | -------------------------------------------------------------------------------- /tests/testthat/test_RmullwlskUniversal.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | load(system.file('testdata', 'InputFormMllwlskInCpp.RData', package='fdapace')) 3 | IN = InputFormMllwlskInCpp 4 | 5 | ord <- order(IN$tPairs[, 1]) 6 | xin <- IN$tPairs[ord, ] 7 | yin <- IN$cxxn[ord] 8 | win <- rep(1,38) 9 | 10 | 11 | # These check out OK. 12 | U = test_that("basic inputs for different kernels match previous inputs.", { 13 | 14 | AA = Rmullwlsk(2* IN$bw,t(IN$tPairs),cxxn=IN$cxxn, xgrid=IN$regGrid, ygrid=IN$regGrid, kernel_type='epan',win=rep(1,38), bwCheck = FALSE) 15 | AAu = RmullwlskUniversal( bw = 2* IN$bw, tPairs =t(xin), cxxn=yin, xgrid=IN$regGrid, ygrid=IN$regGrid, kernel_type='epan', win=win, FALSE, TRUE) 16 | 17 | BB = Rmullwlsk(2* IN$bw,t(IN$tPairs),cxxn=IN$cxxn, xgrid=IN$regGrid, ygrid=IN$regGrid, kernel_type='rect',win=rep(1,38), bwCheck = FALSE) 18 | BBu = RmullwlskUniversal( bw = 2* IN$bw, tPairs =t(xin), cxxn=yin, xgrid=IN$regGrid, ygrid=IN$regGrid, kernel_type='rect', win=win, FALSE, TRUE) 19 | 20 | CC = Rmullwlsk(2* IN$bw,t(IN$tPairs),cxxn=IN$cxxn, xgrid=IN$regGrid, ygrid=IN$regGrid, kernel_type='gauss',win=rep(1,38), bwCheck = FALSE) 21 | CCu = RmullwlskUniversal( bw = 2* IN$bw, tPairs =t(xin), cxxn=yin, xgrid=IN$regGrid, ygrid=IN$regGrid, kernel_type='gauss', win=win, FALSE, TRUE) 22 | 23 | expect_equal( CC, CCu) 24 | expect_equal( BB, BBu) 25 | expect_equal( AA, AAu) 26 | 27 | 28 | 29 | }) 30 | 31 | 32 | -------------------------------------------------------------------------------- /man/MakeGPFunctionalData.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/MakeGPFunctionalData.R 3 | \name{MakeGPFunctionalData} 4 | \alias{MakeGPFunctionalData} 5 | \title{Create a Dense Functional Data sample for a Gaussian process} 6 | \usage{ 7 | MakeGPFunctionalData( 8 | n, 9 | M = 100, 10 | mu = rep(0, M), 11 | K = 2, 12 | lambda = rep(1, K), 13 | sigma = 0, 14 | basisType = "cos" 15 | ) 16 | } 17 | \arguments{ 18 | \item{n}{number of samples to generate} 19 | 20 | \item{M}{number of equidistant readings per sample (default: 100)} 21 | 22 | \item{mu}{vector of size M specifying the mean (default: rep(0,M))} 23 | 24 | \item{K}{scalar specifying the number of basis to be used (default: 2)} 25 | 26 | \item{lambda}{vector of size K specifying the variance of each components (default: rep(1,K))} 27 | 28 | \item{sigma}{The standard deviation of the Gaussian noise added to each observation points.} 29 | 30 | \item{basisType}{string specifying the basis type used; possible options are: 'sin', 'cos' and 'fourier' (default: 'cos') (See code of 'CreateBasis' for implementation details.)} 31 | } 32 | \value{ 33 | A list containing the following fields: 34 | \item{Y}{A vector of noiseless observations.} 35 | \item{Yn}{A vector of noisy observations if \code{sigma} > 0.} 36 | } 37 | \description{ 38 | For a Gaussian process, create a dense functional data sample of size n over a [0,1] support. 39 | } 40 | -------------------------------------------------------------------------------- /R/DesignPlotCount.R: -------------------------------------------------------------------------------- 1 | # This function is used to create a count matrix based on 2 | # observed pairs of time points for the raw covariance. 3 | 4 | ###### 5 | # Input: 6 | ###### 7 | # t: n * 1 array contains time points for n subjects 8 | # obsGrid: 1 * N vector contains sorted unique time points from t 9 | # noDiagonal: TRUE: set diagonal count as 0 10 | # FALSE: don't set diagonal count as 0 11 | # isColorPlot: TRUE: the resulting matrix has 1 indicates there exists points for out1(i) and out1(j) 12 | # FALSE: the resulting matrix contains counts of points for out1(i) and out1(j) 13 | ###### 14 | # Output: 15 | ###### 16 | # res: N * N matrix contains count for each distinct pairs of 17 | # time points 18 | 19 | DesignPlotCount = function(t, obsGrid, noDiagonal, isColorPlot){ 20 | N = length(obsGrid) # number of distinct observed time pts 21 | res = matrix(0, nrow = N, ncol = N) 22 | 23 | for(cur in t){ 24 | curidx = match(cur, obsGrid) 25 | if(isColorPlot == FALSE){ 26 | res[curidx, curidx] = 1 27 | } else { 28 | res[curidx, curidx] = res[curidx, curidx] + 1 29 | } 30 | } 31 | 32 | if(noDiagonal == TRUE){ 33 | diag(res) = 0 34 | } 35 | 36 | return(res) 37 | } 38 | 39 | # searchID = function(cur, obsGrid){ 40 | # ni = length(cur) 41 | # id = rep(0, ni) 42 | # for(i in 1:ni){ 43 | # id[i] = which(obsGrid == cur[i]) 44 | # } 45 | # return(id) 46 | # } 47 | -------------------------------------------------------------------------------- /man/CreateBWPlot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/CreateBWPlot.R 3 | \name{CreateBWPlot} 4 | \alias{CreateBWPlot} 5 | \title{Functional Principal Component Analysis Bandwidth Diagnostics plot} 6 | \usage{ 7 | CreateBWPlot(fpcaObj, derOptns = NULL, bwMultipliers = NULL) 8 | } 9 | \arguments{ 10 | \item{fpcaObj}{An FPCA class object returned by FPCA().} 11 | 12 | \item{derOptns}{A list of options to control the derivation parameters; see ?FPCAder. If NULL standard diagnostics are returned} 13 | 14 | \item{bwMultipliers}{A vector of multipliers that the original 'bwMu' and 'bwCov' will be multiplied by. (default: c(0.50, 0.75, 1.00, 1.25, 1.50)) 15 | - default: NULL} 16 | } 17 | \description{ 18 | This function by default creates the mean and first principal modes of variation plots for 19 | 50%, 75%, 100%, 125% and 150% of the defined bandwidth choices in the fpcaObj provided as input. 20 | If provided with a derivative options object (?FPCAder) it will return the 21 | differentiated mean and first two principal modes of variation for 50%, 75%, 100%, 125% and 150% of the defined bandwidth choice. 22 | } 23 | \examples{ 24 | set.seed(1) 25 | n <- 40 26 | pts <- seq(0, 1, by=0.05) 27 | sampWiener <- Wiener(n, pts) 28 | sampWiener <- Sparsify(sampWiener, pts, 10) 29 | res1 <- FPCA(sampWiener$Ly, sampWiener$Lt, 30 | list(dataType='Sparse', error=FALSE, kernel='epan', verbose=FALSE)) 31 | CreateBWPlot(res1) 32 | } 33 | -------------------------------------------------------------------------------- /tests/testthat/test_CreatePathPlot.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | # devtools::load_all() 3 | 4 | set.seed(1) 5 | n <- 300 6 | pts <- seq(0, 1, by=0.05) 7 | sampWiener <- Wiener(n, pts) 8 | sampWiener <- sampWiener + matrix(rnorm(n, sd=0.1), n, length(pts)) 9 | sampWiener <- Sparsify(sampWiener, pts, 1:5) 10 | res <- FPCA(sampWiener$Ly, sampWiener$Lt, 11 | list(dataType='Sparse', kernel='epan')) 12 | resDer <- FPCAder(res, list(method='DPC')) 13 | 14 | test_that('CreatePathPlot works for FPCA object', { 15 | CreatePathPlot(res) 16 | CreatePathPlot(res, 1:10) 17 | CreatePathPlot(res, 1:20, showObs=FALSE) 18 | CreatePathPlot(res, 1:20, showMean=TRUE, showObs=FALSE) 19 | CreatePathPlot(res, 1:20, obsOnly=TRUE) 20 | CreatePathPlot(res, 1:20, obsOnly=TRUE, showObs=FALSE) 21 | CreatePathPlot(inputData=sampWiener, subset=1:20, obsOnly=TRUE) 22 | CreatePathPlot(res, subset=seq_len(n) %% 5 == 0, K=4, inputData=list(Lt=sampWiener$Lt, Ly=sampWiener$Ly), main='123', xlab='T') 23 | }) 24 | 25 | test_that('CreatePathPlot works for FPCAder object', { 26 | CreatePathPlot(resDer) 27 | CreatePathPlot(resDer, 1:10) 28 | CreatePathPlot(resDer, 1:10, showMean=TRUE) 29 | CreatePathPlot(resDer, 1:20, showObs=TRUE) 30 | CreatePathPlot(resDer, 1:20, obsOnly=TRUE, showObs=FALSE) 31 | }) 32 | 33 | test_that('User defined colors work', { 34 | showInd <- 11:13 35 | shown <- length(showInd) 36 | CreatePathPlot(res, showInd) 37 | CreatePathPlot(res, showInd, col=c('blue', 'cyan', 'grey')) 38 | }) 39 | -------------------------------------------------------------------------------- /tests/testthat/test_GetEigenAnalysisResults.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | library(testthat) 3 | 4 | trueLam <- 4 / ((2 * (1:50) - 1 ) * pi) ^ 2 5 | 6 | set.seed(1) 7 | pts <- seq(0, 1, by=0.05) 8 | regGrid <- seq(0, 1, by=0.01) 9 | samp3 <- Wiener(50, pts, sparsify=length(pts)) 10 | mu3 <- rep(0, length(pts)) 11 | 12 | # without error 13 | p0 <- SetOptions(samp3$Ly, samp3$Lt, list(maxK=50, FVEthreshold=1, dataType='Sparse', error=FALSE, kernel='epan')) 14 | noErrBin <- GetSmoothedCovarSurface(samp3$Ly, samp3$Lt, mu3, pts, regGrid, p0, useBinnedCov=TRUE) 15 | tmp <- GetEigenAnalysisResults(noErrBin$smoothCov, regGrid, p0) 16 | 17 | # consistency test 18 | test_that('Eigenvalues are close', { 19 | expect_equal((abs(tmp$lam - trueLam[1:length(tmp$lam)]) / trueLam[1:length(tmp$lam)] )[1:3], trueLam[1:3], tolerance=0.2) 20 | }) 21 | 22 | # TEst integrate to one. 23 | innerProd <- apply(tmp$phi, 2, function(lam1) 24 | apply(tmp$phi, 2, function(lam2) 25 | pracma::trapz(noErrBin$outGrid, lam1 * lam2))) 26 | test_that('Eigenfunctions are orthonormal', { 27 | expect_equal(diag(innerProd), rep(1, tmp$kChoosen)) 28 | expect_equal(innerProd[row(innerProd) != col(innerProd)], rep(0, length(innerProd) - nrow(innerProd)), tolerance=0.010) 29 | }) 30 | 31 | 32 | # # with error 33 | # p1 <- SetOptions(samp3$Ly, samp3$Lt, CreateOptions(dataType='Sparse', error=TRUE, kernel='epan')) 34 | # Err <- GetSmoothedCovarSurface(samp3$Ly, samp3$Lt, mu3, pts, regGrid, p1, useBinnedCov=FALSE) 35 | 36 | -------------------------------------------------------------------------------- /man/GetNormalisedSample.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/GetNormalisedSample.R 3 | \name{GetNormalisedSample} 4 | \alias{GetNormalisedSample} 5 | \alias{GetNormalizedSample} 6 | \title{Normalise sparse multivariate functional data} 7 | \usage{ 8 | GetNormalisedSample(fpcaObj, errorSigma = FALSE) 9 | 10 | GetNormalizedSample(...) 11 | } 12 | \arguments{ 13 | \item{fpcaObj}{An FPCA object.} 14 | 15 | \item{errorSigma}{Indicator to use sigma^2 error variance when normalising the data (default: FALSE)} 16 | 17 | \item{...}{Passed into GetNormalisedSample} 18 | } 19 | \value{ 20 | A list containing the normalised sample 'y' at times 't' 21 | } 22 | \description{ 23 | Normalise sparse functional sample given in an FPCA object 24 | } 25 | \examples{ 26 | set.seed(1) 27 | n <- 100 28 | M <- 51 29 | pts <- seq(0, 1, length.out=M) 30 | mu <- rep(0, length(pts)) 31 | sampDense <- MakeGPFunctionalData(n, M, mu, K=1, basisType='sin', sigma=0.01) 32 | samp4 <- MakeFPCAInputs(tVec=sampDense$pts, yVec=sampDense$Yn) 33 | res4E <- FPCA(samp4$Ly, samp4$Lt, list(error=TRUE)) 34 | sampN <- GetNormalisedSample(res4E, errorSigma=TRUE) 35 | 36 | CreatePathPlot(subset=1:20, inputData=samp4, obsOnly=TRUE, showObs=FALSE) 37 | CreatePathPlot(subset=1:20, inputData=sampN, obsOnly=TRUE, showObs=FALSE) 38 | } 39 | \references{ 40 | \cite{Chiou, Jeng-Min and Chen, Yu-Ting and Yang, Ya-Fang. "Multivariate Functional Principal Component Analysis: A Normalization Approach" Statistica Sinica 24 (2014): 1571-1596} 41 | } 42 | -------------------------------------------------------------------------------- /R/BinData.R: -------------------------------------------------------------------------------- 1 | BinData = function(y,t,optns){ 2 | 3 | # Bin the data 'y' 4 | # y : n-by-1 list of vectors 5 | # t : n-by-1 list of vectors 6 | # dataType : indicator about structure of the data 7 | # (dense (2), or dataType data with missing values (1) or sparse (0)) 8 | # verbose gives warning messages 9 | # numBins: number of bins (if set) 10 | 11 | BinDataOutput <- list( newy <- NULL, newt <- NULL); 12 | 13 | dataType = optns$dataType; 14 | verbose = optns$verbose; 15 | 16 | n = length(t); 17 | ni = sapply(FUN= length,t); 18 | 19 | if (dataType == 'Sparse'){ 20 | m = median(ni) 21 | } else { 22 | m = max(ni); 23 | } 24 | 25 | # Check the number of bins automatically 26 | if (is.null(numBins)){ 27 | numBins = GetBinNum(n,m,dataType,verbose) 28 | }else if( numBins <1){ 29 | warning("number of bins must be positive integer! We reset to the default number of bins!\n") 30 | numBins = GetBinNum(n,m,dataType,verbose) 31 | } 32 | 33 | # If it is determined to be NULL return the unbinned data 34 | if (is.null(numBins)){ 35 | BinDataOutput$newt = t; 36 | BinDataOutput$newy = y; 37 | return( BinDataOutput ) 38 | } 39 | 40 | numBins = ceiling(numBins); 41 | 42 | tt = unlist(t); 43 | a0 = min(tt); 44 | b0 = max(tt); 45 | 46 | for (i in 1:n){ 47 | res = GetBinnedCurve(t[[i]], y[[i]], numBins, TRUE, TRUE, c(a0, b0)); 48 | BinDataOutput$newt[i] = res$midpoint; 49 | BinDataOutput$newy[i] = res$newy; 50 | } 51 | 52 | return( BinDataOutput ) 53 | } 54 | -------------------------------------------------------------------------------- /src/GetIndCEScoresCPP.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include // to get std::lower_bound 3 | #include // to get std::iterator 4 | #include // to get NaN 5 | 6 | // [[Rcpp::depends(RcppEigen)]] 7 | // [[Rcpp::export]] 8 | 9 | 10 | Rcpp::List GetIndCEScoresCPP( const Eigen::Map & yVec, const Eigen::Map & muVec, const Eigen::Map & lamVec, const Eigen::Map & phiMat, const Eigen::Map & SigmaYi){ 11 | 12 | // Setting up initial values 13 | 14 | const unsigned int lenlamVec = lamVec.size(); 15 | 16 | Eigen::MatrixXd xiVar = Eigen::MatrixXd::Constant(lenlamVec,lenlamVec,std::numeric_limits::quiet_NaN()); 17 | Eigen::MatrixXd xiEst = Eigen::MatrixXd::Constant(lenlamVec,1,std::numeric_limits::quiet_NaN()); 18 | Eigen::MatrixXd fittedY = Eigen::MatrixXd::Constant(lenlamVec,1,std::numeric_limits::quiet_NaN()); 19 | 20 | Eigen::MatrixXd LamPhi = lamVec.asDiagonal() * phiMat.transpose(); 21 | Eigen::LDLT ldlt_SigmaYi(SigmaYi); 22 | xiEst = LamPhi * ldlt_SigmaYi.solve(yVec - muVec) ; // LamPhiSig * (yVec - muVec); 23 | xiVar = -LamPhi * ldlt_SigmaYi.solve(LamPhi.transpose()); // LamPhiSig.transpose(); 24 | 25 | xiVar.diagonal() += lamVec; 26 | fittedY = muVec + phiMat * xiEst; 27 | 28 | return Rcpp::List::create(Rcpp::Named("xiEst") = xiEst, 29 | Rcpp::Named("xiVar") = xiVar, 30 | Rcpp::Named("fittedY") = fittedY); 31 | } 32 | -------------------------------------------------------------------------------- /R/HandleNumericsAndNAN.R: -------------------------------------------------------------------------------- 1 | # #' Check if NaN are present in the data and if yes remove them 2 | # #' 3 | # #' Check if there are problems caused by missing values with the form and basic structure of the functional data 'Ly' and the recorded times 'Lt'. 4 | # #' 5 | # #' @param Ly is a n-by-1 list of vectors 6 | # #' @param Lt is a n-by-1 list of vectors 7 | 8 | HandleNumericsAndNAN <- function(Ly,Lt){ 9 | 10 | # Check for the presense of NA and remove them (if they exist) from the two lists in a pairwise manner 11 | if( any(is.na(unlist(Lt))) || any(is.na(unlist(Ly))) ){ 12 | 13 | helperF <- function(x) which(!is.na(unlist(x))) 14 | L <- list(); for(j in 1:length(Ly)) L[[j]] = list(Ly[[j]],Lt[[j]]) 15 | validIndexes = lapply(L, function(x) intersect(helperF(x[1]), helperF(x[2]) )) 16 | 17 | Ly = lapply(1:length(Ly), function(i) Ly[[i]][validIndexes[[i]]]) 18 | Lt = lapply(1:length(Ly), function(i) Lt[[i]][validIndexes[[i]]]) 19 | 20 | if( any(unlist(lapply(Ly, function(x) length(x) == 0))) ){ 21 | stop('Subjects with only NA values are not allowed.\n') 22 | } 23 | 24 | ni_y = unlist(lapply(Ly,function(x) sum(!is.na(x)))) 25 | if(all(ni_y == 1)){ 26 | stop("FPCA is aborted because the data do not contain repeated measurements after removing NA values.\n"); 27 | } 28 | } 29 | 30 | 31 | 32 | # Force the data to be list of numeric members 33 | Ly <- lapply(Ly, as.numeric) 34 | Lt <- lapply(Lt, as.numeric) 35 | Lt <- lapply(Lt, signif, 14) 36 | return( inputData <- list(Ly=Ly, Lt=Lt)); 37 | 38 | } 39 | -------------------------------------------------------------------------------- /R/CondProjection.R: -------------------------------------------------------------------------------- 1 | ##### 2 | ##### conditional projection 3 | ##### 4 | 5 | ##### input variables: 6 | ##### f: evaluated values of component functions at estimation grid (N*d matrix) 7 | ##### kj: index of conditional projection for the k-th component function on the j-th component function space (2-dim. vector) 8 | ##### x: estimation grid (N*d matrix) 9 | ##### X: covariate observation grid (n*d matrix) 10 | ##### MgnJntDensity: evaluated values of marginal and 2-dim. joint densities (2-dim. list, referred to the output of 'MgnJntDensity') 11 | 12 | ##### output: 13 | ##### conditional projection of the k-th component function on the j-th component function space (N-dim. vector) 14 | 15 | 16 | CondProjection <- function(f, kj, x, X, MgnJntDens){ 17 | 18 | N <- nrow(x) 19 | n <- nrow(X) 20 | d <- ncol(X) 21 | 22 | k <- kj[1] 23 | j <- kj[2] 24 | 25 | xj <- x[,j] 26 | xk <- c() 27 | 28 | fk <- f[,k] 29 | if (length(fk)==n) { 30 | xk <- X[,k] 31 | } else { 32 | xk <- x[,k] 33 | } 34 | 35 | asdf <- MgnJntDens$pMatMgn[,j] 36 | 37 | tmpInd <- which(asdf!=0) 38 | qwer <- MgnJntDens$pArrJnt[,tmpInd,k,j] 39 | 40 | if (length(tmpInd)>0) { 41 | 42 | pHat <- matrix(0,nrow=length(xk),ncol=length(xj)) 43 | 44 | pHat[,tmpInd] <- t(t(qwer)/asdf[tmpInd]) 45 | 46 | tmp <- c() 47 | for (l in 1:ncol(pHat)) { 48 | tmptmp <- fk*c(pHat[,l]) 49 | tmp[l] <- trapzRcpp(sort(xk),tmptmp[order(xk)]) 50 | } 51 | 52 | return(tmp) 53 | 54 | } else { 55 | return(0) 56 | } 57 | } 58 | -------------------------------------------------------------------------------- /man/SelectK.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/SelectK.R 3 | \name{SelectK} 4 | \alias{SelectK} 5 | \title{Selects number of functional principal components for 6 | given FPCA output and selection criteria} 7 | \usage{ 8 | SelectK(fpcaObj, criterion = "FVE", FVEthreshold = 0.95, Ly = NULL, Lt = NULL) 9 | } 10 | \arguments{ 11 | \item{fpcaObj}{A list containing FPCA related objects returned by MakeFPCAResults().} 12 | 13 | \item{criterion}{A string or positive integer specifying selection criterion for the number of functional principal components. 14 | Available options: 'FVE', 'AIC', 'BIC', or the specified number of components - default: 'FVE' 15 | For explanations of these criteria, see Yao et al (2005, JASA)} 16 | 17 | \item{FVEthreshold}{A threshold fraction to be specified by the user when using "FVE" as selection criterion: (0,1] - default: NULL} 18 | 19 | \item{Ly}{A list of \emph{n} vectors containing the observed values for each individual - default: NULL} 20 | 21 | \item{Lt}{A list of \emph{n} vectors containing the observation time points for each individual corresponding to Ly - default: NULL} 22 | } 23 | \value{ 24 | A list including the following two fields: 25 | \item{K}{An integer indicating the selected number of components based on given criterion.} 26 | \item{criterion}{The calculated criterion value for the selected number of components, i.e. FVE, AIC or BIC value, NULL for fixedK criterion.} 27 | } 28 | \description{ 29 | Selects number of functional principal components for 30 | given FPCA output and selection criteria 31 | } 32 | -------------------------------------------------------------------------------- /man/MakeSparseGP.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/MakeSparseGP.R 3 | \name{MakeSparseGP} 4 | \alias{MakeSparseGP} 5 | \title{Create a sparse Functional Data sample for a Gaussian Process} 6 | \usage{ 7 | MakeSparseGP( 8 | n, 9 | rdist = runif, 10 | sparsity = 2:9, 11 | muFun = function(x) rep(0, length(x)), 12 | K = 2, 13 | lambda = rep(1, K), 14 | sigma = 0, 15 | basisType = "cos", 16 | CovFun = NULL 17 | ) 18 | } 19 | \arguments{ 20 | \item{n}{number of samples to generate.} 21 | 22 | \item{rdist}{a sampler for generating the random design time points within [0, 1].} 23 | 24 | \item{sparsity}{A vector of integers. The number of observation per sample is chosen to be one of the elements in sparsity with equal chance.} 25 | 26 | \item{muFun}{a function that takes a vector input and output a vector of the corresponding mean (default: zero function).} 27 | 28 | \item{K}{scalar specifying the number of basis to be used (default: 2).} 29 | 30 | \item{lambda}{vector of size K specifying the variance of each components (default: rep(1,K)).} 31 | 32 | \item{sigma}{The standard deviation of the Gaussian noise added to each observation points.} 33 | 34 | \item{basisType}{string specifying the basis type used; possible options are: 'sin', 'cos' and 'fourier' (default: 'cos') (See code of 'CreateBasis' for implementation details.)} 35 | 36 | \item{CovFun}{an alternative specification of the covariance structure.} 37 | } 38 | \value{ 39 | TODO 40 | } 41 | \description{ 42 | Functional data sample of size n, sparsely sampled from a Gaussian process 43 | } 44 | -------------------------------------------------------------------------------- /src/dropZeroElementsXYWin.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include // to map kernels to integers for the switch 3 | #include // to read in the kernel name 4 | #include // to use vectors 5 | #include // to get the intersect and sort 6 | 7 | // [[Rcpp::depends(RcppEigen)]] 8 | // [[Rcpp::export]] 9 | 10 | 11 | Eigen::MatrixXd dropZeroElementsXYWin( const Eigen::Map & win, const Eigen::Map & xin, const Eigen::Map & yin){ 12 | 13 | const unsigned int nXGrid = xin.size(); 14 | 15 | // Check that we have equal number of readings 16 | if( nXGrid != yin.size()){ 17 | Rcpp::stop("The input Y-grid does not have the same number of points as input X-grid."); 18 | } 19 | 20 | if( nXGrid != win.size()){ 21 | Rcpp::stop("The input weight vector does not have the same number of points as input X-grid."); 22 | } 23 | 24 | unsigned int nZeroElements = std::count(&win[0], &win[nXGrid], 0.); 25 | 26 | // Check that we do not have zero weights // Should do a try-catch here 27 | if( nZeroElements != 0 ){ // 28 | Eigen::MatrixXd Q(nXGrid - nZeroElements,3); 29 | unsigned int q = 0; 30 | for( unsigned int i = 0; i != nXGrid; ++i){ 31 | if ( win[i] != 0 ) { 32 | Q(q,0) = xin[i]; 33 | Q(q,1) = yin[i]; 34 | Q(q,2) = win[i]; 35 | ++q; 36 | } 37 | } 38 | return( Q ); 39 | } else { 40 | Eigen::MatrixXd Q(nXGrid,3); 41 | Q.col(0) = xin; 42 | Q.col(1) = yin; 43 | Q.col(2) = win; 44 | return( Q ); 45 | } 46 | } 47 | -------------------------------------------------------------------------------- /tests/testthat/test_FitEigenValues.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | ##options(error=recover) 3 | library(testthat) 4 | 5 | test_that('FitEigenValues works for binned rcov, error=TRUE', { 6 | set.seed(2) 7 | pts <- seq(0, 1, by=0.001) 8 | samp3 <- Wiener(10, pts, sparsify=2:7) 9 | rcov3 <- GetRawCov(samp3$Ly, samp3$Lt, pts, rep(0, length(pts)), 'Sparse', error=TRUE) 10 | brcov3 <- BinRawCov(rcov3) 11 | phi <- cbind(sin((2 * 1 - 1) * pi * pts / 2), sin((2 * 2 - 1) * pi * pts / 2)) * sqrt(2) 12 | expect_equal(FitEigenValues(rcov3, pts, phi, 2), FitEigenValues(brcov3, pts, phi, 2)) 13 | }) 14 | 15 | test_that('FitEigenValues works for binned rcov, error=FALSE', { 16 | set.seed(2) 17 | pts <- seq(0, 1, by=0.001) 18 | samp3 <- Wiener(10, pts, sparsify=2:7) 19 | rcov3 <- GetRawCov(samp3$Ly, samp3$Lt, pts, rep(0, length(pts)), 'Sparse', error=FALSE) 20 | brcov3 <- BinRawCov(rcov3) 21 | phi <- cbind(sin((2 * 1 - 1) * pi * pts / 2), sin((2 * 2 - 1) * pi * pts / 2)) * sqrt(2) 22 | expect_equal(FitEigenValues(rcov3, pts, phi, 2), FitEigenValues(brcov3, pts, phi, 2)) 23 | }) 24 | 25 | trueLambda <- 4 / (2 * (1:20) - 1)^2 / pi^2 26 | test_that('FitEigenValues is consistent', { 27 | set.seed(2) 28 | pts <- seq(0, 1, by=0.05) 29 | samp3 <- Wiener(300, pts, sparsify=length(pts)) 30 | rcov3 <- GetRawCov(samp3$Ly, samp3$Lt, pts, rep(0, length(pts)), 'Sparse', error=TRUE) 31 | phi <- cbind(sin((2 * 1 - 1) * pi * pts / 2), sin((2 * 2 - 1) * pi * pts / 2)) * sqrt(2) 32 | estLam <- FitEigenValues(rcov3, pts, phi, 2) 33 | expect_equal(estLam, trueLambda[1:length(estLam)], tolerance = 0.15) 34 | }) 35 | 36 | # Test truncation 37 | -------------------------------------------------------------------------------- /R/BestDes_TR.R: -------------------------------------------------------------------------------- 1 | # Find optimal designs for trajectory recovery 2 | BestDes_TR <- function(p, ridge, workGrid, Cov, isSequential=FALSE){ 3 | # select optimal designs for trajectory recovery case, sequential method available 4 | if(isSequential == FALSE){ # Global Selection 5 | comblist <- utils::combn(1:length(workGrid),p) 6 | temps <- rep(0,ncol(comblist)) 7 | for(i in 1:ncol(comblist)){ temps[i] <- TRCri(comblist[,i], ridge, Cov, workGrid) } 8 | best <- sort(comblist[,min(which(temps==max(temps)))]) 9 | return(list(best=best)) 10 | } else { # Sequential optimization 11 | optdes <- c() 12 | for(iter in 1:p){ 13 | candidx <- which(!((1:length(workGrid)) %in% optdes)) 14 | seqcri <- rep(NA, length(candidx)) 15 | for(i in 1:length(candidx)){ 16 | tempdes <- sort(c(optdes,candidx[i])) 17 | seqcri[i] <- TRCri(tempdes, ridge, Cov, workGrid) 18 | } 19 | optdes <- sort(c(optdes, candidx[min(which(seqcri == max(seqcri)))])) 20 | } 21 | return(list(best=optdes,med=NULL)) # based on sequential selection 22 | } 23 | } 24 | 25 | TRCri <- function(design, ridge, Cov, workGrid){ 26 | # Optimization criterion for TR 27 | # Numerical Integration, equal to matrix multiplication if time grid is year 28 | design <- sort(design) 29 | RidgeCov <- Cov + diag(ridge, nrow(Cov)) 30 | designcovinv <- solve(RidgeCov[design,design]) 31 | if(length(design) > 1){ 32 | trcri <- trapzRcpp(X=workGrid,Y=diag(t(Cov[design,])%*%designcovinv%*%(Cov[design,]))) 33 | } else { 34 | trcri <- trapzRcpp(X=workGrid,Y=diag(Cov[design,]%*%designcovinv%*%(Cov[design,]))) 35 | } 36 | return(trcri) 37 | } 38 | -------------------------------------------------------------------------------- /R/NormKernel.R: -------------------------------------------------------------------------------- 1 | ##### 2 | ##### normalization of compactly supported kernel (Mammen et al., 1999) 3 | ##### 4 | 5 | ##### input variables 6 | ##### x: estimation points (N-dim. vector) 7 | ##### X: covariate observation points (n-dim. vector) 8 | ##### h: bandwidth (scalar) 9 | ##### K: kernel function (function object, default is the Epanechnikov kernel) 10 | ##### supp: support of stimation interested (2-dim. vector, default is a closed interval [0,1]) 11 | 12 | ##### output variable: 13 | ##### evaluated values of normalized kernel at estimation points near observation points (N by n matrix) 14 | 15 | 16 | 17 | ### normalized kernel 18 | NormKernel <- function(x, X, h=NULL, K='epan', supp=NULL){ 19 | 20 | N <- length(x) 21 | n <- length(X) 22 | 23 | if (K!='epan') { 24 | message('Epanechnikov kernel is the default choice') 25 | K<-'epan' 26 | } 27 | if (is.null(supp)==TRUE) { 28 | supp <- c(0,1) 29 | } 30 | if (is.null(h)==TRUE) { 31 | h <- 0.25*n^(-1/5)*(supp[2]-supp[1]) 32 | } 33 | 34 | numer <- ScaleKernel(x,X,h,K=K,supp=supp) 35 | 36 | ind1 <- which(dunif(X,supp[1],supp[2])==0) 37 | numer[,ind1] <- 0 38 | 39 | denom <- c() 40 | for (i in 1:n) { 41 | denom[i] <- trapzRcpp(sort(x),numer[order(x),i]) 42 | } 43 | #denom <- apply(numer[x_order,],2,FUN='trapzRcpp',X=sort(x)) 44 | 45 | ind2 <- which(denom==0) 46 | 47 | NormKernelTmp <- numer/matrix(rep(denom,N),nrow=N,byrow=TRUE) 48 | NormKernelTmp[,ind2] <- 0 49 | 50 | if (min(nrow(NormKernelTmp),ncol(NormKernelTmp))==1) { 51 | return(c(NormKernelTmp)) 52 | } else { 53 | return(NormKernelTmp) 54 | } 55 | } 56 | 57 | -------------------------------------------------------------------------------- /R/demeanFuc.R: -------------------------------------------------------------------------------- 1 | ### demeanFuc: see FPCReg 2 | 3 | demeanFuc <- function(p, varsTrain, kern, varsOptns) { 4 | for (i in 1:(p+1)) { 5 | userBwMuXi <- SetOptions(varsTrain[[i]]$Ly, varsTrain[[i]]$Lt, varsOptns[[i]])$userBwMu 6 | varsTrain[[i]] <- list(Lt = varsTrain[[i]]$Lt, Ly = varsTrain[[i]]$Ly, userBwMu = userBwMuXi) 7 | } 8 | tmp <- lapply(varsTrain, function(x) { 9 | Tin <- sort(unique(unlist(x[['Lt']]))) 10 | xmu <- GetSmoothedMeanCurve(x[['Ly']], x[['Lt']], Tin, Tin[1], list(userBwMu = x[['userBwMu']], kernel=kern))[['mu']] 11 | muFun<-approxfun(Tin, xmu) 12 | x[['Ly']] <- lapply(1:length(x[['Ly']]), function(i) x[['Ly']][[i]] - muFun(x[['Lt']][[i]])) 13 | xmu <- muFun 14 | list(x = x, mu = xmu) 15 | }) 16 | xList <- lapply(tmp, `[[`, 'x') 17 | muList <- lapply(tmp, `[[`, 'mu') 18 | list(xList = xList, muList = muList) 19 | } 20 | 21 | dx <- function(p, intLenX, gridNumX, brkX){ 22 | for(i in 1:p){ 23 | if (i == 1) {dxMatrix <- diag(intLenX[1] / (gridNumX[1] - 1), gridNumX[1])}else{dxMatrix <- cdiag(dxMatrix, diag(intLenX[i] / (gridNumX[i]-1), gridNumX[i]))} 24 | dxMatrix[brkX[i]+1, brkX[i]+1] <- dxMatrix[brkX[i]+1, brkX[i]+1]/2 25 | dxMatrix[brkX[i+1], brkX[i+1]] <- dxMatrix[brkX[i+1], brkX[i+1]]/2 26 | } 27 | dxMatrix <- sqrt(as.matrix(dxMatrix)) 28 | return(dxMatrix) 29 | } 30 | 31 | cdiag <- function(A,B){ 32 | if(is.matrix(A)==0){A <- as.matrix(A)} 33 | if(is.matrix(B)==0){B <- as.matrix(B)} 34 | nrow <- dim(A)[1]+dim(B)[1] 35 | ncol <- dim(A)[2]+dim(B)[2] 36 | C <- array(0,c(nrow,ncol)) 37 | C[1:dim(A)[1],1:dim(A)[2]] <- A 38 | C[(dim(A)[1]+1):(dim(A)[1]+dim(B)[1]),(dim(A)[2]+1):(dim(A)[2]+dim(B)[2])] <- B 39 | return(C) 40 | } 41 | 42 | -------------------------------------------------------------------------------- /tests/testthat/test_CreateTrueMean.R: -------------------------------------------------------------------------------- 1 | 2 | myEps <- .Machine$double.eps; 3 | 4 | test_that(" basic 0/1 combination matches MATLAB output ", { 5 | expect_equal( CreateTrueMean(1,0), 0) 6 | expect_equal( CreateTrueMean(0,1), 0) 7 | expect_equal( CreateTrueMean(0,0), 0) 8 | expect_equal( CreateTrueMean(1,1), 1.841470984807897, tolerance = 2*myEps, scale = 1) 9 | }) 10 | 11 | test_that(" 'multiple t, single p'-case matches MATLAB output ", { 12 | expect_equal( CreateTrueMean( c(0.1, 1.3), 3), c(0.199833416646828, 2.263558185417193), tolerance = 2*myEps, scale = 1 ) 13 | expect_equal( CreateTrueMean( c(0.1, 1.3), 1), c(0.199833416646828, 0) , tolerance = 2*myEps, scale = 1 ) 14 | }) 15 | 16 | test_that(" 'single t, multiple p'-case matches MATLAB output ", { 17 | expect_equal( CreateTrueMean( 1, c(0.1, 1.3)), 0 ) 18 | expect_equal( CreateTrueMean( 3, c(0.1, 1.3)), c(0, 0) ) 19 | }) 20 | 21 | test_that(" 'multiple t, multiple p'-case matches MATLAB output ", { 22 | expect_equal( CreateTrueMean( c(3, 1), c(0.1, 1.3)), c(0, 1.841470984807897), tolerance = 2*myEps, scale = 1) 23 | expect_equal( CreateTrueMean( c(1, 3), c(0.1, 1.3)), c(0, 0) , tolerance = 2*myEps, scale = 1) 24 | expect_equal( CreateTrueMean( c(0.1, 1.3), c(3, 1)), c(0.199833416646828, 0), tolerance = 2*myEps, scale = 1) 25 | expect_equal( CreateTrueMean( c(0.1, 1.3), c(1, 3)), c(0.199833416646828, 2.263558185417193), tolerance = 2*myEps, scale = 1) 26 | expect_equal( CreateTrueMean( c(1.1, 0.3), c(3, 1)), c(1.991207360061436, 0.595520206661340), tolerance = 2*myEps, scale = 1) 27 | expect_equal( CreateTrueMean( c(1.1, 0.3), c(1, 3)), c(0, 0.595520206661340), tolerance = 2*myEps, scale = 1) 28 | }) 29 | 30 | # cat("Done") -------------------------------------------------------------------------------- /R/CreateScreePlot.R: -------------------------------------------------------------------------------- 1 | #' Create the scree plot for the fitted eigenvalues 2 | #' 3 | #' This function will open a new device if not instructed otherwise. 4 | #' 5 | #' @param fpcaObj A object of class FPCA returned by the function FPCA(). 6 | #' @param ... Additional arguments for the 'plot' function. 7 | #' 8 | #' @examples 9 | #' set.seed(1) 10 | #' n <- 20 11 | #' pts <- seq(0, 1, by=0.05) 12 | #' sampWiener <- Wiener(n, pts) 13 | #' sampWiener <- Sparsify(sampWiener, pts, 10) 14 | #' res <- FPCA(sampWiener$Ly, sampWiener$Lt, 15 | #' list(dataType='Sparse', error=FALSE, kernel='epan', verbose=TRUE)) 16 | #' CreateScreePlot(res) 17 | #' @export 18 | 19 | CreateScreePlot <-function(fpcaObj, ...){ 20 | 21 | args1 <- list( main="Scree plot", ylab='Fraction of variance explained', xlab='Number of components') 22 | inargs <- list(...) 23 | args1[names(inargs)] <- inargs 24 | 25 | ys <- fpcaObj$cumFVE ; 26 | 27 | 28 | if( !is.vector(ys) ){ 29 | stop('Please use a vector as input.') 30 | } 31 | if(max(ys) > 1){ 32 | warning('The maximum number in the input vector is larger than 1; are you sure it is right?'); 33 | } 34 | if(any(ys < 0) || any(diff(ys) <0) ){ 35 | stop('This is not a valid cumulative FVE vector.') 36 | } 37 | 38 | dfbar <- do.call( barplot, c( args1, list( ylim=c(0,1.05)), list(axes=FALSE), list(height = rep(NA,length(ys))) ) ) 39 | 40 | abline(h=(seq(0,1,.05)), col="lightgray", lty="dotted") 41 | barplot(c(ys[1], diff(ys)), add = TRUE , names.arg = as.character(1:fpcaObj$selectK)) 42 | lines(dfbar, y= ys, col='red') 43 | points(dfbar, y= ys, col='red') 44 | legend("right", "Cumul. FVE", col='red', lty=1, pch=1, bty='n') 45 | 46 | } 47 | -------------------------------------------------------------------------------- /man/CreateModeOfVarPlot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/CreateModeOfVarPlot.R 3 | \name{CreateModeOfVarPlot} 4 | \alias{CreateModeOfVarPlot} 5 | \title{Functional Principal Component Analysis: Mode of variation plot} 6 | \usage{ 7 | CreateModeOfVarPlot( 8 | fpcaObj, 9 | k = 1, 10 | rainbowPlot = FALSE, 11 | colSpectrum = NULL, 12 | ... 13 | ) 14 | } 15 | \arguments{ 16 | \item{fpcaObj}{An FPCA class object returned by FPCA().} 17 | 18 | \item{k}{The k-th mode of variation to plot (default k = 1)} 19 | 20 | \item{rainbowPlot}{Indicator to create a rainbow-plot instead of a shaded plot (default: FALSE)} 21 | 22 | \item{colSpectrum}{Character vector to be use as input in the 'colorRampPalette' function defining the outliers colours (default: c("blue","red", "green"), relevant only for rainbowPlot=TRUE)} 23 | 24 | \item{...}{Additional arguments for the \code{plot} function.} 25 | } 26 | \description{ 27 | Creates the k-th mode of variation plot around the mean. The red-line is 28 | the functional mean, the grey shaded areas show the range of variation 29 | around the mean: \eqn{ \pm Q \sqrt{\lambda_k} \phi_k}{+/- Q sqrt{lambda_k} phi_k} 30 | for the dark grey area Q = 1, and for the light grey are Q = 2. In the case of 'rainbowPlot' 31 | the blue edge corresponds to Q = -3, the green edge to Q = +3 and the red-line to Q = 0 (the mean). 32 | } 33 | \examples{ 34 | set.seed(1) 35 | n <- 20 36 | pts <- seq(0, 1, by=0.05) 37 | sampWiener <- Wiener(n, pts) 38 | sampWiener <- Sparsify(sampWiener, pts, 10) 39 | res <- FPCA(sampWiener$Ly, sampWiener$Lt, 40 | list(dataType='Sparse', error=FALSE, kernel='epan', verbose=TRUE)) 41 | CreateModeOfVarPlot(res) 42 | } 43 | -------------------------------------------------------------------------------- /man/plot.FPCA.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/CreateDiagnosticsPlot.R, R/plot.FPCA.R 3 | \name{CreateDiagnosticsPlot} 4 | \alias{CreateDiagnosticsPlot} 5 | \alias{plot.FPCA} 6 | \title{Functional Principal Component Analysis Diagnostics plot} 7 | \usage{ 8 | CreateDiagnosticsPlot(...) 9 | 10 | \method{plot}{FPCA}(x, openNewDev = FALSE, addLegend = TRUE, ...) 11 | } 12 | \arguments{ 13 | \item{...}{passed into \code{plot.FPCA}.} 14 | 15 | \item{x}{An FPCA class object returned by FPCA().} 16 | 17 | \item{openNewDev}{A logical specifying if a new device should be opened - default: FALSE} 18 | 19 | \item{addLegend}{A logical specifying whether to add legend.} 20 | } 21 | \description{ 22 | Deprecated. Use \code{plot.FPCA} instead. 23 | 24 | Plotting the results of an FPCA, including printing the design plot, mean function, scree-plot 25 | and the first three eigenfunctions for a functional sample. If provided with a derivative options object (?FPCAder), it will return the 26 | differentiated mean function and first two principal modes of variation for 50\%, 75\%, 100\%, 125\% and 150\% of the defined bandwidth choice. 27 | } 28 | \details{ 29 | The black, red, and green curves stand for the first, second, and third eigenfunctions, respectively. 30 | \code{plot.FPCA} is currently implemented only for the original function, but not a derivative FPCA object. 31 | } 32 | \examples{ 33 | set.seed(1) 34 | n <- 20 35 | pts <- seq(0, 1, by=0.05) 36 | sampWiener <- Wiener(n, pts) 37 | sampWiener <- Sparsify(sampWiener, pts, 10) 38 | res1 <- FPCA(sampWiener$Ly, sampWiener$Lt, 39 | list(dataType='Sparse', error=FALSE, kernel='epan', verbose=FALSE)) 40 | plot(res1) 41 | } 42 | -------------------------------------------------------------------------------- /R/Lwls1D.R: -------------------------------------------------------------------------------- 1 | #' One dimensional local linear kernel smoother 2 | #' 3 | #' One dimensional local linear kernel smoother for longitudinal data. 4 | #' 5 | #' @param bw Scalar holding the bandwidth 6 | #' @param kernel_type Character holding the kernel type (see ?FPCA for supported kernels) 7 | #' @param win Vector of length N with weights 8 | #' @param xin Vector of length N with measurement points 9 | #' @param yin Vector of length N with measurement values 10 | #' @param xout Vector of length M with output measurement points 11 | #' @param npoly Scalar (integer) degree of polynomial fitted (default 1) 12 | #' @param nder Scalar (integer) degree of derivative fitted (default 0) 13 | #' 14 | #' @return Vector of length M with measurement values at the the point specified by 'xout' 15 | #' 16 | #' @export 17 | 18 | 19 | Lwls1D <- function( bw, kernel_type, win=rep(1L, length(xin)), xin, yin, xout, npoly = 1L, nder = 0L){ 20 | 21 | if(is.unsorted(xin)){ 22 | stop('`xin` needs to be sorted in increasing order') 23 | } 24 | 25 | if(is.unsorted(xout)){ 26 | stop('`xout` needs to be sorted in increasing order') 27 | } 28 | 29 | if(all(is.na(win)) || all(is.na(xin)) || all(is.na(yin))){ 30 | stop(' win, xin or yin contain only NAs!') 31 | } 32 | 33 | # Deal with NA/NaN measurement values 34 | NAinY = is.na(xin) | is.na(yin) | is.na(win) 35 | if(any(NAinY)){ 36 | win = win[!NAinY] 37 | xin = xin[!NAinY] 38 | yin = yin[!NAinY] 39 | } 40 | 41 | return( CPPlwls1d(bw= as.numeric(bw), kernel_type = kernel_type, npoly= as.integer(npoly), nder= as.integer(nder), 42 | xin = as.numeric(xin), yin= as.numeric(yin), xout= as.numeric(xout), win = as.numeric(win))) 43 | } 44 | 45 | -------------------------------------------------------------------------------- /tests/testthat/test_GetCovDense.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | library(testthat) 3 | ##options(error=recover) 4 | 5 | trueLam <- 4 / ((2 * (1:50) - 1 ) * pi) ^ 2 6 | 7 | test_that('GetCovDense fails when data is too sparse', { 8 | 9 | set.seed(1) 10 | n <- 200 11 | p <- 101 12 | pts <- seq(0, 1, length.out=p) 13 | sigma2 <- 0.1 14 | mu <- pts 15 | samp <- Wiener(n, pts) + matrix(pts, n, p, byrow=TRUE) + 16 | rnorm(n * length(pts), sd=sqrt(sigma2)) 17 | samp[seq_len(n - 1), 1] <- NA # only subject 1 was observed at the first time point 18 | expect_error(GetCovDense(samp, colMeans(samp), list(error=FALSE, dataType='DenseWithMV')), 19 | "Data is too sparse to be considered DenseWithMV. Remove sparse observations or specify dataType='Sparse' for FPCA") 20 | 21 | }) 22 | 23 | 24 | test_that('GetCovDense with noise, get sigma2', { 25 | set.seed(1) 26 | n <- 200 27 | p <- 101 28 | pts <- seq(0, 1, length.out=p) 29 | sigma2 <- 0.1 30 | mu <- pts 31 | samp <- Wiener(n, pts) + matrix(pts, n, p, byrow=TRUE) + 32 | rnorm(n * length(pts), sd=sqrt(sigma2)) 33 | tmp <- MakeFPCAInputs(tVec=pts, yVec=samp) 34 | 35 | optnsNoerr <- SetOptions(tmp$Ly, tmp$Lt, list(error=FALSE, dataType='Dense')) 36 | optnsErr <- SetOptions(tmp$Ly, tmp$Lt, list(error=TRUE, dataType='Dense')) 37 | noerr <- GetCovDense(samp, colMeans(samp), optnsNoerr) 38 | err <- GetCovDense(samp, colMeans(samp), optnsErr) 39 | 40 | eigNoerr <- GetEigenAnalysisResults(noerr$smoothCov, pts, optnsNoerr) 41 | eigErr <- GetEigenAnalysisResults(err$smoothCov, pts, optnsErr) 42 | 43 | expect_equal(err$sigma2, sigma2, tolerance=1e-2) 44 | expect_equal(eigNoerr$fittedCov, eigNoerr$fittedCov) 45 | }) 46 | -------------------------------------------------------------------------------- /tests/testthat/test_FClust.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | library(testthat) 3 | 4 | test_that('the growth example works.', { 5 | 6 | 7 | A <- read.table(system.file('testdata', 'growth.dat', 8 | package='fdapace')) 9 | B <- MakeFPCAInputs( IDs = A[,1], tVec = A$V3, yVec = A$V4) 10 | C <- FClust(B$Ly, B$Lt, k = 2, cmethod = 'EMCluster') 11 | D <- FClust(B$Ly, B$Lt, k = 2, cmethod = 'kCFC') 12 | trueClusters <- A$V2[!duplicated(A$V1)] 13 | N = length(trueClusters) 14 | cRates <- c( sum(trueClusters == C$cluster), sum(trueClusters == C$cluster) )/N # 0.9677 & 0.9355 15 | cRates <- sapply(cRates, function(x) ifelse(x < 0.5, 1- x, x)) 16 | 17 | expect_gt( cRates[2], 0.935) # kCFC 18 | expect_gt( cRates[1], 0.967) # Rmixmod 19 | 20 | load(system.file('data', 'medfly25.RData', package='fdapace')) 21 | Flies <- MakeFPCAInputs(medfly25$ID, medfly25$Days, medfly25$nEggs) 22 | for (i in 1:3) { 23 | set.seed(i) 24 | A <- FClust(Flies$Ly, Flies$Lt, optnsFPCA = list(methodMuCovEst = 'smooth', userBwCov = 2, FVEthreshold = 0.90)) 25 | # B <- FClust(Flies$Ly, Flies$Lt, optnsFPCA = list(methodMuCovEst = 'smooth', userBwCov = 2, FVEthreshold = 0.90), k = 2, seed=i) 26 | } 27 | }) 28 | 29 | test_that('the k-means initialisation error occurs normally.', { 30 | 31 | set.seed(1) 32 | n <- 100 33 | p <- 101 34 | pts <- seq(0, 1, length.out=p) 35 | sigma2 <- 0.1 36 | mu <- pts 37 | sampTrue <- Wiener(n, pts) + matrix(pts, n, p, byrow=TRUE) 38 | samp <- sampTrue + rnorm(n * length(pts), sd=sqrt(sigma2)) 39 | tmp <- MakeFPCAInputs(tVec=pts, yVec=samp) 40 | expect_error(FClust(tmp$Ly, tmp$Lt, k = 14, cmethod = "kCFC", optnsFPCA = list(userBwCov= 2, FVEthreshold = 0.90)) ) 41 | 42 | }) 43 | -------------------------------------------------------------------------------- /man/FVPA.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/FVPA.R 3 | \name{FVPA} 4 | \alias{FVPA} 5 | \title{Functional Variance Process Analysis for dense functional data} 6 | \usage{ 7 | FVPA(y, t, q = 0.1, optns = list(error = TRUE, FVEthreshold = 0.9)) 8 | } 9 | \arguments{ 10 | \item{y}{A list of \emph{n} vectors containing the observed values for each individual. Missing values specified by \code{NA}s are supported for dense case (\code{dataType='dense'}).} 11 | 12 | \item{t}{A list of \emph{n} vectors containing the observation time points for each individual corresponding to y.} 13 | 14 | \item{q}{A scalar defining the percentile of the pooled sample residual sample used for adjustment before taking log (default: 0.1).} 15 | 16 | \item{optns}{A list of options control parameters specified by \code{list(name=value)}; by default: 'error' has to be TRUE, 'FVEthreshold' is set to 0.90. See `Details in ?FPCA'.} 17 | } 18 | \value{ 19 | A list containing the following fields: 20 | \item{sigma2}{Variance estimator of the functional variance process.} 21 | \item{fpcaObjY}{FPCA object for the original data.} 22 | \item{fpcaObjR}{FPCA object for the functional variance process associated with the original data.} 23 | } 24 | \description{ 25 | Functional Variance Process Analysis for dense functional data 26 | } 27 | \examples{ 28 | set.seed(1) 29 | n <- 25 30 | pts <- seq(0, 1, by=0.01) 31 | sampWiener <- Wiener(n, pts) 32 | # Data have to dense for FVPA to be relevant! 33 | sampWiener <- Sparsify(sampWiener, pts, 101) 34 | fvpaObj <- FVPA(sampWiener$Ly, sampWiener$Lt) 35 | } 36 | \references{ 37 | \cite{Hans-Georg Müller, Ulrich Stadtmüller and Fang Yao, "Functional variance processes." Journal of the American Statistical Association 101 (2006): 1007-1018} 38 | } 39 | -------------------------------------------------------------------------------- /man/GetMeanCI.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/GetMeanCI.R 3 | \name{GetMeanCI} 4 | \alias{GetMeanCI} 5 | \title{Bootstrap pointwise confidence intervals for the mean function for densely observed data.} 6 | \usage{ 7 | GetMeanCI(Ly, Lt, level = 0.95, R = 999, optns = list()) 8 | } 9 | \arguments{ 10 | \item{Ly}{A list of n vectors containing the observed values for each individual. 11 | Missing values specified by \code{NA}s are supported for dense case \code{(dataType='dense')}.} 12 | 13 | \item{Lt}{A list of n vectors containing the observation time points for each 14 | individual corresponding to each element in \code{Ly}. Each vector should be sorted in ascending order.} 15 | 16 | \item{level}{A number taking values in [0,1] determing the confidence level. Default: 0.95.} 17 | 18 | \item{R}{An integer holding the number of bootstrap replicates. Default: 999.} 19 | 20 | \item{optns}{A list of options; see \code{\link{FPCA}} for details.} 21 | } 22 | \value{ 23 | A list of two elements: 24 | \item{CI}{A data frame holding three variables: \code{CIgrid} --- the time grid where the CIs are evaluated; \code{lower} and \code{upper} --- the lower and upper bounds of the CIs on \code{CIgrid}.} 25 | \item{level}{The confidence level of the CIs}. 26 | } 27 | \description{ 28 | Note that bootstrap pointwise confidence intervals do not work for sparsely observed data. 29 | } 30 | \examples{ 31 | n <- 30 32 | tgrid <- seq(0,1,length.out=21) 33 | phi1 <- function(t) sqrt(2)*sin(2*pi*t) 34 | phi2 <- function(t) sqrt(2)*sin(4*pi*t) 35 | Lt <- rep(list(tgrid), n) 36 | Ly <- lapply(1:n, function(i){ 37 | tgrid + rnorm(1,0,2) * phi1(tgrid) + rnorm(1,0,0.5) * phi2(tgrid) + rnorm(1,0,0.01) 38 | }) 39 | res <- GetMeanCI(Lt = Lt, Ly = Ly, level = 0.9) 40 | } 41 | -------------------------------------------------------------------------------- /tests/testthat/test_CreateFolds.R: -------------------------------------------------------------------------------- 1 | #options(error=recover) 2 | library(testthat) 3 | 4 | test_that('SimpleFolds works', { 5 | samp <- 1:10 6 | res1 <- SimpleFolds(samp, 10) 7 | expect_equal(length(res1), 10) 8 | expect_equal(sum(sapply(res1, length)), length(samp)) 9 | expect_equal(diff(range(sapply(res1, length))), 0) 10 | 11 | samp <- 20:60 12 | res2 <- SimpleFolds(samp, 10) 13 | expect_equal(length(res2), 10) 14 | expect_equal(sum(sapply(res2, length)), length(samp)) 15 | expect_equal(diff(range(sapply(res2, length))), 1) 16 | }) 17 | 18 | test_that('CreateFolds works for numeric responses', { 19 | set.seed(1) 20 | samp1 <- CreateFolds(rnorm(55), 10) 21 | sampVec1 <- sort(do.call(c, samp1)) 22 | expect_true(diff(range(sapply(samp1, length))) <= 5) 23 | expect_equal(sampVec1, seq_along(sampVec1)) 24 | 25 | samp2 <- CreateFolds(rnorm(5), 10) 26 | sampVec2 <- sort(do.call(c, samp2)) 27 | expect_true(diff(range(sapply(samp2, length))) <= 1) 28 | expect_equal(sampVec2, seq_along(sampVec2)) 29 | }) 30 | 31 | test_that('CreateFolds works for factor/class responses', { 32 | set.seed(1) 33 | nclass <- 2 34 | tmp <- sample(c(rep(0, 10), rep(1, 11))) 35 | samp3 <- CreateFolds(tmp, 10) 36 | expect_true(diff(range(sapply(samp3, length))) <= nclass) 37 | expect_true(all(sapply(samp3, function(ind) any(tmp[ind] == 0) && any(tmp[ind] == 1)))) 38 | 39 | nclass <- 3 40 | tmp <- sample(c(rep(1, 10), rep(2, 11), rep(3, 5))) 41 | tmp <- factor(tmp) 42 | samp4 <- CreateFolds(tmp, 10) 43 | expect_true(diff(range(sapply(samp4, length))) <= nclass) 44 | expect_true(all(sapply(samp4, function(ind) sum(table(tmp[ind]) != 0) >= 2))) 45 | }) 46 | 47 | # debug(CreateFolds) 48 | # undebug(CreateFolds) 49 | # debug(SimpleFolds) 50 | # undebug(SimpleFolds) 51 | -------------------------------------------------------------------------------- /R/GetMinb.R: -------------------------------------------------------------------------------- 1 | # Approximate the minimum bandwidth choice for the covariance function. 2 | # Instead of the getMinb.m functionality this garantees a minimal number of neighboring points 3 | # Note: distMat is memory-inefficient. 4 | GetMinb <- function(t, obsGrid, dataType='Sparse', npoly=1, minUniqPts=3, minPts=6, legacyCode = FALSE) { 5 | 6 | 7 | if( legacyCode ){ 8 | if (dataType == 'Sparse') { 9 | dstar <- Minb(obsGrid, 2 + npoly) # rough 1D initial value 10 | n_obs = length(obsGrid); 11 | tmp1 = matrix( rep(0, n_obs^2), ncol = n_obs) 12 | 13 | # Find the pair against which we have measurements in the same curve 14 | for (i in 1:length(t)){ 15 | idx = match( t[[i]], obsGrid) 16 | tmp1[idx, idx] = 1 17 | } 18 | res = tmp1 - diag(n_obs); 19 | # First and last timepoint are always considered observed 20 | res[c(1, n_obs),] = 1; 21 | ids = matrix(res > 0); 22 | b = matrix( rep(obsGrid, n_obs), nrow=n_obs); 23 | # Use half of the largest difference between two consequative points in the same 24 | # as curve as your candidate bandwith. We do no worry about the difference 25 | # between to [t_j(end) - t_{1+j}(1)] because this will be negative. This bandwidth tends to be conservative (too large). 26 | # dstar = max(dstar, max(diff(b[ids])/2)); # Original code 27 | dstar = max(dstar, quantile( diff(b[ids]), 0.95)/2 ); # Fix to avoid outliers 28 | } else if (dataType == 'RegularWithMV') { 29 | dstar <- Minb(obsGrid, 1 + npoly) * 2; 30 | } else if (dataType == 'Dense') { 31 | dstar = Minb(obsGrid, 2 + npoly) * 1.5; 32 | } 33 | return(dstar) 34 | } 35 | 36 | dstar = BwNN(t, k= 2 + npoly, onlyCov = TRUE)['cov'] 37 | 38 | return(dstar) 39 | } 40 | -------------------------------------------------------------------------------- /R/NWMgnReg.R: -------------------------------------------------------------------------------- 1 | ##### 2 | ##### Nadaraya-Watson marginal regression estimation 3 | ##### 4 | 5 | ##### input variables: 6 | ##### Y: response observation points (n-dim. vector) 7 | ##### kj: index of conditional projection for the k-th component function on the j-th component function space (2-dim. vector) 8 | ##### x: estimation grid (N*d matrix) 9 | ##### X: covariate observation grid (n*d matrix) 10 | ##### h: bandwidths (d-dim. vector) 11 | ##### K: kernel function (function object, default is the Epanechnikov kernel) 12 | ##### supp: supports of estimation interested (d*2 matrix) 13 | 14 | ##### output: 15 | ##### NW marginal regression function kernel estimators at each estimation point (N*d matrix) 16 | 17 | NWMgnReg <- function(Y, x, X, h=NULL, K='epan', supp=NULL){ 18 | 19 | N <- nrow(x) 20 | d <- ncol(x) 21 | n <- nrow(X) 22 | 23 | if (K!='epan') { 24 | message('Epanechnikov kernel is only supported currently. It uses Epanechnikov kernel automatically') 25 | K<-'epan' 26 | } 27 | if (is.null(supp)==TRUE) { 28 | supp <- matrix(rep(c(0,1),d),ncol=2,byrow=TRUE) 29 | } 30 | if (is.null(h)==TRUE) { 31 | h <- rep(0.25*n^(-1/5),d)*(supp[,2]-supp[,1]) 32 | } 33 | 34 | fNW <- matrix(0,nrow=N,ncol=d) 35 | 36 | tmpIndex <- rep(1,n) 37 | for (j in 1:d) { 38 | tmpIndex <- tmpIndex*dunif(X[,j],supp[j,1],supp[j,2])*(supp[j,2]-supp[j,1]) 39 | } 40 | tmpIndex <- which(tmpIndex==1) 41 | 42 | for (j in 1:d) { 43 | pHatj <- NormKernel(x[,j],X[,j],h[j],K,c(supp[j,1],supp[j,2])) 44 | rHatj <- c(pHatj[,tmpIndex]%*%Y[tmpIndex])/length(Y) 45 | 46 | pHatj <- apply(pHatj[,tmpIndex],1,'sum')/length(Y) 47 | 48 | tmpInd <- which(pHatj!=0) 49 | 50 | fNW[tmpInd,j] <- rHatj[tmpInd]/pHatj[tmpInd] 51 | } 52 | 53 | return(fNW) 54 | } 55 | 56 | -------------------------------------------------------------------------------- /man/CreateCovPlot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/CreateCovPlot.R 3 | \name{CreateCovPlot} 4 | \alias{CreateCovPlot} 5 | \title{Creates a correlation surface plot based on the results from FPCA() or FPCder().} 6 | \usage{ 7 | CreateCovPlot( 8 | fpcaObj, 9 | covPlotType = "Fitted", 10 | corr = FALSE, 11 | isInteractive = FALSE, 12 | colSpectrum = NULL, 13 | ... 14 | ) 15 | } 16 | \arguments{ 17 | \item{fpcaObj}{returned object from FPCA().} 18 | 19 | \item{covPlotType}{a string specifying the type of covariance surface to be plotted: 20 | 'Smoothed': plot the smoothed cov surface 21 | 'Fitted': plot the fitted cov surface} 22 | 23 | \item{corr}{a boolean value indicating whether to plot the fitted covariance or correlation surface from the fpca object 24 | TRUE: fitted correlation surface; 25 | FALSE: fitted covariance surface; 26 | default is FALSE; 27 | Only plotted for fitted fpca objects} 28 | 29 | \item{isInteractive}{an option for interactive plot: 30 | TRUE: interactive plot; FALSE: printable plot} 31 | 32 | \item{colSpectrum}{character vector to be use as input in the 'colorRampPalette' function defining the colouring scheme (default: c('blue','red'))} 33 | 34 | \item{...}{other arguments passed into persp3d, persp3D, plot3d or points3D for plotting options} 35 | } 36 | \description{ 37 | This function will open a new device if not instructed otherwise. 38 | } 39 | \examples{ 40 | set.seed(1) 41 | n <- 20 42 | pts <- seq(0, 1, by=0.05) 43 | sampWiener <- Wiener(n, pts) 44 | sampWiener <- Sparsify(sampWiener, pts, 10) 45 | res <- FPCA(sampWiener$Ly, sampWiener$Lt, 46 | list(dataType='Sparse', error=FALSE, kernel='epan', verbose=TRUE)) 47 | CreateCovPlot(res) ##plotting the covariance surface 48 | CreateCovPlot(res, corr = TRUE) ##plotting the correlation surface 49 | } 50 | -------------------------------------------------------------------------------- /man/DynCorr.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/DynCorr.R 3 | \name{DynCorr} 4 | \alias{DynCorr} 5 | \title{Dynamical Correlation} 6 | \usage{ 7 | DynCorr(x, y, t) 8 | } 9 | \arguments{ 10 | \item{x}{a n by m matrix where rows representing subjects and columns representing measurements, missings are allowed.} 11 | 12 | \item{y}{a n by m matrix where rows representing subjects and columns representing measurements, missings are allowed.} 13 | 14 | \item{t}{a length m vector of time points where x,y are observed.} 15 | } 16 | \value{ 17 | A length n vector of individual dynamic correlations. The dynamic correlation can be obtained by taking average of this vector. 18 | } 19 | \description{ 20 | Calculates the Dynamical Correlation for 2 paired dense regular functional data observed on the same grid. 21 | } 22 | \examples{ 23 | set.seed(10) 24 | n=200 # sample size 25 | t=seq(0,1,length.out=100) # length of data 26 | mu_quad_x=8*t^2-4*t+5 27 | mu_quad_y=8*t^2-12*t+6 28 | fun=rbind(rep(1,length(t)),-t,t^2) 29 | z1=matrix(0,n,3) 30 | z1[,1]=rnorm(n,0,2) 31 | z1[,2]=rnorm(n,0,16/3) 32 | z1[,3]=rnorm(n,0,4) 33 | x1_quad_error=y1_quad_error=matrix(0,nrow=n,ncol=length(t)) 34 | for (i in 1:n){ 35 | x1_quad_error[i,]=mu_quad_x+z1[i,]\%*\%fun+rnorm(length(t),0,0.01) 36 | y1_quad_error[i,]=mu_quad_y+2*z1[i,]\%*\%fun +rnorm(length(t),0,0.01) 37 | } 38 | dyn1_quad=DynCorr(x1_quad_error,y1_quad_error,t) 39 | } 40 | \references{ 41 | \cite{Dubin J A, Müller H G. Dynamical correlation for multivariate longitudinal data (2005). 42 | Journal of the American Statistical Association 100(471): 872-881.} 43 | \cite{Liu S, Zhou Y, Palumbo R, Wang, J.L. (2016). Dynamical correlation: A new method for quantifying synchrony with 44 | multivariate intensive longitudinal data. Psychological methods 21(3): 291.} 45 | } 46 | -------------------------------------------------------------------------------- /R/GetBinnedDataset.R: -------------------------------------------------------------------------------- 1 | GetBinnedDataset <- function (y, t, optns){ 2 | 3 | # Bin the data 'y' 4 | # y : n-by-1 list of vectors 5 | # t : n-by-1 list of vectors 6 | 7 | BinDataOutput <- list( newy=NULL, newt=NULL); 8 | 9 | dataType = optns$dataType; 10 | verbose = optns$verbose; 11 | numBins = optns$numBins; 12 | tt = unlist(t); 13 | a0 = min(tt); 14 | b0 = max(tt); 15 | 16 | n = length(t); 17 | ni = sapply(FUN= length,t); 18 | 19 | if (dataType == 'Sparse'){ 20 | m = median(ni) 21 | } else { 22 | m = max(ni); 23 | } 24 | 25 | # Determine the number of bins automatically if numBins is null 26 | if (is.null(numBins) && optns$useBinnedData =='AUTO'){ 27 | numBins = GetBinNum(n,m,dataType,verbose) 28 | # and if it is still NULL return the unbinned data 29 | if (is.null(numBins)){ 30 | BinDataOutput$newt = t; 31 | BinDataOutput$newy = y; 32 | return( BinDataOutput ) 33 | } else if (optns$useBinnedData == 'AUTO') { 34 | warning('Automatically binning measurements. To turn off this warning set option useBinnedData to \'FORCE\' or \'OFF\'') 35 | } 36 | } 37 | # otherwise use the one provided by the user (ceiled) 38 | numBins = ceiling(numBins); 39 | 40 | resList <- lapply(1:n, function(i) 41 | GetBinnedCurve(t[[i]], y[[i]], numBins, TRUE, TRUE, c(a0, b0))) 42 | BinDataOutput[['newt']] <- lapply(resList, `[[`, 'midpoint') 43 | BinDataOutput[['newy']] <- lapply(resList, `[[`, 'newy') 44 | 45 | # for (i in 1:n){ 46 | # res = GetBinnedCurve(t[[i]], y[[i]], numBins, TRUE, TRUE, c(a0, b0)); 47 | # BinDataOutput$newt[[i]] = res$midpoint; 48 | # BinDataOutput$newy[[i]] = res$newy; 49 | # } 50 | 51 | result <- list( 'newt' = BinDataOutput$newt, 'newy' = BinDataOutput$newy, 52 | numBins = numBins) 53 | return(result) 54 | } 55 | 56 | 57 | -------------------------------------------------------------------------------- /R/BwNN.R: -------------------------------------------------------------------------------- 1 | #' Minimum bandwidth based on kNN criterion. 2 | #' 3 | #' Input a list of time points Lt, and the number of unique neighbors k. Obtain the minimum bandwidth guaranteeing k unique neighbours. 4 | #' 5 | #' @param Lt n-by-1 list of vectors 6 | #' @param k number of unique neighbors for cov and mu (default = 3) 7 | #' @param onlyCov Indicator to return only the minimum bandwidth for the covariance 8 | #' @param onlyMean Indicator to return only the minimum bandwidth for the mean 9 | #' @examples 10 | #' tinyGrid = list(c(1,7), c(2,3), 6, c(2,4), c(4,5)) 11 | #' BwNN(tinyGrid, k = 2) # c(3,2) 12 | #' @export 13 | 14 | BwNN <- function(Lt, k=3, onlyMean = FALSE, onlyCov = FALSE) { 15 | 16 | tPairs <- do.call(rbind, lapply(Lt, function(t) { 17 | expand.grid(t, t) 18 | })) 19 | 20 | if( k <1){ 21 | stop("You cannot have less than 1 neighbours.") 22 | } 23 | 24 | if( onlyMean && onlyCov){ 25 | stop("BwNN returns nothing!") 26 | } 27 | 28 | distNN2 = NULL 29 | distNN1 = NULL 30 | 31 | if( !onlyMean ){ 32 | uniqTPairs <- unique(tPairs) 33 | distNN2 <- FindNN(uniqTPairs, k) 34 | } 35 | 36 | if( !is.null(distNN2) && is.infinite(distNN2)){ 37 | stop("You are asking an unreasonable ammount of neighbours for the covariace.") 38 | } 39 | 40 | if( !onlyCov ){ 41 | gridPts <- sort(unique(uniqTPairs[, 1])) 42 | distNN1 <- max(diff(gridPts, lag=k)) 43 | } 44 | 45 | if( !is.null(distNN1) && is.infinite(distNN1)){ 46 | stop("You are asking an unreasonable ammount of neighbours for the mean.") 47 | } 48 | 49 | return(c(cov = distNN2, mu = distNN1)) 50 | } 51 | 52 | FindNN <- function(mat, k=3) { 53 | max(apply(mat, 1, function(x) { 54 | d <- abs(mat - matrix(1, nrow(mat), 1) %*% x) 55 | distTox <- pmax(d[, 1], d[, 2]) 56 | sort(distTox, partial=k + 1)[k + 1] 57 | })) 58 | } 59 | 60 | -------------------------------------------------------------------------------- /man/CreateDesignPlot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/CreateDesignPlot.R 3 | \name{CreateDesignPlot} 4 | \alias{CreateDesignPlot} 5 | \title{Create design plots for functional data. See Yao, F., Müller, H.G., Wang, J.L. (2005). Functional 6 | data analysis for sparse longitudinal data. J. American Statistical Association 100, 577-590 7 | for interpretation and usage of these plots. 8 | This function will open a new device as default.} 9 | \usage{ 10 | CreateDesignPlot( 11 | Lt, 12 | obsGrid = NULL, 13 | isColorPlot = TRUE, 14 | noDiagonal = TRUE, 15 | addLegend = TRUE, 16 | ... 17 | ) 18 | } 19 | \arguments{ 20 | \item{Lt}{a list of observed time points for functional data} 21 | 22 | \item{obsGrid}{a vector of sorted observed time points. Default are the 23 | unique time points in Lt.} 24 | 25 | \item{isColorPlot}{an option for colorful plot: 26 | TRUE: create color plot with color indicating counts 27 | FALSE: create black and white plot with dots indicating observed time pairs} 28 | 29 | \item{noDiagonal}{an option specifying plotting the diagonal design points: 30 | TRUE: remove diagonal time pairs 31 | FALSE: do not remove diagonal time pairs} 32 | 33 | \item{addLegend}{Logical, default TRUE} 34 | 35 | \item{...}{Other arguments passed into \code{plot()}.} 36 | } 37 | \description{ 38 | Create design plots for functional data. See Yao, F., Müller, H.G., Wang, J.L. (2005). Functional 39 | data analysis for sparse longitudinal data. J. American Statistical Association 100, 577-590 40 | for interpretation and usage of these plots. 41 | This function will open a new device as default. 42 | } 43 | \examples{ 44 | set.seed(1) 45 | n <- 20 46 | pts <- seq(0, 1, by=0.05) 47 | sampWiener <- Wiener(n, pts) 48 | sampWiener <- Sparsify(sampWiener, pts, 10) 49 | CreateDesignPlot(sampWiener$Lt, sort(unique(unlist(sampWiener$Lt)))) 50 | } 51 | -------------------------------------------------------------------------------- /man/CreateStringingPlot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/CreateStringingPlot.R 3 | \name{CreateStringingPlot} 4 | \alias{CreateStringingPlot} 5 | \title{Create plots for observed and stringed high dimensional data} 6 | \usage{ 7 | CreateStringingPlot(stringingObj, subset, ...) 8 | } 9 | \arguments{ 10 | \item{stringingObj}{A stringing object of class "Stringing", returned by the function Stringing.} 11 | 12 | \item{subset}{A vector of indices or a logical vector for subsetting the observations. If missing, first min(n,50) observations will be plotted where n is the sample size.} 13 | 14 | \item{...}{Other arguments passed into matplot for plotting options} 15 | } 16 | \description{ 17 | The function produces the following three plots: 18 | 1) A plot of predictors (standardized if specified so during stringing) in original order for a subset of observations; 19 | 2) A plot of predictors in stringed order for the same subset of observations; 20 | 3) A plot of the stringing function, which is the stringed order vs. the original order. 21 | } 22 | \details{ 23 | This approach is based on 24 | Chen, K., Chen, K., Müller, H.G., Wang, J.L. (2011). Stringing high-dimensional data for functional analysis. J. American Statistical Association 106, 275--284. 25 | } 26 | \examples{ 27 | set.seed(1) 28 | n <- 50 29 | wiener = Wiener(n = n)[,-1] 30 | p = ncol(wiener) 31 | rdmorder = sample(size = p, x=1:p, replace = FALSE) 32 | stringingfit = Stringing(X = wiener[,rdmorder], disOptns = "correlation") 33 | diff_norev = sum(abs(rdmorder[stringingfit$StringingOrder] - 1:p)) 34 | diff_rev = sum(abs(rdmorder[stringingfit$StringingOrder] - p:1)) 35 | if(diff_rev <= diff_norev){ 36 | stringingfit$StringingOrder = rev(stringingfit$StringingOrder) 37 | stringingfit$Ly = lapply(stringingfit$Ly, rev) 38 | } 39 | CreateStringingPlot(stringingfit, 1:20) 40 | 41 | } 42 | -------------------------------------------------------------------------------- /R/GetCrCorYX.R: -------------------------------------------------------------------------------- 1 | #' Create cross-correlation matrix from auto- and cross-covariance matrix 2 | #' 3 | #' 4 | #' @param ccXY The cross-covariance matrix between variables X and Y. 5 | #' @param ccXX The auto-covariance matrix of variable X or the diagonal of that matrix. 6 | #' @param ccYY The auto-covariance matrix of variable Y or the diagonal of that matrix. 7 | #' 8 | #' @return A cross-correlation matrix between variables X and Y. 9 | #' 10 | #' @export 11 | #' 12 | #' 13 | GetCrCorYX <- function(ccXY, ccXX , ccYY){ 14 | 15 | if(!is.matrix(ccXY)){ 16 | stop('The cross-covariance matrix is must be a matrix.') 17 | } 18 | 19 | if(!is.matrix(ccXX) && !is.vector(ccXX)){ 20 | stop('The auto-covariance matrix for X must be a matrix or vector.') 21 | } 22 | 23 | if(!is.matrix(ccYY) && !is.vector(ccYY)){ 24 | stop('The auto-covariance matrix for Y must be a matrix or vector.') 25 | } 26 | 27 | if(is.matrix(ccYY)){ 28 | diagYY = diag(ccYY) 29 | } else { 30 | diagYY =(ccYY) 31 | } 32 | 33 | if(is.matrix(ccXX)){ 34 | diagXX = diag(ccXX) 35 | } else { 36 | diagXX =(ccXX) 37 | } 38 | 39 | if( length(diagXX) != dim(ccXY)[1] ){ 40 | stop('The cross-covariance matrix for XY and the provided covariance for X are incompatible.') 41 | } 42 | 43 | if( length(diagYY) != dim(ccXY)[2] ){ 44 | stop('The cross-covariance matrix for XY and the provided covariance for Y are incompatible.') 45 | } 46 | 47 | if( any(1e-12> diagXX)){ 48 | stop('The provided covariance for X are unreasonable small or negative. Rescale/check your data.') 49 | } 50 | 51 | if( any(1e-12> diagYY)){ 52 | stop('The provided covariance for X are unreasonable small or negative. Rescale/check your data.') 53 | } 54 | 55 | # return (solve(sqrt(diag(diagXX))) %*% ccXY %*% solve(sqrt(diag(diagYY)))) 56 | return( diag(1/sqrt(diagXX) , nrow = length(diagXX)) %*% ccXY %*% diag(1/sqrt(diagYY), nrow = length(diagYY)) ) 57 | } 58 | 59 | 60 | 61 | -------------------------------------------------------------------------------- /R/GetINScores.R: -------------------------------------------------------------------------------- 1 | # This function obtains the FPC scores for dense 2 | # regular functional data by trapezoidal rule integration (see 3 | # https://en.wikipedia.org/wiki/Functional_principal_component_analysis) 4 | 5 | ###### 6 | # Input: 7 | ###### 8 | # yvec: length p vector of dense regular functional observations 9 | # tvec: length p vector of observed time grids for the functional observations 10 | ###### 11 | # Output: 12 | ###### 13 | # ret: xiEst: n by length(lambda) matrix of estimated FPC scores 14 | # fittedY: n by p matrix of fitted/recovered functional observations 15 | ########################################################################## 16 | 17 | GetINScores <- function(yvec, tvec, optns,obsGrid, mu, lambda, phi, sigma2=NULL){ 18 | 19 | if(is.vector(phi)){ 20 | phi=matrix(as.numeric(phi),nrow=length(phi),ncol=1) 21 | } 22 | 23 | if(length(lambda) != ncol(phi)){ 24 | stop('No. of eigenvalues is not the same as the no. of eigenfunctions.') 25 | } 26 | 27 | #tau = sort(unique(signif( unlist(t),14 ))) # get observed time grid 28 | ranget <- diff(range(tvec)) 29 | mu= approx(obsGrid,mu,tvec)$y 30 | cy = yvec - mu 31 | phi = apply(phi,2,function(phivec){return(approx(obsGrid,phivec,tvec)$y)}) 32 | 33 | if(!is.matrix(phi)){ 34 | phi=matrix(as.numeric(phi),nrow=1,ncol=length(phi)) 35 | } 36 | 37 | xiEst = matrix(0,length(lambda)) 38 | # Get Scores xiEst 39 | for(i in 1:length(lambda)){ 40 | temp = cy * phi[,i] 41 | xiEst[i,1] = trapzRcpp(X = tvec[!is.na(temp)], Y = temp[!is.na(temp)]) 42 | if (optns[['shrink']] && !is.null(sigma2)) { 43 | xiEst[i,1] <- xiEst[i,1] * lambda[i] / 44 | (lambda[i] + ranget * sigma2 / length(tvec)) 45 | } 46 | } 47 | 48 | # Get Fitted Y: n by p matrix on observed time grid 49 | fittedY = mu + t(phi %*% xiEst) 50 | 51 | ret = list('xiEst' = xiEst,xiVar=matrix(NA, length(lambda), length(lambda)), 'fittedY' = fittedY) 52 | 53 | return(ret) 54 | 55 | } 56 | -------------------------------------------------------------------------------- /R/CreateFolds.R: -------------------------------------------------------------------------------- 1 | # Returns the test sets indices for k-fold cross-validation. Stratified sampling is used. 2 | # y: the response vector, for stratifying 3 | # k: number of folds 4 | # returns: a list of length k, containing the test-set indices. 5 | CreateFolds <- function(y, k=10) { 6 | n <- length(y) 7 | if (n == 0) 8 | stop('response length is zero') 9 | 10 | uniqY <- unique(y) 11 | if (!is.factor(y) && length(y) / length(uniqY) >= k) { 12 | # Intepret the integer-valued y as class labels. Stratify if the number of class labels is <= 5. 13 | y <- factor(y) 14 | } else if (is.numeric(y)) { 15 | # 5-stratum Stratified sampling 16 | if (n >= 5 * k) { 17 | breaks <- unique(quantile(y, probs=seq(0, 1, length.out=5))) 18 | y <- as.integer(cut(y, breaks, include.lowest=TRUE)) 19 | } else 20 | y <- rep(1, length(y)) 21 | } 22 | 23 | sampList <- tapply(seq_along(y), y, SimpleFolds, k=k, simplify=FALSE) 24 | list0 <- list() 25 | length(list0) <- k 26 | samp <- Reduce(function(list1, list2) { 27 | mapply(c, list1, list2, SIMPLIFY=FALSE) 28 | }, sampList, list0) 29 | 30 | return(samp) 31 | } 32 | 33 | # Simple k-fold test-set samples. 34 | # Input a set of SAMPLES 35 | # Returns: a list of length k, containing the SAMPLES. 36 | SimpleFolds <- function(yy, k=10) { 37 | if (length(yy) > 1) 38 | allSamp <- sample(yy) 39 | else 40 | allSamp <- yy 41 | 42 | n <- length(yy) 43 | nEach <- n %/% k 44 | samp <- list() 45 | length(samp) <- k 46 | for (i in seq_along(samp)) { 47 | if (nEach > 0) 48 | samp[[i]] <- allSamp[1:nEach + (i - 1) * nEach] 49 | else 50 | samp[[i]] <- numeric(0) 51 | } 52 | restSamp <- allSamp[seq(nEach * k + 1, length(allSamp), length.out=length(allSamp) - nEach * k)] 53 | restInd <- sample(k, length(restSamp)) 54 | for (i in seq_along(restInd)) { 55 | sampInd <- restInd[i] 56 | samp[[sampInd]] <- c(samp[[sampInd]], restSamp[i]) 57 | } 58 | 59 | return(samp) 60 | } 61 | -------------------------------------------------------------------------------- /R/BinRawCov.R: -------------------------------------------------------------------------------- 1 | # Bin a `RawCov` object. Observations with the same time pairs are binned together and only one entry will be returned, containting the mean value (`meanVals`), weight (`count`), and residual sums of squares at each point (`RSS`). If `rcov$diag` is used then also bin the diagonal of the raw covariance similarly (with fields `diagMeans`, `diagRSS`, and `diagCount`. 2 | # rcov: A `RawCov` object. 3 | # returns: A list of class `BinnedRawCov`. 4 | BinRawCov <- function(rcov) { 5 | 6 | if ('RawCC' %in% class(rcov)) { 7 | rcov$cxxn <- rcov$rawCCov 8 | rcov$tPairs <- rcov$tpairn 9 | } 10 | # Get the count, mean raw cov, and residual sum of squares at each pair of observed time points. 11 | tmp <- aggregate(rcov$cxxn, list(rcov$tPairs[, 1], rcov$tPairs[, 2]), 12 | function(yy) c(RCPPmean(yy), length(yy), RCPPvar(yy) * (length(yy) - 1))) 13 | 14 | tPairs <- unname(as.matrix(tmp[, 1:2])) 15 | summaryDat <- tmp[, 3] 16 | meanVals <- summaryDat[, 1] 17 | count <- summaryDat[, 2] 18 | RSS <- summaryDat[, 3] # Residual sum of squares. For implementing GCV. 19 | RSS[is.na(RSS)] <- 0 20 | 21 | diagRSS <- diagCount <- diagMeans <- tDiag <- NULL 22 | if (!is.null(rcov$diag)) { 23 | tmp <- aggregate(rcov$diag[, 2], list(rcov$diag[, 1]), 24 | function(yy) c(RCPPmean(yy), length(yy), RCPPvar(yy) * (length(yy) - 1))) 25 | 26 | tDiag <- tmp[, 1] 27 | diagSummary <- tmp[, 2] 28 | diagMeans <- diagSummary[, 1] 29 | diagCount <- diagSummary[, 2] 30 | diagRSS <- diagSummary[, 3] 31 | diagRSS[is.na(diagRSS)] <- 0 32 | } 33 | 34 | res <- list(tPairs=tPairs, meanVals=meanVals, RSS=RSS, 35 | tDiag=tDiag, diagMeans=diagMeans, diagRSS=diagRSS, 36 | count=count, 37 | diagCount=diagCount, 38 | error=rcov$error, dataType=rcov$dataType) 39 | if ('RawCC' %in% class(rcov)) { 40 | class(res) <- 'BinnedRawCC' 41 | } else { 42 | class(res) <- 'BinnedRawCov' 43 | } 44 | 45 | return(res) 46 | } 47 | -------------------------------------------------------------------------------- /R/GetCrCorYZ.R: -------------------------------------------------------------------------------- 1 | #' Create cross-correlation matrix from auto- and cross-covariance matrix 2 | #' 3 | #' 4 | #' @param ccYZ The cross-covariance vector between variables Y and Z (n-by-1). 5 | #' @param acYY The auto-covariance n-by-n matrix of variable Y or the (n-by-1) diagonal of that matrix. 6 | #' @param covZ The (scalar) covariance of variable Z. 7 | #' 8 | #' @return A cross-correlation matrix between variables Y (functional) and Z (scalar). 9 | #' 10 | #' @export 11 | #' 12 | GetCrCorYZ <- function(ccYZ, acYY , covZ){ 13 | 14 | acYY = as.matrix(acYY); # Such a messy things because R does not treat vectors as matrices. 15 | 16 | # Check basic sizes 17 | if(1 != length(covZ)){ 18 | stop('The variance of Z must be a scalar.') 19 | } 20 | if(!is.matrix(ccYZ) && !is.vector(ccYZ)){ 21 | stop('The cross-covariance of Y and Z is must be a matrix or a vector.') 22 | } 23 | if( is.matrix(ccYZ) && (1 != dim(ccYZ)[2]) ){ 24 | stop('The cross-covariance matrix of a functional variable Y and a scalar variable Z is not n-by-1.') 25 | } 26 | N = length(ccYZ); 27 | 28 | if( N^2 == length(acYY)){ 29 | diagYY = diag(acYY) 30 | } else { 31 | if( 1 != dim(acYY)[2]){ 32 | stop('The auto-covariance is not n-by-n or n-by-1 ') 33 | } else { 34 | diagYY = as.vector(acYY) 35 | } 36 | } 37 | 38 | diagZ =(covZ[1]) 39 | 40 | if( length(diagYY) != length(ccYZ) ){ 41 | stop('The cross-covariance for YZ and the provided covariance for Y are of incompatible sizes.') 42 | } 43 | if( any(1e-12> diagYY)){ 44 | stop('The provided covariance for X are unreasonable small or negative. Rescale/check your data.') 45 | } 46 | if( any(1e-12> diagZ)){ 47 | stop('The provided covariance for Z are unreasonable small or negative. Rescale/check your data.') 48 | } 49 | 50 | # return (solve(sqrt(diag(diagYY))) %*% ccYZ %*% solve(sqrt(diag(diagZ)))) 51 | return( diag(1/sqrt(diagYY) , nrow = length(diagYY)) %*% ccYZ %*% diag(1/sqrt(diagZ), nrow = length(diagZ)) ) 52 | } 53 | 54 | 55 | 56 | -------------------------------------------------------------------------------- /src/RcppPseudoApprox.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | // [[Rcpp::depends(RcppEigen)]] 5 | 6 | float LinearInterpolation ( const Eigen::Map & X , const Eigen::Map & Y, float X_PointOfInterest){ 7 | //Produce Y_point_of_interest given X,Y and target X_point_of_interest 8 | //X : vector containing the X variables of the interpolant 9 | //Y : vector containing the Y variables of the interpolant 10 | //PointOfInterest : Point of X to estimate the new point of Y 11 | 12 | float xk, xkp1, yk, ykp1 = 0; //Points adjecent to the point of interpolation 13 | if ( X.size() != Y.size() ){ 14 | Rcpp::stop("Problem with unequal vector sizes when doing linear interpolation.");} 15 | //cout << " X(0): " << X(0) <<" X(Y.size()-1): " < X(Y.size()-1) ){Rcpp::warning("You interpolate out of the curve boundaries"); return(-1);} 17 | //Find the points right before and right after the point of interest 18 | for (int i=1; i= X_PointOfInterest){ 20 | xkp1 = X(i); 21 | xk = X(i-1); 22 | ykp1 = Y(i); 23 | yk = Y(i-1); 24 | break;} 25 | } 26 | //point-slope form for a line formula 27 | float t = (X_PointOfInterest -xk)/(xkp1 -xk); 28 | float yPOI = (1-t) * yk + t * ykp1; // estimate point of interest 29 | // cout << "(" << xk << ", " << X_PointOfInterest << " , " << xkp1 << ") & (" << yk << ", " << yPOI << ", " << ykp1 << ")"<< endl; 30 | return (yPOI); 31 | } 32 | 33 | // [[Rcpp::export]] 34 | Eigen::VectorXd RcppPseudoApprox( const Eigen::Map & X, const Eigen::Map & Y, const Eigen::Map & X_target){ 35 | //evaluate Y_target for X_target given X and Y 36 | 37 | int N = X_target.size(); 38 | Eigen::VectorXd rr(N); 39 | for (int i=0; i toGrid[1]) || 25 | ( fromGrid[length(fromGrid)] + buff < toGrid[length(toGrid)]) ) { 26 | stop("Insufficient size of 'fromGrid'.")} 27 | 28 | if (!is.null(mu)) {# convert mu 29 | return(MapX1D(fromGrid, mu, toGrid)) 30 | } else if (!is.null(Cov)) { 31 | mode(fromGrid) <- 'numeric' 32 | mode(toGrid) <- 'numeric' 33 | mode(Cov) <- 'numeric' 34 | gd <- expand.grid(X=toGrid, Y=toGrid) 35 | ret <- matrix(interp2lin(fromGrid, fromGrid, Cov, gd$X, gd$Y), nrow=length(toGrid)) 36 | if (!isCrossCov) { # ensure that covariance is symmetric 37 | ret <- 0.5 * (ret + t(ret)) 38 | } 39 | return(ret) 40 | } else if (!is.null(phi)) { 41 | return(MapX1D(fromGrid, phi, toGrid)) 42 | } 43 | 44 | } 45 | 46 | -------------------------------------------------------------------------------- /R/GetNormalisedSample.R: -------------------------------------------------------------------------------- 1 | #' Normalise sparse multivariate functional data 2 | #' 3 | #' Normalise sparse functional sample given in an FPCA object 4 | #' 5 | #' @param fpcaObj An FPCA object. 6 | #' @param errorSigma Indicator to use sigma^2 error variance when normalising the data (default: FALSE) 7 | #' 8 | #' @return A list containing the normalised sample 'y' at times 't' 9 | #' 10 | #' @references 11 | #' \cite{Chiou, Jeng-Min and Chen, Yu-Ting and Yang, Ya-Fang. "Multivariate Functional Principal Component Analysis: A Normalization Approach" Statistica Sinica 24 (2014): 1571-1596} 12 | #' @examples 13 | #' set.seed(1) 14 | #' n <- 100 15 | #' M <- 51 16 | #' pts <- seq(0, 1, length.out=M) 17 | #' mu <- rep(0, length(pts)) 18 | #' sampDense <- MakeGPFunctionalData(n, M, mu, K=1, basisType='sin', sigma=0.01) 19 | #' samp4 <- MakeFPCAInputs(tVec=sampDense$pts, yVec=sampDense$Yn) 20 | #' res4E <- FPCA(samp4$Ly, samp4$Lt, list(error=TRUE)) 21 | #' sampN <- GetNormalisedSample(res4E, errorSigma=TRUE) 22 | #' 23 | #' CreatePathPlot(subset=1:20, inputData=samp4, obsOnly=TRUE, showObs=FALSE) 24 | #' CreatePathPlot(subset=1:20, inputData=sampN, obsOnly=TRUE, showObs=FALSE) 25 | #' @export 26 | GetNormalisedSample<- function(fpcaObj, errorSigma = FALSE){ 27 | if (any( 0>=diag(fpcaObj$fittedCov)) ){ 28 | stop("The fitted autocovariance functions appears to have negative or zero values.") 29 | } 30 | 31 | if (errorSigma){ 32 | sigmaE = fpcaObj$sigma2 33 | } else { 34 | sigmaE = 0 35 | } 36 | 37 | ynorm = mapply(FUN = function(vy, vt){ 38 | return( ( vy - approx(y = fpcaObj$mu, x =fpcaObj$workGrid, xout = vt)$y) / 39 | approx(y = sqrt(sigmaE + diag(fpcaObj$fittedCov)), x =fpcaObj$workGrid, xout = vt)$y) 40 | }, vy = fpcaObj$inputData$Ly, vt = fpcaObj$inputData$Lt, SIMPLIFY = FALSE) 41 | return(list(Ly = ynorm, Lt = fpcaObj$inputData$Lt )) 42 | } 43 | 44 | #' \code{GetNormalizedSample} is an alias of \code{GetNormalizedSample} 45 | #' @param ... Passed into GetNormalisedSample 46 | #' @export 47 | #' @rdname GetNormalisedSample 48 | GetNormalizedSample <- function(...) { 49 | GetNormalisedSample(...) 50 | } 51 | -------------------------------------------------------------------------------- /tests/testthat/test_MakeFPCAInputs.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | library(testthat) 3 | 4 | test_that('MakeFPCAInputs works', { 5 | set.seed(1) 6 | NN = 32 7 | LyOrig = sapply( 1:NN, function(x) rnorm(x), simplify=FALSE) 8 | LtOrig = sapply( 1:NN, function(x) sample(1:100,x), simplify=FALSE) 9 | 10 | LyOrigVec = as.vector(unlist(LyOrig)) 11 | LtOrigVec = as.vector(unlist(LtOrig)) 12 | 13 | LusersOrig = sapply( 1:NN, function(x) rep( paste0(collapse='', 'user', x), x) ) 14 | LusersOrigVec = as.vector(unlist(LusersOrig)) 15 | ZZ = MakeFPCAInputs(IDs= LusersOrigVec, tVec=LtOrigVec,yVec= LyOrigVec) 16 | # BB = FPCA(Ly= ZZ$Ly, Lt= ZZ$Lt) # This errs! 17 | ZZs = MakeFPCAInputs(IDs= LusersOrigVec, tVec=LtOrigVec,yVec= LyOrigVec, sort=TRUE) 18 | # CC = FPCA(Ly= ZZs$Ly, Lt= ZZs$Lt) 19 | 20 | expect_s3_class(FPCA(Ly= ZZs$Ly, Lt= ZZs$Lt), 'FPCA') 21 | expect_error( FPCA(Ly = ZZ$Ly, Lt = ZZ$Lt), "Each vector in t should be in ascending order" ) 22 | 23 | }) 24 | 25 | test_that("basic arguments give reasonable output ", { 26 | 27 | IDs = factor(c('a','a','b','b', 'd'), c('d', 'a', 'b', 'c')) 28 | tVec = 1:5; 29 | yVec = cos(tVec); 30 | B = MakeFPCAInputs(IDs= IDs , tVec=tVec, yVec=yVec) 31 | 32 | expect_equal( unname(unlist(B$Lt)), tVec, tolerance = 2*.Machine$double.eps, scale = 1) 33 | expect_equal( B$Ly[[2]], cos(c(3,4)), tolerance = 2*.Machine$double.eps, scale = 1) 34 | expect_true( (length(B$Lid) == length(B$Ly)) && (length(B$Ly) == length(B$Lt)) ) 35 | expect_true( B$Lid[[3]] == IDs[5] ) 36 | }) 37 | 38 | test_that("basic arguments give reasonable output when number of measurement points is equal ", { 39 | 40 | IDs = rep(1:3,each=3); 41 | tVec = rep(c(0,2,5),3); 42 | yVec = 10:19; 43 | 44 | B = MakeFPCAInputs(IDs= IDs , tVec=tVec, yVec=yVec) 45 | 46 | expect_equal( unname(unlist(B$Lt)), tVec, tolerance = 2*.Machine$double.eps, scale = 1) 47 | expect_equal( B$Ly[[2]], c(13,14,15), tolerance = 2*.Machine$double.eps, scale = 1) 48 | expect_true( (length(B$Lid) == length(B$Ly)) && (length(B$Ly) == length(B$Lt)) ) 49 | expect_true( B$Lid[[3]] == IDs[9] ) 50 | }) 51 | 52 | 53 | -------------------------------------------------------------------------------- /man/Lwls2D.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Lwls2D.R 3 | \name{Lwls2D} 4 | \alias{Lwls2D} 5 | \title{Two dimensional local linear kernel smoother.} 6 | \usage{ 7 | Lwls2D( 8 | bw, 9 | kern = "epan", 10 | xin, 11 | yin, 12 | win = NULL, 13 | xout1 = NULL, 14 | xout2 = NULL, 15 | xout = NULL, 16 | subset = NULL, 17 | crosscov = FALSE, 18 | method = ifelse(kern == "gauss", "plain", "sort2") 19 | ) 20 | } 21 | \arguments{ 22 | \item{bw}{A scalar or a vector of length 2 specifying the bandwidth.} 23 | 24 | \item{kern}{Kernel used: 'gauss', 'rect', 'gausvar', 'epan' (default), 'quar'.} 25 | 26 | \item{xin}{An n by 2 data frame or matrix of x-coordinate.} 27 | 28 | \item{yin}{A vector of y-coordinate.} 29 | 30 | \item{win}{A vector of weights on the observations.} 31 | 32 | \item{xout1}{a p1-vector of first output coordinate grid. Defaults to the input gridpoints if left unspecified.} 33 | 34 | \item{xout2}{a p2-vector of second output coordinate grid. Defaults to the input gridpoints if left unspecified.} 35 | 36 | \item{xout}{alternative to xout1 and xout2. A matrix of p by 2 specifying the output points (may be inefficient if the size of \code{xout} is small).} 37 | 38 | \item{subset}{a vector with the indices of x-/y-/w-in to be used (Default: NULL)} 39 | 40 | \item{crosscov}{using function for cross-covariance estimation (Default: FALSE). FALSE for auto-covariance estimation and 41 | TRUE for two-dimensional local linear kernel smoothing or cross-covariance estimation. 42 | For auto-covariance estimation (i.e., when \code{crosscov} is FALSE), \code{xout1} and \code{xout2} should be the same.} 43 | 44 | \item{method}{should one try to sort the values xin and yin before using the lwls smoother? if yes ('sort2' - default for non-Gaussian kernels), if no ('plain' - fully stable; de)} 45 | } 46 | \value{ 47 | a p1 by p2 matrix of fitted values if xout is not specified. Otherwise a vector of length p corresponding to the rows of xout. 48 | } 49 | \description{ 50 | Two dimensional local weighted least squares smoother. Only local linear smoother for estimating the original curve is available (no higher order, no derivative). 51 | } 52 | -------------------------------------------------------------------------------- /tests/testthat/test_GetRawCov.R: -------------------------------------------------------------------------------- 1 | 2 | myEps <- .Machine$double.eps; 3 | load(system.file('testdata', 'dataForGetRawCov.RData', package='fdapace')) 4 | AA = GetRawCov(y,t, sort(unlist(t)), mu,'Sparse',TRUE) #Matches ML output 5 | BB = GetRawCov(y,t, sort(unlist(t)), mu,'Sparse',FALSE) #Matches ML output 6 | 7 | test_that(" basic argument match MATLAB output ", { 8 | expect_equal( sum(AA$indx) , 184, tolerance = 2*myEps, scale = 1) 9 | expect_equal( sum(AA$cxxn) , -7.416002855888680, tolerance = 1e-13, scale = 1) 10 | expect_equal( sum(AA$cyy) , 16.327874649330514, tolerance = 1e-13, scale = 1) 11 | expect_equal( sum(AA$tPairs) , 4.053285461728229e+02, tolerance = 1e-12, scale = 1) 12 | }) 13 | 14 | test_that(" basic argument match MATLAB output ", { 15 | expect_equal( sum(BB$indx) , 298, tolerance = 2*myEps, scale = 1) 16 | expect_equal( sum(BB$cxxn) , 16.327874649330514, tolerance = 1e-13, scale = 1) 17 | expect_equal( sum(BB$cyy) , 16.327874649330514, tolerance = 1e-13, scale = 1) 18 | expect_equal( sum(BB$tPairs) , 6.330209554605514e+02, tolerance = 1e-12, scale = 1) 19 | }) 20 | 21 | y2 = list(1:10, 2:11) 22 | t2 = list( 1:10, 1:10) 23 | 24 | CC = GetRawCov(y2,t2, sort(unique(unlist(t2))), seq(1.5,10.5, length.out=10) ,'Dense',TRUE) #Matches ML output 25 | DD = GetRawCov(y2,t2, sort(unique(unlist(t2))), seq(1.5,10.5, length.out=10) ,'Dense',FALSE) #Matches ML output 26 | # DD = getRawCov(y2,t2, sort(unique(cell2mat(t2))), linspace(1.5,10.5, 10), 2, 0) 27 | 28 | 29 | test_that(" basic argument match MATLAB output ", { 30 | expect_equal( sum(CC$indx) , 0, tolerance = 2*myEps, scale = 1) 31 | expect_equal( sum(CC$cxxn) , 22.5, tolerance = 1e-13, scale = 1) 32 | expect_equal( sum(CC$cyy) , 25, tolerance = 1e-13, scale = 1) 33 | expect_equal( sum(CC$tPairs) , 990, tolerance = 1e-12, scale = 1) 34 | }) 35 | 36 | 37 | test_that(" basic argument match MATLAB output ", { 38 | expect_equal( sum(DD$indx) , 0, tolerance = 2*myEps, scale = 1) 39 | expect_equal( sum(DD$cxxn) , 25, tolerance = 1e-13, scale = 1) 40 | expect_equal( sum(DD$cyy) , 25, tolerance = 1e-13, scale = 1) 41 | expect_equal( sum(DD$tPairs) , 1100, tolerance = 1e-12, scale = 1) 42 | }) 43 | 44 | 45 | -------------------------------------------------------------------------------- /tests/testthat/test_GetRawCrCovFuncScal.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | #source('GetRawCrCovFuncScal.R') 3 | 4 | # These check out OK. 5 | test_that("basic R output matche MATLAB output for different means", { 6 | 7 | # simplest case 8 | AA = GetRawCrCovFuncScal(list(c(5,5,5),c(2,2,2)), list(c(1,2,3), c(1,3,5)), c(1,2,3,4),Z =c(4,5), Zmu = 4) 9 | # t_x = {[1,2,3], [1,3,5]} ; x= {[5 5 5], [2 2 2]}; y =[ 4 5]; t_y=[]; mu_x = [1,2,3,4]; mu_y = 4; isYFun=0; regular=0; 10 | 11 | # simplest case different E[Y] 12 | BB = GetRawCrCovFuncScal(list(c(5,5,5),c(2,2,2)), list(c(1,2,3), c(1,3,5)), c(1,2,3,4),Z =c(4,5), Zmu = 6) 13 | # t_x = {[1,2,3], [1,3,5]} ; x= {[5 5 5], [2 2 2]}; y =[ 4 5]; t_y=[]; mu_x = [1,2,3,4]; mu_y = 6; isYFun=0; regular=0; 14 | 15 | # simple case more readings per sample 16 | CC = GetRawCrCovFuncScal(list(c(5,5,5,0),c(2,2,2,0)), list(c(1,2,3,8), c(1,3,5,8)), c(1,2,3,4,1),Z =c(4,5), Zmu =6) 17 | # t_x = {[1,2,3,8], [1,3,5,8]} ; x= {[5 5 5 0], [2 2 2 0]}; y =[ 4 5]; t_y=[]; mu_x = [1,2,3,4,1]; mu_y = 6; isYFun=0; regular=0; 18 | 19 | # simple case more three curves 20 | DD = GetRawCrCovFuncScal(list(c(5,5,5,0),c(2,2,2,0),c(1,2,5)), list(c(1,2,3,8), c(1,3,5,8), c(1,2,5)), c(1,2,3,4,1),Z =c(4,5,0), Zmu = 0) 21 | # t_x = {[1,2,3,8],[1,3,5,8],[1,2,5]} ; x= {[5 5 5 0],[2 2 2 0],[1 2 5]}; y =[ 4 5 0]; t_y=[]; mu_x = [1,2,3,4,1]; mu_y = 0; isYFun=0; regular=0; 22 | 23 | # simple case readings with single measurement 24 | EE = GetRawCrCovFuncScal(list(c(5,5,5,0),c(2)), list(c(1,2,3,8), c(5)), c(1,2,3,4,1),Z =c(4,5), Zmu = 6) 25 | # t_x = {[1,2,3,8], [5]} ; x= {[5 5 5 0], [2]}; y =[ 4 5]; t_y=[]; mu_x = [1,2,3,4,1]; mu_y = 6; isYFun=0; regular=0; 26 | 27 | expect_equal( AA$tpairn, c(1,2,3,1,3,5)) 28 | expect_equal( BB$tpairn, c(1,2,3,1,3,5)) 29 | expect_equal( CC$tpairn, c(1,2,3,8,1,3,5,8)) 30 | expect_equal( DD$tpairn, c(1,2,3,8,1,3,5,8,1,2,5)) 31 | expect_equal( EE$tpairn, c(1,2,3,8,5)) 32 | 33 | expect_equal( AA$rawCCov, c(0, 0, 0, 1,-1,-2)) 34 | expect_equal( BB$rawCCov, c(-8,-6,-4,-1,1,2)) 35 | expect_equal( CC$rawCCov, c(-8,-6,-4,2,-1,1,2,1)) 36 | expect_equal( DD$rawCCov, c(16,12,8,-4, 5,-5,-10,-5,0,0,0)) 37 | expect_equal( EE$rawCCov, c(-8,-6,-4,2,2)) 38 | 39 | }) 40 | -------------------------------------------------------------------------------- /man/CreateFuncBoxPlot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/CreateFuncBoxPlot.R 3 | \name{CreateFuncBoxPlot} 4 | \alias{CreateFuncBoxPlot} 5 | \title{Create functional boxplot using 'bagplot', 'KDE' or 'pointwise' methodology} 6 | \usage{ 7 | CreateFuncBoxPlot(fpcaObj, optns = list(), ...) 8 | } 9 | \arguments{ 10 | \item{fpcaObj}{An object of class FPCA returned by the function FPCA().} 11 | 12 | \item{optns}{A list of options control parameters specified by \code{list(name=value)}. See `Details'.} 13 | 14 | \item{...}{Additional arguments for the 'plot' function.} 15 | } 16 | \description{ 17 | Using an FPCA object create a functional box-plot based on the function scores. 18 | The green line corresponds to the functional median, the dark gray area to the area spanned 19 | by the curves within the 25th and 75-th percentile and the light gray to the area spanned 20 | by the curves within the 2.5th and 97.5-th percentile. 21 | } 22 | \details{ 23 | Available control options are 24 | \describe{ 25 | \item{ifactor}{inflation ifactor for the bag-plot defining the loop of bag-plot or multiplying ifactor 26 | the KDE pilot bandwidth matrix. (see ?aplpack::compute.bagplot; ?ks::Hpi respectively; default: 2.58; 2 respectively).} 27 | \item{variant}{string defining the method used ('KDE', 'pointwise' or 'bagplot') (default: 'bagplot')} 28 | \item{unimodal}{logical specifying if the KDE estimate should be unimodal (default: FALSE, relevant only for variant='KDE')} 29 | \item{addIndx}{vector of indices corresponding to which samples one should overlay (Default: NULL)} 30 | \item{K}{integer number of the first K components used for the representation. (default: length(fpcaObj$lambda ))} 31 | } 32 | } 33 | \examples{ 34 | set.seed(1) 35 | n <- 20 36 | pts <- seq(0, 1, by=0.05) 37 | sampWiener <- Wiener(n, pts) 38 | sampWiener <- Sparsify(sampWiener, pts, 10) 39 | res <- FPCA(sampWiener$Ly, sampWiener$Lt, 40 | list(dataType='Sparse', error=FALSE, kernel='epan', verbose=TRUE)) 41 | CreateFuncBoxPlot(res, list(addIndx=c(1:3)) ) 42 | } 43 | \references{ 44 | \cite{P. J. Rousseeuw, I. Ruts, J. W. Tukey (1999): The bagplot: a bivariate boxplot, The American Statistician, vol. 53, no. 4, 382-387} 45 | } 46 | -------------------------------------------------------------------------------- /man/Lwls2DDeriv.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Lwls2DDeriv.R 3 | \name{Lwls2DDeriv} 4 | \alias{Lwls2DDeriv} 5 | \title{Two dimensional local linear kernel smoother to target derivatives.} 6 | \usage{ 7 | Lwls2DDeriv( 8 | bw, 9 | kern = "epan", 10 | xin, 11 | yin, 12 | win = NULL, 13 | xout1 = NULL, 14 | xout2 = NULL, 15 | xout = NULL, 16 | npoly = 1L, 17 | nder1 = 0L, 18 | nder2 = 0L, 19 | subset = NULL, 20 | crosscov = TRUE, 21 | method = "sort2" 22 | ) 23 | } 24 | \arguments{ 25 | \item{bw}{A scalar or a vector of length 2 specifying the bandwidth.} 26 | 27 | \item{kern}{Kernel used: 'gauss', 'rect', 'gausvar', 'epan' (default), 'quar'.} 28 | 29 | \item{xin}{An n by 2 data frame or matrix of x-coordinate.} 30 | 31 | \item{yin}{A vector of y-coordinate.} 32 | 33 | \item{win}{A vector of weights on the observations.} 34 | 35 | \item{xout1}{a p1-vector of first output coordinate grid. Defaults to the input gridpoints if left unspecified.} 36 | 37 | \item{xout2}{a p2-vector of second output coordinate grid. Defaults to the input gridpoints if left unspecified.} 38 | 39 | \item{xout}{alternative to xout1 and xout2. A matrix of p by 2 specifying the output points (may be inefficient if the size of \code{xout} is small).} 40 | 41 | \item{npoly}{The degree of polynomials (include all \eqn{x^a y^b} terms where \eqn{a + b <= npoly})} 42 | 43 | \item{nder1}{Order of derivative in the first direction} 44 | 45 | \item{nder2}{Order of derivative in the second direction} 46 | 47 | \item{subset}{a vector with the indices of x-/y-/w-in to be used (Default: NULL)} 48 | 49 | \item{crosscov}{using function for cross-covariance estimation (Default: TRUE)} 50 | 51 | \item{method}{should one try to sort the values xin and yin before using the lwls smoother? if yes ('sort2' - default for non-Gaussian kernels), if no ('plain' - fully stable; de)} 52 | } 53 | \value{ 54 | a p1 by p2 matrix of fitted values if xout is not specified. Otherwise a vector of length p corresponding to the rows of xout. 55 | } 56 | \description{ 57 | Two dimensional local weighted least squares smoother. Only a local linear smoother for estimating the original curve is available (no higher order) 58 | } 59 | -------------------------------------------------------------------------------- /R/GenBSpline.R: -------------------------------------------------------------------------------- 1 | # B-spline basis generator on [0,1] with equally spaced interior knots 2 | 3 | GenBSpline <- function(x,nIntKnot=NULL,order=NULL) { 4 | 5 | # x: n-dimensional vector for evaluation 6 | # nIntKnot: a number of interior knots on (0,1) (scalar) 7 | # order: the order of B-spline basis function (scalar) 8 | 9 | if (is.null(nIntKnot)==TRUE) { 10 | nIntKnot <- 10 11 | } 12 | if (is.null(order)==TRUE) { 13 | order <- 3 14 | } 15 | if (nIntKnot < order) { 16 | stop('The number of knots should be greater than the order of B-spline basis.') 17 | } 18 | 19 | kOrder <- 0 20 | 21 | n <- length(x) 22 | t0 <- seq(0,1,length.out=(nIntKnot+2))[-c(1,nIntKnot+2)] 23 | 24 | newB <- matrix(0,nrow=n,ncol=(nIntKnot+1)) 25 | t <- c(0,t0,1) 26 | 27 | for (i in 1:n) { 28 | for (k in 1:(nIntKnot)) { 29 | if (x[i] >= t[k] && x[i] < t[k+1]) { 30 | newB[i,k] <- 1 31 | } 32 | if (x[i]>=t[nIntKnot+1]) 33 | newB[i,nIntKnot+1] <- 1 34 | } 35 | } 36 | 37 | if (order == 0) { 38 | 39 | return(B=newB) 40 | 41 | } else { 42 | 43 | while (kOrder < order) { 44 | 45 | kOrder <- kOrder + 1 46 | 47 | oldB <- cbind(rep(0,n),newB,rep(0,n)) 48 | newB <- matrix(0,nrow=n,ncol=(nIntKnot+1+kOrder)) 49 | t <- c(0,t,1) 50 | 51 | for (i in 1:n) { 52 | 53 | newB[i,1] <- (t[1+1+kOrder]-x[i])/(t[1+1+kOrder]-t[1+1])*oldB[i,1+1] 54 | 55 | for (k in 2:(nIntKnot+kOrder)) { 56 | newB[i,k] <- (x[i]-t[k])/(t[k+kOrder]-t[k])*oldB[i,k] + (t[k+1+kOrder]-x[i])/(t[k+1+kOrder]-t[k+1])*oldB[i,k+1] 57 | } 58 | 59 | newB[i,nIntKnot+1+kOrder] <- (x[i]-t[nIntKnot+1+kOrder])/(t[nIntKnot+1+2*kOrder]-t[nIntKnot+1+kOrder])*oldB[i,nIntKnot+1+kOrder] 60 | } 61 | } 62 | 63 | return(B=newB) 64 | 65 | } 66 | } 67 | 68 | # x <- sample(seq(0,1,length.out=201),201) 69 | # 70 | # nIntKnot <- 10 71 | # order <- 3 72 | # 73 | # B <- GenBSpline(x,nIntKnot,order) 74 | # # B <- GenBSpline(x) 75 | # 76 | # plot(sort(x),B[order(x),1],type='l',col=1,ylim=c(min(B),max(B))) 77 | # for (k in 2:ncol(B)) { 78 | # points(sort(x),B[order(x),k],type='l',col=k) 79 | # } 80 | # abline(v=seq(0,1,length.out=(nIntKnot+2)),col=8) 81 | # B 82 | # dim(B) -------------------------------------------------------------------------------- /man/CreatePathPlot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/CreatePathPlot.R 3 | \name{CreatePathPlot} 4 | \alias{CreatePathPlot} 5 | \title{Create the fitted sample path plot based on the results from FPCA().} 6 | \usage{ 7 | CreatePathPlot( 8 | fpcaObj, 9 | subset, 10 | K = NULL, 11 | inputData = fpcaObj[["inputData"]], 12 | showObs = !is.null(inputData), 13 | obsOnly = FALSE, 14 | showMean = FALSE, 15 | derOptns = list(p = 0), 16 | ... 17 | ) 18 | } 19 | \arguments{ 20 | \item{fpcaObj}{Returned object from FPCA().} 21 | 22 | \item{subset}{A vector of indices or a logical vector for subsetting the 23 | observations.} 24 | 25 | \item{K}{The number of components to reconstruct the fitted sample paths.} 26 | 27 | \item{inputData}{A list of length 2 containing the sparse/dense 28 | (unsupported yet) observations. \code{inputData} needs to contain two 29 | fields: \code{Lt} for a list of time points and \code{Ly} for a list of 30 | observations. Default to the `inputData` field within `fpcaObj`.} 31 | 32 | \item{showObs}{Whether to plot the original observations for each subject.} 33 | 34 | \item{obsOnly}{Whether to show only the original curves.} 35 | 36 | \item{showMean}{Whether to plot the mean function as a bold solid curve.} 37 | 38 | \item{derOptns}{A list of options to control derivation parameters; see `fitted.FPCA'. (default = NULL)} 39 | 40 | \item{...}{other arguments passed into matplot for plotting options} 41 | } 42 | \description{ 43 | Create the fitted sample path plot based on the results from FPCA(). 44 | } 45 | \examples{ 46 | set.seed(1) 47 | n <- 20 48 | pts <- seq(0, 1, by=0.05) 49 | sampWiener <- Wiener(n, pts) 50 | sampWiener <- Sparsify(sampWiener, pts, 10) 51 | res <- FPCA(sampWiener$Ly, sampWiener$Lt, 52 | list(dataType='Sparse', error=FALSE, kernel='epan', 53 | verbose=TRUE)) 54 | CreatePathPlot(res, subset=1:5) 55 | 56 | # CreatePathPlot has a lot of usages: 57 | \donttest{ 58 | CreatePathPlot(res) 59 | CreatePathPlot(res, 1:20) 60 | CreatePathPlot(res, 1:20, showObs=FALSE) 61 | CreatePathPlot(res, 1:20, showMean=TRUE, showObs=FALSE) 62 | CreatePathPlot(res, 1:20, obsOnly=TRUE) 63 | CreatePathPlot(res, 1:20, obsOnly=TRUE, showObs=FALSE) 64 | CreatePathPlot(inputData=sampWiener, subset=1:20, obsOnly=TRUE)} 65 | 66 | } 67 | -------------------------------------------------------------------------------- /man/GetCrCovYZ.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/GetCrCovYZ.R 3 | \name{GetCrCovYZ} 4 | \alias{GetCrCovYZ} 5 | \title{Functional Cross Covariance between longitudinal variable Y and scalar variable Z} 6 | \usage{ 7 | GetCrCovYZ( 8 | bw = NULL, 9 | Z, 10 | Zmu = NULL, 11 | Ly, 12 | Lt = NULL, 13 | Ymu = NULL, 14 | support = NULL, 15 | kern = "gauss" 16 | ) 17 | } 18 | \arguments{ 19 | \item{bw}{Scalar bandwidth for smoothing the cross-covariance function (if NULL it will be automatically estimated)} 20 | 21 | \item{Z}{Vector N-1 Vector of length N with the scalar function values} 22 | 23 | \item{Zmu}{Scalar with the mean of Z (if NULL it will be automatically estimated)} 24 | 25 | \item{Ly}{List of N vectors with amplitude information} 26 | 27 | \item{Lt}{List of N vectors with timing information} 28 | 29 | \item{Ymu}{Vector Q-1 Vector of length nObsGrid containing the mean function estimate} 30 | 31 | \item{support}{Vector of unique and sorted values for the support of the smoothed cross-covariance function (if NULL it will be automatically estimated)} 32 | 33 | \item{kern}{Kernel type to be used. See ?FPCA for more details. (default: 'gauss') 34 | If the variables Ly1 is in matrix form the data are assumed dense and only 35 | the raw cross-covariance is returned. One can obtain Ymu1 36 | from \code{FPCA} and \code{ConvertSupport}.} 37 | } 38 | \value{ 39 | A list containing: 40 | \item{smoothedCC}{The smoothed cross-covariance as a vector} 41 | \item{rawCC}{The raw cross-covariance as a vector } 42 | \item{bw}{The bandwidth used for smoothing as a scalar} 43 | \item{score}{The GCV score associated with the scalar used} 44 | } 45 | \description{ 46 | Calculate the raw and the smoothed cross-covariance between functional 47 | and scalar predictors using bandwidth bw or estimate that bw using GCV 48 | } 49 | \examples{ 50 | Ly <- list( runif(5), c(1:3), c(2:4), c(4)) 51 | Lt <- list( c(1:5), c(1:3), c(1:3), 4) 52 | Z = rep(4,4) # Constant vector so the covariance has to be zero. 53 | sccObj = GetCrCovYZ(bw=1, Z= Z, Ly=Ly, Lt=Lt, Ymu=rep(4,5)) 54 | } 55 | \references{ 56 | \cite{Yang, Wenjing, Hans-Georg Müller, and Ulrich Stadtmüller. "Functional singular component analysis." Journal of the Royal Statistical Society: Series B (Statistical Methodology) 73.3 (2011): 303-324} 57 | } 58 | -------------------------------------------------------------------------------- /man/predict.FPCA.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/predict.FPCA.R 3 | \name{predict.FPCA} 4 | \alias{predict.FPCA} 5 | \title{Predict FPC scores and curves for a new sample given an FPCA object} 6 | \usage{ 7 | \method{predict}{FPCA}(object, newLy, newLt, sigma2 = NULL, K = NULL, xiMethod = "CE", ...) 8 | } 9 | \arguments{ 10 | \item{object}{An FPCA object.} 11 | 12 | \item{newLy}{A list of \emph{n} vectors containing the observed values for each individual.} 13 | 14 | \item{newLt}{A list of \emph{n} vectors containing the observation time points for each individual corresponding to y.} 15 | 16 | \item{sigma2}{The user-defined measurement error variance. A positive scalar. (default: rho if applicable, otherwise sigma2 if applicable, otherwise 0 if no error. )} 17 | 18 | \item{K}{The scalar defining the number of clusters to define; (default: from user-specified FPCA Object).} 19 | 20 | \item{xiMethod}{The integration method used to calculate the functional principal component scores 21 | (standard numerical integration 'IN' or conditional expectation 'CE'); default: 'CE'.} 22 | 23 | \item{...}{Not used.} 24 | } 25 | \value{ 26 | A list containing the following fields: 27 | \item{scores}{A matrix of size \emph{n}-by-\emph{k} which comprise of the predicted functional principal component scores.} 28 | \item{predCurves}{A matrix of size \emph{n}-by-\emph{l} where \emph{l} is the length of the work grid in \emph{object}.} 29 | \item{predGrid}{A vector of length \emph{l} which is the output grid of the predicted curves. This is same is the workgrid of \emph{object}.} 30 | } 31 | \description{ 32 | Return a list containing the matrix with the first k FPC scores according to conditional expectation or numerical integration, the matrix of predicted trajectories and the prediction work grid. 33 | } 34 | \examples{ 35 | \donttest{ 36 | set.seed(1) 37 | n <- 50 38 | pts <- seq(0, 1, by=0.05) 39 | # The first n samples are for training and the rest testing 40 | sampWiener <- Wiener(2 * n, pts) 41 | sparsity <- 2:5 42 | train <- Sparsify(sampWiener[seq_len(n), , drop=FALSE], pts, sparsity) 43 | test <- Sparsify(sampWiener[seq(n + 1, 2 * n), , drop=FALSE], pts, sparsity) 44 | res <- FPCA(train$Ly, train$Lt) 45 | pred <- predict(res, test$Ly, test$Lt, K=3) 46 | plot(pred$predGrid, pred$predCurves[1,]) 47 | } 48 | 49 | } 50 | -------------------------------------------------------------------------------- /man/FCCor.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/FCCor.R 3 | \name{FCCor} 4 | \alias{FCCor} 5 | \title{Calculation of functional correlation between two simultaneously observed processes.} 6 | \usage{ 7 | FCCor( 8 | x, 9 | y, 10 | Lt, 11 | bw = stop("bw missing"), 12 | kern = "epan", 13 | Tout = sort(unique(unlist(Lt))) 14 | ) 15 | } 16 | \arguments{ 17 | \item{x}{A list of function values corresponding to the first process.} 18 | 19 | \item{y}{A list of function values corresponding to the second process.} 20 | 21 | \item{Lt}{A list of time points for both \code{x} and \code{y}.} 22 | 23 | \item{bw}{A numeric vector for bandwidth of length either 5 or 1, specifying the bandwidths for E(X), E(Y), var(X), var(Y), and cov(X, Y). If \code{bw} is a scalar then all five bandwidths are chosen to be the same.} 24 | 25 | \item{kern}{Smoothing kernel for mu and covariance; "rect", "gauss", "epan", "gausvar", "quar" (default: "gauss")} 26 | 27 | \item{Tout}{Output time points. Default to the sorted unique time points.} 28 | } 29 | \value{ 30 | A list with the following components: 31 | \item{corr}{A vector of the correlation corr(X(t), Y(t)) evaluated at \code{Tout}.} 32 | \item{Tout}{Same as the input Tout.} 33 | \item{bw}{The bandwidths used for E(X), E(Y), var(X), var(Y), and cov(X, Y).} 34 | } 35 | \description{ 36 | Calculation of functional correlation between two simultaneously observed processes. 37 | } 38 | \details{ 39 | \code{FCCor} calculate only the concurrent correlation corr(X(t), Y(t)) (note that the time points t are the same). It assumes no measurement error in the observed values. 40 | } 41 | \examples{ 42 | set.seed(1) 43 | n <- 200 44 | nGridIn <- 50 45 | sparsity <- 1:5 # must have length > 1 46 | bw <- 0.2 47 | kern <- 'epan' 48 | T <- matrix(seq(0.5, 1, length.out=nGridIn)) 49 | 50 | ## Corr(X(t), Y(t)) = 1/2 51 | A <- Wiener(n, T) 52 | B <- Wiener(n, T) 53 | C <- Wiener(n, T) + matrix((1:nGridIn) , n, nGridIn, byrow=TRUE) 54 | X <- A + B 55 | Y <- A + C 56 | indEach <- lapply(1:n, function(x) sort(sample(nGridIn, sample(sparsity, 1)))) 57 | tAll <- lapply(1:n, function(i) T[indEach[[i]]]) 58 | Xsp <- lapply(1:n, function(i) X[i, indEach[[i]]]) 59 | Ysp <- lapply(1:n, function(i) Y[i, indEach[[i]]]) 60 | 61 | plot(T, FCCor(Xsp, Ysp, tAll, bw)[['corr']], ylim=c(-1, 1)) 62 | abline(h=0.5) 63 | } 64 | -------------------------------------------------------------------------------- /R/MakeLNtoZscore02y.R: -------------------------------------------------------------------------------- 1 | #' Z-score height for age 0 to 24 months based on WHO standards 2 | #' 3 | #' Convert vector of age and height measurement to z-scores based on WHO standards using mu and sigma (not LMS) 4 | #' 5 | #' @param sex A character 'M' or 'F' indicating the sex of the child. 6 | #' @param age A vector of time points of size Q. 7 | #' @param ln A vector of body-length readings of size Q (in cm). 8 | #' 9 | #' @return A vector of Z-scores of size Q. 10 | #' @export 11 | MakeLNtoZscore02y <- function(sex, age, ln){ 12 | time = 0:24 13 | 14 | if(length(age) != length(ln)){ 15 | stop('Number of readings for age and length are not the same.') 16 | } 17 | if(!all( (age <= time[24]) && (time[1] <= age))){ 18 | stop('Age requested is outside the [0,24] months.') 19 | } 20 | if(sex == 'F'){ 21 | #http://www.who.int/childgrowth/standards/tab_lhfa_girls_p_0_2.txt 22 | muGln = c(49.1477, 53.6872, 57.0673, 59.8029, 62.0899, 64.0301, 23 | 65.7311, 67.2873, 68.7498, 70.1435, 71.4818, 72.771, 24 | 74.015, 75.2176, 76.3817, 77.5099, 78.6055, 79.671, 25 | 80.7079, 81.7182, 82.7036, 83.6654, 84.604, 85.5202, 86.4153) 26 | sdGln = c(1.8627, 1.9542, 2.0362, 2.1051, 2.1645, 2.2174, 27 | 2.2664, 2.3154, 2.365, 2.4157, 2.4676, 2.5208, 28 | 2.575, 2.6296, 2.6841, 2.7392, 2.7944, 2.849, 29 | 2.9039, 2.9582, 3.0129, 3.0672, 3.1202, 3.1737, 3.2267); 30 | return( (ln - spline(x=time, y = muGln, xout = age)$y) / spline(x=time, y = sdGln, xout = age)$y) 31 | } else if(sex == 'M'){ 32 | #http://www.who.int/childgrowth/standards/tab_lhfa_boys_p_0_2.txt 33 | muBln = c(49.8842, 54.7244, 58.4249, 61.4292, 63.886, 65.9026, 34 | 67.6236, 69.1645, 70.5994, 71.9687, 73.281, 74.5388, 35 | 75.7488, 76.9186, 78.0497, 79.1458, 80.211, 81.2487, 36 | 82.2587, 83.2418, 84.1996, 85.1348, 6.0477, 86.941, 87.8161) 37 | sdBln = c(1.8931, 1.9465, 2.0005, 2.0444, 2.0808, 2.1115, 38 | 2.1403, 2.1711, 2.2055, 2.2433, 2.2849, 2.3293, 39 | 2.3762, 2.426, 2.4773, 2.5303, 2.5844, 2.6406, 40 | 2.6973, 2.7553, 2.814, 2.8742, 2.9342, 2.9951, 3.0551) 41 | return( (ln - spline(x=time, y = muBln, xout = age)$y) / spline(x=time, y = sdBln, xout = age)$y) 42 | } else{ 43 | stop("Sex type undefined.") 44 | } 45 | } -------------------------------------------------------------------------------- /R/CheckData.R: -------------------------------------------------------------------------------- 1 | #' Check data format 2 | #' 3 | #' Check if there are problems with the form and basic structure of the functional data 'y' and the recorded times 't'. 4 | #' 5 | #' @param y is a n-by-1 list of vectors 6 | #' @param t is a n-by-1 list of vectors 7 | #' @export 8 | 9 | 10 | CheckData = function(y,t){ 11 | 12 | if(!is.list(y)){ 13 | stop('y should be list \n') 14 | } 15 | if(!is.list(t)){ 16 | stop('t should be list \n') 17 | } 18 | 19 | if( length(t) != length(y)){ 20 | stop('t and y should have the same length \n') 21 | } 22 | 23 | ni_y = unlist(lapply(y,function(x) sum(!is.na(x)))) 24 | if(all(ni_y == 1)){ 25 | stop("FPCA is aborted because the data do not contain repeated measurements in y!\n"); 26 | } 27 | ni_tt = unlist(lapply(t,function(x) sum(!is.na(x)))) 28 | if(all(ni_tt == 1)){ 29 | stop("FPCA is aborted because the data do not contain repeated measurements in t!\n"); 30 | } 31 | if( !all(unlist(lapply(y,function(x) typeof(x) %in% c('integer', 'double') ) ) ) ){ 32 | stop("FPCA is aborted because 'y' members are not all of type double or integer! Try \"lapply(y,function(x) typeof(x))\" to see the current types \n"); 33 | } 34 | if( !all(unlist(lapply(t,function(x) typeof(x) %in% c('integer', 'double'))) ) ){ 35 | stop("FPCA is aborted because 't' members are not all of type double or integer! Try \"lapply(t,function(x) typeof(x))\" to see the current types \n"); 36 | } 37 | 38 | if(any( unlist( lapply(t, function(x) length(x) != length(unique(x))))) ){ 39 | stop("FPCA is aborted because within-subject 't' members have duplicated values. Try \"which( unlist( lapply(t, function(x) length(x) != length(unique(x)))))\" to see potentially problematic entries. \n"); 40 | } 41 | if( any(sapply(t[seq_len(min(1001, length(t)))], is.unsorted, na.rm=TRUE)) ) { 42 | stop('Each vector in t should be in ascending order') 43 | } 44 | if(min(unlist(y),na.rm=TRUE)==-Inf){ 45 | stop('There are entries in Ly which are -Inf') 46 | } 47 | if(max(unlist(y),na.rm=TRUE)==Inf){ 48 | stop('There are entries in Ly which are Inf') 49 | } 50 | 51 | #check possible time gap across subjects 52 | if(max(diff(sort(unlist(t))),na.rm=TRUE)/(max(unlist(t),na.rm=TRUE)-min(unlist(t),na.rm=TRUE))>0.1){ 53 | warning('There is a time gap of at least 10% of the observed range across subjects') 54 | } 55 | 56 | } 57 | 58 | -------------------------------------------------------------------------------- /R/MakeHCtoZscore02y.R: -------------------------------------------------------------------------------- 1 | #' Z-score head-circumference for age 0 to 24 months based on WHO standards 2 | #' 3 | #' Convert vector of age and height measurement to z-scores based on WHO standards using mu and sigma (not LMS) 4 | #' 5 | #' @param sex A character 'M' or 'F' indicating the sex of the child. 6 | #' @param age A vector of time points of size Q. 7 | #' @param hc A vector of head circumference readings of size Q (in cm). 8 | #' 9 | #' @return A vector of Z-scores of size Q. 10 | #' @export 11 | MakeHCtoZscore02y <- function(sex, age, hc){ 12 | time = 0:24 13 | 14 | if(length(age) != length(hc)){ 15 | stop('Number of readings for age and head circ. are not the same.') 16 | } 17 | if(!all( (age <= time[24]) && (time[1] <= age))){ 18 | stop('Age requested is outside the [0,24] months.') 19 | } 20 | if(sex == 'F'){ 21 | # http://www.who.int/childgrowth/standards/second_set/tab_hcfa_girls_p_0_5.txt 22 | muGhc = c(33.8787, 36.5463, 38.2521, 39.5328, 40.5817, 41.4590, 42.1995, 42.8290, 43.3671, 23 | 43.8300, 44.2319, 44.5844, 44.8965, 45.1752, 45.4265, 45.6551, 45.8650, 46.0598, 24 | 46.2424, 46.4152, 46.5801, 46.7384, 46.8913, 47.0391, 47.1822) 25 | sdGhc = c(1.18440, 1.17314, 1.21183, 1.24133, 1.26574, 1.28606, 1.30270, 1.31699, 1.32833, 26 | 1.33813, 1.34642, 1.35314, 1.35902, 1.36384, 1.36825, 1.37239, 1.37549, 1.37857, 27 | 1.38126, 1.38410, 1.38669, 1.38907, 1.39126, 1.39330, 1.39518); 28 | return( (hc - spline(x=time, y = muGhc, xout = age)$y) / spline(x=time, y = sdGhc, xout = age)$y) 29 | } else if(sex == 'M'){ 30 | # http://www.who.int/childgrowth/standards/second_set/tab_hcfa_boys_p_0_5.txt 31 | muBhc = c(34.4618, 37.2759, 39.1285, 40.5135, 41.6317, 42.5576, 43.3306, 43.9803, 44.5300, 32 | 44.9998, 45.4051, 45.7573, 46.0661, 46.3395, 46.5844, 46.8060, 47.0088, 47.1962, 33 | 47.3711, 47.5357, 47.6919, 47.8408, 47.9833, 48.1201, 48.2515) 34 | sdBhc = c(1.27026, 1.16785, 1.17268, 1.18218, 1.19400, 1.20736, 1.22062, 1.23321, 1.24506, 35 | 1.25639, 1.26680, 1.27617, 1.28478, 1.29241, 1.30017, 1.30682, 1.31390, 1.32008, 36 | 1.32639, 1.33243, 1.33823, 1.34433, 1.34977, 1.35554, 1.36667) 37 | return( (hc - spline(x=time, y = muBhc, xout = age)$y) / spline(x=time, y = sdBhc, xout = age)$y) 38 | } else{ 39 | stop("Sex type undefined.") 40 | } 41 | } -------------------------------------------------------------------------------- /src/GetIndCEScoresCPPnewInd.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include // to get std::lower_bound 3 | #include // to get std::iterator 4 | #include // to get NaN 5 | 6 | // [[Rcpp::depends(RcppEigen)]] 7 | // Be carefu; not to export this guy!! 8 | Eigen::MatrixXd pinv( const Eigen::MatrixXd& Mat){ 9 | // This is a slow puppy 10 | const double pinvtol = 1.e-9; // Tolerance! 11 | Eigen::JacobiSVD svdMat(Mat, Eigen::ComputeThinU | Eigen::ComputeThinV); 12 | Eigen::VectorXd S = svdMat.singularValues(); 13 | Eigen::VectorXd Sinv = S; 14 | 15 | for ( int i=0; i pinvtol ){ 17 | Sinv(i)=1.0/S(i); 18 | } else { 19 | Sinv(i)=0; 20 | } 21 | } 22 | return(svdMat.matrixV()*Sinv.asDiagonal()*svdMat.matrixU().transpose()); 23 | } 24 | 25 | // [[Rcpp::export]] 26 | Rcpp::List GetIndCEScoresCPPnewInd( const Eigen::Map & yVec, const Eigen::Map & muVec, const Eigen::Map & lamVec, const Eigen::Map & phiMat, const Eigen::Map & SigmaYi, const Eigen::Map & newPhi, const Eigen::Map & newMu ){ 27 | 28 | // Setting up initial values 29 | // const unsigned int lenyVec = yVec.size(); 30 | const unsigned int lenlamVec = lamVec.size(); 31 | 32 | Eigen::MatrixXd xiVar = Eigen::MatrixXd::Constant(lenlamVec,lenlamVec,std::numeric_limits::quiet_NaN()); 33 | Eigen::MatrixXd xiEst = Eigen::MatrixXd::Constant(lenlamVec,1,std::numeric_limits::quiet_NaN()); 34 | Eigen::MatrixXd fittedY = Eigen::MatrixXd::Constant(lenlamVec,1,std::numeric_limits::quiet_NaN()); 35 | 36 | Eigen::MatrixXd LamPhi = lamVec.asDiagonal() * phiMat.transpose(); 37 | // Eigen::MatrixXd LamPhiSig = LamPhi * SigmaYi.inverse(); // LamPhi * pinv(SigmaYi); // // Original code. 38 | Eigen::LDLT ldlt_SigmaYi(SigmaYi); 39 | 40 | xiEst = LamPhi * ldlt_SigmaYi.solve(yVec - muVec) ;// LamPhiSig * (yVec - muVec); 41 | xiVar = -LamPhi * ldlt_SigmaYi.solve(LamPhi.transpose()); // LamPhiSig.transpose(); 42 | xiVar.diagonal() += lamVec; 43 | fittedY = newMu + newPhi * xiEst; 44 | 45 | return Rcpp::List::create(Rcpp::Named("xiEst") = xiEst, 46 | Rcpp::Named("xiVar") = xiVar, 47 | Rcpp::Named("fittedY") = fittedY); 48 | } 49 | 50 | -------------------------------------------------------------------------------- /R/MakeGPFunctionalData.R: -------------------------------------------------------------------------------- 1 | #' Create a Dense Functional Data sample for a Gaussian process 2 | #' 3 | #' For a Gaussian process, create a dense functional data sample of size n over a [0,1] support. 4 | #' 5 | #' @param n number of samples to generate 6 | #' @param M number of equidistant readings per sample (default: 100) 7 | #' @param mu vector of size M specifying the mean (default: rep(0,M)) 8 | #' @param K scalar specifying the number of basis to be used (default: 2) 9 | #' @param lambda vector of size K specifying the variance of each components (default: rep(1,K)) 10 | #' @param sigma The standard deviation of the Gaussian noise added to each observation points. 11 | #' @param basisType string specifying the basis type used; possible options are: 'sin', 'cos' and 'fourier' (default: 'cos') (See code of 'CreateBasis' for implementation details.) 12 | #' 13 | #' @return A list containing the following fields: 14 | #' \item{Y}{A vector of noiseless observations.} 15 | #' \item{Yn}{A vector of noisy observations if \code{sigma} > 0.} 16 | #' @export 17 | 18 | MakeGPFunctionalData <-function(n, M = 100, mu=rep(0,M), K = 2, lambda = rep(1,K), sigma=0, basisType='cos'){ 19 | 20 | if(n <2){ 21 | stop("Samples of size 1 are irrelevant.") 22 | } 23 | if(M <20){ 24 | stop("Dense samples with less than 20 observations per subject are irrelevant.") 25 | } 26 | if (!is.numeric(sigma) || sigma < 0) { 27 | stop("'sigma' needs to be a nonnegative number") 28 | } 29 | s <- seq(0,1,length.out = M) 30 | 31 | if(length(mu) != M){ 32 | stop("Make sure that 'M' and the number of points over which 'mu' is evaluated is the same.") 33 | } 34 | # if(is.null(lambda)){ 35 | # lambda = seq(K,1,-1) 36 | # } 37 | if(K != length(lambda)){ 38 | stop("Make sure you provide 'lambda's for all 'K' modes of variation.") 39 | } 40 | # if( !(basisType %in% c('cos','sin','fourier'))){ 41 | # stop("Make sure you provide a valid parametric basis.") 42 | # } 43 | 44 | Ksi <- apply(matrix(rnorm(n*K), ncol=K), 2, scale) %*% diag(sqrt(lambda)) 45 | Phi <- CreateBasis(pts= s, type= basisType, K = K) 46 | 47 | yTrue <- t(matrix(rep(mu,n), nrow=M)) + Ksi %*% t(Phi) 48 | 49 | res <- list(Y = yTrue, Phi = Phi, xi=Ksi, pts=s) 50 | 51 | if (sigma > 0) { 52 | yNoisy <- yTrue + rnorm(n * M, sd=sigma) 53 | res <- c(res, list(Yn = yNoisy)) 54 | } 55 | 56 | return(res) 57 | } 58 | 59 | -------------------------------------------------------------------------------- /tests/testthat/test_CreateStringingPlot.R: -------------------------------------------------------------------------------- 1 | # test CreateStringingPlot 2 | library(testthat) 3 | 4 | # implement the first kind of simulation in stringing paper 5 | # Fourier basis, specify signal-to-noise ratio (SNR), number of components used 6 | # returns true underlying curves XTraj, and randomly ordered design matrix X 7 | stringing_sim1 <- function(K = 4, SNR = 10, n = 50, p = 50){ 8 | grid = seq(5/p,5,5/p) 9 | lambda = 8*(0.5^(1:K)) # exponential decay 10 | phi = cbind(-sqrt(0.2)*cos(0.2*pi*grid), sqrt(0.2)*sin(0.2*pi*grid), 11 | -sqrt(0.2)*cos(0.4*pi*grid), sqrt(0.2)*sin(0.4*pi*grid)) 12 | scores = t(MASS::mvrnorm(n = n, mu = rep(0,K), Sigma = diag(lambda))) 13 | Xtrue = t(phi %*% scores) # ith row corresponds to ith subject 14 | if(SNR == Inf){ 15 | Xt = Xtrue 16 | } else { 17 | Xt = Xtrue + rnorm(n*p, mean=0, sd=mean(abs(Xtrue))/SNR) 18 | } 19 | rdmorder = sample(x = 1:p, size = p, replace = FALSE) # random columns indices for the original order 20 | X = Xt[,rdmorder] 21 | return(list(XTraj = Xt, X = X, order = rdmorder, n = n, p = p, RegGrid = grid)) 22 | } 23 | 24 | test_that("CreateStringingPlot works",{ 25 | set.seed(1) 26 | simdata = stringing_sim1(SNR = Inf) 27 | stringingfit = Stringing(simdata$X, disOptns = "correlation") 28 | # check with simulated data to see if reversal of order is needed 29 | diff_norev = sum(abs(simdata$order[stringingfit$StringingOrder] - 1:simdata$p)) 30 | diff_rev = sum(abs(simdata$order[stringingfit$StringingOrder] - simdata$p:1)) 31 | if(diff_rev <= diff_norev){ 32 | stringingfit$StringingOrder = rev(stringingfit$StringingOrder) 33 | stringingfit$Ly = lapply(stringingfit$Ly, rev) 34 | } 35 | CreateStringingPlot(stringingObj = stringingfit, subset = 1:10) 36 | }) 37 | 38 | test_that("CreateStringingPlot works",{ 39 | set.seed(1) 40 | simdata = stringing_sim1(SNR = Inf) 41 | stringingfit = Stringing(simdata$X, disOptns = "euclidean", standardize = TRUE) 42 | # check with simulated data to see if reversal of order is needed 43 | diff_norev = sum(abs(simdata$order[stringingfit$StringingOrder] - 1:simdata$p)) 44 | diff_rev = sum(abs(simdata$order[stringingfit$StringingOrder] - simdata$p:1)) 45 | if(diff_rev <= diff_norev){ 46 | stringingfit$StringingOrder = rev(stringingfit$StringingOrder) 47 | stringingfit$Ly = lapply(stringingfit$Ly, rev) 48 | } 49 | CreateStringingPlot(stringingObj = stringingfit, subset = 1:10) 50 | }) 51 | -------------------------------------------------------------------------------- /man/Dyn_test.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Dyn_test.R 3 | \name{Dyn_test} 4 | \alias{Dyn_test} 5 | \title{Bootstrap test of Dynamic Correlation} 6 | \usage{ 7 | Dyn_test(x1, y1, t1, x2, y2, t2, B = 1000) 8 | } 9 | \arguments{ 10 | \item{x1}{a n by m matrix where rows representing subjects and columns representing measurements, missings are allowed.} 11 | 12 | \item{y1}{a n by m matrix where rows representing subjects and columns representing measurements, missings are allowed.} 13 | 14 | \item{t1}{a vector of time points where x1,y1 are observed.} 15 | 16 | \item{x2}{(optional if missing will be one sample test) a n by m matrix where rows representing subjects and columns representing measurements, missings are allowed.} 17 | 18 | \item{y2}{(optional if missing will be one sample test) a n by m matrix where rows representing subjects and columns representing measurements, missings are allowed.} 19 | 20 | \item{t2}{(optional if missing will be one sample test) a vector of time points where x2,y2 are observed.} 21 | 22 | \item{B}{number of bootstrap samples.} 23 | } 24 | \value{ 25 | a list of the following 26 | \item{stats}{Test statistics.} 27 | \item{pval}{p-value of the test.} 28 | } 29 | \description{ 30 | Perform one sample (H0: Dynamic correlation = 0) or two sample (H0:Dynamic_correlation_1 = Dynamic_correlation_2) bootstrap test 31 | of H_0: Dynamical Correlation=0. 32 | } 33 | \examples{ 34 | n=20 # sample size 35 | t=seq(0,1,length.out=100) # length of data 36 | mu_quad_x=8*t^2-4*t+5 37 | mu_quad_y=8*t^2-12*t+6 38 | fun=rbind(rep(1,length(t)),-t,t^2) 39 | z1=matrix(0,n,3) 40 | z1[,1]=rnorm(n,0,2) 41 | z1[,2]=rnorm(n,0,16/3) 42 | z1[,3]=rnorm(n,0,4) # covariance matrix of random effects 43 | x1_quad_error=y1_quad_error=matrix(0,nrow=n,ncol=length(t)) 44 | for (i in 1:n){ 45 | x1_quad_error[i,]=mu_quad_x+z1[i,]\%*\%fun+rnorm(length(t),0,0.01) 46 | y1_quad_error[i,]=mu_quad_y+2*z1[i,]\%*\%fun +rnorm(length(t),0,0.01) 47 | } 48 | bt_DC=Dyn_test(x1_quad_error,y1_quad_error,t,B=500) # using B=500 for speed consideration 49 | 50 | } 51 | \references{ 52 | \cite{Dubin J A, Müller H G. (2005) Dynamical correlation for multivariate longitudinal data. 53 | Journal of the American Statistical Association 100(471): 872-881.} 54 | 55 | \cite{Liu S, Zhou Y, Palumbo R, Wang, J.L. (2016). Dynamical correlation: A new method for quantifying synchrony with multivariate intensive 56 | longitudinal data. Psychological Methods 21(3): 291.} 57 | } 58 | -------------------------------------------------------------------------------- /tests/testthat/test_GetRho.R: -------------------------------------------------------------------------------- 1 | # devtools::load_all() 2 | #options(error=recover) 3 | library(testthat) 4 | 5 | # set up 6 | y <- list(c(1, 2), 4, c(0, 2, 3)) 7 | t <- list(c(1.5, 2.5), 2, c(1, 1.5, 2.5)) 8 | obsGrid <- seq(0, 3, length.out=7) 9 | mu <- obsGrid 10 | pts <- seq(0, 1, length.out=7) 11 | phi <- cbind(sin(2 * pi * pts), cos(2 * pi * pts)) 12 | lambda <- c(6, 1) 13 | rho <- 0.5 14 | fittedCov <- phi %*% diag(lambda) %*% t(phi) 15 | 16 | 17 | test_that('Truncation works for GetRho', { 18 | set.seed(1) 19 | n <- 20 20 | pts <- signif(seq(0, 1, by=0.05), 14) 21 | truncPts <- signif(seq(0.1, 0.9, 0.05), 14) 22 | mu <- rep(0, length(pts)) 23 | samp4 <- Wiener(n, pts) + rnorm(n * length(pts), sd=0.1) 24 | samp4 <- Sparsify(samp4, pts, 10) 25 | samp4$Ly[[1]] <- samp4$Lt[[1]] <- c(0, 1) 26 | samp4Trunc <- TruncateObs(samp4$Ly, samp4$Lt, truncPts) 27 | pTrunc <- SetOptions(samp4$Ly, samp4$Lt, list(dataType='Sparse', error=TRUE, kernel='epan', verbose=TRUE)) 28 | smc4 <- GetSmoothedCovarSurface(samp4$Ly, samp4$Lt, mu, pts, pts, pTrunc) 29 | eig4 <- GetEigenAnalysisResults(smc4$smoothCov, pts, pTrunc) 30 | phiObs <- ConvertSupport(pts, truncPts, phi=eig4$phi) 31 | CovObs <- ConvertSupport(pts, truncPts, Cov=eig4$fittedCov) 32 | 33 | rho4 <- GetRho(samp4Trunc$Ly, samp4Trunc$Lt, pTrunc, mu[1:length(truncPts)],mu[1:length(truncPts)],truncPts, CovObs, eig4$lambda, phiObs, phiObs, truncPts,smc4$sigma2) 34 | expect_true(rho4 < 0.2) 35 | }) 36 | # # Matlab code: 37 | # y{1} = [1, 2]; y{2} = [4]; y{3} = [0, 2, 3] 38 | # t{1} = [1.5, 2.5]; t{2} = [2]; t{3} = [1, 1.5, 2.5] 39 | # ni = cellfun(@length, y); 40 | # mu = linspace(0, 3, 7); 41 | # out1 = linspace(0, 3, 7); 42 | # pts = linspace(0, 1, 7); 43 | # phi = [sin(2 * pi * pts)', cos(2 * pi * pts)']; 44 | # lambda = [6, 1]; 45 | # sigma = 0; 46 | # sig1 = 0.4; 47 | # noeig = 2; 48 | # error = 1; 49 | # method = 'CE'; 50 | # shrink = 0; 51 | # regular = 0; 52 | # rho = 0; 53 | # [muSub, phiSub] = convertMuPhi(t, out1, mu, phi, regular); 54 | # LAMBDA = diag(lambda); 55 | # rho = 0.5; 56 | # subID = [1 3]; 57 | # tjID = [2 1 2 3]; 58 | # verbose = false; 59 | 60 | # getScores2(y, t, mu, phi, lambda, sigma, sig1, noeig, error, method, shrink, out1, regular, muSub, phiSub, LAMBDA, rho, subID, tjID) 61 | 62 | # T = range(out1); 63 | # gamma = ((trapz(out1, mu.^2)+sum(lambda))/T)^(0.5); 64 | # alpha = linspace(0.01, 0.22,50); 65 | # rho = gamma*alpha; 66 | # cv_rho(y, t, mu, phi, lambda, sigma, sig1, noeig, error, method, shrink, out1, regular, rho, ni, tjID, verbose) 67 | 68 | -------------------------------------------------------------------------------- /man/FLMCI.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/FLMCI.R 3 | \name{FLMCI} 4 | \alias{FLMCI} 5 | \title{Confidence Intervals for Functional Linear Models.} 6 | \usage{ 7 | FLMCI(Y, X, level = 0.95, R = 999, optnsListY = NULL, optnsListX = NULL) 8 | } 9 | \arguments{ 10 | \item{Y}{Either an n-dimensional vector whose elements consist of scalar responses, or a list which contains functional responses in the form of a list LY and the time points LT at which they are observed (i.e., \code{list(Ly = LY,Lt = LT)}).} 11 | 12 | \item{X}{A list of lists which contains the observed functional predictors list Lxj and the time points list Ltj at which they are observed. It needs to be of the form \code{list(list(Ly = Lx1,Lt = Lxt1),list(Ly = Lx2,Lt = Lxt2),...)}.} 13 | 14 | \item{level}{A number taking values in [0,1] determining the confidence level. Default: 0.95.} 15 | 16 | \item{R}{An integer holding the number of bootstrap replicates. Default: 999.} 17 | 18 | \item{optnsListY}{A list of options control parameters for the response specified by \code{list(name=value)}. See 'Details' in FPCA.} 19 | 20 | \item{optnsListX}{A list of options control parameters for the predictors specified by \code{list(name=value)}. See 'Details' in FPCA.} 21 | } 22 | \value{ 23 | A list containing the following fields: 24 | \item{CI_alpha}{CI for the intercept function --- A data frame holding three variables: 25 | \code{CI_grid} --- the time grid where the CIs are evaluated, 26 | \code{CI_lower} and \code{CI_upper} --- the lower and upper bounds of the CIs 27 | for the intercept function on \code{CIgrid}.} 28 | \item{CI_beta}{ A list containing CIs for the slope functions --- the length of 29 | the list is the same as the number of covariates. Each list contains the following fields: 30 | A data frame holding three variables: \code{CI_grid} --- the time grid where the CIs are evaluated, 31 | \code{CI_lower} and \code{CI_upper} --- the lower and upper bounds of the CIs 32 | for the coefficient function on \code{CIgrid} for \eqn{j = 1,2,\dots}.} 33 | \item{level}{The confidence level of the CIs.} 34 | } 35 | \description{ 36 | Bootstrap pointwise confidence intervals for the coefficient functions in functional linear models. 37 | } 38 | \details{ 39 | If measurement error is assumed, the diagonal elements of the raw covariance will be removed. This could result in highly unstable estimate 40 | if the design is very sparse, or strong seasonality presents. 41 | WARNING! For very sparse functional data, setting \code{measurementError=TRUE} is not recommended. 42 | } 43 | -------------------------------------------------------------------------------- /R/CreateBasis.R: -------------------------------------------------------------------------------- 1 | #' Create an orthogonal basis of K functions in [0, 1], with nGrid points. 2 | #' 3 | #' @param K A positive integer specifying the number of eigenfunctions to generate. 4 | #' @param pts A vector specifying the time points to evaluate the basis functions. 5 | #' @param type A string for the type of orthogonal basis. 6 | #' @return A K by nGrid matrix, each column containing an basis function. 7 | #' 8 | #' @examples 9 | #' basis <- CreateBasis(3, type='fourier') 10 | #' head(basis) 11 | #' 12 | #' @export 13 | CreateBasis <- function(K, pts=seq(0, 1, length.out=50), type=c('cos', 'sin', 'fourier', 'legendre01', 'poly')) { 14 | 15 | nGrid <- length(pts) 16 | type <- match.arg(type) 17 | 18 | stopifnot(is.numeric(K) && length(K) == 1 && K > 0) 19 | 20 | if (type == 'cos') { 21 | res <- sapply(seq_len(K), function(k) 22 | if (k == 1) { 23 | rep(1, nGrid) 24 | } else { 25 | sqrt(2) * cos((k - 1) * pi * pts) 26 | } 27 | ) 28 | } else if (type == 'sin') { 29 | res <- sapply(seq_len(K), function(k) sqrt(2) * sin(k * pi * pts)) 30 | } else if (type == 'fourier') { 31 | res <- sapply(seq_len(K), function(k) 32 | if (k == 1) { 33 | rep(1, nGrid) 34 | } else if (k %% 2 == 0) { 35 | sqrt(2) * sin(k * pi * pts) 36 | } else { 37 | sqrt(2) * cos((k - 1) * pi * pts) 38 | } 39 | ) 40 | } else if (type == 'legendre01') { 41 | # coefMat <- matrix(0, K, K) 42 | if (K == 1) { 43 | res <- matrix(1, length(pts), 1) 44 | } else if (K > 1) { 45 | coefMat <- sapply(seq_len(K), function(n) { 46 | coef <- rep(0, K) 47 | # # coef[1] <- (-1)^(n - 1) 48 | for (k in seq_len(n)) { 49 | coef[k] <- (-1)^(n - k) * choose(n - 1, k - 1) * 50 | choose(n + k - 2, k - 1) 51 | } 52 | coef * sqrt(2 * n - 1) 53 | }) 54 | xMat <- cbind(1, stats::poly(pts, K - 1, raw=TRUE)) 55 | res <- xMat %*% coefMat 56 | # browser() 57 | } 58 | 59 | if (K >= 25) { 60 | warning('Numeric unstability may occur. Use K < 25.') 61 | } 62 | } else if (type == 'poly') { 63 | if (K == 1) { 64 | res <- matrix(1, length(pts), 1) 65 | } else if (K > 1) { 66 | res <- cbind(1, stats::poly(pts, K - 1, raw=TRUE)) 67 | } 68 | 69 | if (K >= 25) { 70 | warning('Numeric unstability may occur. Use K < 25.') 71 | } 72 | } else if (type == 'unknown') { 73 | stop('unknown basis type') 74 | } 75 | 76 | res <- matrix(res, ncol=K) # prevent single length pts 77 | res 78 | } 79 | --------------------------------------------------------------------------------