├── logo ├── logo.png ├── SVC_image.png ├── varycoef_hex.pptx └── create_image.R ├── R-pkg ├── data │ ├── house.rda │ └── SVCdata.rda ├── tests │ ├── testthat.R │ └── testthat │ │ ├── test_SVC_selection.R │ │ ├── test_SVC_mle.R │ │ ├── test_predict-SVC_mle.R │ │ ├── test_utils.R │ │ └── test_example.R ├── R │ ├── nlocs.R │ ├── nobs-SVC_mle.R │ ├── residuals-SVC_mle.R │ ├── fitted-SVC_mle.R │ ├── eff_dof.R │ ├── print-SVC_mle.R │ ├── coef-SVC_mle.R │ ├── logLik-SVC_mle.R │ ├── BIC-SVC_mle.R │ ├── cov_par.R │ ├── objective_functions.R │ ├── data.R │ ├── varycoef.R │ ├── plot-SVC_mle.R │ ├── example.R │ ├── summary-SVC_mle.R │ ├── predict-SVC_mle.R │ ├── SVC_selection.R │ ├── utils.R │ └── SVC_mle.R ├── man │ ├── nlocs.Rd │ ├── nobs.SVC_mle.Rd │ ├── print.SVC_mle.Rd │ ├── residuals.SVC_mle.Rd │ ├── summary.SVC_mle.Rd │ ├── fitted.SVC_mle.Rd │ ├── print.summary.SVC_mle.Rd │ ├── coef.SVC_mle.Rd │ ├── cov_par.Rd │ ├── check_cov_lower.Rd │ ├── logLik.SVC_mle.Rd │ ├── IC.SVC_mle.Rd │ ├── SVCdata.Rd │ ├── SVC_selection.Rd │ ├── init_bounds_optim.Rd │ ├── GLS_chol.Rd │ ├── house.Rd │ ├── plot.SVC_mle.Rd │ ├── sample_SVCdata.Rd │ ├── predict.SVC_mle.Rd │ ├── varycoef.Rd │ ├── SVC_selection_control.Rd │ ├── SVC_mle.Rd │ └── SVC_mle_control.Rd ├── DESCRIPTION ├── inst │ └── CITATION ├── NAMESPACE └── vignettes │ └── Introduction.Rmd ├── varycoef.Rproj └── README.md /logo/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jakobdambon/varycoef/HEAD/logo/logo.png -------------------------------------------------------------------------------- /logo/SVC_image.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jakobdambon/varycoef/HEAD/logo/SVC_image.png -------------------------------------------------------------------------------- /R-pkg/data/house.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jakobdambon/varycoef/HEAD/R-pkg/data/house.rda -------------------------------------------------------------------------------- /R-pkg/tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(varycoef) 3 | 4 | test_check("varycoef") 5 | -------------------------------------------------------------------------------- /R-pkg/data/SVCdata.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jakobdambon/varycoef/HEAD/R-pkg/data/SVCdata.rda -------------------------------------------------------------------------------- /logo/varycoef_hex.pptx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jakobdambon/varycoef/HEAD/logo/varycoef_hex.pptx -------------------------------------------------------------------------------- /R-pkg/tests/testthat/test_SVC_selection.R: -------------------------------------------------------------------------------- 1 | test_that("SVC_selection error handling works", { 2 | # 3 | expect_error(SVC_selection(1, 1)) 4 | 5 | 6 | }) 7 | -------------------------------------------------------------------------------- /varycoef.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | BuildType: Package 16 | PackageUseDevtools: Yes 17 | PackageInstallArgs: --no-multiarch --with-keep.source 18 | -------------------------------------------------------------------------------- /R-pkg/R/nlocs.R: -------------------------------------------------------------------------------- 1 | #' @title Extract Number of Unique Locations 2 | #' 3 | #' @description Function to extract the number of unique locations in the data 4 | #' set used in an MLE of the \code{\link{SVC_mle}} object. 5 | #' 6 | #' @param object \code{\link{SVC_mle}} object 7 | #' 8 | #' @return integer with the number of unique locations 9 | #' 10 | #' @author Jakob Dambon 11 | #' 12 | #' 13 | #' @export 14 | nlocs <- function(object) { 15 | nrow(unique(object$MLE$call.args$locs)) 16 | } 17 | 18 | -------------------------------------------------------------------------------- /R-pkg/R/nobs-SVC_mle.R: -------------------------------------------------------------------------------- 1 | #' @title Extract Number of Observations 2 | #' 3 | #' @description Method to extract the number of observations used in MLE for an \code{\link{SVC_mle}} object. 4 | #' 5 | #' @param object \code{\link{SVC_mle}} object 6 | #' @param ... further arguments 7 | #' 8 | #' @return an integer of number of observations 9 | #' 10 | #' @author Jakob Dambon 11 | #' 12 | #' @importFrom stats nobs 13 | #' @export 14 | nobs.SVC_mle <- function(object, ...) { 15 | length(object$data$y) 16 | } 17 | 18 | -------------------------------------------------------------------------------- /logo/create_image.R: -------------------------------------------------------------------------------- 1 | library(varycoef) 2 | 3 | par(mar = rep(1, 4)) 4 | matplot( 5 | # Locations and SVCs 6 | x = SVCdata$locs, 7 | y = SVCdata$beta, 8 | # Lines 9 | type = "l", 10 | lty = 1, 11 | lwd = 8, 12 | # no labels (will follow), no box 13 | xlab = "", 14 | ylab = "", 15 | bty = "n", 16 | xaxt = "n", 17 | yaxt = "n", 18 | col = 2:3 19 | ) 20 | # Adding axis 21 | axis(1, at = 2*(0:5), lwd=4, lwd.tick=4, lab=F, cex.axis = 1.5, las = 1) 22 | axis(2, at = 0:3, lwd=4, lwd.tick=4, lab=F, cex.axis = 1.5, las = 1) 23 | -------------------------------------------------------------------------------- /R-pkg/man/nlocs.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/nlocs.R 3 | \name{nlocs} 4 | \alias{nlocs} 5 | \title{Extract Number of Unique Locations} 6 | \usage{ 7 | nlocs(object) 8 | } 9 | \arguments{ 10 | \item{object}{\code{\link{SVC_mle}} object} 11 | } 12 | \value{ 13 | integer with the number of unique locations 14 | } 15 | \description{ 16 | Function to extract the number of unique locations in the data 17 | set used in an MLE of the \code{\link{SVC_mle}} object. 18 | } 19 | \author{ 20 | Jakob Dambon 21 | } 22 | -------------------------------------------------------------------------------- /R-pkg/man/nobs.SVC_mle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/nobs-SVC_mle.R 3 | \name{nobs.SVC_mle} 4 | \alias{nobs.SVC_mle} 5 | \title{Extract Number of Observations} 6 | \usage{ 7 | \method{nobs}{SVC_mle}(object, ...) 8 | } 9 | \arguments{ 10 | \item{object}{\code{\link{SVC_mle}} object} 11 | 12 | \item{...}{further arguments} 13 | } 14 | \value{ 15 | an integer of number of observations 16 | } 17 | \description{ 18 | Method to extract the number of observations used in MLE for an \code{\link{SVC_mle}} object. 19 | } 20 | \author{ 21 | Jakob Dambon 22 | } 23 | -------------------------------------------------------------------------------- /R-pkg/man/print.SVC_mle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/print-SVC_mle.R 3 | \name{print.SVC_mle} 4 | \alias{print.SVC_mle} 5 | \title{Print Method for \code{SVC_mle}} 6 | \usage{ 7 | \method{print}{SVC_mle}(x, digits = max(3L, getOption("digits") - 3L), ...) 8 | } 9 | \arguments{ 10 | \item{x}{\code{\link{SVC_mle}} object} 11 | 12 | \item{digits}{(\code{numeric}) 13 | Number of digits to be plotted.} 14 | 15 | \item{...}{further arguments} 16 | } 17 | \description{ 18 | Method to print an \code{\link{SVC_mle}} object. 19 | } 20 | \author{ 21 | Jakob Dambon 22 | } 23 | -------------------------------------------------------------------------------- /R-pkg/R/residuals-SVC_mle.R: -------------------------------------------------------------------------------- 1 | #' @title Extact Model Residuals 2 | #' 3 | #' @description Method to extract the residuals from an \code{\link{SVC_mle}} 4 | #' object. This is only possible if \code{save.fitted} was set to \code{TRUE}. 5 | #' 6 | #' @param object \code{\link{SVC_mle}} object 7 | #' @param ... further arguments 8 | #' 9 | #' @return (\code{numeric(n)}) 10 | #' Residuals of model 11 | #' 12 | #' @author Jakob Dambon 13 | #' 14 | #' @importFrom stats residuals resid 15 | #' @export 16 | residuals.SVC_mle <- function(object, ...) { 17 | stopifnot(!is.null(object$residuals)) 18 | return(object$residuals) 19 | } 20 | 21 | -------------------------------------------------------------------------------- /R-pkg/man/residuals.SVC_mle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/residuals-SVC_mle.R 3 | \name{residuals.SVC_mle} 4 | \alias{residuals.SVC_mle} 5 | \title{Extact Model Residuals} 6 | \usage{ 7 | \method{residuals}{SVC_mle}(object, ...) 8 | } 9 | \arguments{ 10 | \item{object}{\code{\link{SVC_mle}} object} 11 | 12 | \item{...}{further arguments} 13 | } 14 | \value{ 15 | (\code{numeric(n)}) 16 | Residuals of model 17 | } 18 | \description{ 19 | Method to extract the residuals from an \code{\link{SVC_mle}} 20 | object. This is only possible if \code{save.fitted} was set to \code{TRUE}. 21 | } 22 | \author{ 23 | Jakob Dambon 24 | } 25 | -------------------------------------------------------------------------------- /R-pkg/R/fitted-SVC_mle.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title Extact Model Fitted Values 3 | #' 4 | #' @description Method to extract the fitted values from an \code{\link{SVC_mle}} object. This is only possible if \code{save.fitted} was set to \code{TRUE} in the control of the function call 5 | #' 6 | #' @param object \code{\link{SVC_mle}} object 7 | #' @param ... further arguments 8 | #' 9 | #' @return Data frame, fitted values to given data, i.e., the SVC as well as the response and their locations 10 | #' 11 | #' @author Jakob Dambon 12 | #' 13 | #' @importFrom stats fitted 14 | #' @export 15 | fitted.SVC_mle <- function(object, ...) { 16 | stopifnot(!is.null(object$fitted)) 17 | return(object$fitted) 18 | } 19 | 20 | -------------------------------------------------------------------------------- /R-pkg/man/summary.SVC_mle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/summary-SVC_mle.R 3 | \name{summary.SVC_mle} 4 | \alias{summary.SVC_mle} 5 | \title{Summary Method for \code{SVC_mle}} 6 | \usage{ 7 | \method{summary}{SVC_mle}(object, ...) 8 | } 9 | \arguments{ 10 | \item{object}{\code{\link{SVC_mle}} object} 11 | 12 | \item{...}{further arguments} 13 | } 14 | \value{ 15 | object of class \code{summary.SVC_mle} with summarized values of the MLE. 16 | } 17 | \description{ 18 | Method to construct a \code{summary.SVC_mle} object out of a 19 | \code{\link{SVC_mle}} object. 20 | } 21 | \seealso{ 22 | \code{\link{SVC_mle}} 23 | } 24 | \author{ 25 | Jakob Dambon 26 | } 27 | -------------------------------------------------------------------------------- /R-pkg/man/fitted.SVC_mle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fitted-SVC_mle.R 3 | \name{fitted.SVC_mle} 4 | \alias{fitted.SVC_mle} 5 | \title{Extact Model Fitted Values} 6 | \usage{ 7 | \method{fitted}{SVC_mle}(object, ...) 8 | } 9 | \arguments{ 10 | \item{object}{\code{\link{SVC_mle}} object} 11 | 12 | \item{...}{further arguments} 13 | } 14 | \value{ 15 | Data frame, fitted values to given data, i.e., the SVC as well as the response and their locations 16 | } 17 | \description{ 18 | Method to extract the fitted values from an \code{\link{SVC_mle}} object. This is only possible if \code{save.fitted} was set to \code{TRUE} in the control of the function call 19 | } 20 | \author{ 21 | Jakob Dambon 22 | } 23 | -------------------------------------------------------------------------------- /R-pkg/man/print.summary.SVC_mle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/summary-SVC_mle.R 3 | \name{print.summary.SVC_mle} 4 | \alias{print.summary.SVC_mle} 5 | \title{Printing Method for \code{summary.SVC_mle}} 6 | \usage{ 7 | \method{print}{summary.SVC_mle}(x, digits = max(3L, getOption("digits") - 3L), ...) 8 | } 9 | \arguments{ 10 | \item{x}{\code{\link{summary.SVC_mle}}} 11 | 12 | \item{digits}{the number of significant digits to use when printing.} 13 | 14 | \item{...}{further arguments} 15 | } 16 | \value{ 17 | The printed output of the summary in the console. 18 | } 19 | \description{ 20 | Printing Method for \code{summary.SVC_mle} 21 | } 22 | \seealso{ 23 | \link{summary.SVC_mle} \link{SVC_mle} 24 | } 25 | -------------------------------------------------------------------------------- /R-pkg/man/coef.SVC_mle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/coef-SVC_mle.R 3 | \name{coef.SVC_mle} 4 | \alias{coef.SVC_mle} 5 | \alias{coef.SVC_selection} 6 | \title{Extact Mean Effects} 7 | \usage{ 8 | \method{coef}{SVC_mle}(object, ...) 9 | 10 | \method{coef}{SVC_selection}(object, ...) 11 | } 12 | \arguments{ 13 | \item{object}{\code{\link{SVC_mle}} or \code{\link{SVC_selection}} object} 14 | 15 | \item{...}{further arguments} 16 | } 17 | \value{ 18 | named vector with mean effects, i.e. \eqn{\mu} from 19 | \code{\link[varycoef]{SVC_mle}} 20 | } 21 | \description{ 22 | Method to extract the mean effects from an \code{\link{SVC_mle}} 23 | or \code{\link{SVC_selection}} object. 24 | } 25 | \author{ 26 | Jakob Dambon 27 | } 28 | -------------------------------------------------------------------------------- /R-pkg/R/eff_dof.R: -------------------------------------------------------------------------------- 1 | tr <- function(A) { 2 | # computes the trace of a matrix 3 | sum(diag(A)) 4 | } 5 | 6 | 7 | eff_dof <- function(cov.par, X, cov_func, outer.W, taper) { 8 | 9 | n <- nrow(X) 10 | p <- length(outer.W) 11 | nug.var <- cov.par[length(cov.par)] 12 | Sigma <- Sigma_y(cov.par, cov_func, outer.W, taper) 13 | 14 | iSigma <- solve(Sigma) 15 | 16 | XtiS <- crossprod(X, iSigma) 17 | 18 | # trace of hat matrix (equation 15 in Mueller et al. 2013, Stat. Sci.) 19 | as.numeric(nug.var * tr(solve(XtiS %*% X) %*% XtiS %*% iSigma %*% X) + 20 | n - nug.var * tr(iSigma)) 21 | } 22 | 23 | tr_Sigma <- function(cov.par, X, cov_func, outer.W, taper) { 24 | 25 | n <- nrow(X) 26 | nug.var <- tail(cov.par, 1) 27 | p <- length(outer.W) 28 | 29 | 30 | tr(Sigma_y(cov.par, cov_func, outer.W, taper)) - nug.var*n 31 | } 32 | 33 | -------------------------------------------------------------------------------- /R-pkg/R/print-SVC_mle.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title Print Method for \code{SVC_mle} 3 | #' 4 | #' @description Method to print an \code{\link{SVC_mle}} object. 5 | #' 6 | #' @param x \code{\link{SVC_mle}} object 7 | #' @param digits (\code{numeric}) 8 | #' Number of digits to be plotted. 9 | #' @param ... further arguments 10 | #' 11 | #' @author Jakob Dambon 12 | #' 13 | #' @method print SVC_mle 14 | #' @export 15 | print.SVC_mle <- function(x, digits = max(3L, getOption("digits") - 3L), ...) { 16 | 17 | cat("\nCall:\n", paste(deparse(x$call), sep = "\n", collapse = "\n"), 18 | "\n\n", sep = "") 19 | 20 | cat("Coefficients of fixed effects:\n") 21 | print.default(format(coef(x), digits = digits), print.gap = 2L, 22 | quote = FALSE) 23 | 24 | cat("\n\nCovaraiance parameters of the SVC(s):\n") 25 | print.default(format(cov_par(x), digits = digits), print.gap = 2L, 26 | quote = FALSE) 27 | 28 | cat("\n") 29 | invisible(x) 30 | 31 | } 32 | -------------------------------------------------------------------------------- /R-pkg/man/cov_par.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/cov_par.R 3 | \name{cov_par} 4 | \alias{cov_par} 5 | \alias{cov_par.SVC_mle} 6 | \alias{cov_par.SVC_selection} 7 | \title{Extact Covariance Parameters} 8 | \usage{ 9 | cov_par(...) 10 | 11 | \method{cov_par}{SVC_mle}(object, ...) 12 | 13 | \method{cov_par}{SVC_selection}(object, ...) 14 | } 15 | \arguments{ 16 | \item{...}{further arguments} 17 | 18 | \item{object}{\code{\link{SVC_mle}} or \code{\link{SVC_selection}} object} 19 | } 20 | \value{ 21 | vector with covariance parameters with the following attributes: 22 | \itemize{ 23 | \item \code{"GRF"}, charachter, describing the covariance function used for 24 | the GP, see \code{\link{SVC_mle_control}}. 25 | \item \code{"tapering"}, either \code{NULL} if no tapering is applied of 26 | the taper range. 27 | } 28 | } 29 | \description{ 30 | Function to extract the covariance parameters from an 31 | \code{\link{SVC_mle}} or \code{\link{SVC_selection}}object. 32 | } 33 | \author{ 34 | Jakob Dambon 35 | } 36 | -------------------------------------------------------------------------------- /R-pkg/man/check_cov_lower.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \name{check_cov_lower} 4 | \alias{check_cov_lower} 5 | \title{Check Lower Bound of Covariance Parameters} 6 | \usage{ 7 | check_cov_lower(cv, q) 8 | } 9 | \arguments{ 10 | \item{cv}{(\code{numeric(2*q+1)}) \cr Covariance vector of SVC model.} 11 | 12 | \item{q}{(\code{numeric(1)}) \cr Integer indicating the number of SVCs.} 13 | } 14 | \value{ 15 | \code{logical(1)} with \code{TRUE} if all conditions above are 16 | fulfilled. 17 | } 18 | \description{ 19 | Ensures that the covariance parameters define a positive definite covariance 20 | matrix. It takes the vector 21 | \eqn{(\rho_1, \sigma^2_1, ..., \rho_q, \sigma^2_q, \tau^2)} and checks if 22 | all \eqn{\rho_k>0}, all \eqn{\sigma_k^2>=0}, and \eqn{\tau^2>0}. 23 | } 24 | \examples{ 25 | # first one is true, all other are false 26 | check_cov_lower(c(0.1, 0, 0.2, 1, 0.2), q = 2) 27 | check_cov_lower(c(0 , 0, 0.2, 1, 0.2), q = 2) 28 | check_cov_lower(c(0.1, 0, 0.2, 1, 0 ), q = 2) 29 | check_cov_lower(c(0.1, 0, 0.2, -1, 0 ), q = 2) 30 | } 31 | -------------------------------------------------------------------------------- /R-pkg/man/logLik.SVC_mle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/logLik-SVC_mle.R 3 | \name{logLik.SVC_mle} 4 | \alias{logLik.SVC_mle} 5 | \title{Extact the Likelihood} 6 | \usage{ 7 | \method{logLik}{SVC_mle}(object, ...) 8 | } 9 | \arguments{ 10 | \item{object}{\code{\link{SVC_mle}} object} 11 | 12 | \item{...}{further arguments} 13 | } 14 | \value{ 15 | an object of class \code{logLik} with attributes 16 | \itemize{ 17 | \item \code{"penalized"}, logical, if the likelihood (\code{FALSE}) or some penalized likelihood (\code{TRUE}) was optimized. 18 | \item \code{"profileLik"}, logical, if the optimization was done using the profile likelihood (\code{TRUE}) or not. 19 | \item \code{"nobs"}, integer of number of observations 20 | \item \code{"df"}, integer of how many parameters were estimated. \strong{Note}: This includes only the covariance parameters if the profile likelihood was used. 21 | } 22 | } 23 | \description{ 24 | Method to extract the computed (penalized) log (profile) Likelihood from an \code{\link{SVC_mle}} object. 25 | } 26 | \author{ 27 | Jakob Dambon 28 | } 29 | -------------------------------------------------------------------------------- /R-pkg/R/coef-SVC_mle.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title Extact Mean Effects 3 | #' 4 | #' @description Method to extract the mean effects from an \code{\link{SVC_mle}} 5 | #' or \code{\link{SVC_selection}} object. 6 | #' 7 | #' @param object \code{\link{SVC_mle}} or \code{\link{SVC_selection}} object 8 | #' @param ... further arguments 9 | #' 10 | #' @return named vector with mean effects, i.e. \eqn{\mu} from 11 | #' \code{\link[varycoef]{SVC_mle}} 12 | #' 13 | #' @author Jakob Dambon 14 | #' 15 | #' @importFrom stats coef 16 | #' @export 17 | coef.SVC_mle <- function(object, ...) { 18 | mu <- as.numeric(object$coefficients) 19 | 20 | X.vars <- colnames(object$data$X) 21 | 22 | names(mu) <- if (is.null(X.vars)) { 23 | paste0("Var", 1:length(mu)) 24 | } else { 25 | X.vars 26 | } 27 | 28 | mu 29 | } 30 | 31 | #' @rdname coef.SVC_mle 32 | #' @importFrom stats coef na.omit 33 | #' @export 34 | coef.SVC_selection <- function(object, ...) { 35 | mu <- as.numeric(tail(na.omit(object$PMLE_pars$mu.par), 1)) 36 | 37 | X.vars <- colnames(object$obj.fun$args$X) 38 | 39 | names(mu) <- if (is.null(X.vars)) { 40 | paste0("Var", 1:length(mu)) 41 | } else { 42 | X.vars 43 | } 44 | 45 | mu 46 | } 47 | -------------------------------------------------------------------------------- /R-pkg/man/IC.SVC_mle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/BIC-SVC_mle.R 3 | \name{IC.SVC_mle} 4 | \alias{IC.SVC_mle} 5 | \alias{BIC.SVC_mle} 6 | \alias{AIC.SVC_mle} 7 | \title{Conditional Akaike's and Bayesian Information Criteria} 8 | \usage{ 9 | \method{BIC}{SVC_mle}(object, ...) 10 | 11 | \method{AIC}{SVC_mle}(object, conditional = "BW", ...) 12 | } 13 | \arguments{ 14 | \item{object}{\code{\link{SVC_mle}} object} 15 | 16 | \item{...}{further arguments} 17 | 18 | \item{conditional}{string. If \code{conditional = "BW"}, the 19 | conditional AIC is calculated.} 20 | } 21 | \value{ 22 | numeric, value of information criteria 23 | } 24 | \description{ 25 | Methods to calculate information criteria for 26 | \code{\link{SVC_mle}} objects. Currently, two are supported: the conditional 27 | Akaike's Information Criteria \eqn{cAIC = -2*log-likelihood + 2*(edof + df)} 28 | and the Bayesian Information Criteria \eqn{BIC = -2*log-likelihood + log(n) * npar}. 29 | Note that the Akaike's Information Criteria is of the corrected form, that 30 | is: \eqn{edof} is the effective degrees of freedom which is derived as the 31 | trace of the hat matrices and df is the degree of freedoms with respect to 32 | mean parameters. 33 | } 34 | \author{ 35 | Jakob Dambon 36 | } 37 | -------------------------------------------------------------------------------- /R-pkg/R/logLik-SVC_mle.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | #' @title Extact the Likelihood 4 | #' 5 | #' @description Method to extract the computed (penalized) log (profile) Likelihood from an \code{\link{SVC_mle}} object. 6 | #' 7 | #' @param object \code{\link{SVC_mle}} object 8 | #' @param ... further arguments 9 | #' 10 | #' @return an object of class \code{logLik} with attributes 11 | #' \itemize{ 12 | #' \item \code{"penalized"}, logical, if the likelihood (\code{FALSE}) or some penalized likelihood (\code{TRUE}) was optimized. 13 | #' \item \code{"profileLik"}, logical, if the optimization was done using the profile likelihood (\code{TRUE}) or not. 14 | #' \item \code{"nobs"}, integer of number of observations 15 | #' \item \code{"df"}, integer of how many parameters were estimated. \strong{Note}: This includes only the covariance parameters if the profile likelihood was used. 16 | #' } 17 | #' 18 | #' @author Jakob Dambon 19 | #' 20 | #' @importFrom stats logLik 21 | #' @export 22 | logLik.SVC_mle <- function(object, ...) { 23 | 24 | profLik <- object$MLE$call.args$control$profileLik 25 | 26 | # we transform from neg2LL to LL 27 | val <- (-1/2) * as.numeric(object$MLE$optim.output$value) 28 | attr(val, "penalized") <- (!is.null(object$MLE$call.args$control$pc.prior)) 29 | attr(val, "profileLik") <- profLik 30 | attr(val, "nobs") <- nobs(object) 31 | attr(val, "df") <- object$df$df 32 | class(val) <- "logLik" 33 | val 34 | } 35 | -------------------------------------------------------------------------------- /R-pkg/R/BIC-SVC_mle.R: -------------------------------------------------------------------------------- 1 | #' @title Conditional Akaike's and Bayesian Information Criteria 2 | #' 3 | #' @name IC.SVC_mle 4 | #' @aliases AIC.SVC_mle 5 | #' 6 | #' @description Methods to calculate information criteria for 7 | #' \code{\link{SVC_mle}} objects. Currently, two are supported: the conditional 8 | #' Akaike's Information Criteria \eqn{cAIC = -2*log-likelihood + 2*(edof + df)} 9 | #' and the Bayesian Information Criteria \eqn{BIC = -2*log-likelihood + log(n) * npar}. 10 | #' Note that the Akaike's Information Criteria is of the corrected form, that 11 | #' is: \eqn{edof} is the effective degrees of freedom which is derived as the 12 | #' trace of the hat matrices and df is the degree of freedoms with respect to 13 | #' mean parameters. 14 | #' 15 | #' @param object \code{\link{SVC_mle}} object 16 | #' @param ... further arguments 17 | #' 18 | #' @return numeric, value of information criteria 19 | #' 20 | #' @author Jakob Dambon 21 | #' @importFrom stats BIC 22 | #' @export 23 | BIC.SVC_mle <- function(object, ...) { 24 | as.numeric( 25 | -2*logLik(object) + 26 | log(nobs(object)) * 27 | object$df$df 28 | ) 29 | } 30 | 31 | 32 | #' @rdname IC.SVC_mle 33 | #' @param conditional string. If \code{conditional = "BW"}, the 34 | #' conditional AIC is calculated. 35 | #' 36 | #' @importFrom stats AIC 37 | #' @export 38 | AIC.SVC_mle <- function(object, conditional = "BW", ...) { 39 | as.numeric( 40 | -2*logLik(object) + 41 | 2*(object$df$edof + object$df$df) 42 | ) 43 | } 44 | 45 | -------------------------------------------------------------------------------- /R-pkg/tests/testthat/test_SVC_mle.R: -------------------------------------------------------------------------------- 1 | test_that("SVC_mle call creates correct objects", { 2 | ## ---- toy example ---- 3 | ## We use the sampled, i.e., onde dimensional SVCs 4 | data(SVCdata) 5 | # sub-sample data to have feasible run time for example 6 | set.seed(123) 7 | id <- sample(length(SVCdata$locs), 50) 8 | 9 | ## SVC_mle call with matrix arguments 10 | 11 | # Test on the side: Internally, the spam.trivalues option is set to TRUE. 12 | # We check that it is set back to the original value after the call. 13 | options(spam.trivalues = FALSE) 14 | expect_identical(FALSE, getOption("spam.trivalues")) 15 | 16 | fit1 <- with(SVCdata, SVC_mle( 17 | y[id], X[id, ], locs[id], 18 | control = SVC_mle_control(profileLik = TRUE, cov.name = "mat32"))) 19 | 20 | expect_identical(FALSE, getOption("spam.trivalues")) 21 | 22 | ## SVC_mle call with formula 23 | df <- with(SVCdata, data.frame(y = y[id], X = X[id, -1])) 24 | fit2 <- SVC_mle( 25 | y ~ X, data = df, locs = SVCdata$locs[id], 26 | control = SVC_mle_control(profileLik = TRUE, cov.name = "mat32") 27 | ) 28 | 29 | ## SVC_mle call with formula 30 | df <- with(SVCdata, data.frame(y = y[id], X = X[id, -1])) 31 | fit2_2 <- SVC_mle( 32 | y ~ X, data = df, RE_formula = ~ 1, locs = SVCdata$locs[id], 33 | control = SVC_mle_control(profileLik = TRUE, cov.name = "mat32") 34 | ) 35 | 36 | expect_null(fit1$formula, fit1$RE_formula) 37 | 38 | expect_identical(fit2$formula, y ~ X) 39 | expect_identical(fit2$RE_formula, y ~ X) 40 | 41 | expect_identical(fit2_2$formula, y ~ X) 42 | expect_identical(fit2_2$RE_formula, ~ 1) 43 | }) -------------------------------------------------------------------------------- /R-pkg/tests/testthat/test_predict-SVC_mle.R: -------------------------------------------------------------------------------- 1 | test_that("prediction functions works with formula and matrix calls", { 2 | ## ---- toy example (from SVC_mle help file) ---- 3 | # We use the sampled, i.e., onde dimensional SVCs 4 | data(SVCdata) 5 | # sub-sample data to have feasible run time for example 6 | set.seed(123) 7 | id <- sample(length(SVCdata$locs), 50) 8 | 9 | ## SVC_mle call with matrix arguments 10 | fit_mat <- with(SVCdata, SVC_mle( 11 | y[id], X[id, ], locs[id], 12 | control = SVC_mle_control(profileLik = TRUE, cov.name = "mat32"))) 13 | 14 | ## SVC_mle call with formula 15 | df <- with(SVCdata, data.frame(y = y[id], X = X[id, -1])) 16 | fit_form <- SVC_mle( 17 | y ~ X, data = df, locs = SVCdata$locs[id], 18 | control = SVC_mle_control(profileLik = TRUE, cov.name = "mat32") 19 | ) 20 | 21 | ## ---- predictions ---- 22 | newdata <- data.frame(X = 3:4) 23 | newlocs <- 1:2 24 | newX <- matrix(c(1, 1, 3:4), ncol = 2) 25 | # only predicting SVC and response 26 | pred_mat <- predict(fit_mat, newX = newX, newW = newX, newlocs = newlocs) 27 | pred_form <- predict(fit_form, newdata = newdata, newlocs = newlocs) 28 | 29 | expect_equal(pred_mat, pred_form, tolerance = 1e-10) 30 | 31 | # only predicting SVCs 32 | pred_mat <- predict(fit_mat, newlocs = newlocs) 33 | pred_form <- predict(fit_form, newlocs = newlocs) 34 | 35 | expect_equal(pred_mat, pred_form, tolerance = 1e-10) 36 | # check warning for overwriting arguments 37 | expect_warning( 38 | predict(fit_form, newdata = newdata, newX = newX, newlocs = newlocs)) 39 | expect_warning( 40 | predict(fit_form, newdata = newdata, newW = newX, newlocs = newlocs)) 41 | }) -------------------------------------------------------------------------------- /R-pkg/man/SVCdata.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data.R 3 | \docType{data} 4 | \name{SVCdata} 5 | \alias{SVCdata} 6 | \title{Sampled SVC Data} 7 | \format{ 8 | A \code{list} with the following entries: 9 | \describe{ 10 | \item{y}{(\code{numeric}) Response} 11 | \item{X}{(\code{numeric}) Covariates; first columns contains ones to model 12 | an intercept, the second column contains standard-normal sampled data.} 13 | \item{beta}{(\code{numeric}) The sampled Gaussian processes, which are 14 | usually unobserved. It uses a Matern covariance function and the true 15 | parameters are given in the entry `true_pars`.} 16 | \item{eps}{(\code{numeric}) Error (or Nugget effect), i.e., drawn from a 17 | zero-mean normal distribution with 0.5 standard deviation.} 18 | \item{locs}{(\code{numeric}) Locations sampled from a uniform distribution 19 | on the interval 0 to 10.} 20 | \item{true_pars}{(\code{data.frame}) True parameters of the GP-based SVC 21 | model with Gaussian process mean, variance, and range. Additionally, the 22 | smoothness (nu) is given.} 23 | } 24 | } 25 | \usage{ 26 | SVCdata 27 | } 28 | \description{ 29 | A list object that contains sampled data of 500 observations. The data has 30 | been sampled using the \code{RandomFields} package (Schlather et al., 2015). 31 | It is given in the list object \code{SVCdata} which contains the following. 32 | } 33 | \references{ 34 | Schlather, M., Malinowski, A., Menck, P. J., Oesting, M., Strokorb, K. (2015) 35 | \emph{Analysis, simulation and prediction of multivariate random fields with package RandomFields}, 36 | Journal of Statistical Software, \doi{10.18637/jss.v063.i08} 37 | } 38 | \keyword{datasets} 39 | -------------------------------------------------------------------------------- /R-pkg/man/SVC_selection.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/SVC_selection.R 3 | \name{SVC_selection} 4 | \alias{SVC_selection} 5 | \title{SVC Model Selection} 6 | \usage{ 7 | SVC_selection(obj.fun, mle.par, control = NULL, ...) 8 | } 9 | \arguments{ 10 | \item{obj.fun}{(\code{SVC_obj_fun}) \cr 11 | Function of class \code{SVC_obj_fun}. This is the output of 12 | \code{\link{SVC_mle}} with the \code{\link{SVC_mle_control}} parameter 13 | \code{extract_fun} set to \code{TRUE}. This objective function comprises 14 | of the whole SVC model on which the selection should be applied.} 15 | 16 | \item{mle.par}{(\code{numeric(2*q+1)}) \cr 17 | Numeric vector with estimated covariance parameters of unpenalized MLE.} 18 | 19 | \item{control}{(\code{list} or \code{NULL}) \cr 20 | List of control parameters for variable selection. Output of 21 | \code{\link{SVC_selection_control}}. If \code{NULL} is given, the 22 | default values of \code{\link{SVC_selection_control}} are used.} 23 | 24 | \item{...}{Further arguments.} 25 | } 26 | \value{ 27 | Returns an object of class \code{SVC_selection}. It contains parameter estimates under PMLE and the optimization as well as choice of the shrinkage parameters. 28 | } 29 | \description{ 30 | This function implements the variable selection for 31 | Gaussian process-based SVC models using a penalized maximum likelihood 32 | estimation (PMLE, Dambon et al., 2021, ). 33 | It jointly selects the fixed and random effects of GP-based SVC models. 34 | } 35 | \references{ 36 | Dambon, J. A., Sigrist, F., Furrer, R. (2021). 37 | \emph{Joint Variable Selection of both Fixed and Random Effects for 38 | Gaussian Process-based Spatially Varying Coefficient Models}, 39 | ArXiv Preprint \url{https://arxiv.org/abs/2101.01932} 40 | } 41 | \author{ 42 | Jakob Dambon 43 | } 44 | -------------------------------------------------------------------------------- /R-pkg/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Type: Package 2 | Package: varycoef 3 | Title: Modeling Spatially Varying Coefficients 4 | Version: 0.3.5 5 | Authors@R: c( 6 | person("Jakob A.", "Dambon", , "jakob.dambon@math.ethz.ch", role = c("aut", "cre"), 7 | comment = c(ORCID = "0000-0001-5855-2017")), 8 | person("Fabio", "Sigrist", role = "ctb", 9 | comment = c(ORCID = "0000-0002-3994-2244")), 10 | person("Reinhard", "Furrer", role = "ctb", 11 | comment = c(ORCID = "0000-0002-6319-2332")) 12 | ) 13 | Description: Implements a maximum likelihood estimation (MLE) method for 14 | estimation and prediction of Gaussian process-based spatially varying 15 | coefficient (SVC) models (Dambon et al. (2021a) 16 | ). Covariance tapering (Furrer et 17 | al. (2006) ) can be applied such that 18 | the method scales to large data. Further, it implements a joint 19 | variable selection of the fixed and random effects (Dambon et al. 20 | (2021b) ). The package and its 21 | capabilities are described in (Dambon et al. (2021c) 22 | ). 23 | License: GPL-2 24 | URL: https://github.com/jakobdambon/varycoef 25 | BugReports: https://github.com/jakobdambon/varycoef/issues 26 | Depends: 27 | R (>= 3.5.0) 28 | Imports: 29 | glmnet, 30 | lhs, 31 | methods, 32 | mlr, 33 | mlrMBO, 34 | optimParallel (>= 0.8-1), 35 | ParamHelpers, 36 | pbapply, 37 | smoof, 38 | spam 39 | Suggests: 40 | DiceKriging, 41 | knitr, 42 | lattice, 43 | latticeExtra, 44 | parallel, 45 | rmarkdown, 46 | sp, 47 | spData, 48 | testthat (>= 3.0.0) 49 | Config/testthat/edition: 3 50 | Encoding: UTF-8 51 | LazyData: true 52 | RoxygenNote: 7.3.2 53 | VignetteBuilder: knitr 54 | -------------------------------------------------------------------------------- /R-pkg/tests/testthat/test_utils.R: -------------------------------------------------------------------------------- 1 | test_that("formula functions works", { 2 | x <- as.character("y~X1 + X2") 3 | f1 <- as.formula(x) 4 | f2 <- ~X1 + X2 5 | 6 | expect_false(is.formula(x)) 7 | expect_true(is.formula(f1)) 8 | 9 | # need the as.character transformation as Environment attributes of the 10 | # outputs are different 11 | expect_identical( 12 | as.character(varycoef:::drop_response(f1)), 13 | as.character(f2) 14 | ) 15 | expect_identical( 16 | as.character(varycoef:::drop_response(f2)), 17 | as.character(f2) 18 | ) 19 | }) 20 | 21 | 22 | test_that("MLE.cov.func gets the right covariance functions", { 23 | set.seed(123) 24 | x <- c(0, runif(10), 1) 25 | # covariance parameters 26 | cp <- c(2/7, 4) 27 | 28 | f <- MLE.cov.func("exp") 29 | expect_identical(f(x, theta = cp), spam::cov.exp(x, theta = cp)) 30 | 31 | f <- MLE.cov.func("mat32") 32 | expect_identical(f(x, theta = cp), spam::cov.mat(x, theta = c(cp, 3/2))) 33 | # covariance parameter length must be 2 34 | expect_error(f(x, theta = 1)) 35 | expect_error(f(x, theta = rep(1, 3))) 36 | 37 | f <- MLE.cov.func("mat52") 38 | expect_identical(f(x, theta = cp), spam::cov.mat(x, theta = c(cp, 5/2))) 39 | # covariance parameter length must be 2 40 | expect_error(f(x, theta = 1)) 41 | expect_error(f(x, theta = rep(1, 3))) 42 | 43 | f <- MLE.cov.func("sph") 44 | expect_identical(f(x, theta = cp), spam::cov.sph(x, theta = cp)) 45 | 46 | f <- MLE.cov.func("wend1") 47 | expect_identical(f(x, theta = cp), spam::cov.wend1(x, theta = cp)) 48 | 49 | f <- MLE.cov.func("wend2") 50 | expect_identical(f(x, theta = cp), spam::cov.wend2(x, theta = cp)) 51 | 52 | # for function argument should return function 53 | f2 <- function(x) x^2 54 | f <- MLE.cov.func(f2) 55 | expect_identical(f(x), f2(x)) 56 | 57 | expect_error(MLE.cov.func(2)) 58 | }) 59 | -------------------------------------------------------------------------------- /R-pkg/man/init_bounds_optim.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \name{init_bounds_optim} 4 | \alias{init_bounds_optim} 5 | \title{Setting of Optimization Bounds and Initial Values} 6 | \usage{ 7 | init_bounds_optim(control, p, q, id_obj, med_dist, y_var, OLS_mu) 8 | } 9 | \arguments{ 10 | \item{control}{(\code{\link{SVC_mle_control}} output, i.e. \code{list})} 11 | 12 | \item{p}{(\code{numeric(1)}) \cr Number of fixed effects} 13 | 14 | \item{q}{(\code{numeric(1)}) \cr Number of SVCs} 15 | 16 | \item{id_obj}{(\code{numeric(2*q+1+q)}) \cr Index vector to identify the 17 | arguments of objective function.} 18 | 19 | \item{med_dist}{(\code{numeric(1)}) \cr Median distance between observations} 20 | 21 | \item{y_var}{(\code{numeric(1)}) \cr Variance of response \code{y}} 22 | 23 | \item{OLS_mu}{(\code{numeric(p)}) \cr Coefficient estimates of ordinary 24 | least squares (OLS).} 25 | } 26 | \value{ 27 | A \code{list} with three entries: \code{lower}, \code{init}, 28 | and \code{upper}. 29 | } 30 | \description{ 31 | Sets bounds and initial values for \code{\link[stats]{optim}} by 32 | extracting potentially given values from \code{\link{SVC_mle_control}} and 33 | checking them, or calculating them from given data. See Details. 34 | } 35 | \details{ 36 | If values are not provided, then they are set in the following way. 37 | Let \eqn{d} be the median distance \code{med_dist}, let \eqn{s^2_y} be 38 | the variance of the response \code{y_var}, and let \eqn{b_j} be the OLS 39 | coefficients of the linear model. The computed values are given in the 40 | table below.\tabular{lrrr}{ 41 | Parameter \tab Lower bound \tab Initial Value \tab Upper Bound \cr 42 | Range \tab \eqn{d/1000} \tab \eqn{d/4} \tab \eqn{10 d} \cr 43 | Variance \tab \eqn{0} \tab \eqn{s^2_y/(q+1)} \tab \eqn{10s^2_y} \cr 44 | Nugget \tab \eqn{10^{-6}} \tab \eqn{s^2_y/(q+1)} \tab \eqn{10s^2_y} \cr 45 | Mean \eqn{j} \tab \code{-Inf} \tab \eqn{b_j} \tab \code{Inf} \cr 46 | } 47 | } 48 | \author{ 49 | Jakob Dambon 50 | } 51 | -------------------------------------------------------------------------------- /R-pkg/R/cov_par.R: -------------------------------------------------------------------------------- 1 | #' @title Extact Covariance Parameters 2 | #' 3 | #' @description Function to extract the covariance parameters from an 4 | #' \code{\link{SVC_mle}} or \code{\link{SVC_selection}}object. 5 | #' 6 | #' @param object \code{\link{SVC_mle}} or \code{\link{SVC_selection}} object 7 | #' @param ... further arguments 8 | #' 9 | #' @return vector with covariance parameters with the following attributes: 10 | #' \itemize{ 11 | #' \item \code{"GRF"}, charachter, describing the covariance function used for 12 | #' the GP, see \code{\link{SVC_mle_control}}. 13 | #' \item \code{"tapering"}, either \code{NULL} if no tapering is applied of 14 | #' the taper range. 15 | #' } 16 | #' 17 | #' @author Jakob Dambon 18 | #' 19 | #' 20 | #' @export 21 | cov_par <- function(...) UseMethod("cov_par") 22 | 23 | #' @rdname cov_par 24 | #' @export 25 | cov_par.SVC_mle <- function(object, ...) { 26 | covpars <- as.numeric(object$cov.par) 27 | 28 | W.vars <- colnames(object$data$W) 29 | 30 | names(covpars) <- if (is.null(W.vars)) { 31 | c(paste0(rep(paste0("SVC", 1:((length(covpars)-1)/2)), each = 2), 32 | c(".range", ".var")), "nugget.var") 33 | } else { 34 | c(paste0(rep(W.vars, each = 2), c(".range", ".var")), "nugget.var") 35 | } 36 | 37 | attr(covpars, "cov_fun") <- object$MLE$call.args$control$cov.name 38 | attr(covpars, "tapering") <- object$MLE$call.args$control$tapering 39 | 40 | covpars 41 | } 42 | 43 | 44 | #' @rdname cov_par 45 | #' @importFrom stats na.omit 46 | #' @export 47 | cov_par.SVC_selection <- function(object, ...) { 48 | covpars <- as.numeric(tail(na.omit(object$PMLE_pars$c.par), 1)) 49 | 50 | W.vars <- colnames(object$obj.fun$args$W) 51 | 52 | names(covpars) <- if (is.null(W.vars)) { 53 | c(paste0(rep(paste0("SVC", 1:((length(covpars)-1)/2)), each = 2), 54 | c(".range", ".var")), "nugget.var") 55 | } else { 56 | c(paste0(rep(W.vars, each = 2), c(".range", ".var")), "nugget.var") 57 | } 58 | 59 | attr(covpars, "cov_fun") <- attr(object$mle.par, "cov_fun") 60 | attr(covpars, "tapering") <- object$obj.fun$args$taper 61 | 62 | covpars 63 | } 64 | 65 | 66 | 67 | 68 | 69 | 70 | -------------------------------------------------------------------------------- /R-pkg/man/GLS_chol.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \name{GLS_chol} 4 | \alias{GLS_chol} 5 | \alias{GLS_chol.spam.chol.NgPeyton} 6 | \alias{GLS_chol.matrix} 7 | \title{GLS Estimate using Cholesky Factor} 8 | \usage{ 9 | GLS_chol(R, X, y) 10 | 11 | \method{GLS_chol}{spam.chol.NgPeyton}(R, X, y) 12 | 13 | \method{GLS_chol}{matrix}(R, X, y) 14 | } 15 | \arguments{ 16 | \item{R}{(\code{spam.chol.NgPeyton} or \code{matrix(n, n)}) \cr Cholesky factor of 17 | the covariance matrix \eqn{\Sigma}. If covariance tapering and sparse 18 | matrices are used, then the input is of class \code{spam.chol.NgPeyton}. 19 | Otherwise, \code{R} is the output of a standard \code{\link[base]{chol}}, 20 | i.e., a simple \code{matrix}} 21 | 22 | \item{X}{(\code{matrix(n, p)}) \cr Data / design matrix.} 23 | 24 | \item{y}{(\code{numeric(n)}) \cr Response vector} 25 | } 26 | \value{ 27 | A \code{numeric(p)} vector, i.e., the mean effects. 28 | } 29 | \description{ 30 | Computes the GLS estimate using the formula: 31 | \deqn{\mu_{GLS} = (X^\top \Sigma^{-1} X)^{-1}X^\top \Sigma^{-1} y.} 32 | The computation is done depending on the input class of the Cholesky factor 33 | \code{R}. It relies on the classical \code{\link[base]{solve}} or on 34 | using \code{forwardsolve} and \code{backsolve} functions of package 35 | \code{spam}, see \code{\link[spam]{solve}}. This is much faster than 36 | computing the inverse of \eqn{\Sigma}, especially since we have to compute 37 | the Cholesky decomposition of \eqn{\Sigma} either way. 38 | } 39 | \examples{ 40 | # generate data 41 | n <- 10 42 | X <- cbind(1, 20+1:n) 43 | y <- rnorm(n) 44 | A <- matrix(runif(n^2)*2-1, ncol=n) 45 | Sigma <- t(A) \%*\% A 46 | # two possibilities 47 | ## using standard Cholesky decomposition 48 | R_mat <- chol(Sigma); str(R_mat) 49 | mu_mat <- GLS_chol(R_mat, X, y) 50 | ## using spam 51 | R_spam <- chol(spam::as.spam(Sigma)); str(R_spam) 52 | mu_spam <- GLS_chol(R_spam, X, y) 53 | # should be identical to the following 54 | mu <- solve(crossprod(X, solve(Sigma, X))) \%*\% 55 | crossprod(X, solve(Sigma, y)) 56 | ## check 57 | abs(mu - mu_mat) 58 | abs(mu - mu_spam) 59 | } 60 | \author{ 61 | Jakob Dambon 62 | } 63 | -------------------------------------------------------------------------------- /R-pkg/man/house.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data.R 3 | \docType{data} 4 | \name{house} 5 | \alias{house} 6 | \title{Lucas County House Price Data} 7 | \format{ 8 | A data frame with 25357 rows and 25 variables: 9 | \describe{ 10 | \item{price}{(\code{integer}) selling price, in US dollars} 11 | \item{yrbuilt}{(\code{integer}) year the house was built} 12 | \item{stories}{(\code{factor}) levels are \code{"one", "bilevel", 13 | "multilvl", "one+half", "two", "two+half", "three"}} 14 | \item{TLA}{(\code{integer}) total living area, in square feet.} 15 | \item{wall}{(\code{factor}) levels are \code{"stucdrvt", "ccbtile", 16 | "metlvnyl", "brick", "stone", "wood", "partbrk"}} 17 | \item{beds, baths, halfbaths}{(\code{integer}) number of corresponding 18 | rooms / facilities.} 19 | \item{frontage, depth}{dimensions of the lot. Unit is feet.} 20 | \item{garage}{(\code{factor}) levels are \code{"no garage", "basement", 21 | "attached", "detached", "carport"}} 22 | \item{garagesqft}{(\code{integer}) garage area, in square feet. If 23 | \code{garage == "no garage"}, then \code{garagesqft == 0}.} 24 | \item{rooms}{(\code{integer}) number of rooms} 25 | \item{lotsize}{(\code{integer}) area of lot, in square feet} 26 | \item{sdate}{(\code{Date}) selling date, in format \code{yyyy-mm-dd}} 27 | \item{avalue}{(\code{int}) appraised value} 28 | \item{s1993, s1994, s1995, s1996, s1997, s1998}{(\code{int}) dummies for 29 | selling year.} 30 | \item{syear}{(\code{factor}) levels are selling years \code{"1993", "1994", 31 | "1995", "1996", "1997", "1998"}} 32 | \item{long, lat}{(\code{numeric}) location of houses. Longitude and 33 | Latitude are given in \code{CRS(+init=epsg:2834)}, the Ohio North State 34 | Plane. Units are meters.} 35 | } 36 | } 37 | \source{ 38 | \url{http://www.spatial-econometrics.com/html/jplv6.zip} 39 | } 40 | \usage{ 41 | house 42 | } 43 | \description{ 44 | A dataset containing the prices and other attributes of 25,357 houses in 45 | Lucas County, Ohio. The selling dates span years 1993 to 1998. Data taken 46 | from \code{\link[spData]{house}} (\code{spData} package) and slightly modified to a \code{data.frame}. 47 | } 48 | \keyword{datasets} 49 | -------------------------------------------------------------------------------- /R-pkg/inst/CITATION: -------------------------------------------------------------------------------- 1 | year <- sub("-.*", "", Sys.Date()) 2 | note <- sprintf("R package version %s", meta$Version) 3 | 4 | 5 | citHeader("To cite varycoef, please use one of the following:") 6 | 7 | 8 | bibentry( 9 | bibtype = "article", 10 | author = c(person("Jakob A.", "Dambon"), 11 | person("Fabio", "Sigrist"), 12 | person("Reinhard", "Furrer")), 13 | title = "Maximum Likelihood Estimation of Spatially Varying Coefficient Models for Large Data with an Application to Real Estate Price Prediction", 14 | journal = "Spatial Statistics 41 (100470)", 15 | year = "2021", 16 | url = "https://doi.org/10.1016/j.spasta.2020.100470", 17 | textVersion = "Dambon, JA., Sigrist, F., Furrer, R. (2021) Maximum Likelihood Estimation of Spatially Varying Coefficient Models for Large Data with an Application to Real Estate Price Prediction, Spatial Statistics 41 (100470)" 18 | ) 19 | 20 | 21 | 22 | bibentry( 23 | bibtype = "article", 24 | author = c(person("Jakob A.", "Dambon"), 25 | person("Fabio", "Sigrist"), 26 | person("Reinhard", "Furrer")), 27 | title = "varycoef: An R Package for Gaussian Process-based Spatially Varying Coefficient Models", 28 | journal = "ArXiv Preprint", 29 | year = "2021", 30 | url = "https://arxiv.org/abs/2106.02364", 31 | textVersion = "Dambon, JA., Sigrist, F., Furrer, R. (2021) varycoef: An R Package for Gaussian Process-based Spatially Varying Coefficient Models, ArXiv Preprint arXiv:2106.02364" 32 | ) 33 | 34 | 35 | bibentry( 36 | bibtype = "article", 37 | author = c(person("Jakob A.", "Dambon"), 38 | person("Fabio", "Sigrist"), 39 | person("Reinhard", "Furrer")), 40 | title = "Joint Variable Selection of both Fixed and Random Effects for Gaussian Process-based Spatially Varying Coefficient Models", 41 | journal = "International Journal of Geographical Information Science", 42 | year = "2021", 43 | url = "https://doi.org/10.1080/13658816.2022.2097684", 44 | textVersion = "Dambon, JA., Sigrist, F., Furrer, R. (2021) Joint Variable Selection of both Fixed and Random Effects for Gaussian Process-based Spatially Varying Coefficient Models, International Journal of Geographical Information Science" 45 | ) 46 | 47 | 48 | 49 | -------------------------------------------------------------------------------- /R-pkg/man/plot.SVC_mle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plot-SVC_mle.R 3 | \name{plot.SVC_mle} 4 | \alias{plot.SVC_mle} 5 | \title{Plotting Residuals of \code{SVC_mle} model} 6 | \usage{ 7 | \method{plot}{SVC_mle}(x, which = 1:2, ...) 8 | } 9 | \arguments{ 10 | \item{x}{(\code{\link{SVC_mle}})} 11 | 12 | \item{which}{(\code{numeric}) \cr A numeric vector and subset of 13 | \code{1:2} indicating which of the 2 plots should be plotted.} 14 | 15 | \item{...}{further arguments} 16 | } 17 | \value{ 18 | a maximum 2 plots 19 | \itemize{ 20 | \item Tukey-Anscombe plot, i.e. residuals vs. fitted 21 | \item QQ-plot 22 | } 23 | } 24 | \description{ 25 | Method to plot the residuals from an \code{\link{SVC_mle}} 26 | object. For this, \code{save.fitted} has to be \code{TRUE} in 27 | \code{\link{SVC_mle_control}}. 28 | } 29 | \examples{ 30 | #' ## ---- toy example ---- 31 | ## sample data 32 | # setting seed for reproducibility 33 | set.seed(123) 34 | m <- 7 35 | # number of observations 36 | n <- m*m 37 | # number of SVC 38 | p <- 3 39 | # sample data 40 | y <- rnorm(n) 41 | X <- matrix(rnorm(n*p), ncol = p) 42 | # locations on a regular m-by-m-grid 43 | locs <- expand.grid(seq(0, 1, length.out = m), 44 | seq(0, 1, length.out = m)) 45 | 46 | ## preparing for maximum likelihood estimation (MLE) 47 | # controls specific to MLE 48 | control <- SVC_mle_control( 49 | # initial values of optimization 50 | init = rep(0.1, 2*p+1), 51 | # using profile likelihood 52 | profileLik = TRUE 53 | ) 54 | 55 | # controls specific to optimization procedure, see help(optim) 56 | opt.control <- list( 57 | # number of iterations (set to one for demonstration sake) 58 | maxit = 1, 59 | # tracing information 60 | trace = 6 61 | ) 62 | 63 | ## starting MLE 64 | fit <- SVC_mle(y = y, X = X, locs = locs, 65 | control = control, 66 | optim.control = opt.control) 67 | 68 | ## output: convergence code equal to 1, since maxit was only 1 69 | summary(fit) 70 | 71 | ## plot residuals 72 | # only QQ-plot 73 | plot(fit, which = 2) 74 | 75 | # two plots next to each other 76 | oldpar <- par(mfrow = c(1, 2)) 77 | plot(fit) 78 | par(oldpar) 79 | 80 | } 81 | \seealso{ 82 | \code{\link[graphics]{legend}} \link{SVC_mle} 83 | } 84 | \author{ 85 | Jakob Dambon 86 | } 87 | -------------------------------------------------------------------------------- /R-pkg/NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(AIC,SVC_mle) 4 | S3method(BIC,SVC_mle) 5 | S3method(GLS_chol,matrix) 6 | S3method(GLS_chol,spam.chol.NgPeyton) 7 | S3method(SVC_mle,default) 8 | S3method(SVC_mle,formula) 9 | S3method(SVC_mle_control,SVC_mle) 10 | S3method(SVC_mle_control,default) 11 | S3method(coef,SVC_mle) 12 | S3method(coef,SVC_selection) 13 | S3method(cov_par,SVC_mle) 14 | S3method(cov_par,SVC_selection) 15 | S3method(fitted,SVC_mle) 16 | S3method(logLik,SVC_mle) 17 | S3method(nobs,SVC_mle) 18 | S3method(plot,SVC_mle) 19 | S3method(predict,SVC_mle) 20 | S3method(print,SVC_mle) 21 | S3method(print,summary.SVC_mle) 22 | S3method(residuals,SVC_mle) 23 | S3method(summary,SVC_mle) 24 | export(GLS_chol) 25 | export(SVC_mle) 26 | export(SVC_mle_control) 27 | export(SVC_selection) 28 | export(SVC_selection_control) 29 | export(check_cov_lower) 30 | export(cov_par) 31 | export(init_bounds_optim) 32 | export(nlocs) 33 | export(sample_SVCdata) 34 | import(spam) 35 | importFrom(ParamHelpers,generateDesign) 36 | importFrom(ParamHelpers,makeNumericVectorParam) 37 | importFrom(ParamHelpers,makeParamSet) 38 | importFrom(glmnet,coef.glmnet) 39 | importFrom(glmnet,glmnet) 40 | importFrom(graphics,abline) 41 | importFrom(graphics,legend) 42 | importFrom(graphics,plot) 43 | importFrom(lhs,maximinLHS) 44 | importFrom(methods,is) 45 | importFrom(mlr,makeLearner) 46 | importFrom(mlrMBO,makeMBOControl) 47 | importFrom(mlrMBO,makeMBOInfillCritEI) 48 | importFrom(mlrMBO,mbo) 49 | importFrom(mlrMBO,setMBOControlTermination) 50 | importFrom(optimParallel,optimParallel) 51 | importFrom(parallel,clusterEvalQ) 52 | importFrom(parallel,clusterExport) 53 | importFrom(pbapply,pbapply) 54 | importFrom(pbapply,pboptions) 55 | importFrom(smoof,makeSingleObjectiveFunction) 56 | importFrom(spam,backsolve) 57 | importFrom(spam,chol.spam) 58 | importFrom(spam,cov.exp) 59 | importFrom(spam,cov.mat) 60 | importFrom(spam,cov.sph) 61 | importFrom(spam,cov.wend1) 62 | importFrom(spam,cov.wend2) 63 | importFrom(spam,forwardsolve) 64 | importFrom(spam,nearest.dist) 65 | importFrom(spam,rmvnorm) 66 | importFrom(stats,AIC) 67 | importFrom(stats,BIC) 68 | importFrom(stats,as.formula) 69 | importFrom(stats,coef) 70 | importFrom(stats,dist) 71 | importFrom(stats,fitted) 72 | importFrom(stats,lm.fit) 73 | importFrom(stats,logLik) 74 | importFrom(stats,median) 75 | importFrom(stats,model.matrix) 76 | importFrom(stats,na.omit) 77 | importFrom(stats,nobs) 78 | importFrom(stats,optim) 79 | importFrom(stats,pchisq) 80 | importFrom(stats,pnorm) 81 | importFrom(stats,printCoefmat) 82 | importFrom(stats,qqline) 83 | importFrom(stats,qqnorm) 84 | importFrom(stats,resid) 85 | importFrom(stats,residuals) 86 | importFrom(stats,rnorm) 87 | importFrom(stats,sd) 88 | importFrom(stats,var) 89 | -------------------------------------------------------------------------------- /R-pkg/tests/testthat/test_example.R: -------------------------------------------------------------------------------- 1 | test_that("structure and dimensions of sample_SVCdata are correct", { 2 | n <- 10L 3 | 4 | set.seed(123) 5 | # SVC parameters 6 | df.pars <- data.frame( 7 | var = c(2, 0, 1), 8 | scale = c(3, 1, 1), 9 | mean = c(1, 2, 0) 10 | ) 11 | # nugget standard deviation 12 | tau <- 0.5 13 | 14 | # sample locations 15 | s <- sort(runif(n, min = 0, max = 10)) 16 | SVCdata <- sample_SVCdata( 17 | df.pars = df.pars, nugget.sd = tau, locs = s, cov.name = "mat32" 18 | ) 19 | 20 | expect_type(SVCdata, "list") 21 | expect_identical(names(SVCdata), c("y", "X", "beta", "eps", "locs", "true_pars")) 22 | expect_length(SVCdata$y, n) 23 | expect_identical(dim(SVCdata$X), c(n, 3L)) 24 | expect_identical(dim(SVCdata$beta), c(n, 3L)) 25 | expect_length(SVCdata$eps, n) 26 | expect_type(SVCdata$true_pars, "list") 27 | expect_identical(dim(SVCdata$true_pars), c(4L, 3L)) 28 | expect_identical(SVCdata$true_pars[1:3, ], df.pars) 29 | expect_identical(SVCdata$true_pars[4, 1], tau^2) 30 | expect_identical(SVCdata$true_pars[4, 2], NA_real_) 31 | expect_identical(SVCdata$true_pars[4, 3], NA_real_) 32 | }) 33 | 34 | test_that("all possible four types of SVCs are possible", { 35 | n <- 10L 36 | 37 | set.seed(123) 38 | # SVC parameters 39 | df.pars <- data.frame( 40 | var = c(2, 1, 0, 0), 41 | scale = c(3, 1, 1, 1), 42 | mean = c(10, 0, 2, 0) 43 | ) 44 | # nugget standard deviation 45 | tau <- 0.5 46 | 47 | # sample locations 48 | s <- sort(runif(n, min = 0, max = 10)) 49 | SVCdata <- sample_SVCdata( 50 | df.pars = df.pars, nugget.sd = tau, locs = s, cov.name = "mat32" 51 | ) 52 | 53 | # first SVC (FE + RE): 54 | # mean greater 0 55 | expect_true(all(SVCdata$beta[, 1] > 1)) 56 | # variation 57 | expect_true(min(SVCdata$beta[, 1]) != max(SVCdata$beta[, 1])) 58 | 59 | # second SVC (only RE): 60 | # variation 61 | expect_true(min(SVCdata$beta[, 2]) != max(SVCdata$beta[, 2])) 62 | 63 | # third SVC (only FE): 64 | # mean equal to 2 65 | expect_true(all(SVCdata$beta[, 3] == 2)) 66 | 67 | # fourth SVC (neither FE nor RE): 68 | # mean equal to 2 69 | expect_true(all(SVCdata$beta[, 4] == 0)) 70 | }) 71 | 72 | test_that("providing an X matrix works", { 73 | n <- 10L 74 | 75 | set.seed(123) 76 | # SVC parameters 77 | df.pars <- data.frame( 78 | var = c(2, 0, 1), 79 | scale = c(3, 1, 1), 80 | mean = c(1, 2, 0) 81 | ) 82 | # nugget standard deviation 83 | tau <- 0.5 84 | 85 | # sample locations 86 | s <- sort(runif(n, min = 0, max = 10)) 87 | 88 | # construct some covariate matrices 89 | X2 <- matrix(1:(3*(n+1)), nrow = n+1, ncol = 3) 90 | X3 <- matrix(1:(4*n), nrow = n, ncol = 4) 91 | X4 <- as.data.frame(matrix(1:(3*n), nrow = n, ncol = 3)) 92 | 93 | 94 | expect_error(sample_SVCdata( 95 | df.pars = df.pars, nugget.sd = tau, locs = s, cov.name = "mat32", X = X2 96 | )) 97 | expect_error(sample_SVCdata( 98 | df.pars = df.pars, nugget.sd = tau, locs = s, cov.name = "mat32", X = X3 99 | )) 100 | expect_error(sample_SVCdata( 101 | df.pars = df.pars, nugget.sd = tau, locs = s, cov.name = "mat32", X = X4 102 | )) 103 | }) -------------------------------------------------------------------------------- /R-pkg/man/sample_SVCdata.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/example.R 3 | \name{sample_SVCdata} 4 | \alias{sample_SVCdata} 5 | \title{Sample Function for GP-based SVC Model for Given Locations} 6 | \usage{ 7 | sample_SVCdata( 8 | df.pars, 9 | nugget.sd, 10 | locs, 11 | cov.name = c("exp", "sph", "mat32", "mat52", "wend1", "wend2"), 12 | X = NULL 13 | ) 14 | } 15 | \arguments{ 16 | \item{df.pars}{(\code{data.frame(p, 3)}) \cr 17 | Contains the mean and covariance parameters of SVCs. The three columns 18 | must have the names \code{"mean"}, \code{"var"}, and \code{"scale"}.} 19 | 20 | \item{nugget.sd}{(\code{numeric(1)}) \cr 21 | Standard deviation of the nugget / error term.} 22 | 23 | \item{locs}{(\code{numeric(n)} or \code{matrix(n, d)}) \cr 24 | The numeric vector or matrix contains the observation locations and 25 | therefore defines the number of observations to be \code{n}. For a vector, 26 | we assume locations on the real line, i.e., \eqn{d=1}.} 27 | 28 | \item{cov.name}{(\code{character}(1)) \cr 29 | Character defining the covariance function, c.f. \code{\link{SVC_mle_control}}.} 30 | 31 | \item{X}{(\code{NULL} or \code{matrix(n, p)}) \cr 32 | If \code{NULL}, the covariates are sampled, where the first column contains 33 | only ones to model an intercept and further columns are sampled from a 34 | standard normal. If it is provided as a \code{matrix}, then the dimensions 35 | must match the number of locations in \code{locs} (\code{n}) and the number of SVCs 36 | defined by the number of rows in \code{df.pars} (\code{p}).} 37 | } 38 | \value{ 39 | \code{list} \cr 40 | Returns a list with the response \code{y}, model matrix 41 | \code{X}, a matrix \code{beta} containing the sampled SVC at given 42 | locations, a vector \code{eps} containing the error, and a matrix 43 | \code{locs} containing the original locations. The \code{true_pars} 44 | contains the data frame of covariance parameters that were used to 45 | sample the GP-based SVCs. The nugget variance has been added to the 46 | original argument of the function with its respective variance, but 47 | \code{NA} for \code{"mean"} and \code{"scale"}. 48 | } 49 | \description{ 50 | Samples SVC data at given locations. The SVCs parameters and the 51 | covariance function have to be provided. The sampled model matrix can be 52 | provided or it is sampled. The SVCs are sampled according to their given parametrization and at 53 | respective observation locations. The error vector is sampled from a nugget 54 | effect. Finally, the response vector is computed. Please note that the 55 | function is not optimized for sampling large data sets. 56 | } 57 | \details{ 58 | The parameters of the model can be chosen such that we obtain data 59 | from a not full model, i.e., not all covariates are associated with a 60 | fixed and a random effect. Using \code{var = 0} for instance yields a 61 | constant beta coefficient for respective covariate. Note that in that 62 | case the \code{scale} value is neglected. 63 | } 64 | \examples{ 65 | set.seed(123) 66 | # SVC parameters 67 | (df.pars <- data.frame( 68 | var = c(2, 1), 69 | scale = c(3, 1), 70 | mean = c(1, 2))) 71 | # nugget standard deviation 72 | tau <- 0.5 73 | 74 | # sample locations 75 | s <- sort(runif(500, min = 0, max = 10)) 76 | SVCdata <- sample_SVCdata( 77 | df.pars = df.pars, nugget.sd = tau, locs = s, cov.name = "mat32" 78 | ) 79 | } 80 | -------------------------------------------------------------------------------- /R-pkg/man/predict.SVC_mle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/predict-SVC_mle.R 3 | \name{predict.SVC_mle} 4 | \alias{predict.SVC_mle} 5 | \title{Prediction of SVCs (and response variable)} 6 | \usage{ 7 | \method{predict}{SVC_mle}( 8 | object, 9 | newlocs = NULL, 10 | newX = NULL, 11 | newW = NULL, 12 | newdata = NULL, 13 | compute.y.var = FALSE, 14 | ... 15 | ) 16 | } 17 | \arguments{ 18 | \item{object}{(\code{SVC_mle}) \cr 19 | Model obtained from \code{\link{SVC_mle}} function call.} 20 | 21 | \item{newlocs}{(\code{NULL} or \code{matrix(n.new, 2)}) \cr 22 | If \code{NULL}, then function uses observed locations of model to estimate 23 | SVCs. Otherwise, these are the new locations the SVCs are predicted for.} 24 | 25 | \item{newX}{(\code{NULL} or \code{matrix(n.new, q)}) \cr 26 | If provided (together with \code{newW}), the function also returns the 27 | predicted response variable.} 28 | 29 | \item{newW}{(\code{NULL} or \code{matrix(n.new, p)}) \cr 30 | If provided (together with \code{newX}), the function also returns the 31 | predicted response variable.} 32 | 33 | \item{newdata}{(\code{NULL} or \code{data.frame(n.new, p)}) \cr 34 | This argument can be used, when the \code{SVC_mle} function has been called 35 | with an formula, see examples.} 36 | 37 | \item{compute.y.var}{(\code{logical(1)}) \cr 38 | If \code{TRUE} and the response is being estimated, the predictive 39 | variance of each estimate will be computed.} 40 | 41 | \item{...}{further arguments} 42 | } 43 | \value{ 44 | The function returns a data frame of \code{n.new} rows and with 45 | columns 46 | \itemize{ 47 | \item \code{SVC_1, ..., SVC_p}: the predicted SVC at locations \code{newlocs}. 48 | \item \code{y.pred}, if \code{newX} and \code{newW} are provided 49 | \item \code{y.var}, if \code{newX} and \code{newW} are provided and 50 | \code{compute.y.var} is set to \code{TRUE}. 51 | \item \code{loc_x, loc_y}, the locations of the predictions 52 | } 53 | } 54 | \description{ 55 | Prediction of SVCs (and response variable) 56 | } 57 | \examples{ 58 | ## ---- toy example ---- 59 | ## We use the sampled, i.e., one dimensional SVCs 60 | str(SVCdata) 61 | # sub-sample data to have feasible run time for example 62 | set.seed(123) 63 | id <- sample(length(SVCdata$locs), 50) 64 | 65 | ## SVC_mle call with matrix arguments 66 | fit_mat <- with(SVCdata, SVC_mle( 67 | y[id], X[id, ], locs[id], 68 | control = SVC_mle_control(profileLik = TRUE, cov.name = "mat32"))) 69 | 70 | ## SVC_mle call with formula 71 | df <- with(SVCdata, data.frame(y = y[id], X = X[id, -1])) 72 | fit_form <- SVC_mle( 73 | y ~ X, data = df, locs = SVCdata$locs[id], 74 | control = SVC_mle_control(profileLik = TRUE, cov.name = "mat32") 75 | ) 76 | 77 | ## prediction 78 | 79 | # predicting SVCs 80 | predict(fit_mat, newlocs = 1:2) 81 | predict(fit_form, newlocs = 1:2) 82 | 83 | # predicting SVCs and response providing new covariates 84 | predict( 85 | fit_mat, 86 | newX = matrix(c(1, 1, 3, 4), ncol = 2), 87 | newW = matrix(c(1, 1, 3, 4), ncol = 2), 88 | newlocs = 1:2 89 | ) 90 | predict(fit_form, newdata = data.frame(X = 3:4), newlocs = 1:2) 91 | 92 | } 93 | \references{ 94 | Dambon, J. A., Sigrist, F., Furrer, R. (2021) 95 | \emph{Maximum likelihood estimation of spatially varying coefficient 96 | models for large data with an application to real estate price prediction}, 97 | Spatial Statistics \doi{10.1016/j.spasta.2020.100470} 98 | } 99 | \seealso{ 100 | \code{\link{SVC_mle}} 101 | } 102 | \author{ 103 | Jakob Dambon 104 | } 105 | -------------------------------------------------------------------------------- /R-pkg/R/objective_functions.R: -------------------------------------------------------------------------------- 1 | # holds objective functions to be optimized, i.e. negative log-likelihood of SVC-Models 2 | 3 | #' @importFrom spam chol.spam forwardsolve 4 | n2LL <- function( 5 | x, cov_func, outer.W, y, X, W, 6 | mean.est = NULL, 7 | taper = NULL, 8 | pc.dens = NULL, 9 | Rstruct = NULL, 10 | profile = TRUE 11 | ) { 12 | 13 | q <- dim(W)[2] 14 | p <- dim(X)[2] 15 | n <- length(y) 16 | 17 | # compute covariance matrices 18 | Sigma <- Sigma_y(x[1:(2*q+1)], cov_func, outer.W, taper = taper) 19 | 20 | # calculate Cholesky-Decompisition 21 | # powerboost function 22 | # spam pivot check 23 | if (is.spam(Sigma)) { 24 | cholS <- spam::chol.spam(Sigma, Rstruct = Rstruct) 25 | } else { 26 | cholS <- chol(Sigma) 27 | } 28 | 29 | 30 | ## profile LL 31 | mu <- if (profile) { 32 | # compute mu(theta)... 33 | if (is.null(mean.est)) { 34 | # ...using GLS 35 | GLS_chol(cholS, X, y) 36 | } else { 37 | # ...or set by some constant 38 | mean.est 39 | } 40 | } else { 41 | # given directly by objective parameters 42 | x[1 + 2*q + 1:p] 43 | } 44 | 45 | res <- y - X %*% mu 46 | 47 | ## quadratic form of residual, i.e., t(res) %*% Sigma^-1 %*% res 48 | quad_res <- if (is.matrix(cholS)) { 49 | as.numeric(crossprod(solve(t(cholS), res))) 50 | } else { 51 | as.numeric(crossprod(spam::forwardsolve(cholS, res, 52 | transpose = TRUE, 53 | upper.tri = TRUE))) 54 | } 55 | 56 | # n2LL as stated in paper Dambon et al. (2020) does not contain the 57 | # summand n*log(2 * pi), but it is needed to compute the actual LL 58 | return(n * log(2 * pi) + 59 | 2 * c(determinant(cholS)$modulus) + 60 | quad_res + 61 | pc_penalty(x, q, pc.dens)) 62 | } 63 | 64 | # 65 | # n2LL <- function(x, cov_func, outer.W, y, X, W, 66 | # taper = NULL, pc.dens = NULL, Rstruct = NULL) { 67 | # 68 | # 69 | # pW <- ncol(W) 70 | # pX <- ncol(X) 71 | # n <- length(y) 72 | # 73 | # # compute covariance matrices 74 | # Sigma <- Sigma_y(x, cov_func, outer.W, taper = taper) 75 | # 76 | # 77 | # if (is.spam(Sigma)) { 78 | # cholS <- spam::chol.spam(Sigma, Rstruct = Rstruct) 79 | # } else { 80 | # cholS <- chol(Sigma) 81 | # } 82 | # 83 | # # calculate Cholesky-Decompisition 84 | # cholS <- spam::chol.spam(Sigma, Rstruct = Rstruct) 85 | # 86 | # # get mu 87 | # mu <- x[1 + 2*pW + 1:pX] 88 | # 89 | # res <- y - X %*% mu 90 | # 91 | # 92 | # quad_res <- if (is.matrix(cholS)) { 93 | # as.numeric(crossprod(solve(t(cholS), res))) 94 | # } else { 95 | # as.numeric(crossprod(spam::forwardsolve(cholS, res, 96 | # transpose = TRUE, 97 | # upper.tri = TRUE))) 98 | # } 99 | # 100 | # 101 | # # n2LL as stated in paper Dambon et al. (2020) does not contain the 102 | # # summand n*log(2 * pi), but it is needed to compute the actual LL 103 | # return(n * log(2 * pi) + 104 | # 2 * c(determinant(cholS)$modulus) + 105 | # quad_res + 106 | # pc_penalty(x, pW, pc.dens)) 107 | # } 108 | 109 | 110 | pc_penalty <- function(x, q, pc.dens) { 111 | 112 | if (is.null(pc.dens)) { 113 | return(0) 114 | } else { 115 | cov_vars <- x[1:(2*q)] 116 | 117 | pc.priors <- sapply(1:q, function(j) { 118 | pc.dens(cov_vars[2*(j-1) + 1:2]) 119 | }) 120 | 121 | return(sum(pc.priors)) 122 | } 123 | } 124 | -------------------------------------------------------------------------------- /R-pkg/R/data.R: -------------------------------------------------------------------------------- 1 | #' Lucas County House Price Data 2 | #' 3 | #' A dataset containing the prices and other attributes of 25,357 houses in 4 | #' Lucas County, Ohio. The selling dates span years 1993 to 1998. Data taken 5 | #' from \code{\link[spData]{house}} (\code{spData} package) and slightly modified to a \code{data.frame}. 6 | #' 7 | #' @format A data frame with 25357 rows and 25 variables: 8 | #' \describe{ 9 | #' \item{price}{(\code{integer}) selling price, in US dollars} 10 | #' \item{yrbuilt}{(\code{integer}) year the house was built} 11 | #' \item{stories}{(\code{factor}) levels are \code{"one", "bilevel", 12 | #' "multilvl", "one+half", "two", "two+half", "three"}} 13 | #' \item{TLA}{(\code{integer}) total living area, in square feet.} 14 | #' \item{wall}{(\code{factor}) levels are \code{"stucdrvt", "ccbtile", 15 | #' "metlvnyl", "brick", "stone", "wood", "partbrk"}} 16 | #' \item{beds, baths, halfbaths}{(\code{integer}) number of corresponding 17 | #' rooms / facilities.} 18 | #' \item{frontage, depth}{dimensions of the lot. Unit is feet.} 19 | #' \item{garage}{(\code{factor}) levels are \code{"no garage", "basement", 20 | #' "attached", "detached", "carport"}} 21 | #' \item{garagesqft}{(\code{integer}) garage area, in square feet. If 22 | #' \code{garage == "no garage"}, then \code{garagesqft == 0}.} 23 | #' \item{rooms}{(\code{integer}) number of rooms} 24 | #' \item{lotsize}{(\code{integer}) area of lot, in square feet} 25 | #' \item{sdate}{(\code{Date}) selling date, in format \code{yyyy-mm-dd}} 26 | #' \item{avalue}{(\code{int}) appraised value} 27 | #' \item{s1993, s1994, s1995, s1996, s1997, s1998}{(\code{int}) dummies for 28 | #' selling year.} 29 | #' \item{syear}{(\code{factor}) levels are selling years \code{"1993", "1994", 30 | #' "1995", "1996", "1997", "1998"}} 31 | #' \item{long, lat}{(\code{numeric}) location of houses. Longitude and 32 | #' Latitude are given in \code{CRS(+init=epsg:2834)}, the Ohio North State 33 | #' Plane. Units are meters.} 34 | #' } 35 | #' @source \url{http://www.spatial-econometrics.com/html/jplv6.zip} 36 | "house" 37 | 38 | 39 | #' Sampled SVC Data 40 | #' 41 | #' A list object that contains sampled data of 500 observations. The data has 42 | #' been sampled using the \code{RandomFields} package (Schlather et al., 2015). 43 | #' It is given in the list object \code{SVCdata} which contains the following. 44 | #' 45 | #' @format A \code{list} with the following entries: 46 | #' \describe{ 47 | #' \item{y}{(\code{numeric}) Response} 48 | #' \item{X}{(\code{numeric}) Covariates; first columns contains ones to model 49 | #' an intercept, the second column contains standard-normal sampled data.} 50 | #' \item{beta}{(\code{numeric}) The sampled Gaussian processes, which are 51 | #' usually unobserved. It uses a Matern covariance function and the true 52 | #' parameters are given in the entry `true_pars`.} 53 | #' \item{eps}{(\code{numeric}) Error (or Nugget effect), i.e., drawn from a 54 | #' zero-mean normal distribution with 0.5 standard deviation.} 55 | #' \item{locs}{(\code{numeric}) Locations sampled from a uniform distribution 56 | #' on the interval 0 to 10.} 57 | #' \item{true_pars}{(\code{data.frame}) True parameters of the GP-based SVC 58 | #' model with Gaussian process mean, variance, and range. Additionally, the 59 | #' smoothness (nu) is given.} 60 | #' } 61 | #' @references Schlather, M., Malinowski, A., Menck, P. J., Oesting, M., Strokorb, K. (2015) 62 | #' \emph{Analysis, simulation and prediction of multivariate random fields with package RandomFields}, 63 | #' Journal of Statistical Software, \doi{10.18637/jss.v063.i08} 64 | "SVCdata" 65 | -------------------------------------------------------------------------------- /R-pkg/R/varycoef.R: -------------------------------------------------------------------------------- 1 | #' varycoef: Modeling Spatially Varying Coefficients 2 | #' 3 | #' This package offers functions to estimate and predict Gaussian process-based 4 | #' spatially varying coefficient (SVC) models. Briefly described, one 5 | #' generalizes a linear regression equation such that the coefficients are no 6 | #' longer constant, but have the possibility to vary spatially. This is enabled 7 | #' by modeling the coefficients using Gaussian processes with (currently) either 8 | #' an exponential or spherical covariance function. The advantages of such SVC 9 | #' models are that they are usually quite easy to interpret, yet they offer a 10 | #' very high level of flexibility. 11 | #' 12 | #' 13 | #' @section Estimation and Prediction: 14 | #' The ensemble of the function \code{\link{SVC_mle}} and the method 15 | #' \code{predict} estimates the defined SVC model and gives predictions of the 16 | #' SVC as well as the response for some pre-defined locations. This concept 17 | #' should be rather familiar as it is the same for the classical regression 18 | #' (\code{\link{lm}}) or local polynomial regression (\code{\link{loess}}), 19 | #' to name a couple. As the name suggests, we are using a \emph{maximum 20 | #' likelihood estimation} (MLE) approach in order to estimate the model. The 21 | #' predictor is obtained by the empirical best linear unbiased predictor. 22 | #' to give location-specific predictions. A detailed tutorial with examples is 23 | #' given in a vignette; call \code{vignette("example", package = "varycoef")}. 24 | #' We also refer to the original article Dambon et al. (2021) which lays the 25 | #' methodological foundation of this package. 26 | #' 27 | #' 28 | #' With the before mentioned \code{\link{SVC_mle}} function one gets an object 29 | #' of class \code{\link{SVC_mle}}. And like the method \code{predict} for 30 | #' predictions, there are several more methods in order to diagnose the model, 31 | #' see \code{methods(class = "SVC_mle")}. 32 | #' 33 | #' @section Variable Selection: 34 | #' As of version 0.3.0 of \code{varycoef}, a joint variable selection of both 35 | #' fixed and random effect of the Gaussian process-based SVC model is 36 | #' implemented. It uses a \emph{penalized maximum likelihood estimation} (PMLE) 37 | #' which is implemented via a gradient descent. The estimation of the shrinkage 38 | #' parameter is available using a \emph{model-based optimization} (MBO). Here, 39 | #' we use the framework by Bischl et al. (2017). The methodological foundation 40 | #' of the PMLE is described in Dambon et al. (2022). 41 | #' 42 | #' @examples 43 | #' vignette("manual", package = "varycoef") 44 | #' methods(class = "SVC_mle") 45 | #' 46 | #' @author Jakob Dambon 47 | #' 48 | #' @references Bischl, B., Richter, J., Bossek, J., Horn, D., Thomas, J., 49 | #' Lang, M. (2017). \emph{mlrMBO: A Modular Framework for Model-Based 50 | #' Optimization of Expensive Black-Box Functions}, 51 | #' ArXiv preprint \url{https://arxiv.org/abs/1703.03373} 52 | #' 53 | #' Dambon, J. A., Sigrist, F., Furrer, R. (2021). 54 | #' \emph{Maximum likelihood estimation of spatially varying coefficient 55 | #' models for large data with an application to real estate price prediction}, 56 | #' Spatial Statistics 41 100470 \doi{10.1016/j.spasta.2020.100470} 57 | #' 58 | #' Dambon, J. A., Sigrist, F., Furrer, R. (2022). 59 | #' \emph{Joint Variable Selection of both Fixed and Random Effects for 60 | #' Gaussian Process-based Spatially Varying Coefficient Models}, 61 | #' International Journal of Geographical Information Science 62 | #' \doi{10.1080/13658816.2022.2097684} 63 | #' 64 | #' @docType package 65 | #' @name varycoef 66 | #' @aliases varycoef-package 67 | #' @rdname varycoef 68 | NULL 69 | -------------------------------------------------------------------------------- /R-pkg/R/plot-SVC_mle.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | #' @title Plotting Residuals of \code{SVC_mle} model 4 | #' 5 | #' @description Method to plot the residuals from an \code{\link{SVC_mle}} 6 | #' object. For this, \code{save.fitted} has to be \code{TRUE} in 7 | #' \code{\link{SVC_mle_control}}. 8 | #' 9 | #' @param x (\code{\link{SVC_mle}}) 10 | #' @param which (\code{numeric}) \cr A numeric vector and subset of 11 | #' \code{1:2} indicating which of the 2 plots should be plotted. 12 | #' @param ... further arguments 13 | #' 14 | #' @return a maximum 2 plots 15 | #' \itemize{ 16 | #' \item Tukey-Anscombe plot, i.e. residuals vs. fitted 17 | #' \item QQ-plot 18 | #' } 19 | #' 20 | #' @author Jakob Dambon 21 | #' 22 | #' @seealso \code{\link[graphics]{legend}} \link{SVC_mle} 23 | #' 24 | #' @examples 25 | #' #' ## ---- toy example ---- 26 | #' ## sample data 27 | #' # setting seed for reproducibility 28 | #' set.seed(123) 29 | #' m <- 7 30 | #' # number of observations 31 | #' n <- m*m 32 | #' # number of SVC 33 | #' p <- 3 34 | #' # sample data 35 | #' y <- rnorm(n) 36 | #' X <- matrix(rnorm(n*p), ncol = p) 37 | #' # locations on a regular m-by-m-grid 38 | #' locs <- expand.grid(seq(0, 1, length.out = m), 39 | #' seq(0, 1, length.out = m)) 40 | #' 41 | #' ## preparing for maximum likelihood estimation (MLE) 42 | #' # controls specific to MLE 43 | #' control <- SVC_mle_control( 44 | #' # initial values of optimization 45 | #' init = rep(0.1, 2*p+1), 46 | #' # using profile likelihood 47 | #' profileLik = TRUE 48 | #' ) 49 | #' 50 | #' # controls specific to optimization procedure, see help(optim) 51 | #' opt.control <- list( 52 | #' # number of iterations (set to one for demonstration sake) 53 | #' maxit = 1, 54 | #' # tracing information 55 | #' trace = 6 56 | #' ) 57 | #' 58 | #' ## starting MLE 59 | #' fit <- SVC_mle(y = y, X = X, locs = locs, 60 | #' control = control, 61 | #' optim.control = opt.control) 62 | #' 63 | #' ## output: convergence code equal to 1, since maxit was only 1 64 | #' summary(fit) 65 | #' 66 | #' ## plot residuals 67 | #' # only QQ-plot 68 | #' plot(fit, which = 2) 69 | #' 70 | #' # two plots next to each other 71 | #' oldpar <- par(mfrow = c(1, 2)) 72 | #' plot(fit) 73 | #' par(oldpar) 74 | #' 75 | #' @importFrom stats qqnorm qqline 76 | #' @importFrom graphics plot abline legend 77 | #' @method plot SVC_mle 78 | #' @export 79 | plot.SVC_mle <- function(x, which = 1:2, ...) { 80 | 81 | stopifnot( 82 | # residuals needed 83 | !is.null(x$residuals), 84 | # only two kinds of plots supported 85 | all(which %in% 1:2) 86 | ) 87 | 88 | ## Tukey-Anscombe 89 | if (1 %in% which) { 90 | plot(fitted(x)$y.pred, 91 | residuals(x), 92 | main = "Tukey-Anscombe Plot", 93 | xlab = "fitted", ylab = "residuals", 94 | col = "grey") 95 | abline(h = 0) 96 | } 97 | 98 | ## QQ-plot 99 | if (2 %in% which) { 100 | qqnorm(residuals(x)) 101 | qqline(residuals(x)) 102 | } 103 | 104 | # ## spatial residuals 105 | # if (3 %in% which) { 106 | # loc_x <- fitted(x)$loc_x 107 | # loc_y <- fitted(x)$loc_y 108 | # res <- residuals(x) 109 | # cex.range <- range(sqrt(abs(res))) 110 | # 111 | # plot(loc_x, loc_y, 112 | # type = "p", 113 | # main = "Spatial Residuals Plot", 114 | # xlab = "x locations", ylab = "y locations", 115 | # pch = 1, col = ifelse(res < 0, "blue", "orange"), 116 | # cex = sqrt(abs(res))) 117 | # 118 | # legend(legend.pos, 119 | # legend = c("pos. residuals", "neg. residuals", "min", "max"), 120 | # pch = c(19, 19, 1, 1), 121 | # col = c("orange", "blue", "grey", "grey"), 122 | # pt.cex = c(1, 1, cex.range)) 123 | # } 124 | } 125 | -------------------------------------------------------------------------------- /R-pkg/man/varycoef.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/varycoef.R 3 | \docType{package} 4 | \name{varycoef} 5 | \alias{varycoef} 6 | \alias{varycoef-package} 7 | \title{varycoef: Modeling Spatially Varying Coefficients} 8 | \description{ 9 | This package offers functions to estimate and predict Gaussian process-based 10 | spatially varying coefficient (SVC) models. Briefly described, one 11 | generalizes a linear regression equation such that the coefficients are no 12 | longer constant, but have the possibility to vary spatially. This is enabled 13 | by modeling the coefficients using Gaussian processes with (currently) either 14 | an exponential or spherical covariance function. The advantages of such SVC 15 | models are that they are usually quite easy to interpret, yet they offer a 16 | very high level of flexibility. 17 | } 18 | \section{Estimation and Prediction}{ 19 | 20 | The ensemble of the function \code{\link{SVC_mle}} and the method 21 | \code{predict} estimates the defined SVC model and gives predictions of the 22 | SVC as well as the response for some pre-defined locations. This concept 23 | should be rather familiar as it is the same for the classical regression 24 | (\code{\link{lm}}) or local polynomial regression (\code{\link{loess}}), 25 | to name a couple. As the name suggests, we are using a \emph{maximum 26 | likelihood estimation} (MLE) approach in order to estimate the model. The 27 | predictor is obtained by the empirical best linear unbiased predictor. 28 | to give location-specific predictions. A detailed tutorial with examples is 29 | given in a vignette; call \code{vignette("example", package = "varycoef")}. 30 | We also refer to the original article Dambon et al. (2021) which lays the 31 | methodological foundation of this package. 32 | 33 | 34 | With the before mentioned \code{\link{SVC_mle}} function one gets an object 35 | of class \code{\link{SVC_mle}}. And like the method \code{predict} for 36 | predictions, there are several more methods in order to diagnose the model, 37 | see \code{methods(class = "SVC_mle")}. 38 | } 39 | 40 | \section{Variable Selection}{ 41 | 42 | As of version 0.3.0 of \code{varycoef}, a joint variable selection of both 43 | fixed and random effect of the Gaussian process-based SVC model is 44 | implemented. It uses a \emph{penalized maximum likelihood estimation} (PMLE) 45 | which is implemented via a gradient descent. The estimation of the shrinkage 46 | parameter is available using a \emph{model-based optimization} (MBO). Here, 47 | we use the framework by Bischl et al. (2017). The methodological foundation 48 | of the PMLE is described in Dambon et al. (2022). 49 | } 50 | 51 | \examples{ 52 | vignette("manual", package = "varycoef") 53 | methods(class = "SVC_mle") 54 | 55 | } 56 | \references{ 57 | Bischl, B., Richter, J., Bossek, J., Horn, D., Thomas, J., 58 | Lang, M. (2017). \emph{mlrMBO: A Modular Framework for Model-Based 59 | Optimization of Expensive Black-Box Functions}, 60 | ArXiv preprint \url{https://arxiv.org/abs/1703.03373} 61 | 62 | Dambon, J. A., Sigrist, F., Furrer, R. (2021). 63 | \emph{Maximum likelihood estimation of spatially varying coefficient 64 | models for large data with an application to real estate price prediction}, 65 | Spatial Statistics 41 100470 \doi{10.1016/j.spasta.2020.100470} 66 | 67 | Dambon, J. A., Sigrist, F., Furrer, R. (2022). 68 | \emph{Joint Variable Selection of both Fixed and Random Effects for 69 | Gaussian Process-based Spatially Varying Coefficient Models}, 70 | International Journal of Geographical Information Science 71 | \doi{10.1080/13658816.2022.2097684} 72 | } 73 | \seealso{ 74 | Useful links: 75 | \itemize{ 76 | \item \url{https://github.com/jakobdambon/varycoef} 77 | \item Report bugs at \url{https://github.com/jakobdambon/varycoef/issues} 78 | } 79 | 80 | } 81 | \author{ 82 | Jakob Dambon 83 | } 84 | -------------------------------------------------------------------------------- /R-pkg/man/SVC_selection_control.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/SVC_selection.R 3 | \name{SVC_selection_control} 4 | \alias{SVC_selection_control} 5 | \title{SVC Selection Parameters} 6 | \usage{ 7 | SVC_selection_control( 8 | IC.type = c("BIC", "cAIC_BW", "cAIC_VB"), 9 | method = c("grid", "MBO"), 10 | r.lambda = c(1e-10, 10), 11 | n.lambda = 10L, 12 | n.init = 10L, 13 | n.iter = 10L, 14 | CD.conv = list(N = 20L, delta = 1e-06, logLik = TRUE), 15 | hessian = FALSE, 16 | adaptive = FALSE, 17 | parallel = NULL, 18 | optim.args = list() 19 | ) 20 | } 21 | \arguments{ 22 | \item{IC.type}{(\code{character(1)}) \cr 23 | Select Information Criterion.} 24 | 25 | \item{method}{(\code{character(1)}) \cr 26 | Select optimization method for lambdas, i.e., shrinkage parameters. 27 | Either model-based optimization (MBO, Bischl et al., 2017 ) or over grid.} 28 | 29 | \item{r.lambda}{(\code{numeric(2)}) \cr 30 | Range of lambdas, i.e., shrinkage parameters.} 31 | 32 | \item{n.lambda}{(\code{numeric(1)}) \cr 33 | If grid method is selected, number of lambdas per side of grid.} 34 | 35 | \item{n.init}{(\code{numeric(1)}) \cr 36 | If MBO method is selected, number of initial values for surrogate model.} 37 | 38 | \item{n.iter}{(\code{numeric(1)}) \cr 39 | If MBO method is selected, number of iteration steps of surrogate models.} 40 | 41 | \item{CD.conv}{(\code{list(3)}) \cr 42 | List containing the convergence conditions, i.e., 43 | first entry is the maximum number of iterations, 44 | second value is the relative change necessary to stop iteration, 45 | third is logical to toggle if relative change in log likelihood 46 | (\code{TRUE}) or rather the parameters themselves (\code{FALSE}) 47 | is the criteria for convergence.} 48 | 49 | \item{hessian}{(\code{logical(1)}) \cr 50 | If \code{TRUE}, Hessian will be computed for final model.} 51 | 52 | \item{adaptive}{(\code{logical(1)}) \cr 53 | If \code{TRUE}, adaptive LASSO is executed, i.e., 54 | the shrinkage parameter is defined as \eqn{\lambda_j := \lambda / |\theta_j|}.} 55 | 56 | \item{parallel}{(\code{list}) \cr 57 | List with arguments for parallelization, 58 | see documentation of \code{\link[optimParallel]{optimParallel}}.} 59 | 60 | \item{optim.args}{(\code{list}) \cr 61 | List of further arguments of \code{\link[optimParallel]{optimParallel}}, 62 | such as the lower bounds.} 63 | } 64 | \value{ 65 | A list of control parameters for SVC selection. 66 | } 67 | \description{ 68 | Function to set up control parameters for 69 | \code{\link{SVC_selection}}. The underlying Gaussian Process-based 70 | SVC model is defined in \code{\link{SVC_mle}}. \code{\link{SVC_selection}} 71 | then jointly selects fixed and random effects of the GP-based 72 | SVC model using a penalized maximum likelihood estimation (PMLE). 73 | In this function, one can set the parameters for the PMLE and 74 | its optimization procedures (Dambon et al., 2022). 75 | } 76 | \examples{ 77 | # Initializing parameters and switching logLik to FALSE 78 | selection_control <- SVC_selection_control( 79 | CD.conv = list(N = 20L, delta = 1e-06, logLik = FALSE) 80 | ) 81 | # or 82 | selection_control <- SVC_selection_control() 83 | selection_control$CD.conv$logLik <- FALSE 84 | 85 | } 86 | \references{ 87 | Bischl, B., Richter, J., Bossek, J., Horn, D., Thomas, J., 88 | Lang, M. (2017). 89 | \emph{mlrMBO: A Modular Framework for Model-Based Optimization of 90 | Expensive Black-Box Functions}, 91 | ArXiv preprint \url{https://arxiv.org/abs/1703.03373} 92 | 93 | Dambon, J. A., Sigrist, F., Furrer, R. (2022). 94 | \emph{Joint Variable Selection of both Fixed and Random Effects for 95 | Gaussian Process-based Spatially Varying Coefficient Models}, 96 | International Journal of Geographical Information Science 97 | \doi{10.1080/13658816.2022.2097684} 98 | } 99 | \author{ 100 | Jakob Dambon 101 | } 102 | -------------------------------------------------------------------------------- /R-pkg/R/example.R: -------------------------------------------------------------------------------- 1 | 2 | #' Sample Function for GP-based SVC Model for Given Locations 3 | #' 4 | #' @description Samples SVC data at given locations. The SVCs parameters and the 5 | #' covariance function have to be provided. The sampled model matrix can be 6 | #' provided or it is sampled. The SVCs are sampled according to their given parametrization and at 7 | #' respective observation locations. The error vector is sampled from a nugget 8 | #' effect. Finally, the response vector is computed. Please note that the 9 | #' function is not optimized for sampling large data sets. 10 | #' 11 | #' @param df.pars (\code{data.frame(p, 3)}) \cr 12 | #' Contains the mean and covariance parameters of SVCs. The three columns 13 | #' must have the names \code{"mean"}, \code{"var"}, and \code{"scale"}. 14 | #' @param nugget.sd (\code{numeric(1)}) \cr 15 | #' Standard deviation of the nugget / error term. 16 | #' @param cov.name (\code{character}(1)) \cr 17 | #' Character defining the covariance function, c.f. \code{\link{SVC_mle_control}}. 18 | #' @param locs (\code{numeric(n)} or \code{matrix(n, d)}) \cr 19 | #' The numeric vector or matrix contains the observation locations and 20 | #' therefore defines the number of observations to be \code{n}. For a vector, 21 | #' we assume locations on the real line, i.e., \eqn{d=1}. 22 | #' @param X (\code{NULL} or \code{matrix(n, p)}) \cr 23 | #' If \code{NULL}, the covariates are sampled, where the first column contains 24 | #' only ones to model an intercept and further columns are sampled from a 25 | #' standard normal. If it is provided as a \code{matrix}, then the dimensions 26 | #' must match the number of locations in \code{locs} (\code{n}) and the number of SVCs 27 | #' defined by the number of rows in \code{df.pars} (\code{p}). 28 | #' 29 | #' @return \code{list} \cr 30 | #' Returns a list with the response \code{y}, model matrix 31 | #' \code{X}, a matrix \code{beta} containing the sampled SVC at given 32 | #' locations, a vector \code{eps} containing the error, and a matrix 33 | #' \code{locs} containing the original locations. The \code{true_pars} 34 | #' contains the data frame of covariance parameters that were used to 35 | #' sample the GP-based SVCs. The nugget variance has been added to the 36 | #' original argument of the function with its respective variance, but 37 | #' \code{NA} for \code{"mean"} and \code{"scale"}. 38 | #' 39 | #' @details The parameters of the model can be chosen such that we obtain data 40 | #' from a not full model, i.e., not all covariates are associated with a 41 | #' fixed and a random effect. Using \code{var = 0} for instance yields a 42 | #' constant beta coefficient for respective covariate. Note that in that 43 | #' case the \code{scale} value is neglected. 44 | #' 45 | #' @examples 46 | #' set.seed(123) 47 | #' # SVC parameters 48 | #' (df.pars <- data.frame( 49 | #' var = c(2, 1), 50 | #' scale = c(3, 1), 51 | #' mean = c(1, 2))) 52 | #' # nugget standard deviation 53 | #' tau <- 0.5 54 | #' 55 | #' # sample locations 56 | #' s <- sort(runif(500, min = 0, max = 10)) 57 | #' SVCdata <- sample_SVCdata( 58 | #' df.pars = df.pars, nugget.sd = tau, locs = s, cov.name = "mat32" 59 | #' ) 60 | #' @importFrom spam rmvnorm cov.exp cov.mat cov.sph cov.wend1 cov.wend2 61 | #' @importFrom stats rnorm 62 | #' @export 63 | sample_SVCdata <- function( 64 | df.pars, nugget.sd, locs, 65 | cov.name = c("exp", "sph", "mat32", "mat52", "wend1", "wend2"), 66 | X = NULL 67 | ) { 68 | # transform to matrix for further computations 69 | if (is.vector(locs)) { 70 | locs <- matrix(locs, ncol = 1) 71 | } 72 | # check covariance parameters and locations 73 | stopifnot( 74 | is.data.frame(df.pars), 75 | all(df.pars$var >= 0), 76 | all(df.pars$scale > 0), 77 | nugget.sd > 0, 78 | is.matrix(locs) 79 | ) 80 | # dimensions 81 | d <- dim(locs)[2] 82 | n <- dim(locs)[1] 83 | p <- nrow(df.pars) 84 | 85 | ## build SVC models depending on covariance function, i.e., Sigma_y 86 | D <- as.matrix(dist(locs, diag = TRUE, upper = TRUE)) 87 | 88 | ## covariance functions 89 | cov_fun <- function(theta) { 90 | do.call( 91 | what = MLE.cov.func(cov.name), 92 | args = list(h = D, theta = theta) 93 | ) 94 | } 95 | 96 | 97 | ## sample SVCs (including mean effect) 98 | beta <- apply(df.pars, 1, function(x) { 99 | if (x["var"] == 0) { 100 | rep(x["mean"], n) 101 | } else { 102 | spam::rmvnorm( 103 | n = 1, 104 | mu = rep(x["mean"], n), 105 | Sigma = cov_fun(theta = x[c("scale", "var")]) 106 | ) 107 | } 108 | }) 109 | # nugget 110 | eps <- rnorm(n, sd = nugget.sd) 111 | 112 | # data 113 | if (is.null(X)) { 114 | X <- cbind(1, matrix(rnorm(n*(p-1)), ncol = p-1)) 115 | } else { 116 | stopifnot( 117 | is.matrix(X), 118 | dim(X)[1] == n, 119 | dim(X)[2] == p 120 | ) 121 | } 122 | y <- apply(beta*X, 1, sum) + eps 123 | 124 | list( 125 | y = y, X = X, beta = beta, eps = eps, locs = locs, 126 | true_pars = rbind( 127 | df.pars, 128 | data.frame( 129 | var = nugget.sd^2, 130 | scale = NA, mean = NA 131 | ) 132 | ) 133 | ) 134 | } 135 | -------------------------------------------------------------------------------- /R-pkg/R/summary-SVC_mle.R: -------------------------------------------------------------------------------- 1 | 2 | #' @title Summary Method for \code{SVC_mle} 3 | #' 4 | #' @description Method to construct a \code{summary.SVC_mle} object out of a 5 | #' \code{\link{SVC_mle}} object. 6 | #' 7 | #' @param object \code{\link{SVC_mle}} object 8 | #' @param ... further arguments 9 | #' 10 | #' @return object of class \code{summary.SVC_mle} with summarized values of the MLE. 11 | #' 12 | #' @author Jakob Dambon 13 | #' 14 | #' @seealso \code{\link{SVC_mle}} 15 | #' 16 | #' @importFrom stats pchisq pnorm 17 | #' @method summary SVC_mle 18 | #' @export 19 | summary.SVC_mle <- function(object, ...) { 20 | 21 | stopifnot(!is.null(object$residuals)) 22 | 23 | p <- dim(as.matrix(object$data$X))[2] 24 | q <- dim(as.matrix(object$data$W))[2] 25 | 26 | se_RE <- object$MLE$comp.args$par_SE$RE$SE 27 | se_FE <- object$MLE$comp.args$par_SE$FE$SE 28 | 29 | covpars <- cbind( 30 | Estimate = cov_par(object), 31 | `Std. Error` = se_RE, 32 | `W value` = (cov_par(object)/se_RE)^2, 33 | `Pr(>W)` = pchisq((cov_par(object)/se_RE)^2, df = 1, lower.tail = FALSE) 34 | ) 35 | # do not test range and nugget variance 36 | covpars[-(2*(1:q)), 3:4] <- NA 37 | 38 | ans <- list( 39 | call = object$call, 40 | pX = p, 41 | pW = q, 42 | nobs = nobs(object), 43 | nlocs = nlocs(object), 44 | resids = resid(object), 45 | y.mean.resid = object$data$y-mean(object$data$y), 46 | coefs = cbind( 47 | Estimate = coef(object), 48 | `Std. Error` = se_FE, 49 | `Z value` = (coef(object)/se_FE), 50 | `Pr(>|Z|)` = 2*pnorm(abs(coef(object)/se_FE), lower.tail = FALSE) 51 | ), 52 | covpars = covpars, 53 | cov_fun = switch( 54 | attr(cov_par(object), "cov_fun"), 55 | "exp" = "exponential", 56 | "mat32" = "Matern (nu = 3/2)", 57 | "mat52" = "Matern (nu = 5/2)", 58 | "sph" = "spherical", 59 | "wend1" = "Wendland (kappa = 1)", 60 | "wend2" = "Wendland (kappa = 2)"), 61 | optim.out = object$MLE$optim.output, 62 | logLik = logLik(object), 63 | taper = object$MLE$call.args$control$tapering, 64 | BIC = as.numeric(BIC(object)) 65 | ) 66 | 67 | ans$r.squared <- 1 - sum(ans$resids^2)/sum(ans$y.mean.resid^2) 68 | class(ans) <- "summary.SVC_mle" 69 | ans 70 | 71 | } 72 | 73 | 74 | #' @title Printing Method for \code{summary.SVC_mle} 75 | #' 76 | #' @param x \code{\link{summary.SVC_mle}} 77 | #' @param digits the number of significant digits to use when printing. 78 | #' @param ... further arguments 79 | #' 80 | #' 81 | #' @return The printed output of the summary in the console. 82 | #' @seealso \link{summary.SVC_mle} \link{SVC_mle} 83 | #' 84 | #' @importFrom stats printCoefmat sd 85 | #' @method print summary.SVC_mle 86 | #' @export 87 | print.summary.SVC_mle <- function(x, digits = max(3L, getOption("digits") - 3L), 88 | ...) { 89 | cat("\nCall:\n", paste(deparse(x$call), sep = "\n", collapse = "\n"), 90 | "\n\n", sep = "") 91 | cat(paste0("Fitting a GP-based SVC model with ", 92 | x$pX, 93 | " fixed effect(s) and ", 94 | x$pW, 95 | " SVC(s)\n")) 96 | cat(paste0("using ", x$nobs, " observations at ", 97 | x$nlocs, " different locations / coordinates.\n\n")) 98 | 99 | cat("Residuals:\n") 100 | print.default(format(summary(x$resids)[-4], digits = digits), print.gap = 2L, 101 | quote = FALSE) 102 | cat(paste0("\nResidual standard error: ", 103 | formatC(sd(x$resids), 104 | digits = digits), 105 | "\nMultiple R-squared: ", 106 | formatC(x$r.squared, 107 | digits = digits), 108 | ", BIC: ", formatC(x$BIC, 109 | digits = digits), "\n")) 110 | 111 | cat("\n\nCoefficients of fixed effect(s):\n") 112 | stats::printCoefmat(x$coefs, digits = digits, 113 | signif.stars = getOption("show.signif.stars"), 114 | na.print = "NA", ...) 115 | # print.default(format(x$coefs, digits = digits), print.gap = 2L, 116 | # quote = FALSE) 117 | 118 | # covpar <- as.data.frame(matrix(x$covpars[-(2*x$pW+1)], 119 | # ncol = 2, byrow = TRUE)) 120 | # colnames(covpar) <- c("range", "variance") 121 | # rownames(covpar) <- substr(names(x$covpars)[2*(1:x$pW)], 122 | # 1, nchar(names(x$covpars)[2*(1:x$pW)])-4) 123 | 124 | cat("\n\nCovariance parameters of the SVC(s):\n") 125 | stats::printCoefmat(x$covpar, digits = digits, 126 | signif.stars = getOption("show.signif.stars"), 127 | na.print = "NA", ...) 128 | 129 | cat(paste0("\nThe covariance parameters were estimated using \n", 130 | x$cov_fun, " covariance functions.\n")) 131 | if(is.null(x$taper)) { 132 | cat("No covariance tapering applied.\n") 133 | } else { 134 | cat(paste0("Covariance tapering range set to: ", 135 | formatC(x$taper, digits = digits), "\n")) 136 | } 137 | 138 | 139 | cat(paste0( 140 | "\n\nMLE:\nThe MLE terminated after ", 141 | x$optim.out$counts["function"], 142 | " function evaluations with convergence code ", 143 | x$optim.out$convergence, 144 | "\n(0 meaning that the optimization was succesful).\n" 145 | )) 146 | cat(paste0( 147 | "The final", if (attr(x$logLik, "penalized")) {" regularized"} else {""} , 148 | if (attr(x$logLik, "profileLik")) {" profile"} else {""}, 149 | " log likelihood value is " , 150 | formatC(x$logLik,digits = digits), ".\n" 151 | )) 152 | cat("\n") 153 | invisible(x) 154 | 155 | } 156 | -------------------------------------------------------------------------------- /R-pkg/man/SVC_mle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/SVC_mle.R 3 | \name{SVC_mle} 4 | \alias{SVC_mle} 5 | \alias{SVC_mle.default} 6 | \alias{SVC_mle.formula} 7 | \title{MLE of SVC model} 8 | \usage{ 9 | SVC_mle(...) 10 | 11 | \method{SVC_mle}{default}(y, X, locs, W = NULL, control = NULL, optim.control = list(), ...) 12 | 13 | \method{SVC_mle}{formula}( 14 | formula, 15 | data, 16 | RE_formula = NULL, 17 | locs, 18 | control = NULL, 19 | optim.control = list(), 20 | ... 21 | ) 22 | } 23 | \arguments{ 24 | \item{...}{further arguments} 25 | 26 | \item{y}{(\code{numeric(n)}) \cr 27 | Response vector.} 28 | 29 | \item{X}{(\code{matrix(n, p)}) \cr 30 | Design matrix. Intercept has to be added manually.} 31 | 32 | \item{locs}{(\code{matrix(n, d)}) \cr 33 | Locations in a \eqn{d}-dimensional space. May contain multiple 34 | observations at single location.} 35 | 36 | \item{W}{(\code{NULL} or \code{matrix(n, q)}) \cr 37 | If \code{NULL}, the same matrix as provided in \code{X} is used. This 38 | fits a full SVC model, i.e., each covariate effect is modeled with a mean 39 | and an SVC. In this case we have \eqn{p = q}. If optional matrix \code{W} 40 | is provided, SVCs are only modeled for covariates within matrix \code{W}.} 41 | 42 | \item{control}{(\code{list}) \cr 43 | Control paramaters given by \code{\link{SVC_mle_control}}.} 44 | 45 | \item{optim.control}{(\code{list}) \cr 46 | Control arguments for optimization function, see Details in 47 | \code{\link{optim}}.} 48 | 49 | \item{formula}{Formula describing the fixed effects in SVC model. The response, 50 | i.e. LHS of the formula, is not allowed to have functions such as \code{sqrt()} or \code{log()}.} 51 | 52 | \item{data}{data frame containing the observations} 53 | 54 | \item{RE_formula}{Formula describing the random effects in SVC model. 55 | Only RHS is considered. If \code{NULL}, the same RHS of argument \code{formula} for fixed effects is used.} 56 | } 57 | \value{ 58 | Object of class \code{SVC_mle} if \code{control$extract_fun = FALSE}, 59 | meaning that a MLE has been conducted. Otherwise, if \code{control$extract_fun = TRUE}, 60 | the function returns a list with two entries: 61 | \itemize{ 62 | \item \code{obj_fun}: the objective function used in the optimization 63 | \item \code{args}: the arguments to evaluate the objective function. 64 | } 65 | For further details, see description of \code{\link{SVC_mle_control}}. 66 | } 67 | \description{ 68 | Conducts a maximum likelihood estimation (MLE) for a Gaussian 69 | process-based spatially varying coefficient model as described in 70 | Dambon et al. (2021) \doi{10.1016/j.spasta.2020.100470}. 71 | } 72 | \details{ 73 | The GP-based SVC model is defined with some abuse of notation as: 74 | 75 | \deqn{y(s) = X \mu + W \eta (s) + \epsilon(s)} 76 | 77 | where: 78 | \itemize{ 79 | \item \eqn{y} is the response (vector of length \eqn{n}) 80 | \item \eqn{X} is the data matrix for the fixed effects covariates. The 81 | dimensions are \eqn{n} times \eqn{p}. This leads to \eqn{p} fixed effects. 82 | \item \eqn{\mu} is the vector containing the fixed effects 83 | \item W is the data matrix for the SVCs modeled by GPs. The dimensions are 84 | \eqn{n} times \eqn{q}. This lead to \eqn{q} SVCs in the model. 85 | \item \eqn{\eta} are the SVCs represented by a GP. 86 | \item \eqn{\epsilon} is the nugget effect 87 | } 88 | 89 | The MLE is an numeric optimization that runs \code{\link[stats]{optim}} or 90 | (if parallelized) \code{\link[optimParallel]{optimParallel}}. 91 | 92 | You can call the function in two ways. Either, you define the model matrices 93 | yourself and provide them using the arguments \code{X} and \code{W}. As usual, 94 | the individual columns correspond to the fixed and random effects, i.e., the 95 | Gaussian processes, respectively. The second way is to call the function with 96 | formulas, like you would in \code{\link[stats]{lm}}. From the \code{data.frame} 97 | provided in argument \code{data}, the respective model matrices as described 98 | above are implicitly built. Using simple arguments \code{formula} and 99 | \code{RE_formula} with \code{data} column names, we can decide which 100 | covariate is modeled with a fixed or random effect (SVC). 101 | 102 | Note that similar to model matrix call from above, if the \code{RE_formula} 103 | is not provided, we use the one as in argument \code{formula}. Further, note 104 | that the intercept is implicitly constructed in the model matrix if not 105 | prohibited. 106 | } 107 | \examples{ 108 | ## ---- toy example ---- 109 | ## We use the sampled, i.e., one dimensional SVCs 110 | str(SVCdata) 111 | # sub-sample data to have feasible run time for example 112 | set.seed(123) 113 | id <- sample(length(SVCdata$locs), 50) 114 | 115 | ## SVC_mle call with matrix arguments 116 | fit <- with(SVCdata, SVC_mle( 117 | y[id], X[id, ], locs[id], 118 | control = SVC_mle_control(profileLik = TRUE, cov.name = "mat32"))) 119 | 120 | ## SVC_mle call with formula 121 | df <- with(SVCdata, data.frame(y = y[id], X = X[id, -1])) 122 | fit <- SVC_mle( 123 | y ~ X, data = df, locs = SVCdata$locs[id], 124 | control = SVC_mle_control(profileLik = TRUE, cov.name = "mat32") 125 | ) 126 | class(fit) 127 | 128 | summary(fit) 129 | 130 | \donttest{ 131 | ## ---- real data example ---- 132 | require(sp) 133 | ## get data set 134 | data("meuse", package = "sp") 135 | 136 | # construct data matrix and response, scale locations 137 | y <- log(meuse$cadmium) 138 | X <- model.matrix(~1+dist+lime+elev, data = meuse) 139 | locs <- as.matrix(meuse[, 1:2])/1000 140 | 141 | 142 | ## starting MLE 143 | # the next call takes a couple of seconds 144 | fit <- SVC_mle( 145 | y = y, X = X, locs = locs, 146 | # has 4 fixed effects, but only 3 random effects (SVC) 147 | # elev is missing in SVC 148 | W = X[, 1:3], 149 | control = SVC_mle_control( 150 | # inital values for 3 SVC 151 | # 7 = (3 * 2 covariance parameters + nugget) 152 | init = c(rep(c(0.4, 0.2), 3), 0.2), 153 | profileLik = TRUE 154 | ) 155 | ) 156 | 157 | ## summary and residual output 158 | summary(fit) 159 | plot(fit) 160 | 161 | ## predict 162 | # new locations 163 | newlocs <- expand.grid( 164 | x = seq(min(locs[, 1]), max(locs[, 1]), length.out = 30), 165 | y = seq(min(locs[, 2]), max(locs[, 2]), length.out = 30)) 166 | # predict SVC for new locations 167 | SVC <- predict(fit, newlocs = as.matrix(newlocs)) 168 | # visualization 169 | sp.SVC <- SVC 170 | coordinates(sp.SVC) <- ~loc_1+loc_2 171 | spplot(sp.SVC, colorkey = TRUE) 172 | } 173 | } 174 | \references{ 175 | Dambon, J. A., Sigrist, F., Furrer, R. (2021) 176 | \emph{Maximum likelihood estimation of spatially varying coefficient 177 | models for large data with an application to real estate price prediction}, 178 | Spatial Statistics \doi{10.1016/j.spasta.2020.100470} 179 | } 180 | \seealso{ 181 | \code{\link{predict.SVC_mle}} 182 | } 183 | \author{ 184 | Jakob Dambon 185 | } 186 | -------------------------------------------------------------------------------- /R-pkg/man/SVC_mle_control.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/SVC_mle.R 3 | \name{SVC_mle_control} 4 | \alias{SVC_mle_control} 5 | \alias{SVC_mle_control.default} 6 | \alias{SVC_mle_control.SVC_mle} 7 | \title{Set Parameters for \code{SVC_mle}} 8 | \usage{ 9 | SVC_mle_control(...) 10 | 11 | \method{SVC_mle_control}{default}( 12 | cov.name = c("exp", "sph", "mat32", "mat52", "wend1", "wend2"), 13 | tapering = NULL, 14 | parallel = NULL, 15 | init = NULL, 16 | lower = NULL, 17 | upper = NULL, 18 | save.fitted = TRUE, 19 | profileLik = FALSE, 20 | mean.est = c("GLS", "OLS"), 21 | pc.prior = NULL, 22 | extract_fun = FALSE, 23 | hessian = TRUE, 24 | dist = list(method = "euclidean"), 25 | parscale = TRUE, 26 | ... 27 | ) 28 | 29 | \method{SVC_mle_control}{SVC_mle}(object, ...) 30 | } 31 | \arguments{ 32 | \item{...}{Further Arguments yet to be implemented} 33 | 34 | \item{cov.name}{(\code{character(1)}) \cr 35 | Name of the covariance function of the GPs. Currently, the following are 36 | implemented: \code{"exp"} for the exponential, \code{"sph"} for 37 | spherical, \code{"mat32"} and \code{"mat52"} for Matern class covariance 38 | functions with smoothness 3/2 or 5/2, as well as \code{"wend1"} and 39 | \code{"wend2"} for Wendland class covariance functions with kappa 1 or 2.} 40 | 41 | \item{tapering}{(\code{NULL} or \code{numeric(1)}) \cr 42 | If \code{NULL}, no tapering is applied. If a scalar is given, covariance 43 | tapering with this taper range is applied, for all Gaussian processes 44 | modeling the SVC. Only defined for Matern class covariance functions, 45 | i.e., set \code{cov.name} either to \code{"exp"}, \code{"mat32"}, or 46 | \code{"mat52"}.} 47 | 48 | \item{parallel}{(\code{NULL} or \code{list}) \cr 49 | If \code{NULL}, no parallelization is applied. If cluster has been 50 | established, define arguments for parallelization with a list, see 51 | documentation of \code{\link[optimParallel]{optimParallel}}. See Examples.} 52 | 53 | \item{init}{(\code{NULL} or \code{numeric(2q+1+p*as.numeric(profileLik))}) \cr 54 | Initial values for optimization procedure. If \code{NULL} is given, an 55 | initial vector is calculated (see Details). Otherwise, the vector is 56 | assumed to consist of q-times (alternating) range and variance, 57 | the nugget variance and if \code{profileLik = TRUE} p mean effects.} 58 | 59 | \item{lower}{(\code{NULL} or \code{numeric(2q+1+p*as.numeric(profileLik))}) \cr 60 | Lower bound for \code{init} in \code{optim}. Default \code{NULL} calculates 61 | the lower bounds (see Details).} 62 | 63 | \item{upper}{(\code{NULL} or \code{numeric(2q+1+p*as.numeric(profileLik))}) \cr 64 | Upper bound for \code{init} in \code{optim}. Default \code{NULL} calculates 65 | the upper bounds (see Details).} 66 | 67 | \item{save.fitted}{(\code{logical(1)}) \cr 68 | If \code{TRUE}, calculates the fitted values and residuals after MLE and 69 | stores them. This is necessary to call \code{\link{residuals}} and 70 | \code{\link{fitted}} methods afterwards.} 71 | 72 | \item{profileLik}{(\code{logical(1)}) \cr 73 | If \code{TRUE}, MLE is done over profile Likelihood of covariance 74 | parameters.} 75 | 76 | \item{mean.est}{(\code{character(1)}) \cr 77 | If \code{profileLik = TRUE}, the means have to be estimated seperately for 78 | each step. \code{"GLS"} uses the generalized least square estimate while 79 | \code{"OLS"} uses the ordinary least squares estimate.} 80 | 81 | \item{pc.prior}{(\code{NULL} or \code{numeric(4)}) \cr 82 | If numeric vector is given, penalized complexity priors are applied. The 83 | order is \eqn{\rho_0, \alpha_\rho, \sigma_0, \alpha_\sigma} to give some 84 | prior believes for the range and the standard deviation of GPs, such that 85 | \eqn{P(\rho < \rho_0) = \alpha_\rho, P(\sigma > \sigma_0) = \alpha_\sigma}. 86 | This regulates the optimization process. Currently, only supported for 87 | GPs with of Matérn class covariance functions. Based on the idea by 88 | Fulgstad et al. (2018) \doi{10.1080/01621459.2017.1415907}.} 89 | 90 | \item{extract_fun}{(\code{logical(1)}) \cr 91 | If \code{TRUE}, the function call of \code{\link{SVC_mle}} stops before 92 | the MLE and gives back the objective function of the MLE as well as all 93 | used arguments. If \code{FALSE}, regular MLE is conducted.} 94 | 95 | \item{hessian}{(\code{logical(1)}) \cr 96 | If \code{TRUE}, Hessian matrix is computed, see \link[stats]{optim}. This 97 | required to give the standard errors for covariance parameters and to do 98 | a Wald test on the variances, see \code{\link{summary.SVC_mle}}.} 99 | 100 | \item{dist}{(\code{list}) \cr 101 | List containing the arguments of \link[stats]{dist} or 102 | \link[spam]{nearest.dist}. This controls 103 | the method of how the distances and therefore dependency structures are 104 | calculated. The default gives Euclidean distances in a \eqn{d}-dimensional 105 | space. Further editable arguments are \code{p, miles, R}, see respective 106 | help files of \link[stats]{dist} or \link[spam]{nearest.dist}.} 107 | 108 | \item{parscale}{(\code{logical(1)}) \cr 109 | Triggers parameter scaling within the optimization in \link[stats]{optim}. 110 | If \code{TRUE}, the optional parameter scaling in \code{optim.control} in 111 | function \code{\link{SVC_mle}} is overwritten by the initial value used in 112 | the numeric optimization. The initial value is either computed from the 113 | data or provided by the user, see \code{init} argument above or Details 114 | below. Note that we check whether the initial values are unequal to zero. 115 | If they are zero, the corresponding scaling factor is 0.001. If 116 | \code{FALSE}, the \code{parscale} argument in \code{optim.control} is let 117 | unchanged.} 118 | 119 | \item{object}{(\code{SVC_mle}) \cr 120 | The function then extracts the control settings from the function call 121 | used to compute in the given \code{SVC_mle} object.} 122 | } 123 | \value{ 124 | A list with which \code{\link{SVC_mle}} can be controlled. 125 | } 126 | \description{ 127 | Function to set up control parameters for \code{\link{SVC_mle}}. 128 | In the following, we assume the GP-based SVC model to have \eqn{q} GPs which 129 | model the SVCs and \eqn{p} fixed effects. 130 | } 131 | \details{ 132 | If not provided, the initial values as well as the lower and upper 133 | bounds are calculated given the provided data. In particular, we require 134 | the median distance between observations, the variance of the response and, 135 | the ordinary least square (OLS) estimates, see \code{\link{init_bounds_optim}}. 136 | 137 | The argument \code{extract_fun} is useful, when one wants to modify 138 | the objective function. Further, when trying to parallelize the 139 | optimization, it is useful to check whether a single evaluation of the 140 | objective function takes longer than 0.05 seconds to evaluate, 141 | cf. Gerber and Furrer (2019) \doi{10.32614/RJ-2019-030}. Platform specific 142 | issues can be sorted out by the user by setting up their own optimization. 143 | } 144 | \examples{ 145 | control <- SVC_mle_control(init = rep(0.3, 10)) 146 | # or 147 | control <- SVC_mle_control() 148 | control$init <- rep(0.3, 10) 149 | 150 | \donttest{ 151 | # Code for setting up parallel computing 152 | require(parallel) 153 | # exchange number of nodes (1) for detectCores()-1 or appropriate number 154 | cl <- makeCluster(1, setup_strategy = "sequential") 155 | clusterEvalQ( 156 | cl = cl, 157 | { 158 | library(spam) 159 | library(varycoef) 160 | }) 161 | # use this list for parallel argument in SVC_mle_control 162 | parallel.control <- list(cl = cl, forward = TRUE, loginfo = TRUE) 163 | # SVC_mle goes here ... 164 | # DO NOT FORGET TO STOP THE CLUSTER! 165 | stopCluster(cl); rm(cl) 166 | } 167 | } 168 | \seealso{ 169 | \code{\link{SVC_mle}} 170 | } 171 | \author{ 172 | Jakob Dambon 173 | } 174 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | varycoef icon 5 | 6 | `varycoef`: An R Package to Model Spatially Varying Coefficients using Gaussian Processes 7 | ================================================================================ 8 | 9 | 10 | [![CRAN](http://www.r-pkg.org/badges/version/varycoef?color=blue)](http://cran.rstudio.com/package=varycoef) [![Downloads](http://cranlogs.r-pkg.org/badges/grand-total/varycoef?color=green)](http://www.r-pkg.org/pkg/varycoef) 11 | 12 | ## About 13 | 14 | The R package `varycoef` is the software implementation of **Gaussian process-based spatially varying coefficient models** by [Dambon et al. (2021a)](https://doi.org/10.1016/j.spasta.2020.100470). It extends linear regression models such that the coefficients are depending on some coordinates in a `d` dimensional space, i.e., the coefficient `b_j` for a covariate `j` is depending on coordinates `s` and therefore of the form `b_j(s)`. These coefficients are modeled using Gaussian processes. In most applications, the coordinates `s` tend to be observation locations like longitude and latitude (see [Dambon et al. (2022)](https://doi.org/10.1186/s41937-021-00080-2) as an example). However, the concept can be extended in the number of dimensions or, say, using observation time points to model time-varying coefficients. 15 | 16 | The method relies on maximum likelihood estimation. It has been optimized to work with large data sets by applying covariance tapering by [Furrer et al. (2006)](https://www.jstor.org/stable/27594195) if necessary and allows for a moderate number of spatially varying coefficients. The R package contains methods to estimate Gaussian process-based (spatially) varying coefficient models, (spatially) predict coefficients as well as the response, and variable selection methods. Latter are based on [Dambon et al. (2021b)](https://doi.org/10.1080/13658816.2022.2097684). 17 | 18 | ## Getting Started 19 | 20 | To install it, run 21 | 22 | ``` 23 | devtools::install_github("jakobdambon/varycoef") 24 | ``` 25 | 26 | for the latest version on this repository or download it from [CRAN](https://cran.r-project.org/web/packages/varycoef/index.html). 27 | 28 | ## Model Assumptions 29 | 30 | **Note: The exact definition of the model is given in [Dambon et al. (2021a)](https://doi.org/10.1016/j.spasta.2020.100470).** 31 | 32 | ### Linear Model 33 | 34 | Let `y` be the response vector, let `X` be the covariate matrix, and let `xi` be the error term sampled from a zero-mean normal distribution with variance `s2`. Then the linear model is given by 35 | 36 | ``` 37 | y = Xb + xi 38 | ``` 39 | 40 | with coefficient vector `b`. The coefficients are also called *fixed effects*. 41 | 42 | ### Spatially Varying Coefficients 43 | 44 | We now allow the coefficients to vary from their respective mean. Let `e(s)` contain the location-dependent differences. In a first step, with some slight abuse of notation, the linear model from above is extended by: 45 | 46 | ``` 47 | y = X(b + e(s)) + xi 48 | ``` 49 | 50 | Note that not all coefficients necessarily must be varying. Therefore, we introduce a second covariate matrix `W` to specify which coefficients are spatially varying. In the case where all coefficients are varying, we have `W = X`. Again with some abuse of notation, we have the SVC model: 51 | 52 | ``` 53 | y = Xb + We(s) + xi 54 | ``` 55 | 56 | ### Gaussian Process-based Coefficients 57 | 58 | We assume that the spatially varying coefficients are defined by Gaussian processes. That is, the deviations per covariate `e_k(s)` are defined as a zero-mean Gaussian process defined by some covariance function `c(d, par)` that models the spatial dependence between observations using the pairwise distances. Each coefficient is parameterized by a tuple of parameters `par` that consists of a range and variance. One main assumption of the model is that the individual coefficients per covariate, i.e., the individual Gaussian processes, are mutually independent and independent of the error. 59 | 60 | ### Connection to Mixed Effect Models 61 | 62 | For a finite number of observations `n`, the model can be expressed as a so-called mixed effect model. That is, using the covariance functions of the Gaussian processes and the distance matrix of the observations, we can express each `e_k(s)` as a multivariate, zero-mean normal distribution. Another common name for these effects are random effects. Together with the fixed effects from an ordinary linear model, we receive a so-called mixed effect model. The assumption of mutual independence between the Gaussian allows an easy construction of the joint covariance matrix `S_y` of the response `y`. 63 | 64 | ## Examples 65 | 66 | The R package contains a vignette, which is also linked here: 67 | 68 | - [01_Introduction](https://htmlpreview.github.io/?https://github.com/jakobdambon/varycoef/blob/master/examples/01_Introduction.html) 69 | 70 | 71 | ## Version History-Pre GitHub Releases 72 | 73 | | Version | Functionality | Release Date | 74 | |----------------------|---------------------------------|-----------------| 75 | | 0.3.5 | Bringing back to CRAN after some failed UT in ATLAS | 26th of March 2025 | 76 | | 0.3.4 | | 17th of September 2022 | 77 | | 0.3.3 | Removed some dependencies to `RandomFields` | 1st of June 2022 | 78 | | 0.3.2 | Parscale option in SVC_mle_control | 19th of July 2021 | 79 | | 0.3.1 | New methods (summary output), pre JSS Submission | 12th of May 2021 | 80 | | 0.3.0 | Joint variable selection method available on CRAN | 13th of January 2021 | 81 | | 0.2.10 | parallelization using `optimParallel`, citation info, orcID | 23rd of February 2020 | 82 | | 0.2.9 | Final CRAN version | 10th of October 2019 | 83 | | 0.2.8 | Revisions for CRAN submission | 8th of October 2019 | 84 | | 0.2.7 | add summary, printing, plotting functions, and other methods for `SVC_mle` objects | 16th of September 2019 | 85 | | 0.2.6 | predictive variance | 5th of September 2019 | 86 | | 0.2.5 | new handling of multiple observations | 10th of July 2019 | 87 | | 0.2.4 | add SVC_mle.control for SVC_mle object, update vignette | 10th of July 2019 | 88 | | 0.2.3 | add profile LL MLE, add functions to extract coefs and covariance parameters | 10th of July 2019 | 89 | | 0.2.2 | BUGFIX: Mulitple Observations at locations. New residuals and fitted methods for SVC_mle, SVC_mle with formula call, warning on call without control | 5th of June 2019 | 90 | | 0.2.1 | enable tapering | 23rd of April 2019 | 91 | | 0.2.0 | Seperate fixed and random effects | 12th of April 2019 | 92 | -------------------------------------------------------------------------------- /R-pkg/R/predict-SVC_mle.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | #' Prediction of SVCs (and response variable) 4 | #' 5 | #' @param object (\code{SVC_mle}) \cr 6 | #' Model obtained from \code{\link{SVC_mle}} function call. 7 | #' @param newlocs (\code{NULL} or \code{matrix(n.new, 2)}) \cr 8 | #' If \code{NULL}, then function uses observed locations of model to estimate 9 | #' SVCs. Otherwise, these are the new locations the SVCs are predicted for. 10 | #' @param newX (\code{NULL} or \code{matrix(n.new, q)}) \cr 11 | #' If provided (together with \code{newW}), the function also returns the 12 | #' predicted response variable. 13 | #' @param newW (\code{NULL} or \code{matrix(n.new, p)}) \cr 14 | #' If provided (together with \code{newX}), the function also returns the 15 | #' predicted response variable. 16 | #' @param newdata (\code{NULL} or \code{data.frame(n.new, p)}) \cr 17 | #' This argument can be used, when the \code{SVC_mle} function has been called 18 | #' with an formula, see examples. 19 | #' @param compute.y.var (\code{logical(1)}) \cr 20 | #' If \code{TRUE} and the response is being estimated, the predictive 21 | #' variance of each estimate will be computed. 22 | #' @param ... further arguments 23 | #' 24 | #' @return The function returns a data frame of \code{n.new} rows and with 25 | #' columns 26 | #' \itemize{ 27 | #' \item \code{SVC_1, ..., SVC_p}: the predicted SVC at locations \code{newlocs}. 28 | #' \item \code{y.pred}, if \code{newX} and \code{newW} are provided 29 | #' \item \code{y.var}, if \code{newX} and \code{newW} are provided and 30 | #' \code{compute.y.var} is set to \code{TRUE}. 31 | #' \item \code{loc_x, loc_y}, the locations of the predictions 32 | #' } 33 | #' 34 | #' @seealso \code{\link{SVC_mle}} 35 | #' 36 | #' @author Jakob Dambon 37 | #' @references Dambon, J. A., Sigrist, F., Furrer, R. (2021) 38 | #' \emph{Maximum likelihood estimation of spatially varying coefficient 39 | #' models for large data with an application to real estate price prediction}, 40 | #' Spatial Statistics \doi{10.1016/j.spasta.2020.100470} 41 | #' 42 | #' @examples 43 | #' ## ---- toy example ---- 44 | #' ## We use the sampled, i.e., one dimensional SVCs 45 | #' str(SVCdata) 46 | #' # sub-sample data to have feasible run time for example 47 | #' set.seed(123) 48 | #' id <- sample(length(SVCdata$locs), 50) 49 | #' 50 | #' ## SVC_mle call with matrix arguments 51 | #' fit_mat <- with(SVCdata, SVC_mle( 52 | #' y[id], X[id, ], locs[id], 53 | #' control = SVC_mle_control(profileLik = TRUE, cov.name = "mat32"))) 54 | #' 55 | #' ## SVC_mle call with formula 56 | #' df <- with(SVCdata, data.frame(y = y[id], X = X[id, -1])) 57 | #' fit_form <- SVC_mle( 58 | #' y ~ X, data = df, locs = SVCdata$locs[id], 59 | #' control = SVC_mle_control(profileLik = TRUE, cov.name = "mat32") 60 | #' ) 61 | #' 62 | #' ## prediction 63 | #' 64 | #' # predicting SVCs 65 | #' predict(fit_mat, newlocs = 1:2) 66 | #' predict(fit_form, newlocs = 1:2) 67 | #' 68 | #' # predicting SVCs and response providing new covariates 69 | #' predict( 70 | #' fit_mat, 71 | #' newX = matrix(c(1, 1, 3, 4), ncol = 2), 72 | #' newW = matrix(c(1, 1, 3, 4), ncol = 2), 73 | #' newlocs = 1:2 74 | #' ) 75 | #' predict(fit_form, newdata = data.frame(X = 3:4), newlocs = 1:2) 76 | #' 77 | #' @import spam 78 | #' @importFrom stats sd model.matrix 79 | #' @export 80 | predict.SVC_mle <- function( 81 | object, 82 | newlocs = NULL, 83 | newX = NULL, 84 | newW = NULL, 85 | newdata = NULL, 86 | compute.y.var = FALSE, 87 | ... 88 | ) { 89 | # extract parameters 90 | mu <- coef(object) 91 | cov.par <- cov_par(object) 92 | 93 | 94 | q <- dim(as.matrix(object$MLE$call.args$W))[2] 95 | p <- dim(as.matrix(object$MLE$call.args$X))[2] 96 | n <- length(object$MLE$call.args$y) 97 | locs <- object$MLE$call.args$locs 98 | tapering <- object$MLE$call.args$control$tapering 99 | dist_args <- object$MLE$call.args$control$dist 100 | 101 | # define distance matrices 102 | d <- do.call( 103 | own_dist, 104 | c(list(x = locs, taper = tapering), dist_args) 105 | ) 106 | 107 | # if no new locations are given, predict for training data 108 | if (is.null(newlocs)) { 109 | newlocs <- object$MLE$call.args$locs 110 | d_cross <- d 111 | n.new <- n 112 | } else { 113 | newlocs <- as.matrix(newlocs) 114 | n.new <- nrow(newlocs) 115 | d_cross <- do.call( 116 | own_dist, 117 | c(list(x = newlocs, y = locs, taper = tapering), dist_args) 118 | ) 119 | } 120 | 121 | # covariance function (not tapered) 122 | raw.cf <- MLE.cov.func(object$MLE$call.args$control$cov.name) 123 | 124 | if (is.null(object$MLE$call.args$control$taper)) { 125 | taper <- NULL 126 | 127 | # cross-covariance (newlocs and locs) 128 | cf_cross <- function(x) raw.cf(d_cross, x) 129 | 130 | } else { 131 | taper <- get_taper( 132 | object$MLE$call.args$control$cov.name, d, tapering 133 | ) 134 | 135 | taper_cross <- get_taper( 136 | object$MLE$call.args$control$cov.name, d_cross, tapering 137 | ) 138 | 139 | # cross-covariance (newlocs and locs) 140 | cf_cross <- function(x) raw.cf(d_cross, x)*taper_cross 141 | } 142 | 143 | # covariance y 144 | cf <- function(x) raw.cf(d, x) 145 | cov_y <- object$MLE$comp.args$Sigma_final 146 | 147 | 148 | # cross-covariance beta' y 149 | cov_b_y <- Sigma_b_y( 150 | x = cov.par, 151 | cov.func = cf_cross, 152 | W = as.matrix(object$MLE$call.args$W), 153 | n.new = n.new 154 | ) 155 | 156 | eff <- cov_b_y %*% 157 | solve(cov_y, object$MLE$call.args$y - object$MLE$call.args$X %*% mu) 158 | eff <- matrix(eff, ncol = q) 159 | 160 | # if newdata is given and formula is present in SVC_mle object, extract 161 | # newX and newW (and overwrite provided ones) 162 | if (!is.null(newdata)) { 163 | if (!is.null(object$formula)) { 164 | if (!is.null(newX)) { 165 | warning("Formula and 'newdata' provided: 'newX' argument was overwritten!") 166 | } 167 | if (!is.null(newW)) { 168 | warning("Formula and 'newdata' provided: 'newW' argument was overwritten!") 169 | } 170 | # create covariates 171 | # drop response from fromula 172 | formula <- drop_response(object$formula) 173 | RE_formula <- drop_response(object$RE_formula) 174 | 175 | newX <- as.matrix(stats::model.matrix(formula, data = newdata)) 176 | newW <- as.matrix(stats::model.matrix(RE_formula, data = newdata)) 177 | } else { 178 | warning("Data provided bu object has not been trained by a formula.\n 179 | Cannot compute fixed and random effect covariates.") 180 | } 181 | } 182 | 183 | if (!is.null(newX) & !is.null(newW)) { 184 | # Do dimensions for training and prediction data match? 185 | stopifnot(q == ncol(newW), p == ncol(newX)) 186 | y.pred <- apply(newW * eff, 1, sum) + newX %*% mu 187 | 188 | # computation of standard deviation fro each observation. 189 | if (compute.y.var) { 190 | # Have to compute 191 | # 192 | # var.y = Sigma_ynew - Sigma_ynew_y Sigma_y^-1 Sigma_y_ynew 193 | # 194 | # Sigma_ynew = A 195 | # Sigma_ynew_y = B 196 | # Sigma_y = C 197 | # Sigma_y_ynew = D = t(C) 198 | 199 | 200 | # Part B: 201 | cov_ynew_y <- Sigma_y_y( 202 | cov.par, 203 | cov.func = cf_cross, 204 | X = object$MLE$call.args$W, 205 | newX = newW 206 | ) 207 | 208 | # Part A: 209 | d_new <- if (n.new == 1) { 210 | as.matrix(0) 211 | } else { 212 | do.call( 213 | own_dist, 214 | c(list(x = newlocs, taper = tapering), dist_args) 215 | ) 216 | } 217 | 218 | if (is.null(tapering)) { 219 | outer.newW <- lapply(1:q, function(k) { 220 | (newW[, k]%o%newW[, k]) }) 221 | taper_new <- NULL 222 | } else { 223 | taper_new <- get_taper( 224 | object$MLE$call.args$control$cov.name, d_new, tapering 225 | ) 226 | 227 | outer.newW <- lapply(1:q, function(k) { 228 | (newW[, k]%o%newW[, k]) * taper_new 229 | }) 230 | } 231 | 232 | # cross-covariance (newlocs and locs) 233 | cf_new <- function(x) raw.cf(d_new, x) 234 | 235 | cov_ynew <- Sigma_y( 236 | cov.par, 237 | cf_new, 238 | outer.W = outer.newW, 239 | taper = taper_new 240 | ) 241 | 242 | # Part C: already calculated with cov_y 243 | 244 | # Computation of variance of y 245 | var.y <- diag(cov_ynew) - diag(cov_ynew_y %*% solve(cov_y, t(cov_ynew_y))) 246 | 247 | # form out put 248 | out <- as.data.frame(cbind(eff, y.pred, var.y, newlocs)) 249 | colnames(out) <- c(paste0("SVC_", 1:ncol(eff)), "y.pred", "y.var", paste0("loc_", 1:ncol(newlocs))) 250 | } else { 251 | out <- as.data.frame(cbind(eff, y.pred, newlocs)) 252 | colnames(out) <- c(paste0("SVC_", 1:ncol(eff)), "y.pred", paste0("loc_", 1:ncol(newlocs))) 253 | } 254 | 255 | 256 | } else { 257 | 258 | if (compute.y.var) 259 | warning("Please provide 'newX' and 'newW' to predict y and its variance.") 260 | 261 | out <- as.data.frame(cbind(eff, newlocs)) 262 | colnames(out) <- c(paste0("SVC_", 1:ncol(eff)), paste0("loc_", 1:ncol(newlocs))) 263 | } 264 | # two ensure that predict calls with formula and matrix are identical 265 | row.names(out) <- as.character(row.names(out)) 266 | return(out) 267 | } 268 | 269 | -------------------------------------------------------------------------------- /R-pkg/R/SVC_selection.R: -------------------------------------------------------------------------------- 1 | BW_pen <- function(x, X, cov_func, outer.W, taper) { 2 | 2*(eff_dof(x, X, cov_func, outer.W, taper) + 3 | 2*length(outer.W) + 1) 4 | } 5 | 6 | VB_pen <- function(x, X, cov_func, outer.W, taper) { 7 | n <- nrow(X) 8 | p <- ncol(X) 9 | q <- length(outer.W) 10 | eff.dof <- eff_dof(x, X, cov_func, outer.W, taper) 11 | 12 | (2*n)/(n-p-2)*(eff.dof + 1 - (eff.dof - p)/(n-p)) 13 | } 14 | 15 | 16 | #' @importFrom glmnet glmnet coef.glmnet 17 | CD_mu <- function( 18 | theta.k, 19 | mle.par, 20 | obj.fun, 21 | lambda.mu, 22 | adaptive = FALSE 23 | ) { 24 | ## dimensions 25 | p <- ncol(obj.fun$args$X) 26 | q <- (length(theta.k)-1)/2 27 | 28 | ## transform from GLS to OLS 29 | # compute covariance matrix and Cholesky-decomp thereof 30 | C.mat <- Sigma_y(theta.k, obj.fun$args$cov_func, obj.fun$args$outer.W) 31 | R <- spam::chol(C.mat) 32 | R.t.inv <- solve(t(R)) 33 | # transform 34 | y.tilde <- R.t.inv %*% obj.fun$args$y 35 | X.tilde <- R.t.inv %*% obj.fun$args$X 36 | 37 | # MLE / OLS estimate 38 | # mu.MLE <- coef(lm(y.tilde~X.tilde-1)) 39 | 40 | ## run (adaptive) LASSO 41 | LASSO <- glmnet::glmnet( 42 | y = y.tilde, 43 | x = X.tilde, 44 | lambda = lambda.mu, 45 | alpha = 1, 46 | intercept = FALSE, 47 | penalty.factor = if (adaptive) { 48 | 1/abs(mle.par) 49 | } else { 50 | rep(1, p) 51 | } 52 | ) 53 | 54 | # without 0 for intercept 55 | as.numeric(coef(LASSO))[1+(1:p)] 56 | } 57 | 58 | CD_theta <- function( 59 | mu.k, theta.k, # theta.k only needed as initial value 60 | mle.par, 61 | obj.fun, 62 | lambda.theta, 63 | parallel.control, 64 | optim.args = list(), 65 | adaptive = FALSE 66 | ) { 67 | ## dimensions 68 | q <- (length(theta.k)-1)/2 69 | n <- length(obj.fun$args$y) 70 | 71 | # update profile log-lik. function using new mu.k 72 | obj.fun$args$mean.est <- mu.k 73 | 74 | fn <- function(x) { 75 | do.call(obj.fun$obj_fun, c(list(x = x), obj.fun$args)) 76 | } 77 | 78 | # adaptive LASSO? 79 | if (adaptive) { 80 | # # MLE needed for adaptive penalties 81 | # MLE <- optimParallel::optimParallel( 82 | # theta.k, fn = fn, 83 | # lower = c(rep(c(1e-10, 0), q), 1e-10), 84 | # parallel = parallel.control, 85 | # control = list( 86 | # parscale = ifelse(abs(theta.k) < 1e-9, 1, abs(theta.k)) 87 | # ) 88 | # ) 89 | # MLE.theta <- MLE$par 90 | 91 | 92 | # adaptive penalties 93 | lambda2 <- ifelse( 94 | abs(mle.par[2*(1:q)]) < 1e-9, 95 | 1e99, 96 | lambda.theta/abs(mle.par[2*(1:q)]) 97 | ) 98 | } else { 99 | lambda2 <- lambda.theta 100 | } 101 | 102 | 103 | # objective function (f in paper) 104 | pl <- function(x) { 105 | fn(x) + 2*n*sum(lambda2*abs(x[2*(1:q)])) 106 | } 107 | 108 | # PMLE: use last known theta.k as initial value 109 | PMLE <- do.call( 110 | what = optimParallel::optimParallel, 111 | args = c( 112 | list( 113 | par = theta.k, 114 | fn = pl, 115 | parallel = parallel.control 116 | ), 117 | optim.args 118 | ) 119 | ) 120 | 121 | # return covariance parameters theta.k+1 122 | PMLE$par 123 | } 124 | 125 | 126 | PMLE_CD <- function( 127 | lambda, 128 | mle.par, 129 | obj.fun, 130 | parallel.control, 131 | optim.args = list(), 132 | adaptive = FALSE, 133 | return.par = FALSE, 134 | IC.type = c("BIC", "cAIC_BW", "cAIC_VB"), 135 | CD.conv = list(N = 20L, delta = 1e-6, logLik = TRUE) 136 | ) { 137 | ## dimensions 138 | n <- nrow(obj.fun$args$X) 139 | p <- ncol(obj.fun$args$X) 140 | q <- length(obj.fun$args$outer.W) 141 | 142 | ## initialize output matrix 143 | # covariance parameters 144 | c.par <- matrix(NA_real_, nrow = CD.conv$N + 1, ncol = 2*q+1) 145 | c.par[1, ] <- mle.par 146 | # mean parameter 147 | mu.par <- matrix(NA_real_, nrow = CD.conv$N + 1, ncol = p) 148 | I.C.mat <- solve( 149 | Sigma_y(mle.par, obj.fun$args$cov_func, obj.fun$args$outer.W) 150 | ) 151 | B <- crossprod(obj.fun$args$X, I.C.mat) 152 | mu.par[1, ] <- solve(B %*% obj.fun$args$X) %*% B %*% obj.fun$args$y 153 | # log-likelihood 154 | loglik.CD <- rep(NA_real_, CD.conv$N + 1) 155 | 156 | # update mean parameter for log-likelihood function 157 | obj.fun$args$mean.est <- mu.par[1, ] 158 | # initialize log-likelihood function 159 | ll <- function(x) { 160 | (-1/2) * do.call(obj.fun$obj_fun, c(list(x = x), obj.fun$args)) 161 | } 162 | loglik.CD[1] <- ll(c.par[1, ]) 163 | 164 | ## cyclic coordinate descent 165 | for (k in 1:CD.conv$N) { 166 | 167 | # Step 1: Updating mu 168 | mu.par[k+1, ] <- CD_mu( 169 | theta.k = c.par[k, ], 170 | mle.par = mu.par[1, ], 171 | obj.fun = obj.fun, 172 | lambda.mu = lambda[1], 173 | adaptive = adaptive 174 | ) 175 | 176 | # Step 2: Updating theta 177 | c.par[k+1, ] <- CD_theta( 178 | mu.k = mu.par[k+1, ], 179 | theta.k = c.par[k, ], # only used as an initial value for optimization 180 | mle.par = c.par[1, ], 181 | obj.fun = obj.fun, 182 | lambda.theta = lambda[2], 183 | parallel.control = parallel.control, 184 | optim.args = optim.args, 185 | adaptive = adaptive 186 | ) 187 | 188 | ## compute new log-likelihood 189 | # update mean parameter for log-likelihood function 190 | obj.fun$args$mean.est <- mu.par[k + 1, ] 191 | # initialize log-likelihood function 192 | ll <- function(x) { 193 | (-1/2) * do.call(obj.fun$obj_fun, c(list(x = x), obj.fun$args)) 194 | } 195 | loglik.CD[k + 1] <- ll(c.par[k+1, ]) 196 | 197 | # check for convergence in theta parameters 198 | if (CD.conv$logLik) { 199 | # on the log likelihood 200 | if (abs(loglik.CD[k] - loglik.CD[k + 1])/ 201 | abs(loglik.CD[k]) < CD.conv$delta) break 202 | } else { 203 | # on the parameters 204 | if (sum(abs(c(c.par[k, ], mu.par[k, ]) - c(c.par[k+1, ], mu.par[k+1, ])))/ 205 | sum(abs(c(c.par[k, ], mu.par[k, ]))) < CD.conv$delta) break 206 | } 207 | } 208 | 209 | 210 | ## prepare output 211 | # update profile log-lik. function using last mu.k 212 | obj.fun$args$mean.est <- mu.par[k + 1, ] 213 | # note: neg2LL is the objective function of MLE is -2 times the log-lik. 214 | # We transform it back to the exact log-lik in the return call 215 | neg2LL <- function(x) { 216 | do.call(obj.fun$obj_fun, c(list(x = x), obj.fun$args)) 217 | } 218 | 219 | # model-complexity (penalty) 220 | MC <- switch( 221 | match.arg(IC.type), 222 | cAIC_BW = BW_pen( 223 | c.par[k+1, ], 224 | obj.fun$args$X, 225 | obj.fun$args$cov_func, 226 | obj.fun$args$outer.W, 227 | obj.fun$args$taper 228 | ), 229 | cAIC_VB = VB_pen( 230 | c.par[k+1, ], 231 | obj.fun$args$X, 232 | obj.fun$args$cov_func, 233 | obj.fun$args$outer.W, 234 | obj.fun$args$taper 235 | ), 236 | BIC = { 237 | log(n)*sum(abs(c(mu.par[k+1, ], c.par[k+1, 2*(1:q)]) > 1e-10)) 238 | } 239 | ) 240 | # calculate final IC 241 | final.IC <- neg2LL(c.par[k+1, ]) + MC 242 | 243 | # return either all parameters of CD or 244 | # only IC value (needed for numeric optimization) 245 | if (return.par) { 246 | attr(final.IC, "IC.type") <- IC.type 247 | return(list( 248 | mu.par = mu.par, 249 | c.par = c.par, 250 | loglik.CD = loglik.CD, 251 | final.IC = final.IC 252 | )) 253 | } else { 254 | return(final.IC) 255 | } 256 | } 257 | 258 | 259 | 260 | 261 | #' @importFrom pbapply pbapply pboptions 262 | IC_opt_grid <- function(IC.obj, r.lambda, n.lambda) { 263 | 264 | l.lambda <- seq(log(r.lambda[1]), log(r.lambda[2]), length.out = n.lambda) 265 | 266 | op <- pbapply::pboptions(type = "timer") 267 | IC_result <- pbapply::pbapply( 268 | expand.grid(lambda_mu = exp(l.lambda), lambda_sigma_sq = exp(l.lambda)), 269 | 1, 270 | function(lambda) 271 | IC.obj(lambda = as.numeric(lambda)) 272 | ) 273 | pbapply::pboptions(op) 274 | 275 | out <- list( 276 | IC_grid = IC_result, 277 | l.lambda = l.lambda 278 | ) 279 | class(out) <- c("SVC_pmle_grid", "SVC_pmle") 280 | return(out) 281 | } 282 | 283 | 284 | 285 | #' @importFrom pbapply pbapply pboptions 286 | #' @importFrom ParamHelpers makeParamSet makeNumericVectorParam generateDesign 287 | #' @importFrom smoof makeSingleObjectiveFunction 288 | #' @importFrom mlr makeLearner 289 | #' @importFrom mlrMBO makeMBOControl setMBOControlTermination mbo makeMBOInfillCritEI 290 | #' @importFrom lhs maximinLHS 291 | IC_opt_MBO <- function( 292 | IC.obj, r.lambda, n.init, n.iter, 293 | infill.crit = mlrMBO::makeMBOInfillCritEI() 294 | ) { 295 | 296 | par.set <- ParamHelpers::makeParamSet( 297 | ParamHelpers::makeNumericVectorParam( 298 | "lambda", 299 | len = 2, 300 | lower = rep(r.lambda[1], 2), 301 | upper = rep(r.lambda[2], 2)) 302 | ) 303 | 304 | 305 | obj.fun <- smoof::makeSingleObjectiveFunction( 306 | fn = IC.obj, 307 | par.set = par.set, 308 | name = "IC" 309 | ) 310 | 311 | design <- ParamHelpers::generateDesign( 312 | n = n.init, 313 | par.set = par.set, 314 | fun = lhs::maximinLHS 315 | ) 316 | 317 | op <- pbapply::pboptions(type = "timer") 318 | design$y <- pbapply::pbapply(design, 1, obj.fun) 319 | pbapply::pboptions(op) 320 | 321 | surr.km <- mlr::makeLearner( 322 | "regr.km", 323 | predict.type = "se", 324 | covtype = "matern3_2" 325 | ) 326 | 327 | control <- mlrMBO::makeMBOControl() 328 | control <- mlrMBO::setMBOControlTermination(control, iters = n.iter) 329 | control <- mlrMBO::setMBOControlInfill( 330 | control, 331 | crit = infill.crit 332 | ) 333 | 334 | run <- mlrMBO::mbo( 335 | obj.fun, 336 | design = design, 337 | learner = surr.km, 338 | control = control, 339 | show.info = TRUE 340 | ) 341 | 342 | } 343 | 344 | 345 | #' SVC Selection Parameters 346 | #' 347 | #' @description Function to set up control parameters for 348 | #' \code{\link{SVC_selection}}. The underlying Gaussian Process-based 349 | #' SVC model is defined in \code{\link{SVC_mle}}. \code{\link{SVC_selection}} 350 | #' then jointly selects fixed and random effects of the GP-based 351 | #' SVC model using a penalized maximum likelihood estimation (PMLE). 352 | #' In this function, one can set the parameters for the PMLE and 353 | #' its optimization procedures (Dambon et al., 2022). 354 | #' 355 | #' @param IC.type (\code{character(1)}) \cr 356 | #' Select Information Criterion. 357 | #' @param method (\code{character(1)}) \cr 358 | #' Select optimization method for lambdas, i.e., shrinkage parameters. 359 | #' Either model-based optimization (MBO, Bischl et al., 2017 ) or over grid. 360 | #' @param r.lambda (\code{numeric(2)}) \cr 361 | #' Range of lambdas, i.e., shrinkage parameters. 362 | #' @param n.lambda (\code{numeric(1)}) \cr 363 | #' If grid method is selected, number of lambdas per side of grid. 364 | #' @param n.init (\code{numeric(1)}) \cr 365 | #' If MBO method is selected, number of initial values for surrogate model. 366 | #' @param n.iter (\code{numeric(1)}) \cr 367 | #' If MBO method is selected, number of iteration steps of surrogate models. 368 | #' @param CD.conv (\code{list(3)}) \cr 369 | #' List containing the convergence conditions, i.e., 370 | #' first entry is the maximum number of iterations, 371 | #' second value is the relative change necessary to stop iteration, 372 | #' third is logical to toggle if relative change in log likelihood 373 | #' (\code{TRUE}) or rather the parameters themselves (\code{FALSE}) 374 | #' is the criteria for convergence. 375 | #' @param hessian (\code{logical(1)}) \cr 376 | #' If \code{TRUE}, Hessian will be computed for final model. 377 | #' @param adaptive (\code{logical(1)}) \cr 378 | #' If \code{TRUE}, adaptive LASSO is executed, i.e., 379 | #' the shrinkage parameter is defined as \eqn{\lambda_j := \lambda / |\theta_j|}. 380 | #' @param parallel (\code{list}) \cr 381 | #' List with arguments for parallelization, 382 | #' see documentation of \code{\link[optimParallel]{optimParallel}}. 383 | #' @param optim.args (\code{list}) \cr 384 | #' List of further arguments of \code{\link[optimParallel]{optimParallel}}, 385 | #' such as the lower bounds. 386 | #' 387 | #' @export 388 | #' 389 | #' @examples 390 | #' # Initializing parameters and switching logLik to FALSE 391 | #' selection_control <- SVC_selection_control( 392 | #' CD.conv = list(N = 20L, delta = 1e-06, logLik = FALSE) 393 | #' ) 394 | #' # or 395 | #' selection_control <- SVC_selection_control() 396 | #' selection_control$CD.conv$logLik <- FALSE 397 | #' 398 | #' @author Jakob Dambon 399 | #' 400 | #' @references Bischl, B., Richter, J., Bossek, J., Horn, D., Thomas, J., 401 | #' Lang, M. (2017). 402 | #' \emph{mlrMBO: A Modular Framework for Model-Based Optimization of 403 | #' Expensive Black-Box Functions}, 404 | #' ArXiv preprint \url{https://arxiv.org/abs/1703.03373} 405 | #' 406 | #' Dambon, J. A., Sigrist, F., Furrer, R. (2022). 407 | #' \emph{Joint Variable Selection of both Fixed and Random Effects for 408 | #' Gaussian Process-based Spatially Varying Coefficient Models}, 409 | #' International Journal of Geographical Information Science 410 | #' \doi{10.1080/13658816.2022.2097684} 411 | #' 412 | #' 413 | #' @return A list of control parameters for SVC selection. 414 | SVC_selection_control <- function( 415 | IC.type = c("BIC", "cAIC_BW", "cAIC_VB"), 416 | method = c("grid", "MBO"), 417 | r.lambda = c(1e-10, 1e01), 418 | n.lambda = 10L, 419 | n.init = 10L, 420 | n.iter = 10L, 421 | CD.conv = list(N = 20L, delta = 1e-06, logLik = TRUE), 422 | hessian = FALSE, 423 | adaptive = FALSE, 424 | parallel = NULL, 425 | optim.args = list() 426 | ) { 427 | 428 | # check r.lambda 429 | stopifnot( 430 | length(r.lambda) == 2 | 431 | r.lambda[1] > 0 | 432 | r.lambda[1] < r.lambda[2] ) 433 | # check n.lambda 434 | stopifnot( 435 | is.numeric(n.lambda) | n.lambda > 0 ) 436 | # check n.init 437 | stopifnot( 438 | is.numeric(n.init) | n.init > 0 ) 439 | # check n.iter 440 | stopifnot( 441 | is.numeric(n.iter) | n.iter > 0 ) 442 | # check CD.conv 443 | stopifnot( 444 | is.list(CD.conv) | 445 | is.numeric(CD.conv$N) | CD.conv$N > 0 | 446 | is.numeric(CD.conv$delta) | CD.conv$delta > 0 | 447 | is.logical(CD.conv$logLik)) 448 | # hessian & adaptive 449 | stopifnot( 450 | is.logical(hessian) | is.logical(adaptive) ) 451 | 452 | switch(match.arg(method), 453 | "grid" = { 454 | stopifnot(n.lambda >= 1) 455 | }, 456 | "MBO" = { 457 | stopifnot( 458 | n.init > 2 | 459 | n.iter >= 1 460 | ) 461 | }) 462 | 463 | 464 | list( 465 | IC.type = match.arg(IC.type), 466 | method = match.arg(method), 467 | r.lambda = r.lambda, 468 | n.lambda = n.lambda, 469 | n.init = n.init, 470 | n.iter = n.iter, 471 | CD.conv = CD.conv, 472 | hessian = hessian, 473 | adaptive = adaptive, 474 | parallel = parallel, 475 | optim.args = optim.args 476 | ) 477 | } 478 | 479 | 480 | #' SVC Model Selection 481 | #' 482 | #' @description This function implements the variable selection for 483 | #' Gaussian process-based SVC models using a penalized maximum likelihood 484 | #' estimation (PMLE, Dambon et al., 2021, ). 485 | #' It jointly selects the fixed and random effects of GP-based SVC models. 486 | #' 487 | #' @param obj.fun (\code{SVC_obj_fun}) \cr 488 | #' Function of class \code{SVC_obj_fun}. This is the output of 489 | #' \code{\link{SVC_mle}} with the \code{\link{SVC_mle_control}} parameter 490 | #' \code{extract_fun} set to \code{TRUE}. This objective function comprises 491 | #' of the whole SVC model on which the selection should be applied. 492 | #' @param mle.par (\code{numeric(2*q+1)}) \cr 493 | #' Numeric vector with estimated covariance parameters of unpenalized MLE. 494 | #' @param control (\code{list} or \code{NULL}) \cr 495 | #' List of control parameters for variable selection. Output of 496 | #' \code{\link{SVC_selection_control}}. If \code{NULL} is given, the 497 | #' default values of \code{\link{SVC_selection_control}} are used. 498 | #' @param ... Further arguments. 499 | #' 500 | #' @return Returns an object of class \code{SVC_selection}. It contains parameter estimates under PMLE and the optimization as well as choice of the shrinkage parameters. 501 | #' 502 | #' @author Jakob Dambon 503 | #' 504 | #' @references Dambon, J. A., Sigrist, F., Furrer, R. (2021). 505 | #' \emph{Joint Variable Selection of both Fixed and Random Effects for 506 | #' Gaussian Process-based Spatially Varying Coefficient Models}, 507 | #' ArXiv Preprint \url{https://arxiv.org/abs/2101.01932} 508 | #' 509 | #' @export 510 | #' 511 | #' 512 | #' @importFrom optimParallel optimParallel 513 | SVC_selection <- function( 514 | obj.fun, 515 | mle.par, 516 | control = NULL, 517 | ... 518 | ) { 519 | 520 | # dimensions 521 | n <- nrow(obj.fun$args$X) 522 | p <- ncol(obj.fun$args$X) 523 | q <- length(obj.fun$args$outer.W) 524 | 525 | # Error handling 526 | if (is(obj.fun, "SVC_obj_fun")) { 527 | stop("The obj.fun argument must be of class 'SVC_obj_fun', see help file.") 528 | } 529 | 530 | if (!is.numeric(mle.par) | (length(mle.par) != 2*q+1)) { 531 | stop(paste0( 532 | "The mle.par argument must be a numeric vector of length ", 2*q+1, "!" 533 | )) 534 | } 535 | 536 | 537 | 538 | if (is.null(control)) { 539 | control <- SVC_selection_control() 540 | } 541 | 542 | # IC black-box function 543 | IC.obj <- function(lambda) 544 | do.call(PMLE_CD, list( 545 | lambda = lambda, 546 | mle.par = mle.par, 547 | obj.fun = obj.fun, 548 | parallel.control = control$parallel, 549 | optim.args = control$optim.args, 550 | adaptive = control$adaptive, 551 | return.par = FALSE, 552 | IC.type = control$IC.type, 553 | CD.conv = control$CD.conv 554 | )) 555 | 556 | 557 | # start optimization 558 | PMLE_opt <- switch( 559 | control$method, 560 | "grid" = {IC_opt_grid( 561 | IC.obj = IC.obj, 562 | r.lambda = control$r.lambda, 563 | n.lambda = control$n.lambda 564 | )}, 565 | "MBO" = { 566 | stopifnot(control$n.init > 2) 567 | IC_opt_MBO( 568 | IC.obj = IC.obj, 569 | r.lambda = control$r.lambda, 570 | n.init = control$n.init, 571 | n.iter = control$n.iter 572 | )} 573 | ) 574 | 575 | sel_lambda <- switch ( 576 | control$method, 577 | "grid" = { 578 | l.grid <- expand.grid( 579 | PMLE_opt$l.lambda, 580 | PMLE_opt$l.lambda 581 | ) 582 | 583 | exp(as.numeric(l.grid[which.min(PMLE_opt$IC_grid), ])) 584 | }, 585 | "MBO" = { 586 | as.numeric(PMLE_opt$x$lambda) 587 | } 588 | ) 589 | 590 | 591 | PMLE <- function(lambda) 592 | do.call(PMLE_CD, list( 593 | lambda = lambda, 594 | mle.par = mle.par, 595 | obj.fun = obj.fun, 596 | parallel.control = control$parallel, 597 | optim.args = control$optim.args, 598 | adaptive = control$adaptive, 599 | return.par = TRUE, 600 | IC.type = control$IC.type, 601 | CD.conv = control$CD.conv 602 | )) 603 | 604 | PMLE_pars <- PMLE(sel_lambda) 605 | 606 | object <- list( 607 | PMLE_pars = PMLE_pars, 608 | PMLE_opt = PMLE_opt, 609 | lambda = sel_lambda, 610 | obj.fun = obj.fun, 611 | mle.par = mle.par 612 | ) 613 | class(object) <- "SVC_selection" 614 | 615 | return(object) 616 | } 617 | -------------------------------------------------------------------------------- /R-pkg/R/utils.R: -------------------------------------------------------------------------------- 1 | #' @importFrom spam cov.mat 2 | cov.mat32 <- function(h, theta) { 3 | stopifnot(length(theta) == 2L) 4 | # smoothness nu = 3/2 5 | spam::cov.mat(h, theta = c(theta, 3/2)) 6 | } 7 | 8 | #' @importFrom spam cov.mat 9 | cov.mat52 <- function(h, theta) { 10 | stopifnot(length(theta) == 2L) 11 | # smoothness nu = 5/2 12 | spam::cov.mat(h, theta = c(theta, 5/2)) 13 | } 14 | 15 | 16 | ## ---- help function to give back correct covariance function ---- 17 | #' @importFrom spam cov.exp cov.sph cov.wend1 cov.wend2 18 | MLE.cov.func <- function( 19 | cov.name = c("exp", "mat32", "mat52", "sph", "wend1", "wend2") 20 | ) { 21 | if (is.character(cov.name)) { 22 | cov.func <- get(paste0("cov.", match.arg(cov.name))) 23 | } else if (is.function(cov.name)) { 24 | cov.func <- cov.name 25 | } else { 26 | stop("Cov.name argument neither character, nor covariance function.") 27 | } 28 | return(cov.func) 29 | } 30 | 31 | 32 | 33 | #' GLS Estimate using Cholesky Factor 34 | #' 35 | #' Computes the GLS estimate using the formula: 36 | #' \deqn{\mu_{GLS} = (X^\top \Sigma^{-1} X)^{-1}X^\top \Sigma^{-1} y.} 37 | #' The computation is done depending on the input class of the Cholesky factor 38 | #' \code{R}. It relies on the classical \code{\link[base]{solve}} or on 39 | #' using \code{forwardsolve} and \code{backsolve} functions of package 40 | #' \code{spam}, see \code{\link[spam]{solve}}. This is much faster than 41 | #' computing the inverse of \eqn{\Sigma}, especially since we have to compute 42 | #' the Cholesky decomposition of \eqn{\Sigma} either way. 43 | #' 44 | #' @param R (\code{spam.chol.NgPeyton} or \code{matrix(n, n)}) \cr Cholesky factor of 45 | #' the covariance matrix \eqn{\Sigma}. If covariance tapering and sparse 46 | #' matrices are used, then the input is of class \code{spam.chol.NgPeyton}. 47 | #' Otherwise, \code{R} is the output of a standard \code{\link[base]{chol}}, 48 | #' i.e., a simple \code{matrix} 49 | #' @param X (\code{matrix(n, p)}) \cr Data / design matrix. 50 | #' @param y (\code{numeric(n)}) \cr Response vector 51 | #' 52 | #' @return A \code{numeric(p)} vector, i.e., the mean effects. 53 | #' @author Jakob Dambon 54 | #' 55 | #' @export 56 | #' 57 | #' @examples 58 | #' # generate data 59 | #' n <- 10 60 | #' X <- cbind(1, 20+1:n) 61 | #' y <- rnorm(n) 62 | #' A <- matrix(runif(n^2)*2-1, ncol=n) 63 | #' Sigma <- t(A) %*% A 64 | #' # two possibilities 65 | #' ## using standard Cholesky decomposition 66 | #' R_mat <- chol(Sigma); str(R_mat) 67 | #' mu_mat <- GLS_chol(R_mat, X, y) 68 | #' ## using spam 69 | #' R_spam <- chol(spam::as.spam(Sigma)); str(R_spam) 70 | #' mu_spam <- GLS_chol(R_spam, X, y) 71 | #' # should be identical to the following 72 | #' mu <- solve(crossprod(X, solve(Sigma, X))) %*% 73 | #' crossprod(X, solve(Sigma, y)) 74 | #' ## check 75 | #' abs(mu - mu_mat) 76 | #' abs(mu - mu_spam) 77 | GLS_chol <- function(R, X, y) UseMethod("GLS_chol") 78 | 79 | #' @rdname GLS_chol 80 | #' @importFrom spam forwardsolve backsolve 81 | #' @export 82 | GLS_chol.spam.chol.NgPeyton <- function(R, X, y) { 83 | # (X^T * Sigma^-1 * X)^-1 84 | solve( 85 | crossprod(spam::forwardsolve(R, X)) 86 | ) %*% 87 | # (X^T * Sigma^-1 * y) 88 | crossprod(X, spam::backsolve(R, spam::forwardsolve(R, y))) 89 | } 90 | 91 | #' @rdname GLS_chol 92 | #' @export 93 | GLS_chol.matrix <- function(R, X, y) { 94 | RiX <- solve(t(R), X) 95 | # (X^T * Sigma^-1 * X)^-1 96 | solve( 97 | crossprod(RiX) 98 | ) %*% 99 | # (X^T * Sigma^-1 * y) 100 | crossprod(RiX, solve(t(R), y)) 101 | } 102 | 103 | 104 | # Covariance Matrix of GP-based SVC Model 105 | # 106 | # Builds the covariance matrix of \eqn{y} (p. 6, Dambon et al. (2021) 107 | #\doi{10.1016/j.spasta.2020.100470}) for a given set of covariance 108 | # parameters and other, pre-defined objects (like the outer-products, 109 | # covariance function, and, possibly, a taper matrix). 110 | # 111 | # @param x (\code{numeric(2q+1)}) \cr Non negative vector containing 112 | # the covariance parameters in the following order: \eqn{\rho_1, \sigma_1^2, 113 | # ..., \rho_q, \sigma_q^2 , \tau^2}. Note that the odd entries, i.e., the 114 | # ranges and the nugget variance, have to be greater than 0, otherwise the 115 | # covariance matrix is not well-defined (singularities or not-invertible). 116 | # @param cov_func (\code{function}) \cr A covariance function that works on 117 | # the pre-defined distance matrix \code{d}. It takes a numeric vector as an 118 | # input, the first entry being the range, the second being the variance 119 | # (also called partial sill). Usually, it is defined as, e.g.: 120 | # \code{function(pars) spam::cov.exp(d, pars)} or any other covariance function 121 | # defined for two parameters. 122 | # @param outer.W (\code{list(q)}) \cr A list of length \code{q} containing 123 | # the outer products of the random effect covariates in a lower triangular, 124 | # (possibly sparse) matrix. If tapering is applied, the list entries, i.e., 125 | # the outer products have to be given as \code{\link[spam]{spam}} objects. 126 | # @param taper (\code{NULL} or \code{spam}) \cr If covariance tapering is 127 | # applied, this argument contains the taper matrix, which is a 128 | # \code{\link[spam]{spam}} object. Otherwise, it is \code{NULL}. 129 | # 130 | # @return Returns a positive-definite covariance matrix y, which is needed in 131 | # the MLE. Specifically, a Cholesky Decomposition is applied on the covariance 132 | # matrix. 133 | # 134 | # 135 | # @author Jakob Dambon 136 | # @references Dambon, J. A., Sigrist, F., Furrer, R. (2021) 137 | # \emph{Maximum likelihood estimation of spatially varying coefficient 138 | # models for large data with an application to real estate price prediction}, 139 | # Spatial Statistics \doi{10.1016/j.spasta.2020.100470} 140 | # 141 | # 142 | # @examples 143 | # # locations 144 | # locs <- 1:6 145 | # # random effects covariates 146 | # W <- cbind(rep(1, 6), 5:10) 147 | # # distance matrix with and without tapering 148 | # d <- as.matrix(dist(locs)) 149 | # # distance matrix with and without tapering 150 | # tap_dist <- 2 151 | # d_tap <- spam::nearest.dist(locs, delta = tap_dist) 152 | # # call without tapering 153 | # (Sy <- varycoef:::Sigma_y( 154 | # x = rep(0.5, 5), 155 | # cov_func = function(x) spam::cov.exp(d, x), 156 | # outer.W = lapply(1:ncol(W), function(k) W[, k] %o% W[, k]) 157 | # )) 158 | # str(Sy) 159 | # # call with tapering 160 | # (Sy_tap <- varycoef:::Sigma_y( 161 | # x = rep(0.5, 5), 162 | # cov_func = function(x) spam::cov.exp(d_tap, x), 163 | # outer.W = lapply(1:ncol(W), function(k) 164 | # spam::as.spam((W[, k] %o% W[, k]) * (d_tap<=tap_dist)) 165 | # ), 166 | # taper = spam::cov.wend1(d_tap, c(tap_dist, 1, 0)) 167 | # )) 168 | # str(Sy_tap) 169 | # # difference between tapered and untapered covariance matrices 170 | # Sy-Sy_tap 171 | Sigma_y <- function(x, cov_func, outer.W, taper = NULL) { 172 | n <- nrow(outer.W[[1]]) 173 | q <- length(outer.W) 174 | 175 | if (is.null(taper)) { 176 | # with no tapering computations are done on matrix objects 177 | Sigma <- matrix(0, nrow = n, ncol = n) 178 | 179 | for (k in 1:q) { 180 | # first argument: range, second argument: variance / sill 181 | Cov <- cov_func(x[2*(k-1) + 1:2]) 182 | 183 | Sigma <- Sigma + ( 184 | Cov * outer.W[[k]] 185 | ) 186 | } 187 | 188 | nug <- if (n == 1) { 189 | x[2*q+1] 190 | } else { 191 | diag(rep(x[2*q+1], n)) 192 | } 193 | 194 | return(Sigma + nug) 195 | } else { 196 | # With tapering computations are done on spam objects. 197 | # Specifically, due to their fixed structure and since we are only 198 | # pair-wise adding and multiplying, on the spam entries themselves 199 | 200 | stopifnot( 201 | all(sapply(outer.W, is.spam)) 202 | ) 203 | 204 | # construct a sparse matrix with 0 values as future entries 205 | # for k = 1 206 | Sigma <- outer.W[[1]] * cov_func(x[1:2]) 207 | 208 | # if q > 1, build covariance matrix using components of other GPs 209 | if (q > 1) { 210 | for (k in 2:q) { 211 | Cov <- do.call(cov_func, list(c(x[2*(k-1) + 1:2], 0))) 212 | 213 | Sigma <- Sigma + (Cov * outer.W[[k]]) 214 | } 215 | } 216 | 217 | options(spam.trivalues = TRUE) 218 | 219 | nug <- if (n == 1) { 220 | x[2*q+1] 221 | } else { 222 | spam::diag.spam(rep(x[2*q+1], n)) 223 | } 224 | 225 | # Sigma <- Sigma * taper 226 | # add lower tri. cov-matrices up and mirror them to get full cov-matrix 227 | # due to spam::nearest.dist design 228 | 229 | return(spam::lower.tri.spam(Sigma) + 230 | spam::t.spam(Sigma) + 231 | nug) 232 | } 233 | } 234 | 235 | 236 | 237 | 238 | Sigma_b_y <- function(x, cov.func, W, n.new) { 239 | n <- nrow(W) 240 | 241 | cov <- lapply(1:ncol(W), 242 | function(j) { 243 | # cross-covariances of Sigma_b_y 244 | cov.func(c(x[2*(j-1) + 1:2])) * 245 | matrix(rep(W[, j], each = n.new), ncol = n) 246 | }) 247 | # binding to one matrix 248 | Reduce(rbind, cov) 249 | } 250 | 251 | 252 | Sigma_y_y <- function(x, cov.func, X, newX) { 253 | 254 | p <- ncol(X) 255 | 256 | Sigma <- matrix(0, ncol = nrow(X), nrow = nrow(newX)) 257 | 258 | for (j in 1:p) { 259 | Cov <- cov.func(c(x[2*(j-1) + 1:2], 0)) 260 | 261 | Sigma <- Sigma + ( 262 | Cov * (newX[, j] %o% X[, j]) 263 | ) 264 | } 265 | 266 | 267 | return(Sigma) 268 | 269 | } 270 | 271 | 272 | #' Check Lower Bound of Covariance Parameters 273 | #' 274 | #' Ensures that the covariance parameters define a positive definite covariance 275 | #' matrix. It takes the vector 276 | #' \eqn{(\rho_1, \sigma^2_1, ..., \rho_q, \sigma^2_q, \tau^2)} and checks if 277 | #' all \eqn{\rho_k>0}, all \eqn{\sigma_k^2>=0}, and \eqn{\tau^2>0}. 278 | #' @param cv (\code{numeric(2*q+1)}) \cr Covariance vector of SVC model. 279 | #' @param q (\code{numeric(1)}) \cr Integer indicating the number of SVCs. 280 | #' 281 | #' @return \code{logical(1)} with \code{TRUE} if all conditions above are 282 | #' fulfilled. 283 | #' @export 284 | #' 285 | #' @examples 286 | #' # first one is true, all other are false 287 | #' check_cov_lower(c(0.1, 0, 0.2, 1, 0.2), q = 2) 288 | #' check_cov_lower(c(0 , 0, 0.2, 1, 0.2), q = 2) 289 | #' check_cov_lower(c(0.1, 0, 0.2, 1, 0 ), q = 2) 290 | #' check_cov_lower(c(0.1, 0, 0.2, -1, 0 ), q = 2) 291 | check_cov_lower <- function(cv, q) { 292 | # check range and nugget variance parameters 293 | l_rp <- all(cv[1+2*(0:q)]>0) 294 | # check SVC variances 295 | l_vp <- all(cv[2*(1:q)] >= 0) 296 | return(l_rp & l_vp) 297 | } 298 | 299 | 300 | #' Setting of Optimization Bounds and Initial Values 301 | #' 302 | #' Sets bounds and initial values for \code{\link[stats]{optim}} by 303 | #' extracting potentially given values from \code{\link{SVC_mle_control}} and 304 | #' checking them, or calculating them from given data. See Details. 305 | #' 306 | #' @param control (\code{\link{SVC_mle_control}} output, i.e. \code{list}) 307 | #' @param p (\code{numeric(1)}) \cr Number of fixed effects 308 | #' @param q (\code{numeric(1)}) \cr Number of SVCs 309 | #' @param id_obj (\code{numeric(2*q+1+q)}) \cr Index vector to identify the 310 | #' arguments of objective function. 311 | #' @param med_dist (\code{numeric(1)}) \cr Median distance between observations 312 | #' @param y_var (\code{numeric(1)}) \cr Variance of response \code{y} 313 | #' @param OLS_mu (\code{numeric(p)}) \cr Coefficient estimates of ordinary 314 | #' least squares (OLS). 315 | #' 316 | #' @details If values are not provided, then they are set in the following way. 317 | #' Let \eqn{d} be the median distance \code{med_dist}, let \eqn{s^2_y} be 318 | #' the variance of the response \code{y_var}, and let \eqn{b_j} be the OLS 319 | #' coefficients of the linear model. The computed values are given in the 320 | #' table below. 321 | #' 322 | #' | Parameter | Lower bound | Initial Value | Upper Bound | 323 | #' | ------------ | -------------:| -----------------:| -------------:| 324 | #' | Range | \eqn{d/1000} | \eqn{d/4} | \eqn{10 d} | 325 | #' | Variance | \eqn{0} | \eqn{s^2_y/(q+1)} | \eqn{10s^2_y} | 326 | #' | Nugget | \eqn{10^{-6}} | \eqn{s^2_y/(q+1)} | \eqn{10s^2_y} | 327 | #' | Mean \eqn{j} | \code{-Inf} | \eqn{b_j} | \code{Inf} | 328 | #' @md 329 | #' 330 | #' @author Jakob Dambon 331 | #' 332 | #' @export 333 | #' 334 | #' @return A \code{list} with three entries: \code{lower}, \code{init}, 335 | #' and \code{upper}. 336 | init_bounds_optim <- function(control, p, q, id_obj, med_dist, y_var, OLS_mu) { 337 | 338 | # lower bound for optim 339 | if (is.null(control$lower)) { 340 | lower <- if (control$profileLik) { 341 | c(rep(c(med_dist/1000, 0), q), 1e-6) 342 | } else { 343 | c(rep(c(med_dist/1000, 0), q), 1e-6, rep(-Inf, p)) 344 | } 345 | } else { 346 | lower <- control$lower 347 | if (length(lower) != length(id_obj)) { 348 | stop("Lower boundary vector has wrong length. Check SVC_mle_control.") 349 | } 350 | if (!check_cov_lower(lower[1:(2*q+1)], q)) { 351 | stop("Lower boundary vector is not greater (or equal) than 0. Call ?check_cov_lower.") 352 | } 353 | } 354 | 355 | # upper bound for optim 356 | if (is.null(control$upper)) { 357 | upper <- if (control$profileLik) { 358 | c(rep(c(10*med_dist, 10*y_var), q), 10*y_var) 359 | } else { 360 | c(rep(c(10*med_dist, 10*y_var), q), 10*y_var, rep(Inf, p)) 361 | } 362 | } else { 363 | upper <- control$upper 364 | if (length(upper) != length(id_obj)) { 365 | stop("Upper boundary vector has wrong length. Check SVC_mle_control.") 366 | } 367 | if (!check_cov_lower(upper[1:(2*q+1)], q)) { 368 | stop("Upper boundary vector is not greater (or equal) than 0. Call ?check_cov_lower.") 369 | } 370 | if (any(lower>upper)) { 371 | stop("Upper boundary vector smaller than lower boundary.") 372 | } 373 | } 374 | 375 | # init 376 | if (is.null(control$init)) { 377 | init <- if (control$profileLik) { 378 | c(rep(c(med_dist/4, y_var/(q+1)), q), y_var/(q+1)) 379 | } else { 380 | c(rep(c(med_dist/4, y_var/(q+1)), q), y_var/(q+1), OLS_mu) 381 | } 382 | } else { 383 | init <- control$init 384 | if (length(init) != length(id_obj)) { 385 | stop("Initial vector has wrong length. Check SVC_mle_control.") 386 | } 387 | if (!check_cov_lower(init[1:(2*q+1)], q)) { 388 | stop("Initial value vector is not greater (or equal) than 0. Call ?check_cov_lower.") 389 | } 390 | if (!(all(lower <= init) & all(init <= upper))) { 391 | stop("Initial values do not lie between lower and upper boundarys.") 392 | } 393 | } 394 | 395 | return(list(lower = lower, init = init, upper = upper)) 396 | } 397 | 398 | 399 | 400 | # Preparation of Parameter Output 401 | # 402 | # Prepares and computes the ML estimates and their respective standard errors. 403 | # @param output_par (\code{numeric}) \cr Found optimal value of 404 | # \code{\link[stats]{optim}}. 405 | # @param Sigma_final (\code{spam} or \code{matrix(n, n)}) \cr Covariance matrix 406 | # Sigma of SVC under final covariance parameters. 407 | # @param Rstruct (\code{NULL} or \code{spam.chol.NgPeyton}) \cr If 408 | # covariance tapering is used, the Cholesky factor has been calculated 409 | # previously and can be used to efficiently update the Cholesky factor of 410 | # \code{Sigma_final}, which is an \code{spam} object. 411 | # @param profileLik (\code{logical(1)}) \cr Indicates if optimization has been 412 | # conducted over full or profile likelihood. 413 | # @param X (\code{matrix(n, p)}) Design matrix 414 | # @param y (\code{numeric(p)}) Response vector 415 | # @param H (\code{NULL} or \code{matrix}) Hessian of MLE 416 | # @param q (\code{numeric(1)}) Number of SVC 417 | # 418 | # @return A \code{list} with two \code{data.frame}. Each contains the estimated 419 | # parameters with their standard errors of the fixed and random effects, 420 | # respectively. 421 | # 422 | #' @importFrom methods is 423 | prep_par_output <- function(output_par, Sigma_final, Rstruct, profileLik, 424 | X, y, H, q) { 425 | p <- dim(as.matrix(X))[2] 426 | 427 | # get mean effects depending on likelihood optimization 428 | if (profileLik) { 429 | # calculate Cholesky-Decomposition 430 | if (is.spam(Sigma_final)) { 431 | cholS <- chol(Sigma_final, Rstruct = Rstruct) 432 | } else { 433 | cholS <- chol(Sigma_final) 434 | } 435 | 436 | mu <- GLS_chol(cholS, X, y) 437 | } else { 438 | mu <- output_par[2*q+1 + 1:p] 439 | } 440 | 441 | # get standard errors of parameters 442 | if (is.null(H)) { 443 | warning("MLE without Hessian. Cannot return standard errors of covariance parameters.") 444 | se_all <- rep(NA_real_, length(output_par)) 445 | } else { 446 | # divide by 2 due to (-2)*LL 447 | se_all <- try({sqrt(diag(solve(H/2)))}, silent = TRUE) 448 | 449 | # if no convergence, standard errors cannot be extracted 450 | if (methods::is(se_all, "try-error")) { 451 | warning("Could not invert Hessian.") 452 | se_all <- rep(NA_real_, length(output_par)) 453 | } 454 | } 455 | # on profile? 456 | if (profileLik) { 457 | se_RE <- se_all 458 | # compute variance covariance matrix for fixed effects 459 | 460 | # using GLS properties 461 | Sigma_FE <- solve(crossprod(X, solve(Sigma_final, X))) 462 | 463 | se_FE <- sqrt(diag(Sigma_FE)) 464 | } else { 465 | se_RE <- se_all[1:(2*q+1)] 466 | se_FE <- se_all[2*q+1 + 1:p] 467 | } 468 | 469 | return(list( 470 | RE = data.frame(est = output_par[1:(2*q+1)], SE = se_RE), 471 | FE = data.frame(est = mu, SE = se_FE) 472 | )) 473 | } 474 | 475 | # 476 | # own_dist <- function( 477 | # locs, newlocs = NULL, taper = NULL, method_list = NULL 478 | # ) { 479 | # if (is.null(taper)) { 480 | # d <- as.matrix( 481 | # do.call(dist, 482 | # c(list(x = locs, diag = TRUE, upper = TRUE), method_list))) 483 | # } else { 484 | # d <- do.call(spam::nearest.dist, 485 | # c(list(x = locs, 486 | # delta = control$tapering), 487 | # control$dist)) 488 | # } 489 | # } 490 | 491 | 492 | # Computes (Cross-) Distances 493 | # 494 | # @param x (\code{matrix}) \cr Matrix containing locations 495 | # @param y (\code{NULL} or \code{matrix}) \cr If \code{NULL}, computes the 496 | # distances between \code{x}. Otherwise, computes cross-distances, i.e., 497 | # pair-wise distances between rows of \code{x} and \code{y}. 498 | # @param taper (\code{NULL} or \code{numeric(1)}) \cr If \code{NULL}, all 499 | # distances are considered. Otherwise, only distances shorter than 500 | # \code{taper} are used. Hence the output will be a sparse matrix of type 501 | # \code{\link[spam]{spam}}. 502 | # @param ... Further arguments for either \code{\link[stats]{dist}} or 503 | # \code{\link[spam]{nearest.dist}}. 504 | # 505 | # @return A \code{matrix} or \code{spam} object. 506 | #' @importFrom spam nearest.dist 507 | #' @importFrom stats dist 508 | own_dist <- function(x, y = NULL, taper = NULL, ...) { 509 | 510 | d <- if (is.null(taper)) { 511 | # without tapering 512 | if (is.null(y)) { 513 | # no cross distances 514 | as.matrix(do.call( 515 | dist, 516 | c(list(x = x, diag = TRUE, upper = TRUE), ...) 517 | )) 518 | } else { 519 | # cross distances 520 | as.matrix(do.call( 521 | spam::nearest.dist, 522 | c(list(x = x, y = y, delta = 1e99), ...) 523 | )) 524 | } 525 | } else { 526 | # with tapering 527 | if (is.null(y)) { 528 | # no cross distances 529 | do.call( 530 | spam::nearest.dist, 531 | c(list(x = x, delta = taper), ...) 532 | ) 533 | } else { 534 | # cross distances 535 | do.call( 536 | spam::nearest.dist, 537 | c(list(x = x, y = y, delta = taper), ...) 538 | ) 539 | } 540 | } 541 | # return output 542 | d 543 | } 544 | 545 | get_taper <- function(cov.name, d, tapering) { 546 | switch( 547 | cov.name, 548 | "exp" = spam::cov.wend1(d, c(tapering, 1, 0)), 549 | "mat32" = spam::cov.wend1(d, c(tapering, 1, 0)), 550 | "mat52" = spam::cov.wend2(d, c(tapering, 1, 0)) 551 | ) 552 | } 553 | 554 | is.formula <- function(x){ 555 | inherits(x,"formula") 556 | } 557 | 558 | #' @importFrom stats as.formula 559 | drop_response <- function(formula) { 560 | stopifnot(is.formula(formula)) 561 | 562 | deparsed_form <- as.character(formula) 563 | if (length(deparsed_form) > 2L) { 564 | return(stats::as.formula(paste(deparsed_form[c(1, 3)], collapse = " "))) 565 | } else { 566 | return(formula) 567 | } 568 | } 569 | -------------------------------------------------------------------------------- /R-pkg/vignettes/Introduction.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "varycoef: An R Package to Model Spatially Varying Coefficients" 3 | author: "Jakob A. Dambon" 4 | date: "October 2019, Updated: August 2022" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{Introduction} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | %\VignetteEncoding{UTF-8} 10 | --- 11 | 12 | ```{r setup, include=FALSE} 13 | knitr::opts_chunk$set(echo = TRUE, message = FALSE, 14 | fig.width=7, fig.height=4) 15 | library(knitr) 16 | prop_train <- 0.2 17 | ``` 18 | 19 | 20 | ## Introduction 21 | 22 | With the R package `varycoef` we enable the user to analyze spatial data and in a simple, yet versatile way. The underlying idea are *spatially varying coefficients* (SVC) that extend the linear model 23 | 24 | $$ y_i = x_i^{(1)} \beta_1 + ... + x_i^{(p)} \beta_p + \varepsilon_i$$ 25 | by allowing the coefficients $\beta_j, j = 1, ..., p$ to vary over space. That is, for a location $s$ we assume the following model: 26 | 27 | $$ y_i = x_i^{(1)} \beta_1(s) + ... + x_i^{(p)} \beta_p(s) + \varepsilon_i$$ 28 | 29 | In particular, we use so-called *Gaussian processes* (GP) to define the spatial structure of the coefficients. Therefore, our models are called *GP-based SVC models*. 30 | 31 | In this article, we will show what SVC models are and how to define them. Afterwards, we give a short and illustrative example with synthetic data and show how to apply the methods provided in `varycoef`. Finally, using the well known data set `meuse` from the package `sp`. 32 | 33 | ### Disclaimer 34 | 35 | The analyses and results in this article are meant to introduce the package `varycoef` and **not** to be a rigorous statistical analysis of a data set. As this article should make the usage of `varycoef` as simple as possible, we skip over some of the technical or mathematical details and in some cases abuse notation. For a rigorous definition, please refer to the resources below. Further, the model estimation is performed on rather small data sets to ease computation ($n < 200$). We recommend to apply SVC models, particularly with many coefficients, on larger data sets. 36 | 37 | ### Further References 38 | 39 | Our package evolved over time and we present some highlights: 40 | 41 | - In [Dambon et al. (2021a)](https://doi.org/10.1016/j.spasta.2020.100470) we introduce the GP-based SVC model and the methodology on how to estimate them. Further, we provide a comparison on synthetic and real world data with other SVC methodologies. 42 | 43 | - In [Dambon et al. (2022a)](https://doi.org/10.1186/s41937-021-00080-2) we present an in-depth analysis of Swiss real estate data using GP-based SVC models. 44 | 45 | - In [Dambon et al. (2022b)](https://doi.org/10.1080/13658816.2022.2097684) we introduce a variable selection method. This is not covered by this article. 46 | 47 | - For more information on Gaussian processes and their application on spatial data, please refer to chapter 9 of the ["STA330: Modeling Dependent Data" lecture notes](http://user.math.uzh.ch/furrer/download/sta330/script_sta330.pdf) by Reinhard Furrer. 48 | 49 | ### Preliminaries 50 | 51 | Before we start, we want to give some prerequisites that you should know about in order to follow the analysis below. Beside a classical linear regression model, we require the knowledge of: 52 | 53 | - spatial data and geostatistics 54 | - Gaussian processes and Gaussian random fields 55 | - covariance functions and how the range and variance parameter influence them 56 | - maximum likelihood estimation 57 | 58 | ### Set up 59 | 60 | The `varycoef` package is available via [CRAN](https://cran.r-project.org/package=varycoef) or [Github](https://github.com/jakobdambon/varycoef). Latter one hosts the most recent version that is released to CRAN on a regular base. 61 | 62 | ```{r install, eval=FALSE} 63 | # install from CRAN 64 | install.packages("varycoef") 65 | 66 | # install from Github (make sure that you installed the package "devtools") 67 | devtools::install_github("jakobdambon/varycoef") 68 | ``` 69 | 70 | ### Where to find help? 71 | 72 | Within the R package, you can use these resources: 73 | 74 | ```{r help and vignettes, warning=FALSE} 75 | # attach package 76 | library(varycoef) 77 | 78 | # general package help file 79 | help("varycoef") 80 | 81 | # where you find this vignette 82 | vignette("Introduction", package = "varycoef") 83 | ``` 84 | 85 | You can find this article on the Github repository, too. We continue to add more material and examples. 86 | 87 | ## Synthetic Data Example 88 | 89 | Let's dive into the analysis of some synthetic data. To ease the visualization, we will work with one-dimensional spatial data, i.e., any location $s$ is from the real line $\mathbb R$. We want to highlight that are package is not restricted to such analysis and that we can analyze spatial data from higher dimensions, i.e., $s \in \mathbb R^d$, where $d \geq 1$. 90 | 91 | ### Model and Data 92 | 93 | As mentioned before, an SVC model extends the linear model by allowing the coefficients to vary over space. Therefore, we can write: 94 | 95 | $$ y_i = x_i^{(1)} \beta_1(s) + ... + x_i^{(p)} \beta_p(s) + \varepsilon_i,$$ 96 | for some location $s$ where $\beta_j(s)$ indicates the dependence of the $j$th coefficient on the space. The coefficients are defined by Gaussian processes, but we skip over this part for now and take a look at a data set that was sampled using the model above. In `varycoef`, a data set named `SVCdata` is provided: 97 | 98 | ```{r synthetic data} 99 | str(SVCdata) 100 | help(SVCdata) 101 | # number of observations, number of coefficients 102 | n <- nrow(SVCdata$X); p <- ncol(SVCdata$X) 103 | ``` 104 | 105 | It consists of the response `y`, the model matrix `X`, the locations `locs`, and the usually unknown true coefficients `beta`, error `eps`, and true parameters `true_pars`. The model matrix is of dimension $`r n` \times `r p`$, i.e., we have $`r n`$ observations and $p = `r p`$ coefficients. The first column of `X` is identical to 1 to model the intercept. 106 | 107 | We will use `r n*prop_train` observations of the data to train the model and leave the remaining `r n*(1-prop_train)` out as a test sample, i.e.: 108 | 109 | ```{r synthetic data train and test} 110 | # create data frame 111 | df <- with(SVCdata, data.frame(y = y, x = X[, 2], locs = locs)) 112 | set.seed(123) 113 | idTrain <- sort(sample(n, n*prop_train)) 114 | df_train <- df[idTrain, ] 115 | df_test <- df[-idTrain, ] 116 | ``` 117 | 118 | ### Exploratory Data Analysis 119 | 120 | We plot the part of the data that is usually available to us: 121 | 122 | ```{r synthetic data EDA} 123 | par(mfrow = 1:2) 124 | plot(y ~ x, data = df_train, xlab = "x", ylab = "y", 125 | main = "Scatter Plot of Response and Covariate") 126 | plot(y ~ locs, data = df_train, xlab = "s", ylab = "y", 127 | main = "Scatter Plot of Response and Locations") 128 | par(mfrow = c(1, 1)) 129 | ``` 130 | 131 | We note that there is a clear linear dependency between the covariate and the response. However, there is not a clear spatial structure. We estimate a linear model and analyze the residuals thereof. 132 | 133 | ```{r synthetic data linear model} 134 | fit_lm <- lm(y ~ x, data = df_train) 135 | coef(fit_lm) 136 | # residual plots 137 | par(mfrow = 1:2) 138 | plot(x = fitted(fit_lm), y = resid(fit_lm), 139 | xlab = "Fitted Values", ylab = "Residuals", 140 | main = "Residuals vs Fitted") 141 | abline(h = 0, lty = 2, col = "grey") 142 | plot(x = df_train$locs, y = resid(fit_lm), xlab = "Location", ylab = "Residuals", 143 | main = "Residuals vs Locations") 144 | abline(h = 0, lty = 2, col = "grey") 145 | par(mfrow = c(1, 1)) 146 | ``` 147 | 148 | Discarding the spatial information, we observe no structure within the residuals (Figure above, LHS). However, if we plot the residuals against there location, we clearly see some spatial structure. Therefore, we will apply the SVC model next. 149 | 150 | ### SVC Model 151 | 152 | To estimate an SVC model, we can use the `SVC_mle()` function almost like the `lm()` function from above. As the name suggests, we use a *maximum likelihood estimation* (MLE) for estimating the parameters. For now, we only focus on the mean coefficients, which we obtain by the `coef()` method. 153 | 154 | ```{r synthetic data svc model} 155 | fit_svc <- SVC_mle(y ~ x, data = df_train, locs = df_train$locs) 156 | coef(fit_svc) 157 | ``` 158 | 159 | The only additional argument that we have to provide explicitly when calling `SVC_mle()` are the coordinates, i.e., the observation locations. The output is an object of class `r class(fit_svc)`. We can apply most of the methods that exist for `lm` objects to out output, too. For instance methods of `summary()`, `fitted()`, or `resid()`. We give the `summary()` output but do not go into details for now. Further, use the `fitted()` and `residuals()` methods to analyze the SVC model. Contrary to a `fitted()` method for an `lm` object, the output does not only contain the fitted response, but is a `data.frame` that contains the spatial deviations from the mean named `SVC_1`, `SVC_2`, and so on (see section Model Interpretation below), the response `y.pred`, and the respective locations `loc_1`, `loc_2`, etc. In our case, there is only one column since the locations are from a one-dimensional domain. 160 | 161 | ```{r methods} 162 | # summary output 163 | summary(fit_svc) 164 | # fitted output 165 | head(fitted(fit_svc)) 166 | # residual plots 167 | par(mfrow = 1:2) 168 | plot(x = fitted(fit_svc)$y.pred, y = resid(fit_svc), 169 | xlab = "Fitted Values", ylab = "Residuals", 170 | main = "Residuals vs Fitted") 171 | abline(h = 0, lty = 2, col = "grey") 172 | plot(x = df_train$locs, y = resid(fit_svc), xlab = "Location", ylab = "Residuals", 173 | main = "Residuals vs Locations") 174 | abline(h = 0, lty = 2, col = "grey") 175 | par(mfrow = c(1, 1)) 176 | ``` 177 | 178 | Compared to the output and residuals of the linear models, we immediately see that the residuals of the SVC model are smaller in range and do not have a spatial structure. They are both with respect to fitted values and locations distributed around zero and homoscedastic. 179 | 180 | ### Comparison of Models 181 | 182 | We end this synthetic data example by comparing the linear with the SVC model. We already saw some advantages of the SVC model when investigating the residuals. Now, we take a look at the quality of the model fit, the model interpretation, and the predictive performance. 183 | 184 | #### Model Fit 185 | 186 | We can compare the models by the log likelihood, Akaike's or the Bayesian information criterion (AIC and BIC, respectively). Again, the corresponding methods are available: 187 | 188 | ```{r synthetic data model fit} 189 | kable(data.frame( 190 | Model = c("linear", "SVC"), 191 | # using method logLik 192 | `log Likelihood` = round(as.numeric(c(logLik(fit_lm), logLik(fit_svc))), 2), 193 | # using method AIC 194 | AIC = round(c(AIC(fit_lm), AIC(fit_svc)), 2), 195 | # using method BIC 196 | BIC = round(c(BIC(fit_lm), BIC(fit_svc)), 2) 197 | )) 198 | ``` 199 | 200 | In all four metrics the SVC model outperforms the linear model, i.e., the log likelihood is larger and the two information criteria are smaller. 201 | 202 | #### Visualization of Coefficients 203 | 204 | While the linear model estimates constant coefficients $\beta_j$, contrary and as the name suggests, the SVC model's coefficients vary over space $\beta_j(s)$. That is why the `fitted()` method does not only return the fitted response, but also the fitted coefficients and at their given locations: 205 | 206 | ```{r synthetic data fitted} 207 | head(fitted(fit_svc)) 208 | ``` 209 | 210 | Therefore, the SVC mentioned above is the sum of the mean value from the method `coef()` which we name $\mu_j$ and the zero-mean spatial deviations from above which we name $\eta_j(s)$, i.e., $\beta_j(s) = \mu_j + \eta_j(s)$. We visualize the coefficients at their respective locations: 211 | 212 | ```{r synthetic data SVC plot} 213 | mat_coef <- cbind( 214 | # constant coefficients from lm 215 | lin1 = coef(fit_lm)[1], 216 | lin2 = coef(fit_lm)[2], 217 | # SVCs 218 | svc1 = coef(fit_svc)[1] + fitted(fit_svc)[, 1], 219 | svc2 = coef(fit_svc)[2] + fitted(fit_svc)[, 2] 220 | ) 221 | matplot( 222 | x = df_train$locs, 223 | y = mat_coef, pch = c(1, 2, 1, 2), col = c(1, 1, 2, 2), 224 | xlab = "Location", ylab = "Beta", main = "Estimated Coefficients") 225 | legend("topright", legend = c("Intercept", "covariate x", "linear model", "SVC model"), 226 | pch = c(1, 2, 19, 19), col = c("grey", "grey", "black", "red")) 227 | ``` 228 | 229 | #### Spatial Prediction 230 | 231 | We use the entire data set to compute the in- and out-of-sample rooted mean square error (RMSE) for the response for both the linear and SVC model. Here we rely on the `predict()` methods. Further, we can compare the predicted coefficients with the true coefficients provided in `SVCdata`, something that we usually cannot do. 232 | 233 | ```{r synthetic data predictive performance} 234 | # using method predict with whole data and corresponding locations 235 | df_svc_pred <- predict(fit_svc, newdata = df, newlocs = df$locs) 236 | # combining mean values and deviations 237 | mat_coef_pred <- cbind( 238 | svc1_pred = coef(fit_svc)[1] + df_svc_pred[, 1], 239 | svc2_pred = coef(fit_svc)[2] + df_svc_pred[, 2] 240 | ) 241 | # plot 242 | matplot(x = df$locs, y = mat_coef_pred, 243 | xlab = "Location", ylab = "Beta", 244 | main = "Predicted vs Actual Coefficients", 245 | col = c(1, 2), lty = c(1, 1), type = "l") 246 | points(x = df$locs, y = SVCdata$beta[, 1], col = 1, pch = ".") 247 | points(x = df$locs, y = SVCdata$beta[, 2], col = 2, pch = ".") 248 | legend("topright", legend = c("Intercept", "Covariate", "Actual"), 249 | col = c("black", "red", "black"), 250 | pch = c(NA, NA, "."), 251 | lty = c(1, 1, NA)) 252 | ``` 253 | 254 | #### Model Interpretation 255 | 256 | The linear model is constant and the same for each location, i.e.: 257 | 258 | $$y = \beta_1 + \beta_2\cdot x + \varepsilon = `r round(coef(fit_lm)[1], 2)` + `r round(coef(fit_lm)[2], 2)` \cdot x + \varepsilon$$ 259 | Here, the SVC model can be interpreted in a similar way where on average, it is simply the mean coefficient value with some location specific deviation $\eta_j(s)$, i.e.: 260 | 261 | $$y = \beta_1(s) + \beta_2(s)\cdot x + \varepsilon = \bigl(`r round(coef(fit_svc)[1], 2)` + \eta_1(s)\bigr) + \bigl(`r round(coef(fit_svc)[2], 2)`+ \eta_2(s) \bigr) \cdot x + \varepsilon$$ 262 | 263 | Say we are interested in a particular position, like: 264 | ```{r sample location} 265 | (s_id <- sample(n, 1)) 266 | ``` 267 | 268 | The coordinate is $s_{`r s_id`} = `r round(df$locs[s_id], 2)`$. We can extract the deviations $\eta_j(s)$ and simply add them to the model. We receive the following location specific model. 269 | 270 | $$y = \beta_1(s_{`r s_id`}) + \beta_2(s_{`r s_id`})\cdot x + \varepsilon = \bigl(`r round(coef(fit_svc)[1], 2)` `r round(df_svc_pred[s_id, 1], 2)`\bigr) + \bigl(`r round(coef(fit_svc)[2], 2)`+ `r round(df_svc_pred[s_id, 2], 2)`\bigr) \cdot x + \varepsilon = `r round(coef(fit_svc)[1] + df_svc_pred[s_id, 1], 2)` + `r round(coef(fit_svc)[2] + df_svc_pred[s_id, 2], 2)` \cdot x + \varepsilon$$ 271 | The remaining comparison of the two model at the given location is as usual. Between the both models we see that the intercept of the linear model is larger and the coefficient of $x$ is smaller than the 272 | SVC model's intercept and coefficient of $x$, respectively. 273 | 274 | #### Predictive Performance 275 | 276 | Finally, we compare the prediction errors of the model. We compute the rooted mean squared errors (RMSE) for both models and both the training and testing data. 277 | 278 | ```{r synthetic data RMSE} 279 | SE_lm <- (predict(fit_lm, newdata = df) - df$y)^2 280 | # df_svc_pred from above 281 | SE_svc <- (df_svc_pred$y.pred - df$y)^2 282 | kable(data.frame( 283 | model = c("linear", "SVC"), 284 | `in-sample RMSE` = round(sqrt(c(mean(SE_lm[idTrain]), mean(SE_svc[idTrain]))), 3), 285 | `out-of-sample RMSE` = round(sqrt(c(mean(SE_lm[-idTrain]), mean(SE_svc[-idTrain]))), 3) 286 | )) 287 | ``` 288 | 289 | We notice a significant difference in both RMSE between the models. On the training data, i.e., the in-sample RMSE, we observe and improvement by more than 50%. This is quite common since the SVC model has a higher flexibility. Therefore, it is very pleasing to see that even on the testing data, i.e., the out-of-sample RMSE, the SVC model still improves the RMSE by almost 30% compared to the linear model. 290 | 291 | ## Meuse Data Set Example 292 | 293 | We now turn to a real world data set, the `meuse` data from the package `sp`. 294 | 295 | ```{r meuse intro} 296 | library(sp) 297 | # attach sp and load data 298 | data("meuse") 299 | 300 | # documentation 301 | help("meuse") 302 | 303 | # overview 304 | summary(meuse) 305 | dim(meuse) 306 | ``` 307 | 308 | Our goal is to model the log `cadmium` measurements using the following independent variables: 309 | 310 | - `dist`, i.e. the normalized distance to the river Meuse. 311 | - `lime`, which is a 2-level factor indicating the presence of lime. 312 | - `elev`, i.e. the relative elevation above the local river bed. 313 | 314 | This provides us a model with "cheap" covariates and we can regress our variable of interest on them. 315 | 316 | ```{r meuse data and location of interest} 317 | df_meuse <- meuse[, c("dist", "lime", "elev")] 318 | df_meuse$l_cad <- log(meuse$cadmium) 319 | df_meuse$lime <- as.numeric(as.character(df_meuse$lime)) 320 | locs <- as.matrix(meuse[, c("x", "y")]) 321 | ``` 322 | 323 | ### Exploratory Data Analysis 324 | 325 | First, we plot the log Cadmium measurements at their respective locations. The color ranges from yellow (high Cadmium measurements) to black (low Cadmium measurements). 326 | 327 | ```{r meuse data spatial plot, echo = FALSE, message=FALSE, warning=FALSE} 328 | # load meuse river outlines 329 | data("meuse.riv") 330 | # create spatial object to create spplot 331 | sp_meuse <- df_meuse 332 | coordinates(sp_meuse) <- ~ locs 333 | # visualize log Cadmium measurements along river 334 | spplot( 335 | sp_meuse, zcol = "l_cad", main = "Meuse River and Log Cadmium Measurements" 336 | ) + latticeExtra::layer(panel.lines(meuse.riv)) 337 | ``` 338 | 339 | Generally, the values for `l_cad` are highest close to the river Meuse. However, there is some spatial structure comparing the center of all observations to the Northern part. Therefore, we expect the `dist` covariate to be an important regressor. Omitting the spatial structure, we can also look at a `pairs` plot. 340 | 341 | ```{r meuse data pairs} 342 | pairs(df_meuse) 343 | ``` 344 | 345 | Indeed, we note linear relationships between `l_cad` on the one hand and `elev` as well as `dist` on the other hand. Further, when `lime` is equal to 1, i.e., there is lime present in the soil, the Cadmium measurements are higher. 346 | 347 | ### Linear Model 348 | 349 | As a baseline, we start with a linear model: 350 | 351 | ```{r meuse linear model} 352 | fit_lm <- lm(l_cad ~ ., data = df_meuse) 353 | coef(fit_lm) 354 | ``` 355 | 356 | The residual analysis shows: 357 | 358 | ```{r LM residuals} 359 | oldpar <- par(mfrow = c(1, 2)) 360 | plot(fit_lm, which = 1:2) 361 | par(oldpar) 362 | ``` 363 | 364 | The spatial distribution of the residuals is the following: 365 | 366 | ```{r LM spatial residuals, echo=FALSE} 367 | # add residuals to spatial object 368 | sp_meuse$res_lm <- resid(fit_lm) 369 | # visualize linear model residuals along river 370 | spplot(sp_meuse, zcol = "res_lm", 371 | main = "Meuse River and Residuals of Linear Model" 372 | ) + latticeExtra::layer(panel.lines(meuse.riv)) 373 | ``` 374 | 375 | One can observe that there is a spatial structure in the residuals. This motivates us to use an SVC model. 376 | 377 | ### SVC Model 378 | 379 | The call to estimate the SVC model is again quite similar to the `lm()` call from above. However, we specify further arguments for the MLE using the `control` argument. First, we are using an optimization over the profiled likelihood (`profileLik = TRUE`) and second, we apply parameter scaling (`parscale = TRUE`) in the numeric optimization. Please check the corresponding help file `help("SVC_mle_control")` for more details. 380 | 381 | ```{r meuse SVC model, warning=FALSE} 382 | fit_svc <- SVC_mle(l_cad ~ ., data = df_meuse, locs = locs, 383 | control = SVC_mle_control( 384 | profileLik = TRUE, 385 | parscale = TRUE 386 | )) 387 | coef(fit_svc) 388 | ``` 389 | 390 | The obtained mean coefficient values of the linear and SVC model are quite similar, but this does not come as a surprise. 391 | 392 | ```{r meuse fixed effects, echo = FALSE} 393 | kable(t(data.frame( 394 | round(cbind(`linear` = coef(fit_lm), `SVC`= coef(fit_svc)), 3) 395 | ))) 396 | ``` 397 | 398 | ### Predictions 399 | 400 | Additionally to the `meuse` data the `sp` package also contains another data set called `meuse.grid` that contains a 40 by 40 meter spaced grid of the entire study area along the Meuse river. We can use the locations to predict the SVCs. However, the covariates `elev` and `lime` are missing. Therefore, we cannot predict the response. Again, the fitted SVC values are only the deviations from the mean. We observe that the SVC for `elev` is in fact constant. 401 | 402 | ```{r varycoef predict locations} 403 | # study area 404 | data("meuse.grid") 405 | # prediction 406 | df_svc_pred <- predict(fit_svc, newlocs = as.matrix(meuse.grid[, c("x", "y")])) 407 | colnames(df_svc_pred)[1:4] <- c("Intercept", "dist", "lime", "elev") 408 | head(df_svc_pred) 409 | ``` 410 | 411 | The attentive reader might have noticed that the `elev` column only contains 0. Therefore, there are no deviations and the respective coefficient is constant and our method is capable to estimate constant coefficients within the MLE. There exists a selection method to not only select the varying coefficients, but to also select the mean value, i.e., the fixed effect. Please refer to Dambon et al. (2022b) for further information. 412 | 413 | ## Conclusion 414 | 415 | SVC models are a powerful tool to analyze spatial data. With the R package `varycoef`, we provide an accessible and easy way to apply GP-based SVC models that is very close to the classical `lm` experience. If you have further questions or issues, please visit our [Github repository](https://github.com/jakobdambon/varycoef). 416 | 417 | 418 | ## References 419 | 420 | Dambon, J. A., Sigrist, F., Furrer, R. (2021) **Maximum likelihood estimation of spatially varying coefficient models for large data with an application to real estate price prediction**, Spatial Statistics, 41 (100470). [doi:10.1016/j.spasta.2020.100470 ](https://doi.org/10.1016/j.spasta.2020.100470) 421 | 422 | Dambon, J.A., Fahrländer, S.S., Karlen, S. et al. (2022a) **Examining the vintage effect in hedonic pricing using spatially varying coefficients models: a case study of single-family houses in the Canton of Zurich**, Swiss Journal Economics Statistics 158(2). [doi:10.1186/s41937-021-00080-2](https://doi.org/10.1186/s41937-021-00080-2) 423 | 424 | Dambon, J. A., Sigrist, F., Furrer, R. (2022b) **Joint variable selection of both fixed and random effects for Gaussian process-based spatially varying coefficient models**, International Journal of Geographical Information Science [doi:10.1080/13658816.2022.2097684](https://doi.org/10.1080/13658816.2022.2097684) 425 | 426 | Furrer, R. (2022) **Modeling Dependent Data**, [Lecture notes](http://user.math.uzh.ch/furrer/download/sta330/script_sta330.pdf) accessed on August 15, 2022 -------------------------------------------------------------------------------- /R-pkg/R/SVC_mle.R: -------------------------------------------------------------------------------- 1 | ## ----------------------------------------------------------------------------- 2 | ## In this script, one finds every function directly related to estimating 3 | ## and predicting SVC using our proposed MLE. 4 | ## ----------------------------------------------------------------------------- 5 | 6 | 7 | 8 | ## ---- help function to do MLE for SVC model ---- 9 | #' @importFrom stats coef lm.fit median var 10 | #' @importFrom optimParallel optimParallel 11 | #' @importFrom parallel clusterExport clusterEvalQ 12 | MLE_computation <- function( 13 | y, X, locs, W, control, optim.control 14 | ) { 15 | 16 | # set new options while recording old to reset on exit 17 | oopts <- options(spam.trivalues = TRUE, spam.cholsymmetrycheck = FALSE) 18 | on.exit(options(oopts)) 19 | 20 | ## -- set important dimensions ---- 21 | # number random effects and fixed effects 22 | q <- dim(W)[2] 23 | p <- dim(X)[2] 24 | # indices of objective and covariance parameters 25 | id_obj <- if (control$profileLik) { 26 | (1:(2*q+1)) 27 | } else { 28 | (1:(2*q+1+p)) 29 | } 30 | id_cov <- (1:(2*q+1)) 31 | 32 | # define distance matrix 33 | d <- do.call( 34 | own_dist, 35 | c(list(x = locs, taper = control$tapering), control$dist) 36 | ) 37 | 38 | ## -- check and initialize optim vectors ----- 39 | if (is.null(control$lower) | is.null(control$upper) | is.null(control$init)) { 40 | # median distances 41 | med_dist <- if (is.matrix(d)) { 42 | median(as.numeric(d)) 43 | } else { 44 | median(lower.tri(d@entries)) 45 | } 46 | # variance of response 47 | y_var <- var(y) 48 | # fixed effects estimates by ordinary least squares (OLS) 49 | OLS_mu <- coef(lm.fit(x = X, y = y)) 50 | } else { 51 | med_dist <- y_var <- OLS_mu <- NULL 52 | } 53 | # liu - _L_ower _I_nit _U_pper 54 | liu <- init_bounds_optim(control, p, q, id_obj, med_dist, y_var, OLS_mu) 55 | 56 | ## -- define distance matrices, covariance functions, and taper matrix ----- 57 | # get covariance function 58 | raw.cov.func <- MLE.cov.func(control$cov.name) 59 | 60 | # covariance function 61 | cov.func <- function(x) raw.cov.func(d, x) 62 | 63 | Rstruct <- NULL 64 | # tapering? 65 | if (is.null(control$tapering)) { 66 | taper <-NULL 67 | outer.W <- lapply(1:q, function(k) W[, k]%o%W[, k]) 68 | } else { 69 | taper <- get_taper(control$cov.name, d, control$taper) 70 | outer.W <- lapply(1:q, function(k) { 71 | (W[, k]%o%W[, k]) * taper 72 | }) 73 | 74 | Sigma1 <- Sigma_y( 75 | x = liu$init[id_cov], 76 | cov_func = cov.func, 77 | outer.W = outer.W, 78 | taper = taper 79 | ) 80 | Rstruct <- spam::chol.spam(Sigma1) 81 | } 82 | 83 | ## -- pc priors ----- 84 | # ordering: pcp = c(\rho_0, \alpha_\rho, \sigma_0, \alpha_\sigma) 85 | pcp.neg2dens <- if (is.null(control$pc.prior)) { 86 | NULL 87 | } else { 88 | pcp <- control$pc.prior 89 | 90 | lambda.r <- -log(pcp[2])*2*pcp[1] 91 | lambda.s <- -log(pcp[4])/pcp[3] 92 | 93 | # for Matérn GRF (-2 * log( pc prior dens)) 94 | function(theta) { 95 | 4*log(theta[1]) + 96 | lambda.r/theta[1]+2*lambda.s*sqrt(theta[2]) 97 | } 98 | 99 | } 100 | 101 | 102 | # how to compute mu if optimization is over porfile likelihood 103 | # prepare for optimization by computing mean effect 104 | mu.estimate <- if (control$mean.est == "GLS") { 105 | NULL 106 | } else { # Ordinary Least Squares 107 | coef(lm.fit(x = X, y = y)) 108 | } 109 | 110 | # extract objective function 111 | if (control$extract_fun) { 112 | 113 | obj_fun <- function(x, ...) 114 | n2LL(x, ...) 115 | args <- list( 116 | cov_func = cov.func, 117 | outer.W = outer.W, 118 | y = y, 119 | X = X, 120 | W = W, 121 | mean.est = mu.estimate, 122 | taper = taper, 123 | pc.dens = pcp.neg2dens, 124 | Rstruct = Rstruct, 125 | profile = control$profileLik 126 | ) 127 | 128 | return(list( 129 | obj_fun = obj_fun, 130 | args = args 131 | )) 132 | } 133 | 134 | # overwrite parameter scaling if required 135 | if (control$parscale) { 136 | optim.control$parscale <- abs(ifelse( 137 | liu$init[id_obj] == 0, 0.001, liu$init[id_obj] 138 | )) 139 | } 140 | 141 | 142 | ## -- optimization ----- 143 | if (is.null(control$parallel)) { 144 | # ... without parallelization 145 | optim.output <- stats::optim( 146 | par = liu$init[id_obj], 147 | fn = n2LL, 148 | # arguments of 2nLL 149 | cov_func = cov.func, 150 | outer.W = outer.W, 151 | y = y, 152 | X = X, 153 | W = W, 154 | mean.est = mu.estimate, 155 | taper = taper, 156 | pc.dens = pcp.neg2dens, 157 | Rstruct = Rstruct, 158 | profile = control$profileLik, 159 | method = "L-BFGS-B", 160 | lower = liu$lower[id_obj], 161 | upper = liu$upper[id_obj], 162 | hessian = control$hessian, 163 | control = optim.control) 164 | } else { 165 | # ... with parallelization 166 | parallel::clusterEvalQ( 167 | cl = control$parallel$cl, 168 | { 169 | library(spam) 170 | library(varycoef) 171 | } 172 | ) 173 | 174 | parallel::clusterExport( 175 | cl = control$parallel$cl, 176 | varlist = ls(), 177 | envir = environment() 178 | ) 179 | 180 | optim.output <- optimParallel::optimParallel( 181 | par = liu$init[id_obj], 182 | fn = n2LL, 183 | # arguments of 2nLL 184 | cov_func = cov.func, 185 | outer.W = outer.W, 186 | y = y, 187 | X = X, 188 | W = W, 189 | mean.est = mu.estimate, 190 | taper = taper, 191 | pc.dens = pcp.neg2dens, 192 | Rstruct = Rstruct, 193 | profile = control$profileLik, 194 | lower = liu$lower[id_obj], 195 | upper = liu$upper[id_obj], 196 | hessian = control$hessian, 197 | control = optim.control, 198 | parallel = control$parallel 199 | ) 200 | } 201 | 202 | ## -- Estimates and Standard errors ----- 203 | # compute covariance matrices 204 | Sigma_final <- Sigma_y( 205 | optim.output$par[id_cov], cov.func, outer.W, taper = taper 206 | ) 207 | 208 | par_SE <- prep_par_output( 209 | optim.output$par, Sigma_final, Rstruct, control$profileLik, X, y, 210 | optim.output$hessian, q 211 | ) 212 | 213 | # effective degrees of freedom 214 | edof <- eff_dof( 215 | cov.par = par_SE$RE$est, 216 | cov_func = cov.func, 217 | outer.W = outer.W, 218 | X = X, 219 | taper = taper 220 | ) 221 | 222 | # preparing output 223 | return( 224 | list( 225 | optim.output = optim.output, 226 | call.args = list( 227 | y = as.numeric(y), 228 | X = as.matrix(X), 229 | locs = as.matrix(locs), 230 | control = control, 231 | optim.control = optim.control, 232 | W = W 233 | ), 234 | comp.args = list( 235 | liu = liu, 236 | edof = edof, 237 | Sigma_final = Sigma_final, 238 | par_SE = par_SE 239 | ) 240 | ) 241 | ) 242 | } 243 | 244 | ## ---- help function to compute fitted values after MLE ---- 245 | fitted_computation <- function(SVC_obj, y, X, W, locs) { 246 | class(SVC_obj) <- "SVC_mle" 247 | 248 | 249 | predict.SVC_mle(SVC_obj, newlocs = locs, newX = X, newW = W) 250 | 251 | } 252 | 253 | ## ---- help function to construct SVC_mle object ---- 254 | create_SVC_mle <- function( 255 | ML_estimate, 256 | y, 257 | X, 258 | W, 259 | locs, 260 | control, 261 | formula = NULL, 262 | RE_formula = NULL 263 | ) { 264 | 265 | q <- dim(W)[2] 266 | 267 | # extract covariance parameters and coefficients for methods 268 | cov.par <- ML_estimate$comp.args$par_SE$RE$est 269 | mu <- ML_estimate$comp.args$par_SE$FE$est 270 | 271 | # non zero parameters, i.e., means or variances 272 | df <- sum(abs(c(mu, cov.par[2*(1:q)])) > 1e-10) 273 | 274 | SVC_obj <- list( 275 | MLE = ML_estimate, 276 | coefficients = mu, 277 | cov.par = cov.par, 278 | # (effective) degrees of freedom 279 | df = list( 280 | df = as.integer(df), 281 | edof = ML_estimate$comp.args$edof), 282 | fitted = NULL, 283 | residuals = NULL, 284 | data = list(y = y, X = X, W = W, locs = locs), 285 | formula = formula, 286 | RE_formula = RE_formula 287 | ) 288 | 289 | 290 | if (control$save.fitted) { 291 | # compute fitted values (i.e. EBLUP = empirical BLUP) 292 | pred <- fitted_computation(SVC_obj, y, X, W, locs) 293 | 294 | SVC_obj$fitted = pred 295 | SVC_obj$residuals = y-pred$y.pred 296 | } 297 | 298 | return(SVC_obj) 299 | } 300 | 301 | 302 | #' @title Set Parameters for \code{SVC_mle} 303 | #' 304 | #' @description Function to set up control parameters for \code{\link{SVC_mle}}. 305 | #' In the following, we assume the GP-based SVC model to have \eqn{q} GPs which 306 | #' model the SVCs and \eqn{p} fixed effects. 307 | #' 308 | #' @param cov.name (\code{character(1)}) \cr 309 | #' Name of the covariance function of the GPs. Currently, the following are 310 | #' implemented: \code{"exp"} for the exponential, \code{"sph"} for 311 | #' spherical, \code{"mat32"} and \code{"mat52"} for Matern class covariance 312 | #' functions with smoothness 3/2 or 5/2, as well as \code{"wend1"} and 313 | #' \code{"wend2"} for Wendland class covariance functions with kappa 1 or 2. 314 | #' @param tapering (\code{NULL} or \code{numeric(1)}) \cr 315 | #' If \code{NULL}, no tapering is applied. If a scalar is given, covariance 316 | #' tapering with this taper range is applied, for all Gaussian processes 317 | #' modeling the SVC. Only defined for Matern class covariance functions, 318 | #' i.e., set \code{cov.name} either to \code{"exp"}, \code{"mat32"}, or 319 | #' \code{"mat52"}. 320 | #' @param parallel (\code{NULL} or \code{list}) \cr 321 | #' If \code{NULL}, no parallelization is applied. If cluster has been 322 | #' established, define arguments for parallelization with a list, see 323 | #' documentation of \code{\link[optimParallel]{optimParallel}}. See Examples. 324 | #' @param init (\code{NULL} or \code{numeric(2q+1+p*as.numeric(profileLik))}) \cr 325 | #' Initial values for optimization procedure. If \code{NULL} is given, an 326 | #' initial vector is calculated (see Details). Otherwise, the vector is 327 | #' assumed to consist of q-times (alternating) range and variance, 328 | #' the nugget variance and if \code{profileLik = TRUE} p mean effects. 329 | #' @param lower (\code{NULL} or \code{numeric(2q+1+p*as.numeric(profileLik))}) \cr 330 | #' Lower bound for \code{init} in \code{optim}. Default \code{NULL} calculates 331 | #' the lower bounds (see Details). 332 | #' @param upper (\code{NULL} or \code{numeric(2q+1+p*as.numeric(profileLik))}) \cr 333 | #' Upper bound for \code{init} in \code{optim}. Default \code{NULL} calculates 334 | #' the upper bounds (see Details). 335 | #' @param save.fitted (\code{logical(1)}) \cr 336 | #' If \code{TRUE}, calculates the fitted values and residuals after MLE and 337 | #' stores them. This is necessary to call \code{\link{residuals}} and 338 | #' \code{\link{fitted}} methods afterwards. 339 | #' @param profileLik (\code{logical(1)}) \cr 340 | #' If \code{TRUE}, MLE is done over profile Likelihood of covariance 341 | #' parameters. 342 | #' @param mean.est (\code{character(1)}) \cr 343 | #' If \code{profileLik = TRUE}, the means have to be estimated seperately for 344 | #' each step. \code{"GLS"} uses the generalized least square estimate while 345 | #' \code{"OLS"} uses the ordinary least squares estimate. 346 | #' @param pc.prior (\code{NULL} or \code{numeric(4)}) \cr 347 | #' If numeric vector is given, penalized complexity priors are applied. The 348 | #' order is \eqn{\rho_0, \alpha_\rho, \sigma_0, \alpha_\sigma} to give some 349 | #' prior believes for the range and the standard deviation of GPs, such that 350 | #' \eqn{P(\rho < \rho_0) = \alpha_\rho, P(\sigma > \sigma_0) = \alpha_\sigma}. 351 | #' This regulates the optimization process. Currently, only supported for 352 | #' GPs with of Matérn class covariance functions. Based on the idea by 353 | #' Fulgstad et al. (2018) \doi{10.1080/01621459.2017.1415907}. 354 | #' @param extract_fun (\code{logical(1)}) \cr 355 | #' If \code{TRUE}, the function call of \code{\link{SVC_mle}} stops before 356 | #' the MLE and gives back the objective function of the MLE as well as all 357 | #' used arguments. If \code{FALSE}, regular MLE is conducted. 358 | #' @param hessian (\code{logical(1)}) \cr 359 | #' If \code{TRUE}, Hessian matrix is computed, see \link[stats]{optim}. This 360 | #' required to give the standard errors for covariance parameters and to do 361 | #' a Wald test on the variances, see \code{\link{summary.SVC_mle}}. 362 | #' @param dist (\code{list}) \cr 363 | #' List containing the arguments of \link[stats]{dist} or 364 | #' \link[spam]{nearest.dist}. This controls 365 | #' the method of how the distances and therefore dependency structures are 366 | #' calculated. The default gives Euclidean distances in a \eqn{d}-dimensional 367 | #' space. Further editable arguments are \code{p, miles, R}, see respective 368 | #' help files of \link[stats]{dist} or \link[spam]{nearest.dist}. 369 | #' @param parscale (\code{logical(1)}) \cr 370 | #' Triggers parameter scaling within the optimization in \link[stats]{optim}. 371 | #' If \code{TRUE}, the optional parameter scaling in \code{optim.control} in 372 | #' function \code{\link{SVC_mle}} is overwritten by the initial value used in 373 | #' the numeric optimization. The initial value is either computed from the 374 | #' data or provided by the user, see \code{init} argument above or Details 375 | #' below. Note that we check whether the initial values are unequal to zero. 376 | #' If they are zero, the corresponding scaling factor is 0.001. If 377 | #' \code{FALSE}, the \code{parscale} argument in \code{optim.control} is let 378 | #' unchanged. 379 | #' @param ... Further Arguments yet to be implemented 380 | #' 381 | #' @details If not provided, the initial values as well as the lower and upper 382 | #' bounds are calculated given the provided data. In particular, we require 383 | #' the median distance between observations, the variance of the response and, 384 | #' the ordinary least square (OLS) estimates, see \code{\link{init_bounds_optim}}. 385 | #' 386 | #' The argument \code{extract_fun} is useful, when one wants to modify 387 | #' the objective function. Further, when trying to parallelize the 388 | #' optimization, it is useful to check whether a single evaluation of the 389 | #' objective function takes longer than 0.05 seconds to evaluate, 390 | #' cf. Gerber and Furrer (2019) \doi{10.32614/RJ-2019-030}. Platform specific 391 | #' issues can be sorted out by the user by setting up their own optimization. 392 | #' 393 | #' @return A list with which \code{\link{SVC_mle}} can be controlled. 394 | #' @seealso \code{\link{SVC_mle}} 395 | #' 396 | #' @examples 397 | #' control <- SVC_mle_control(init = rep(0.3, 10)) 398 | #' # or 399 | #' control <- SVC_mle_control() 400 | #' control$init <- rep(0.3, 10) 401 | #' 402 | #' \donttest{ 403 | #' # Code for setting up parallel computing 404 | #' require(parallel) 405 | #' # exchange number of nodes (1) for detectCores()-1 or appropriate number 406 | #' cl <- makeCluster(1, setup_strategy = "sequential") 407 | #' clusterEvalQ( 408 | #' cl = cl, 409 | #' { 410 | #' library(spam) 411 | #' library(varycoef) 412 | #' }) 413 | #' # use this list for parallel argument in SVC_mle_control 414 | #' parallel.control <- list(cl = cl, forward = TRUE, loginfo = TRUE) 415 | #' # SVC_mle goes here ... 416 | #' # DO NOT FORGET TO STOP THE CLUSTER! 417 | #' stopCluster(cl); rm(cl) 418 | #' } 419 | #' @author Jakob Dambon 420 | #' 421 | #' @export 422 | SVC_mle_control <- function(...) UseMethod("SVC_mle_control") 423 | 424 | 425 | #' @rdname SVC_mle_control 426 | #' @export 427 | SVC_mle_control.default <- function( 428 | cov.name = c("exp", "sph", "mat32", "mat52", "wend1", "wend2"), 429 | tapering = NULL, 430 | parallel = NULL, 431 | init = NULL, 432 | lower = NULL, 433 | upper = NULL, 434 | save.fitted = TRUE, 435 | profileLik = FALSE, 436 | mean.est = c("GLS", "OLS"), 437 | pc.prior = NULL, 438 | extract_fun = FALSE, 439 | hessian = TRUE, 440 | dist = list(method = "euclidean"), 441 | parscale = TRUE, 442 | ... 443 | ) { 444 | stopifnot( 445 | is.null(tapering) | (tapering>=0), 446 | is.logical(save.fitted), 447 | is.logical(profileLik), 448 | is.logical(extract_fun), 449 | is.logical(hessian), 450 | is.logical(parscale) 451 | ) 452 | 453 | # if (!is.null(tapering) & 454 | # !(match.arg(cov.name) %in% c("sph", "wend1", "wend2"))) { 455 | # stop("Covariance tapering only defined for Matern class covariance functions.") 456 | # } 457 | 458 | list( 459 | cov.name = match.arg(cov.name), 460 | tapering = tapering, 461 | parallel = parallel, 462 | init = init, 463 | lower = lower, 464 | upper = upper, 465 | save.fitted = save.fitted, 466 | profileLik = profileLik, 467 | mean.est = match.arg(mean.est), 468 | pc.prior = pc.prior, 469 | extract_fun = extract_fun, 470 | hessian = hessian, 471 | dist = dist, 472 | parscale = parscale, 473 | ... 474 | ) 475 | } 476 | 477 | #' @param object (\code{SVC_mle}) \cr 478 | #' The function then extracts the control settings from the function call 479 | #' used to compute in the given \code{SVC_mle} object. 480 | #' 481 | #' @rdname SVC_mle_control 482 | #' @export 483 | SVC_mle_control.SVC_mle <- function(object, ...) { 484 | object$MLE$call.args$control 485 | } 486 | 487 | 488 | 489 | 490 | 491 | ############################### 492 | ## SVC MLE functions ########## 493 | ############################### 494 | 495 | 496 | #' @title MLE of SVC model 497 | #' 498 | #' @description Conducts a maximum likelihood estimation (MLE) for a Gaussian 499 | #' process-based spatially varying coefficient model as described in 500 | #' Dambon et al. (2021) \doi{10.1016/j.spasta.2020.100470}. 501 | #' 502 | #' @param y (\code{numeric(n)}) \cr 503 | #' Response vector. 504 | #' @param X (\code{matrix(n, p)}) \cr 505 | #' Design matrix. Intercept has to be added manually. 506 | #' @param locs (\code{matrix(n, d)}) \cr 507 | #' Locations in a \eqn{d}-dimensional space. May contain multiple 508 | #' observations at single location. 509 | #' @param W (\code{NULL} or \code{matrix(n, q)}) \cr 510 | #' If \code{NULL}, the same matrix as provided in \code{X} is used. This 511 | #' fits a full SVC model, i.e., each covariate effect is modeled with a mean 512 | #' and an SVC. In this case we have \eqn{p = q}. If optional matrix \code{W} 513 | #' is provided, SVCs are only modeled for covariates within matrix \code{W}. 514 | #' @param control (\code{list}) \cr 515 | #' Control paramaters given by \code{\link{SVC_mle_control}}. 516 | #' @param optim.control (\code{list}) \cr 517 | #' Control arguments for optimization function, see Details in 518 | #' \code{\link{optim}}. 519 | #' @param ... further arguments 520 | #' 521 | #' @details 522 | #' The GP-based SVC model is defined with some abuse of notation as: 523 | #' 524 | #' \deqn{y(s) = X \mu + W \eta (s) + \epsilon(s)} 525 | #' 526 | #' where: 527 | #' \itemize{ 528 | #' \item \eqn{y} is the response (vector of length \eqn{n}) 529 | #' \item \eqn{X} is the data matrix for the fixed effects covariates. The 530 | #' dimensions are \eqn{n} times \eqn{p}. This leads to \eqn{p} fixed effects. 531 | #' \item \eqn{\mu} is the vector containing the fixed effects 532 | #' \item W is the data matrix for the SVCs modeled by GPs. The dimensions are 533 | #' \eqn{n} times \eqn{q}. This lead to \eqn{q} SVCs in the model. 534 | #' \item \eqn{\eta} are the SVCs represented by a GP. 535 | #' \item \eqn{\epsilon} is the nugget effect 536 | #' } 537 | #' 538 | #' The MLE is an numeric optimization that runs \code{\link[stats]{optim}} or 539 | #' (if parallelized) \code{\link[optimParallel]{optimParallel}}. 540 | #' 541 | #' You can call the function in two ways. Either, you define the model matrices 542 | #' yourself and provide them using the arguments \code{X} and \code{W}. As usual, 543 | #' the individual columns correspond to the fixed and random effects, i.e., the 544 | #' Gaussian processes, respectively. The second way is to call the function with 545 | #' formulas, like you would in \code{\link[stats]{lm}}. From the \code{data.frame} 546 | #' provided in argument \code{data}, the respective model matrices as described 547 | #' above are implicitly built. Using simple arguments \code{formula} and 548 | #' \code{RE_formula} with \code{data} column names, we can decide which 549 | #' covariate is modeled with a fixed or random effect (SVC). 550 | #' 551 | #' Note that similar to model matrix call from above, if the \code{RE_formula} 552 | #' is not provided, we use the one as in argument \code{formula}. Further, note 553 | #' that the intercept is implicitly constructed in the model matrix if not 554 | #' prohibited. 555 | #' 556 | #' @return Object of class \code{SVC_mle} if \code{control$extract_fun = FALSE}, 557 | #' meaning that a MLE has been conducted. Otherwise, if \code{control$extract_fun = TRUE}, 558 | #' the function returns a list with two entries: 559 | #' \itemize{ 560 | #' \item \code{obj_fun}: the objective function used in the optimization 561 | #' \item \code{args}: the arguments to evaluate the objective function. 562 | #' } 563 | #' For further details, see description of \code{\link{SVC_mle_control}}. 564 | #' 565 | #' @references Dambon, J. A., Sigrist, F., Furrer, R. (2021) 566 | #' \emph{Maximum likelihood estimation of spatially varying coefficient 567 | #' models for large data with an application to real estate price prediction}, 568 | #' Spatial Statistics \doi{10.1016/j.spasta.2020.100470} 569 | #' @author Jakob Dambon 570 | #' 571 | #' @seealso \code{\link{predict.SVC_mle}} 572 | #' 573 | #' @examples 574 | #' ## ---- toy example ---- 575 | #' ## We use the sampled, i.e., one dimensional SVCs 576 | #' str(SVCdata) 577 | #' # sub-sample data to have feasible run time for example 578 | #' set.seed(123) 579 | #' id <- sample(length(SVCdata$locs), 50) 580 | #' 581 | #' ## SVC_mle call with matrix arguments 582 | #' fit <- with(SVCdata, SVC_mle( 583 | #' y[id], X[id, ], locs[id], 584 | #' control = SVC_mle_control(profileLik = TRUE, cov.name = "mat32"))) 585 | #' 586 | #' ## SVC_mle call with formula 587 | #' df <- with(SVCdata, data.frame(y = y[id], X = X[id, -1])) 588 | #' fit <- SVC_mle( 589 | #' y ~ X, data = df, locs = SVCdata$locs[id], 590 | #' control = SVC_mle_control(profileLik = TRUE, cov.name = "mat32") 591 | #' ) 592 | #' class(fit) 593 | #' 594 | #' summary(fit) 595 | #' 596 | #' \donttest{ 597 | #' ## ---- real data example ---- 598 | #' require(sp) 599 | #' ## get data set 600 | #' data("meuse", package = "sp") 601 | #' 602 | #' # construct data matrix and response, scale locations 603 | #' y <- log(meuse$cadmium) 604 | #' X <- model.matrix(~1+dist+lime+elev, data = meuse) 605 | #' locs <- as.matrix(meuse[, 1:2])/1000 606 | #' 607 | #' 608 | #' ## starting MLE 609 | #' # the next call takes a couple of seconds 610 | #' fit <- SVC_mle( 611 | #' y = y, X = X, locs = locs, 612 | #' # has 4 fixed effects, but only 3 random effects (SVC) 613 | #' # elev is missing in SVC 614 | #' W = X[, 1:3], 615 | #' control = SVC_mle_control( 616 | #' # inital values for 3 SVC 617 | #' # 7 = (3 * 2 covariance parameters + nugget) 618 | #' init = c(rep(c(0.4, 0.2), 3), 0.2), 619 | #' profileLik = TRUE 620 | #' ) 621 | #' ) 622 | #' 623 | #' ## summary and residual output 624 | #' summary(fit) 625 | #' plot(fit) 626 | #' 627 | #' ## predict 628 | #' # new locations 629 | #' newlocs <- expand.grid( 630 | #' x = seq(min(locs[, 1]), max(locs[, 1]), length.out = 30), 631 | #' y = seq(min(locs[, 2]), max(locs[, 2]), length.out = 30)) 632 | #' # predict SVC for new locations 633 | #' SVC <- predict(fit, newlocs = as.matrix(newlocs)) 634 | #' # visualization 635 | #' sp.SVC <- SVC 636 | #' coordinates(sp.SVC) <- ~loc_1+loc_2 637 | #' spplot(sp.SVC, colorkey = TRUE) 638 | #' } 639 | #' @import spam 640 | #' @importFrom stats dist optim 641 | #' @importFrom optimParallel optimParallel 642 | #' @export 643 | SVC_mle <- function(...) UseMethod("SVC_mle") 644 | 645 | 646 | 647 | #' @rdname SVC_mle 648 | #' @export 649 | SVC_mle.default <- function( 650 | y, 651 | X, 652 | locs, 653 | W = NULL, 654 | control = NULL, 655 | optim.control = list(), 656 | ... 657 | ) { 658 | 659 | # check if W is given arguments 660 | if (is.null(W)) {W <- X} 661 | 662 | # call SVC_mle with default control settings if non are provided 663 | if (is.null(control)) { 664 | control <- SVC_mle_control() 665 | } 666 | 667 | # Start ML Estimation using optim 668 | ML_estimate <- MLE_computation( 669 | y = y, 670 | X = X, 671 | locs = locs, 672 | W = W, 673 | control = control, 674 | optim.control = optim.control 675 | ) 676 | 677 | if (is.function(ML_estimate$obj_fun)) { 678 | # extract objective function 679 | object <- ML_estimate 680 | class(object) <- "SVC_obj_fun" 681 | return(object) 682 | } else { 683 | # after optimization 684 | object <- create_SVC_mle( 685 | ML_estimate, y, X, W, locs, control, 686 | formula = NULL, RE_formula = NULL 687 | ) 688 | object$call <- match.call() 689 | class(object) <- "SVC_mle" 690 | return(object) 691 | } 692 | 693 | } 694 | 695 | # formula call 696 | 697 | #' @param formula Formula describing the fixed effects in SVC model. The response, 698 | #' i.e. LHS of the formula, is not allowed to have functions such as \code{sqrt()} or \code{log()}. 699 | #' @param data data frame containing the observations 700 | #' @param RE_formula Formula describing the random effects in SVC model. 701 | #' Only RHS is considered. If \code{NULL}, the same RHS of argument \code{formula} for fixed effects is used. 702 | #' @importFrom stats model.matrix 703 | #' 704 | #' @rdname SVC_mle 705 | #' @export 706 | SVC_mle.formula <- function( 707 | formula, 708 | data, 709 | RE_formula = NULL, 710 | locs, 711 | control = NULL, 712 | optim.control = list(), 713 | ... 714 | ) { 715 | # extract model matrix 716 | X <- as.matrix(stats::model.matrix(formula, data = data)) 717 | if (is.null(RE_formula)) { 718 | W <- X 719 | RE_formula <- formula 720 | } else { 721 | W <- as.matrix(stats::model.matrix(RE_formula, data = data)) 722 | } 723 | y <- as.numeric(data[, all.vars(formula)[1]]) 724 | 725 | # call SVC_mle with default control settings if non are provided 726 | if (is.null(control)) { 727 | control <- SVC_mle_control() 728 | } 729 | 730 | # Start ML Estimation using optim 731 | ML_estimate <- MLE_computation( 732 | y = y, 733 | X = X, 734 | locs = locs, 735 | W = W, 736 | control = control, 737 | optim.control = optim.control 738 | ) 739 | 740 | # after optimization 741 | object <- create_SVC_mle( 742 | ML_estimate, y, X, W, locs, control, 743 | formula = formula, RE_formula = RE_formula 744 | ) 745 | object$call <- match.call() 746 | class(object) <- "SVC_mle" 747 | return(object) 748 | } 749 | 750 | --------------------------------------------------------------------------------