├── .github ├── .gitignore ├── pull_request_template.md └── workflows │ ├── pkgdown.yaml │ ├── test-coverage.yaml │ ├── check-standard.yaml │ └── pr-commands.yaml ├── vignettes ├── .gitignore ├── demo-one-dim-location.Rmd └── demo-two-dim-location.Rmd ├── R ├── global.R ├── zzz.R ├── RcppExports.R ├── helper.R └── SpatPCA.R ├── tests ├── testthat.R └── testthat │ ├── test-zzz.R │ ├── test-RcppExports.R │ ├── test-helper.R │ └── test-SpatPCA.R ├── NAMESPACE ├── src ├── Makevars ├── Makevars.win ├── RcppExports.cpp └── RcppSpatPCA.cpp ├── .Rbuildignore ├── .gitignore ├── codecov.yml ├── man ├── detrend.Rd ├── scaleLocation.Rd ├── setL2.Rd ├── checkInputData.Rd ├── setCores.Rd ├── setTau1.Rd ├── setTau2.Rd ├── setGamma.Rd ├── fetchUpperBoundNumberEigenfunctions.Rd ├── checkNewLocationsForSpatpcaObject.Rd ├── setNumberEigenfunctions.Rd ├── thinPlateSplineMatrix.Rd ├── SpatPCA-package.Rd ├── plot.spatpca.Rd ├── eigenFunction.Rd ├── spatialPrediction.Rd ├── spatpcaCV.Rd ├── predictEigenfunction.Rd ├── predict.Rd ├── spatpcaCVWithSelectedK.Rd └── spatpca.Rd ├── DESCRIPTION ├── NEWS.md ├── README.md └── LICENSE /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /vignettes/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | *.R 3 | -------------------------------------------------------------------------------- /R/global.R: -------------------------------------------------------------------------------- 1 | utils::globalVariables(c( 2 | "parameter", 3 | "cv", 4 | "type" 5 | )) 6 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | .onAttach <- function(libname, pkgname) { 2 | packageStartupMessage("Welcome to SpatPCA") 3 | } 4 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | 3 | if (!testthat:::on_cran()) { 4 | library(SpatPCA) 5 | test_check("SpatPCA") 6 | } 7 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | useDynLib(SpatPCA, .registration = TRUE) 2 | exportPattern("^[[:alpha:]]+") 3 | export(spatpca) 4 | importFrom(Rcpp, evalCpp) 5 | import(ggplot2) 6 | S3method(plot, spatpca) 7 | -------------------------------------------------------------------------------- /src/Makevars: -------------------------------------------------------------------------------- 1 | PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) 2 | PKG_CXXFLAGS += -DRCPP_PROTECTED_EVAL -DRCPP_USE_UNWIND_PROTECTOR 3 | PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 4 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^_pkgdown\.yml$ 4 | ^docs$ 5 | ^pkgdown$ 6 | .travis.yml 7 | ^\.github$ 8 | ^codecov\.yml$ 9 | ^.*\.gcno$ 10 | ^NEWS$ 11 | LICENSE 12 | \.github 13 | -------------------------------------------------------------------------------- /src/Makevars.win: -------------------------------------------------------------------------------- 1 | PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) 2 | PKG_CXXFLAGS += -DRCPP_PROTECTED_EVAL -DRCPP_USE_UNWIND_PROTECTOR 3 | PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | src/*.o 6 | src/*.so 7 | src/*.dll 8 | .DS_Store 9 | src/.DS_Store 10 | inst/doc 11 | *.gcno 12 | *Rplots.pdf 13 | tools 14 | *.Rproj 15 | -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: false 2 | 3 | coverage: 4 | status: 5 | project: 6 | default: 7 | target: auto 8 | threshold: 1% 9 | informational: true 10 | patch: 11 | default: 12 | target: auto 13 | threshold: 1% 14 | informational: true 15 | -------------------------------------------------------------------------------- /.github/pull_request_template.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | ## Objective 4 | 5 | 6 | ## Changes 7 | 8 | 9 | ## Example 10 | 12 | -------------------------------------------------------------------------------- /man/detrend.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/helper.R 3 | \name{detrend} 4 | \alias{detrend} 5 | \title{Internal function: Detrend Y by column-wise centering} 6 | \usage{ 7 | detrend(Y, is_Y_detrended) 8 | } 9 | \arguments{ 10 | \item{Y}{Data matrix} 11 | } 12 | \value{ 13 | Detrended data matrix 14 | } 15 | \description{ 16 | Internal function: Detrend Y by column-wise centering 17 | } 18 | \keyword{internal} 19 | -------------------------------------------------------------------------------- /man/scaleLocation.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/helper.R 3 | \name{scaleLocation} 4 | \alias{scaleLocation} 5 | \title{Internal function: Scale one-dimension locations} 6 | \usage{ 7 | scaleLocation(location) 8 | } 9 | \arguments{ 10 | \item{location}{Location matrix} 11 | } 12 | \value{ 13 | scaled location matrix 14 | } 15 | \description{ 16 | Internal function: Scale one-dimension locations 17 | } 18 | \keyword{internal} 19 | -------------------------------------------------------------------------------- /man/setL2.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/helper.R 3 | \name{setL2} 4 | \alias{setL2} 5 | \title{Internal function: Set tuning parameter - l2} 6 | \usage{ 7 | setL2(tau2) 8 | } 9 | \arguments{ 10 | \item{tau2}{Vector of a nonnegative sparseness parameter sequence. Default is NULL.} 11 | } 12 | \value{ 13 | Modified vector of a nonnegative tuning parameter sequence for ADMM use 14 | } 15 | \description{ 16 | Internal function: Set tuning parameter - l2 17 | } 18 | \keyword{internal} 19 | -------------------------------------------------------------------------------- /man/checkInputData.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/helper.R 3 | \name{checkInputData} 4 | \alias{checkInputData} 5 | \title{Internal function: Validate input data for a spatpca object} 6 | \usage{ 7 | checkInputData(Y, x, M) 8 | } 9 | \arguments{ 10 | \item{Y}{Data matrix} 11 | 12 | \item{x}{Location matrix.} 13 | 14 | \item{M}{Number of folds for cross-validation} 15 | } 16 | \value{ 17 | \code{NULL}. 18 | } 19 | \description{ 20 | Internal function: Validate input data for a spatpca object 21 | } 22 | \keyword{internal} 23 | -------------------------------------------------------------------------------- /man/setCores.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/helper.R 3 | \name{setCores} 4 | \alias{setCores} 5 | \title{Internal helper: validate requested core count} 6 | \usage{ 7 | setCores(num_cores = NULL) 8 | } 9 | \arguments{ 10 | \item{num_cores}{Optional numeric value representing desired cores. Default is NULL.} 11 | } 12 | \value{ 13 | Logical when a numeric input is provided, otherwise NULL 14 | } 15 | \description{ 16 | Validate the requested number of cores; computations currently run sequentially. 17 | } 18 | \keyword{internal} 19 | -------------------------------------------------------------------------------- /man/setTau1.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/helper.R 3 | \name{setTau1} 4 | \alias{setTau1} 5 | \title{Internal function: Set tuning parameter - tau1} 6 | \usage{ 7 | setTau1(tau1, M) 8 | } 9 | \arguments{ 10 | \item{tau1}{Vector of a nonnegative smoothness parameter sequence. Default is NULL.} 11 | 12 | \item{M}{Number of folds for cross-validation} 13 | } 14 | \value{ 15 | Modified vector of a nonnegative smoothness parameter sequence. 16 | } 17 | \description{ 18 | Internal function: Set tuning parameter - tau1 19 | } 20 | \keyword{internal} 21 | -------------------------------------------------------------------------------- /man/setTau2.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/helper.R 3 | \name{setTau2} 4 | \alias{setTau2} 5 | \title{Internal function: Set tuning parameter - tau2} 6 | \usage{ 7 | setTau2(tau2, M) 8 | } 9 | \arguments{ 10 | \item{tau2}{Vector of a nonnegative sparseness parameter sequence. Default is NULL.} 11 | 12 | \item{M}{Number of folds for cross-validation} 13 | } 14 | \value{ 15 | Modified vector of a nonnegative sparseness parameter sequence. 16 | } 17 | \description{ 18 | Internal function: Set tuning parameter - tau2 19 | } 20 | \keyword{internal} 21 | -------------------------------------------------------------------------------- /man/setGamma.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/helper.R 3 | \name{setGamma} 4 | \alias{setGamma} 5 | \title{Internal function: Set tuning parameter - gamma} 6 | \usage{ 7 | setGamma(gamma, Y) 8 | } 9 | \arguments{ 10 | \item{gamma}{Vector of a nonnegative hyper parameter sequence for tuning eigenvalues. Default is NULL.} 11 | 12 | \item{Y}{Data matrix} 13 | } 14 | \value{ 15 | Modified vector of a nonnegative hyper parameter sequence for tuning eigenvalues. 16 | } 17 | \description{ 18 | Internal function: Set tuning parameter - gamma 19 | } 20 | \keyword{internal} 21 | -------------------------------------------------------------------------------- /man/fetchUpperBoundNumberEigenfunctions.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/helper.R 3 | \name{fetchUpperBoundNumberEigenfunctions} 4 | \alias{fetchUpperBoundNumberEigenfunctions} 5 | \title{Internal function: Fetch the upper bound of the number of eigenfunctions} 6 | \usage{ 7 | fetchUpperBoundNumberEigenfunctions(Y, M) 8 | } 9 | \arguments{ 10 | \item{Y}{Data matrix} 11 | 12 | \item{M}{Number of folds for cross-validation} 13 | } 14 | \value{ 15 | integer 16 | } 17 | \description{ 18 | Internal function: Fetch the upper bound of the number of eigenfunctions 19 | } 20 | \keyword{internal} 21 | -------------------------------------------------------------------------------- /man/checkNewLocationsForSpatpcaObject.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/helper.R 3 | \name{checkNewLocationsForSpatpcaObject} 4 | \alias{checkNewLocationsForSpatpcaObject} 5 | \title{Internal function: Validate new locations for a spatpca object} 6 | \usage{ 7 | checkNewLocationsForSpatpcaObject(spatpca_object, x_new) 8 | } 9 | \arguments{ 10 | \item{spatpca_object}{An \code{spatpca} class object} 11 | 12 | \item{x_new}{New location matrix.} 13 | } 14 | \value{ 15 | \code{NULL}. 16 | } 17 | \description{ 18 | Internal function: Validate new locations for a spatpca object 19 | } 20 | \keyword{internal} 21 | -------------------------------------------------------------------------------- /man/setNumberEigenfunctions.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/helper.R 3 | \name{setNumberEigenfunctions} 4 | \alias{setNumberEigenfunctions} 5 | \title{Internal function: Set the number of eigenfunctions for a spatpca object} 6 | \usage{ 7 | setNumberEigenfunctions(K, Y, M) 8 | } 9 | \arguments{ 10 | \item{K}{Optional user-supplied number of eigenfunctions.} 11 | 12 | \item{Y}{Data matrix} 13 | 14 | \item{M}{Number of folds for cross-validation} 15 | } 16 | \value{ 17 | integer 18 | } 19 | \description{ 20 | Internal function: Set the number of eigenfunctions for a spatpca object 21 | } 22 | \keyword{internal} 23 | -------------------------------------------------------------------------------- /man/thinPlateSplineMatrix.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{thinPlateSplineMatrix} 4 | \alias{thinPlateSplineMatrix} 5 | \title{Thin-plane spline matrix} 6 | \usage{ 7 | thinPlateSplineMatrix(location) 8 | } 9 | \arguments{ 10 | \item{location}{A location matrix} 11 | } 12 | \value{ 13 | A thin-plane spline matrix 14 | } 15 | \description{ 16 | Produce a thin-plane spline matrix based on a given location matrix 17 | } 18 | \examples{ 19 | pesudo_sequence <- seq(-5, 5, length = 5) 20 | two_dim_location <- as.matrix(expand.grid(x = pesudo_sequence, y = pesudo_sequence)) 21 | thin_plate_matrix <- thinPlateSplineMatrix(two_dim_location) 22 | } 23 | -------------------------------------------------------------------------------- /man/SpatPCA-package.Rd: -------------------------------------------------------------------------------- 1 | \name{SpatPCA-package} 2 | \alias{SpatPCA-package} 3 | \docType{package} 4 | \title{Regularized Principal Component Analysis for Spatial Data} 5 | \description{ 6 | A new regularization approach to estimate the leading spatial patterns via smoothness and sparseness penalties, and spatial predictions for spatial data that may be irregularly located in space (including 1D, 2D and 3D), and obtain the spatial prediction at the designated locations. 7 | } 8 | \details{\tabular{ll}{ 9 | Package:\tab SpatPCA\cr 10 | Type:\tab Package\cr 11 | Version:\tab 1.3.3.4\cr 12 | Date:\tab 2021-02-11\cr 13 | License: \tab GPL version 3\cr 14 | } 15 | } 16 | \author{ 17 | Wen-Ting Wang and Hsin-Cheng Huang 18 | } -------------------------------------------------------------------------------- /tests/testthat/test-zzz.R: -------------------------------------------------------------------------------- 1 | test_that(".onAttach only emits welcome message", { 2 | original_backend <- Sys.getenv("RCPP_PARALLEL_BACKEND", unset = "") 3 | output <- capture_message(.onAttach("SpatPCA", "SpatPCA")) 4 | expect_match(output$message, "Welcome to SpatPCA") 5 | expect_equal(Sys.getenv("RCPP_PARALLEL_BACKEND", unset = ""), original_backend) 6 | }) 7 | 8 | test_that(".onAttach does not depend on NOT_CRAN", { 9 | Sys.setenv(NOT_CRAN = "true") 10 | original_backend <- Sys.getenv("RCPP_PARALLEL_BACKEND", unset = "") 11 | output <- capture_message(.onAttach("SpatPCA", "SpatPCA")) 12 | expect_match(output$message, "Welcome to SpatPCA") 13 | expect_equal(Sys.getenv("RCPP_PARALLEL_BACKEND", unset = ""), original_backend) 14 | Sys.unsetenv("NOT_CRAN") 15 | }) 16 | -------------------------------------------------------------------------------- /man/plot.spatpca.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/SpatPCA.R 3 | \name{plot.spatpca} 4 | \alias{plot.spatpca} 5 | \title{Display the cross-validation results} 6 | \usage{ 7 | \method{plot}{spatpca}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{An spatpca class object for \code{plot} method} 11 | 12 | \item{...}{Not used directly} 13 | } 14 | \value{ 15 | \code{NULL}. 16 | } 17 | \description{ 18 | Display the M-fold cross-validation results 19 | } 20 | \examples{ 21 | x_1D <- as.matrix(seq(-5, 5, length = 10)) 22 | Phi_1D <- exp(-x_1D^2) / norm(exp(-x_1D^2), "F") 23 | set.seed(1234) 24 | Y_1D <- rnorm(n = 100, sd = 3) \%*\% t(Phi_1D) + matrix(rnorm(n = 100 * 10), 100, 10) 25 | cv_1D <- spatpca(x = x_1D, Y = Y_1D) 26 | plot(cv_1D) 27 | } 28 | \seealso{ 29 | \link{spatpca} 30 | } 31 | -------------------------------------------------------------------------------- /tests/testthat/test-RcppExports.R: -------------------------------------------------------------------------------- 1 | tol <- 1e-6 2 | pesudo_sequence <- seq(-5, 5, length = 2) 3 | two_dim_location <- 4 | as.matrix(expand.grid(x = pesudo_sequence, y = pesudo_sequence)) 5 | 6 | three_dim_location <- 7 | as.matrix(expand.grid(x = pesudo_sequence, y = pesudo_sequence, z = pesudo_sequence)) 8 | 9 | # thinPlateMatrix 10 | thin_plate_matrix_2D <- thinPlateSplineMatrix(two_dim_location) 11 | thin_plate_matrix_3D <- thinPlateSplineMatrix(three_dim_location) 12 | test_that("Thin-Plate Spline Matrix", { 13 | expect_lte(norm(thin_plate_matrix_2D, "F") - 0.362588, tol) 14 | expect_lte(norm(thin_plate_matrix_3D, "F") - 8.191034, tol) 15 | }) 16 | 17 | # spatialPrediction 18 | Phi <- matrix(c(1, 0, 0, 0), nrow = 4, ncol = 1) 19 | new_location <- matrix(c(0.1, 0.2), nrow = 1, ncol = 2) 20 | test_that("Eigen-function", { 21 | expect_lte(eigenFunction(new_location, two_dim_location, Phi) - 0.2352884, 22 | tol) 23 | }) 24 | -------------------------------------------------------------------------------- /man/eigenFunction.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{eigenFunction} 4 | \alias{eigenFunction} 5 | \title{Interpolated Eigen-function} 6 | \usage{ 7 | eigenFunction(new_location, original_location, Phi) 8 | } 9 | \arguments{ 10 | \item{new_location}{A location matrix} 11 | 12 | \item{original_location}{A location matrix} 13 | 14 | \item{Phi}{An eigenvector matrix} 15 | } 16 | \value{ 17 | A predictive estimate matrix 18 | } 19 | \description{ 20 | Produce Eigen-function values based on new locations 21 | } 22 | \examples{ 23 | pesudo_sequence <- seq(-5, 5, length = 2) 24 | original_location <- as.matrix(expand.grid(x = pesudo_sequence, y = pesudo_sequence)) 25 | new_location <- matrix(c(0.1, 0.2), nrow = 1, ncol = 2) 26 | Phi <- matrix(c(1, 0, 0, 0), nrow = 4, ncol = 1) 27 | thin_plate_matrix <- eigenFunction(new_location, original_location, Phi) 28 | } 29 | \keyword{internal} 30 | -------------------------------------------------------------------------------- /man/spatialPrediction.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{spatialPrediction} 4 | \alias{spatialPrediction} 5 | \title{Internal function: Spatial prediction} 6 | \usage{ 7 | spatialPrediction(phir, Yr, gamma, predicted_eignefunction) 8 | } 9 | \arguments{ 10 | \item{phir}{A matrix of estimated eigenfunctions based on original locations} 11 | 12 | \item{Yr}{A data matrix} 13 | 14 | \item{gamma}{A gamma value} 15 | 16 | \item{predicted_eignefunction}{A vector of values of an eigenfunction on new locations} 17 | } 18 | \value{ 19 | A list of objects 20 | \item{prediction}{A vector of spatial predictions} 21 | \item{estimated_covariance}{An estimated covariance matrix.} 22 | \item{eigenvalue}{A vector of estimated eigenvalues.} 23 | \item{error}{Error rate for the ADMM algorithm} 24 | } 25 | \description{ 26 | Internal function: Spatial prediction 27 | } 28 | \keyword{internal} 29 | -------------------------------------------------------------------------------- /man/spatpcaCV.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{spatpcaCV} 4 | \alias{spatpcaCV} 5 | \title{Internal function: M-fold Cross-validation} 6 | \usage{ 7 | spatpcaCV(sxyr, Yr, M, K, tau1r, tau2r, gammar, nkr, maxit, tol, l2r) 8 | } 9 | \arguments{ 10 | \item{sxyr}{A location matrix} 11 | 12 | \item{Yr}{A data matrix} 13 | 14 | \item{M}{The number of folds for CV} 15 | 16 | \item{K}{The number of estimated eigen-functions} 17 | 18 | \item{tau1r}{A range of tau1} 19 | 20 | \item{tau2r}{A range of tau2} 21 | 22 | \item{gammar}{A range of gamma} 23 | 24 | \item{nkr}{A vector of fold numbers} 25 | 26 | \item{maxit}{A maximum number of iteration} 27 | 28 | \item{tol}{A tolerance rate} 29 | 30 | \item{l2r}{A given tau2} 31 | } 32 | \value{ 33 | A list of selected parameters 34 | } 35 | \description{ 36 | Internal function: M-fold Cross-validation 37 | } 38 | \keyword{internal} 39 | -------------------------------------------------------------------------------- /man/predictEigenfunction.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/SpatPCA.R 3 | \name{predictEigenfunction} 4 | \alias{predictEigenfunction} 5 | \title{Spatial dominant patterns on new locations} 6 | \usage{ 7 | predictEigenfunction(spatpca_object, x_new) 8 | } 9 | \arguments{ 10 | \item{spatpca_object}{An \code{spatpca} class object} 11 | 12 | \item{x_new}{New location matrix.} 13 | } 14 | \value{ 15 | {A matrix with K Eigenfunction values on new locations.} 16 | } 17 | \description{ 18 | Estimate K eigenfunctions on new locations 19 | } 20 | \examples{ 21 | # 1D: artificial irregular locations 22 | x_1D <- as.matrix(seq(-5, 5, length = 10)) 23 | Phi_1D <- exp(-x_1D^2) / norm(exp(-x_1D^2), "F") 24 | set.seed(1234) 25 | Y_1D <- rnorm(n = 100, sd = 3) \%*\% t(Phi_1D) + matrix(rnorm(n = 100 * 10), 100, 10) 26 | rm_loc <- sample(1:10, 2) 27 | x_1Drm <- x_1D[-rm_loc] 28 | Y_1Drm <- Y_1D[, -rm_loc] 29 | x_1Dnew <- as.matrix(seq(-5, 5, length = 20)) 30 | cv_1D <- spatpca(x = x_1Drm, Y = Y_1Drm, tau2 = 1:100) 31 | dominant_patterns <- predictEigenfunction(cv_1D, x_new = x_1Dnew) 32 | 33 | } 34 | \seealso{ 35 | \link{spatpca} 36 | } 37 | -------------------------------------------------------------------------------- /man/predict.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/SpatPCA.R 3 | \name{predict} 4 | \alias{predict} 5 | \title{Spatial predictions on new locations} 6 | \usage{ 7 | predict(spatpca_object, x_new, eigen_patterns_on_new_site = NULL) 8 | } 9 | \arguments{ 10 | \item{spatpca_object}{An \code{spatpca} class object} 11 | 12 | \item{x_new}{New location matrix.} 13 | 14 | \item{eigen_patterns_on_new_site}{Eigen-patterns on x_new} 15 | } 16 | \value{ 17 | A prediction matrix of Y at the new locations, x_new. 18 | } 19 | \description{ 20 | Predict the response on new locations with the estimated spatial structures. 21 | } 22 | \examples{ 23 | # 1D: artificial irregular locations 24 | x_1D <- as.matrix(seq(-5, 5, length = 10)) 25 | Phi_1D <- exp(-x_1D^2) / norm(exp(-x_1D^2), "F") 26 | set.seed(1234) 27 | Y_1D <- rnorm(n = 100, sd = 3) \%*\% t(Phi_1D) + matrix(rnorm(n = 100 * 10), 100, 10) 28 | removed_location <- sample(1:10, 3) 29 | removed_x_1D <- x_1D[-removed_location] 30 | removed_Y_1D <- Y_1D[, -removed_location] 31 | new_x_1D <- as.matrix(seq(-5, 5, length = 20)) 32 | cv_1D <- spatpca(x = removed_x_1D, Y = removed_Y_1D, tau2 = 1:100) 33 | predictions <- predict(cv_1D, x_new = new_x_1D) 34 | 35 | } 36 | \seealso{ 37 | \link{spatpca} 38 | } 39 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | # Ref: https://github.com/r-lib/actions/blob/v2/examples/pkgdown.yaml 2 | on: 3 | push: 4 | branches: [main, master] 5 | pull_request: 6 | branches: [main, master] 7 | release: 8 | types: [published] 9 | workflow_dispatch: 10 | 11 | name: pkgdown 12 | 13 | jobs: 14 | pkgdown: 15 | runs-on: ubuntu-latest 16 | # Only restrict concurrency for non-PR jobs 17 | concurrency: 18 | group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} 19 | env: 20 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 21 | steps: 22 | - uses: actions/checkout@v3 23 | 24 | - uses: r-lib/actions/setup-pandoc@v2 25 | 26 | - uses: r-lib/actions/setup-r@v2 27 | with: 28 | use-public-rspm: true 29 | 30 | - uses: r-lib/actions/setup-r-dependencies@v2 31 | with: 32 | extra-packages: any::pkgdown, local::. 33 | needs: website 34 | 35 | - name: Build site 36 | run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) 37 | shell: Rscript {0} 38 | 39 | - name: Deploy to GitHub pages 🚀 40 | if: github.event_name != 'pull_request' 41 | uses: JamesIves/github-pages-deploy-action@v4.4.1 42 | with: 43 | clean: false 44 | branch: gh-pages 45 | folder: docs 46 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yaml: -------------------------------------------------------------------------------- 1 | # Ref: https://github.com/r-lib/actions/blob/v2/examples/test-coverage.yaml 2 | on: 3 | push: 4 | branches: [main, master] 5 | pull_request: 6 | branches: [main, master] 7 | 8 | name: test-coverage 9 | 10 | jobs: 11 | test-coverage: 12 | runs-on: ubuntu-latest 13 | env: 14 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 15 | 16 | steps: 17 | - uses: actions/checkout@v3 18 | 19 | - uses: r-lib/actions/setup-r@v2 20 | with: 21 | use-public-rspm: true 22 | 23 | - uses: r-lib/actions/setup-r-dependencies@v2 24 | with: 25 | extra-packages: any::covr 26 | needs: coverage 27 | 28 | - name: Test coverage 29 | run: | 30 | covr::codecov( 31 | quiet = FALSE, 32 | clean = FALSE, 33 | install_path = file.path(Sys.getenv("RUNNER_TEMP"), "package") 34 | ) 35 | shell: Rscript {0} 36 | 37 | - name: Show testthat output 38 | if: always() 39 | run: | 40 | ## -------------------------------------------------------------------- 41 | find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true 42 | shell: bash 43 | 44 | - name: Upload test results 45 | if: failure() 46 | uses: actions/upload-artifact@v4 47 | with: 48 | name: coverage-test-failures 49 | path: ${{ runner.temp }}/package 50 | -------------------------------------------------------------------------------- /man/spatpcaCVWithSelectedK.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/SpatPCA.R 3 | \name{spatpcaCVWithSelectedK} 4 | \alias{spatpcaCVWithSelectedK} 5 | \title{Internal function: M-fold CV of SpatPCA with selected K} 6 | \usage{ 7 | spatpcaCVWithSelectedK( 8 | x, 9 | Y, 10 | M, 11 | tau1, 12 | tau2, 13 | gamma, 14 | shuffle_split, 15 | maxit, 16 | thr, 17 | l2 18 | ) 19 | } 20 | \arguments{ 21 | \item{x}{Location matrix} 22 | 23 | \item{Y}{Data matrix} 24 | 25 | \item{M}{The number of folds for cross validation; default is 5.} 26 | 27 | \item{tau1}{Vector of a non-negative smoothness parameter sequence. If NULL, 10 tau1 values in a range are used.} 28 | 29 | \item{tau2}{Vector of a non-negative sparseness parameter sequence. If NULL, none of tau2 is used.} 30 | 31 | \item{gamma}{Vector of a non-negative hyper parameter sequence for tuning eigenvalues. If NULL, 10 values in a range are used.} 32 | 33 | \item{shuffle_split}{Vector of indices for random splitting Y into training and test sets} 34 | 35 | \item{maxit}{Maximum number of iterations. Default value is 100.} 36 | 37 | \item{thr}{Threshold for convergence. Default value is \eqn{10^{-4}}.} 38 | 39 | \item{l2}{Vector of a non-negative tuning parameter sequence for ADMM use} 40 | } 41 | \value{ 42 | A list of objects including 43 | \item{cv_result}{A list of resultant objects produced by \code{spatpcaCV}} 44 | \item{selected_K}{Selected K based on CV.} 45 | } 46 | \description{ 47 | Internal function: M-fold CV of SpatPCA with selected K 48 | } 49 | \keyword{internal} 50 | -------------------------------------------------------------------------------- /.github/workflows/check-standard.yaml: -------------------------------------------------------------------------------- 1 | # Ref: https://github.com/r-lib/actions/blob/v2/examples/check-standard.yaml 2 | on: 3 | push: 4 | branches: [main, master] 5 | pull_request: 6 | branches: [main, master] 7 | 8 | name: R-CMD-check 9 | 10 | jobs: 11 | R-CMD-check: 12 | runs-on: ${{ matrix.config.os }} 13 | 14 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 15 | 16 | strategy: 17 | fail-fast: false 18 | matrix: 19 | config: 20 | - {os: macos-latest, r: 'release'} 21 | - {os: windows-latest, r: 'release'} 22 | - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} 23 | - {os: ubuntu-latest, r: 'release'} 24 | - {os: ubuntu-latest, r: 'oldrel-1'} 25 | 26 | env: 27 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 28 | R_KEEP_PKG_SOURCE: yes 29 | 30 | steps: 31 | - uses: actions/checkout@v3 32 | 33 | - uses: r-lib/actions/setup-pandoc@v2 34 | 35 | - uses: r-lib/actions/setup-r@v2 36 | with: 37 | r-version: ${{ matrix.config.r }} 38 | http-user-agent: ${{ matrix.config.http-user-agent }} 39 | use-public-rspm: true 40 | 41 | - name: Install system dependencies on macOS 42 | if: runner.os == 'macOS' 43 | run: | 44 | # XQuartz is needed by plot2D 45 | brew install xquartz 46 | 47 | - uses: r-lib/actions/setup-r-dependencies@v2 48 | with: 49 | extra-packages: any::rcmdcheck 50 | needs: check 51 | 52 | - uses: r-lib/actions/check-r-package@v2 53 | with: 54 | upload-snapshots: true 55 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: SpatPCA 2 | Title: Regularized Principal Component Analysis for Spatial Data 3 | Version: 1.3.8 4 | Authors@R: c(person( 5 | given = "Wen-Ting", 6 | family = "Wang", 7 | email = "egpivo@gmail.com", 8 | role = c("aut", "cre"), 9 | comment = c(ORCID = "0000-0003-3051-7302") 10 | ), 11 | person( 12 | given = "Hsin-Cheng", 13 | family = "Huang", 14 | email = "hchuang@stat.sinica.edu.tw", 15 | role = "aut", 16 | comment = c(ORCID = "0000-0002-5613-349X") 17 | ) 18 | ) 19 | Description: Provide regularized principal component analysis incorporating smoothness, sparseness and orthogonality of eigen-functions 20 | by using the alternating direction method of multipliers algorithm (Wang and Huang, 2017, ). The 21 | method can be applied to either regularly or irregularly spaced data, including 1D, 2D, and 3D. 22 | License: GPL (>= 2) 23 | LazyData: true 24 | ByteCompile: true 25 | BugReports: https://github.com/egpivo/SpatPCA/issues 26 | Depends: 27 | R (>= 3.4.0) 28 | Imports: 29 | Rcpp (>= 1.0.12), 30 | ggplot2, 31 | parallel 32 | LinkingTo: Rcpp, RcppArmadillo 33 | Suggests: 34 | knitr, 35 | rmarkdown, 36 | testthat (>= 2.1.0), 37 | dplyr (>= 1.0.3), 38 | tidyr, 39 | fields, 40 | scico, 41 | plot3D, 42 | pracma, 43 | RColorBrewer, 44 | maps, 45 | covr, 46 | styler, 47 | V8 48 | SystemRequirements: GNU make 49 | VignetteBuilder: knitr, rmarkdown 50 | Encoding: UTF-8 51 | RoxygenNote: 7.2.3 52 | Roxygen: list(markdown = TRUE) 53 | URL: https://egpivo.github.io/SpatPCA/, https://github.com/egpivo/SpatPCA 54 | Config/testthat/edition: 3 55 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | ## SpatPCA v1.3.6 (Release date: 2024-01-12) 2 | #### Overview 3 | This release focuses on 4 | 1. fixing the warnings from the earlier Rcpp pacakge. 5 | 2. adding LICENSE 6 | 3. refining README 7 | 8 | 9 | ## SpatPCA v1.3.4 (Release date: 2023-11-11) 10 | #### Overview 11 | This release focuses on refining the package to comply with CRAN's regulatory standards. 12 | 13 | #### MAINTENANCE 14 | - Achieve code coverage exceeding 100% 15 | - Upgrade RcppParallel to version 5.1.7 16 | - Correct typos for improved clarity 17 | 18 | 19 | ## SpatPCA v1.3.3.7 (Release date: 2023-01-28) 20 | #### Overview 21 | In this release, we focus on package maintenance. 22 | 23 | #### MAINTENANCE 24 | - Enhance code coverage over `99%` 25 | - Update deprecated R settings and GitHub workflow files 26 | - Fix memory leak errors caused by `tbb` backend in RcppParallel when testing the package on the platform `Debian Linux, R-devel, GCC ASAN/UBSAN` 27 | - Enhance the readability of the resultant plot by adding math expression 28 | - Fix grammar errors 29 | 30 | 31 | ## SpatPCA v1.3.3.0 (Release date: 2021-01-31) 32 | #### Overview 33 | In this release, we take care of the perspective of software quality by refactoring code for better readability and adding unit-tests. Accordingly, we add multiple features by separating implicit functions from `spatpca`. 34 | 35 | #### NEW FEATURES 36 | 1. `thinPlateSplineMatrix()` for producing a thin-plane spline matrix 37 | 2. `predictEigenfunction()`for estimating K dominant patterns on new sites 38 | 3. `predict()` for predicting new target variable `Y` on new sites 39 | 4. `plot()` for `spatpca` objects for plotting M-fold CV results 40 | 41 | #### MAINTENANCE 42 | - Add unit tests with code coverage `87%` 43 | 44 | 45 | ## SpatPCA v1.3.7 (Unreleased) 46 | #### Overview 47 | - Remove the `RcppParallel` dependency and run computation sequentially to improve compatibility with CRAN checks. 48 | - Replace vignette animations with static figures to avoid optional multimedia dependencies. 49 | - Symmetrise matrices before inversion to silence Armadillo warnings. 50 | 51 | -------------------------------------------------------------------------------- /.github/workflows/pr-commands.yaml: -------------------------------------------------------------------------------- 1 | # Ref: https://github.com/r-lib/actions/blob/v2/examples/pr-commands.yaml 2 | on: 3 | issue_comment: 4 | types: [created] 5 | 6 | name: Commands 7 | 8 | jobs: 9 | document: 10 | if: ${{ github.event.issue.pull_request && (github.event.comment.author_association == 'MEMBER' || github.event.comment.author_association == 'OWNER') && startsWith(github.event.comment.body, '/document') }} 11 | name: document 12 | runs-on: ubuntu-latest 13 | env: 14 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 15 | steps: 16 | - uses: actions/checkout@v3 17 | 18 | - uses: r-lib/actions/pr-fetch@v2 19 | with: 20 | repo-token: ${{ secrets.GITHUB_TOKEN }} 21 | 22 | - uses: r-lib/actions/setup-r@v2 23 | with: 24 | use-public-rspm: true 25 | 26 | - uses: r-lib/actions/setup-r-dependencies@v2 27 | with: 28 | extra-packages: any::roxygen2 29 | needs: pr-document 30 | 31 | - name: Document 32 | run: roxygen2::roxygenise() 33 | shell: Rscript {0} 34 | 35 | - name: commit 36 | run: | 37 | git config --local user.name "$GITHUB_ACTOR" 38 | git config --local user.email "$GITHUB_ACTOR@users.noreply.github.com" 39 | git add man/\* NAMESPACE 40 | git commit -m 'Document' 41 | - uses: r-lib/actions/pr-push@v2 42 | with: 43 | repo-token: ${{ secrets.GITHUB_TOKEN }} 44 | 45 | style: 46 | if: ${{ github.event.issue.pull_request && (github.event.comment.author_association == 'MEMBER' || github.event.comment.author_association == 'OWNER') && startsWith(github.event.comment.body, '/style') }} 47 | name: style 48 | runs-on: ubuntu-latest 49 | env: 50 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 51 | steps: 52 | - uses: actions/checkout@v3 53 | 54 | - uses: r-lib/actions/pr-fetch@v2 55 | with: 56 | repo-token: ${{ secrets.GITHUB_TOKEN }} 57 | 58 | - uses: r-lib/actions/setup-r@v2 59 | 60 | - name: Install dependencies 61 | run: install.packages("styler") 62 | shell: Rscript {0} 63 | 64 | - name: Style 65 | run: styler::style_pkg() 66 | shell: Rscript {0} 67 | 68 | - name: commit 69 | run: | 70 | git config --local user.name "$GITHUB_ACTOR" 71 | git config --local user.email "$GITHUB_ACTOR@users.noreply.github.com" 72 | git add \*.R 73 | git commit -m 'Style' 74 | - uses: r-lib/actions/pr-push@v2 75 | with: 76 | repo-token: ${{ secrets.GITHUB_TOKEN }} 77 | -------------------------------------------------------------------------------- /R/RcppExports.R: -------------------------------------------------------------------------------- 1 | # Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | #' @title Thin-plane spline matrix 5 | #' 6 | #' @description Produce a thin-plane spline matrix based on a given location matrix 7 | #' 8 | #' @param location A location matrix 9 | #' @return A thin-plane spline matrix 10 | #' @examples 11 | #' pesudo_sequence <- seq(-5, 5, length = 5) 12 | #' two_dim_location <- as.matrix(expand.grid(x = pesudo_sequence, y = pesudo_sequence)) 13 | #' thin_plate_matrix <- thinPlateSplineMatrix(two_dim_location) 14 | thinPlateSplineMatrix <- function(location) { 15 | .Call(`_SpatPCA_thinPlateSplineMatrix`, location) 16 | } 17 | 18 | #' @title Interpolated Eigen-function 19 | #' 20 | #' @description Produce Eigen-function values based on new locations 21 | #' 22 | #' @keywords internal 23 | #' @param new_location A location matrix 24 | #' @param original_location A location matrix 25 | #' @param Phi An eigenvector matrix 26 | #' @return A predictive estimate matrix 27 | #' @examples 28 | #' pesudo_sequence <- seq(-5, 5, length = 2) 29 | #' original_location <- as.matrix(expand.grid(x = pesudo_sequence, y = pesudo_sequence)) 30 | #' new_location <- matrix(c(0.1, 0.2), nrow = 1, ncol = 2) 31 | #' Phi <- matrix(c(1, 0, 0, 0), nrow = 4, ncol = 1) 32 | #' thin_plate_matrix <- eigenFunction(new_location, original_location, Phi) 33 | eigenFunction <- function(new_location, original_location, Phi) { 34 | .Call(`_SpatPCA_eigenFunction`, new_location, original_location, Phi) 35 | } 36 | 37 | #' Internal function: M-fold Cross-validation 38 | #' @keywords internal 39 | #' @param sxyr A location matrix 40 | #' @param Yr A data matrix 41 | #' @param M The number of folds for CV 42 | #' @param K The number of estimated eigen-functions 43 | #' @param tau1r A range of tau1 44 | #' @param tau2r A range of tau2 45 | #' @param gammar A range of gamma 46 | #' @param nkr A vector of fold numbers 47 | #' @param maxit A maximum number of iteration 48 | #' @param tol A tolerance rate 49 | #' @param l2r A given tau2 50 | #' @return A list of selected parameters 51 | spatpcaCV <- function(sxyr, Yr, M, K, tau1r, tau2r, gammar, nkr, maxit, tol, l2r) { 52 | .Call(`_SpatPCA_spatpcaCV`, sxyr, Yr, M, K, tau1r, tau2r, gammar, nkr, maxit, tol, l2r) 53 | } 54 | 55 | #' Internal function: Spatial prediction 56 | #' @keywords internal 57 | #' @param phir A matrix of estimated eigenfunctions based on original locations 58 | #' @param Yr A data matrix 59 | #' @param gamma A gamma value 60 | #' @param predicted_eignefunction A vector of values of an eigenfunction on new locations 61 | #' @return A list of objects 62 | #' \item{prediction}{A vector of spatial predictions} 63 | #' \item{estimated_covariance}{An estimated covariance matrix.} 64 | #' \item{eigenvalue}{A vector of estimated eigenvalues.} 65 | #' \item{error}{Error rate for the ADMM algorithm} 66 | spatialPrediction <- function(phir, Yr, gamma, predicted_eignefunction) { 67 | .Call(`_SpatPCA_spatialPrediction`, phir, Yr, gamma, predicted_eignefunction) 68 | } 69 | 70 | -------------------------------------------------------------------------------- /tests/testthat/test-helper.R: -------------------------------------------------------------------------------- 1 | default_number <- parallel::detectCores() 2 | if (is.na(default_number) || default_number < 1) { 3 | default_number <- 1 4 | } 5 | test_that("The number of cores for setCores", { 6 | expect_error(setCores("test"), 7 | "Please enter valid type - but got character") 8 | expect_error(setCores(0), 9 | "The number of cores is not greater than 1 - but got 0") 10 | expect_error( 11 | setCores(default_number + 1), 12 | paste0("The input number of cores is invalid - default is ", default_number) 13 | ) 14 | expect_true(setCores(default_number)) 15 | expect_null(setCores()) 16 | }) 17 | 18 | x_1D <- as.matrix(seq(-5, 5, length = 10)) 19 | x_2D <- matrix(c(1, 2), ncol = 2) 20 | test_that("Scale locations", { 21 | expect_equal(sum(scaleLocation(x_1D)), 5) 22 | expect_equal(min(scaleLocation(x_1D)), 0) 23 | expect_equal(max(scaleLocation(x_1D)), 1) 24 | expect_equal(scaleLocation(x_2D), x_2D) 25 | }) 26 | 27 | set.seed(1234) 28 | tol <- 1e-6 29 | num_cores <- 2 30 | 31 | x_1D <- as.matrix(seq(-5, 5, length = 4)) 32 | Phi_1D <- exp(-x_1D ^ 2) / norm(exp(-x_1D ^ 2), "F") 33 | Y_1D <- { 34 | rnorm(n = 100, sd = 3) %*% t(Phi_1D) + 35 | matrix(rnorm(n = 100 * 4), 100, 4) 36 | } 37 | cv_1D <- spatpca(x = x_1D, Y = Y_1D, num_cores = num_cores) 38 | x_1Dnew <- as.matrix(seq(6, 7, length = 4)) 39 | 40 | # Test `predict` 41 | test_that("check new locations for a spatpca object", { 42 | expect_error( 43 | checkNewLocationsForSpatpcaObject(NULL, NULL), 44 | cat("Invalid object! Please enter a `spatpca` object") 45 | ) 46 | expect_error( 47 | checkNewLocationsForSpatpcaObject(cv_1D, NULL), 48 | cat("New locations cannot be NULL") 49 | ) 50 | expect_error( 51 | checkNewLocationsForSpatpcaObject(cv_1D, matrix(c(1, 2), ncol = 2)), 52 | cat("Inconsistent dimension of locations - original dimension is 1") 53 | ) 54 | expect_null(checkNewLocationsForSpatpcaObject(cv_1D, x_1Dnew)) 55 | }) 56 | 57 | # Test invalid input 58 | test_that("check input of spatpca", { 59 | expect_error( 60 | checkInputData(x = as.matrix(1), Y = Y_1D), 61 | cat( 62 | "The number of rows of x should be equal to the number of columns of Y." 63 | ) 64 | ) 65 | expect_error( 66 | checkInputData(x = matrix(1:10, ncol = 10), Y = matrix(1)), 67 | cat("Number of locations must be larger than 2.") 68 | ) 69 | expect_error(checkInputData(x = matrix(1:40, ncol = 10), Y = Y_1D), 70 | cat("Dimension of locations must be less than 4.")) 71 | expect_error( 72 | checkInputData(x = x_1D, Y = Y_1D, M = 1000), 73 | cat("Number of folds must be less than sample size.") 74 | ) 75 | }) 76 | 77 | # Test detrend 78 | test_that("check detrending", { 79 | expect_equal(detrend(Y_1D, FALSE), Y_1D) 80 | expect_lte(sum(detrend(Y_1D, TRUE)), tol) 81 | }) 82 | 83 | # Test tuning parameters 84 | test_that("check the number of eigenfunctons", { 85 | expect_equal(fetchUpperBoundNumberEigenfunctions(Y_1D, 5), 4) 86 | expect_null(setNumberEigenfunctions(NULL, Y_1D, 5)) 87 | expect_warning(setNumberEigenfunctions(300, Y_1D, 5)) 88 | expect_warning(setNumberEigenfunctions(3, Y_1D, 5), NA) 89 | }) 90 | 91 | test_that("check turning parameter - tau1", { 92 | expect_equal(min(setTau1(NULL, 5)), 0) 93 | expect_equal(max(setTau1(NULL, 5)), 1) 94 | expect_lte(median(setTau1(NULL, 5)), 0.0004641589) 95 | expect_equal(median(setTau1(NULL, 1)), 1) 96 | expect_equal(setTau1(c(1, 2), 5), c(1, 2)) 97 | expect_equal(setTau1(c(1, 2), 1), 2) 98 | }) 99 | 100 | test_that("check turning parameter - tau2", { 101 | expect_equal(setTau2(NULL, 5), 0) 102 | expect_equal(setTau2(NULL, 1), 0) 103 | expect_equal(setTau2(c(1, 2), 5), c(1, 2)) 104 | expect_equal(setTau2(c(1, 2), 1), 2) 105 | }) 106 | 107 | test_that("check inner turning parameter based on tau2 - l2", { 108 | expect_equal(setL2(c(1, 2)), 1) 109 | expect_equal(setL2(-1), 1) 110 | expect_equal(max(setL2(1)), 1) 111 | expect_equal(min(setL2(1)), 0) 112 | expect_lte(median(setL2(1)) - 0.005994843, tol) 113 | }) 114 | 115 | test_that("check turning parameter - gamma", { 116 | expect_equal(setGamma(c(1, 2)), c(1, 2)) 117 | expect_lte(max(setGamma(NULL, Y_1D)) - 11.14708, tol) 118 | expect_equal(min(setGamma(NULL, Y_1D)), 0) 119 | expect_lte(median(setGamma(NULL, Y_1D)) - 0.06682497, tol) 120 | }) 121 | -------------------------------------------------------------------------------- /vignettes/demo-one-dim-location.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Capture the Dominant Spatial Pattern with One-Dimensional Locations" 3 | author: "Wen-Ting Wang" 4 | output: 5 | rmarkdown::html_vignette: 6 | fig_width: 6 7 | fig_height: 4 8 | vignette: > 9 | %\VignetteIndexEntry{Capture the Dominant Spatial Pattern with One-Dimensional Locations} 10 | %\VignetteEngine{knitr::rmarkdown} 11 | %\VignetteEncoding{UTF-8} 12 | --- 13 | 14 | ```{r, include = FALSE} 15 | knitr::opts_chunk$set( 16 | collapse = TRUE, 17 | comment = "#>" 18 | ) 19 | ``` 20 | 21 | ## Objective 22 | We have two objectives 23 | 1. Demonstrate how **SpatPCA** captures the most dominant spatial pattern of variation based on different signal-to-noise ratios. 24 | 2. Represent how to use **SpatPCA** for one-dimensional data 25 | 26 | ## Basic settings 27 | #### Used packages 28 | ```{r message=FALSE} 29 | library(SpatPCA) 30 | library(ggplot2) 31 | base_theme <- theme_classic(base_size = 18, base_family = "Times") 32 | ``` 33 | #### True spatial pattern (eigenfunction) 34 | The underlying spatial pattern below indicates realizations will vary dramatically at the center and be almost unchanged at the both ends of the curve. 35 | ```{r} 36 | set.seed(1024) 37 | position <- matrix(seq(-5, 5, length = 100)) 38 | true_eigen_fn <- exp(-position^2) / norm(exp(-position^2), "F") 39 | 40 | plot_df <- data.frame(position = position, eigenfunction = true_eigen_fn) 41 | 42 | ggplot(plot_df, aes(position, eigenfunction)) + 43 | geom_line() + 44 | base_theme 45 | ``` 46 | 47 | ## Case I: Higher signal of the true eigenfunction 48 | #### Generate realizations 49 | We want to generate 100 random sample based on 50 | - The spatial signal for the true spatial pattern is distributed normally with $\sigma=20$ 51 | - The noise follows the standard normal distribution. 52 | 53 | ```{r} 54 | realizations <- rnorm(n = 100, sd = 20) %*% t(true_eigen_fn) + matrix(rnorm(n = 100 * 100), 100, 100) 55 | ``` 56 | 57 | #### Animate realizations 58 | We can see simulated central realizations change in a wide range more frequently than the others. 59 | ```{r} 60 | subset_idx <- seq(1, 100, length.out = 9) 61 | matplot( 62 | t(realizations[subset_idx, ]), type = "l", lty = 1, 63 | ylim = c(-10, 10), 64 | xlab = "position index", ylab = "realization" 65 | ) 66 | ``` 67 | 68 | #### Apply `SpatPCA::spatpca` 69 | ```{r} 70 | cv <- spatpca(x = position, Y = realizations) 71 | eigen_est <- cv$eigenfn 72 | ``` 73 | #### Compare **SpatPCA** with PCA 74 | There are two comparison remarks 75 | 1. Two estimates are similar to the true eigenfunctions 76 | 2. **SpatPCA** can perform better at the both ends. 77 | ```{r} 78 | plot_df <- data.frame( 79 | position = position, 80 | true = true_eigen_fn, 81 | spatpca = eigen_est[, 1], 82 | pca = svd(realizations)$v[, 1] 83 | ) 84 | 85 | plot_df_long <- data.frame( 86 | position = rep(plot_df$position, 3), 87 | estimate = rep(c("true", "spatpca", "pca"), each = nrow(plot_df)), 88 | eigenfunction = c(plot_df$true, plot_df$spatpca, plot_df$pca) 89 | ) 90 | 91 | ggplot(plot_df_long, aes(x = position, y = eigenfunction, color = estimate)) + 92 | geom_line() + 93 | base_theme 94 | ``` 95 | 96 | ## Case II: Lower signal of the true eigenfunction 97 | ### Generate realizations with $\sigma=3$ 98 | ```{r} 99 | realizations <- rnorm(n = 100, sd = 3) %*% t(true_eigen_fn) + matrix(rnorm(n = 100 * 100), 100, 100) 100 | ``` 101 | 102 | ### Animate realizations 103 | It is hard to see a crystal clear spatial pattern via the simulated sample shown below. 104 | ```{r} 105 | subset_idx <- seq(1, 100, length.out = 9) 106 | matplot( 107 | t(realizations[subset_idx, ]), type = "l", lty = 1, 108 | ylim = c(-10, 10), 109 | xlab = "position index", ylab = "realization" 110 | ) 111 | ``` 112 | 113 | ### Compare resultant patterns 114 | The following panel indicates that **SpatPCA** outperforms to PCA visually when the signal-to-noise ratio is quite lower. 115 | 116 | ```{r} 117 | cv <- spatpca(x = position, Y = realizations) 118 | eigen_est <- cv$eigenfn 119 | 120 | plot_df <- data.frame( 121 | position = position, 122 | true = true_eigen_fn, 123 | spatpca = eigen_est[, 1], 124 | pca = svd(realizations)$v[, 1] 125 | ) 126 | 127 | plot_df_long <- data.frame( 128 | position = rep(plot_df$position, 3), 129 | estimate = rep(c("true", "spatpca", "pca"), each = nrow(plot_df)), 130 | eigenfunction = c(plot_df$true, plot_df$spatpca, plot_df$pca) 131 | ) 132 | 133 | ggplot(plot_df_long, aes(x = position, y = eigenfunction, color = estimate)) + 134 | geom_line() + 135 | base_theme 136 | ``` 137 | -------------------------------------------------------------------------------- /src/RcppExports.cpp: -------------------------------------------------------------------------------- 1 | // Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | #include 5 | #include 6 | 7 | using namespace Rcpp; 8 | 9 | #ifdef RCPP_USE_GLOBAL_ROSTREAM 10 | Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); 11 | Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); 12 | #endif 13 | 14 | // thinPlateSplineMatrix 15 | arma::mat thinPlateSplineMatrix(const arma::mat& location); 16 | RcppExport SEXP _SpatPCA_thinPlateSplineMatrix(SEXP locationSEXP) { 17 | BEGIN_RCPP 18 | Rcpp::RObject rcpp_result_gen; 19 | Rcpp::RNGScope rcpp_rngScope_gen; 20 | Rcpp::traits::input_parameter< const arma::mat& >::type location(locationSEXP); 21 | rcpp_result_gen = Rcpp::wrap(thinPlateSplineMatrix(location)); 22 | return rcpp_result_gen; 23 | END_RCPP 24 | } 25 | // eigenFunction 26 | arma::mat eigenFunction(const arma::mat& new_location, const arma::mat& original_location, const arma::mat& Phi); 27 | RcppExport SEXP _SpatPCA_eigenFunction(SEXP new_locationSEXP, SEXP original_locationSEXP, SEXP PhiSEXP) { 28 | BEGIN_RCPP 29 | Rcpp::RObject rcpp_result_gen; 30 | Rcpp::RNGScope rcpp_rngScope_gen; 31 | Rcpp::traits::input_parameter< const arma::mat& >::type new_location(new_locationSEXP); 32 | Rcpp::traits::input_parameter< const arma::mat& >::type original_location(original_locationSEXP); 33 | Rcpp::traits::input_parameter< const arma::mat& >::type Phi(PhiSEXP); 34 | rcpp_result_gen = Rcpp::wrap(eigenFunction(new_location, original_location, Phi)); 35 | return rcpp_result_gen; 36 | END_RCPP 37 | } 38 | // spatpcaCV 39 | Rcpp::List spatpcaCV(const Rcpp::NumericMatrix& sxyr, const Rcpp::NumericMatrix& Yr, int M, int K, const Rcpp::NumericVector& tau1r, const Rcpp::NumericVector& tau2r, const Rcpp::NumericVector& gammar, const Rcpp::NumericVector& nkr, int maxit, double tol, const Rcpp::NumericVector& l2r); 40 | RcppExport SEXP _SpatPCA_spatpcaCV(SEXP sxyrSEXP, SEXP YrSEXP, SEXP MSEXP, SEXP KSEXP, SEXP tau1rSEXP, SEXP tau2rSEXP, SEXP gammarSEXP, SEXP nkrSEXP, SEXP maxitSEXP, SEXP tolSEXP, SEXP l2rSEXP) { 41 | BEGIN_RCPP 42 | Rcpp::RObject rcpp_result_gen; 43 | Rcpp::RNGScope rcpp_rngScope_gen; 44 | Rcpp::traits::input_parameter< const Rcpp::NumericMatrix& >::type sxyr(sxyrSEXP); 45 | Rcpp::traits::input_parameter< const Rcpp::NumericMatrix& >::type Yr(YrSEXP); 46 | Rcpp::traits::input_parameter< int >::type M(MSEXP); 47 | Rcpp::traits::input_parameter< int >::type K(KSEXP); 48 | Rcpp::traits::input_parameter< const Rcpp::NumericVector& >::type tau1r(tau1rSEXP); 49 | Rcpp::traits::input_parameter< const Rcpp::NumericVector& >::type tau2r(tau2rSEXP); 50 | Rcpp::traits::input_parameter< const Rcpp::NumericVector& >::type gammar(gammarSEXP); 51 | Rcpp::traits::input_parameter< const Rcpp::NumericVector& >::type nkr(nkrSEXP); 52 | Rcpp::traits::input_parameter< int >::type maxit(maxitSEXP); 53 | Rcpp::traits::input_parameter< double >::type tol(tolSEXP); 54 | Rcpp::traits::input_parameter< const Rcpp::NumericVector& >::type l2r(l2rSEXP); 55 | rcpp_result_gen = Rcpp::wrap(spatpcaCV(sxyr, Yr, M, K, tau1r, tau2r, gammar, nkr, maxit, tol, l2r)); 56 | return rcpp_result_gen; 57 | END_RCPP 58 | } 59 | // spatialPrediction 60 | Rcpp::List spatialPrediction(const Rcpp::NumericMatrix& phir, const Rcpp::NumericMatrix& Yr, double gamma, const Rcpp::NumericMatrix& predicted_eignefunction); 61 | RcppExport SEXP _SpatPCA_spatialPrediction(SEXP phirSEXP, SEXP YrSEXP, SEXP gammaSEXP, SEXP predicted_eignefunctionSEXP) { 62 | BEGIN_RCPP 63 | Rcpp::RObject rcpp_result_gen; 64 | Rcpp::RNGScope rcpp_rngScope_gen; 65 | Rcpp::traits::input_parameter< const Rcpp::NumericMatrix& >::type phir(phirSEXP); 66 | Rcpp::traits::input_parameter< const Rcpp::NumericMatrix& >::type Yr(YrSEXP); 67 | Rcpp::traits::input_parameter< double >::type gamma(gammaSEXP); 68 | Rcpp::traits::input_parameter< const Rcpp::NumericMatrix& >::type predicted_eignefunction(predicted_eignefunctionSEXP); 69 | rcpp_result_gen = Rcpp::wrap(spatialPrediction(phir, Yr, gamma, predicted_eignefunction)); 70 | return rcpp_result_gen; 71 | END_RCPP 72 | } 73 | 74 | static const R_CallMethodDef CallEntries[] = { 75 | {"_SpatPCA_thinPlateSplineMatrix", (DL_FUNC) &_SpatPCA_thinPlateSplineMatrix, 1}, 76 | {"_SpatPCA_eigenFunction", (DL_FUNC) &_SpatPCA_eigenFunction, 3}, 77 | {"_SpatPCA_spatpcaCV", (DL_FUNC) &_SpatPCA_spatpcaCV, 11}, 78 | {"_SpatPCA_spatialPrediction", (DL_FUNC) &_SpatPCA_spatialPrediction, 4}, 79 | {NULL, NULL, 0} 80 | }; 81 | 82 | RcppExport void R_init_SpatPCA(DllInfo *dll) { 83 | R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); 84 | R_useDynamicSymbols(dll, FALSE); 85 | } 86 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # SpatPCA: Regularized Principal Component Analysis for Spatial Data 2 | 3 | [![R build status](https://github.com/egpivo/SpatPCA/workflows/R-CMD-check/badge.svg)](https://github.com/egpivo/SpatPCA/actions) 4 | [![Coverage Status](https://img.shields.io/codecov/c/github/egpivo/SpatPCA/master.svg)](https://app.codecov.io/github/egpivo/SpatpCA?branch=master) 5 | [![CRAN_Status_Badge](https://www.r-pkg.org/badges/version/SpatPCA?color=green)](https://cran.r-project.org/package=SpatPCA) 6 | [![Downloads (monthly)](https://cranlogs.r-pkg.org/badges/SpatPCA?color=brightgreen)](https://www.r-pkg.org/pkg/SpatPCA) 7 | [![Downloads (total)](https://cranlogs.r-pkg.org/badges/grand-total/SpatPCA?color=brightgreen)](https://www.r-pkg.org/pkg/SpatPCA) 8 | [![JCGS](https://img.shields.io/badge/JCGS-10.18637%2F10618600.2016.1157483-brightgreen)](https://doi.org/10.1080/10618600.2016.1157483) 9 | 10 | 11 | ## Description 12 | **SpatPCA** is an R package designed for efficient regularized principal component analysis, providing the following features: 13 | 14 | - Identify dominant spatial patterns (eigenfunctions) with both smooth and localized characteristics. 15 | - Conduct spatial prediction (Kriging) at new locations. 16 | - Adapt to regularly or irregularly spaced data, spanning 1D, 2D, and 3D datasets. 17 | - Implement using the alternating direction method of multipliers (ADMM) algorithm. 18 | 19 | 20 | ## Installation 21 | You can install **SpatPCA** using either of the following methods: 22 | 23 | ### Install from CRAN 24 | 25 | ```r 26 | install.packages("SpatPCA") 27 | ``` 28 | ### Install the Development Version from GitHub 29 | ```r 30 | remotes::install_github("egpivo/SpatPCA") 31 | ``` 32 | ### Compilation Requirements 33 | To compile C++ code with the required [`RcppArmadillo`](https://CRAN.R-project.org/package=RcppArmadillo) package, follow these instructions based on your operating system: 34 | 35 | 36 | #### For Windows users 37 | Install [Rtools](https://CRAN.R-project.org/bin/windows/Rtools/) 38 | 39 | #### For Mac users 40 | 1. Install Xcode Command Line Tools 41 | 2. Install the `gfortran` library. You can achieve this by running the following commands in the terminal: 42 | ```bash 43 | brew update 44 | brew install gcc 45 | ``` 46 | 47 | For a detailed solution, refer to [this link](https://blog.thecoatlessprofessor.com/programming/rcpp-rcpparmadillo-and-os-x-mavericks-lgfortran-and-lquadmath-error/index.html), or download and install the library [`gfortran`](https://github.com/fxcoudert/gfortran-for-macOS/releases) to resolve the error `ld: library not found for -lgfortran`. 48 | 49 | ## Usage 50 | To use **SpatPCA**, first load the package: 51 | 52 | ```r 53 | library(SpatPCA) 54 | ``` 55 | 56 | Then, apply the `spatpca` function with the following syntax: 57 | ```r 58 | spatpca(position, realizations) 59 | ``` 60 | - Input: Realizations with the corresponding positions. 61 | - Output: Return the most dominant eigenfunctions automatically. 62 | 63 | For more details, refer to the [Demo](https://egpivo.github.io/SpatPCA/articles/). 64 | 65 | ## Development 66 | To submit package checks to R-hub v2, source `tools/run_rhub_checks.R` and use 67 | 68 | ```r 69 | submission <- run_rhub_checks(confirmation = TRUE) 70 | summarise_rhub_jobs(submission) 71 | ``` 72 | 73 | Adjust `include_os`, `platforms`, or `email` as needed. `summarise_rhub_jobs()` 74 | prints the submission id plus GitHub URLs where each builder’s logs appear. 75 | 76 | ## Authors 77 | - [Wen-Ting Wang](https://www.linkedin.com/in/wen-ting-wang-6083a17b) ([GitHub](https://github.com/egpivo)) 78 | - [Hsin-Cheng Huang](https://sites.stat.sinica.edu.tw/hchuang/) 79 | 80 | ## Maintainer 81 | [Wen-Ting Wang](https://www.linkedin.com/in/wen-ting-wang-6083a17b) ([GitHub](https://github.com/egpivo)) 82 | 83 | ## Reference 84 | Wang, W.-T. and Huang, H.-C. (2017). [Regularized principal component analysis for spatial data](https://arxiv.org/pdf/1501.03221.pdf). *Journal of Computational and Graphical Statistics*, **26**, 14-25. 85 | 86 | 87 | ## License 88 | GPL (>= 2) 89 | 90 | ## Citation 91 | - To cite package ‘SpatPCA’ in publications use: 92 | ``` 93 | Wang W, Huang H (2023). SpatPCA: Regularized Principal Component Analysis for 94 | Spatial Data_. R package version 1.3.5, 95 | . 96 | ``` 97 | 98 | - A BibTeX entry for LaTeX users is 99 | ``` 100 | @Manual{, 101 | title = {SpatPCA: Regularized Principal Component Analysis for Spatial Data}, 102 | author = {Wen-Ting Wang and Hsin-Cheng Huang}, 103 | year = {2023}, 104 | note = {R package version 1.3.5}, 105 | url = {https://CRAN.R-project.org/package=SpatPCA}, 106 | } 107 | ``` 108 | -------------------------------------------------------------------------------- /vignettes/demo-two-dim-location.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Capture the Dominant Spatial Pattern with Two-Dimensional Locations" 3 | author: "Wen-Ting Wang" 4 | output: 5 | rmarkdown::html_vignette: 6 | fig_width: 6 7 | fig_height: 4 8 | vignette: > 9 | %\VignetteIndexEntry{Capture the Dominant Spatial Pattern with Two-Dimensional Locations} 10 | %\VignetteEngine{knitr::rmarkdown} 11 | %\VignetteEncoding{UTF-8} 12 | --- 13 | 14 | ```{r, include = FALSE} 15 | knitr::opts_chunk$set( 16 | collapse = TRUE, 17 | comment = "#>", 18 | fig.align = "center", 19 | dpi = 300 20 | ) 21 | ``` 22 | 23 | ## Objective 24 | Represent how to use **SpatPCA** for two-dimensional data for capturing the most dominant spatial pattern 25 | 26 | ## Basic settings 27 | #### Used packages 28 | ```{r message=FALSE} 29 | library(SpatPCA) 30 | library(ggplot2) 31 | 32 | base_theme <- theme_minimal(base_size = 10, base_family = "Times") + 33 | theme(legend.position = "bottom") 34 | fill_bar <- guides(fill = guide_colourbar( 35 | barwidth = 10, 36 | barheight = 0.5, 37 | label.position = "bottom") 38 | ) 39 | coltab <- with( 40 | list(), 41 | colorRampPalette(c("#3b4cc0", "#f7f7f7", "#b40426"))(128) 42 | ) 43 | color_scale_limit <- c(-.8, .8) 44 | ``` 45 | Selected realizations are displayed as static images below. 46 | #### True spatial pattern (eigenfunction) 47 | - The underlying spatial pattern below indicates realizations will vary dramatically at the center and be almost unchanged at the both ends of the curve. 48 | ```{r, out.width = '100%'} 49 | set.seed(1024) 50 | p <- 25 51 | n <- 8 52 | location <- 53 | matrix(rep(seq(-5, 5, length = p), 2), nrow = p, ncol = 2) 54 | expanded_location <- expand.grid(location[, 1], location[, 2]) 55 | unnormalized_eigen_fn <- 56 | as.vector(exp(-location[, 1] ^ 2) %*% t(exp(-location[, 2] ^ 2))) 57 | true_eigen_fn <- 58 | unnormalized_eigen_fn / norm(t(unnormalized_eigen_fn), "F") 59 | 60 | plot_df <- data.frame( 61 | location_dim1 = expanded_location[, 1], 62 | location_dim2 = expanded_location[, 2], 63 | eigenfunction = true_eigen_fn 64 | ) 65 | 66 | ggplot(plot_df, aes(location_dim1, location_dim2)) + 67 | geom_tile(aes(fill = eigenfunction)) + 68 | scale_fill_gradientn(colours = coltab, limits = color_scale_limit) + 69 | base_theme + 70 | labs(title = "True Eigenfunction", fill = "") + 71 | fill_bar 72 | 73 | ``` 74 | 75 | ## Experiment 76 | #### Generate 2-D realizations 77 | - We want to generate 100 random sample based on 78 | - The spatial signal for the true spatial pattern is distributed normally with $\sigma=20$ 79 | - The noise follows the standard normal distribution. 80 | 81 | ```{r} 82 | realizations <- rnorm(n = n, sd = 3) %*% t(true_eigen_fn) + matrix(rnorm(n = n * p^2), n, p^2) 83 | ``` 84 | 85 | #### Animate realizations 86 | - We can see simulated central realizations change in a wide range more frequently than the others. 87 | ```{r, out.width = '100%'} 88 | realization_df <- data.frame( 89 | location_dim1 = expanded_location[, 1], 90 | location_dim2 = expanded_location[, 2], 91 | value = realizations[1, ] 92 | ) 93 | 94 | ggplot(realization_df, aes(location_dim1, location_dim2)) + 95 | geom_tile(aes(fill = value)) + 96 | scale_fill_gradientn(colours = coltab, limits = c(-10, 10)) + 97 | base_theme + 98 | labs(title = "1st realization", fill = "") + 99 | fill_bar 100 | ``` 101 | 102 | #### Apply `SpatPCA::spatpca` 103 | We add a candidate set of `tau2` to see how **SpatPCA** obtain a localized smooth pattern. 104 | ```{r} 105 | tau2 <- c(0, exp(seq(log(10), log(400), length = 10))) 106 | cv <- spatpca(x = expanded_location, Y = realizations, tau2 = tau2) 107 | eigen_est <- cv$eigenfn 108 | ``` 109 | #### Compare **SpatPCA** with PCA 110 | The following figure shows that **SpatPCA** can find sparser pattern than PCA, which is close to the true pattern. 111 | ```{r, out.width = '100%'} 112 | plot_df <- data.frame( 113 | location_dim1 = expanded_location[, 1], 114 | location_dim2 = expanded_location[, 2], 115 | spatpca = eigen_est[, 1], 116 | pca = svd(realizations)$v[, 1] 117 | ) 118 | 119 | plot_df_long <- rbind( 120 | data.frame(location_dim1 = plot_df$location_dim1, 121 | location_dim2 = plot_df$location_dim2, 122 | estimate = "spatpca", 123 | eigenfunction = plot_df$spatpca), 124 | data.frame(location_dim1 = plot_df$location_dim1, 125 | location_dim2 = plot_df$location_dim2, 126 | estimate = "pca", 127 | eigenfunction = plot_df$pca) 128 | ) 129 | 130 | ggplot(plot_df_long, aes(location_dim1, location_dim2)) + 131 | geom_tile(aes(fill = eigenfunction)) + 132 | scale_fill_gradientn(colours = coltab, limits = color_scale_limit) + 133 | base_theme + 134 | facet_wrap(~estimate) + 135 | labs(fill = "") + 136 | fill_bar 137 | ``` 138 | -------------------------------------------------------------------------------- /tests/testthat/test-SpatPCA.R: -------------------------------------------------------------------------------- 1 | # generate 1-D data with a given seed 2 | set.seed(1234) 3 | tol <- 1e-6 4 | num_cores <- 2 5 | 6 | x_1D <- as.matrix(seq(-5, 5, length = 10)) 7 | Phi_1D <- exp(-x_1D ^ 2) / norm(exp(-x_1D ^ 2), "F") 8 | Y_1D <- { 9 | rnorm(n = 100, sd = 3) %*% t(Phi_1D) + 10 | matrix(rnorm(n = 100 * 10), 100, 10) 11 | } 12 | 13 | cv_1D <- spatpca(x = x_1D, Y = Y_1D, num_cores = num_cores) 14 | cv_1D_fixed_K_multiple_tau2 <- spatpca( 15 | x = x_1D, 16 | Y = Y_1D, 17 | K = 1, 18 | tau2 = c(0, 1), 19 | num_cores = num_cores 20 | ) 21 | cv_1D_fixed_K_multiple_gamma <- spatpca( 22 | x = x_1D, 23 | Y = Y_1D, 24 | K = 1, 25 | gamma = c(0, 1), 26 | num_cores = num_cores 27 | ) 28 | cv_1D_fixed_K_fixed_tau1_fixed_tau2 <- spatpca( 29 | x = x_1D, 30 | Y = Y_1D, 31 | K = 1, 32 | tau1 = 10, 33 | tau2 = 100, 34 | num_cores = num_cores 35 | ) 36 | cv_1D_fixed_K_fixed_tau1_fixed_tau2_multiple_gamma <- spatpca( 37 | x = x_1D, 38 | Y = Y_1D, 39 | K = 1, 40 | tau1 = 0, 41 | tau2 = 0, 42 | gamma = c(0, 0.5, 1), 43 | num_cores = num_cores 44 | ) 45 | cv_1D_fixed_K_fixed_tau1 <- spatpca( 46 | x = x_1D, 47 | Y = Y_1D, 48 | K = 1, 49 | tau1 = 10, 50 | num_cores = num_cores 51 | ) 52 | estimated_eigenvalue_large_gamma <- 53 | spatialPrediction( 54 | cv_1D_fixed_K_fixed_tau1$eigenfn, 55 | cv_1D_fixed_K_fixed_tau1$detrended_Y, 56 | 1000, 57 | cv_1D_fixed_K_fixed_tau1$eigenfn 58 | )$eigenvalue 59 | 60 | estimated_signle_eigenvalue_medium_gamma <- 61 | spatialPrediction( 62 | cv_1D_fixed_K_fixed_tau1$eigenfn, 63 | cv_1D_fixed_K_fixed_tau1$detrended_Y, 64 | 5, 65 | cv_1D_fixed_K_fixed_tau1$eigenfn 66 | )$eigenvalue 67 | 68 | cv_1D_fixed_K_zero_tau1_zero_tau2 <- spatpca( 69 | x = x_1D, 70 | Y = Y_1D, 71 | K = 5, 72 | tau1 = 0, 73 | tau2 = 0, 74 | num_cores = num_cores 75 | ) 76 | estimated_eigenvalue_small_gamma <- spatialPrediction( 77 | cv_1D_fixed_K_zero_tau1_zero_tau2$eigenfn, 78 | cv_1D_fixed_K_zero_tau1_zero_tau2$detrended_Y, 79 | 0.5, 80 | cv_1D_fixed_K_zero_tau1_zero_tau2$eigenfn 81 | )$eigenvalue 82 | 83 | estimated_eigenvalue_medium_gamma <- spatialPrediction( 84 | cv_1D_fixed_K_zero_tau1_zero_tau2$eigenfn, 85 | cv_1D_fixed_K_zero_tau1_zero_tau2$detrended_Y, 86 | 10, 87 | cv_1D_fixed_K_zero_tau1_zero_tau2$eigenfn 88 | )$eigenvalue 89 | 90 | 91 | expected_selected_tau1_R_3.6_higher <- 0.00046416 92 | expected_selected_tau1_R_3.6_lower <- 0.01169 93 | expected_selected_gamma_R_3.6_higher <- 0.44503397 94 | expected_selected_gamma_R_3.6_lower <- 0.4737518 95 | 96 | # Test 97 | test_that("Selected tuning parameters", { 98 | expect_lte(min( 99 | abs(cv_1D$selected_tau1 - expected_selected_tau1_R_3.6_higher), 100 | abs(cv_1D$selected_tau1 - expected_selected_tau1_R_3.6_lower) 101 | ), 102 | tol) 103 | expect_lte(abs(cv_1D$selected_tau2 - 0), tol) 104 | expect_lte(min( 105 | abs( 106 | cv_1D$selected_gamma - expected_selected_gamma_R_3.6_higher 107 | ), 108 | abs(cv_1D$selected_gamma - expected_selected_gamma_R_3.6_lower) 109 | ), 110 | tol) 111 | expect_null(cv_1D$selected_K) 112 | expect_equal(cv_1D_fixed_K_multiple_tau2$selected_K, 1) 113 | expect_lte(abs(cv_1D_fixed_K_multiple_tau2$selected_tau1 - 0.002154435), 114 | tol) 115 | expect_equal(cv_1D_fixed_K_multiple_tau2$selected_tau2, 1) 116 | expect_equal(cv_1D_fixed_K_multiple_gamma$selected_gamma, 0) 117 | expect_equal(cv_1D_fixed_K_fixed_tau1_fixed_tau2$selected_tau1, 10) 118 | expect_equal(cv_1D_fixed_K_fixed_tau1_fixed_tau2$selected_tau2, 100) 119 | expect_equal(cv_1D_fixed_K_fixed_tau1_fixed_tau2_multiple_gamma$selected_gamma, 120 | 0) 121 | expect_equal(cv_1D_fixed_K_fixed_tau1$selected_tau1, 10) 122 | expect_equal(sum(cv_1D_fixed_K_fixed_tau1$cv_score_tau1), 0) 123 | expect_equal(sum(estimated_eigenvalue_large_gamma), 0) 124 | expect_equal(sum(estimated_eigenvalue_medium_gamma), 0) 125 | expect_lte(abs(sum(estimated_eigenvalue_small_gamma) - 9.397599), tol) 126 | expect_lte(sum(estimated_signle_eigenvalue_medium_gamma) - 0.1066821, 127 | tol) 128 | }) 129 | 130 | 131 | test_that("cross-validation plot", { 132 | expect_error(plot.spatpca("test"), 133 | cat("Invalid object! Please enter a `spatpca` object")) 134 | expect_true("ggplot" %in% class(plot.spatpca(cv_1D))) 135 | }) 136 | 137 | # Test `predict` 138 | x_1Dnew <- as.matrix(seq(6, 7, length = 4)) 139 | prediction <- predict(cv_1D, x_new = x_1Dnew) 140 | dominant_pattern_on_new_sites <- 141 | predictEigenfunction(cv_1D, x_new = x_1Dnew) 142 | 143 | test_that("prediction", { 144 | expect_equal(ncol(prediction), 4) 145 | expect_equal(nrow(dominant_pattern_on_new_sites), 4) 146 | }) 147 | 148 | 149 | # Test auxiliary function - CV with selecting K 150 | set.seed(1234) 151 | M <- 3 152 | shuffle_split <- sample(rep(1:M, length.out = nrow(Y_1D))) 153 | tau1 <- setTau1(NULL, M) 154 | tau2 <- setTau2(NULL, M) 155 | l2 <- setL2(tau2) 156 | setCores(2) 157 | cv_with_k_seleted <- 158 | spatpcaCVWithSelectedK(x_1D, Y_1D, M, tau1, tau2, 1, shuffle_split, 10, 1e-04, l2) 159 | 160 | test_that("auxiliary function for selecting K", { 161 | expect_equal(cv_with_k_seleted$selected_K, 1) 162 | expect_equal(cv_with_k_seleted$cv_result$selected_gamma, 1) 163 | expect_equal(cv_with_k_seleted$cv_result$selected_tau1, 1) 164 | expect_equal(cv_with_k_seleted$cv_result$selected_tau2, 0) 165 | }) 166 | 167 | 168 | # 3-D 169 | set.seed(1234) 170 | p <- 4 171 | x <- y <- z <- as.matrix(seq(-5, 5, length = p)) 172 | d <- expand.grid(x, y, z) 173 | Phi_3D <- 174 | rowSums(exp(-d ^ 2)) / norm(as.matrix(rowSums(exp(-d ^ 2))), "F") 175 | Y_3D <- 176 | rnorm(n = 100, sd = 3) %*% t(Phi_3D) + matrix(rnorm(n = 100 * p ^ 3), 100, p ^ 177 | 3) 178 | cv_3D <- spatpca(x = d, Y = Y_3D, num_cores = 2) 179 | predict <- 180 | eigenFunction(matrix(c(0, 0, 0), 1, 3), as.matrix(d), cv_3D$eigenfn) 181 | 182 | test_that("3D case", { 183 | expect_equal(dim(cv_3D$eigenfn), c(64, 2)) 184 | expect_lte(sum(abs(predict - c( 185 | 0.232199, 0.007501031 186 | ))), tol) 187 | }) 188 | -------------------------------------------------------------------------------- /man/spatpca.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/SpatPCA.R 3 | \name{spatpca} 4 | \alias{spatpca} 5 | \title{Regularized PCA for spatial data} 6 | \usage{ 7 | spatpca( 8 | x, 9 | Y, 10 | M = 5, 11 | K = NULL, 12 | is_K_selected = ifelse(is.null(K), TRUE, FALSE), 13 | tau1 = NULL, 14 | tau2 = NULL, 15 | gamma = NULL, 16 | is_Y_detrended = FALSE, 17 | maxit = 100, 18 | thr = 1e-04, 19 | num_cores = NULL 20 | ) 21 | } 22 | \arguments{ 23 | \item{x}{Location matrix (\eqn{p \times d}). Each row is a location. \eqn{d} is the dimension of locations} 24 | 25 | \item{Y}{Data matrix (\eqn{n \times p}) stores the values at \eqn{p} locations with sample size \eqn{n}.} 26 | 27 | \item{M}{Optional number of folds for cross validation; default is 5.} 28 | 29 | \item{K}{Optional user-supplied number of eigenfunctions; default is NULL. If K is NULL or is_K_selected is TRUE, K is selected automatically.} 30 | 31 | \item{is_K_selected}{If TRUE, K is selected automatically; otherwise, is_K_selected is set to be user-supplied K. Default depends on user-supplied K.} 32 | 33 | \item{tau1}{Optional user-supplied numeric vector of a non-negative smoothness parameter sequence. If NULL, 10 tau1 values in a range are used.} 34 | 35 | \item{tau2}{Optional user-supplied numeric vector of a non-negative sparseness parameter sequence. If NULL, none of tau2 is used.} 36 | 37 | \item{gamma}{Optional user-supplied numeric vector of a non-negative tuning parameter sequence. If NULL, 10 values in a range are used.} 38 | 39 | \item{is_Y_detrended}{If TRUE, center the columns of Y. Default is FALSE.} 40 | 41 | \item{maxit}{Maximum number of iterations. Default value is 100.} 42 | 43 | \item{thr}{Threshold for convergence. Default value is \eqn{10^{-4}}.} 44 | 45 | \item{num_cores}{Optional numeric value indicating desired cores. The request is validated but computations run sequentially. Default value is NULL.} 46 | } 47 | \value{ 48 | A list of objects including 49 | \item{eigenfn}{Estimated eigenfunctions at the new locations, x_new.} 50 | \item{selected_K}{Selected K based on CV. Execute the algorithm when \code{is_K_selected} is \code{TRUE}.} 51 | \item{selected_tau1}{Selected tau1.} 52 | \item{selected_tau2}{Selected tau2.} 53 | \item{selected_gamma}{Selected gamma.} 54 | \item{cv_score_tau1}{cv scores for tau1.} 55 | \item{cv_score_tau2}{cv scores for tau2.} 56 | \item{cv_score_gamma}{cv scores for gamma.} 57 | \item{tau1}{Sequence of tau1-values used in the process.} 58 | \item{tau2}{Sequence of tau2-values used in the process.} 59 | \item{gamma}{Sequence of gamma-values used in the process.} 60 | \item{detrended_Y}{If is_Y_detrended is TRUE, detrended_Y means Y is detrended; else, detrended_Y is equal to Y.} 61 | \item{scaled_x}{Input location matrix. Only scale when it is one-dimensional} 62 | } 63 | \description{ 64 | Produce spatial dominant patterns and spatial predictions at the designated locations according to the specified tuning parameters or the selected tuning parameters by the M-fold cross-validation. 65 | } 66 | \details{ 67 | An ADMM form of the proposed objective function is written as 68 | \deqn{\min_{\mathbf{\Phi}} \|\mathbf{Y}-\mathbf{Y}\mathbf{\Phi}\mathbf{\Phi}'\|^2_F +\tau_1\mbox{tr}(\mathbf{\Phi}^T\mathbf{\Omega}\mathbf{\Phi})+\tau_2\sum_{k=1}^K\sum_{j=1}^p |\phi_{jk}|,} 69 | \eqn{\mbox{subject to $ \mathbf{\Phi}^T\mathbf{\Phi}=\mathbf{I}_K$,}} where \eqn{\mathbf{Y}} is a data matrix, \eqn{{\mathbf{\Omega}}} is a smoothness matrix, and \eqn{\mathbf{\Phi}=\{\phi_{jk}\}}. 70 | } 71 | \examples{ 72 | # The following examples run sequentially. 73 | ## 1D: regular locations 74 | x_1D <- as.matrix(seq(-5, 5, length = 50)) 75 | Phi_1D <- exp(-x_1D^2) / norm(exp(-x_1D^2), "F") 76 | set.seed(1234) 77 | Y_1D <- rnorm(n = 100, sd = 3) \%*\% t(Phi_1D) + matrix(rnorm(n = 100 * 50), 100, 50) 78 | cv_1D <- spatpca(x = x_1D, Y = Y_1D) 79 | plot(x_1D, cv_1D$eigenfn[, 1], type = "l", main = "1st eigenfunction") 80 | lines(x_1D, svd(Y_1D)$v[, 1], col = "red") 81 | legend("topleft", c("SpatPCA", "PCA"), lty = 1:1, col = 1:2) 82 | 83 | \donttest{ 84 | ## 2D: Daily 8-hour ozone averages for sites in the Midwest (USA) 85 | if (requireNamespace("fields", quietly = TRUE) && 86 | requireNamespace("pracma", quietly = TRUE) && 87 | requireNamespace("maps", quietly = TRUE)) { 88 | library(fields) 89 | library(pracma) 90 | library(maps) 91 | data(ozone2) 92 | x <- ozone2$lon.lat 93 | Y <- ozone2$y 94 | date <- as.Date(ozone2$date, format = "\%y\%m\%d") 95 | rmna <- !colSums(is.na(Y)) 96 | YY <- matrix(Y[, rmna], nrow = nrow(Y)) 97 | YY <- detrend(YY, "linear") 98 | xx <- x[rmna, ] 99 | cv <- spatpca(x = xx, Y = YY) 100 | quilt.plot(xx, cv$eigenfn[, 1]) 101 | map("state", xlim = range(xx[, 1]), ylim = range(xx[, 2]), add = TRUE) 102 | map.text("state", xlim = range(xx[, 1]), ylim = range(xx[, 2]), cex = 2, add = TRUE) 103 | plot(date, YY \%*\% cv$eigenfn[, 1], type = "l", ylab = "1st Principal Component") 104 | ### new locations 105 | new_p <- 200 106 | x_lon <- seq(min(xx[, 1]), max(xx[, 1]), length = new_p) 107 | x_lat <- seq(min(xx[, 2]), max(xx[, 2]), length = new_p) 108 | xx_new <- as.matrix(expand.grid(x = x_lon, y = x_lat)) 109 | eof <- spatpca(x = xx, 110 | Y = YY, 111 | K = cv$selected_K, 112 | tau1 = cv$selected_tau1, 113 | tau2 = cv$selected_tau2) 114 | predicted_eof <- predictEigenfunction(eof, xx_new) 115 | quilt.plot(xx_new, 116 | predicted_eof[,1], 117 | nx = new_p, 118 | ny = new_p, 119 | xlab = "lon.", 120 | ylab = "lat.") 121 | map("state", xlim = range(x_lon), ylim = range(x_lat), add = TRUE) 122 | map.text("state", xlim = range(x_lon), ylim = range(x_lat), cex = 2, add = TRUE) 123 | } 124 | ## 3D: regular locations 125 | p <- 10 126 | x <- y <- z <- as.matrix(seq(-5, 5, length = p)) 127 | d <- expand.grid(x, y, z) 128 | Phi_3D <- rowSums(exp(-d^2)) / norm(as.matrix(rowSums(exp(-d^2))), "F") 129 | Y_3D <- rnorm(n = 100, sd = 3) \%*\% t(Phi_3D) + matrix(rnorm(n = 100 * p^3), 100, p^3) 130 | cv_3D <- spatpca(x = d, Y = Y_3D, tau2 = seq(0, 1000, length = 10)) 131 | library(plot3D) 132 | library(RColorBrewer) 133 | cols <- colorRampPalette(brewer.pal(9, "Blues"))(p) 134 | isosurf3D(x, y, z, 135 | colvar = array(cv_3D$eigenfn[, 1], c(p, p, p)), 136 | level= seq(min(cv_3D$eigenfn[, 1]), max(cv_3D$eigenfn[, 1]), length = p), 137 | ticktype = "detailed", 138 | colkey = list(side = 1), 139 | col = cols) 140 | } 141 | } 142 | \references{ 143 | Wang, W.-T. and Huang, H.-C. (2017). Regularized principal component analysis for spatial data. \emph{Journal of Computational and Graphical Statistics} \bold{26} 14-25. 144 | } 145 | \seealso{ 146 | \link{predict} 147 | } 148 | \author{ 149 | Wen-Ting Wang and Hsin-Cheng Huang 150 | } 151 | -------------------------------------------------------------------------------- /R/helper.R: -------------------------------------------------------------------------------- 1 | # This file was generated by Rcpp::compileAttributes 2 | # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | #' 4 | #' Internal helper: validate requested core count 5 | #' 6 | #' @keywords internal 7 | #' @param num_cores Optional numeric value representing desired cores. Default is NULL. 8 | #' @return TRUE when `num_cores` passes validation; otherwise NULL 9 | #' 10 | setCores <- function(num_cores = NULL) { 11 | if (!is.null(num_cores)) { 12 | if (!is.numeric(num_cores)) { 13 | stop("Please enter valid type - but got ", class(num_cores)) 14 | } 15 | if (length(num_cores) != 1) { 16 | stop("Please supply a single numeric value for num_cores.") 17 | } 18 | default_number <- parallel::detectCores() 19 | if (is.na(default_number) || default_number < 1) { 20 | default_number <- 1 21 | } 22 | if (num_cores > default_number) { 23 | stop("The input number of cores is invalid - default is ", 24 | default_number) 25 | } 26 | if (num_cores < 1) { 27 | stop("The number of cores is not greater than 1 - but got ", num_cores) 28 | } 29 | return(TRUE) 30 | } 31 | invisible(NULL) 32 | } 33 | 34 | #' 35 | #' Internal function: Scale one-dimension locations 36 | #' 37 | #' @keywords internal 38 | #' @param location Location matrix 39 | #' @return scaled location matrix 40 | #' 41 | scaleLocation <- function(location) { 42 | if (dim(location)[2] == 1) { 43 | min_location <- min(location) 44 | max_location <- max(location) 45 | scaled_location <- 46 | (location - min_location) / (max_location - min_location) 47 | } else { 48 | scaled_location <- location 49 | } 50 | return(scaled_location) 51 | } 52 | 53 | #' 54 | #' Internal function: Validate new locations for a spatpca object 55 | #' 56 | #' @keywords internal 57 | #' @param spatpca_object An `spatpca` class object 58 | #' @param x_new New location matrix. 59 | #' @return `NULL`. 60 | #' 61 | checkNewLocationsForSpatpcaObject <- 62 | function(spatpca_object, x_new) { 63 | if (!inherits(spatpca_object, "spatpca")) { 64 | stop("Invalid object! Please enter a `spatpca` object") 65 | } 66 | if (is.null(x_new)) { 67 | stop("New locations cannot be NULL") 68 | } 69 | x_new <- as.matrix(x_new) 70 | if (ncol(x_new) != ncol(spatpca_object$scaled_x)) { 71 | stop( 72 | "Inconsistent dimension of locations - original dimension is ", 73 | ncol(spatpca_object$x) 74 | ) 75 | } 76 | } 77 | 78 | #' 79 | #' Internal function: Validate input data for a spatpca object 80 | #' 81 | #' @keywords internal 82 | #' @param Y Data matrix 83 | #' @param x Location matrix. 84 | #' @param M Number of folds for cross-validation 85 | #' @return `NULL`. 86 | #' 87 | checkInputData <- function(Y, x, M) { 88 | x <- as.matrix(x) 89 | p <- ncol(Y) 90 | n <- nrow(Y) 91 | if (p < 3) { 92 | stop("Number of locations must be larger than 2.") 93 | } 94 | if (nrow(x) != p) { 95 | stop("The number of rows of x should be equal to the number of columns of Y.") 96 | } 97 | if (ncol(x) > 3) { 98 | stop("Dimension of locations must be less than 4.") 99 | } 100 | if (M >= n) { 101 | stop("Number of folds must be less than sample size.") 102 | } 103 | } 104 | 105 | #' 106 | #' Internal function: Fetch the upper bound of the number of eigenfunctions 107 | #' 108 | #' @keywords internal 109 | #' @param Y Data matrix 110 | #' @param M Number of folds for cross-validation 111 | #' @return integer 112 | #' 113 | fetchUpperBoundNumberEigenfunctions <- function(Y, M) { 114 | n <- nrow(Y) 115 | p <- ncol(Y) 116 | return(min(floor(n - n / M), p)) 117 | } 118 | 119 | #' 120 | #' Internal function: Set the number of eigenfunctions for a spatpca object 121 | #' 122 | #' @keywords internal 123 | #' @param K Optional user-supplied number of eigenfunctions. 124 | #' @param Y Data matrix 125 | #' @param M Number of folds for cross-validation 126 | #' @return integer 127 | #' 128 | setNumberEigenfunctions <- function(K, Y, M) { 129 | upper_bound <- fetchUpperBoundNumberEigenfunctions(Y, M) 130 | if (!is.null(K)) { 131 | if (K > upper_bound) { 132 | K <- upper_bound 133 | warning("K must be smaller than min(floor(n - n/M), p). Set K as ", K) 134 | } 135 | } 136 | return(K) 137 | } 138 | 139 | #' 140 | #' Internal function: Set tuning parameter - tau1 141 | #' 142 | #' @keywords internal 143 | #' @param tau1 Vector of a nonnegative smoothness parameter sequence. Default is NULL. 144 | #' @param M Number of folds for cross-validation 145 | #' @return Modified vector of a nonnegative smoothness parameter sequence. 146 | #' 147 | setTau1 <- function(tau1, M) { 148 | if (is.null(tau1)) { 149 | modified_tau1 <- c(0, exp(seq(log(1e-6), 0, length = 10))) 150 | } else { 151 | modified_tau1 <- tau1 152 | } 153 | 154 | if (M < 2) { 155 | return(max(modified_tau1)) 156 | } else { 157 | return(modified_tau1) 158 | } 159 | } 160 | 161 | #' 162 | #' Internal function: Set tuning parameter - tau2 163 | #' 164 | #' @keywords internal 165 | #' @param tau2 Vector of a nonnegative sparseness parameter sequence. Default is NULL. 166 | #' @param M Number of folds for cross-validation 167 | #' @return Modified vector of a nonnegative sparseness parameter sequence. 168 | #' 169 | setTau2 <- function(tau2, M) { 170 | if (is.null(tau2)) { 171 | modified_tau2 <- 0 172 | } else { 173 | modified_tau2 <- tau2 174 | } 175 | if (M < 2) { 176 | return(max(modified_tau2)) 177 | } else { 178 | return(modified_tau2) 179 | } 180 | } 181 | 182 | #' 183 | #' Internal function: Set tuning parameter - l2 184 | #' 185 | #' @keywords internal 186 | #' @param tau2 Vector of a nonnegative sparseness parameter sequence. Default is NULL. 187 | #' @return Modified vector of a nonnegative tuning parameter sequence for ADMM use 188 | #' 189 | setL2 <- function(tau2) { 190 | if (length(tau2) == 1 && tau2 > 0) { 191 | return(c(0, exp(seq( 192 | log(tau2 / 1e4), log(tau2), length = 10 193 | )))) 194 | } else { 195 | return(1) 196 | } 197 | } 198 | 199 | #' 200 | #' Internal function: Set tuning parameter - gamma 201 | #' 202 | #' @keywords internal 203 | #' @param gamma Vector of a nonnegative hyper parameter sequence for tuning eigenvalues. Default is NULL. 204 | #' @param Y Data matrix 205 | #' @return Modified vector of a nonnegative hyper parameter sequence for tuning eigenvalues. 206 | #' 207 | setGamma <- function(gamma, Y) { 208 | if (is.null(gamma)) { 209 | svd_Y_partial <- svd(Y) 210 | max_gamma <- svd_Y_partial$d[1] ^ 2 / nrow(Y) 211 | return(c(0, exp(seq( 212 | log(max_gamma / 1e4), log(max_gamma), length = 10 213 | )))) 214 | } else { 215 | return(gamma) 216 | } 217 | } 218 | 219 | #' 220 | #' Internal function: Detrend Y by column-wise centering 221 | #' 222 | #' @keywords internal 223 | #' @param Y Data matrix 224 | #' @return Detrended data matrix 225 | #' 226 | detrend <- function(Y, is_Y_detrended) { 227 | if (is_Y_detrended) { 228 | return(Y - rep(colMeans(Y), rep.int(nrow(Y), ncol(Y)))) 229 | } else { 230 | return(Y) 231 | } 232 | } 233 | -------------------------------------------------------------------------------- /R/SpatPCA.R: -------------------------------------------------------------------------------- 1 | # This file was generated by Rcpp::compileAttributes 2 | # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | #' 4 | #' Internal function: M-fold CV of SpatPCA with selected K 5 | #' 6 | #' @keywords internal 7 | #' 8 | #' @param x Location matrix 9 | #' @param Y Data matrix 10 | #' @param M The number of folds for cross validation; default is 5. 11 | #' @param tau1 Vector of a non-negative smoothness parameter sequence. If NULL, 10 tau1 values in a range are used. 12 | #' @param tau2 Vector of a non-negative sparseness parameter sequence. If NULL, none of tau2 is used. 13 | #' @param gamma Vector of a non-negative hyper parameter sequence for tuning eigenvalues. If NULL, 10 values in a range are used. 14 | #' @param shuffle_split Vector of indices for random splitting Y into training and test sets 15 | #' @param maxit Maximum number of iterations. Default value is 100. 16 | #' @param thr Threshold for convergence. Default value is \eqn{10^{-4}}. 17 | #' @param l2 Vector of a non-negative tuning parameter sequence for ADMM use 18 | #' @return A list of objects including 19 | #' \item{cv_result}{A list of resultant objects produced by `spatpcaCV`} 20 | #' \item{selected_K}{Selected K based on CV.} 21 | #' 22 | 23 | spatpcaCVWithSelectedK <- 24 | function(x, 25 | Y, 26 | M, 27 | tau1, 28 | tau2, 29 | gamma, 30 | shuffle_split, 31 | maxit, 32 | thr, 33 | l2) { 34 | upper_bound <- fetchUpperBoundNumberEigenfunctions(Y, M) 35 | prev_cv_selection <- spatpcaCV(x, Y, M, 1, tau1, tau2, gamma, shuffle_split, maxit, thr, l2) 36 | 37 | for (k in 2:upper_bound) { 38 | cv_selection <- 39 | spatpcaCV(x, Y, M, k, tau1, tau2, gamma, shuffle_split, maxit, thr, l2) 40 | difference <- 41 | prev_cv_selection$selected_gamma - cv_selection$selected_gamma 42 | prev_cv_selection <- cv_selection 43 | if (difference <= 0 || abs(difference) <= 1e-8) { 44 | break 45 | } 46 | } 47 | return(list(cv_result = cv_selection, selected_K = k - 1)) 48 | } 49 | 50 | #' 51 | #' @title Regularized PCA for spatial data 52 | #' 53 | #' @description Produce spatial dominant patterns and spatial predictions at the designated locations according to the specified tuning parameters or the selected tuning parameters by the M-fold cross-validation. 54 | #' 55 | #' @param x Location matrix (\eqn{p \times d}). Each row is a location. \eqn{d} is the dimension of locations 56 | #' @param Y Data matrix (\eqn{n \times p}) stores the values at \eqn{p} locations with sample size \eqn{n}. 57 | #' @param K Optional user-supplied number of eigenfunctions; default is NULL. If K is NULL or is_K_selected is TRUE, K is selected automatically. 58 | #' @param is_K_selected If TRUE, K is selected automatically; otherwise, is_K_selected is set to be user-supplied K. Default depends on user-supplied K. 59 | #' @param tau1 Optional user-supplied numeric vector of a non-negative smoothness parameter sequence. If NULL, 10 tau1 values in a range are used. 60 | #' @param tau2 Optional user-supplied numeric vector of a non-negative sparseness parameter sequence. If NULL, none of tau2 is used. 61 | #' @param gamma Optional user-supplied numeric vector of a non-negative tuning parameter sequence. If NULL, 10 values in a range are used. 62 | #' @param M Optional number of folds for cross validation; default is 5. 63 | #' @param is_Y_detrended If TRUE, center the columns of Y. Default is FALSE. 64 | #' @param maxit Maximum number of iterations. Default value is 100. 65 | #' @param thr Threshold for convergence. Default value is \eqn{10^{-4}}. 66 | #' @param num_cores Optional numeric value indicating desired cores. The request is validated but computations currently run sequentially. Default is NULL. 67 | #' 68 | #' @seealso \link{predict} 69 | #' 70 | #' @return A list of objects including 71 | #' \item{eigenfn}{Estimated eigenfunctions at the new locations, x_new.} 72 | #' \item{selected_K}{Selected K based on CV. Execute the algorithm when `is_K_selected` is `TRUE`.} 73 | #' \item{selected_tau1}{Selected tau1.} 74 | #' \item{selected_tau2}{Selected tau2.} 75 | #' \item{selected_gamma}{Selected gamma.} 76 | #' \item{cv_score_tau1}{cv scores for tau1.} 77 | #' \item{cv_score_tau2}{cv scores for tau2.} 78 | #' \item{cv_score_gamma}{cv scores for gamma.} 79 | #' \item{tau1}{Sequence of tau1-values used in the process.} 80 | #' \item{tau2}{Sequence of tau2-values used in the process.} 81 | #' \item{gamma}{Sequence of gamma-values used in the process.} 82 | #' \item{detrended_Y}{If is_Y_detrended is TRUE, detrended_Y means Y is detrended; else, detrended_Y is equal to Y.} 83 | #' \item{scaled_x}{Input location matrix. Only scale when it is one-dimensional} 84 | #' 85 | #' @details An ADMM form of the proposed objective function is written as 86 | #' \deqn{\min_{\mathbf{\Phi}} \|\mathbf{Y}-\mathbf{Y}\mathbf{\Phi}\mathbf{\Phi}'\|^2_F +\tau_1\mbox{tr}(\mathbf{\Phi}^T\mathbf{\Omega}\mathbf{\Phi})+\tau_2\sum_{k=1}^K\sum_{j=1}^p |\phi_{jk}|,} 87 | #' \eqn{\mbox{subject to $ \mathbf{\Phi}^T\mathbf{\Phi}=\mathbf{I}_K$,}} where \eqn{\mathbf{Y}} is a data matrix, \eqn{{\mathbf{\Omega}}} is a smoothness matrix, and \eqn{\mathbf{\Phi}=\{\phi_{jk}\}}. 88 | #' @export 89 | #' @author Wen-Ting Wang and Hsin-Cheng Huang 90 | #' @references Wang, W.-T. and Huang, H.-C. (2017). Regularized principal component analysis for spatial data. \emph{Journal of Computational and Graphical Statistics} \bold{26} 14-25. 91 | #' @examples 92 | #' # The following examples run sequentially. 93 | #' ## 1D: regular locations 94 | #' x_1D <- as.matrix(seq(-5, 5, length = 50)) 95 | #' Phi_1D <- exp(-x_1D^2) / norm(exp(-x_1D^2), "F") 96 | #' set.seed(1234) 97 | #' Y_1D <- rnorm(n = 100, sd = 3) %*% t(Phi_1D) + matrix(rnorm(n = 100 * 50), 100, 50) 98 | #' cv_1D <- spatpca(x = x_1D, Y = Y_1D) 99 | #' plot(x_1D, cv_1D$eigenfn[, 1], type = "l", main = "1st eigenfunction") 100 | #' lines(x_1D, svd(Y_1D)$v[, 1], col = "red") 101 | #' legend("topleft", c("SpatPCA", "PCA"), lty = 1:1, col = 1:2) 102 | #' 103 | #' \donttest{ 104 | #' ## 2D: Daily 8-hour ozone averages for sites in the Midwest (USA) 105 | #' if (requireNamespace("fields", quietly = TRUE) && 106 | #' requireNamespace("pracma", quietly = TRUE) && 107 | #' requireNamespace("maps", quietly = TRUE)) { 108 | #' library(fields) 109 | #' library(pracma) 110 | #' library(maps) 111 | #' data(ozone2) 112 | #' x <- ozone2$lon.lat 113 | #' Y <- ozone2$y 114 | #' date <- as.Date(ozone2$date, format = "%y%m%d") 115 | #' rmna <- !colSums(is.na(Y)) 116 | #' YY <- matrix(Y[, rmna], nrow = nrow(Y)) 117 | #' YY <- detrend(YY, "linear") 118 | #' xx <- x[rmna, ] 119 | #' cv <- spatpca(x = xx, Y = YY) 120 | #' quilt.plot(xx, cv$eigenfn[, 1]) 121 | #' map("state", xlim = range(xx[, 1]), ylim = range(xx[, 2]), add = TRUE) 122 | #' map.text("state", xlim = range(xx[, 1]), ylim = range(xx[, 2]), cex = 2, add = TRUE) 123 | #' plot(date, YY %*% cv$eigenfn[, 1], type = "l", ylab = "1st Principal Component") 124 | #' ### new locations 125 | #' new_p <- 200 126 | #' x_lon <- seq(min(xx[, 1]), max(xx[, 1]), length = new_p) 127 | #' x_lat <- seq(min(xx[, 2]), max(xx[, 2]), length = new_p) 128 | #' xx_new <- as.matrix(expand.grid(x = x_lon, y = x_lat)) 129 | #' eof <- spatpca(x = xx, 130 | #' Y = YY, 131 | #' K = cv$selected_K, 132 | #' tau1 = cv$selected_tau1, 133 | #' tau2 = cv$selected_tau2) 134 | #' predicted_eof <- predictEigenfunction(eof, xx_new) 135 | #' quilt.plot(xx_new, 136 | #' predicted_eof[, 1], 137 | #' nx = new_p, 138 | #' ny = new_p, 139 | #' xlab = "lon.", 140 | #' ylab = "lat.") 141 | #' map("state", xlim = range(x_lon), ylim = range(x_lat), add = TRUE) 142 | #' map.text("state", xlim = range(x_lon), ylim = range(x_lat), cex = 2, add = TRUE) 143 | #' } 144 | #' ## 3D: regular locations 145 | #' p <- 10 146 | #' x <- y <- z <- as.matrix(seq(-5, 5, length = p)) 147 | #' d <- expand.grid(x, y, z) 148 | #' Phi_3D <- rowSums(exp(-d^2)) / norm(as.matrix(rowSums(exp(-d^2))), "F") 149 | #' Y_3D <- rnorm(n = 100, sd = 3) %*% t(Phi_3D) + matrix(rnorm(n = 100 * p^3), 100, p^3) 150 | #' cv_3D <- spatpca(x = d, Y = Y_3D, tau2 = seq(0, 1000, length = 10)) 151 | #' library(plot3D) 152 | #' library(RColorBrewer) 153 | #' cols <- colorRampPalette(brewer.pal(9, "Blues"))(p) 154 | #' isosurf3D(x, y, z, 155 | #' colvar = array(cv_3D$eigenfn[, 1], c(p, p, p)), 156 | #' level= seq(min(cv_3D$eigenfn[, 1]), max(cv_3D$eigenfn[, 1]), length = p), 157 | #' ticktype = "detailed", 158 | #' colkey = list(side = 1), 159 | #' col = cols) 160 | #' } 161 | spatpca <- function(x, 162 | Y, 163 | M = 5, 164 | K = NULL, 165 | is_K_selected = ifelse(is.null(K), TRUE, FALSE), 166 | tau1 = NULL, 167 | tau2 = NULL, 168 | gamma = NULL, 169 | is_Y_detrended = FALSE, 170 | maxit = 100, 171 | thr = 1e-04, 172 | num_cores = NULL) { 173 | call2 <- match.call() 174 | checkInputData(Y, x, M) 175 | setCores(num_cores) 176 | 177 | # Transform main objects 178 | x <- as.matrix(x) 179 | Y <- detrend(Y, is_Y_detrended) 180 | K <- setNumberEigenfunctions(K, Y, M) 181 | p <- ncol(Y) 182 | n <- nrow(Y) 183 | scaled_x <- scaleLocation(x) 184 | shuffle_split <- sample(rep(1:M, length.out = nrow(Y))) 185 | 186 | # Initialize candidates of tuning parameters 187 | tau1 <- setTau1(tau1, M) 188 | tau2 <- setTau2(tau2, M) 189 | l2 <- setL2(tau2) 190 | gamma <- setGamma(gamma, Y[which(shuffle_split != 1), ]) 191 | 192 | if (is_K_selected) { 193 | cv_with_selected_k <- 194 | spatpcaCVWithSelectedK(scaled_x, 195 | Y, 196 | M, 197 | tau1, 198 | tau2, 199 | gamma, 200 | shuffle_split, 201 | maxit, 202 | thr, 203 | l2) 204 | cv_result <- cv_with_selected_k$cv_result 205 | selected_K <- cv_with_selected_k$selected_K 206 | } 207 | else { 208 | cv_result <- 209 | spatpcaCV(scaled_x, 210 | Y, 211 | M, 212 | K, 213 | tau1, 214 | tau2, 215 | gamma, 216 | shuffle_split, 217 | maxit, 218 | thr, 219 | l2) 220 | selected_K <- K 221 | } 222 | 223 | selected_tau1 <- cv_result$selected_tau1 224 | selected_tau2 <- cv_result$selected_tau2 225 | selected_gamma <- cv_result$selected_gamma 226 | cv_score_tau1 <- cv_result$cv_score_tau1 227 | cv_score_tau2 <- cv_result$cv_score_tau2 228 | cv_score_gamma <- cv_result$cv_score_gamma 229 | estimated_eigenfn <- cv_result$estimated_eigenfn 230 | 231 | obj.cv <- list( 232 | call = call2, 233 | eigenfn = estimated_eigenfn, 234 | selected_K = K, 235 | selected_tau1 = selected_tau1, 236 | selected_tau2 = selected_tau2, 237 | selected_gamma = selected_gamma, 238 | cv_score_tau1 = cv_score_tau1, 239 | cv_score_tau2 = cv_score_tau2, 240 | cv_score_gamma = cv_score_gamma, 241 | tau1 = tau1, 242 | tau2 = tau2, 243 | gamma = gamma, 244 | detrended_Y = Y, 245 | scaled_x = scaled_x 246 | ) 247 | class(obj.cv) <- "spatpca" 248 | return(obj.cv) 249 | } 250 | 251 | #' @title Spatial dominant patterns on new locations 252 | #' 253 | #' @description Estimate K eigenfunctions on new locations 254 | #' 255 | #' @param spatpca_object An `spatpca` class object 256 | #' @param x_new New location matrix. 257 | #' @seealso \link{spatpca} 258 | #' @return {A matrix with K Eigenfunction values on new locations.} 259 | #' @examples 260 | #' # 1D: artificial irregular locations 261 | #' x_1D <- as.matrix(seq(-5, 5, length = 10)) 262 | #' Phi_1D <- exp(-x_1D^2) / norm(exp(-x_1D^2), "F") 263 | #' set.seed(1234) 264 | #' Y_1D <- rnorm(n = 100, sd = 3) %*% t(Phi_1D) + matrix(rnorm(n = 100 * 10), 100, 10) 265 | #' rm_loc <- sample(1:10, 2) 266 | #' x_1Drm <- x_1D[-rm_loc] 267 | #' Y_1Drm <- Y_1D[, -rm_loc] 268 | #' x_1Dnew <- as.matrix(seq(-5, 5, length = 20)) 269 | #' cv_1D <- spatpca(x = x_1Drm, Y = Y_1Drm, tau2 = 1:100) 270 | #' dominant_patterns <- predictEigenfunction(cv_1D, x_new = x_1Dnew) 271 | #' 272 | predictEigenfunction <- function(spatpca_object, x_new) { 273 | checkNewLocationsForSpatpcaObject(spatpca_object, x_new) 274 | scaled_x_new <- scaleLocation(x_new) 275 | 276 | predicted_eigenfn <- eigenFunction(scaled_x_new, 277 | spatpca_object$scaled_x, 278 | spatpca_object$eigenfn) 279 | return(predicted_eigenfn) 280 | } 281 | 282 | #' @title Spatial predictions on new locations 283 | #' 284 | #' @description Predict the response on new locations with the estimated spatial structures. 285 | #' 286 | #' @param spatpca_object An `spatpca` class object 287 | #' @param x_new New location matrix. 288 | #' @param eigen_patterns_on_new_site Eigen-patterns on x_new 289 | #' @seealso \link{spatpca} 290 | #' @return A prediction matrix of Y at the new locations, x_new. 291 | #' @examples 292 | #' # 1D: artificial irregular locations 293 | #' x_1D <- as.matrix(seq(-5, 5, length = 10)) 294 | #' Phi_1D <- exp(-x_1D^2) / norm(exp(-x_1D^2), "F") 295 | #' set.seed(1234) 296 | #' Y_1D <- rnorm(n = 100, sd = 3) %*% t(Phi_1D) + matrix(rnorm(n = 100 * 10), 100, 10) 297 | #' removed_location <- sample(1:10, 3) 298 | #' removed_x_1D <- x_1D[-removed_location] 299 | #' removed_Y_1D <- Y_1D[, -removed_location] 300 | #' new_x_1D <- as.matrix(seq(-5, 5, length = 20)) 301 | #' cv_1D <- spatpca(x = removed_x_1D, Y = removed_Y_1D, tau2 = 1:100) 302 | #' predictions <- predict(cv_1D, x_new = new_x_1D) 303 | #' 304 | predict <- 305 | function(spatpca_object, 306 | x_new, 307 | eigen_patterns_on_new_site = NULL) { 308 | checkNewLocationsForSpatpcaObject(spatpca_object, x_new) 309 | 310 | if (is.null(eigen_patterns_on_new_site)) { 311 | eigen_patterns_on_new_site <- 312 | predictEigenfunction(spatpca_object, x_new) 313 | } 314 | 315 | spatial_prediction <- spatialPrediction( 316 | spatpca_object$eigenfn, 317 | spatpca_object$detrended_Y, 318 | spatpca_object$selected_gamma, 319 | eigen_patterns_on_new_site 320 | ) 321 | return(spatial_prediction$prediction) 322 | } 323 | 324 | #' 325 | #' @title Display the cross-validation results 326 | #' 327 | #' @description Display the M-fold cross-validation results 328 | #' 329 | #' @param x An spatpca class object for `plot` method 330 | #' @param ... Not used directly 331 | #' @return `NULL`. 332 | #' @seealso \link{spatpca} 333 | #' 334 | #' @export 335 | #' @method plot spatpca 336 | #' @examples 337 | #' x_1D <- as.matrix(seq(-5, 5, length = 10)) 338 | #' Phi_1D <- exp(-x_1D^2) / norm(exp(-x_1D^2), "F") 339 | #' set.seed(1234) 340 | #' Y_1D <- rnorm(n = 100, sd = 3) %*% t(Phi_1D) + matrix(rnorm(n = 100 * 10), 100, 10) 341 | #' cv_1D <- spatpca(x = x_1D, Y = Y_1D) 342 | #' plot(cv_1D) 343 | # 344 | plot.spatpca <- function(x, ...) { 345 | if (!inherits(x, "spatpca")) { 346 | stop("Invalid object! Please enter a `spatpca` object") 347 | } 348 | 349 | # Set the default theme 350 | theme_set( 351 | theme_bw() + 352 | theme( 353 | text = element_text(size = 16), 354 | legend.position = "none", 355 | legend.title = element_blank(), 356 | plot.title = element_text(hjust = 0.5) 357 | ) 358 | ) 359 | tau1_hat_string = paste( 360 | c( 361 | "hat(tau)[1]==", 362 | formatC(x$selected_tau1, format = "f", digits = 3) 363 | ), 364 | collapse = "" 365 | ) 366 | tau2_hat_string = paste( 367 | c( 368 | "hat(tau)[2]==", 369 | formatC(x$selected_tau2, format = "f", digits = 3) 370 | ), 371 | collapse = "" 372 | ) 373 | parameter_types = c( 374 | "tau[1]~'|'~tau[2]==0", 375 | paste(c("tau[2]~'|'~", tau1_hat_string), collapse = ""), 376 | paste(c("gamma~'|'~list(", tau1_hat_string, ",", tau2_hat_string, ")"), collapse = "") 377 | ) 378 | cv_dataframe <- rbind( 379 | data.frame( 380 | type = parameter_types[1], 381 | parameter = array(x$tau1), 382 | cv = array(x$cv_score_tau1) 383 | ), 384 | data.frame( 385 | type = parameter_types[2], 386 | parameter = array(x$tau2), 387 | cv = array(x$cv_score_tau2) 388 | ), 389 | data.frame( 390 | type = parameter_types[3], 391 | parameter = array(x$gamma), 392 | cv = array(x$cv_score_gamma) 393 | ) 394 | ) 395 | cv_dataframe$type = factor(cv_dataframe$type, levels = parameter_types) 396 | 397 | result <- 398 | ggplot(cv_dataframe, 399 | aes(x = parameter, y = cv, color = type)) + 400 | geom_line(linewidth = 1.5) + 401 | facet_grid(scales = "free", 402 | . ~ type, 403 | labeller = labeller(type = label_parsed)) + 404 | ggtitle("Result of K-fold CV") 405 | return(suppressMessages(print(result))) 406 | } 407 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc., 5 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Lesser General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS 281 | 282 | How to Apply These Terms to Your New Programs 283 | 284 | If you develop a new program, and you want it to be of the greatest 285 | possible use to the public, the best way to achieve this is to make it 286 | free software which everyone can redistribute and change under these terms. 287 | 288 | To do so, attach the following notices to the program. It is safest 289 | to attach them to the start of each source file to most effectively 290 | convey the exclusion of warranty; and each file should have at least 291 | the "copyright" line and a pointer to where the full notice is found. 292 | 293 | 294 | Copyright (C) 295 | 296 | This program is free software; you can redistribute it and/or modify 297 | it under the terms of the GNU General Public License as published by 298 | the Free Software Foundation; either version 2 of the License, or 299 | (at your option) any later version. 300 | 301 | This program is distributed in the hope that it will be useful, 302 | but WITHOUT ANY WARRANTY; without even the implied warranty of 303 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 304 | GNU General Public License for more details. 305 | 306 | You should have received a copy of the GNU General Public License along 307 | with this program; if not, write to the Free Software Foundation, Inc., 308 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 309 | 310 | Also add information on how to contact you by electronic and paper mail. 311 | 312 | If the program is interactive, make it output a short notice like this 313 | when it starts in an interactive mode: 314 | 315 | Gnomovision version 69, Copyright (C) year name of author 316 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 317 | This is free software, and you are welcome to redistribute it 318 | under certain conditions; type `show c' for details. 319 | 320 | The hypothetical commands `show w' and `show c' should show the appropriate 321 | parts of the General Public License. Of course, the commands you use may 322 | be called something other than `show w' and `show c'; they could even be 323 | mouse-clicks or menu items--whatever suits your program. 324 | 325 | You should also get your employer (if you work as a programmer) or your 326 | school, if any, to sign a "copyright disclaimer" for the program, if 327 | necessary. Here is a sample; alter the names: 328 | 329 | Yoyodyne, Inc., hereby disclaims all copyright interest in the program 330 | `Gnomovision' (which makes passes at compilers) written by James Hacker. 331 | 332 | , 1 April 1989 333 | Ty Coon, President of Vice 334 | 335 | This General Public License does not permit incorporating your program into 336 | proprietary programs. If your program is a subroutine library, you may 337 | consider it more useful to permit linking proprietary applications with the 338 | library. If this is what you want to do, use the GNU Lesser General 339 | Public License instead of this License. 340 | -------------------------------------------------------------------------------- /src/RcppSpatPCA.cpp: -------------------------------------------------------------------------------- 1 | // includes from the plugin 2 | // [[Rcpp::depends(RcppArmadillo)]] 3 | #include 4 | #include 5 | #include 6 | // [[Rcpp::plugins(cpp17)]] 7 | 8 | using namespace Rcpp; 9 | using namespace std; 10 | using namespace arma; 11 | 12 | struct thinPlateSpline { 13 | const mat& P; 14 | mat& L; 15 | int p; 16 | int d; 17 | thinPlateSpline(const mat &P, mat& L, int p, int d): P(P), L(L), p(p), d(d) {} 18 | 19 | void operator()(std::size_t begin, std::size_t end) { 20 | for(std::size_t i = begin; i < end; i++) { 21 | for(int j = 0; j < p; ++j) { 22 | if(j > i) { 23 | if(d == 1) { 24 | double r = sqrt(pow(P(i, 0) - P(j, 0), 2)); 25 | L(i, j) = pow(r, 3) / 12; 26 | } 27 | else if(d == 2) { 28 | double r = sqrt(pow(P(i, 0) - P(j, 0), 2) + (pow(P(i, 1) - P(j, 1), 2))); 29 | L(i, j) = r * r * log(r) / (8.0 * datum::pi); 30 | } 31 | else if(d == 3) { 32 | double r = sqrt(pow(P(i, 0) - P(j, 0), 2) + 33 | pow(P(i, 1) - P(j, 1), 2) + 34 | pow(P(i, 2) - P(j, 2), 2)); 35 | L(i, j) = -r / (8.0 * datum::pi); 36 | } 37 | } 38 | } 39 | 40 | L(i, p) = 1; 41 | for(int k = 0; k < d; ++k) 42 | L(i, p + k + 1) = P(i, k); 43 | } 44 | } 45 | }; 46 | 47 | //' @title Thin-plane spline matrix 48 | //' 49 | //' @description Produce a thin-plane spline matrix based on a given location matrix 50 | //' 51 | //' @param location A location matrix 52 | //' @return A thin-plane spline matrix 53 | //' @examples 54 | //' pesudo_sequence <- seq(-5, 5, length = 5) 55 | //' two_dim_location <- as.matrix(expand.grid(x = pesudo_sequence, y = pesudo_sequence)) 56 | //' thin_plate_matrix <- thinPlateSplineMatrix(two_dim_location) 57 | // [[Rcpp::export]] 58 | arma::mat thinPlateSplineMatrix(const arma::mat& location) { 59 | const int p = location.n_rows, d = location.n_cols; 60 | const int total_size = p + d; 61 | 62 | mat L(total_size + 1, total_size + 1, fill::zeros); 63 | const mat Ip(total_size + 1, total_size + 1, fill::eye); 64 | 65 | thinPlateSpline thin_plate_spline(location, L, p, d); 66 | thin_plate_spline(0, p); 67 | L = symmatu(L); 68 | 69 | mat Lp = inv(L + 1e-8 * Ip); 70 | Lp.shed_cols(p, total_size); 71 | Lp.shed_rows(p, total_size); 72 | L.shed_cols(p, total_size); 73 | L.shed_rows(p, total_size); 74 | 75 | return Lp.t() * (L * Lp); 76 | } 77 | 78 | //' @title Interpolated Eigen-function 79 | //' 80 | //' @description Produce Eigen-function values based on new locations 81 | //' 82 | //' @keywords internal 83 | //' @param new_location A location matrix 84 | //' @param original_location A location matrix 85 | //' @param Phi An eigenvector matrix 86 | //' @return A predictive estimate matrix 87 | //' @examples 88 | //' pesudo_sequence <- seq(-5, 5, length = 2) 89 | //' original_location <- as.matrix(expand.grid(x = pesudo_sequence, y = pesudo_sequence)) 90 | //' new_location <- matrix(c(0.1, 0.2), nrow = 1, ncol = 2) 91 | //' Phi <- matrix(c(1, 0, 0, 0), nrow = 4, ncol = 1) 92 | //' thin_plate_matrix <- eigenFunction(new_location, original_location, Phi) 93 | // [[Rcpp::export]] 94 | arma::mat eigenFunction(const arma::mat& new_location, 95 | const arma::mat& original_location, 96 | const arma::mat& Phi) { 97 | const int p = original_location.n_rows, d = original_location.n_cols, K = Phi.n_cols; 98 | const int total_size = p + d; 99 | 100 | mat L(total_size + 1, total_size + 1, fill::zeros); 101 | thinPlateSpline tps(original_location, L, p, d); 102 | tps(0, p); 103 | L = L + L.t(); 104 | 105 | mat Phi_star(total_size + 1, K, fill::zeros); 106 | Phi_star.rows(0, p - 1) = Phi; 107 | 108 | mat para = solve(L, Phi_star); 109 | 110 | const int pnew = new_location.n_rows; 111 | mat eigen_fn(pnew, K, fill::zeros); 112 | 113 | for (int new_i = 0; new_i < pnew ; ++new_i) { 114 | for (int i = 0; i < K; ++i) { 115 | double psum = 0.0; 116 | for (int j = 0; j < p; ++j) { 117 | double r = 0.0; 118 | if (d == 1) { 119 | r = std::abs(new_location(new_i, 0) - original_location(j, 0)); 120 | if (r > 0) psum += para(j, i) * (r * r * r) / 12.0; 121 | } else if (d == 2) { 122 | const double dx = new_location(new_i, 0) - original_location(j, 0); 123 | const double dy = new_location(new_i, 1) - original_location(j, 1); 124 | r = std::sqrt(dx*dx + dy*dy); 125 | if (r > 0) psum += para(j, i) * r * r * std::log(r) / (8.0 * datum::pi); 126 | } else if (d == 3) { 127 | const double dx = new_location(new_i, 0) - original_location(j, 0); 128 | const double dy = new_location(new_i, 1) - original_location(j, 1); 129 | const double dz = new_location(new_i, 2) - original_location(j, 2); 130 | r = std::sqrt(dx*dx + dy*dy + dz*dz); 131 | if (r > 0) psum -= para(j, i) * r / (8.0 * datum::pi); 132 | } 133 | } 134 | if (d == 1) { 135 | eigen_fn(new_i, i) = psum + para(p + 1, i) * new_location(new_i, 0) + para(p, i); 136 | } else if (d == 2) { 137 | eigen_fn(new_i, i) = psum + para(p + 1, i) * new_location(new_i, 0) 138 | + para(p + 2, i) * new_location(new_i, 1) + para(p, i); 139 | } else { // d == 3 140 | eigen_fn(new_i, i) = psum + para(p + 1, i) * new_location(new_i, 0) 141 | + para(p + 2, i) * new_location(new_i, 1) 142 | + para(p + 3, i) * new_location(new_i, 2) + para(p, i); 143 | } 144 | } 145 | } 146 | return eigen_fn; 147 | } 148 | 149 | // user includes 150 | void spatpcaCore2( 151 | const mat gram_matrix_Y, 152 | mat& Phi, 153 | mat& C, 154 | mat& Lambda2, 155 | const mat Omega, 156 | const double tau1, 157 | const double rho, 158 | const int maxit, 159 | const double tol) { 160 | int p = Phi.n_rows, K = Phi.n_cols, iter = 0; 161 | mat Ip, Sigtau1, temp, tempinv, U, V, diff, Cold = C, Lambda2old = Lambda2; 162 | vec error(2), S; 163 | Ip.eye(p,p); 164 | Sigtau1 = tau1 * Omega - gram_matrix_Y; 165 | tempinv = inv_sympd(symmatu(2 * Sigtau1 + rho * Ip)); 166 | 167 | for(iter = 0; iter < maxit; iter++) { 168 | Phi = tempinv * ((rho * Cold) - Lambda2old); 169 | temp = Phi + (Lambda2old / rho); 170 | svd_econ(U, S, V, temp); 171 | C = U.cols(0, V.n_cols - 1) * V.t(); 172 | diff = Phi - C; 173 | Lambda2 = Lambda2old + rho * diff; 174 | 175 | error[0] = norm(diff, "fro") / sqrt(p * K / 1.0); 176 | error[1] = norm(C - Cold, "fro") / sqrt(p * K / 1.0); 177 | 178 | if(max(error) <= tol) 179 | break; 180 | Cold = C; 181 | Lambda2old = Lambda2; 182 | } 183 | 184 | iter++; 185 | } 186 | 187 | mat spatpcaCore2p( 188 | const mat gram_matrix_Y, 189 | mat& C, 190 | mat& Lambda2, 191 | const mat Omega, 192 | const double tau1, 193 | const double rho, 194 | const int maxit, 195 | const double tol) { 196 | int p = C.n_rows, K = C.n_cols, iter = 0; 197 | mat Ip, Sigtau1, temp, tempinv, U, V, diff, Phi, Cold = C, Lambda2old = Lambda2; 198 | vec error(2), S; 199 | 200 | Ip.eye(p, p); 201 | Sigtau1 = tau1 * Omega - gram_matrix_Y; 202 | 203 | tempinv = inv_sympd(symmatu(2 * Sigtau1 + rho * Ip)); 204 | for(iter = 0; iter < maxit; iter++) { 205 | Phi = tempinv * ((rho * Cold) - Lambda2old); 206 | temp = Phi + (Lambda2old / rho); 207 | svd_econ(U, S, V, temp); 208 | C = U.cols(0, V.n_cols - 1) * V.t(); 209 | diff = Phi - C; 210 | Lambda2 = Lambda2old + rho * diff; 211 | 212 | error[0] = norm(diff, "fro") / sqrt(p * K / 1.0); 213 | error[1] = norm(C - Cold, "fro") / sqrt(p * K / 1.0); 214 | 215 | if(max(error) <= tol) 216 | break; 217 | Cold = C; 218 | Lambda2old = Lambda2; 219 | } 220 | iter++; 221 | return(Phi); 222 | } 223 | 224 | void spatpcaCore3( 225 | const arma::mat tempinv, 226 | arma::mat& Phi, 227 | arma::mat& R, 228 | arma::mat& C, 229 | arma::mat& Lambda1, 230 | arma::mat& Lambda2, 231 | const double tau2, 232 | double rho, 233 | const int maxit, 234 | const double tol) { 235 | 236 | const int p = Phi.n_rows, K = Phi.n_cols; 237 | arma::mat temp, U, V, difference_Phi_R, difference_Phi_C; 238 | arma::mat Rold = R, Cold = C, Lambda1old = Lambda1, Lambda2old = Lambda2; 239 | arma::vec S; 240 | arma::vec err(4, arma::fill::zeros); // indices 0..3 241 | 242 | const arma::mat zero(p, K, arma::fill::zeros); 243 | const arma::mat one (p, K, arma::fill::ones); 244 | const arma::mat scaled_tau2 = (tau2 / rho) * one; 245 | 246 | for (int iter = 0; iter < maxit; ++iter) { 247 | Phi = 0.5 * tempinv * (rho * (Rold + Cold) - (Lambda1old + Lambda2old)); 248 | R = arma::sign(Lambda1old / rho + Phi) % 249 | arma::max(zero, arma::abs(Lambda1old / rho + Phi) - scaled_tau2); 250 | 251 | temp = Phi + Lambda2old / rho; 252 | arma::svd_econ(U, S, V, temp); 253 | C = U.cols(0, V.n_cols - 1) * V.t(); 254 | 255 | difference_Phi_R = Phi - R; 256 | difference_Phi_C = Phi - C; 257 | Lambda1 = Lambda1old + rho * difference_Phi_R; 258 | Lambda2 = Lambda2old + rho * difference_Phi_C; 259 | 260 | const double denom = std::sqrt(double(p) * double(K)); 261 | err[0] = arma::norm(difference_Phi_R, "fro") / denom; 262 | err[1] = arma::norm(R - Rold, "fro") / denom; 263 | err[2] = arma::norm(difference_Phi_C, "fro") / denom; 264 | err[3] = arma::norm(C - Cold, "fro") / denom; 265 | 266 | if (err.max() <= tol) break; 267 | 268 | Rold = R; Cold = C; Lambda1old = Lambda1; Lambda2old = Lambda2; 269 | } 270 | } 271 | 272 | struct spatpcaCVPhi { 273 | const mat& Y; 274 | int K; 275 | const mat& Omega; 276 | const vec& tau1; 277 | const vec& nk; 278 | int maxit; 279 | double tol; 280 | mat& output; 281 | cube& gram_matrix_Y_train; 282 | cube& Phi_cv; 283 | cube& Lambd2_cv; 284 | mat& rho; 285 | spatpcaCVPhi( 286 | const mat& Y, 287 | int K, 288 | const mat& Omega, 289 | const vec& tau1, 290 | const vec& nk, 291 | int maxit, 292 | double tol, 293 | mat& output, 294 | cube& gram_matrix_Y_train, 295 | cube& Phi_cv, 296 | cube& Lambd2_cv, 297 | mat& rho): 298 | Y(Y), 299 | K(K), 300 | Omega(Omega), 301 | tau1(tau1), 302 | nk(nk), 303 | maxit(maxit), 304 | tol(tol), 305 | output(output), 306 | gram_matrix_Y_train(gram_matrix_Y_train), 307 | Phi_cv(Phi_cv), 308 | Lambd2_cv(Lambd2_cv), 309 | rho(rho) 310 | {} 311 | 312 | void operator()(std::size_t begin, std::size_t end) { 313 | mat Ip; 314 | Ip.eye(Y.n_cols, Y.n_cols); 315 | for(std::size_t k = begin; k < end; k++) { 316 | mat svd_U, Phi_old, Phi,C, Lambda2; 317 | vec singular_value; 318 | mat Y_train = Y.rows(find(nk != (k + 1))); 319 | mat Y_validation = Y.rows(find(nk == (k + 1))); 320 | 321 | svd_econ(svd_U, singular_value, Phi_old, Y_train, "right"); 322 | rho(k, 0) = 10 * pow(singular_value[0], 2.0); 323 | 324 | Phi_cv.slice(k) = Phi_old.cols(0, K - 1); 325 | Phi = C = Phi_cv.slice(k); 326 | Lambda2 = Lambd2_cv.slice(k) = Phi * (diagmat(rho(k, 0) - 1 / (rho(k, 0) - 2 * pow(singular_value.subvec(0, K - 1), 2)))); 327 | output(k, 0) = pow(norm(Y_validation * (Ip - (Phi_cv.slice(k)) * (Phi_cv.slice(k)).t()), "fro"), 2.0); 328 | gram_matrix_Y_train.slice(k) = Y_train.t() * Y_train; 329 | for(uword i = 1; i < tau1.n_elem; i++) { 330 | spatpcaCore2(gram_matrix_Y_train.slice(k), Phi, C, Lambda2, Omega, tau1[i], rho(k, 0), maxit, tol); 331 | output(k, i) = pow(norm(Y_validation * (Ip - Phi * Phi.t()), "fro"), 2.0); 332 | } 333 | } 334 | } 335 | }; 336 | 337 | struct spatpcaCVPhi2 { 338 | const mat& Y; 339 | const cube& gram_matrix_Y_train; 340 | cube& Phi_cv; 341 | cube& Lambd2_cv; 342 | const mat& rho; 343 | int K; 344 | double tau1; 345 | const mat& Omega; 346 | const vec& tau2; 347 | const vec& nk; 348 | int maxit; 349 | double tol; 350 | mat& output; 351 | cube& tempinv; 352 | 353 | spatpcaCVPhi2( 354 | const mat& Y, 355 | const cube& gram_matrix_Y_train, 356 | cube& Phi_cv, 357 | cube& Lambd2_cv, 358 | const mat& rho, 359 | int K, 360 | double tau1, 361 | const mat& Omega, 362 | const vec& tau2, 363 | const vec& nk, 364 | int maxit, 365 | double tol, 366 | mat& output, 367 | cube& tempinv): 368 | Y(Y), 369 | gram_matrix_Y_train(gram_matrix_Y_train), 370 | Phi_cv(Phi_cv), 371 | Lambd2_cv(Lambd2_cv), 372 | rho(rho), 373 | K(K), 374 | tau1(tau1), 375 | Omega(Omega), 376 | tau2(tau2), 377 | nk(nk), 378 | maxit(maxit), 379 | tol(tol), 380 | output(output), 381 | tempinv(tempinv) 382 | {} 383 | 384 | void operator()(std::size_t begin, std::size_t end) { 385 | for(std::size_t k = begin; k < end; k++) { 386 | mat Phi, R, C, Lambda1,Ip, Lambda2; 387 | mat Y_validation = Y.rows(find(nk == (k + 1))); 388 | Ip.eye(Y.n_cols, Y.n_cols); 389 | Phi = C = Phi_cv.slice(k); 390 | Lambda1 = 0 * Phi_cv.slice(k); 391 | Lambda2 = Lambd2_cv.slice(k); 392 | if(tau1 != 0) 393 | spatpcaCore2(gram_matrix_Y_train.slice(k), Phi,C, Lambda2, Omega, tau1, rho(k, 0), maxit, tol); 394 | R = Phi; 395 | Phi_cv.slice(k) = Phi; 396 | Lambd2_cv.slice(k) = Lambda2; 397 | tempinv.slice(k) = inv_sympd(symmatu((tau1 * Omega) - gram_matrix_Y_train.slice(k) + (rho(k, 0) * Ip))); 398 | for(uword i = 0; i < tau2.n_elem; i++) { 399 | spatpcaCore3(tempinv.slice(k), Phi, R, C, Lambda1, Lambda2, tau2[i], rho(k, 0), maxit, tol); 400 | output(k, i) = pow(norm(Y_validation * (Ip - Phi * Phi.t()), "fro"), 2.0); 401 | } 402 | } 403 | } 404 | }; 405 | 406 | struct spatpcaCVPhi3 { 407 | const mat& Y; 408 | const cube& gram_matrix_Y_train; 409 | const cube& Phi_cv; 410 | const cube& Lambd2_cv; 411 | const mat& rho; 412 | const cube& tempinv; 413 | const uword index; 414 | int K; 415 | const mat& Omega; 416 | const double tau1; 417 | const vec& tau2; 418 | const vec& gamma; 419 | const vec& nk; 420 | int maxit; 421 | double tol; 422 | mat& output; 423 | 424 | spatpcaCVPhi3( 425 | const mat& Y, 426 | const cube& gram_matrix_Y_train, 427 | const cube& Phi_cv, 428 | const cube& Lambd2_cv, 429 | const mat& rho, 430 | const cube& tempinv, 431 | const uword index, 432 | int K, 433 | const mat& Omega, 434 | const double tau1, 435 | const vec& tau2, 436 | const vec& gamma, 437 | const vec& nk, 438 | int maxit, 439 | double tol, 440 | mat& output): 441 | Y(Y), 442 | gram_matrix_Y_train(gram_matrix_Y_train), 443 | Phi_cv(Phi_cv), 444 | Lambd2_cv(Lambd2_cv), 445 | rho(rho), 446 | tempinv(tempinv), 447 | index(index), 448 | K(K), 449 | Omega(Omega), 450 | tau1(tau1), 451 | tau2(tau2), 452 | gamma(gamma), 453 | nk(nk), 454 | maxit(maxit), 455 | tol(tol), 456 | output(output) 457 | {} 458 | 459 | void operator()(std::size_t begin, std::size_t end) { 460 | for(std::size_t k = begin; k < end; k++) { 461 | int p = Y.n_cols, tempL, K; 462 | mat Phi, C, Ip, Lambda2; 463 | mat transformed_eigenvectors, decreasing_transformed_eigenvectors, covariance_mtraix_train, covariance_mtraix_validation, estimated_covariance, eigenvalue; 464 | mat Y_validation = Y.rows(find(nk == (k + 1))); 465 | vec transformed_eigenvalues, decreasing_transformed_eigenvalues, one_vector, zero_vector, cv; 466 | double total_variance, error, temp, total_transformed_eigenvalues, previous_total_transformed_eigenvalues; 467 | 468 | Ip.eye(Y.n_cols, Y.n_cols); 469 | Phi = C = Phi_cv.slice(k); 470 | K = Phi.n_cols; 471 | Lambda2 = Lambd2_cv.slice(k); 472 | 473 | if(max(tau2) != 0 || max(tau1) != 0) { 474 | if(tau2.n_elem == 1) { 475 | spatpcaCore2(gram_matrix_Y_train.slice(k), Phi, C, Lambda2, Omega, tau1, rho(k, 0), maxit, tol); 476 | } 477 | else { 478 | mat R = Phi; 479 | mat Lambda1 = 0 * Phi_cv.slice(k); 480 | for(uword i = 0; i <= index; i++) { 481 | spatpcaCore3(tempinv.slice(k), Phi, R, C, Lambda1, Lambda2, tau2[i], rho(k, 0), maxit, tol); 482 | } 483 | } 484 | } 485 | else { 486 | Phi = Phi_cv.slice(k); 487 | } 488 | 489 | covariance_mtraix_train = gram_matrix_Y_train.slice(k) / (Y.n_rows - Y_validation.n_rows); 490 | covariance_mtraix_validation = trans(Y_validation) * Y_validation / Y_validation.n_rows; 491 | total_variance = trace(covariance_mtraix_train); 492 | eig_sym(transformed_eigenvalues, transformed_eigenvectors, trans(Phi) * covariance_mtraix_train * Phi); 493 | previous_total_transformed_eigenvalues = accu(transformed_eigenvalues); 494 | decreasing_transformed_eigenvalues = sort(transformed_eigenvalues,"descend"); 495 | decreasing_transformed_eigenvectors = transformed_eigenvectors.cols(sort_index(transformed_eigenvalues,"descend")); 496 | one_vector.ones(decreasing_transformed_eigenvalues.n_elem); 497 | zero_vector.zeros(decreasing_transformed_eigenvalues.n_elem); 498 | 499 | for(int gj = 0; gj < gamma.n_elem; gj++) { 500 | total_transformed_eigenvalues = previous_total_transformed_eigenvalues; 501 | tempL = K; 502 | if(decreasing_transformed_eigenvalues[0] > gamma[gj]) { 503 | error = (total_variance - total_transformed_eigenvalues + K * gamma[gj]) / (p - tempL); 504 | temp = decreasing_transformed_eigenvalues[tempL - 1]; 505 | while(temp - gamma[gj] < error) { 506 | if(tempL == 1) { 507 | error = (total_variance - decreasing_transformed_eigenvalues[0] + gamma[gj]) / (p - 1); 508 | break; 509 | } 510 | total_transformed_eigenvalues -= decreasing_transformed_eigenvalues[tempL - 1]; 511 | tempL --; 512 | error = (total_variance - total_transformed_eigenvalues + tempL * gamma[gj]) / (p - tempL); 513 | temp = decreasing_transformed_eigenvalues[tempL - 1]; 514 | } 515 | if(decreasing_transformed_eigenvalues[0] - gamma[gj] < error) 516 | error = total_variance / p; 517 | } 518 | else 519 | error = total_variance / p; 520 | eigenvalue = max(decreasing_transformed_eigenvalues - (error + gamma[gj]) * one_vector, zero_vector); 521 | estimated_covariance = Phi * decreasing_transformed_eigenvectors * diagmat(eigenvalue) * trans(decreasing_transformed_eigenvectors) * trans(Phi); 522 | output(k, gj) = pow(norm(covariance_mtraix_validation - estimated_covariance - error * Ip, "fro"), 2.0); 523 | } 524 | } 525 | } 526 | }; 527 | 528 | //' Internal function: M-fold Cross-validation 529 | //' @keywords internal 530 | //' @param sxyr A location matrix 531 | //' @param Yr A data matrix 532 | //' @param M The number of folds for CV 533 | //' @param K The number of estimated eigen-functions 534 | //' @param tau1r A range of tau1 535 | //' @param tau2r A range of tau2 536 | //' @param gammar A range of gamma 537 | //' @param nkr A vector of fold numbers 538 | //' @param maxit A maximum number of iteration 539 | //' @param tol A tolerance rate 540 | //' @param l2r A given tau2 541 | //' @return A list of selected parameters 542 | // [[Rcpp::export]] 543 | Rcpp::List spatpcaCV(const Rcpp::NumericMatrix& sxyr, 544 | const Rcpp::NumericMatrix& Yr, 545 | int M, int K, 546 | const Rcpp::NumericVector& tau1r, 547 | const Rcpp::NumericVector& tau2r, 548 | const Rcpp::NumericVector& gammar, 549 | const Rcpp::NumericVector& nkr, 550 | int maxit, double tol, 551 | const Rcpp::NumericVector& l2r) { 552 | int n = Yr.nrow(), p = Yr.ncol(), d = sxyr.ncol(); 553 | mat Y(Yr.begin(), n, p), sxy(sxyr.begin(), p, d); 554 | colvec tau1(tau1r.begin(), tau1r.size()); 555 | colvec tau2(tau2r.begin(), tau2r.size()); 556 | colvec gamma(gammar.begin(), gammar.size()); 557 | colvec nk(nkr.begin(), nkr.size()); 558 | colvec l2(l2r.begin(), l2r.size()); 559 | mat cv(M, tau1.n_elem), cv3(M, gamma.n_elem), cv_score_tau1, cv_score_tau2, cv_score_gamma, Omega, svd_U, svd_V; 560 | double selected_tau1, selected_tau2 = 0, selected_gamma; 561 | mat gram_matrix_Y = Y.t() * Y; 562 | vec singular_value; 563 | svd_econ(svd_U, singular_value, svd_V, Y, "right"); 564 | double estimated_rho = 10 * pow(singular_value[0], 2.0); 565 | mat estimated_Phi = svd_V.cols(0, K - 1); 566 | mat estimated_C = estimated_Phi; 567 | mat estimated_Lambda2 = estimated_Phi * (diagmat(estimated_rho - 1 / (estimated_rho - 2 * pow(singular_value.subvec(0, K - 1), 2)))); 568 | mat rho_cv(M, 1); 569 | cube gram_matrix_Y_train(p, p, M), Phi_cv(p, K, M), Lambd2_cv(p, K, M), tempinv_cv(p, p, M); 570 | uword index1, index2 = 0, index3; 571 | mat Ip; 572 | Ip.eye(Y.n_cols, Y.n_cols); 573 | if(max(tau1) != 0 || max(tau2) != 0) { 574 | Omega = thinPlateSplineMatrix(sxy) + 1e-8 * Ip; 575 | } 576 | else { 577 | if(gamma.n_elem > 1) { 578 | Omega = Ip; 579 | mat Y_train, Y_validation; 580 | mat svd_U, Phi_oldg; 581 | vec singular_value; 582 | for(int k = 0; k < M; ++k) { 583 | Y_train = Y.rows(find(nk != (k + 1))); 584 | Y_validation = Y.rows(find(nk == (k + 1))); 585 | svd_econ(svd_U, singular_value, Phi_oldg, Y_train, "right"); 586 | Phi_cv.slice(k) = Phi_oldg.cols(0, K - 1); 587 | gram_matrix_Y_train.slice(k) = Y_train.t() * Y_train; 588 | } 589 | } 590 | } 591 | 592 | if(tau1.n_elem > 1) { 593 | spatpcaCVPhi worker(Y, K, Omega, tau1, nk, maxit, tol, cv, gram_matrix_Y_train, Phi_cv, Lambd2_cv, rho_cv); 594 | worker(0, M); 595 | rowvec cv_sum = sum(cv, 0); 596 | index1 = cv_sum.index_min(); 597 | selected_tau1 = tau1[index1]; 598 | if(index1 > 0) 599 | estimated_Phi = spatpcaCore2p(gram_matrix_Y, estimated_C, estimated_Lambda2, Omega, selected_tau1, estimated_rho, maxit, tol); 600 | cv_score_tau1 = sum(cv, 0) / M; 601 | } 602 | else { 603 | selected_tau1 = max(tau1); 604 | if(selected_tau1 != 0 && max(tau2) == 0) { 605 | estimated_Phi = spatpcaCore2p(gram_matrix_Y, estimated_C, estimated_Lambda2, Omega, selected_tau1, estimated_rho, maxit, tol); 606 | mat Phigg, Cgg, Lambda2gg; 607 | mat Y_validation, Y_train; 608 | mat svd_U, Phi_oldg; 609 | vec singular_value; 610 | 611 | for(int k = 0; k < M; ++k) { 612 | Y_train = Y.rows(find(nk != (k + 1))); 613 | gram_matrix_Y_train.slice(k) = Y_train.t() * Y_train; 614 | svd_econ(svd_U, singular_value, Phi_oldg, Y_train, "right"); 615 | Phigg = Cgg = Phi_oldg.cols(0, K - 1); 616 | rho_cv(k, 0) = 10 * pow(singular_value[0], 2.0); 617 | Lambda2gg = Phigg * (diagmat(rho_cv(k, 0) - 1 / (rho_cv(k, 0) - 2 * pow(singular_value.subvec(0, K - 1), 2)))); 618 | spatpcaCore2(gram_matrix_Y_train.slice(k), Phigg,Cgg, Lambda2gg, Omega, selected_tau1, rho_cv(k, 0), maxit, tol); 619 | Phi_cv.slice(k) = Phigg; 620 | Lambd2_cv.slice(k) = Lambda2gg; 621 | tempinv_cv.slice(k) = inv_sympd(symmatu((selected_tau1 * Omega) - gram_matrix_Y_train.slice(k) + (rho_cv(k, 0) * Ip))); 622 | } 623 | } 624 | else if(selected_tau1 == 0 && max(tau2) == 0) { 625 | mat svd_U2, Phi_oldc; 626 | vec singular_value2; 627 | svd_econ(svd_U2, singular_value2, Phi_oldc, Y, "right"); 628 | estimated_Phi = Phi_oldc.cols(0,K - 1); 629 | } 630 | else { 631 | mat Phigg, Cgg, Lambda2gg; 632 | mat Y_validation, Y_train; 633 | mat svd_U, Phi_oldg; 634 | vec singular_values; 635 | 636 | for(int k = 0; k < M; ++k) { 637 | Y_train = Y.rows(find(nk != (k + 1))); 638 | gram_matrix_Y_train.slice(k) = Y_train.t() * Y_train; 639 | svd_econ(svd_U, singular_values, Phi_oldg, Y_train, "right"); 640 | Phigg = Cgg = Phi_oldg.cols(0, K - 1); 641 | rho_cv(k, 0) = 10 * pow(singular_values[0], 2.0); 642 | Lambda2gg = Phigg * (diagmat(rho_cv(k, 0) - 1 / (rho_cv(k, 0) - 2 * pow(singular_value.subvec(0, K - 1), 2)))); 643 | if(selected_tau1 != 0) 644 | spatpcaCore2(gram_matrix_Y_train.slice(k), Phigg, Cgg, Lambda2gg, Omega, selected_tau1, rho_cv(k, 0), maxit, tol); 645 | Phi_cv.slice(k) = Phigg; 646 | Lambd2_cv.slice(k) = Lambda2gg; 647 | } 648 | } 649 | cv_score_tau1.zeros(1); 650 | } 651 | 652 | if(tau2.n_elem > 1) { 653 | mat cv2(M, tau2.n_elem); 654 | spatpcaCVPhi2 worker2(Y, gram_matrix_Y_train, Phi_cv, Lambd2_cv, rho_cv, K, selected_tau1, Omega, tau2, nk, maxit, tol, cv2, tempinv_cv); 655 | worker2(0, M); 656 | 657 | rowvec cv2_sum = sum(cv2, 0); 658 | index2 = cv2_sum.index_min(); 659 | selected_tau2 = tau2[index2]; 660 | 661 | mat tempinv = inv_sympd(symmatu((selected_tau1 * Omega) - gram_matrix_Y + (estimated_rho * Ip))); 662 | mat estimated_R = estimated_Phi; 663 | mat estimated_Lambda1 = 0 * estimated_Phi; 664 | 665 | for(uword i = 0; i <= index2; i++) 666 | spatpcaCore3(tempinv, estimated_Phi, estimated_R, estimated_C, estimated_Lambda1, estimated_Lambda2, tau2[i], estimated_rho, maxit, tol); 667 | 668 | cv_score_tau2 = sum(cv2, 0) / M; 669 | } 670 | else { 671 | selected_tau2 = max(tau2); 672 | if(selected_tau2 > 0) { 673 | mat tempinv = inv_sympd(symmatu((selected_tau1 * Omega) - gram_matrix_Y + (estimated_rho * Ip))); 674 | mat estimated_R= estimated_Phi; 675 | mat estimated_Lambda1 = 0 * estimated_Phi; 676 | for(uword i = 0; i < l2.n_elem; i++) 677 | spatpcaCore3(tempinv, estimated_Phi, estimated_R, estimated_C, estimated_Lambda1, estimated_Lambda2, l2[i], estimated_rho, maxit, tol); 678 | } 679 | cv_score_tau2.zeros(1); 680 | } 681 | 682 | spatpcaCVPhi3 worker3(Y, gram_matrix_Y_train, Phi_cv, Lambd2_cv, rho_cv, tempinv_cv, index2, K, Omega, selected_tau1, tau2, gamma, nk, maxit, tol, cv3); 683 | worker3(0, M); 684 | if(gamma.n_elem > 1) { 685 | rowvec cv3_sum = sum(cv3, 0); 686 | index3 = cv3_sum.index_min(); 687 | selected_gamma = gamma[index3]; 688 | } 689 | else { 690 | selected_gamma = max(gamma); 691 | } 692 | cv_score_gamma = sum(cv3, 0) / M; 693 | 694 | return List::create(Named("cv_score_tau1") = cv_score_tau1, 695 | Named("cv_score_tau2") = cv_score_tau2, 696 | Named("cv_score_gamma") = cv_score_gamma, 697 | Named("estimated_eigenfn") = estimated_Phi, 698 | Named("selected_tau1") = selected_tau1, 699 | Named("selected_tau2") = selected_tau2, 700 | Named("selected_gamma") = selected_gamma); 701 | } 702 | 703 | //' Internal function: Spatial prediction 704 | //' @keywords internal 705 | //' @param phir A matrix of estimated eigenfunctions based on original locations 706 | //' @param Yr A data matrix 707 | //' @param gamma A gamma value 708 | //' @param predicted_eignefunction A vector of values of an eigenfunction on new locations 709 | //' @return A list of objects 710 | //' \item{prediction}{A vector of spatial predictions} 711 | //' \item{estimated_covariance}{An estimated covariance matrix.} 712 | //' \item{eigenvalue}{A vector of estimated eigenvalues.} 713 | //' \item{error}{Error rate for the ADMM algorithm} 714 | // [[Rcpp::export]] 715 | Rcpp::List spatialPrediction(const Rcpp::NumericMatrix& phir, 716 | const Rcpp::NumericMatrix& Yr, 717 | double gamma, 718 | const Rcpp::NumericMatrix& predicted_eignefunction) { 719 | int n = Yr.nrow(), p = phir.nrow(), K = phir.ncol(), p2 = predicted_eignefunction.nrow() ; 720 | 721 | mat phi(phir.begin(), p, K); 722 | mat predicted_phi(predicted_eignefunction.begin(), p2, K); 723 | mat Y(Yr.begin(), n, p); 724 | 725 | mat transformed_eigenvectors, decreasing_transformed_eigenvectors; 726 | vec transformed_eigenvalues, decreasing_transformed_eigenvalues; 727 | 728 | mat cov = Y.t() * Y / n; 729 | eig_sym(transformed_eigenvalues, transformed_eigenvectors, phi.t() * cov * phi); 730 | int tempL = K; 731 | double total_variance = trace(cov); 732 | double previous_total_transformed_eigenvalues = accu(transformed_eigenvalues); 733 | double temp_v = total_variance - previous_total_transformed_eigenvalues; 734 | double error = (temp_v + K * gamma) / (p - tempL); 735 | 736 | decreasing_transformed_eigenvalues = sort(transformed_eigenvalues, "descend"); 737 | decreasing_transformed_eigenvectors = transformed_eigenvectors.cols(sort_index(transformed_eigenvalues, "descend")); 738 | double total_transformed_eigenvalues = previous_total_transformed_eigenvalues, temp; 739 | mat one_vector, zero_vector; 740 | one_vector.ones(decreasing_transformed_eigenvalues.n_elem); 741 | zero_vector.zeros(decreasing_transformed_eigenvalues.n_elem); 742 | 743 | if(decreasing_transformed_eigenvalues[0] > gamma) { 744 | error = (total_variance - total_transformed_eigenvalues + K * gamma) / (p - tempL); 745 | temp = decreasing_transformed_eigenvalues[tempL - 1]; 746 | while(temp - gamma < error) { 747 | if(tempL == 1) { 748 | error = (total_variance - decreasing_transformed_eigenvalues[0] + gamma) / (p - 1); 749 | break; 750 | } 751 | total_transformed_eigenvalues -= decreasing_transformed_eigenvalues[tempL - 1]; 752 | tempL --; 753 | error = (total_variance - total_transformed_eigenvalues + tempL * gamma) / (p - tempL); 754 | temp = decreasing_transformed_eigenvalues[tempL - 1]; 755 | } 756 | if(decreasing_transformed_eigenvalues[0] - gamma < error) 757 | error = total_variance / p; 758 | } 759 | else 760 | error = total_variance / p; 761 | 762 | vec eigenvalue = max(decreasing_transformed_eigenvalues - (error + gamma) * one_vector, zero_vector); 763 | vec eigenvalue2 = eigenvalue + error; 764 | mat estimated_covariance = phi * decreasing_transformed_eigenvectors * diagmat(eigenvalue / eigenvalue2) * trans(predicted_phi * decreasing_transformed_eigenvectors); 765 | mat prediction = Y * estimated_covariance; 766 | return List::create(Named("prediction") = prediction, 767 | Named("estimated_covariance") = estimated_covariance, 768 | Named("eigenvalue") = eigenvalue, 769 | Named("error") = error); 770 | } 771 | --------------------------------------------------------------------------------