From 08bdbd0548a15f0bf58d7094c6ac568cc02049d0 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Thu, 25 May 2023 00:06:57 +0300 Subject: [PATCH 01/47] Increment version number to 2.3.0.9000 --- DESCRIPTION | 2 +- NEWS.md | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index a967343f..e7924e9f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,7 +2,7 @@ Package: rSPDE Type: Package Title: Rational Approximations of Fractional Stochastic Partial Differential Equations -Version: 2.3.0 +Version: 2.3.0.9000 Authors@R: c( person("David", "Bolin", email = "davidbolin@gmail.com", role = c("cre", "aut")), person("Alexandre", "Simas", email = "alexandre.impa@gmail.com", role = "aut"), diff --git a/NEWS.md b/NEWS.md index c93d557d..7e65fbbe 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,5 @@ +# rSPDE (development version) + # rSPDE 2.3.0 * Fixed a bug on rSPDE.construct.matern.loglike when the parameterization is "matern". * Created the rspde_lme() interface, with corresponding standard methods(predict, summary, etc). From 0ddd145d1e95d0e1d135d37fdac14f2186c26802 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Thu, 25 May 2023 10:22:58 +0300 Subject: [PATCH 02/47] Adjusts cran --- DESCRIPTION | 2 +- vignettes/build_source.rmd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index e7924e9f..5cf6f138 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -8,7 +8,7 @@ Authors@R: c( person("Alexandre", "Simas", email = "alexandre.impa@gmail.com", role = "aut"), person("Finn", "Lindgren", email = "finn.lindgren@ed.ac.uk", role = "ctb")) Maintainer: David Bolin -Description: Functions that compute rational approximations of fractional elliptic stochastic partial differential equations. The package also contains functions for common statistical usage of these approximations. +Description: Functions that compute rational approximations of fractional elliptic stochastic partial differential equations. The package also contains functions for common statistical usage of these approximations. The main references for rSPDE are Bolin, Simas and Xiong (2023) for the covariance-based method and in Bolin and Kirchner (2020) for the operator-based rational approximation. These can be generated by the citation function in R. Depends: R (>= 3.5.0), Matrix Imports: stats, methods, numDeriv License: GPL (>=3) | file LICENSE diff --git a/vignettes/build_source.rmd b/vignettes/build_source.rmd index 71ced45d..4d4950fc 100644 --- a/vignettes/build_source.rmd +++ b/vignettes/build_source.rmd @@ -28,7 +28,7 @@ remotes::install_github("davidbolin/rspde", ref = "devel") ## Dependencies on Linux -The `rSPDE` package depends on the [Eigen C++ library](https://eigen.tuxfamily.org/). +The `rSPDE` package depends on the [Eigen C++ library](https://eigen.tuxfamily.org/index.php?title=Main_Page). To install Eigen on Ubuntu, run: From 7a8ec6b0a33a727fd230484fa879098effdd3fb4 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Thu, 25 May 2023 10:41:21 +0300 Subject: [PATCH 03/47] Adjusts for cran --- DESCRIPTION | 2 +- NEWS.md | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 5cf6f138..e030303f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,7 +2,7 @@ Package: rSPDE Type: Package Title: Rational Approximations of Fractional Stochastic Partial Differential Equations -Version: 2.3.0.9000 +Version: 2.3.1.9000 Authors@R: c( person("David", "Bolin", email = "davidbolin@gmail.com", role = c("cre", "aut")), person("Alexandre", "Simas", email = "alexandre.impa@gmail.com", role = "aut"), diff --git a/NEWS.md b/NEWS.md index 7e65fbbe..6a9cbcf5 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,9 @@ # rSPDE (development version) +# rSPDE 2.3.1 +* Adding references in DESCRIPTION. +* Changing link to eigen library. + # rSPDE 2.3.0 * Fixed a bug on rSPDE.construct.matern.loglike when the parameterization is "matern". * Created the rspde_lme() interface, with corresponding standard methods(predict, summary, etc). From a3027f77fe80ac7cfe5b0778e8f45aa4d220a08d Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Thu, 25 May 2023 23:16:42 +0300 Subject: [PATCH 04/47] Adding needscompilation on DESCRIPTION and updating installation instructions --- DESCRIPTION | 2 +- README.md | 24 +++++++++++++----------- 2 files changed, 14 insertions(+), 12 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index e030303f..226e1a95 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -21,7 +21,7 @@ Suggests: knitr, rmarkdown, INLA (>= 22.12.14), testthat, rgdal, Additional_repositories: https://inla.r-inla-download.org/R/testing BugReports: https://github.com/davidbolin/rSPDE/issues VignetteBuilder: knitr -NeedsCompilation: no +NeedsCompilation: yes Author: David Bolin [cre, aut], Alexandre Simas [aut], Finn Lindgren [ctb] diff --git a/README.md b/README.md index 6af9b1ab..079ad91a 100644 --- a/README.md +++ b/README.md @@ -30,7 +30,13 @@ D. Bolin and K. Kirchner (2020) [The rational SPDE approach for Gaussian random # Installation instructions # The latest CRAN release of the package can be installed directly from CRAN with `install.packages("rSPDE")`. -The latest stable version (which is sometimes slightly more recent than the CRAN version), can be installed by using the command + +It is also possible to install the CRAN version from github by using the command: +```r +remotes::install_github("davidbolin/rspde", ref = "cran") +``` + +The latest stable version (which on very rare occasions can be slightly more recent than the CRAN version), can be installed by using the command ```r remotes::install_github("davidbolin/rspde", ref = "stable") ``` @@ -39,17 +45,13 @@ in R. The development version can be installed using the command remotes::install_github("davidbolin/rspde", ref = "devel") ``` -If you want to install the package using the `remotes::install_github`-method on Windows, you first need to install `Rtools` and add the paths to `Rtools` and `gcc` to the Windows `PATH` environment variable. This can be done for the current R session only using the commands -```r -rtools = "C:\\Rtools\\bin" -gcc = "C:\\Rtools\\gcc-4.6.3\\bin" -Sys.setenv(PATH = paste(c(gcc, rtools, Sys.getenv("PATH")), collapse = ";")) -``` -where the variables `rtools` and `gcc` need to be changed if `Rtools` is not installed directly on `C:`, -and `gcc`'s version might need to be changed depending on the version of `Rtools`. +The `stable` and `devel` branches require compilation, which is not the case for the `cran` branch. + +For Windows operating systems, we recommend the user to install from the `cran` branch, which requires no compilation. + +The compilation is required to create a shared object to be used by `INLA`. However, the `INLA` installation comes with such a shared object. Thus, unless there is some specific reason for the user to want to compile from source, it is not required. -Finally, if you want to build the `rSPDE` package from source on Mac or Linux, please -click [here](https://davidbolin.github.io/rSPDE//articles/build_source.html). +Finally, we have the vignette [Building the rSPDE package from source on Mac and Linux](https://davidbolin.github.io/rSPDE//articles/build_source.html) to help you if you want to build the `rSPDE` package from source on Mac or Linux. # Repository branch workflows # The package version format for released versions is `major.minor.bugfix`. All regular development should be performed on the `devel` branch or in a feature branch, managed with `git flow feature`. Ideally, all the changes should be made on the `devel` branch. The `devel` version of the package should contain unit tests and examples for all important functions. Several functions may depend on `INLA`. Examples and tests for such functions might create problems when submitting to CRAN. To solve this problem, we created some Github Actions scripts that get the examples and tests depending on `INLA` on the `devel` branch and adapt to versions that will not fail on CRAN. Therefore, the best way to handle these situations is to avoid as much as possible to do any push to the `stable` branch. The idea is to update the `stable` branch by merges following the workflow that will be described below. From 76b3392bae7b922c305df6553ad3a6fb37c8490a Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Sat, 27 May 2023 20:04:03 +0300 Subject: [PATCH 05/47] improvements fit --- R/fractional.computations.R | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/R/fractional.computations.R b/R/fractional.computations.R index 10f09fcd..18fa0b2f 100644 --- a/R/fractional.computations.R +++ b/R/fractional.computations.R @@ -1457,9 +1457,27 @@ aux_CBrSPDE.matern.loglike <- function(object, Y, A, sigma.e, mu = 0, Q <- object$Q - Q.R <- Matrix::Cholesky(Q) + # Q.R <- Matrix::Cholesky(Q) - logQ <- 2 * c(determinant(Q.R, logarithm = TRUE)$modulus) + # logQ <- 2 * c(determinant(Q.R, logarithm = TRUE)$modulus) + + Q.frac <- object$Q.frac + + Q.fracR <- Matrix::Cholesky(Q.frac) + + logdetL <- object$logdetL + logdetC <- object$logdetC + Q.int.order <- object$Q.int$order + + if (Q.int.order > 0) { + # logQ <- 2 * sum(log(diag(Q.fracR))) + (Q.int.order) * + # (m + 1) * (logdetL - logdetC) + + logQ <- 2 * c(determinant(Q.fracR, logarithm = TRUE)$modulus) + (Q.int.order) * + (m + 1) * (logdetL - logdetC) + } else { + logQ <- 2 * c(determinant(Q.fracR, logarithm = TRUE)$modulus) + } ## compute Q_x|y if(object$alpha %% 1 == 0){ From ca340b0e131076f907629ec6644a21bef2feb5fd Mon Sep 17 00:00:00 2001 From: davidbolin Date: Sun, 28 May 2023 22:50:28 +0300 Subject: [PATCH 06/47] Bug fix in rspde.matern.precision for low values to \nu --- R/inla_rspde.R | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/R/inla_rspde.R b/R/inla_rspde.R index 8141996b..6a611bc6 100644 --- a/R/inla_rspde.R +++ b/R/inla_rspde.R @@ -2388,7 +2388,9 @@ type_rational_approx = "chebfun") { # add k_part into Q if (m_alpha == 0) { - Kpart <- fem_mesh_matrices[["c0"]] + C <- fem_mesh_matrices[["c0"]] + Kpart <- Matrix::Diagonal(dim(C)[1], 1 / rowSums(C)) + Kpart <- Kpart / k } else { if (m_alpha == 1) { @@ -2432,9 +2434,15 @@ type_rational_approx = "chebfun") { (L - p[i] * fem_mesh_matrices[["c0"]]) / r[i] } } - + if(m_alpha==0) { + C <- fem_mesh_matrices[["c0"]] + Kpart <- Matrix::Diagonal(dim(C)[1], 1 / rowSums(C)) + } else { + Kpart <- fem_mesh_matrices[["c0"]] + } + Q[[length(Q) + 1]] <- kappa^(4 * beta) * tau^2 * - fem_mesh_matrices[["c0"]] / k + Kpart / k return(Q) } else { @@ -2446,8 +2454,14 @@ type_rational_approx = "chebfun") { Q <- bdiag(Q, temp) } } - - Q <- bdiag(Q, fem_mesh_matrices[["c0"]] / k) + + if(m_alpha==0) { + C <- fem_mesh_matrices[["c0"]] + Kpart <- Matrix::Diagonal(dim(C)[1], 1 / rowSums(C)) + } else { + Kpart <- fem_mesh_matrices[["c0"]] + } + Q <- bdiag(Q, Kpart / k) Q <- Q * kappa^(4 * beta) From d9511a96c4e34e7eca1c1e2089b8231a70e8722e Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 11:52:13 +0300 Subject: [PATCH 07/47] adjusts news --- DESCRIPTION | 2 +- NEWS.md | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 226e1a95..a61262d4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -8,7 +8,7 @@ Authors@R: c( person("Alexandre", "Simas", email = "alexandre.impa@gmail.com", role = "aut"), person("Finn", "Lindgren", email = "finn.lindgren@ed.ac.uk", role = "ctb")) Maintainer: David Bolin -Description: Functions that compute rational approximations of fractional elliptic stochastic partial differential equations. The package also contains functions for common statistical usage of these approximations. The main references for rSPDE are Bolin, Simas and Xiong (2023) for the covariance-based method and in Bolin and Kirchner (2020) for the operator-based rational approximation. These can be generated by the citation function in R. +Description: Functions that compute rational approximations of fractional elliptic stochastic partial differential equations. The package also contains functions for common statistical usage of these approximations. The main references for rSPDE are Bolin, Simas and Xiong (2023) for the covariance-based method and Bolin and Kirchner (2020) for the operator-based rational approximation. These can be generated by the citation function in R. Depends: R (>= 3.5.0), Matrix Imports: stats, methods, numDeriv License: GPL (>=3) | file LICENSE diff --git a/NEWS.md b/NEWS.md index 6a9cbcf5..b8ec6a0e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,5 @@ # rSPDE (development version) +* Small improvement on speed for rspde_lme. # rSPDE 2.3.1 * Adding references in DESCRIPTION. From f673c4d07a2dea150979451335f10dd02e6eec1c Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 11:59:06 +0300 Subject: [PATCH 08/47] bugfix small nu in d=1 --- src/cgeneric_aux_nonstat.cpp | 2 +- src/cgeneric_aux_nonstat_fixed.cpp | 2 +- src/cgeneric_rspde_stat_frac_model.c | 11 ++++++++--- src/cgeneric_rspde_stat_general.c | 11 ++++++++--- 4 files changed, 18 insertions(+), 8 deletions(-) diff --git a/src/cgeneric_aux_nonstat.cpp b/src/cgeneric_aux_nonstat.cpp index 5f2faf8a..12ed256d 100644 --- a/src/cgeneric_aux_nonstat.cpp +++ b/src/cgeneric_aux_nonstat.cpp @@ -148,7 +148,7 @@ void compute_Q(int size, double *entries_C, int *i_C, int *j_C, // Assemble the K part if(m_alpha == 0){ - Q_tmp = C; + Q_tmp = C.cwiseInverse(); } else if(m_alpha == 1){ Q_tmp = L; } else{ diff --git a/src/cgeneric_aux_nonstat_fixed.cpp b/src/cgeneric_aux_nonstat_fixed.cpp index ba78ef36..d11cf627 100644 --- a/src/cgeneric_aux_nonstat_fixed.cpp +++ b/src/cgeneric_aux_nonstat_fixed.cpp @@ -114,7 +114,7 @@ void compute_Q_fixednu(int size, double *entries_C, int *i_C, int *j_C, // Assemble the K part if(m_alpha == 0){ - Q_tmp = C; + Q_tmp = C.cwiseInverse(); } else if(m_alpha == 1){ Q_tmp = L; } else{ diff --git a/src/cgeneric_rspde_stat_frac_model.c b/src/cgeneric_rspde_stat_frac_model.c index 137f5906..934e96cd 100644 --- a/src/cgeneric_rspde_stat_frac_model.c +++ b/src/cgeneric_rspde_stat_frac_model.c @@ -150,9 +150,14 @@ double *inla_cgeneric_rspde_stat_frac_model(inla_cgeneric_cmd_tp cmd, double *th fact_mult = multQ / (r[j] * SQR(kappa)); daxpy_(&full_size, &fact_mult, &fem_full->doubles[full_size], &one, &ret[k+j*full_size], &one); } - dcopy_(&less_size, &fem_less->doubles[0], &one, &ret[k+rspde_order * full_size], &one); - fact_mult = multQ/k_rat; - dscal_(&less_size, &fact_mult, &ret[k+rspde_order * full_size], &one); + // dcopy_(&less_size, &fem_less->doubles[0], &one, &ret[k+rspde_order * full_size], &one); + // fact_mult = multQ/k_rat; + // dscal_(&less_size, &fact_mult, &ret[k+rspde_order * full_size], &one); + for(i = 0; i < less_size; i++){ + ret[k+rspde_order*full_size + i] = multQ * ( + 1/(k_rat * fem_less->doubles[i]) + ); + } break; } case 1: diff --git a/src/cgeneric_rspde_stat_general.c b/src/cgeneric_rspde_stat_general.c index 4ec9159c..64414831 100644 --- a/src/cgeneric_rspde_stat_general.c +++ b/src/cgeneric_rspde_stat_general.c @@ -212,9 +212,14 @@ double *inla_cgeneric_rspde_stat_general_model(inla_cgeneric_cmd_tp cmd, double fact_mult = multQ / (r[j] * SQR(kappa)); daxpy_(&full_size, &fact_mult, &fem_full->doubles[full_size], &one, &ret[k+j*full_size], &one); } - dcopy_(&less_size, &fem_less->doubles[0], &one, &ret[k+rspde_order * full_size], &one); - fact_mult = multQ/k_rat; - dscal_(&less_size, &fact_mult, &ret[k+rspde_order * full_size], &one); + // dcopy_(&less_size, &fem_less->doubles[0], &one, &ret[k+rspde_order * full_size], &one); + // fact_mult = multQ/k_rat; + // dscal_(&less_size, &fact_mult, &ret[k+rspde_order * full_size], &one); + for(i = 0; i < less_size; i++){ + ret[k+rspde_order*full_size + i] = multQ * ( + 1/(k_rat * fem_less->doubles[i]) + ); + } break; } case 1: From b2697996aac7e5730a4ff9ab11f5787e09093faa Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 12:44:01 +0300 Subject: [PATCH 09/47] adding parameterization options for rspde.result --- R/inla_rspde.R | 213 +++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 171 insertions(+), 42 deletions(-) diff --git a/R/inla_rspde.R b/R/inla_rspde.R index 6a611bc6..7ce3c463 100644 --- a/R/inla_rspde.R +++ b/R/inla_rspde.R @@ -12,7 +12,7 @@ #' be estimated. If nu is `NULL`, it will be estimated. #' @param B.sigma Matrix with specification of log-linear model for \eqn{\sigma} (for 'matern' parameterization) or for \eqn{\sigma^2} (for 'matern2' parameterization). Will be used if `parameterization = 'matern'` or `parameterization = 'matern2'`. #' @param B.range Matrix with specification of log-linear model for \eqn{\rho}, which is a range-like parameter (it is exactly the range parameter in the stationary case). Will be used if `parameterization = 'matern'` or `parameterization = 'matern2'`. -#' @param parameterization Which parameterization to use? `matern` uses range, std. deviation and nu (smoothness). `spde` uses kappa, tau and nu (smoothness). `matern2` uses range-like (1/kappa), variance and nu (smoothness). The default is `matern`. +#' @param parameterization Which parameterization to use? `matern` uses range, std. deviation and nu (smoothness). `spde` uses kappa, tau and nu (smoothness). `matern2` uses range-like (1/kappa), variance and nu (smoothness). The default is `spde`. #' @param B.tau Matrix with specification of log-linear model for \eqn{\tau}. Will be used if `parameterization = 'spde'`. #' @param B.kappa Matrix with specification of log-linear model for \eqn{\kappa}. Will be used if `parameterization = 'spde'`. #' @param prior.kappa a `list` containing the elements `meanlog` and @@ -68,7 +68,7 @@ rspde.matern <- function(mesh, nu = NULL, B.sigma = matrix(c(0, 1, 0), 1, 3), B.range = matrix(c(0, 0, 1), 1, 3), - parameterization = c("matern", "spde", "matern2"), + parameterization = c("spde", "matern", "matern2"), B.tau = matrix(c(0, 1, 0), 1, 3), B.kappa = matrix(c(0, 0, 1), 1, 3), start.nu = NULL, @@ -1239,6 +1239,8 @@ rspde.make.index <- function(name, n.spde = NULL, n.group = 1, #' @param rspde The `inla_rspde` object used for the effect in #' the inla formula. #' @param compute.summary Should the summary be computed? +#' @param parameterization If 'detect', the parameterization from the model will be used. Otherwise, the options are 'spde', 'matern' and 'matern2'. +#' @param n_samples The number of samples to be used if parameterization is different from the one used to fit the model. #' @return If the model was fitted with `matern` parameterization (the default), it returns a list containing: #' \item{marginals.range}{Marginal densities for the range parameter} #' \item{marginals.log.range}{Marginal densities for log(range)} @@ -1331,15 +1333,26 @@ rspde.make.index <- function(name, n.spde = NULL, n.group = 1, #' } #' #devel.tag #' } -rspde.result <- function(inla, name, rspde, compute.summary = TRUE) { +rspde.result <- function(inla, name, rspde, compute.summary = TRUE, parameterization = "detect", n_samples = 5000) { check_class_inla_rspde(rspde) stationary <- rspde$stationary + parameterization <- parameterization[[1]] + parameterization <- tolower(parameterization) + + if(!(parameterization %in% c("detect", "spde", "matern", "matern2"))){ + stop("The possible options for parameterization are 'detect', 'spde', 'matern' and 'matern2'.") + } + nu.upper.bound <- rspde$nu.upper.bound result <- list() - parameterization <- rspde$parameterization + par_model <- rspde$parameterization + + if(parameterization == "detect"){ + parameterization <- rspde$parameterization + } if(stationary){ if (!rspde$est_nu) { @@ -1378,18 +1391,28 @@ rspde.result <- function(inla, name, rspde, compute.summary = TRUE) { name_theta2 <- "r" } - - result[[paste0("summary.log.",name_theta1)]] <- INLA::inla.extract.el( + if(par_model == "spde"){ + name_theta1_model <- "tau" + name_theta2_model <- "kappa" + } else if (par_model == "matern") { + name_theta1_model <- "std.dev" + name_theta2_model <- "range" + } else if (par_model == "matern2") { + name_theta1_model <- "var" + name_theta2_model <- "r" + } + + result[[paste0("summary.log.",name_theta1_model)]] <- INLA::inla.extract.el( inla$summary.hyperpar, paste("Theta1 for ", name, "$", sep = "") ) - rownames( result[[paste0("summary.log.",name_theta1)]]) <- paste0("log(",name_theta1,")") + rownames( result[[paste0("summary.log.",name_theta1_model)]]) <- paste0("log(",name_theta1_model,")") - result[[paste0("summary.log.",name_theta2)]] <- INLA::inla.extract.el( + result[[paste0("summary.log.",name_theta2_model)]] <- INLA::inla.extract.el( inla$summary.hyperpar, paste("Theta2 for ", name, "$", sep = "") ) - rownames(result[[paste0("summary.log.",name_theta2)]]) <- paste0("log(", name_theta2,")") + rownames(result[[paste0("summary.log.",name_theta2_model)]]) <- paste0("log(", name_theta2_model,")") if (rspde$est_nu) { result$summary.logit.nu <- INLA::inla.extract.el( inla$summary.hyperpar, @@ -1399,16 +1422,16 @@ rspde.result <- function(inla, name, rspde, compute.summary = TRUE) { } if (!is.null(inla$marginals.hyperpar[[paste0("Theta1 for ", name)]])) { - result[[paste0("marginals.log.",name_theta1)]] <- INLA::inla.extract.el( + result[[paste0("marginals.log.",name_theta1_model)]] <- INLA::inla.extract.el( inla$marginals.hyperpar, paste("Theta1 for ", name, "$", sep = "") ) - names(result[[paste0("marginals.log.",name_theta1)]]) <- name_theta1 - result[[paste0("marginals.log.",name_theta2)]] <- INLA::inla.extract.el( + names(result[[paste0("marginals.log.",name_theta1_model)]]) <- name_theta1_model + result[[paste0("marginals.log.",name_theta2_model)]] <- INLA::inla.extract.el( inla$marginals.hyperpar, paste("Theta2 for ", name, "$", sep = "") ) - names(result[[paste0("marginals.log.",name_theta2)]]) <- name_theta2 + names(result[[paste0("marginals.log.",name_theta2_model)]]) <- name_theta2_model if (rspde$est_nu) { result$marginals.logit.nu <- INLA::inla.extract.el( @@ -1418,39 +1441,145 @@ rspde.result <- function(inla, name, rspde, compute.summary = TRUE) { names(result$marginals.logit.nu) <- "nu" } - result[[paste0("marginals.",name_theta1)]] <- lapply( - result[[paste0("marginals.log.",name_theta1)]], - function(x) { - INLA::inla.tmarginal( - function(y) exp(y), - x - ) - } - ) - result[[paste0("marginals.",name_theta2)]] <- lapply( - result[[paste0("marginals.log.",name_theta2)]], - function(x) { - INLA::inla.tmarginal( - function(y) exp(y), - x - ) + + if(par_model == parameterization){ + result[[paste0("marginals.",name_theta1)]] <- lapply( + result[[paste0("marginals.log.",name_theta1)]], + function(x) { + INLA::inla.tmarginal( + function(y) exp(y), + x + ) + } + ) + result[[paste0("marginals.",name_theta2)]] <- lapply( + result[[paste0("marginals.log.",name_theta2)]], + function(x) { + INLA::inla.tmarginal( + function(y) exp(y), + x + ) + } + ) + if (rspde$est_nu) { + result$marginals.nu <- lapply( + result$marginals.logit.nu, + function(x) { + INLA::inla.tmarginal( + function(y) { + nu.upper.bound * exp(y) / (1 + exp(y)) + }, + x + ) + } + ) + } + } else{ + if(par_model == "spde"){ + dim <- rspde$dim + if (rspde$est_nu) { + nu_est <- rspde$nu.upper.bound * exp(hyperpar_sample[, paste0('Theta3 for ',name)])/(1+exp(hyperpar_sample[, paste0('Theta3 for ',name)])) + } else{ + nu_est <- rspde[["nu"]] + } + hyperpar_sample <- INLA::inla.hyperpar.sample(n_samples, inla) + tau_est <- exp(hyperpar_sample[, paste0('Theta1 for ',name)]) + kappa_est <- exp(hyperpar_sample[, paste0('Theta2 for ',name)]) + + sigma_est <- sqrt(gamma(0.5) / (tau_est^2 * kappa_est^(2 * nu_est) * + (4 * pi)^(dim / 2) * gamma(nu_est + dim / 2))) + + if(parameterization == "matern"){ + range_est <- sqrt(8 * nu_est)/kappa_est + density_theta1 <- stats::density(sigma_est) + density_theta2 <- stats::density(range_est) + } else if (parameterization == "matern2"){ + var_est <- sigma_est^2 + r_est <- 1/kappa_est + density_theta1 <- stats::density(var_est) + density_theta2 <- stats::density(r_est) + } + + result[[paste0("marginals.",name_theta1)]] <- list() + result[[paste0("marginals.",name_theta1)]][[name_theta1]] <- cbind(density_theta1$x, density_theta1$y) + colnames(result[[paste0("marginals.",name_theta1)]][[name_theta1]]) <- c("x","y") + + result[[paste0("marginals.",name_theta2)]] <- list() + result[[paste0("marginals.",name_theta2)]][[name_theta2]] <- cbind(density_theta2$x, density_theta2$y) + colnames(result[[paste0("marginals.",name_theta2)]][[name_theta2]]) <- c("x","y") + } else if(par_model == "matern"){ + dim <- rspde$dim + if (rspde$est_nu) { + nu_est <- rspde$nu.upper.bound * exp(hyperpar_sample[, paste0('Theta3 for ',name)])/(1+exp(hyperpar_sample[, paste0('Theta3 for ',name)])) + } else{ + nu_est <- rspde[["nu"]] + } + hyperpar_sample <- INLA::inla.hyperpar.sample(n_samples, inla) + sigma_est <- exp(hyperpar_sample[, paste0('Theta1 for ',name)]) + range_est <- exp(hyperpar_sample[, paste0('Theta2 for ',name)]) + + kappa_est <- sqrt(8 * nu_est)/range_est + + if(parameterization == "spde"){ + tau_est <- sqrt(gamma(0.5) / (sigma_est^2 * kappa_est^(2 * nu_est) * + (4 * pi)^(dim / 2) * gamma(nu_est + dim / 2))) + density_theta1 <- stats::density(tau_est) + density_theta2 <- stats::density(kappa_est) + } else if (parameterization == "matern2"){ + var_est <- sigma_est^2 + r_est <- 1/kappa_est + density_theta1 <- stats::density(var_est) + density_theta2 <- stats::density(r_est) + } + + result[[paste0("marginals.",name_theta1)]] <- list() + result[[paste0("marginals.",name_theta1)]][[name_theta1]] <- cbind(density_theta1$x, density_theta1$y) + colnames(result[[paste0("marginals.",name_theta1)]][[name_theta1]]) <- c("x","y") + + result[[paste0("marginals.",name_theta2)]] <- list() + result[[paste0("marginals.",name_theta2)]][[name_theta2]] <- cbind(density_theta2$x, density_theta2$y) + colnames(result[[paste0("marginals.",name_theta2)]][[name_theta2]]) <- c("x","y") + } else if(par_model == "matern2"){ + dim <- rspde$dim + if (rspde$est_nu) { + nu_est <- rspde$nu.upper.bound * exp(hyperpar_sample[, paste0('Theta3 for ',name)])/(1+exp(hyperpar_sample[, paste0('Theta3 for ',name)])) + } else{ + nu_est <- rspde[["nu"]] + } + hyperpar_sample <- INLA::inla.hyperpar.sample(n_samples, inla) + var_est <- exp(hyperpar_sample[, paste0('Theta1 for ',name)]) + r_est <- exp(hyperpar_sample[, paste0('Theta2 for ',name)]) + + kappa_est <- 1/r_est + sigma_est <- sqrt(var_est) + + if(parameterization == "spde"){ + tau_est <- sqrt(gamma(0.5) / (sigma_est^2 * kappa_est^(2 * nu_est) * + (4 * pi)^(dim / 2) * gamma(nu_est + dim / 2))) + density_theta1 <- stats::density(tau_est) + density_theta2 <- stats::density(kappa_est) + } else if (parameterization == "matern"){ + range_est <- sqrt(8 * nu_est)/kappa_est + density_theta1 <- stats::density(sigma_est) + density_theta2 <- stats::density(range_est) + } + + result[[paste0("marginals.",name_theta1)]] <- list() + result[[paste0("marginals.",name_theta1)]][[name_theta1]] <- cbind(density_theta1$x, density_theta1$y) + colnames(result[[paste0("marginals.",name_theta1)]][[name_theta1]]) <- c("x","y") + + result[[paste0("marginals.",name_theta2)]] <- list() + result[[paste0("marginals.",name_theta2)]][[name_theta2]] <- cbind(density_theta2$x, density_theta2$y) + colnames(result[[paste0("marginals.",name_theta2)]][[name_theta2]]) <- c("x","y") } - ) - if (rspde$est_nu) { - result$marginals.nu <- lapply( - result$marginals.logit.nu, - function(x) { - INLA::inla.tmarginal( - function(y) { - nu.upper.bound * exp(y) / (1 + exp(y)) - }, - x - ) - } - ) } + } + + + + if (compute.summary) { norm_const <- function(density_df) { min_x <- min(density_df[, "x"]) From 04f6c4d35a540fff6681c832a17d6a311603b963 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 12:45:00 +0300 Subject: [PATCH 10/47] Update NEWS.md --- NEWS.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS.md b/NEWS.md index b8ec6a0e..68784e50 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # rSPDE (development version) * Small improvement on speed for rspde_lme. +* Bugfix on Q for small values of nu in dimension 1. +* Adding parameterization option for rspde.result. # rSPDE 2.3.1 * Adding references in DESCRIPTION. From a80c67f6bc987fd733c004512a8147abd1c48fb1 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 13:13:31 +0300 Subject: [PATCH 11/47] add parameterization + adjust cgeneric --- R/inla_rspde.R | 53 ++++++++++++++++++---------- src/cgeneric_rspde_stat_frac_model.c | 2 ++ src/cgeneric_rspde_stat_general.c | 2 ++ vignettes/rspde_inlabru.Rmd | 25 ++++++++++++- 4 files changed, 62 insertions(+), 20 deletions(-) diff --git a/R/inla_rspde.R b/R/inla_rspde.R index 7ce3c463..7e3dd9a0 100644 --- a/R/inla_rspde.R +++ b/R/inla_rspde.R @@ -1241,6 +1241,7 @@ rspde.make.index <- function(name, n.spde = NULL, n.group = 1, #' @param compute.summary Should the summary be computed? #' @param parameterization If 'detect', the parameterization from the model will be used. Otherwise, the options are 'spde', 'matern' and 'matern2'. #' @param n_samples The number of samples to be used if parameterization is different from the one used to fit the model. +#' @param n_density The number of equally spaced points to estimate the density. #' @return If the model was fitted with `matern` parameterization (the default), it returns a list containing: #' \item{marginals.range}{Marginal densities for the range parameter} #' \item{marginals.log.range}{Marginal densities for log(range)} @@ -1333,7 +1334,7 @@ rspde.make.index <- function(name, n.spde = NULL, n.group = 1, #' } #' #devel.tag #' } -rspde.result <- function(inla, name, rspde, compute.summary = TRUE, parameterization = "detect", n_samples = 5000) { +rspde.result <- function(inla, name, rspde, compute.summary = TRUE, parameterization = "detect", n_samples = 5000, n_density = 1024) { check_class_inla_rspde(rspde) stationary <- rspde$stationary @@ -1477,12 +1478,12 @@ rspde.result <- function(inla, name, rspde, compute.summary = TRUE, parameteriza } else{ if(par_model == "spde"){ dim <- rspde$dim + hyperpar_sample <- INLA::inla.hyperpar.sample(n_samples, inla) if (rspde$est_nu) { nu_est <- rspde$nu.upper.bound * exp(hyperpar_sample[, paste0('Theta3 for ',name)])/(1+exp(hyperpar_sample[, paste0('Theta3 for ',name)])) } else{ nu_est <- rspde[["nu"]] } - hyperpar_sample <- INLA::inla.hyperpar.sample(n_samples, inla) tau_est <- exp(hyperpar_sample[, paste0('Theta1 for ',name)]) kappa_est <- exp(hyperpar_sample[, paste0('Theta2 for ',name)]) @@ -1491,13 +1492,13 @@ rspde.result <- function(inla, name, rspde, compute.summary = TRUE, parameteriza if(parameterization == "matern"){ range_est <- sqrt(8 * nu_est)/kappa_est - density_theta1 <- stats::density(sigma_est) - density_theta2 <- stats::density(range_est) + density_theta1 <- stats::density(sigma_est, n = n_density) + density_theta2 <- stats::density(range_est, n = n_density) } else if (parameterization == "matern2"){ var_est <- sigma_est^2 r_est <- 1/kappa_est - density_theta1 <- stats::density(var_est) - density_theta2 <- stats::density(r_est) + density_theta1 <- stats::density(var_est, n = n_density) + density_theta2 <- stats::density(r_est, n = n_density) } result[[paste0("marginals.",name_theta1)]] <- list() @@ -1508,13 +1509,13 @@ rspde.result <- function(inla, name, rspde, compute.summary = TRUE, parameteriza result[[paste0("marginals.",name_theta2)]][[name_theta2]] <- cbind(density_theta2$x, density_theta2$y) colnames(result[[paste0("marginals.",name_theta2)]][[name_theta2]]) <- c("x","y") } else if(par_model == "matern"){ + hyperpar_sample <- INLA::inla.hyperpar.sample(n_samples, inla) dim <- rspde$dim if (rspde$est_nu) { nu_est <- rspde$nu.upper.bound * exp(hyperpar_sample[, paste0('Theta3 for ',name)])/(1+exp(hyperpar_sample[, paste0('Theta3 for ',name)])) } else{ nu_est <- rspde[["nu"]] } - hyperpar_sample <- INLA::inla.hyperpar.sample(n_samples, inla) sigma_est <- exp(hyperpar_sample[, paste0('Theta1 for ',name)]) range_est <- exp(hyperpar_sample[, paste0('Theta2 for ',name)]) @@ -1523,13 +1524,13 @@ rspde.result <- function(inla, name, rspde, compute.summary = TRUE, parameteriza if(parameterization == "spde"){ tau_est <- sqrt(gamma(0.5) / (sigma_est^2 * kappa_est^(2 * nu_est) * (4 * pi)^(dim / 2) * gamma(nu_est + dim / 2))) - density_theta1 <- stats::density(tau_est) - density_theta2 <- stats::density(kappa_est) + density_theta1 <- stats::density(tau_est, n = n_density) + density_theta2 <- stats::density(kappa_est, n = n_density) } else if (parameterization == "matern2"){ var_est <- sigma_est^2 r_est <- 1/kappa_est - density_theta1 <- stats::density(var_est) - density_theta2 <- stats::density(r_est) + density_theta1 <- stats::density(var_est, n = n_density) + density_theta2 <- stats::density(r_est, n = n_density) } result[[paste0("marginals.",name_theta1)]] <- list() @@ -1540,13 +1541,13 @@ rspde.result <- function(inla, name, rspde, compute.summary = TRUE, parameteriza result[[paste0("marginals.",name_theta2)]][[name_theta2]] <- cbind(density_theta2$x, density_theta2$y) colnames(result[[paste0("marginals.",name_theta2)]][[name_theta2]]) <- c("x","y") } else if(par_model == "matern2"){ + hyperpar_sample <- INLA::inla.hyperpar.sample(n_samples, inla) dim <- rspde$dim if (rspde$est_nu) { nu_est <- rspde$nu.upper.bound * exp(hyperpar_sample[, paste0('Theta3 for ',name)])/(1+exp(hyperpar_sample[, paste0('Theta3 for ',name)])) } else{ nu_est <- rspde[["nu"]] } - hyperpar_sample <- INLA::inla.hyperpar.sample(n_samples, inla) var_est <- exp(hyperpar_sample[, paste0('Theta1 for ',name)]) r_est <- exp(hyperpar_sample[, paste0('Theta2 for ',name)]) @@ -1556,12 +1557,12 @@ rspde.result <- function(inla, name, rspde, compute.summary = TRUE, parameteriza if(parameterization == "spde"){ tau_est <- sqrt(gamma(0.5) / (sigma_est^2 * kappa_est^(2 * nu_est) * (4 * pi)^(dim / 2) * gamma(nu_est + dim / 2))) - density_theta1 <- stats::density(tau_est) - density_theta2 <- stats::density(kappa_est) + density_theta1 <- stats::density(tau_est, n = n_density) + density_theta2 <- stats::density(kappa_est, n = n_density) } else if (parameterization == "matern"){ range_est <- sqrt(8 * nu_est)/kappa_est - density_theta1 <- stats::density(sigma_est) - density_theta2 <- stats::density(range_est) + density_theta1 <- stats::density(sigma_est, n = n_density) + density_theta2 <- stats::density(range_est, n = n_density) } result[[paste0("marginals.",name_theta1)]] <- list() @@ -1572,6 +1573,21 @@ rspde.result <- function(inla, name, rspde, compute.summary = TRUE, parameteriza result[[paste0("marginals.",name_theta2)]][[name_theta2]] <- cbind(density_theta2$x, density_theta2$y) colnames(result[[paste0("marginals.",name_theta2)]][[name_theta2]]) <- c("x","y") } + + if (rspde$est_nu) { + result$marginals.nu <- lapply( + result$marginals.logit.nu, + function(x) { + INLA::inla.tmarginal( + function(y) { + nu.upper.bound * exp(y) / (1 + exp(y)) + }, + x + ) + } + ) + } + } } @@ -1614,13 +1630,12 @@ rspde.result <- function(inla, name, rspde, compute.summary = TRUE, parameteriza result[[paste0("marginals.",name_theta2)]][[name_theta2]][, "y"] <- result[[paste0("marginals.",name_theta2)]][[name_theta2]][, "y"] / norm_const_theta2 - - - result[[paste0("summary.",name_theta1)]] <- create_summary_from_density(result[[paste0("marginals.",name_theta1)]][[name_theta1]], name = name_theta1) + result[[paste0("summary.",name_theta2)]] <- create_summary_from_density(result[[paste0("marginals.",name_theta2)]][[name_theta2]], name = name_theta2) + if (rspde$est_nu) { norm_const_nu <- norm_const(result$marginals.nu$nu) result$marginals.nu$nu[, "y"] <- diff --git a/src/cgeneric_rspde_stat_frac_model.c b/src/cgeneric_rspde_stat_frac_model.c index 934e96cd..3de59cc6 100644 --- a/src/cgeneric_rspde_stat_frac_model.c +++ b/src/cgeneric_rspde_stat_frac_model.c @@ -154,9 +154,11 @@ double *inla_cgeneric_rspde_stat_frac_model(inla_cgeneric_cmd_tp cmd, double *th // fact_mult = multQ/k_rat; // dscal_(&less_size, &fact_mult, &ret[k+rspde_order * full_size], &one); for(i = 0; i < less_size; i++){ + if(fem_less->doubles[i] != 0){ ret[k+rspde_order*full_size + i] = multQ * ( 1/(k_rat * fem_less->doubles[i]) ); + } } break; } diff --git a/src/cgeneric_rspde_stat_general.c b/src/cgeneric_rspde_stat_general.c index 64414831..b7b826fb 100644 --- a/src/cgeneric_rspde_stat_general.c +++ b/src/cgeneric_rspde_stat_general.c @@ -216,9 +216,11 @@ double *inla_cgeneric_rspde_stat_general_model(inla_cgeneric_cmd_tp cmd, double // fact_mult = multQ/k_rat; // dscal_(&less_size, &fact_mult, &ret[k+rspde_order * full_size], &one); for(i = 0; i < less_size; i++){ + if(fem_less->doubles[i] != 0){ ret[k+rspde_order*full_size + i] = multQ * ( 1/(k_rat * fem_less->doubles[i]) ); + } } break; } diff --git a/vignettes/rspde_inlabru.Rmd b/vignettes/rspde_inlabru.Rmd index e1736bbb..663329c6 100644 --- a/vignettes/rspde_inlabru.Rmd +++ b/vignettes/rspde_inlabru.Rmd @@ -318,7 +318,7 @@ We can obtain outputs with respect to parameters in the original scale by using the function `rspde.result()`: ```{r get_result} -result_fit <- rspde.result(rspde_fit, "field", rspde_model) +result_fit <- rspde.result(rspde_fit, "field", rspde_model, parameterization = "matern") summary(result_fit) ``` @@ -600,6 +600,29 @@ result_df <- data.frame( print(result_df) ``` +We can also obtain the summary on a different parameterization by setting the `parameterization` argument on the `rspde.result()` function: + +```{r} +result_fit_rep_matern <- rspde.result(rspde_fit.rep, "field", rspde_model.rep, + parameterization = "matern") +summary(result_fit_rep_matern) +result_df_matern <- data.frame( + parameter = c("std_dev", "range", "nu"), + true = c(sigma, range, nu), + mean = c( + result_fit_rep_matern$summary.std.dev$mean, + result_fit_rep_matern$summary.range$mean, + result_fit_rep_matern$summary.nu$mean + ), + mode = c( + result_fit_rep$summary.std.dev$mode, + result_fit_rep$summary.range$mode, + result_fit_rep$summary.nu$mode + ) +) +print(result_df_matern) +``` + ## An example with a non-stationary model Our goal now is to show how one can fit model with non-stationary $\sigma$ (std. deviation) and non-stationary $\rho$ (a range parameter). From 7e3fcc372c85c2a8e3ce3551c155bed7443ee43a Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 17:03:53 +0300 Subject: [PATCH 12/47] bugfix which_repl --- NEWS.md | 1 + R/fractional.computations.R | 6 +++--- R/rspde_lme.R | 9 ++++++++- man/rspde.matern.Rd | 4 ++-- man/rspde.result.Rd | 16 +++++++++++++++- vignettes/rspde_cov.Rmd | 2 +- 6 files changed, 30 insertions(+), 8 deletions(-) diff --git a/NEWS.md b/NEWS.md index 68784e50..8c18feef 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,7 @@ * Small improvement on speed for rspde_lme. * Bugfix on Q for small values of nu in dimension 1. * Adding parameterization option for rspde.result. +* Bugfix on which_repl in rspde_lme. # rSPDE 2.3.1 * Adding references in DESCRIPTION. diff --git a/R/fractional.computations.R b/R/fractional.computations.R index 18fa0b2f..0c79d456 100644 --- a/R/fractional.computations.R +++ b/R/fractional.computations.R @@ -2344,11 +2344,11 @@ aux_lme_CBrSPDE.matern.loglike <- function(object, y, X_cov, repl, A_list, sigma repl_val <- unique(repl) l <- 0 - + for(i in repl_val){ ind_tmp <- (repl %in% i) y_tmp <- y[ind_tmp] - + if(ncol(X_cov) == 0){ X_cov_tmp <- 0 } else { @@ -2358,6 +2358,7 @@ aux_lme_CBrSPDE.matern.loglike <- function(object, y, X_cov, repl, A_list, sigma na_obs <- is.na(y_tmp) y_ <- y_tmp[!na_obs] + # y_ <- y_list[[as.character(i)]] n.o <- length(y_) A_tmp <- A_list[[as.character(i)]] @@ -2374,7 +2375,6 @@ aux_lme_CBrSPDE.matern.loglike <- function(object, y, X_cov, repl, A_list, sigma posterior.ld <- c(determinant(R.p, logarithm = TRUE)$modulus) - # l <- l + sum(log(diag(R))) - sum(log(diag(R.p))) - n.o*log(sigma_e) l <- l + prior.ld - posterior.ld - n.o*log(sigma_e) diff --git a/R/rspde_lme.R b/R/rspde_lme.R index d04868ac..ea04a842 100644 --- a/R/rspde_lme.R +++ b/R/rspde_lme.R @@ -161,10 +161,15 @@ rspde_lme <- function(formula, loc, data, idx_repl <- (repl %in% which_repl) + y_resp <- y_resp[idx_repl] + if(ncol(X_cov)>0){ X_cov <- X_cov[idx_repl, , drop = FALSE] + } else { + X_cov <- matrix(ncol=0,nrow=0) } + repl <- repl[idx_repl] time_data_end <- Sys.time() @@ -270,13 +275,15 @@ rspde_lme <- function(formula, loc, data, # has_cov <- TRUE # } + loc_df <- loc_df[idx_repl, ,drop=FALSE] + if(!is.null(model$make_A)) { for(j in repl_val){ ind_tmp <- (repl %in% j) y_tmp <- y_resp[ind_tmp] na_obs <- is.na(y_tmp) # y_list[[as.character(j)]] <- y_tmp[!na_obs] - A_list[[as.character(j)]] <- model$make_A(loc_df[ind_tmp,]) + A_list[[as.character(j)]] <- model$make_A(loc_df[ind_tmp,,drop = FALSE]) A_list[[as.character(j)]] <- A_list[[as.character(j)]][!na_obs, , drop = FALSE] # if(has_cov){ # X_cov_list[[as.character(j)]] <- X_cov[ind_tmp, , drop = FALSE] diff --git a/man/rspde.matern.Rd b/man/rspde.matern.Rd index 475cee80..f63b9a71 100644 --- a/man/rspde.matern.Rd +++ b/man/rspde.matern.Rd @@ -11,7 +11,7 @@ rspde.matern( nu = NULL, B.sigma = matrix(c(0, 1, 0), 1, 3), B.range = matrix(c(0, 0, 1), 1, 3), - parameterization = c("matern", "spde", "matern2"), + parameterization = c("spde", "matern", "matern2"), B.tau = matrix(c(0, 1, 0), 1, 3), B.kappa = matrix(c(0, 0, 1), 1, 3), start.nu = NULL, @@ -52,7 +52,7 @@ be estimated. If nu is \code{NULL}, it will be estimated.} \item{B.range}{Matrix with specification of log-linear model for \eqn{\rho}, which is a range-like parameter (it is exactly the range parameter in the stationary case). Will be used if \code{parameterization = 'matern'} or \code{parameterization = 'matern2'}.} -\item{parameterization}{Which parameterization to use? \code{matern} uses range, std. deviation and nu (smoothness). \code{spde} uses kappa, tau and nu (smoothness). \code{matern2} uses range-like (1/kappa), variance and nu (smoothness). The default is \code{matern}.} +\item{parameterization}{Which parameterization to use? \code{matern} uses range, std. deviation and nu (smoothness). \code{spde} uses kappa, tau and nu (smoothness). \code{matern2} uses range-like (1/kappa), variance and nu (smoothness). The default is \code{spde}.} \item{B.tau}{Matrix with specification of log-linear model for \eqn{\tau}. Will be used if \code{parameterization = 'spde'}.} diff --git a/man/rspde.result.Rd b/man/rspde.result.Rd index bf081a8b..48a245de 100644 --- a/man/rspde.result.Rd +++ b/man/rspde.result.Rd @@ -4,7 +4,15 @@ \alias{rspde.result} \title{rSPDE result extraction from INLA estimation results} \usage{ -rspde.result(inla, name, rspde, compute.summary = TRUE) +rspde.result( + inla, + name, + rspde, + compute.summary = TRUE, + parameterization = "detect", + n_samples = 5000, + n_density = 1024 +) } \arguments{ \item{inla}{An \code{inla} object obtained from a call to @@ -17,6 +25,12 @@ in the inla formula.} the inla formula.} \item{compute.summary}{Should the summary be computed?} + +\item{parameterization}{If 'detect', the parameterization from the model will be used. Otherwise, the options are 'spde', 'matern' and 'matern2'.} + +\item{n_samples}{The number of samples to be used if parameterization is different from the one used to fit the model.} + +\item{n_density}{The number of equally spaced points to estimate the density.} } \value{ If the model was fitted with \code{matern} parameterization (the default), it returns a list containing: diff --git a/vignettes/rspde_cov.Rmd b/vignettes/rspde_cov.Rmd index 809d7cbd..8454a34e 100644 --- a/vignettes/rspde_cov.Rmd +++ b/vignettes/rspde_cov.Rmd @@ -424,7 +424,7 @@ obs.loc <- runif(n.obs) A <- rSPDE.A1d(s, obs.loc) ``` -We now generate the observations as $Y_i = 2 + x1 - x2 + u(s_i) + \varepsilon_i$, where $\varepsilon_i \sim N(0,\sigma_e^2)$ is Gaussian measurement noise, $x1$ and $x2$ are covariates generated by uniform and exponential distributions, respectively. We will assume that the latent process has a Matérn covariance +We now generate the observations as $Y_i = 2 + x1 + u(s_i) + \varepsilon_i$, where $\varepsilon_i \sim N(0,\sigma_e^2)$ is Gaussian measurement noise, $x1$ is a covariate giving the observation location. We will assume that the latent process has a Matérn covariance with $\kappa=20, \sigma=2$ and $\nu=0.8$: ```{r} kappa <- 20 From 7a73381653940f4d31eba2f1f9386a5d365888fc Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 17:17:02 +0300 Subject: [PATCH 13/47] adjust --- R/fractional.computations.R | 41 ++++++++++++++++++++----------------- 1 file changed, 22 insertions(+), 19 deletions(-) diff --git a/R/fractional.computations.R b/R/fractional.computations.R index 0c79d456..5d7bbd14 100644 --- a/R/fractional.computations.R +++ b/R/fractional.computations.R @@ -1457,28 +1457,31 @@ aux_CBrSPDE.matern.loglike <- function(object, Y, A, sigma.e, mu = 0, Q <- object$Q - # Q.R <- Matrix::Cholesky(Q) - - # logQ <- 2 * c(determinant(Q.R, logarithm = TRUE)$modulus) - - Q.frac <- object$Q.frac - - Q.fracR <- Matrix::Cholesky(Q.frac) - - logdetL <- object$logdetL - logdetC <- object$logdetC - Q.int.order <- object$Q.int$order - - if (Q.int.order > 0) { - # logQ <- 2 * sum(log(diag(Q.fracR))) + (Q.int.order) * - # (m + 1) * (logdetL - logdetC) - - logQ <- 2 * c(determinant(Q.fracR, logarithm = TRUE)$modulus) + (Q.int.order) * - (m + 1) * (logdetL - logdetC) + if(object$stationary){ + Q.frac <- object$Q.frac + + Q.fracR <- Matrix::Cholesky(Q.frac) + + logdetL <- object$logdetL + logdetC <- object$logdetC + Q.int.order <- object$Q.int$order + + if (Q.int.order > 0) { + # logQ <- 2 * sum(log(diag(Q.fracR))) + (Q.int.order) * + # (m + 1) * (logdetL - logdetC) + + logQ <- 2 * c(determinant(Q.fracR, logarithm = TRUE)$modulus) + (Q.int.order) * + (m + 1) * (logdetL - logdetC) + } else { + logQ <- 2 * c(determinant(Q.fracR, logarithm = TRUE)$modulus) + } } else { - logQ <- 2 * c(determinant(Q.fracR, logarithm = TRUE)$modulus) + Q.R <- Matrix::Cholesky(Q) + + logQ <- 2 * c(determinant(Q.R, logarithm = TRUE)$modulus) } + ## compute Q_x|y if(object$alpha %% 1 == 0){ Abar <- A From abbd7a0eae9e8772b6ec45773ae05eeda928715b Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 17:41:13 +0300 Subject: [PATCH 14/47] bugfix for small values of nu --- R/inla_rspde.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/inla_rspde.R b/R/inla_rspde.R index 7e3dd9a0..d271fee8 100644 --- a/R/inla_rspde.R +++ b/R/inla_rspde.R @@ -2333,6 +2333,8 @@ dim, fem_matrices, graph = NULL, sharp, type_rational_approx) { if (sharp) { if (m_alpha == 0) { Kpart <- fem_matrices[["C_less"]] + idx_nonzero <- (Kpart != 0) + Kpart[idx_nonzero] <- 1/Kpart[idx_nonzero] Kpart <- Kpart / k } else { if (m_alpha == 1) { @@ -2352,6 +2354,8 @@ dim, fem_matrices, graph = NULL, sharp, type_rational_approx) { } else { if (m_alpha == 0) { Kpart <- fem_matrices[["C"]] + idx_nonzero <- (Kpart != 0) + Kpart[idx_nonzero] <- 1/Kpart[idx_nonzero] Kpart <- Kpart / k } else { if (m_alpha == 1) { From 9f37b28627cc1f54e17426f8dcc049c8eaea6776 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 19:15:08 +0300 Subject: [PATCH 15/47] Adjust inlabru vignette --- vignettes/rspde_inlabru.Rmd | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/vignettes/rspde_inlabru.Rmd b/vignettes/rspde_inlabru.Rmd index 663329c6..f02235e6 100644 --- a/vignettes/rspde_inlabru.Rmd +++ b/vignettes/rspde_inlabru.Rmd @@ -724,7 +724,8 @@ so that we do not start the estimation at the true values. ```{r} rspde_model_nonstat <- rspde.matern(mesh = mesh, B.sigma = B.sigma, - B.range = B.range) + B.range = B.range, + parameterization = "matern") ``` Let us now create the `data.frame()` and the vector with the replicates indexes: From ab702022ba7a98b8fb30d21e98886b4335b27b36 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 20:59:21 +0300 Subject: [PATCH 16/47] new devel setup --- .github/workflows/devel_setup.yml | 106 ++++++-------------------- .github/workflows/devel_src_setup.yml | 29 +++++++ DESCRIPTION | 2 +- 3 files changed, 53 insertions(+), 84 deletions(-) create mode 100644 .github/workflows/devel_src_setup.yml diff --git a/.github/workflows/devel_setup.yml b/.github/workflows/devel_setup.yml index fe68e34b..c13e4025 100644 --- a/.github/workflows/devel_setup.yml +++ b/.github/workflows/devel_setup.yml @@ -2,88 +2,28 @@ on: push: branches: - devel - -name: devel_setup +name: devel_setup + jobs: - devel_setup: - runs-on: macOS-latest - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - steps: - - uses: actions/checkout@v2 - - - uses: r-lib/actions/setup-r@v2 - with: - r-version: "release" - extra-repositories: "https://inla.r-inla-download.org/R/testing" - - - uses: r-lib/actions/setup-pandoc@v2 - - - name: Query dependencies - run: | - install.packages('remotes') - saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) - writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") - shell: Rscript {0} - - - name: Install system dependencies - run: | - brew install --cask xquartz - brew install pkg-config - brew install proj@9 - brew install gdal - brew install eigen - - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - dependencies: '"all"' - extra-packages: | - pkgdown - rmarkdown - devtools - - name: Session info - run: | - options(width = 100) - pkgs <- installed.packages()[, "Package"] - sessioninfo::session_info(pkgs, include_base = TRUE) - shell: Rscript {0} - - - name: Install package - run: R CMD INSTALL . - - - name: Finish the setup - run: | - git config --local user.email "actions@github.com" - git config --local user.name "GitHub Actions" - sed -i .bak '/vignettes/d' .Rbuildignore - sed -i .bak '/#'\'' tryCatch({/d' R/inla_rspde.R - sed -i .bak '/Could not run the example/d' R/inla_rspde.R - sed -i .bak 's/donttest{ #tryCatch version/donttest{ #devel version/' R/inla_rspde.R - sed -i .bak 's/#stable\.tag/#devel\.tag/' R/inla_rspde.R - sed -i .bak 's/#stable\.tryCatch/#devel\.tag/' R/inla_rspde.R - sed -i .bak '/#'\'' tryCatch({/d' R/inlabru_rspde.R - sed -i .bak '/Could not run the example/d' R/inlabru_rspde.R - sed -i .bak 's/donttest{ #tryCatch version/donttest{ #devel version/' R/inlabru_rspde.R - sed -i .bak 's/#stable\.tag/#devel\.tag/' R/inlabru_rspde.R - sed -i .bak 's/#stable\.tryCatch/#devel\.tag/' R/inlabru_rspde.R - sed -i .bak 's/R.rsp/knitr/' DESCRIPTION - html_files=$(shopt -s nullglob dotglob; echo vignettes/*.html) - asis_files=$(shopt -s nullglob dotglob; echo vignettes/*.asis) - if (( ${#html_files} )) - then - git rm vignettes/*.html - fi - if (( ${#asis_files} )) - then - git rm vignettes/*.asis - fi - Rscript -e "devtools::document()" - git add man - git add R/inla_rspde.R - git add R/inlabru_rspde.R - git add .Rbuildignore - git add DESCRIPTION - git commit -m "Doing the setup" - git push - shell: bash + cran_setup: + runs-on: ubuntu-20.04 + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + steps: + - uses: actions/checkout@v2 + + - name: Merge with devel-src and accept all incoming changes + run: | + git config --local user.email "actions@github.com" + git config --local user.name "GitHub Actions" + git checkout devel-src + git merge devel --no-edit --no-commit --no-ff + git checkout --theirs . + git add . + git reset -- src/ + sed -i 's/NeedsCompilation: no/NeedsCompilation: yes/' DESCRIPTION + git add DESCRIPTION + git commit -m "Doing the setup" + git push origin devel-src + shell: bash diff --git a/.github/workflows/devel_src_setup.yml b/.github/workflows/devel_src_setup.yml new file mode 100644 index 00000000..16c80d18 --- /dev/null +++ b/.github/workflows/devel_src_setup.yml @@ -0,0 +1,29 @@ +on: + push: + branches: + - devel + +name: devel_setup + +jobs: + cran_setup: + runs-on: ubuntu-20.04 + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + steps: + - uses: actions/checkout@v2 + + - name: Merge with devel-src and accept all incoming changes + run: | + git config --local user.email "actions@github.com" + git config --local user.name "GitHub Actions" + git checkout devel + git merge devel-src --no-edit --no-commit --no-ff + git checkout --theirs . + sed -i 's/NeedsCompilation: yes/NeedsCompilation: no/' DESCRIPTION + git add . + git rm -rf src + rm -rf src + git commit -m "Doing the setup" + git push origin devel + shell: bash diff --git a/DESCRIPTION b/DESCRIPTION index a61262d4..20ec33b2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -21,7 +21,7 @@ Suggests: knitr, rmarkdown, INLA (>= 22.12.14), testthat, rgdal, Additional_repositories: https://inla.r-inla-download.org/R/testing BugReports: https://github.com/davidbolin/rSPDE/issues VignetteBuilder: knitr -NeedsCompilation: yes +NeedsCompilation: no Author: David Bolin [cre, aut], Alexandre Simas [aut], Finn Lindgren [ctb] From dd7dcb82a1804e589f5cc248e5a9938c533d2df1 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 21:02:39 +0300 Subject: [PATCH 17/47] new stable setup --- .github/workflows/devel_src_setup.yml | 6 +- .github/workflows/stable_setup.yml | 138 +++++-------------------- .github/workflows/stable_src_setup.yml | 29 ++++++ 3 files changed, 56 insertions(+), 117 deletions(-) create mode 100644 .github/workflows/stable_src_setup.yml diff --git a/.github/workflows/devel_src_setup.yml b/.github/workflows/devel_src_setup.yml index 16c80d18..ab9c1fe3 100644 --- a/.github/workflows/devel_src_setup.yml +++ b/.github/workflows/devel_src_setup.yml @@ -1,9 +1,9 @@ on: push: branches: - - devel + - devel-src -name: devel_setup +name: devel_src_setup jobs: cran_setup: @@ -13,7 +13,7 @@ jobs: steps: - uses: actions/checkout@v2 - - name: Merge with devel-src and accept all incoming changes + - name: Merge with devel, remove src and accept all incoming changes run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" diff --git a/.github/workflows/stable_setup.yml b/.github/workflows/stable_setup.yml index 53eae578..45e7d380 100644 --- a/.github/workflows/stable_setup.yml +++ b/.github/workflows/stable_setup.yml @@ -1,119 +1,29 @@ on: push: branches: - - cran - -name: cran_setup + - stable +name: stable_setup + jobs: - stable_setup: - runs-on: macOS-latest - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - steps: - - uses: actions/checkout@v2 - - - uses: r-lib/actions/setup-r@v2 - with: - r-version: "release" - extra-repositories: "https://inla.r-inla-download.org/R/testing" - - - uses: r-lib/actions/setup-pandoc@v2 - - - name: Query dependencies - run: | - install.packages('remotes') - saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) - writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") - shell: Rscript {0} - - - name: Install system dependencies - run: | - brew install --cask xquartz - brew install pkg-config - brew install proj@9 - brew install gdal - brew install eigen - - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - dependencies: '"all"' - extra-packages: | - pkgdown - rmarkdown - devtools - - name: Session info - run: | - options(width = 100) - pkgs <- installed.packages()[, "Package"] - sessioninfo::session_info(pkgs, include_base = TRUE) - shell: Rscript {0} - - - name: Install package - run: R CMD INSTALL . - - - name: Generate html files - run: | - Rscript -e "rmarkdown::render('vignettes/rSPDE.Rmd')" - Rscript -e "rmarkdown::render('vignettes/rspde_cov.Rmd')" - Rscript -e "rmarkdown::render('vignettes/rspde_inla.Rmd')" - Rscript -e "rmarkdown::render('vignettes/rspde_base.Rmd')" - Rscript -e "rmarkdown::render('vignettes/rspde_inlabru.Rmd')" - - - name: Finish the setup - run: | - git config --local user.email "actions@github.com" - git config --local user.name "GitHub Actions" - sed -i .bak 's/knitr/R.rsp/' DESCRIPTION - touch vignettes/rSPDE.html.asis - echo "%\VignetteIndexEntry{An introduction to the rSPDE package}" >> vignettes/rSPDE.html.asis - echo "%\VignetteEngine{R.rsp::asis}" >> vignettes/rSPDE.html.asis - echo "%\VignetteEncoding{UTF-8}" >> vignettes/rSPDE.html.asis - touch vignettes/rspde_inla.html.asis - echo "%\VignetteIndexEntry{R-INLA implementation of the rational SPDE approach}" >> vignettes/rspde_inla.html.asis - echo "%\VignetteEngine{R.rsp::asis}" >> vignettes/rspde_inla.html.asis - echo "%\VignetteEncoding{UTF-8}" >> vignettes/rspde_inla.html.asis - touch vignettes/rspde_inlabru.html.asis - echo "%\VignetteIndexEntry{inlabru implementation of the rational SPDE approach}" >> vignettes/rspde_inlabru.html.asis - echo "%\VignetteEngine{R.rsp::asis}" >> vignettes/rspde_inlabru.html.asis - echo "%\VignetteEncoding{UTF-8}" >> vignettes/rspde_inlabru.html.asis - touch vignettes/rspde_cov.html.asis - echo "%\VignetteIndexEntry{Rational approximation with the rSPDE package}" >> vignettes/rspde_cov.html.asis - echo "%\VignetteEngine{R.rsp::asis}" >> vignettes/rspde_cov.html.asis - echo "%\VignetteEncoding{UTF-8}" >> vignettes/rspde_cov.html.asis - touch vignettes/rspde_base.html.asis - echo "%\VignetteIndexEntry{Operator-based rational approximation}" >> vignettes/rspde_base.html.asis - echo "%\VignetteEngine{R.rsp::asis}" >> vignettes/rspde_base.html.asis - echo "%\VignetteEncoding{UTF-8}" >> vignettes/rspde_base.html.asis - echo "^vignettes/.*\.Rmd$" >> .Rbuildignore - sed -i .bak 's/#devel\.tag/#stable\.tag/' R/inla_rspde.R - sed -i .bak '/donttest{ #devel version$/a\ - #'\'' tryCatch({ - ' R/inla_rspde.R - sed -i .bak 's/donttest{ #devel version/donttest{ #tryCatch version/' R/inla_rspde.R - sed -i .bak '/#stable\.tag$/a\ - #'\'' }, error = function(e){print("Could not run the example")}) - ' R/inla_rspde.R - sed -i .bak 's/#stable\.tag/#stable\.tryCatch/' R/inla_rspde.R - sed -i .bak 's/#devel\.tag/#stable\.tag/' R/inlabru_rspde.R - sed -i .bak '/donttest{ #devel version$/a\ - #'\'' tryCatch({ - ' R/inlabru_rspde.R - sed -i .bak 's/donttest{ #devel version/donttest{ #tryCatch version/' R/inlabru_rspde.R - sed -i .bak '/#stable\.tag$/a\ - #'\'' }, error = function(e){print("Could not run the example")}) - ' R/inlabru_rspde.R - sed -i .bak 's/#stable\.tag/#stable\.tryCatch/' R/inlabru_rspde.R - Rscript -e "devtools::document()" - rm -rf src/ - rm -rf inst/shared/ - git add man - git add .Rbuildignore - git add vignettes - git add DESCRIPTION - git add R/inla_rspde.R - git add R/inlabru_rspde.R - git rm tests/testthat/test.inla_rspde.R - git commit -m "Doing the setup" - git push - shell: bash + cran_setup: + runs-on: ubuntu-20.04 + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + steps: + - uses: actions/checkout@v2 + + - name: Merge with stable-src and accept all incoming changes + run: | + git config --local user.email "actions@github.com" + git config --local user.name "GitHub Actions" + git checkout stable-src + git merge stable --no-edit --no-commit --no-ff + git checkout --theirs . + git add . + git reset -- src/ + sed -i 's/NeedsCompilation: no/NeedsCompilation: yes/' DESCRIPTION + git add DESCRIPTION + git commit -m "Doing the setup" + git push origin stable-src + shell: bash diff --git a/.github/workflows/stable_src_setup.yml b/.github/workflows/stable_src_setup.yml new file mode 100644 index 00000000..53146e1c --- /dev/null +++ b/.github/workflows/stable_src_setup.yml @@ -0,0 +1,29 @@ +on: + push: + branches: + - stable-src + +name: stable_src_setup + +jobs: + cran_setup: + runs-on: ubuntu-20.04 + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + steps: + - uses: actions/checkout@v2 + + - name: Merge with stable and accept all incoming changes + run: | + git config --local user.email "actions@github.com" + git config --local user.name "GitHub Actions" + git checkout stable + git merge stable-src --no-edit --no-commit --no-ff + git checkout --theirs . + sed -i 's/NeedsCompilation: yes/NeedsCompilation: no/' DESCRIPTION + git add . + git rm -rf src + rm -rf src + git commit -m "Doing the setup" + git push origin stable + shell: bash From d8a985c561f963e2a71393eb57456b6a0f0b6e14 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 21:07:49 +0300 Subject: [PATCH 18/47] Adjust setups --- .github/workflows/devel_setup.yml | 2 ++ .github/workflows/devel_src_setup.yml | 6 ++++-- .github/workflows/stable_setup.yml | 2 ++ .github/workflows/stable_src_setup.yml | 2 ++ 4 files changed, 10 insertions(+), 2 deletions(-) diff --git a/.github/workflows/devel_setup.yml b/.github/workflows/devel_setup.yml index c13e4025..7f56a3ff 100644 --- a/.github/workflows/devel_setup.yml +++ b/.github/workflows/devel_setup.yml @@ -17,7 +17,9 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" + git branch devel-src git checkout devel-src + git pull origin devel-src git merge devel --no-edit --no-commit --no-ff git checkout --theirs . git add . diff --git a/.github/workflows/devel_src_setup.yml b/.github/workflows/devel_src_setup.yml index ab9c1fe3..b84f24e6 100644 --- a/.github/workflows/devel_src_setup.yml +++ b/.github/workflows/devel_src_setup.yml @@ -6,7 +6,7 @@ on: name: devel_src_setup jobs: - cran_setup: + devel_src_setup: runs-on: ubuntu-20.04 env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} @@ -16,8 +16,10 @@ jobs: - name: Merge with devel, remove src and accept all incoming changes run: | git config --local user.email "actions@github.com" - git config --local user.name "GitHub Actions" + git config --local user.name "GitHub Actions" + git branch devel git checkout devel + git pull origin devel git merge devel-src --no-edit --no-commit --no-ff git checkout --theirs . sed -i 's/NeedsCompilation: yes/NeedsCompilation: no/' DESCRIPTION diff --git a/.github/workflows/stable_setup.yml b/.github/workflows/stable_setup.yml index 45e7d380..4af84b4a 100644 --- a/.github/workflows/stable_setup.yml +++ b/.github/workflows/stable_setup.yml @@ -17,7 +17,9 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" + git branch stable-src git checkout stable-src + git pull origin stable-src git merge stable --no-edit --no-commit --no-ff git checkout --theirs . git add . diff --git a/.github/workflows/stable_src_setup.yml b/.github/workflows/stable_src_setup.yml index 53146e1c..f68e585d 100644 --- a/.github/workflows/stable_src_setup.yml +++ b/.github/workflows/stable_src_setup.yml @@ -17,7 +17,9 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" + git branch stable git checkout stable + git pull origin stable git merge stable-src --no-edit --no-commit --no-ff git checkout --theirs . sed -i 's/NeedsCompilation: yes/NeedsCompilation: no/' DESCRIPTION From df69e97ca51392c1dda8a9676b73456d74557f94 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 21:10:26 +0300 Subject: [PATCH 19/47] Adjusts setup --- .github/workflows/devel_setup.yml | 5 +++-- .github/workflows/devel_src_setup.yml | 1 + .github/workflows/stable_setup.yml | 5 +++-- .github/workflows/stable_src_setup.yml | 3 ++- 4 files changed, 9 insertions(+), 5 deletions(-) diff --git a/.github/workflows/devel_setup.yml b/.github/workflows/devel_setup.yml index 7f56a3ff..acaac188 100644 --- a/.github/workflows/devel_setup.yml +++ b/.github/workflows/devel_setup.yml @@ -6,7 +6,7 @@ on: name: devel_setup jobs: - cran_setup: + devel_setup: runs-on: ubuntu-20.04 env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} @@ -16,7 +16,8 @@ jobs: - name: Merge with devel-src and accept all incoming changes run: | git config --local user.email "actions@github.com" - git config --local user.name "GitHub Actions" + git config --local user.name "GitHub Actions" + git config pull.rebase false git branch devel-src git checkout devel-src git pull origin devel-src diff --git a/.github/workflows/devel_src_setup.yml b/.github/workflows/devel_src_setup.yml index b84f24e6..930da3af 100644 --- a/.github/workflows/devel_src_setup.yml +++ b/.github/workflows/devel_src_setup.yml @@ -17,6 +17,7 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" + git config pull.rebase false git branch devel git checkout devel git pull origin devel diff --git a/.github/workflows/stable_setup.yml b/.github/workflows/stable_setup.yml index 4af84b4a..fa2fc288 100644 --- a/.github/workflows/stable_setup.yml +++ b/.github/workflows/stable_setup.yml @@ -6,7 +6,7 @@ on: name: stable_setup jobs: - cran_setup: + stable_setup: runs-on: ubuntu-20.04 env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} @@ -16,7 +16,8 @@ jobs: - name: Merge with stable-src and accept all incoming changes run: | git config --local user.email "actions@github.com" - git config --local user.name "GitHub Actions" + git config --local user.name "GitHub Actions" + git config pull.rebase false git branch stable-src git checkout stable-src git pull origin stable-src diff --git a/.github/workflows/stable_src_setup.yml b/.github/workflows/stable_src_setup.yml index f68e585d..8a6019c2 100644 --- a/.github/workflows/stable_src_setup.yml +++ b/.github/workflows/stable_src_setup.yml @@ -6,7 +6,7 @@ on: name: stable_src_setup jobs: - cran_setup: + stable_src_setup: runs-on: ubuntu-20.04 env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} @@ -17,6 +17,7 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" + git config pull.rebase false git branch stable git checkout stable git pull origin stable From 21f5aacc1dc41667a97bd726bd79a40bab167edc Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 21:11:56 +0300 Subject: [PATCH 20/47] Adjusts setup --- .github/workflows/devel_setup.yml | 2 +- .github/workflows/devel_src_setup.yml | 2 +- .github/workflows/stable_setup.yml | 2 +- .github/workflows/stable_src_setup.yml | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/.github/workflows/devel_setup.yml b/.github/workflows/devel_setup.yml index acaac188..ce8a8b72 100644 --- a/.github/workflows/devel_setup.yml +++ b/.github/workflows/devel_setup.yml @@ -17,7 +17,7 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" - git config pull.rebase false + git config pull.rebase true git branch devel-src git checkout devel-src git pull origin devel-src diff --git a/.github/workflows/devel_src_setup.yml b/.github/workflows/devel_src_setup.yml index 930da3af..465ea96b 100644 --- a/.github/workflows/devel_src_setup.yml +++ b/.github/workflows/devel_src_setup.yml @@ -17,7 +17,7 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" - git config pull.rebase false + git config pull.rebase true git branch devel git checkout devel git pull origin devel diff --git a/.github/workflows/stable_setup.yml b/.github/workflows/stable_setup.yml index fa2fc288..b7e1b582 100644 --- a/.github/workflows/stable_setup.yml +++ b/.github/workflows/stable_setup.yml @@ -17,7 +17,7 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" - git config pull.rebase false + git config pull.rebase true git branch stable-src git checkout stable-src git pull origin stable-src diff --git a/.github/workflows/stable_src_setup.yml b/.github/workflows/stable_src_setup.yml index 8a6019c2..4157adb5 100644 --- a/.github/workflows/stable_src_setup.yml +++ b/.github/workflows/stable_src_setup.yml @@ -17,7 +17,7 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" - git config pull.rebase false + git config pull.rebase true git branch stable git checkout stable git pull origin stable From 797fcd6c7af264ac25a1eda786079d34a836bcaa Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 21:15:46 +0300 Subject: [PATCH 21/47] Adjust setups --- .github/workflows/devel_setup.yml | 4 ++-- .github/workflows/devel_src_setup.yml | 4 ++-- .github/workflows/stable_setup.yml | 4 ++-- .github/workflows/stable_src_setup.yml | 4 ++-- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/.github/workflows/devel_setup.yml b/.github/workflows/devel_setup.yml index ce8a8b72..d0265c9a 100644 --- a/.github/workflows/devel_setup.yml +++ b/.github/workflows/devel_setup.yml @@ -17,11 +17,11 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" - git config pull.rebase true + git config pull.rebase false git branch devel-src git checkout devel-src git pull origin devel-src - git merge devel --no-edit --no-commit --no-ff + git merge -X theirs devel --no-edit --no-commit --no-ff git checkout --theirs . git add . git reset -- src/ diff --git a/.github/workflows/devel_src_setup.yml b/.github/workflows/devel_src_setup.yml index 465ea96b..f65f0358 100644 --- a/.github/workflows/devel_src_setup.yml +++ b/.github/workflows/devel_src_setup.yml @@ -17,11 +17,11 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" - git config pull.rebase true + git config pull.rebase false git branch devel git checkout devel git pull origin devel - git merge devel-src --no-edit --no-commit --no-ff + git merge -X theirs devel-src --no-edit --no-commit --no-ff git checkout --theirs . sed -i 's/NeedsCompilation: yes/NeedsCompilation: no/' DESCRIPTION git add . diff --git a/.github/workflows/stable_setup.yml b/.github/workflows/stable_setup.yml index b7e1b582..46e6060b 100644 --- a/.github/workflows/stable_setup.yml +++ b/.github/workflows/stable_setup.yml @@ -17,11 +17,11 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" - git config pull.rebase true + git config pull.rebase false git branch stable-src git checkout stable-src git pull origin stable-src - git merge stable --no-edit --no-commit --no-ff + git merge -X theirs stable --no-edit --no-commit --no-ff git checkout --theirs . git add . git reset -- src/ diff --git a/.github/workflows/stable_src_setup.yml b/.github/workflows/stable_src_setup.yml index 4157adb5..146bdced 100644 --- a/.github/workflows/stable_src_setup.yml +++ b/.github/workflows/stable_src_setup.yml @@ -17,11 +17,11 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" - git config pull.rebase true + git config pull.rebase false git branch stable git checkout stable git pull origin stable - git merge stable-src --no-edit --no-commit --no-ff + git merge -X theirs stable-src --no-edit --no-commit --no-ff git checkout --theirs . sed -i 's/NeedsCompilation: yes/NeedsCompilation: no/' DESCRIPTION git add . From 754e5e29dc814a5096ea23f3329d09c714978e07 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 21:16:42 +0300 Subject: [PATCH 22/47] Adjust setups --- .github/workflows/devel_setup.yml | 2 +- .github/workflows/devel_src_setup.yml | 2 +- .github/workflows/stable_setup.yml | 2 +- .github/workflows/stable_src_setup.yml | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/.github/workflows/devel_setup.yml b/.github/workflows/devel_setup.yml index d0265c9a..a9cbf783 100644 --- a/.github/workflows/devel_setup.yml +++ b/.github/workflows/devel_setup.yml @@ -17,7 +17,7 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" - git config pull.rebase false + git config pull.rebase true git branch devel-src git checkout devel-src git pull origin devel-src diff --git a/.github/workflows/devel_src_setup.yml b/.github/workflows/devel_src_setup.yml index f65f0358..4bded4ce 100644 --- a/.github/workflows/devel_src_setup.yml +++ b/.github/workflows/devel_src_setup.yml @@ -17,7 +17,7 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" - git config pull.rebase false + git config pull.rebase true git branch devel git checkout devel git pull origin devel diff --git a/.github/workflows/stable_setup.yml b/.github/workflows/stable_setup.yml index 46e6060b..21be8c4a 100644 --- a/.github/workflows/stable_setup.yml +++ b/.github/workflows/stable_setup.yml @@ -17,7 +17,7 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" - git config pull.rebase false + git config pull.rebase true git branch stable-src git checkout stable-src git pull origin stable-src diff --git a/.github/workflows/stable_src_setup.yml b/.github/workflows/stable_src_setup.yml index 146bdced..8b13ee27 100644 --- a/.github/workflows/stable_src_setup.yml +++ b/.github/workflows/stable_src_setup.yml @@ -17,7 +17,7 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" - git config pull.rebase false + git config pull.rebase true git branch stable git checkout stable git pull origin stable From 59d6091ad906e134dc49c1dc3ae2e4f09453eef2 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 21:19:11 +0300 Subject: [PATCH 23/47] Adjust setups --- .github/workflows/devel_setup.yml | 6 ++---- .github/workflows/devel_src_setup.yml | 4 +--- .github/workflows/stable_setup.yml | 6 ++---- .github/workflows/stable_src_setup.yml | 6 ++---- 4 files changed, 7 insertions(+), 15 deletions(-) diff --git a/.github/workflows/devel_setup.yml b/.github/workflows/devel_setup.yml index a9cbf783..02f3f4a8 100644 --- a/.github/workflows/devel_setup.yml +++ b/.github/workflows/devel_setup.yml @@ -16,12 +16,10 @@ jobs: - name: Merge with devel-src and accept all incoming changes run: | git config --local user.email "actions@github.com" - git config --local user.name "GitHub Actions" - git config pull.rebase true + git config --local user.name "GitHub Actions" git branch devel-src git checkout devel-src - git pull origin devel-src - git merge -X theirs devel --no-edit --no-commit --no-ff + git merge devel --no-edit --no-commit --no-ff git checkout --theirs . git add . git reset -- src/ diff --git a/.github/workflows/devel_src_setup.yml b/.github/workflows/devel_src_setup.yml index 4bded4ce..ee2052c2 100644 --- a/.github/workflows/devel_src_setup.yml +++ b/.github/workflows/devel_src_setup.yml @@ -17,11 +17,9 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" - git config pull.rebase true git branch devel git checkout devel - git pull origin devel - git merge -X theirs devel-src --no-edit --no-commit --no-ff + git merge devel-src --no-edit --no-commit --no-ff git checkout --theirs . sed -i 's/NeedsCompilation: yes/NeedsCompilation: no/' DESCRIPTION git add . diff --git a/.github/workflows/stable_setup.yml b/.github/workflows/stable_setup.yml index 21be8c4a..e235cc19 100644 --- a/.github/workflows/stable_setup.yml +++ b/.github/workflows/stable_setup.yml @@ -16,12 +16,10 @@ jobs: - name: Merge with stable-src and accept all incoming changes run: | git config --local user.email "actions@github.com" - git config --local user.name "GitHub Actions" - git config pull.rebase true + git config --local user.name "GitHub Actions" git branch stable-src git checkout stable-src - git pull origin stable-src - git merge -X theirs stable --no-edit --no-commit --no-ff + git merge stable --no-edit --no-commit --no-ff git checkout --theirs . git add . git reset -- src/ diff --git a/.github/workflows/stable_src_setup.yml b/.github/workflows/stable_src_setup.yml index 8b13ee27..4d0c4b8a 100644 --- a/.github/workflows/stable_src_setup.yml +++ b/.github/workflows/stable_src_setup.yml @@ -16,12 +16,10 @@ jobs: - name: Merge with stable and accept all incoming changes run: | git config --local user.email "actions@github.com" - git config --local user.name "GitHub Actions" - git config pull.rebase true + git config --local user.name "GitHub Actions" git branch stable git checkout stable - git pull origin stable - git merge -X theirs stable-src --no-edit --no-commit --no-ff + git merge stable-src --no-edit --no-commit --no-ff git checkout --theirs . sed -i 's/NeedsCompilation: yes/NeedsCompilation: no/' DESCRIPTION git add . From 67aac52608c2916ec449d60938d64283a3d5f587 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 21:22:29 +0300 Subject: [PATCH 24/47] Adjust setups --- .github/workflows/devel_setup.yml | 2 +- .github/workflows/devel_src_setup.yml | 2 +- .github/workflows/stable_setup.yml | 2 +- .github/workflows/stable_src_setup.yml | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/.github/workflows/devel_setup.yml b/.github/workflows/devel_setup.yml index 02f3f4a8..55151c37 100644 --- a/.github/workflows/devel_setup.yml +++ b/.github/workflows/devel_setup.yml @@ -26,5 +26,5 @@ jobs: sed -i 's/NeedsCompilation: no/NeedsCompilation: yes/' DESCRIPTION git add DESCRIPTION git commit -m "Doing the setup" - git push origin devel-src + git push origin devel-src --force shell: bash diff --git a/.github/workflows/devel_src_setup.yml b/.github/workflows/devel_src_setup.yml index ee2052c2..613c974c 100644 --- a/.github/workflows/devel_src_setup.yml +++ b/.github/workflows/devel_src_setup.yml @@ -26,5 +26,5 @@ jobs: git rm -rf src rm -rf src git commit -m "Doing the setup" - git push origin devel + git push origin devel --force shell: bash diff --git a/.github/workflows/stable_setup.yml b/.github/workflows/stable_setup.yml index e235cc19..01bc968a 100644 --- a/.github/workflows/stable_setup.yml +++ b/.github/workflows/stable_setup.yml @@ -26,5 +26,5 @@ jobs: sed -i 's/NeedsCompilation: no/NeedsCompilation: yes/' DESCRIPTION git add DESCRIPTION git commit -m "Doing the setup" - git push origin stable-src + git push origin stable-src --force shell: bash diff --git a/.github/workflows/stable_src_setup.yml b/.github/workflows/stable_src_setup.yml index 4d0c4b8a..dd972cc1 100644 --- a/.github/workflows/stable_src_setup.yml +++ b/.github/workflows/stable_src_setup.yml @@ -26,5 +26,5 @@ jobs: git rm -rf src rm -rf src git commit -m "Doing the setup" - git push origin stable + git push origin stable --force shell: bash From 1e11963f5bb7f93521405124acd9d6d0b9787794 Mon Sep 17 00:00:00 2001 From: GitHub Actions Date: Mon, 29 May 2023 18:22:46 +0000 Subject: [PATCH 25/47] Doing the setup --- src/Makefile | 29 -- src/cgeneric_aux_nonstat.cpp | 191 -------- src/cgeneric_aux_nonstat_fixed.cpp | 155 ------ src/cgeneric_aux_nonstat_int.cpp | 114 ----- src/cgeneric_defs.h | 68 --- src/cgeneric_gpgraph_alpha1.c | 265 ---------- src/cgeneric_mvnormdens.cpp | 49 -- src/cgeneric_rspde_nonstat_gen_fixed.c | 165 ------- src/cgeneric_rspde_nonstat_general.c | 231 --------- src/cgeneric_rspde_nonstat_int.c | 145 ------ src/cgeneric_rspde_stat_frac_model.c | 484 ------------------- src/cgeneric_rspde_stat_general.c | 565 ---------------------- src/cgeneric_rspde_stat_int.c | 637 ------------------------- src/cgeneric_rspde_stat_parsim_fixed.c | 196 -------- src/cgeneric_rspde_stat_parsim_gen.c | 347 -------------- src/omp.h | 504 ------------------- 16 files changed, 4145 deletions(-) delete mode 100644 src/Makefile delete mode 100644 src/cgeneric_aux_nonstat.cpp delete mode 100644 src/cgeneric_aux_nonstat_fixed.cpp delete mode 100644 src/cgeneric_aux_nonstat_int.cpp delete mode 100644 src/cgeneric_defs.h delete mode 100644 src/cgeneric_gpgraph_alpha1.c delete mode 100644 src/cgeneric_mvnormdens.cpp delete mode 100644 src/cgeneric_rspde_nonstat_gen_fixed.c delete mode 100644 src/cgeneric_rspde_nonstat_general.c delete mode 100644 src/cgeneric_rspde_nonstat_int.c delete mode 100644 src/cgeneric_rspde_stat_frac_model.c delete mode 100644 src/cgeneric_rspde_stat_general.c delete mode 100644 src/cgeneric_rspde_stat_int.c delete mode 100644 src/cgeneric_rspde_stat_parsim_fixed.c delete mode 100644 src/cgeneric_rspde_stat_parsim_gen.c delete mode 100644 src/omp.h diff --git a/src/Makefile b/src/Makefile deleted file mode 100644 index 722f9d04..00000000 --- a/src/Makefile +++ /dev/null @@ -1,29 +0,0 @@ -toInclude = ${R_LIBRARY_DIR}/INLA/include/ - -obj = cgeneric_mvnormdens.o cgeneric_aux_nonstat.o cgeneric_aux_nonstat_fixed.o cgeneric_rspde_stat_frac_model.o cgeneric_rspde_nonstat_general.o cgeneric_rspde_stat_general.o cgeneric_rspde_stat_parsim_gen.o cgeneric_rspde_stat_parsim_fixed.o cgeneric_rspde_stat_int.o cgeneric_rspde_nonstat_gen_fixed.o cgeneric_rspde_nonstat_int.o cgeneric_aux_nonstat_int.o - -all : rSPDE.so - -CC = gcc -CXX = g++ - -EIGEN_MAC = /usr/local -EIGEN_LINUX = /usr - -flags = -O2 -Wall -Wextra -fpic - -%.o: %.c - test -f ${R_LIBRARY_DIR}/INLA/include/cgeneric.h || test -f cgeneric.h || wget -O cgeneric.h https://raw.githubusercontent.com/hrue/r-inla/devel/inlaprog/src/cgeneric.h - $(CC) $(flags) -Iinclude -I$(toInclude) -c $^ -o $@ - -%.o: %.cpp - $(CXX) $(flags) -I$(toInclude) -I$(EIGEN_MAC)/include/eigen3/ -I$(EIGEN_LINUX)/include/eigen3/ -c $^ -o $@ - -rSPDE.so: $(obj) - $(CXX) -shared *.o -o ../inst/shared/rspde_cgeneric_models.so -lblas -llapack - -clean : - rm -f *.o - rm -f cgeneric.h - -.PHONY: all clean \ No newline at end of file diff --git a/src/cgeneric_aux_nonstat.cpp b/src/cgeneric_aux_nonstat.cpp deleted file mode 100644 index 12ed256d..00000000 --- a/src/cgeneric_aux_nonstat.cpp +++ /dev/null @@ -1,191 +0,0 @@ -#include -#include -#include - -extern "C" void compute_Q(int size, double *entries_C, int *i_C, int *j_C, - int n_nonzero_C, - double *entries_G, int *i_G, int *j_G, - int n_nonzero_G, - double *entries_B_kappa, double *entries_B_tau, - int ncol_B, int rspde_order, double *theta_entries, - double *rat_p, double *rat_r, double rat_k, - double *Q_out, - int *graph_i, int *graph_j, int M, - int matern_par, double start_nu, double nu, double d); - -void compute_Q(int size, double *entries_C, int *i_C, int *j_C, - int n_nonzero_C, - double *entries_G, int *i_G, int *j_G, - int n_nonzero_G, - double *entries_B_kappa, double *entries_B_tau, - int ncol_B, int rspde_order, double *theta_entries, - double *rat_p, double *rat_r, double rat_k, - double *Q_out, - int *graph_i, int *graph_j, int M, - int matern_par, double start_nu, double nu, double d) { - - double alpha = nu + d/2.0; - int m_alpha = (int) floor(alpha); - - - typedef Eigen::Triplet Trip; - std::vector trp_C, trp_G, trp_Q; - int k, i, j; - - - // Assemble C and G - Eigen::SparseMatrix C(size,size), G(size,size), Q_graph(size*(rspde_order+1), size*(rspde_order+1)); - - for(k = 0; k < n_nonzero_C; k++){ - trp_C.push_back(Trip(i_C[k],j_C[k],entries_C[k])); - } - - for(k = 0; k < n_nonzero_G; k++){ - trp_G.push_back(Trip(i_G[k],j_G[k],entries_G[k])); - } - - C.setFromTriplets(trp_C.begin(), trp_C.end()); - G.setFromTriplets(trp_G.begin(), trp_G.end()); - - for(k = 0; k < M; k++){ - trp_Q.push_back(Trip(graph_i[k],graph_j[k],1)); - } - - Q_graph.setFromTriplets(trp_Q.begin(), trp_Q.end()); - - Q_graph = Q_graph + Eigen::SparseMatrix(Q_graph.transpose()); - - // Assemble B_kappa and B_tau - - Eigen::MatrixXd B_kappa(size, ncol_B), B_tau(size, ncol_B); - - for(i = 0; i < size; i++){ - for(j = 0; j < ncol_B; j++){ - B_tau(i,j) = entries_B_tau[i*ncol_B + j]; - B_kappa(i,j) = entries_B_kappa[i*ncol_B + j]; - } - } - - if(matern_par == 1){ - B_kappa.col(0) += 0.5 * log( 8 * nu) * Eigen::VectorXd::Constant(B_kappa.rows(), 1) - - 0.5 * log(8 * start_nu) * Eigen::VectorXd::Constant(B_kappa.rows(), 1); - B_tau.col(0) += 0.5 * (lgamma(start_nu + d/2.0) - - lgamma(start_nu) - lgamma(nu + d/2.0) + lgamma(nu)) * Eigen::VectorXd::Constant(B_kappa.rows(),1) + - start_nu * B_kappa.col(0) - nu * B_kappa.col(0); - for(i = 1; i < B_tau.cols(); i++){ - B_tau.col(i) += start_nu * B_kappa.col(i) - nu * B_kappa.col(i); - } - } else if(matern_par == 2){ - B_tau.col(0) += 0.5 * (lgamma(start_nu + d/2.0) - - lgamma(start_nu) - lgamma(nu + d/2.0) + lgamma(nu)) * Eigen::VectorXd::Constant(B_kappa.rows(),1) + - start_nu * B_kappa.col(0) - nu * B_kappa.col(0); - for(i = 1; i < B_tau.cols(); i++){ - B_tau.col(i) += start_nu * B_kappa.col(i) - nu * B_kappa.col(i); - } - } - - - // get kappa and tau - - Eigen::VectorXd theta(ncol_B); - theta(0) = 1; - for(k = 1; k < ncol_B; k++){ - theta(k) = theta_entries[k-1]; - } - - - Eigen::VectorXd kappa = (B_kappa * theta).array().exp(); - Eigen::VectorXd tau = (B_tau * theta).array().exp(); - - // Create vector of the parts of Q - - Eigen::VectorXd Cdiag = C.diagonal(); - - Eigen::SparseMatrix L(size,size), CinvL(size,size); - - L = kappa.cwiseProduct(kappa).cwiseProduct(Cdiag).asDiagonal(); - L = L + G; - - // Scaling L - - double factor = pow(kappa.minCoeff(),2); - - L = L / factor; - - if(m_alpha > 0){ - CinvL = C.cwiseInverse() * L; - } - - int m; - - // Assemble first part of Q - - Eigen::SparseMatrix tau_matrix(size, size); - tau_matrix = tau.asDiagonal(); - - Eigen::SparseMatrix Q_tmp(size,size), Q((rspde_order+1)*size, (rspde_order+1)*size); - - for(k = 0; k < rspde_order; k++){ - Q_tmp = (L - rat_p[k] * C)/rat_r[k]; - if(m_alpha>0){ - for(m = 0; m < m_alpha; m++){ - Q_tmp = Q_tmp * CinvL; - } - } - - Q_tmp = tau_matrix * Q_tmp * tau_matrix; - - for (m=0; m < Q_tmp.outerSize(); ++m) - { - for (Eigen::SparseMatrix::InnerIterator it(Q_tmp,m); it; ++it) - { - Q.insert(it.row() + size*k, it.col() + size*k) = it.value(); - } - } - } - - - // Assemble the K part - - if(m_alpha == 0){ - Q_tmp = C.cwiseInverse(); - } else if(m_alpha == 1){ - Q_tmp = L; - } else{ - Q_tmp = L; - for(m = 0; m < m_alpha-1; m++){ - Q_tmp = Q_tmp * CinvL; - } - } - - Q_tmp = tau_matrix * Q_tmp * tau_matrix; - - - for (m=0; m < Q_tmp.outerSize(); ++m) { - for (Eigen::SparseMatrix::InnerIterator it(Q_tmp,m); it; ++it) - { - Q.insert(it.row() + size*rspde_order, it.col() + size*rspde_order) = it.value()/rat_k; - } - } - - - Q = Q + 0 * Q_graph; - - Q = pow(factor, alpha) * Q; - - Eigen::SparseMatrix Q_triang((rspde_order+1)*size, (rspde_order+1)*size); - Q_triang = Q.triangularView(); - - - int count = 0; - - for (m=0; m < Q_triang.outerSize(); ++m) - { - for (Eigen::SparseMatrix::InnerIterator it(Q_triang,m); it; ++it) - { - Q_out[count] = it.value(); - count++; - } - } - - } \ No newline at end of file diff --git a/src/cgeneric_aux_nonstat_fixed.cpp b/src/cgeneric_aux_nonstat_fixed.cpp deleted file mode 100644 index d11cf627..00000000 --- a/src/cgeneric_aux_nonstat_fixed.cpp +++ /dev/null @@ -1,155 +0,0 @@ -#include -#include -#include - -extern "C" void compute_Q_fixednu(int size, double *entries_C, int *i_C, int *j_C, - int n_nonzero_C, - double *entries_G, int *i_G, int *j_G, - int n_nonzero_G, - double *entries_B_kappa, double *entries_B_tau, - int ncol_B, int rspde_order, double *theta_entries, - double *rat_p, double *rat_r, double rat_k, - int m_alpha, double *Q_out, double alpha); - -void compute_Q_fixednu(int size, double *entries_C, int *i_C, int *j_C, - int n_nonzero_C, - double *entries_G, int *i_G, int *j_G, - int n_nonzero_G, - double *entries_B_kappa, double *entries_B_tau, - int ncol_B, int rspde_order, double *theta_entries, - double *rat_p, double *rat_r, double rat_k, - int m_alpha, double *Q_out, double alpha) { - - - typedef Eigen::Triplet Trip; - std::vector trp_C, trp_G; - int k, i, j; - - - // Assemble C and G - Eigen::SparseMatrix C(size,size), G(size,size), Q_graph(size*(rspde_order+1), size*(rspde_order+1)); - - for(k = 0; k < n_nonzero_C; k++){ - trp_C.push_back(Trip(i_C[k],j_C[k],entries_C[k])); - } - - for(k = 0; k < n_nonzero_G; k++){ - trp_G.push_back(Trip(i_G[k],j_G[k],entries_G[k])); - } - - C.setFromTriplets(trp_C.begin(), trp_C.end()); - G.setFromTriplets(trp_G.begin(), trp_G.end()); - - // Assemble B_kappa and B_tau - - Eigen::MatrixXd B_kappa(size, ncol_B), B_tau(size, ncol_B); - - for(i = 0; i < size; i++){ - for(j = 0; j < ncol_B; j++){ - B_tau(i,j) = entries_B_tau[i*ncol_B + j]; - B_kappa(i,j) = entries_B_kappa[i*ncol_B + j]; - } - } - - // get kappa and tau - - Eigen::VectorXd theta(ncol_B); - theta(0) = 1; - for(k = 1; k < ncol_B; k++){ - theta(k) = theta_entries[k-1]; - } - - - Eigen::VectorXd kappa = (B_kappa * theta).array().exp(); - Eigen::VectorXd tau = (B_tau * theta).array().exp(); - - // Create vector of the parts of Q - - Eigen::VectorXd Cdiag = C.diagonal(); - - Eigen::SparseMatrix L(size,size), CinvL(size,size); - - L = kappa.cwiseProduct(kappa).cwiseProduct(Cdiag).asDiagonal(); - L = L + G; - - // Scaling L - - double factor = pow(kappa.minCoeff(),2); - - L = L / factor; - - if(m_alpha > 0){ - CinvL = C.cwiseInverse() * L; - } - - int m; - - // Assemble first part of Q - - Eigen::SparseMatrix tau_matrix(size, size); - tau_matrix = tau.asDiagonal(); - - Eigen::SparseMatrix Q_tmp(size,size), Q((rspde_order+1)*size, (rspde_order+1)*size); - - for(k = 0; k < rspde_order; k++){ - Q_tmp = (L - rat_p[k] * C)/rat_r[k]; - if(m_alpha>0){ - for(m = 0; m < m_alpha; m++){ - Q_tmp = Q_tmp * CinvL; - } - } - - Q_tmp = tau_matrix * Q_tmp * tau_matrix; - - for (m=0; m < Q_tmp.outerSize(); ++m) - { - for (Eigen::SparseMatrix::InnerIterator it(Q_tmp,m); it; ++it) - { - Q.insert(it.row() + size*k, it.col() + size*k) = it.value(); - } - } - } - - - // Assemble the K part - - if(m_alpha == 0){ - Q_tmp = C.cwiseInverse(); - } else if(m_alpha == 1){ - Q_tmp = L; - } else{ - Q_tmp = L; - for(m = 0; m < m_alpha-1; m++){ - Q_tmp = Q_tmp * CinvL; - } - } - - Q_tmp = tau_matrix * Q_tmp * tau_matrix; - - - for (m=0; m < Q_tmp.outerSize(); ++m) { - for (Eigen::SparseMatrix::InnerIterator it(Q_tmp,m); it; ++it) - { - Q.insert(it.row() + size*rspde_order, it.col() + size*rspde_order) = it.value()/rat_k; - } - } - - - Q = pow(factor, alpha) * Q; - - Eigen::SparseMatrix Q_triang((rspde_order+1)*size, (rspde_order+1)*size); - Q_triang = Q.triangularView(); - - - int count = 0; - - for (m=0; m < Q_triang.outerSize(); ++m) - { - for (Eigen::SparseMatrix::InnerIterator it(Q_triang,m); it; ++it) - { - Q_out[count] = it.value(); - count++; - } - } - - } \ No newline at end of file diff --git a/src/cgeneric_aux_nonstat_int.cpp b/src/cgeneric_aux_nonstat_int.cpp deleted file mode 100644 index df463445..00000000 --- a/src/cgeneric_aux_nonstat_int.cpp +++ /dev/null @@ -1,114 +0,0 @@ -#include -#include -#include - -extern "C" void compute_Q_integer(int size, double *entries_C, int *i_C, int *j_C, - int n_nonzero_C, - double *entries_G, int *i_G, int *j_G, - int n_nonzero_G, - double *entries_B_kappa, double *entries_B_tau, - int ncol_B, double *theta_entries, - double *Q_out, int alpha); - -void compute_Q_integer(int size, double *entries_C, int *i_C, int *j_C, - int n_nonzero_C, - double *entries_G, int *i_G, int *j_G, - int n_nonzero_G, - double *entries_B_kappa, double *entries_B_tau, - int ncol_B, double *theta_entries, - double *Q_out, int alpha) { - - - typedef Eigen::Triplet Trip; - std::vector trp_C, trp_G; - int k, i, j; - - - // Assemble C and G - Eigen::SparseMatrix C(size,size), G(size,size); - - for(k = 0; k < n_nonzero_C; k++){ - trp_C.push_back(Trip(i_C[k],j_C[k],entries_C[k])); - } - - for(k = 0; k < n_nonzero_G; k++){ - trp_G.push_back(Trip(i_G[k],j_G[k],entries_G[k])); - } - - C.setFromTriplets(trp_C.begin(), trp_C.end()); - G.setFromTriplets(trp_G.begin(), trp_G.end()); - - // Assemble B_kappa and B_tau - - Eigen::MatrixXd B_kappa(size, ncol_B), B_tau(size, ncol_B); - - for(i = 0; i < size; i++){ - for(j = 0; j < ncol_B; j++){ - B_tau(i,j) = entries_B_tau[i*ncol_B + j]; - B_kappa(i,j) = entries_B_kappa[i*ncol_B + j]; - } - } - - // get kappa and tau - - Eigen::VectorXd theta(ncol_B); - theta(0) = 1; - for(k = 1; k < ncol_B; k++){ - theta(k) = theta_entries[k-1]; - } - - - Eigen::VectorXd kappa = (B_kappa * theta).array().exp(); - Eigen::VectorXd tau = (B_tau * theta).array().exp(); - - // Create vector of the parts of Q - - Eigen::VectorXd Cdiag = C.diagonal(); - - Eigen::SparseMatrix L(size,size), CinvL(size,size); - - L = kappa.cwiseProduct(kappa).cwiseProduct(Cdiag).asDiagonal(); - L = L + G; - - if(alpha > 1){ - CinvL = C.cwiseInverse() * L; - } - - int m; - - // Assemble first part of Q - - Eigen::SparseMatrix tau_matrix(size, size); - tau_matrix = tau.asDiagonal(); - - Eigen::SparseMatrix Q(size,size); - - Q = L; - - if(alpha > 1){ - for(k = 1; k < alpha; k++){ - Q = Q * CinvL; - } - } - - Q = tau_matrix * Q * tau_matrix; - - - - - Eigen::SparseMatrix Q_triang(size, size); - Q_triang = Q.triangularView(); - - - int count = 0; - - for (m=0; m < Q_triang.outerSize(); ++m) - { - for (Eigen::SparseMatrix::InnerIterator it(Q_triang,m); it; ++it) - { - Q_out[count] = it.value(); - count++; - } - } - - } \ No newline at end of file diff --git a/src/cgeneric_defs.h b/src/cgeneric_defs.h deleted file mode 100644 index cfb6d8d6..00000000 --- a/src/cgeneric_defs.h +++ /dev/null @@ -1,68 +0,0 @@ -#include -#include -#include -#include -#include - -#include "cgeneric.h" - -#define Calloc(n_, type_) (type_ *)calloc((n_), sizeof(type_)) -#define SQR(x) ((x)*(x)) - -// https://stackoverflow.com/questions/9330915/number-of-combinations-n-choose-r-in-c - -double nChoosek( int n, int k ); -double cut_decimals(double nu); - -void daxpy_(int* N, double* DA, double* DX, int* INCX, double* DY, int* INCY); - -void dscal_(int* N, double* DA, double* DX,int* INCX); - -void dcopy_(int* N, double* DX, int* INCX, double* DY,int* INCY); - -void daxpby_(int* N, double* DA, double* DX, int* INCX, double* DB, double* DY, int* INCY, double* DZ); - -void dgesv_(int *n, int *nrhs, double *a, int *lda, - int *ipivot, double *b, int *ldb, int *info) ; - -void dgemv_(char* trans, int* M, int* N, double* alpha, double* A, - int* LDA, double* x, int* incx, - double* beta, double* y, int* inc); - -double * markov_approx_coeff(double beta, double kappa, int d); - -double pnorm(double x, double mu, double sd); - -double logdbeta(double x, double s_1, double s_2); - -double logmultnormvdens(int npar, double *entries_mean, - double *entries_prec, - double *entries_val); - -void compute_Q(int size, double *entries_C, int *i_C, int *j_C, - int n_nonzero_C, - double *entries_G, int *i_G, int *j_G, - int n_nonzero_G, - double *entries_B_kappa, double *entries_B_tau, - int ncol_B, int rspde_order, double *theta_entries, - double *rat_p, double *rat_r, double rat_k, - double *Q_out, - int *graph_i, int *graph_j, int M, - int matern_par, double start_nu, double nu, double d); - -void compute_Q_fixednu(int size, double *entries_C, int *i_C, int *j_C, - int n_nonzero_C, - double *entries_G, int *i_G, int *j_G, - int n_nonzero_G, - double *entries_B_kappa, double *entries_B_tau, - int ncol_B, int rspde_order, double *theta_entries, - double *rat_p, double *rat_r, double rat_k, - int m_alpha, double *Q_out, double alpha); - -void compute_Q_integer(int size, double *entries_C, int *i_C, int *j_C, - int n_nonzero_C, - double *entries_G, int *i_G, int *j_G, - int n_nonzero_G, - double *entries_B_kappa, double *entries_B_tau, - int ncol_B, double *theta_entries, - double *Q_out, int alpha); \ No newline at end of file diff --git a/src/cgeneric_gpgraph_alpha1.c b/src/cgeneric_gpgraph_alpha1.c deleted file mode 100644 index eacc281e..00000000 --- a/src/cgeneric_gpgraph_alpha1.c +++ /dev/null @@ -1,265 +0,0 @@ -#include "cgeneric_defs.h" -#include "stdio.h" - -// This version uses 'padded' matrices with zeroes -double *inla_cgeneric_gpgraph_alpha1_model(inla_cgeneric_cmd_tp cmd, double *theta, inla_cgeneric_data_tp * data) { - - double *ret = NULL; - - double lkappa, lsigma, kappa, sigma; - - double c1, c2, c_1, c_2, one_m_c2, l_e; - - int N, M, i, j, k; - - char *parameterization; - - // the size of the model - assert(data->n_ints == 7); - - // the number of doubles - assert(data->n_doubles == 9); - - assert(!strcasecmp(data->ints[0]->name, "n")); // this will always be the case - N = data->ints[0]->ints[0]; // this will always be the case - assert(N > 0); - - assert(!strcasecmp(data->ints[1]->name, "debug")); // this will always be the case - int debug = data->ints[1]->ints[0]; // this will always be the case - - if(debug == 1){ - debug = 1; - } - - assert(!strcasecmp(data->ints[2]->name, "prec_graph_i")); - inla_cgeneric_vec_tp *graph_i = data->ints[2]; - M = graph_i->len; - - assert(!strcasecmp(data->ints[3]->name, "prec_graph_j")); - inla_cgeneric_vec_tp *graph_j = data->ints[3]; - assert(M == graph_j->len); - - assert(!strcasecmp(data->ints[4]->name, "index_graph")); - inla_cgeneric_vec_tp *idx_ij = data->ints[4]; - int M_full = idx_ij->len; - - assert(!strcasecmp(data->ints[5]->name, "count_idx")); - inla_cgeneric_vec_tp *count_idx = data->ints[5]; - assert(M == count_idx->len); - - assert(!strcasecmp(data->ints[6]->name, "stationary_endpoints")); - inla_cgeneric_vec_tp *stationary_endpoints = data->ints[6]; - - assert(!strcasecmp(data->doubles[0]->name, "EtV2")); - inla_cgeneric_vec_tp *EtV2 = data->doubles[0]; - - int nE = EtV2 -> len; - - assert(!strcasecmp(data->doubles[1]->name, "EtV3")); - inla_cgeneric_vec_tp *EtV3 = data->doubles[1]; - - assert(nE == EtV3 -> len); - - assert(!strcasecmp(data->doubles[2]->name, "El")); - inla_cgeneric_vec_tp *El = data->doubles[2]; - - // prior parameters - assert(!strcasecmp(data->doubles[3]->name, "start_theta")); - double start_theta = data->doubles[3]->doubles[0]; - - assert(!strcasecmp(data->doubles[4]->name, "start_lsigma")); - double start_lsigma = data->doubles[4]->doubles[0]; - - assert(!strcasecmp(data->doubles[5]->name, "prior_theta_meanlog")); - double prior_theta_meanlog = data->doubles[5]->doubles[0]; - - assert(!strcasecmp(data->doubles[6]->name, "prior_theta_sdlog")); - double prior_theta_sdlog = data->doubles[6]->doubles[0]; - - assert(!strcasecmp(data->doubles[7]->name, "prior_sigma_meanlog")); - double prior_sigma_meanlog = data->doubles[7]->doubles[0]; - - assert(!strcasecmp(data->doubles[8]->name, "prior_sigma_sdlog")); - double prior_sigma_sdlog = data->doubles[8]->doubles[0]; - - assert(!strcasecmp(data->chars[2]->name, "parameterization")); - parameterization = &data->chars[2]->chars[0]; - - if (theta) { - // interpretable parameters - - if(!strcasecmp(parameterization, "matern")){ - lkappa = log(2.0) - theta[1]; - } else { - lkappa = theta[1]; - } - lsigma = theta[0]; - kappa = exp(lkappa); - sigma = exp(lsigma); - } - else { - lsigma = lkappa = sigma = kappa = NAN; - } - - switch (cmd) { - case INLA_CGENERIC_VOID: - { - assert(!(cmd == INLA_CGENERIC_VOID)); - break; - } - - case INLA_CGENERIC_GRAPH: - { - k=2; - ret = Calloc(k + 2 * M, double); - ret[0] = N; /* dimension */ - ret[1] = M; /* number of (i <= j) */ - for (i = 0; i < M; i++) { - ret[k++] = graph_i->ints[i]; - } - for (i = 0; i < M; i++) { - ret[k++] = graph_j->ints[i]; - } - break; - } - - - case INLA_CGENERIC_Q: - { - k = 2; - ret = Calloc(k + M, double); - ret[0] = -1; /* REQUIRED */ - ret[1] = M; /* REQUIRED */ - - double *raw_entries; - raw_entries = Calloc(M_full, double); - - // int count=0; - // for(i = 0; i < nE; i++){ - // l_e = El->doubles[i]; - // c1 = exp(-kappa*l_e); - // c2 = SQR(c1); - // one_m_c2 = 1-c2; - // c_1 = 0.5 + c2/one_m_c2; - // c_2 = -c1/one_m_c2; - - // if(EtV2->doubles[i] != EtV3->doubles[i]){ - - // ret[k + idx_ij->ints[count]] = c_1; - // ret[k + idx_ij->ints[count + 1]] = c_1; - // ret[k + idx_ij->ints[count + 2]] = c_2; - // count += 3; - // }else{ - // ret[k + idx_ij->ints[count]] = tanh(0.5 * kappa * l_e); - // count++; - // } - // } - - // if(stationary_endpoints->ints[0]>=0){ - // int stat_endpt_len = stationary_endpoints->len; - // for(i = 0; i < stat_endpt_len; i++){ - // ret[k+idx_ij->ints[count+i]] = 0.5; - // } - // count += stat_endpt_len; - // } - - // assert(count == M); - - // double fact = 2*kappa / (pow(sigma,2)); - - // int one=1; - // dscal_(&M, &fact, &ret[k], &one); - - int count=0; - for(i = 0; i < nE; i++){ - l_e = El->doubles[i]; - c1 = exp(-kappa*l_e); - c2 = SQR(c1); - one_m_c2 = 1-c2; - c_1 = 0.5 + c2/one_m_c2; - c_2 = -c1/one_m_c2; - - if(EtV2->doubles[i] != EtV3->doubles[i]){ - - raw_entries[idx_ij->ints[count]] = c_1; - raw_entries[idx_ij->ints[count + 1]] = c_1; - raw_entries[idx_ij->ints[count + 2]] = c_2; - count += 3; - }else{ - raw_entries[idx_ij->ints[count]] = tanh(0.5 * kappa * l_e); - count++; - } - } - - if(stationary_endpoints->ints[0]>=0){ - int stat_endpt_len = stationary_endpoints->len; - for(i = 0; i < stat_endpt_len; i++){ - raw_entries[idx_ij->ints[count+i]] = 0.5; - } - count += stat_endpt_len; - } - - assert(count == M_full); - - double fact = 2*kappa / (pow(sigma,2)); - - int one=1; - dscal_(&M_full, &fact, &raw_entries[0], &one); - - count = 0; - for(i = 0; i < M; i++){ - for(j = 0; j < count_idx->ints[i]; j++){ - // ret[k + i] += raw_entries[count]; - ret[k + i] += raw_entries[count]; - count++; - } - } - assert(M_full == count); - - break; - } - - case INLA_CGENERIC_MU: - { - ret = Calloc(1, double); - ret[0] = 0.0; - break; - } - - case INLA_CGENERIC_INITIAL: - { - // return c(P, initials) - // where P is the number of hyperparameters - ret = Calloc(3, double); - ret[0] = 2; - ret[1] = start_lsigma; - ret[2] = start_theta; - break; - } - - case INLA_CGENERIC_LOG_NORM_CONST: - { - break; - } - - case INLA_CGENERIC_LOG_PRIOR: - { - ret = Calloc(1, double); - - ret[0] = 0.0; - - ret[0] += -0.5 * SQR(theta[1] - prior_theta_meanlog)/(SQR(prior_theta_sdlog)) - - log(prior_theta_sdlog) - 0.5 * log(2.0 * M_PI); - - ret[0] += -0.5 * SQR(lsigma - prior_sigma_meanlog)/(SQR(prior_sigma_sdlog)) - - log(prior_sigma_sdlog) - 0.5 * log(2.0 * M_PI); - break; - } - - case INLA_CGENERIC_QUIT: - default: - break; - } - - return (ret); -} \ No newline at end of file diff --git a/src/cgeneric_mvnormdens.cpp b/src/cgeneric_mvnormdens.cpp deleted file mode 100644 index b35975ed..00000000 --- a/src/cgeneric_mvnormdens.cpp +++ /dev/null @@ -1,49 +0,0 @@ -#include -#include -#include - -extern "C" double logmultnormvdens(int npar, double *entries_mean, - double *entries_prec, - double *entries_val); - -double logmultnormvdens(int npar, double *entries_mean, - double *entries_prec, - double *entries_val) { - - int i, j, k; - - Eigen::MatrixXd prec_matrix(npar, npar); - - for(i = 0; i < npar; i++){ - for(j = 0; j < npar; j++){ - prec_matrix(i,j) = entries_prec[i*npar + j]; - } - } - - Eigen::VectorXd mean_vec(npar); - for(k = 0; k < npar; k++){ - mean_vec(k) = entries_mean[k]; - } - - Eigen::VectorXd val_vec(npar); - for(k = 0; k < npar; k++){ - val_vec(k) = entries_val[k]; - } - - Eigen::LLT chol(prec_matrix); - - double logdens; - - Eigen::VectorXd centered_vec(npar); - - centered_vec = val_vec - mean_vec; - - logdens = -0.5 * centered_vec.cwiseProduct(prec_matrix * centered_vec).sum(); - - logdens -= npar/2.0 * log(2 * M_PI); - - logdens += chol.matrixL().toDenseMatrix().diagonal().array().log().sum(); - - return logdens; - - } \ No newline at end of file diff --git a/src/cgeneric_rspde_nonstat_gen_fixed.c b/src/cgeneric_rspde_nonstat_gen_fixed.c deleted file mode 100644 index b6b26aad..00000000 --- a/src/cgeneric_rspde_nonstat_gen_fixed.c +++ /dev/null @@ -1,165 +0,0 @@ -#include "cgeneric_defs.h" -#include "stdio.h" -// #include "gsl/gsl_vector_double.h" - - -// This version uses 'padded' matrices with zeroes -double *inla_cgeneric_rspde_nonstat_fixed_model(inla_cgeneric_cmd_tp cmd, double *theta, inla_cgeneric_data_tp * data) { - - double *ret = NULL; - - int k, i; - - assert(!strcasecmp(data->ints[0]->name, "n")); // this will always be the case - int N = data->ints[0]->ints[0]; // this will always be the case - assert(N > 0); - - assert(!strcasecmp(data->ints[1]->name, "debug")); // this will always be the case - int debug = data->ints[1]->ints[0]; // this will always be the case - - if(debug == 1){ - debug = 1; - } - - assert(!strcasecmp(data->ints[2]->name, "graph_opt_i")); - inla_cgeneric_vec_tp *graph_i = data->ints[2]; - int M = graph_i->len; - - assert(!strcasecmp(data->ints[3]->name, "graph_opt_j")); - inla_cgeneric_vec_tp *graph_j = data->ints[3]; - assert(M == graph_j->len); - - assert(!strcasecmp(data->ints[4]->name, "rspde_order")); - int rspde_order = data->ints[4]->ints[0]; - - - assert(!strcasecmp(data->doubles[0]->name, "d")); - double d = data->doubles[0]->doubles[0]; - - assert(!strcasecmp(data->doubles[1]->name, "r_ratapprox")); - double *r = data->doubles[1]->doubles; - - assert(!strcasecmp(data->doubles[2]->name, "p_ratapprox")); - double *p = data->doubles[2]->doubles; - - assert(!strcasecmp(data->doubles[3]->name, "k_ratapprox")); - double k_rat = data->doubles[3]->doubles[0]; - - assert(!strcasecmp(data->doubles[4]->name, "nu")); - double nu = data->doubles[4]->doubles[0]; - - double alpha = nu + d / 2.0; - int m_alpha = floor(alpha); - - assert(!strcasecmp(data->smats[0]->name, "C")); - inla_cgeneric_smat_tp *C = data->smats[0]; - - assert(!strcasecmp(data->smats[1]->name, "G")); - inla_cgeneric_smat_tp *G = data->smats[1]; - - int n_mesh = C->ncol; - - assert(!strcasecmp(data->mats[0]->name, "B_tau")); - inla_cgeneric_mat_tp *B_tau = data->mats[0]; - - assert(!strcasecmp(data->mats[1]->name, "B_kappa")); - inla_cgeneric_mat_tp *B_kappa = data->mats[1]; - - int n_par = B_tau->ncol; - - // Starting values - - assert(!strcasecmp(data->doubles[5]->name, "start.theta")); - inla_cgeneric_vec_tp *start_theta = data->doubles[5]; - - assert(!strcasecmp(data->doubles[6]->name, "theta.prior.mean")); - inla_cgeneric_vec_tp *theta_prior_mean = data->doubles[6]; - - assert(!strcasecmp(data->mats[2]->name, "theta.prior.prec")); - inla_cgeneric_mat_tp *theta_prior_prec = data->mats[2]; - - switch (cmd) { - case INLA_CGENERIC_VOID: - { - assert(!(cmd == INLA_CGENERIC_VOID)); - break; - } - - case INLA_CGENERIC_GRAPH: - { - k=2; - ret = Calloc(k + 2 * M, double); - ret[0] = N; /* dimension */ - ret[1] = M; /* number of (i <= j) */ - for (i = 0; i < M; i++) { - ret[k++] = graph_i->ints[i]; - } - for (i = 0; i < M; i++) { - ret[k++] = graph_j->ints[i]; - } - break; - } - - case INLA_CGENERIC_Q: - { - k = 2; - ret = Calloc(k + M, double); - ret[0] = -1; /* REQUIRED */ - ret[1] = M; /* REQUIRED */ - - compute_Q_fixednu(n_mesh, C->x, C->i, C->j, - C->n, - G->x, G->i, G->j, - G->n, - B_kappa->x, B_tau->x, - B_kappa->ncol, rspde_order, - theta, p, r, k_rat, - m_alpha, &ret[k], - alpha); - - break; - } - - case INLA_CGENERIC_MU: - { - ret = Calloc(1, double); - ret[0] = 0.0; - break; - } - - case INLA_CGENERIC_INITIAL: - { - // return c(P, initials) - // where P is the number of hyperparameters - ret = Calloc(n_par, double); - ret[0] = n_par-1; - for(i=1; idoubles[i-1]; - } - break; - } - - case INLA_CGENERIC_LOG_NORM_CONST: - { - break; - } - - case INLA_CGENERIC_LOG_PRIOR: - { - ret = Calloc(1, double); - - ret[0] = 0.0; - - ret[0] += logmultnormvdens(n_par-1, theta_prior_mean->doubles, - theta_prior_prec->x, theta); - - break; - } - - case INLA_CGENERIC_QUIT: - default: - break; - } - - return (ret); -} \ No newline at end of file diff --git a/src/cgeneric_rspde_nonstat_general.c b/src/cgeneric_rspde_nonstat_general.c deleted file mode 100644 index 9d799109..00000000 --- a/src/cgeneric_rspde_nonstat_general.c +++ /dev/null @@ -1,231 +0,0 @@ -#include "cgeneric_defs.h" -#include "stdio.h" -// #include "gsl/gsl_vector_double.h" - - -// This version uses 'padded' matrices with zeroes -double *inla_cgeneric_rspde_nonstat_general_model(inla_cgeneric_cmd_tp cmd, double *theta, inla_cgeneric_data_tp * data) { - - double *ret = NULL; - - char *prior_nu_dist; - - int k, i; - - assert(!strcasecmp(data->ints[0]->name, "n")); // this will always be the case - int N = data->ints[0]->ints[0]; // this will always be the case - assert(N > 0); - - assert(!strcasecmp(data->ints[1]->name, "debug")); // this will always be the case - int debug = data->ints[1]->ints[0]; // this will always be the case - - if(debug == 1){ - debug = 1; - } - - assert(!strcasecmp(data->ints[2]->name, "graph_opt_i")); - inla_cgeneric_vec_tp *graph_i = data->ints[2]; - int M = graph_i->len; - - assert(!strcasecmp(data->ints[3]->name, "graph_opt_j")); - inla_cgeneric_vec_tp *graph_j = data->ints[3]; - assert(M == graph_j->len); - - assert(!strcasecmp(data->ints[4]->name, "rspde_order")); - int rspde_order = data->ints[4]->ints[0]; - - assert(!strcasecmp(data->ints[5]->name, "matern_par")); - int matern_par = data->ints[5]->ints[0]; - - - assert(!strcasecmp(data->doubles[0]->name, "d")); - double d = data->doubles[0]->doubles[0]; - - assert(!strcasecmp(data->doubles[1]->name, "nu_upper_bound")); - double nu_upper_bound = data->doubles[1]->doubles[0]; - - assert(!strcasecmp(data->mats[0]->name, "rational_table")); - inla_cgeneric_mat_tp *rational_table = data->mats[0]; - assert(rational_table->nrow == 999); - - assert(!strcasecmp(data->smats[0]->name, "C")); - inla_cgeneric_smat_tp *C = data->smats[0]; - - assert(!strcasecmp(data->smats[1]->name, "G")); - inla_cgeneric_smat_tp *G = data->smats[1]; - - int n_mesh = C->ncol; - - assert(!strcasecmp(data->mats[1]->name, "B_tau")); - inla_cgeneric_mat_tp *B_tau = data->mats[1]; - - assert(!strcasecmp(data->mats[2]->name, "B_kappa")); - inla_cgeneric_mat_tp *B_kappa = data->mats[2]; - - int n_par = B_tau->ncol; - - // Prior param - - assert(!strcasecmp(data->doubles[2]->name, "prior.nu.loglocation")); - double prior_nu_loglocation = data->doubles[2]->doubles[0]; - - assert(!strcasecmp(data->doubles[3]->name, "prior.nu.logscale")); - double prior_nu_logscale = data->doubles[3]->doubles[0]; - - assert(!strcasecmp(data->doubles[4]->name, "prior.nu.mean")); - double prior_nu_mean = data->doubles[4]->doubles[0]; - - assert(!strcasecmp(data->doubles[5]->name, "prior.nu.prec")); - double prior_nu_prec = data->doubles[5]->doubles[0]; - - // Nu prior - - assert(!strcasecmp(data->chars[2]->name, "prior.nu.dist")); - prior_nu_dist = &data->chars[2]->chars[0]; - - // Starting values - - assert(!strcasecmp(data->doubles[6]->name, "start.nu")); - double start_nu = data->doubles[6]->doubles[0]; - - assert(!strcasecmp(data->doubles[7]->name, "start.theta")); - inla_cgeneric_vec_tp *start_theta = data->doubles[7]; - - assert(!strcasecmp(data->doubles[8]->name, "theta.prior.mean")); - inla_cgeneric_vec_tp *theta_prior_mean = data->doubles[8]; - - assert(!strcasecmp(data->mats[3]->name, "theta.prior.prec")); - inla_cgeneric_mat_tp *theta_prior_prec = data->mats[3]; - - double lnu, nu; - - if (theta) { - // interpretable parameters - lnu = theta[n_par-1]; - nu = (exp(lnu)/(1.0 + exp(lnu))) * nu_upper_bound; - } - else { - lnu = nu = NAN; - } - - - - switch (cmd) { - case INLA_CGENERIC_VOID: - { - assert(!(cmd == INLA_CGENERIC_VOID)); - break; - } - - case INLA_CGENERIC_GRAPH: - { - k=2; - ret = Calloc(k + 2 * M, double); - ret[0] = N; /* dimension */ - ret[1] = M; /* number of (i <= j) */ - for (i = 0; i < M; i++) { - ret[k++] = graph_i->ints[i]; - } - for (i = 0; i < M; i++) { - ret[k++] = graph_j->ints[i]; - } - break; - } - - case INLA_CGENERIC_Q: - { - k = 2; - ret = Calloc(k + M, double); - ret[0] = -1; /* REQUIRED */ - ret[1] = M; /* REQUIRED */ - - int n_terms = 2*rspde_order + 2; - - double new_alpha = nu + d/2.0; - - int row_nu = (int)round(1000*cut_decimals(new_alpha))-1; - - double *rat_coef = Calloc(n_terms-1, double); - - rat_coef = &rational_table->x[row_nu*n_terms+1]; - - double *r, *p, k_rat; - - r = Calloc(rspde_order, double); - p = Calloc(rspde_order, double); - - r = &rat_coef[0]; - p = &rat_coef[rspde_order]; - k_rat = rat_coef[2*rspde_order]; - - compute_Q(n_mesh, C->x, C->i, C->j, - C->n, - G->x, G->i, G->j, - G->n, - B_kappa->x, B_tau->x, - B_kappa->ncol, rspde_order, - theta, p, r, k_rat, &ret[k], - graph_i->ints, graph_j->ints, - M, matern_par, start_nu, nu, - d); - - break; - } - - case INLA_CGENERIC_MU: - { - ret = Calloc(1, double); - ret[0] = 0.0; - break; - } - - case INLA_CGENERIC_INITIAL: - { - // return c(P, initials) - // where P is the number of hyperparameters - ret = Calloc(n_par+1, double); - ret[0] = n_par; - for(i=1; idoubles[i-1]; - } - ret[n_par] = log(start_nu/(nu_upper_bound - start_nu)); - break; - } - - case INLA_CGENERIC_LOG_NORM_CONST: - { - break; - } - - case INLA_CGENERIC_LOG_PRIOR: - { - ret = Calloc(1, double); - - ret[0] = 0.0; - - if(!strcasecmp(prior_nu_dist, "lognormal")){ - ret[0] += -0.5 * SQR(lnu - prior_nu_loglocation)/(SQR(prior_nu_logscale)); - ret[0] += -log(prior_nu_logscale) - 0.5 * log(2.0*M_PI); - ret[0] -= log(pnorm(log(nu_upper_bound), prior_nu_loglocation, prior_nu_logscale)); - - } - else { // if(!strcasecmp(prior_nu_dist, "beta")){ - double s_1 = (prior_nu_mean / nu_upper_bound) * prior_nu_prec; - double s_2 = (1 - prior_nu_mean / nu_upper_bound) * prior_nu_prec; - ret[0] += logdbeta(nu / nu_upper_bound, s_1, s_2) - log(nu_upper_bound); - } - - ret[0] += logmultnormvdens(n_par-1, theta_prior_mean->doubles, - theta_prior_prec->x, theta); - - - break; - } - - case INLA_CGENERIC_QUIT: - default: - break; - } - - return (ret); -} \ No newline at end of file diff --git a/src/cgeneric_rspde_nonstat_int.c b/src/cgeneric_rspde_nonstat_int.c deleted file mode 100644 index 6311d85f..00000000 --- a/src/cgeneric_rspde_nonstat_int.c +++ /dev/null @@ -1,145 +0,0 @@ -#include "cgeneric_defs.h" -#include "stdio.h" -// #include "gsl/gsl_vector_double.h" - - -// This version uses 'padded' matrices with zeroes -double *inla_cgeneric_rspde_nonstat_int_model(inla_cgeneric_cmd_tp cmd, double *theta, inla_cgeneric_data_tp * data) { - - double *ret = NULL; - - int k, i; - - assert(!strcasecmp(data->ints[0]->name, "n")); // this will always be the case - int N = data->ints[0]->ints[0]; // this will always be the case - assert(N > 0); - - assert(!strcasecmp(data->ints[1]->name, "debug")); // this will always be the case - int debug = data->ints[1]->ints[0]; // this will always be the case - - if(debug == 1){ - debug = 1; - } - - assert(!strcasecmp(data->ints[2]->name, "graph_opt_i")); - inla_cgeneric_vec_tp *graph_i = data->ints[2]; - int M = graph_i->len; - - assert(!strcasecmp(data->ints[3]->name, "graph_opt_j")); - inla_cgeneric_vec_tp *graph_j = data->ints[3]; - assert(M == graph_j->len); - - assert(!strcasecmp(data->ints[4]->name, "alpha")); - int alpha = data->ints[4]->ints[0]; - - assert(!strcasecmp(data->smats[0]->name, "C")); - inla_cgeneric_smat_tp *C = data->smats[0]; - - assert(!strcasecmp(data->smats[1]->name, "G")); - inla_cgeneric_smat_tp *G = data->smats[1]; - - int n_mesh = C->ncol; - - assert(!strcasecmp(data->mats[0]->name, "B_tau")); - inla_cgeneric_mat_tp *B_tau = data->mats[0]; - - assert(!strcasecmp(data->mats[1]->name, "B_kappa")); - inla_cgeneric_mat_tp *B_kappa = data->mats[1]; - - int n_par = B_tau->ncol; - - // Starting values - - assert(!strcasecmp(data->doubles[0]->name, "start.theta")); - inla_cgeneric_vec_tp *start_theta = data->doubles[0]; - - assert(!strcasecmp(data->doubles[1]->name, "theta.prior.mean")); - inla_cgeneric_vec_tp *theta_prior_mean = data->doubles[1]; - - assert(!strcasecmp(data->mats[2]->name, "theta.prior.prec")); - inla_cgeneric_mat_tp *theta_prior_prec = data->mats[2]; - - switch (cmd) { - case INLA_CGENERIC_VOID: - { - assert(!(cmd == INLA_CGENERIC_VOID)); - break; - } - - case INLA_CGENERIC_GRAPH: - { - k=2; - ret = Calloc(k + 2 * M, double); - ret[0] = N; /* dimension */ - ret[1] = M; /* number of (i <= j) */ - for (i = 0; i < M; i++) { - ret[k++] = graph_i->ints[i]; - } - for (i = 0; i < M; i++) { - ret[k++] = graph_j->ints[i]; - } - break; - } - - case INLA_CGENERIC_Q: - { - k = 2; - ret = Calloc(k + M, double); - ret[0] = -1; /* REQUIRED */ - ret[1] = M; /* REQUIRED */ - - compute_Q_integer(n_mesh, C->x, C->i, C->j, - C->n, - G->x, G->i, G->j, - G->n, - B_kappa->x, B_tau->x, - B_kappa->ncol, - theta, &ret[k], - alpha); - - break; - } - - case INLA_CGENERIC_MU: - { - ret = Calloc(1, double); - ret[0] = 0.0; - break; - } - - case INLA_CGENERIC_INITIAL: - { - // return c(P, initials) - // where P is the number of hyperparameters - ret = Calloc(n_par, double); - ret[0] = n_par-1; - for(i=1; idoubles[i-1]; - } - break; - } - - case INLA_CGENERIC_LOG_NORM_CONST: - { - break; - } - - case INLA_CGENERIC_LOG_PRIOR: - { - ret = Calloc(1, double); - - ret[0] = 0.0; - - ret[0] += logmultnormvdens(n_par-1, theta_prior_mean->doubles, - theta_prior_prec->x, theta); - - break; - } - - case INLA_CGENERIC_QUIT: - default: - break; - } - - return (ret); -} \ No newline at end of file diff --git a/src/cgeneric_rspde_stat_frac_model.c b/src/cgeneric_rspde_stat_frac_model.c deleted file mode 100644 index 3de59cc6..00000000 --- a/src/cgeneric_rspde_stat_frac_model.c +++ /dev/null @@ -1,484 +0,0 @@ -#include "cgeneric_defs.h" -// #include "stdio.h" -// #include "gsl/gsl_vector_double.h" - -// This version uses 'padded' matrices with zeroes -double *inla_cgeneric_rspde_stat_frac_model(inla_cgeneric_cmd_tp cmd, double *theta, inla_cgeneric_data_tp * data) { - - double *ret = NULL; - double ltau, lkappa, tau, kappa; - double alpha, nu; - int m_alpha; - int N, M, i, k, j, rspde_order, d; - int full_size, less_size; - int one = 1; - char *parameterization, *theta_param; - - assert(!strcasecmp(data->ints[0]->name, "n")); // this will always be the case - N = data->ints[0]->ints[0]; // this will always be the case - assert(N > 0); - - assert(!strcasecmp(data->ints[1]->name, "debug")); // this will always be the case - int debug = data->ints[1]->ints[0]; // this will always be the case - - if(debug == 1){ - debug = 1; - } - - assert(!strcasecmp(data->ints[2]->name, "graph_opt_i")); - inla_cgeneric_vec_tp *graph_i = data->ints[2]; - M = graph_i->len; - - assert(!strcasecmp(data->ints[3]->name, "graph_opt_j")); - inla_cgeneric_vec_tp *graph_j = data->ints[3]; - assert(M == graph_j->len); - - assert(!strcasecmp(data->ints[4]->name, "rspde.order")); - rspde_order = data->ints[4]->ints[0]; - - assert(!strcasecmp(data->ints[5]->name, "d")); - d = data->ints[5]->ints[0]; - - assert(!strcasecmp(data->chars[2]->name, "parameterization")); - parameterization = &data->chars[2]->chars[0]; - - assert(!strcasecmp(data->chars[3]->name, "prior.theta.param")); - theta_param = &data->chars[3]->chars[0]; - - assert(!strcasecmp(data->doubles[0]->name, "nu")); - nu = data->doubles[0]->doubles[0]; - - alpha = nu + d / 2.0; - m_alpha = floor(alpha); - - assert(!strcasecmp(data->doubles[1]->name, "matrices_less")); - inla_cgeneric_vec_tp *fem_less = data->doubles[1]; - - assert(!strcasecmp(data->doubles[2]->name, "matrices_full")); - inla_cgeneric_vec_tp *fem_full = data->doubles[2]; - full_size = (fem_full->len)/(m_alpha+2); - less_size = (fem_less->len)/(m_alpha+1); - assert(M == rspde_order * full_size + less_size); - - - assert(!strcasecmp(data->doubles[3]->name, "r_ratapprox")); - double *r = data->doubles[3]->doubles; - - assert(!strcasecmp(data->doubles[4]->name, "p_ratapprox")); - double *p = data->doubles[4]->doubles; - - assert(!strcasecmp(data->doubles[5]->name, "k_ratapprox")); - double k_rat = data->doubles[5]->doubles[0]; - - // prior parameters - - assert(!strcasecmp(data->doubles[6]->name, "theta.prior.mean")); - inla_cgeneric_vec_tp *theta_prior_mean = data->doubles[6]; - - assert(!strcasecmp(data->mats[0]->name, "theta.prior.prec")); - inla_cgeneric_mat_tp *theta_prior_prec = data->mats[0]; - - assert(!strcasecmp(data->doubles[7]->name, "start.theta")); - inla_cgeneric_vec_tp *start_theta = data->doubles[7]; - - if (theta) { - // interpretable parameters - if(!strcasecmp(parameterization, "matern")){ - lkappa = 0.5 * log(8.0 * nu) - theta[1]; - ltau = - theta[0] + 0.5 *( - lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) - ); - - } else if(!strcasecmp(parameterization, "matern2")) { - lkappa = - theta[1]; - ltau = - 0.5 * theta[0] + 0.5 *( - lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) - ); - } else { - ltau = theta[0]; - lkappa = theta[1]; - } - tau = exp(ltau); - kappa = exp(lkappa); - - } - else { - ltau = lkappa = tau = kappa = NAN; - } - - switch (cmd) { - case INLA_CGENERIC_VOID: - { - assert(!(cmd == INLA_CGENERIC_VOID)); - break; - } - - case INLA_CGENERIC_GRAPH: - { - k=2; - ret = Calloc(k + 2 * M, double); - ret[0] = N; /* dimension */ - ret[1] = M; /* number of (i <= j) */ - for (i = 0; i < M; i++) { - ret[k++] = graph_i->ints[i]; - } - for (i = 0; i < M; i++) { - ret[k++] = graph_j->ints[i]; - } - break; - } - - case INLA_CGENERIC_Q: - { - k = 2; - ret = Calloc(k + M, double); - ret[0] = -1; /* REQUIRED */ - ret[1] = M; /* REQUIRED */ - - // FORTRAN IMPLEMENTATION - - double multQ = pow(kappa, 2*alpha) * SQR(tau); - - switch(m_alpha){ - case 0: - { - double fact_mult; - for(j = 0; j < rspde_order; j++){ - fact_mult = multQ * (1-p[j])/r[j]; - dcopy_(&full_size, &fem_full->doubles[0], &one, &ret[k + j*full_size], &one); - dscal_(&full_size, &fact_mult, &ret[k+ j*full_size], &one); - fact_mult = multQ / (r[j] * SQR(kappa)); - daxpy_(&full_size, &fact_mult, &fem_full->doubles[full_size], &one, &ret[k+j*full_size], &one); - } - // dcopy_(&less_size, &fem_less->doubles[0], &one, &ret[k+rspde_order * full_size], &one); - // fact_mult = multQ/k_rat; - // dscal_(&less_size, &fact_mult, &ret[k+rspde_order * full_size], &one); - for(i = 0; i < less_size; i++){ - if(fem_less->doubles[i] != 0){ - ret[k+rspde_order*full_size + i] = multQ * ( - 1/(k_rat * fem_less->doubles[i]) - ); - } - } - break; - } - case 1: - { - double *Malpha2, fact_mult; - Malpha2 = Calloc(full_size, double); - for(j = 0; j < rspde_order; j++){ - dcopy_(&full_size, &fem_full->doubles[0], &one, &ret[k+j*full_size], &one); - fact_mult = 1/SQR(kappa); - daxpy_(&full_size, &fact_mult, &fem_full->doubles[full_size], &one, &ret[k+j*full_size], &one); - fact_mult = multQ * (1-p[j])/r[j]; - dscal_(&full_size, &fact_mult, &ret[k+j*full_size], &one); - dcopy_(&full_size, &fem_full->doubles[full_size], &one, Malpha2, &one); - fact_mult = 1/SQR(kappa); - daxpy_(&full_size, &fact_mult, &fem_full->doubles[2*full_size], &one, Malpha2, &one); - fact_mult = multQ/(SQR(kappa) * r[j]); - daxpy_(&full_size, &fact_mult, Malpha2, &one, &ret[k + j*full_size], &one); - } - - free(Malpha2); - - dcopy_(&less_size, &fem_less->doubles[0], &one, &ret[k+rspde_order*full_size], &one); - fact_mult = multQ/k_rat; - dscal_(&less_size, &fact_mult, &ret[k+rspde_order*full_size], &one); - fact_mult = multQ/(k_rat * SQR(kappa)); - daxpy_(&less_size, &fact_mult, &fem_less->doubles[less_size], &one, &ret[k+rspde_order*full_size], &one); - break; - } - default: - { - double *Malpha2, fact_mult; - Malpha2 = Calloc(full_size, double); - for(j = 0; j < rspde_order; j++){ - dcopy_(&full_size, &fem_full->doubles[0],&one, &ret[k+j*full_size], &one); - fact_mult = m_alpha/SQR(kappa); - daxpy_(&full_size, &fact_mult, &fem_full->doubles[full_size], &one, &ret[k+j*full_size], &one); - for(i = 2; i<= m_alpha; i++){ - fact_mult = nChoosek(m_alpha, i)/(pow(kappa, 2*i)); - daxpy_(&full_size, &fact_mult, &fem_full->doubles[i*full_size], &one, &ret[k+j*full_size], &one); - } - fact_mult = multQ * (1-p[j])/r[j]; - dscal_(&full_size, &fact_mult, &ret[k+j*full_size], &one); - dcopy_(&full_size, &fem_full->doubles[full_size], &one, Malpha2, &one); - fact_mult = m_alpha/SQR(kappa); - daxpy_(&full_size, &fact_mult, &fem_full->doubles[2*full_size], &one, Malpha2, &one); - for(i = 2; i<= m_alpha; i++){ - fact_mult = nChoosek(m_alpha, i)/(pow(kappa, 2*i)); - daxpy_(&full_size, &fact_mult, &fem_full->doubles[(i+1)*full_size], &one, Malpha2, &one); - } - fact_mult = multQ/(SQR(kappa) * r[j]); - daxpy_(&full_size, &fact_mult, Malpha2, &one, &ret[k + j*full_size], &one); - } - - free(Malpha2); - - dcopy_(&less_size, &fem_less->doubles[0], &one, &ret[k+rspde_order*full_size], &one); - fact_mult = multQ/k_rat; - dscal_(&less_size, &fact_mult, &ret[k+rspde_order*full_size], &one); - fact_mult = multQ * m_alpha/(k_rat * SQR(kappa)); - daxpy_(&less_size, &fact_mult, &fem_less->doubles[less_size], &one, &ret[k+rspde_order*full_size], &one); - for(j = 2; j<= m_alpha; j++){ - fact_mult = multQ * nChoosek(m_alpha, j)/(k_rat * pow(SQR(kappa),j)); - daxpy_(&less_size, &fact_mult, &fem_less->doubles[j*less_size], &one, &ret[k+rspde_order*full_size], &one); - } - break; - } - } - - // GSL IMPLEMENTATION - - // gsl_vector * FEM1 = gsl_vector_calloc(full_size); // C, then G, G_2, etc. - // gsl_vector * FEM2 = gsl_vector_calloc(full_size); // G, then G_2, G_3, etc., then part to be returned - - - - // switch(new_m_alpha){ - // case 0: - // { - // dcopy_(&full_size, &fem_full->doubles[0], &one, &FEM1->data[0], &one); - // for(j = 0; j < rspde_order; j++){ - // dcopy_(&full_size, &fem_full->doubles[full_size], &one, &FEM2->data[0], &one); - // gsl_vector_axpby(multQ * (1-p[j])/r[j], FEM1, multQ / (r[j] * SQR(kappa)), FEM2); - // dcopy_(&full_size, &FEM2->data[0], &one, &ret[k + j*full_size], &one); - // } - // gsl_vector_free(FEM1); - // gsl_vector_free(FEM2); - // gsl_vector * FEM1 = gsl_vector_calloc(less_size); // C, then G, G_2, etc. - // dcopy_(&less_size, &fem_less->doubles[0], &one, &FEM1->data[0], &one); - // gsl_vector_scale(FEM1, multQ/k_rat); - // dcopy_(&less_size, &FEM1->data[0], &one, &ret[k + rspde_order * full_size], &one); - // gsl_vector_free(FEM1); - // break; - // } - // case 1: - // { - // dcopy_(&full_size, &fem_full->doubles[0], &one, &FEM1->data[0], &one); - // dcopy_(&full_size, &fem_full->doubles[full_size], &one, &FEM2->data[0], &one); - // gsl_vector_axpby(1/SQR(kappa), FEM2, 1, FEM1); // FEM1 = M_alpha - // gsl_vector * FEM3 = gsl_vector_calloc(full_size); - // dcopy_(&full_size, &fem_full->doubles[2 * full_size], &one, &FEM3->data[0], &one); - // gsl_vector_axpby(1/SQR(kappa), FEM3, 1, FEM2); // FEM2 = M_alpha2 - // gsl_vector_memcpy(FEM3, FEM2); - // for(j = 0; j < rspde_order; j++){ - // gsl_vector_axpby(multQ * (1-p[j])/r[j], FEM1, multQ/(SQR(kappa) * r[j]), FEM2); //FEM2 -> part of Q - // dcopy_(&full_size, &FEM2->data[0], &one, &ret[k + j*full_size], &one); - // gsl_vector_memcpy(FEM2, FEM3); - // } - // // Add k part - // gsl_vector_free(FEM1); - // gsl_vector_free(FEM2); - // gsl_vector_free(FEM3); - // gsl_vector * FEM1 = gsl_vector_calloc(less_size); - // gsl_vector * FEM2 = gsl_vector_calloc(less_size); - // dcopy_(&less_size, &fem_less->doubles[0], &one, &FEM1->data[0], &one); // copy C back to FEM1 - // dcopy_(&less_size, &fem_less->doubles[less_size], &one, &FEM2->data[0], &one); - // gsl_vector_axpby(multQ/(k_rat * SQR(kappa)), FEM2, multQ/k_rat, FEM1); - // dcopy_(&less_size, &FEM1->data[0], &one, &ret[k + rspde_order * full_size], &one); - // gsl_vector_free(FEM1); - // gsl_vector_free(FEM2); - // break; - // } - // default: - // { - // dcopy_(&full_size, &fem_full->doubles[0], &one, &FEM1->data[0], &one); - // gsl_vector * FEM3 = gsl_vector_calloc(full_size); - // dcopy_(&full_size, &fem_full->doubles[full_size], &one, &FEM2->data[0], &one); - // gsl_vector_axpby(new_m_alpha/SQR(kappa), FEM2, 1, FEM1); // FEM1 = M_alpha - // for(j = 2; j<= new_m_alpha; j++){ - // dcopy_(&full_size, &fem_full->doubles[j * full_size], &one, &FEM3->data[0], &one); - // gsl_vector_axpby(nChoosek(new_m_alpha, j)/(pow(kappa, 2*j)), FEM3, 1, FEM1); - // } - // dcopy_(&full_size, &fem_full->doubles[2 * full_size], &one, &FEM3->data[0], &one); - // gsl_vector_axpby(new_m_alpha/SQR(kappa), FEM3, 1, FEM2); // FEM2 = M_alpha2 - // for(j = 2; j<= new_m_alpha; j++){ - // dcopy_(&full_size, &fem_full->doubles[(j+1) * full_size], &one, &FEM3->data[0], &one); - // gsl_vector_axpby(nChoosek(new_m_alpha, j)/(pow(kappa,2*j)), FEM3, 1, FEM2); - // } - - - // gsl_vector_memcpy(FEM3, FEM2); - // for(j = 0; j < rspde_order; j++){ - // gsl_vector_axpby(multQ * (1-p[j])/r[j], FEM1, multQ/(SQR(kappa) * r[j]), FEM2); //FEM2 -> part of Q - // dcopy_(&full_size, &FEM2->data[0], &one, &ret[k + j*full_size], &one); - // gsl_vector_memcpy(FEM2, FEM3); - // } - // // Add k part - // gsl_vector_free(FEM1); - // gsl_vector_free(FEM2); - // gsl_vector_free(FEM3); - // gsl_vector * FEM1 = gsl_vector_calloc(less_size); - // gsl_vector * FEM2 = gsl_vector_calloc(less_size); - // dcopy_(&less_size, &fem_less->doubles[0], &one, &FEM1->data[0], &one); // copy C back to FEM1 - // dcopy_(&less_size, &fem_less->doubles[less_size], &one, &FEM2->data[0], &one); - // gsl_vector_axpby(multQ * new_m_alpha/(k_rat * SQR(kappa)), FEM2, multQ/k_rat, FEM1); - // for(j = 2; j<= new_m_alpha; j++){ - // dcopy_(&less_size, &fem_less->doubles[j * less_size], &one, &FEM2->data[0], &one); - // gsl_vector_axpby(multQ * nChoosek(new_m_alpha, j)/(k_rat * pow(SQR(kappa),j)), FEM2, 1, FEM1); - // } - // dcopy_(&less_size, &FEM1->data[0], &one, &ret[k + rspde_order * full_size], &one); - // gsl_vector_free(FEM1); - // gsl_vector_free(FEM2); - // break; - // } - // } - - // DIRECT C IMPLEMENTATION - - // double *Malpha, *Malpha2; - - - // // double multQ = pow(kappa, 2*new_alpha) * SQR(tau); - - // if(new_m_alpha == 0){ - // for(j = 0; j < rspde_order; j++){ - // for(i = 0; i < full_size; i++){ - // ret[k + j*full_size + i] = multQ * ( - // (fem_full->doubles[i] + (fem_full->doubles[full_size+i])/(SQR(kappa))) - - // (p[j] * fem_full->doubles[i]) - // ) / r[j]; - // } - // } - - // // Kpart - // for(i = 0; i < less_size; i++){ - // ret[k+rspde_order*full_size + i] = multQ * ( - // fem_less->doubles[i]/k_rat - // ); - // } - - // } else{ - - // Malpha = Calloc(full_size, double); - // Malpha2 = Calloc(full_size, double); - - // if(new_m_alpha == 1){ - // // for(i = 0; i < full_size; i++){ - // // Malpha[i] = fem_full->doubles[i] + (fem_full->doubles[full_size+i])/(SQR(kappa)); - // // Malpha2[i] = fem_full->doubles[full_size+i] + (fem_full->doubles[2*full_size+i])/(SQR(kappa)); - // // } - // for(i = 0; i < full_size; i++){ - // Malpha[i] = fem_full->doubles[i] + (fem_full->doubles[full_size+i])/(SQR(kappa)); - // } - // for(i = 0; i < full_size; i++){ - // Malpha2[i] = fem_full->doubles[full_size+i] + (fem_full->doubles[2*full_size+i])/(SQR(kappa)); - // } - // } else if(new_m_alpha > 1){ - // // for(i = 0; i < full_size; i++){ - // // Malpha[i] = fem_full->doubles[i] + new_m_alpha * (fem_full->doubles[full_size+i])/(SQR(kappa)); - // // for(j = 2; j <= new_m_alpha; j++){ - // // Malpha[i] += nChoosek(new_m_alpha, j) * (fem_full->doubles[j*full_size+i])/(pow(kappa, 2*j)); - // // } - - // // Malpha2[i] = fem_full->doubles[full_size+i] + new_m_alpha * (fem_full->doubles[2*full_size+i])/(SQR(kappa)); - // // for(j = 2; j <= new_m_alpha ; j++){ - // // Malpha2[i] += nChoosek(new_m_alpha, j) * (fem_full->doubles[(j+1)*full_size + i])/(pow(kappa,2*j)); - // // } - // // } - - // for(i = 0; i < full_size; i++){ - // Malpha[i] = fem_full->doubles[i] + new_m_alpha * (fem_full->doubles[full_size+i])/(SQR(kappa)); - // for(j = 2; j <= new_m_alpha; j++){ - // Malpha[i] += nChoosek(new_m_alpha, j) * (fem_full->doubles[j*full_size+i])/(pow(kappa, 2*j)); - // } - // } - // for(i = 0; i < full_size; i++){ - // Malpha2[i] = fem_full->doubles[full_size+i] + new_m_alpha * (fem_full->doubles[2*full_size+i])/(SQR(kappa)); - // for(j = 2; j <= new_m_alpha ; j++){ - // Malpha2[i] += nChoosek(new_m_alpha, j) * (fem_full->doubles[(j+1)*full_size + i])/(pow(kappa,2*j)); - // } - // } - // } - - // for(j = 0; j < rspde_order; j++){ - // for(i = 0; i < full_size; i++){ - // ret[k + j * full_size + i] = multQ * ( - // (1-p[j]) * Malpha[i] + (Malpha2[i])/(SQR(kappa)) - // )/(r[j]); - // } - // } - - // if(new_m_alpha == 1){ - - // for(i = 0; i < less_size; i++){ - // ret[k+rspde_order*full_size + i] = multQ/(k_rat) * ( - // fem_less->doubles[i] + (fem_less->doubles[less_size+i])/(SQR(kappa)) - // ); - // } - // } else{ - - // for(i = 0; i < less_size; i++){ - // ret[k+rspde_order*full_size + i] = multQ/(k_rat) * ( - // fem_less->doubles[i] + (new_m_alpha/SQR(kappa)) * fem_less->doubles[less_size+i] - // ); - // for(j = 2; j <= new_m_alpha ; j++){ - // ret[k+rspde_order*full_size + i] += multQ/(k_rat) * ( - // nChoosek(new_m_alpha,j)*(fem_less->doubles[i + j*less_size])/(pow(kappa,2*j)) - // ); - // } - // } - // } - - // } - - break; - } - - case INLA_CGENERIC_MU: - { - ret = Calloc(1, double); - ret[0] = 0.0; - break; - } - - case INLA_CGENERIC_INITIAL: - { - // return c(P, initials) - // where P is the number of hyperparameters - ret = Calloc(3, double); - ret[0] = 2; - ret[1] = start_theta->doubles[0]; - ret[2] = start_theta->doubles[1]; - break; - } - - case INLA_CGENERIC_LOG_NORM_CONST: - { - break; - } - - case INLA_CGENERIC_LOG_PRIOR: - { - ret = Calloc(1, double); - - ret[0] = 0.0; - - if(!strcasecmp(theta_param, "theta") || !strcasecmp(parameterization, "spde")){ - ret[0] += logmultnormvdens(2, theta_prior_mean->doubles, - theta_prior_prec->x, theta); - } - else { - double theta_prior_mean_spde[2], theta_spde[2]; - theta_spde[1] = lkappa; - theta_spde[0] = ltau; - theta_prior_mean_spde[1] = 0.5 * log(8.0 * nu) - theta_prior_mean->doubles[1]; - theta_prior_mean_spde[0] = - theta_prior_mean->doubles[0] + 0.5 *( - lgamma(nu) - 2.0 * nu * theta_prior_mean_spde[1] - - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) - ); - - ret[0] += logmultnormvdens(2, theta_prior_mean_spde, - theta_prior_prec->x, theta_spde); - } - break; - } - - case INLA_CGENERIC_QUIT: - default: - break; - } - - return (ret); -} \ No newline at end of file diff --git a/src/cgeneric_rspde_stat_general.c b/src/cgeneric_rspde_stat_general.c deleted file mode 100644 index b7b826fb..00000000 --- a/src/cgeneric_rspde_stat_general.c +++ /dev/null @@ -1,565 +0,0 @@ -#include "cgeneric_defs.h" -#include "stdio.h" -// #include "gsl/gsl_vector_double.h" - -double cut_decimals(double nu){ - double temp = nu - floor(nu); - if(temp < pow(10,-3)){ - temp = pow(10,-3); - } - if(temp > 0.999){ - temp = 0.999; - } - return temp; -} - -double pnorm(double x, double mu, double sd) -{ - return (1 + erf((x-mu) / (sd * sqrt(2.0))))/(2.0); -} - -double logdbeta(double x, double s_1, double s_2){ - double tmp = lgamma(s_1 + s_2) - lgamma(s_1) - lgamma(s_2); - tmp += (s_1-1)*log(x) + (s_2-1)*log(1-x); - return tmp; -} - -// This version uses 'padded' matrices with zeroes -double *inla_cgeneric_rspde_stat_general_model(inla_cgeneric_cmd_tp cmd, double *theta, inla_cgeneric_data_tp * data) { - - double *ret = NULL; - double ltau, lkappa, tau, kappa, lnu, nu; - double alpha, nu_upper_bound; - int m_alpha; - double prior_nu_mean, prior_nu_loglocation, prior_nu_prec; - double prior_nu_logscale; - double start_nu; - int N, M, i, k, j, rspde_order; - double d; - char *prior_nu_dist, *parameterization, *theta_param; - int full_size, less_size; - int one = 1; - - - assert(!strcasecmp(data->ints[0]->name, "n")); // this will always be the case - N = data->ints[0]->ints[0]; // this will always be the case - assert(N > 0); - - assert(!strcasecmp(data->ints[1]->name, "debug")); // this will always be the case - int debug = data->ints[1]->ints[0]; // this will always be the case - - if(debug == 1){ - debug = 1; - } - - assert(!strcasecmp(data->ints[2]->name, "graph_opt_i")); - inla_cgeneric_vec_tp *graph_i = data->ints[2]; - M = graph_i->len; - - assert(!strcasecmp(data->ints[3]->name, "graph_opt_j")); - inla_cgeneric_vec_tp *graph_j = data->ints[3]; - assert(M == graph_j->len); - - assert(!strcasecmp(data->ints[4]->name, "rspde.order")); - rspde_order = data->ints[4]->ints[0]; - - assert(!strcasecmp(data->chars[2]->name, "prior.nu.dist")); - prior_nu_dist = &data->chars[2]->chars[0]; - - assert(!strcasecmp(data->chars[4]->name, "prior.theta.param")); - theta_param = &data->chars[4]->chars[0]; - - assert(!strcasecmp(data->chars[3]->name, "parameterization")); - parameterization = &data->chars[3]->chars[0]; - - assert(!strcasecmp(data->doubles[0]->name, "d")); - d = data->doubles[0]->doubles[0]; - - assert(!strcasecmp(data->doubles[1]->name, "nu.upper.bound")); - nu_upper_bound = data->doubles[1]->doubles[0]; - - alpha = nu_upper_bound + d / 2.0; - m_alpha = floor(alpha); - - assert(!strcasecmp(data->doubles[2]->name, "matrices_less")); - inla_cgeneric_vec_tp *fem_less = data->doubles[2]; - - assert(!strcasecmp(data->doubles[3]->name, "matrices_full")); - inla_cgeneric_vec_tp *fem_full = data->doubles[3]; - full_size = (fem_full->len)/(m_alpha+2); - less_size = (fem_less->len)/(m_alpha+1); - assert(M == rspde_order * full_size + less_size); - - - assert(!strcasecmp(data->mats[0]->name, "rational_table")); - inla_cgeneric_mat_tp *rational_table = data->mats[0]; - assert(rational_table->nrow == 999); - - // prior parameters - assert(!strcasecmp(data->doubles[4]->name, "start.theta")); - inla_cgeneric_vec_tp *start_theta = data->doubles[4]; - - assert(!strcasecmp(data->doubles[5]->name, "theta.prior.mean")); - inla_cgeneric_vec_tp *theta_prior_mean = data->doubles[5]; - - assert(!strcasecmp(data->mats[1]->name, "theta.prior.prec")); - inla_cgeneric_mat_tp *theta_prior_prec = data->mats[1]; - - assert(!strcasecmp(data->doubles[6]->name, "prior.nu.loglocation")); - prior_nu_loglocation = data->doubles[6]->doubles[0]; - - assert(!strcasecmp(data->doubles[7]->name, "prior.nu.mean")); - prior_nu_mean = data->doubles[7]->doubles[0]; - - assert(!strcasecmp(data->doubles[8]->name, "prior.nu.prec")); - prior_nu_prec = data->doubles[8]->doubles[0]; - - assert(!strcasecmp(data->doubles[9]->name, "prior.nu.logscale")); - prior_nu_logscale = data->doubles[9]->doubles[0]; - - assert(!strcasecmp(data->doubles[10]->name, "start.nu")); - start_nu = data->doubles[10]->doubles[0]; - - if (theta) { - // interpretable parameters - lnu = theta[2]; - nu = (exp(lnu)/(1.0 + exp(lnu))) * nu_upper_bound; - if(!strcasecmp(parameterization, "matern")){ - lkappa = 0.5 * log(8.0 * nu) - theta[1]; - ltau = - theta[0] + 0.5 *( - lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) - ); - } else if(!strcasecmp(parameterization, "matern2")) { - lkappa = - theta[1]; - ltau = - 0.5 * theta[0] + 0.5 *( - lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) - ); - } else { - ltau = theta[0]; - lkappa = theta[1]; - } - tau = exp(ltau); - kappa = exp(lkappa); - } - else { - ltau = lkappa = lnu = tau = kappa = nu = NAN; - } - - switch (cmd) { - case INLA_CGENERIC_VOID: - { - assert(!(cmd == INLA_CGENERIC_VOID)); - break; - } - - case INLA_CGENERIC_GRAPH: - { - k=2; - ret = Calloc(k + 2 * M, double); - ret[0] = N; /* dimension */ - ret[1] = M; /* number of (i <= j) */ - for (i = 0; i < M; i++) { - ret[k++] = graph_i->ints[i]; - } - for (i = 0; i < M; i++) { - ret[k++] = graph_j->ints[i]; - } - break; - } - - case INLA_CGENERIC_Q: - { - k = 2; - ret = Calloc(k + M, double); - ret[0] = -1; /* REQUIRED */ - ret[1] = M; /* REQUIRED */ - - int n_terms = 2*rspde_order + 2; - - double new_alpha = nu + d / 2.0; - - int new_m_alpha = (int) floor(new_alpha); - - double multQ = pow(kappa, 2*new_alpha) * SQR(tau); - - int row_nu = (int)round(1000*cut_decimals(new_alpha))-1; - - double *rat_coef = Calloc(n_terms-1, double); - - rat_coef = &rational_table->x[row_nu*n_terms+1]; - - double *r, *p, k_rat; - - r = Calloc(rspde_order, double); - p = Calloc(rspde_order, double); - - r = &rat_coef[0]; - p = &rat_coef[rspde_order]; - k_rat = rat_coef[2*rspde_order]; - - // FORTRAN IMPLEMENTATION - - - - switch(new_m_alpha){ - case 0: - { - double fact_mult; - for(j = 0; j < rspde_order; j++){ - fact_mult = multQ * (1-p[j])/r[j]; - dcopy_(&full_size, &fem_full->doubles[0], &one, &ret[k + j*full_size], &one); - dscal_(&full_size, &fact_mult, &ret[k+ j*full_size], &one); - fact_mult = multQ / (r[j] * SQR(kappa)); - daxpy_(&full_size, &fact_mult, &fem_full->doubles[full_size], &one, &ret[k+j*full_size], &one); - } - // dcopy_(&less_size, &fem_less->doubles[0], &one, &ret[k+rspde_order * full_size], &one); - // fact_mult = multQ/k_rat; - // dscal_(&less_size, &fact_mult, &ret[k+rspde_order * full_size], &one); - for(i = 0; i < less_size; i++){ - if(fem_less->doubles[i] != 0){ - ret[k+rspde_order*full_size + i] = multQ * ( - 1/(k_rat * fem_less->doubles[i]) - ); - } - } - break; - } - case 1: - { - double *Malpha2, fact_mult; - Malpha2 = Calloc(full_size, double); - for(j = 0; j < rspde_order; j++){ - dcopy_(&full_size, &fem_full->doubles[0], &one, &ret[k+j*full_size], &one); - fact_mult = 1/SQR(kappa); - daxpy_(&full_size, &fact_mult, &fem_full->doubles[full_size], &one, &ret[k+j*full_size], &one); - fact_mult = multQ * (1-p[j])/r[j]; - dscal_(&full_size, &fact_mult, &ret[k+j*full_size], &one); - dcopy_(&full_size, &fem_full->doubles[full_size], &one, Malpha2, &one); - fact_mult = 1/SQR(kappa); - daxpy_(&full_size, &fact_mult, &fem_full->doubles[2*full_size], &one, Malpha2, &one); - fact_mult = multQ/(SQR(kappa) * r[j]); - daxpy_(&full_size, &fact_mult, Malpha2, &one, &ret[k + j*full_size], &one); - } - - free(Malpha2); - - dcopy_(&less_size, &fem_less->doubles[0], &one, &ret[k+rspde_order*full_size], &one); - fact_mult = multQ/k_rat; - dscal_(&less_size, &fact_mult, &ret[k+rspde_order*full_size], &one); - fact_mult = multQ/(k_rat * SQR(kappa)); - daxpy_(&less_size, &fact_mult, &fem_less->doubles[less_size], &one, &ret[k+rspde_order*full_size], &one); - break; - } - default: - { - double *Malpha2, fact_mult; - Malpha2 = Calloc(full_size, double); - for(j = 0; j < rspde_order; j++){ - dcopy_(&full_size, &fem_full->doubles[0],&one, &ret[k+j*full_size], &one); - fact_mult = new_m_alpha/SQR(kappa); - daxpy_(&full_size, &fact_mult, &fem_full->doubles[full_size], &one, &ret[k+j*full_size], &one); - for(i = 2; i<= new_m_alpha; i++){ - fact_mult = nChoosek(new_m_alpha, i)/(pow(kappa, 2*i)); - daxpy_(&full_size, &fact_mult, &fem_full->doubles[i*full_size], &one, &ret[k+j*full_size], &one); - } - fact_mult = multQ * (1-p[j])/r[j]; - dscal_(&full_size, &fact_mult, &ret[k+j*full_size], &one); - dcopy_(&full_size, &fem_full->doubles[full_size], &one, Malpha2, &one); - fact_mult = new_m_alpha/SQR(kappa); - daxpy_(&full_size, &fact_mult, &fem_full->doubles[2*full_size], &one, Malpha2, &one); - for(i = 2; i<= new_m_alpha; i++){ - fact_mult = nChoosek(new_m_alpha, i)/(pow(kappa, 2*i)); - daxpy_(&full_size, &fact_mult, &fem_full->doubles[(i+1)*full_size], &one, Malpha2, &one); - } - fact_mult = multQ/(SQR(kappa) * r[j]); - daxpy_(&full_size, &fact_mult, Malpha2, &one, &ret[k + j*full_size], &one); - } - - free(Malpha2); - - dcopy_(&less_size, &fem_less->doubles[0], &one, &ret[k+rspde_order*full_size], &one); - fact_mult = multQ/k_rat; - dscal_(&less_size, &fact_mult, &ret[k+rspde_order*full_size], &one); - fact_mult = multQ * new_m_alpha/(k_rat * SQR(kappa)); - daxpy_(&less_size, &fact_mult, &fem_less->doubles[less_size], &one, &ret[k+rspde_order*full_size], &one); - for(j = 2; j<= new_m_alpha; j++){ - fact_mult = multQ * nChoosek(new_m_alpha, j)/(k_rat * pow(SQR(kappa),j)); - daxpy_(&less_size, &fact_mult, &fem_less->doubles[j*less_size], &one, &ret[k+rspde_order*full_size], &one); - } - break; - } - } - - // GSL IMPLEMENTATION - - // gsl_vector * FEM1 = gsl_vector_calloc(full_size); // C, then G, G_2, etc. - // gsl_vector * FEM2 = gsl_vector_calloc(full_size); // G, then G_2, G_3, etc., then part to be returned - - - - // switch(new_m_alpha){ - // case 0: - // { - // dcopy_(&full_size, &fem_full->doubles[0], &one, &FEM1->data[0], &one); - // for(j = 0; j < rspde_order; j++){ - // dcopy_(&full_size, &fem_full->doubles[full_size], &one, &FEM2->data[0], &one); - // gsl_vector_axpby(multQ * (1-p[j])/r[j], FEM1, multQ / (r[j] * SQR(kappa)), FEM2); - // dcopy_(&full_size, &FEM2->data[0], &one, &ret[k + j*full_size], &one); - // } - // gsl_vector_free(FEM1); - // gsl_vector_free(FEM2); - // gsl_vector * FEM1 = gsl_vector_calloc(less_size); // C, then G, G_2, etc. - // dcopy_(&less_size, &fem_less->doubles[0], &one, &FEM1->data[0], &one); - // gsl_vector_scale(FEM1, multQ/k_rat); - // dcopy_(&less_size, &FEM1->data[0], &one, &ret[k + rspde_order * full_size], &one); - // gsl_vector_free(FEM1); - // break; - // } - // case 1: - // { - // dcopy_(&full_size, &fem_full->doubles[0], &one, &FEM1->data[0], &one); - // dcopy_(&full_size, &fem_full->doubles[full_size], &one, &FEM2->data[0], &one); - // gsl_vector_axpby(1/SQR(kappa), FEM2, 1, FEM1); // FEM1 = M_alpha - // gsl_vector * FEM3 = gsl_vector_calloc(full_size); - // dcopy_(&full_size, &fem_full->doubles[2 * full_size], &one, &FEM3->data[0], &one); - // gsl_vector_axpby(1/SQR(kappa), FEM3, 1, FEM2); // FEM2 = M_alpha2 - // gsl_vector_memcpy(FEM3, FEM2); - // for(j = 0; j < rspde_order; j++){ - // gsl_vector_axpby(multQ * (1-p[j])/r[j], FEM1, multQ/(SQR(kappa) * r[j]), FEM2); //FEM2 -> part of Q - // dcopy_(&full_size, &FEM2->data[0], &one, &ret[k + j*full_size], &one); - // gsl_vector_memcpy(FEM2, FEM3); - // } - // // Add k part - // gsl_vector_free(FEM1); - // gsl_vector_free(FEM2); - // gsl_vector_free(FEM3); - // gsl_vector * FEM1 = gsl_vector_calloc(less_size); - // gsl_vector * FEM2 = gsl_vector_calloc(less_size); - // dcopy_(&less_size, &fem_less->doubles[0], &one, &FEM1->data[0], &one); // copy C back to FEM1 - // dcopy_(&less_size, &fem_less->doubles[less_size], &one, &FEM2->data[0], &one); - // gsl_vector_axpby(multQ/(k_rat * SQR(kappa)), FEM2, multQ/k_rat, FEM1); - // dcopy_(&less_size, &FEM1->data[0], &one, &ret[k + rspde_order * full_size], &one); - // gsl_vector_free(FEM1); - // gsl_vector_free(FEM2); - // break; - // } - // default: - // { - // dcopy_(&full_size, &fem_full->doubles[0], &one, &FEM1->data[0], &one); - // gsl_vector * FEM3 = gsl_vector_calloc(full_size); - // dcopy_(&full_size, &fem_full->doubles[full_size], &one, &FEM2->data[0], &one); - // gsl_vector_axpby(new_m_alpha/SQR(kappa), FEM2, 1, FEM1); // FEM1 = M_alpha - // for(j = 2; j<= new_m_alpha; j++){ - // dcopy_(&full_size, &fem_full->doubles[j * full_size], &one, &FEM3->data[0], &one); - // gsl_vector_axpby(nChoosek(new_m_alpha, j)/(pow(kappa, 2*j)), FEM3, 1, FEM1); - // } - // dcopy_(&full_size, &fem_full->doubles[2 * full_size], &one, &FEM3->data[0], &one); - // gsl_vector_axpby(new_m_alpha/SQR(kappa), FEM3, 1, FEM2); // FEM2 = M_alpha2 - // for(j = 2; j<= new_m_alpha; j++){ - // dcopy_(&full_size, &fem_full->doubles[(j+1) * full_size], &one, &FEM3->data[0], &one); - // gsl_vector_axpby(nChoosek(new_m_alpha, j)/(pow(kappa,2*j)), FEM3, 1, FEM2); - // } - - - // gsl_vector_memcpy(FEM3, FEM2); - // for(j = 0; j < rspde_order; j++){ - // gsl_vector_axpby(multQ * (1-p[j])/r[j], FEM1, multQ/(SQR(kappa) * r[j]), FEM2); //FEM2 -> part of Q - // dcopy_(&full_size, &FEM2->data[0], &one, &ret[k + j*full_size], &one); - // gsl_vector_memcpy(FEM2, FEM3); - // } - // // Add k part - // gsl_vector_free(FEM1); - // gsl_vector_free(FEM2); - // gsl_vector_free(FEM3); - // gsl_vector * FEM1 = gsl_vector_calloc(less_size); - // gsl_vector * FEM2 = gsl_vector_calloc(less_size); - // dcopy_(&less_size, &fem_less->doubles[0], &one, &FEM1->data[0], &one); // copy C back to FEM1 - // dcopy_(&less_size, &fem_less->doubles[less_size], &one, &FEM2->data[0], &one); - // gsl_vector_axpby(multQ * new_m_alpha/(k_rat * SQR(kappa)), FEM2, multQ/k_rat, FEM1); - // for(j = 2; j<= new_m_alpha; j++){ - // dcopy_(&less_size, &fem_less->doubles[j * less_size], &one, &FEM2->data[0], &one); - // gsl_vector_axpby(multQ * nChoosek(new_m_alpha, j)/(k_rat * pow(SQR(kappa),j)), FEM2, 1, FEM1); - // } - // dcopy_(&less_size, &FEM1->data[0], &one, &ret[k + rspde_order * full_size], &one); - // gsl_vector_free(FEM1); - // gsl_vector_free(FEM2); - // break; - // } - // } - - // DIRECT C IMPLEMENTATION - - // double *Malpha, *Malpha2; - - - // // double multQ = pow(kappa, 2*new_alpha) * SQR(tau); - - // if(new_m_alpha == 0){ - // for(j = 0; j < rspde_order; j++){ - // for(i = 0; i < full_size; i++){ - // ret[k + j*full_size + i] = multQ * ( - // (fem_full->doubles[i] + (fem_full->doubles[full_size+i])/(SQR(kappa))) - - // (p[j] * fem_full->doubles[i]) - // ) / r[j]; - // } - // } - - // // Kpart - // for(i = 0; i < less_size; i++){ - // ret[k+rspde_order*full_size + i] = multQ * ( - // fem_less->doubles[i]/k_rat - // ); - // } - - // } else{ - - // Malpha = Calloc(full_size, double); - // Malpha2 = Calloc(full_size, double); - - // if(new_m_alpha == 1){ - // // for(i = 0; i < full_size; i++){ - // // Malpha[i] = fem_full->doubles[i] + (fem_full->doubles[full_size+i])/(SQR(kappa)); - // // Malpha2[i] = fem_full->doubles[full_size+i] + (fem_full->doubles[2*full_size+i])/(SQR(kappa)); - // // } - // for(i = 0; i < full_size; i++){ - // Malpha[i] = fem_full->doubles[i] + (fem_full->doubles[full_size+i])/(SQR(kappa)); - // } - // for(i = 0; i < full_size; i++){ - // Malpha2[i] = fem_full->doubles[full_size+i] + (fem_full->doubles[2*full_size+i])/(SQR(kappa)); - // } - // } else if(new_m_alpha > 1){ - // // for(i = 0; i < full_size; i++){ - // // Malpha[i] = fem_full->doubles[i] + new_m_alpha * (fem_full->doubles[full_size+i])/(SQR(kappa)); - // // for(j = 2; j <= new_m_alpha; j++){ - // // Malpha[i] += nChoosek(new_m_alpha, j) * (fem_full->doubles[j*full_size+i])/(pow(kappa, 2*j)); - // // } - - // // Malpha2[i] = fem_full->doubles[full_size+i] + new_m_alpha * (fem_full->doubles[2*full_size+i])/(SQR(kappa)); - // // for(j = 2; j <= new_m_alpha ; j++){ - // // Malpha2[i] += nChoosek(new_m_alpha, j) * (fem_full->doubles[(j+1)*full_size + i])/(pow(kappa,2*j)); - // // } - // // } - - // for(i = 0; i < full_size; i++){ - // Malpha[i] = fem_full->doubles[i] + new_m_alpha * (fem_full->doubles[full_size+i])/(SQR(kappa)); - // for(j = 2; j <= new_m_alpha; j++){ - // Malpha[i] += nChoosek(new_m_alpha, j) * (fem_full->doubles[j*full_size+i])/(pow(kappa, 2*j)); - // } - // } - // for(i = 0; i < full_size; i++){ - // Malpha2[i] = fem_full->doubles[full_size+i] + new_m_alpha * (fem_full->doubles[2*full_size+i])/(SQR(kappa)); - // for(j = 2; j <= new_m_alpha ; j++){ - // Malpha2[i] += nChoosek(new_m_alpha, j) * (fem_full->doubles[(j+1)*full_size + i])/(pow(kappa,2*j)); - // } - // } - // } - - // for(j = 0; j < rspde_order; j++){ - // for(i = 0; i < full_size; i++){ - // ret[k + j * full_size + i] = multQ * ( - // (1-p[j]) * Malpha[i] + (Malpha2[i])/(SQR(kappa)) - // )/(r[j]); - // } - // } - - // if(new_m_alpha == 1){ - - // for(i = 0; i < less_size; i++){ - // ret[k+rspde_order*full_size + i] = multQ/(k_rat) * ( - // fem_less->doubles[i] + (fem_less->doubles[less_size+i])/(SQR(kappa)) - // ); - // } - // } else{ - - // for(i = 0; i < less_size; i++){ - // ret[k+rspde_order*full_size + i] = multQ/(k_rat) * ( - // fem_less->doubles[i] + (new_m_alpha/SQR(kappa)) * fem_less->doubles[less_size+i] - // ); - // for(j = 2; j <= new_m_alpha ; j++){ - // ret[k+rspde_order*full_size + i] += multQ/(k_rat) * ( - // nChoosek(new_m_alpha,j)*(fem_less->doubles[i + j*less_size])/(pow(kappa,2*j)) - // ); - // } - // } - // } - - // } - - break; - } - - case INLA_CGENERIC_MU: - { - ret = Calloc(1, double); - ret[0] = 0.0; - break; - } - - case INLA_CGENERIC_INITIAL: - { - // return c(P, initials) - // where P is the number of hyperparameters - ret = Calloc(4, double); - ret[0] = 3; - ret[1] = start_theta->doubles[0]; - ret[2] = start_theta->doubles[1]; - ret[3] = log(start_nu/(nu_upper_bound - start_nu)); - break; - } - - case INLA_CGENERIC_LOG_NORM_CONST: - { - break; - } - - case INLA_CGENERIC_LOG_PRIOR: - { - ret = Calloc(1, double); - - ret[0] = 0.0; - - if(!strcasecmp(prior_nu_dist, "lognormal")){ - ret[0] += -0.5 * SQR(lnu - prior_nu_loglocation)/(SQR(prior_nu_logscale)); - ret[0] += -log(prior_nu_logscale) - 0.5 * log(2.0*M_PI); - ret[0] -= log(pnorm(log(nu_upper_bound), prior_nu_loglocation, prior_nu_logscale)); - } - else { // if(!strcasecmp(prior_nu_dist, "beta")){ - double s_1 = (prior_nu_mean / nu_upper_bound) * prior_nu_prec; - double s_2 = (1 - prior_nu_mean / nu_upper_bound) * prior_nu_prec; - ret[0] += logdbeta(nu / nu_upper_bound, s_1, s_2) - log(nu_upper_bound); - } - - if(!strcasecmp(theta_param, "theta") || !strcasecmp(parameterization, "spde")){ - ret[0] += logmultnormvdens(2, theta_prior_mean->doubles, - theta_prior_prec->x, theta); - } - else { - double theta_prior_mean_spde[2], theta_spde[2], prior_nu_tmp; - if(!strcasecmp(prior_nu_dist, "lognormal")){ - prior_nu_tmp = exp(prior_nu_loglocation); - } - else{ - prior_nu_tmp = prior_nu_mean; - } - theta_spde[1] = lkappa; - theta_spde[0] = ltau; - theta_prior_mean_spde[1] = 0.5 * log(8.0 * prior_nu_tmp) - theta_prior_mean->doubles[1]; - theta_prior_mean_spde[0] = - theta_prior_mean->doubles[0] + 0.5 *( - lgamma(prior_nu_tmp) - 2.0 * prior_nu_tmp * theta_prior_mean_spde[1] - - (d/2.0) * log(4 * M_PI) - lgamma(prior_nu_tmp + d/2.0) - ); - - ret[0] += logmultnormvdens(2, theta_prior_mean_spde, - theta_prior_prec->x, theta_spde); - } - - break; - } - - case INLA_CGENERIC_QUIT: - default: - break; - } - - return (ret); -} \ No newline at end of file diff --git a/src/cgeneric_rspde_stat_int.c b/src/cgeneric_rspde_stat_int.c deleted file mode 100644 index 1d5c9061..00000000 --- a/src/cgeneric_rspde_stat_int.c +++ /dev/null @@ -1,637 +0,0 @@ -#include "cgeneric_defs.h" -// #include "stdio.h" -// #include "gsl/gsl_vector_double.h" - -double nChoosek( int n, int k ){ - if (k > n) return 0; - if (k * 2 > n) k = n-k; - if (k == 0) return 1; - - int result = n; - for( int i = 2; i <= k; ++i ) { - result *= (n-i+1); - result /= i; - } - return (double) result; -} - -// This version uses 'padded' matrices with zeroes -double *inla_cgeneric_rspde_stat_int_model(inla_cgeneric_cmd_tp cmd, double *theta, inla_cgeneric_data_tp * data) { - - double *ret = NULL; - double ltau, lkappa, tau, kappa; - double nu; - char *parameterization, *theta_param; - - int N, M, i, k, j; - - assert(!strcasecmp(data->ints[0]->name, "n")); // this will always be the case - N = data->ints[0]->ints[0]; // this will always be the case - assert(N > 0); - - assert(!strcasecmp(data->ints[1]->name, "debug")); // this will always be the case - int debug = data->ints[1]->ints[0]; // this will always be the case - - if(debug == 1){ - debug = 1; - } - - assert(!strcasecmp(data->ints[2]->name, "m_alpha")); - int m_alpha = data->ints[2]->ints[0]; - - assert(!strcasecmp(data->ints[3]->name, "graph_opt_i")); - inla_cgeneric_vec_tp *graph_i = data->ints[3]; - M = graph_i->len; - - assert(!strcasecmp(data->ints[4]->name, "graph_opt_j")); - inla_cgeneric_vec_tp *graph_j = data->ints[4]; - assert(M == graph_j->len); - - assert(!strcasecmp(data->chars[2]->name, "parameterization")); - parameterization = &data->chars[2]->chars[0]; - - assert(!strcasecmp(data->chars[3]->name, "prior.theta.param")); - theta_param = &data->chars[3]->chars[0]; - - // assert(!strcasecmp(data->ints[5]->name, "positions_C")); - // inla_cgeneric_vec_tp *positions_C = data->ints[5]; - - // assert(!strcasecmp(data->ints[6]->name, "positions_G")); - // inla_cgeneric_vec_tp *positions_G = data->ints[6]; - - assert(!strcasecmp(data->doubles[0]->name, "matrices_less")); - inla_cgeneric_vec_tp *fem = data->doubles[0]; - assert(M*(m_alpha+1) == fem->len); - - // prior parameters - assert(!strcasecmp(data->doubles[1]->name, "theta.prior.mean")); - inla_cgeneric_vec_tp *theta_prior_mean = data->doubles[1]; - - assert(!strcasecmp(data->mats[0]->name, "theta.prior.prec")); - inla_cgeneric_mat_tp *theta_prior_prec = data->mats[0]; - - assert(!strcasecmp(data->doubles[2]->name, "start.theta")); - inla_cgeneric_vec_tp *start_theta = data->doubles[2]; - - assert(!strcasecmp(data->doubles[3]->name, "nu")); - nu = data->doubles[3]->doubles[0]; - - int d = (int) 2 * (m_alpha - nu); - - if (theta) { - // interpretable parameters - if(!strcasecmp(parameterization, "matern")){ - lkappa = 0.5 * log(8.0 * nu) - theta[1]; - ltau = - theta[0] + 0.5 *( - lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) - ); - } else if(!strcasecmp(parameterization, "matern2")) { - lkappa = - theta[1]; - ltau = - 0.5 * theta[0] + 0.5 *( - lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) - ); - } else { - ltau = theta[0]; - lkappa = theta[1]; - } - tau = exp(ltau); - kappa = exp(lkappa); - } - else { - ltau = lkappa = tau = kappa = NAN; - } - - switch (cmd) { - case INLA_CGENERIC_VOID: - { - assert(!(cmd == INLA_CGENERIC_VOID)); - break; - } - - case INLA_CGENERIC_GRAPH: - { - k=2; - ret = Calloc(k + 2 * M, double); - ret[0] = N; /* dimension */ - ret[1] = M; /* number of (i <= j) */ - for (i = 0; i < M; i++) { - ret[k++] = graph_i->ints[i]; - } - for (i = 0; i < M; i++) { - ret[k++] = graph_j->ints[i]; - } - break; - } - - case INLA_CGENERIC_Q: - { - k = 2; - ret = Calloc(k + M, double); - ret[0] = -1; /* REQUIRED */ - ret[1] = M; /* REQUIRED */ - - // int one = 1; - // gsl_vector * GC = gsl_vector_calloc (M); // First G then C - // gsl_vector * retG2 = gsl_vector_calloc (M); // first G2 then return - - // dcopy_(&M, &fem->doubles[2*M], &one, &retG2->data[0], &one); - // dcopy_(&M, &fem->doubles[M], &one, &GC->data[0], &one); - // gsl_vector_axpby(2*SQR(tau)*SQR(kappa), GC, SQR(tau), retG2); - // dcopy_(&M, &fem->doubles[0], &one, &GC->data[0], &one); - // gsl_vector_axpby(SQR(tau)*SQR(kappa*kappa), GC, 1, retG2); - // dcopy_(&M, &retG2->data[0], &one, &ret[k], &one); - - - // gsl_vector * retV = gsl_vector_calloc(M); - // gsl_vector_memcpy(retV, G2); - - // gsl_vector_axpby(2*SQR(tau)*SQR(kappa), G, SQR(tau), retV); - // gsl_vector_axpby(SQR(tau)*SQR(kappa*kappa), C, 1, retV); - // dcopy_(&M, &retV->data[0], &one, &ret[k], &one); - - - // dscal_(&M, &sqtau, &ret[k], &one); - // for(i = 0; i < positions_C->len; i++){ - // ret[k + positions_G->ints[i]-1] += 2*SQR(tau) * SQR(kappa) * fem->doubles[M+positions_G->ints[i]-1]; - // ret[k + positions_C->ints[i]-1] += SQR(tau) * SQR(kappa * kappa) * fem->doubles[positions_C->ints[i]-1]; - // } - // for(i = positions_C->len; ilen; i++){ - // ret[k + positions_G->ints[i]-1] += 2*SQR(tau) * SQR(kappa) * fem->doubles[M+positions_G->ints[i]-1]; - // } - - // Direct version: - - // if(m_alpha == 1){ - // for (i = 0; i < M; i++) { - // ret[k + i] = SQR(tau) * (SQR(kappa) * fem->doubles[i] + fem->doubles[M+i]); - // } - // } - // else if(m_alpha > 1){ - // for (i = 0; i < M; i++) { - // ret[k + i] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[i] + m_alpha * - // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[M+i]); - - // if(m_alpha>=2){ - // for(j = 0; j <= (m_alpha-2); j++){ - // ret[k + i] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(j+2)*M+i]); - // } - // } - - // } - // } - - // Currently the faster version: - - // if(m_alpha == 1){ - // for (i = 0; i < M; i++) { - // ret[k + i] = SQR(tau) * (SQR(kappa) * fem->doubles[2*i] + fem->doubles[2*i+1]); - // } - // } - // else if(m_alpha > 1){ - // int quot = M/4; - // int remainder = M%4; - // for (i = 0; i < quot; i++) { - // ret[k + 4*i] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (4*i)] + m_alpha * - // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (4*i) + 1]); - - // if(m_alpha>=2){ - // for(j = 0; j <= (m_alpha-2); j++){ - // ret[k + 4*i] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(4*i)+(j+2)]); - // } - // } - - // ret[k + 4*i+1] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (4*i+1)] + m_alpha * - // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (4*i+1) + 1]); - - // if(m_alpha>=2){ - // for(j = 0; j <= (m_alpha-2); j++){ - // ret[k + 4*i+1] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(4*i+1)+(j+2)]); - // } - // } - - // ret[k + 4*i + 2] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (4*i+2)] + m_alpha * - // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (4*i+2) + 1]); - - // if(m_alpha>=2){ - // for(j = 0; j <= (m_alpha-2); j++){ - // ret[k + 4*i + 2] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(4*i+2)+(j+2)]); - // } - // } - - // ret[k + 4*i + 3] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (4*i+3)] + m_alpha * - // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (4*i+3) + 1]); - - // if(m_alpha>=2){ - // for(j = 0; j <= (m_alpha-2); j++){ - // ret[k + 4*i + 3] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(4*i+3)+(j+2)]); - // } - // } - // } - - // if(remainder > 0){ - // for(i = 0; i < remainder; i++){ - // ret[k+4*quot + i] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (4*quot+i)] + m_alpha * - // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (4*quot+i)+1]); - // if(m_alpha>=2){ - // for(j = 0; j <= (m_alpha-2); j++){ - // ret[k + 4*quot + i] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(4*quot+i)+(j+2)]); - // } - // } - // } - // } - - // } - -// THE FASTEST!!! - - // if(m_alpha == 1){ - // for (i = 0; i < M; i++) { - // ret[k + i] = SQR(tau) * (SQR(kappa) * fem->doubles[2*i] + fem->doubles[2*i+1]); - // } - // } - // else if(m_alpha > 1){ - // int quot = M/3; - // int remainder = M%3; - // for (i = 0; i < quot; i++) { - // ret[k + 3*i] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (3*i)] + m_alpha * - // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (3*i) + 1]); - - // if(m_alpha>=2){ - // for(j = 0; j <= (m_alpha-2); j++){ - // ret[k + 3*i] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(3*i)+(j+2)]); - // } - // } - - // ret[k + 3*i+1] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (3*i+1)] + m_alpha * - // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (3*i+1) + 1]); - - // if(m_alpha>=2){ - // for(j = 0; j <= (m_alpha-2); j++){ - // ret[k + 3*i+1] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(3*i+1)+(j+2)]); - // } - // } - - // ret[k + 3*i + 2] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (3*i+2)] + m_alpha * - // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (3*i+2) + 1]); - - // if(m_alpha>=2){ - // for(j = 0; j <= (m_alpha-2); j++){ - // ret[k + 3*i + 2] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(3*i+2)+(j+2)]); - // } - // } - // } - // if(remainder > 0){ - // for(i = 0; i < remainder; i++){ - // ret[k+3*quot + i] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (3*quot+i)] + m_alpha * - // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (3*quot+i)+1]); - // if(m_alpha>=2){ - // for(j = 0; j <= (m_alpha-2); j++){ - // ret[k + 3*quot + i] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(3*quot+i)+(j+2)]); - // } - // } - // } - // } - - // } - - - // Testing other splits: - - // if(m_alpha == 1){ - // for (i = 0; i < M; i++) { - // ret[k + i] = SQR(tau) * (SQR(kappa) * fem->doubles[2*i] + fem->doubles[2*i+1]); - // } - // } - // else if(m_alpha > 1){ - // int quot = M/6; - // int remainder = M%6; - // for (i = 0; i < quot; i++) { - // ret[k + 6*i] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (6*i)] + m_alpha * - // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (6*i) + 1]); - - // if(m_alpha>=2){ - // for(j = 0; j <= (m_alpha-2); j++){ - // ret[k + 6*i] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(6*i)+(j+2)]); - // } - // } - - // ret[k + 6*i+1] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (6*i+1)] + m_alpha * - // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (6*i+1) + 1]); - - // if(m_alpha>=2){ - // for(j = 0; j <= (m_alpha-2); j++){ - // ret[k + 6*i+1] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(6*i+1)+(j+2)]); - // } - // } - - // ret[k + 6*i + 2] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (6*i+2)] + m_alpha * - // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (6*i+2) + 1]); - - // if(m_alpha>=2){ - // for(j = 0; j <= (m_alpha-2); j++){ - // ret[k + 6*i + 2] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(6*i+2)+(j+2)]); - // } - // } - - // ret[k + 6*i + 3] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (6*i+3)] + m_alpha * - // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (6*i+3) + 1]); - - // if(m_alpha>=2){ - // for(j = 0; j <= (m_alpha-2); j++){ - // ret[k + 6*i + 3] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(6*i+3)+(j+2)]); - // } - // } - - // ret[k + 6*i + 4] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (6*i+4)] + m_alpha * - // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (6*i+4) + 1]); - - // if(m_alpha>=2){ - // for(j = 0; j <= (m_alpha-2); j++){ - // ret[k + 6*i + 4] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(6*i+4)+(j+2)]); - // } - // } - - // ret[k + 6*i + 5] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (6*i+5)] + m_alpha * - // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (6*i+5) + 1]); - - // if(m_alpha>=2){ - // for(j = 0; j <= (m_alpha-2); j++){ - // ret[k + 6*i + 5] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(6*i+5)+(j+2)]); - // } - // } - // } - - // for(i = 0; i < remainder; i++){ - // ret[k+6*quot + i] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (6*quot+i)] + m_alpha * - // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (6*quot+i)+1]); - // if(m_alpha>=2){ - // for(j = 0; j <= (m_alpha-2); j++){ - // ret[k + 6*quot + i] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(6*quot+i)+(j+2)]); - // } - // } - // } - - // } - - - // // Fortran implementation - // double sqtau, sqtaukappa, sqtaukappatmp, sqkappatau1, sqkappatau2; - // int one=1; - // sqtau = SQR(tau); - // sqtaukappa = SQR(tau) * SQR(kappa); - // sqkappatau1 = SQR(tau) * SQR(kappa*kappa); - // sqkappatau2 = SQR(tau) * 2 * SQR(kappa); - // if(m_alpha == 1){ - // dcopy_(&M, &fem->doubles[0], &one, &ret[k], &one); - // dscal_(&M, &sqtaukappa, &ret[k], &one); - // daxpy_(&M, &sqtau, &fem->doubles[M], &one, &ret[k], &one); - // } else if (m_alpha == 2){ - // dcopy_(&M, &fem->doubles[0], &one, &ret[k], &one); - // dscal_(&M, &sqkappatau1, &ret[k], &one); - // daxpy_(&M, &sqkappatau2, &fem->doubles[M], &one, &ret[k], &one); - // daxpy_(&M, &sqtau, &fem->doubles[2*M], &one, &ret[k], &one); - // } else{ - // sqkappatau1 = SQR(tau) * pow(kappa, 2 * m_alpha); - // sqkappatau2 = SQR(tau) * m_alpha * pow(kappa, 2 * (m_alpha - 1)); - // dcopy_(&M, &fem->doubles[0], &one, &ret[k], &one); - // dscal_(&M, &sqkappatau1, &ret[k], &one); - // daxpy_(&M, &sqkappatau2, &fem->doubles[M], &one, &ret[k], &one); - // if(m_alpha>=2){ - // for(j = 2; j<= m_alpha; j++){ - // sqtaukappatmp = SQR(tau) * pow(kappa, 2*(m_alpha-j)) * nChoosek(m_alpha, j); - // daxpy_(&M, &sqtaukappatmp, &fem->doubles[j*M], &one, &ret[k], &one); - // } - // } - // } - - // More compact - int one = 1; - double sqkappatau1 = SQR(tau) * pow(kappa, 2 * m_alpha); - double sqkappatau2 = SQR(tau) * m_alpha * pow(kappa, 2 * (m_alpha - 1)); - double sqtaukappatmp; - dcopy_(&M, &fem->doubles[0], &one, &ret[k], &one); - dscal_(&M, &sqkappatau1, &ret[k], &one); - daxpy_(&M, &sqkappatau2, &fem->doubles[M], &one, &ret[k], &one); - if(m_alpha>=2){ - for(j = 2; j<= m_alpha; j++){ - sqtaukappatmp = SQR(tau) * pow(kappa, 2*(m_alpha-j)) * nChoosek(m_alpha, j); - daxpy_(&M, &sqtaukappatmp, &fem->doubles[j*M], &one, &ret[k], &one); - } - } - - // Fortran matrix product version - - // double sqtau, sqtaukappa, sqtaukappatmp, sqkappatau1, sqkappatau2; - // int one=1; - - // dcopy_(&M, &fem->doubles[0], &one, &ret[k], &one); - // if(m_alpha == 1){ - - // sqtau = SQR(tau); - // sqtaukappa = SQR(tau) * SQR(kappa); - // double *coeff_vec; - // coeff_vec = Calloc(2, double); - // coeff_vec[0] = sqtaukappa; - // coeff_vec[1] = sqtau; - - // int two = 2; - // double d_one = 1.0, d_zero = 0.0; - - // char char_tmp; - // char_tmp = 'T'; - - // dgemv_(&char_tmp, &two, &M, &d_one, &fem->doubles[0], &two, coeff_vec, &one, &d_zero, &ret[k], &one); - - - - // } else if (m_alpha == 2){ - - // sqtau = SQR(tau); - // sqkappatau1 = SQR(tau) * SQR(kappa*kappa); - // sqkappatau2 = SQR(tau) * 2.0 * SQR(kappa); - // double *coeff_vec; - // coeff_vec = Calloc(3, double); - // coeff_vec[0] = sqkappatau1; - // coeff_vec[1] = sqkappatau2; - // coeff_vec[2] = sqtau; - - // int three = 3; - // double d_one = 1.0, d_zero = 0.0; - - // char char_tmp; - // char_tmp = 'T'; - - // dgemv_(&char_tmp, &three, &M, &d_one, &fem->doubles[0], &three, coeff_vec, &one, &d_zero, &ret[k], &one); - - // } else{ - - // double sqkappatau1 = SQR(tau) * pow(kappa, 2 * m_alpha); - // double sqkappatau2 = SQR(tau) * m_alpha * pow(kappa, 2 * (m_alpha - 1)); - // double *coeff_vec; - // coeff_vec = Calloc(m_alpha+1, double); - // coeff_vec[0] = sqkappatau1; - // coeff_vec[1] = sqkappatau2; - - // if(m_alpha>=2){ - // for(j = 2; j<= m_alpha; j++){ - // sqtaukappatmp = SQR(tau) * pow(kappa, 2.0*(m_alpha-j)) * nChoosek(m_alpha, j); - // coeff_vec[j] = sqtaukappatmp; - // } - // } - - // int m_alpha_plus_one = m_alpha+1; - // double d_one = 1.0, d_zero = 0.0; - - // char char_tmp; - // char_tmp = 'T'; - - // dgemv_(&char_tmp, &m_alpha_plus_one, &M, &d_one, &fem->doubles[0], &m_alpha_plus_one, coeff_vec, &one, &d_zero, &ret[k], &one); - - // } - - // Version using sparsity - - // double sqtau = SQR(tau); - // int one=1; - // if(m_alpha == 1){ - // // int one=1; - // dcopy_(&M, &fem->doubles[0], &one, &ret[k], &one); - // dscal_(&M, &sqtau, &ret[k], &one); - // } else if (m_alpha == 2){ - // // int one=1; - // dcopy_(&M, &fem->doubles[2*M], &one, &ret[k], &one); - // dscal_(&M, &sqtau, &ret[k], &one); - // for(i = 0; i < positions_C->len; i++){ - // ret[k + positions_G->ints[i]-1] += 2*SQR(tau) * SQR(kappa) * fem->doubles[M+positions_G->ints[i]-1]; - // ret[k + positions_C->ints[i]-1] += SQR(tau) * SQR(kappa * kappa) * fem->doubles[positions_C->ints[i]-1]; - // } - // for(i = positions_C->len; ilen; i++){ - // ret[k + positions_G->ints[i]-1] += 2*SQR(tau) * SQR(kappa) * fem->doubles[M+positions_G->ints[i]-1]; - // } - - // } else{ - // // int one=1; - // } - - - - - - // switch(m_alpha){ - // double sqtau = SQR(tau); - // double sqtaukappa = SQR(tau) * SQR(kappa); - // double sqkappatau1 = SQR(tau) * SQR(kappa*kappa); - // double sqkappatau2 = SQR(tau) * 2 * SQR(kappa); - // double sqtaukappatmp; - // int one=1; - // dcopy_(&M, &fem->doubles[M], &one, &ret[k], &one); - // dscal_(&M, &sqtau, &ret[k], &one); - // daxpy_(&M, &sqtaukappa, &fem->doubles[0], &one, &ret[k], &one); - - // case 1: - // { - // dscal_(&M, &sqtaukappa, &ret[k], &one); - // daxpy_(&M, &sqtau, &fem->doubles[M], &one, &ret[k], &one); - // break; - // } case 2: - // { - // dscal_(&M, &sqkappatau1, &ret[k], &one); - // daxpy_(&M, &sqkappatau2, &fem->doubles[M], &one, &ret[k], &one); - // daxpy_(&M, &sqtau, &fem->doubles[2*M], &one, &ret[k], &one); - // break; - // } - // default: - // { - // dscal_(&M, &sqkappatau1, &ret[k], &one); - // daxpy_(&M, &sqkappatau2, &fem->doubles[M], &one, &ret[k], &one); - // if(m_alpha>=2){ - // for(j = 2; j<= m_alpha; j++){ - // sqkappatau1 = SQR(tau) * pow(kappa, 2 * m_alpha); - // sqkappatau2 = SQR(tau) * m_alpha * pow(kappa, 2 * (m_alpha - 1)); - // sqtaukappatmp = SQR(tau) * pow(kappa, 2*(m_alpha-j)) * nChoosek(m_alpha, j); - // daxpy_(&M, &sqtaukappatmp, &fem->doubles[j*M], &one, &ret[k], &one); - // } - // } - // break; - // } - // } - - - // if(m_alpha == 1){ - // double sqtau = SQR(tau); - // double sqtaukappa = SQR(tau) * SQR(kappa); - // int one=1; - // daxpby_(&M, &sqtaukappa, &fem->doubles[0], &one, &sqtau, &fem->doubles[M], &one, &ret[k]); - // } else { - // int one=1; - // double sqkappatau1 = SQR(tau) * pow(kappa, 2 * m_alpha); - // double sqkappatau2 = SQR(tau) * m_alpha * pow(kappa, 2 * (m_alpha - 1)); - // daxpby_(&M, &sqkappatau2, &fem->doubles[M], &one ,&sqkappatau1, &fem->doubles[0], &one, &ret[k]); - // if(m_alpha>=2){ - // for(j = 0; j<= (m_alpha-2); j++){ - // double sqtaukappatmp = SQR(tau) * pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2); - // daxpy_(&M, &sqtaukappatmp, &fem->doubles[(j+2)*M], &one, &ret[k], &one); - // } - // } - // } - - break; - } - - case INLA_CGENERIC_MU: - { - ret = Calloc(1, double); - ret[0] = 0.0; - break; - } - - case INLA_CGENERIC_INITIAL: - { - // return c(P, initials) - // where P is the number of hyperparameters - ret = Calloc(3, double); - ret[0] = 2; - ret[1] = start_theta->doubles[0]; - ret[2] = start_theta->doubles[1]; - break; - } - - case INLA_CGENERIC_LOG_NORM_CONST: - { - break; - } - - case INLA_CGENERIC_LOG_PRIOR: - { - ret = Calloc(1, double); - - ret[0] = 0.0; - - if(!strcasecmp(theta_param, "theta") || !strcasecmp(parameterization, "spde")){ - ret[0] += logmultnormvdens(2, theta_prior_mean->doubles, - theta_prior_prec->x, theta); - } - else { - double theta_prior_mean_spde[2], theta_spde[2]; - theta_spde[1] = lkappa; - theta_spde[0] = ltau; - theta_prior_mean_spde[1] = 0.5 * log(8.0 * nu) - theta_prior_mean->doubles[1]; - theta_prior_mean_spde[0] = - theta_prior_mean->doubles[0] + 0.5 *( - lgamma(nu) - 2.0 * nu * theta_prior_mean_spde[1] - - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) - ); - - ret[0] += logmultnormvdens(2, theta_prior_mean_spde, - theta_prior_prec->x, theta_spde); - } - - break; - } - - case INLA_CGENERIC_QUIT: - default: - break; - } - - return (ret); -} \ No newline at end of file diff --git a/src/cgeneric_rspde_stat_parsim_fixed.c b/src/cgeneric_rspde_stat_parsim_fixed.c deleted file mode 100644 index 6b4c806d..00000000 --- a/src/cgeneric_rspde_stat_parsim_fixed.c +++ /dev/null @@ -1,196 +0,0 @@ - -#include "cgeneric_defs.h" -#include - - -// This version uses 'padded' matrices with zeroes -double *inla_cgeneric_rspde_stat_parsim_fixed_model(inla_cgeneric_cmd_tp cmd, double *theta, inla_cgeneric_data_tp * data) { - double *ret = NULL; - double ltau, lkappa, tau, kappa, nu; - double alpha; - int m_alpha; - int N, M, i, k; - double d; - char *parameterization, *theta_param; - int fem_size; - int one = 1; - - assert(!strcasecmp(data->ints[0]->name, "n")); // this will always be the case - N = data->ints[0]->ints[0]; // this will always be the case - assert(N > 0); - - assert(!strcasecmp(data->ints[1]->name, "debug")); // this will always be the case - int debug = data->ints[1]->ints[0]; // this will always be the case - - if(debug == 1){ - debug = 1; - } - - assert(!strcasecmp(data->ints[2]->name, "graph_opt_i")); - inla_cgeneric_vec_tp *graph_i = data->ints[2]; - M = graph_i->len; - - assert(!strcasecmp(data->ints[3]->name, "graph_opt_j")); - inla_cgeneric_vec_tp *graph_j = data->ints[3]; - assert(M == graph_j->len); - - assert(!strcasecmp(data->chars[2]->name, "parameterization")); - parameterization = &data->chars[2]->chars[0]; - - assert(!strcasecmp(data->chars[3]->name, "prior.theta.param")); - theta_param = &data->chars[3]->chars[0]; - - assert(!strcasecmp(data->doubles[0]->name, "d")); - d = data->doubles[0]->doubles[0]; - - assert(!strcasecmp(data->doubles[1]->name, "nu")); - nu = data->doubles[1]->doubles[0]; - - alpha = nu + d / 2.0; - m_alpha = (int) floor(alpha); - - assert(!strcasecmp(data->doubles[2]->name, "matrices_full")); - inla_cgeneric_vec_tp *fem = data->doubles[2]; - - fem_size = (fem->len)/(m_alpha+2); - assert(M == fem_size); - - // prior parameters - assert(!strcasecmp(data->doubles[3]->name, "theta.prior.mean")); - inla_cgeneric_vec_tp *theta_prior_mean = data->doubles[3]; - - assert(!strcasecmp(data->mats[0]->name, "theta.prior.prec")); - inla_cgeneric_mat_tp *theta_prior_prec = data->mats[0]; - - assert(!strcasecmp(data->doubles[4]->name, "start.theta")); - inla_cgeneric_vec_tp *start_theta = data->doubles[4]; - - if (theta) { - // interpretable parameters - if(!strcasecmp(parameterization, "matern")){ - lkappa = 0.5 * log(8.0 * nu) - theta[1]; - ltau = - theta[0] + 0.5 *( - lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) - ); - } else if(!strcasecmp(parameterization, "matern2")) { - lkappa = - theta[1]; - ltau = - 0.5 * theta[0] + 0.5 *( - lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) - ); - } else { - ltau = theta[0]; - lkappa = theta[1]; - } - tau = exp(ltau); - kappa = exp(lkappa); - - } - else { - ltau = lkappa = tau = kappa = NAN; - } - - switch (cmd) { - case INLA_CGENERIC_VOID: - { - assert(!(cmd == INLA_CGENERIC_VOID)); - break; - } - - case INLA_CGENERIC_GRAPH: - { - k=2; - ret = Calloc(k + 2 * M, double); - ret[0] = N; /* dimension */ - ret[1] = M; /* number of (i <= j) */ - for (i = 0; i < M; i++) { - ret[k++] = graph_i->ints[i]; - } - for (i = 0; i < M; i++) { - ret[k++] = graph_j->ints[i]; - } - break; - } - - case INLA_CGENERIC_Q: - { - k = 2; - ret = Calloc(k + M, double); - ret[0] = -1; /* REQUIRED */ - ret[1] = M; /* REQUIRED */ - - - double *coeff; - - coeff = Calloc(m_alpha+2, double); - - coeff = markov_approx_coeff(alpha/2.0, kappa, (int)d); - - // FORTRAN IMPLEMENTATION - - dcopy_(&M, &fem->doubles[0], &one, &ret[k], &one); - coeff[0] = coeff[0] * SQR(tau); - dscal_(&M, &coeff[0], &ret[k], &one); - - for(i = 1; i < m_alpha + 2; i++){ - coeff[i] = coeff[i] * SQR(tau); - daxpy_(&M, &coeff[i], &fem->doubles[i*M], &one, &ret[k], &one); - } - break; - } - - case INLA_CGENERIC_MU: - { - ret = Calloc(1, double); - ret[0] = 0.0; - break; - } - - case INLA_CGENERIC_INITIAL: - { - // return c(P, initials) - // where P is the number of hyperparameters - ret = Calloc(3, double); - ret[0] = 2; - ret[1] = start_theta->doubles[0]; - ret[2] = start_theta->doubles[1]; - break; - } - - case INLA_CGENERIC_LOG_NORM_CONST: - { - break; - } - - case INLA_CGENERIC_LOG_PRIOR: - { - ret = Calloc(1, double); - - ret[0] = 0.0; - - if(!strcasecmp(theta_param, "theta") || !strcasecmp(parameterization, "spde")){ - ret[0] += logmultnormvdens(2, theta_prior_mean->doubles, - theta_prior_prec->x, theta); - } - else { - double theta_prior_mean_spde[2], theta_spde[2]; - theta_spde[1] = lkappa; - theta_spde[0] = ltau; - theta_prior_mean_spde[1] = 0.5 * log(8.0 * nu) - theta_prior_mean->doubles[1]; - theta_prior_mean_spde[0] = - theta_prior_mean->doubles[0] + 0.5 *( - lgamma(nu) - 2.0 * nu * theta_prior_mean_spde[1] - - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) - ); - - ret[0] += logmultnormvdens(2, theta_prior_mean_spde, - theta_prior_prec->x, theta_spde); - } - break; - } - - case INLA_CGENERIC_QUIT: - default: - break; - } - - return (ret); -} \ No newline at end of file diff --git a/src/cgeneric_rspde_stat_parsim_gen.c b/src/cgeneric_rspde_stat_parsim_gen.c deleted file mode 100644 index 3d100e09..00000000 --- a/src/cgeneric_rspde_stat_parsim_gen.c +++ /dev/null @@ -1,347 +0,0 @@ -#include "cgeneric_defs.h" -// #include - -// Creates a diagonal matrix with the elements of the vector as diagonal entries -void diag(double *vec_long, double *vec_short, int n){ //n = size of vec_short - int nplusone = n+1, one = 1; - dcopy_(&n, vec_short, &one, vec_long, &nplusone); -} - -// Mat should be given by column! -int solveAb(double *mat, double *vec, int size){ // compute A^{-1}b, where b is a vector - int one=1; - int ipivot[size]; - int info; - dgesv_(&size, &one, mat, &size, ipivot, vec, &size, &info); - return(info); -} - -//Get diagonal of a square matrix -// n is the size (number of columns) of the matrix -void getDiag(double *mat, double *destvec, int n){ - int nplusone = n+1, one = 1; - dcopy_(&n, mat, &nplusone, destvec, &one); -} - -// Computes solve(solve(diag(sqrt(diag(B))),B),solve(diag(sqrt(diag(B))),c)) -// This will also change the matrix mat (but for our application there is no problem)! -int CrazySolve(double *mat, double *in_out_vec, int size){ - double *tmp_vec, *tmp_mat; - int i, ipivot[size]; - tmp_vec = Calloc(size, double); - int info; - getDiag(mat, tmp_vec, size); - for(i = 0; i < size; i++){ - tmp_vec[i] = sqrt(tmp_vec[i]); - } - tmp_mat = Calloc(size*size, double); - diag(tmp_mat, tmp_vec, size); - solveAb(tmp_mat, in_out_vec, size); - - dgesv_(&size, &size, tmp_mat, &size, ipivot, mat, &size, &info); - - solveAb(mat, in_out_vec, size); - - free(tmp_vec); - free(tmp_mat); - return(info); -} - -double kappa_integral(int n, double beta, double kappa){ - double y; - int k; - y = 0; - for(k = 0; k <= n; k++){ - y += (2*(k%2) - 1) * nChoosek(n,k)/(n-k-beta+1); - } - return(y*pow(kappa, 2*(n-beta+1))); -} - -double * markov_approx_coeff(double beta, double kappa, int d){ - double nu = 2*beta - d/2.0; - double alpha = nu + d/2.0; - double L = alpha - floor(alpha); - int p = (int)ceil(alpha); - int i,j; - double *Bmat; - Bmat = Calloc( SQR(p+1), double); - double *c_vec; - c_vec = Calloc(p+1, double); - for(i = 0; i <= p; i++){ - c_vec[i] = 1.0; - } - for (i = 0; i <= p; i++){ - c_vec[i] = 2*kappa_integral(i,-alpha+2.0*p+1.0+L,kappa); - for (j = 0; j <= p; j++){ - Bmat[j+i*(p+1)] = 2*kappa_integral(i+j,2.0*p+1.0+L,kappa); - } - } - int info; - info = CrazySolve(Bmat, c_vec, p+1); - assert(info == 0); - // double fact = exp(lgamma(nu))/(signgam*exp(lgamma(alpha))*pow((4.0*M_PI),d/2.0)*pow(kappa,(2*nu))); - // for(i = 0; i <= p; i++){ - // c_vec[i] *= fact; - // } - return(c_vec); -} - - -double *inla_cgeneric_rspde_stat_parsim_gen_model(inla_cgeneric_cmd_tp cmd, double *theta, inla_cgeneric_data_tp * data) { - - double *ret = NULL; - double ltau, lkappa, tau, kappa, lnu, nu; - double alpha, nu_upper_bound; - int m_alpha; - double prior_nu_mean, prior_nu_loglocation, prior_nu_prec; - double prior_nu_logscale; - double start_nu; - int N, M, i, k, j; - double d; - char *prior_nu_dist, *parameterization, *theta_param; - int fem_size; - int one = 1; -// double *coeff; - - - assert(!strcasecmp(data->ints[0]->name, "n")); // this will always be the case - N = data->ints[0]->ints[0]; // this will always be the case - assert(N > 0); - - assert(!strcasecmp(data->ints[1]->name, "debug")); // this will always be the case - int debug = data->ints[1]->ints[0]; // this will always be the case - - if(debug == 1){ - debug = 1; - } - - assert(!strcasecmp(data->ints[2]->name, "graph_opt_i")); - inla_cgeneric_vec_tp *graph_i = data->ints[2]; - M = graph_i->len; - - assert(!strcasecmp(data->ints[3]->name, "graph_opt_j")); - inla_cgeneric_vec_tp *graph_j = data->ints[3]; - assert(M == graph_j->len); - - assert(!strcasecmp(data->chars[2]->name, "prior.nu.dist")); - prior_nu_dist = &data->chars[2]->chars[0]; - - assert(!strcasecmp(data->chars[3]->name, "parameterization")); - parameterization = &data->chars[3]->chars[0]; - - assert(!strcasecmp(data->chars[4]->name, "prior.theta.param")); - theta_param = &data->chars[4]->chars[0]; - - assert(!strcasecmp(data->doubles[0]->name, "d")); - d = data->doubles[0]->doubles[0]; - - assert(!strcasecmp(data->doubles[1]->name, "nu.upper.bound")); - nu_upper_bound = data->doubles[1]->doubles[0]; - - alpha = nu_upper_bound + d / 2.0; - m_alpha = floor(alpha); - - assert(!strcasecmp(data->doubles[2]->name, "matrices_full")); - inla_cgeneric_vec_tp *fem = data->doubles[2]; - - fem_size = (fem->len)/(m_alpha+2); - assert(M == fem_size); - - // prior parameters - - assert(!strcasecmp(data->doubles[3]->name, "theta.prior.mean")); - inla_cgeneric_vec_tp *theta_prior_mean = data->doubles[3]; - - assert(!strcasecmp(data->mats[0]->name, "theta.prior.prec")); - inla_cgeneric_mat_tp *theta_prior_prec = data->mats[0]; - - assert(!strcasecmp(data->doubles[4]->name, "prior.nu.loglocation")); - prior_nu_loglocation = data->doubles[4]->doubles[0]; - - assert(!strcasecmp(data->doubles[5]->name, "prior.nu.mean")); - prior_nu_mean = data->doubles[5]->doubles[0]; - - assert(!strcasecmp(data->doubles[6]->name, "prior.nu.prec")); - prior_nu_prec = data->doubles[6]->doubles[0]; - - assert(!strcasecmp(data->doubles[7]->name, "prior.nu.logscale")); - prior_nu_logscale = data->doubles[7]->doubles[0]; - - assert(!strcasecmp(data->doubles[8]->name, "start.theta")); - inla_cgeneric_vec_tp *start_theta = data->doubles[8]; - - assert(!strcasecmp(data->doubles[9]->name, "start.nu")); - start_nu = data->doubles[9]->doubles[0]; - - if (theta) { - // interpretable parameters - lnu = theta[2]; - nu = (exp(lnu)/(1.0 + exp(lnu))) * nu_upper_bound; - if(!strcasecmp(parameterization, "matern")){ - lkappa = 0.5 * log(8.0 * nu) - theta[1]; - ltau = - theta[0] + 0.5 *( - lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) - ); - } else if(!strcasecmp(parameterization, "matern2")) { - lkappa = - theta[1]; - ltau = - 0.5 * theta[0] + 0.5 *( - lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) - ); - } else { - ltau = theta[0]; - lkappa = theta[1]; - } - tau = exp(ltau); - kappa = exp(lkappa); - } - else { - ltau = lkappa = lnu = tau = kappa = nu = NAN; - } - - switch (cmd) { - case INLA_CGENERIC_VOID: - { - assert(!(cmd == INLA_CGENERIC_VOID)); - break; - } - - case INLA_CGENERIC_GRAPH: - { - k=2; - ret = Calloc(k + 2 * M, double); - ret[0] = N; /* dimension */ - ret[1] = M; /* number of (i <= j) */ - for (i = 0; i < M; i++) { - ret[k++] = graph_i->ints[i]; - } - for (i = 0; i < M; i++) { - ret[k++] = graph_j->ints[i]; - } - break; - } - - case INLA_CGENERIC_Q: - { - k = 2; - ret = Calloc(k + M, double); - ret[0] = -1; /* REQUIRED */ - ret[1] = M; /* REQUIRED */ - - double new_alpha = nu + d / 2.0; - int new_m_alpha = (int) floor(new_alpha); - - if(new_alpha / 2.0 == (int) new_alpha/2.0){ - double sqkappatau1 = SQR(tau) * pow(kappa, 2 * new_m_alpha); - double sqkappatau2 = SQR(tau) * new_m_alpha * pow(kappa, 2 * (new_m_alpha - 1)); - double sqtaukappatmp; - dcopy_(&M, &fem->doubles[0], &one, &ret[k], &one); - dscal_(&M, &sqkappatau1, &ret[k], &one); - daxpy_(&M, &sqkappatau2, &fem->doubles[M], &one, &ret[k], &one); - if(new_m_alpha>=2){ - for(j = 2; j<= new_m_alpha; j++){ - sqtaukappatmp = SQR(tau) * pow(kappa, 2*(new_m_alpha-j)) * nChoosek(new_m_alpha, j); - daxpy_(&M, &sqtaukappatmp, &fem->doubles[j*M], &one, &ret[k], &one); - } - } - } else { - - double *coeff; - - coeff = Calloc(new_m_alpha+2, double); - - coeff = markov_approx_coeff(new_alpha/2.0, kappa, (int)d); - - for(i = 0; i < new_m_alpha + 2; i++){ - coeff[i] *= SQR(tau); - } - - // FORTRAN IMPLEMENTATION - - dcopy_(&M, &fem->doubles[0], &one, &ret[k], &one); - dscal_(&M, &coeff[0], &ret[k], &one); - - for(i = 1; i < new_m_alpha + 2; i++){ - daxpy_(&M, &coeff[i], &fem->doubles[i*M], &one, &ret[k], &one); - } - // free(coeff); - } - - - break; - } - - case INLA_CGENERIC_MU: - { - ret = Calloc(1, double); - ret[0] = 0.0; - break; - } - - case INLA_CGENERIC_INITIAL: - { - // return c(P, initials) - // where P is the number of hyperparameters - ret = Calloc(4, double); - ret[0] = 3; - ret[1] = start_theta->doubles[0]; - ret[2] = start_theta->doubles[1]; - ret[3] = log(start_nu/(nu_upper_bound - start_nu)); - break; - } - - case INLA_CGENERIC_LOG_NORM_CONST: - { - break; - } - - case INLA_CGENERIC_LOG_PRIOR: - { - ret = Calloc(1, double); - - ret[0] = 0.0; - - if(!strcasecmp(prior_nu_dist, "lognormal")){ - ret[0] += -0.5 * SQR(lnu - prior_nu_loglocation)/(SQR(prior_nu_logscale)); - ret[0] += -log(prior_nu_logscale) - 0.5 * log(2.0*M_PI); - ret[0] -= log(pnorm(log(nu_upper_bound), prior_nu_loglocation, prior_nu_logscale)); - } - else { // if(!strcasecmp(prior_nu_dist, "beta")){ - double s_1 = (prior_nu_mean / nu_upper_bound) * prior_nu_prec; - double s_2 = (1 - prior_nu_mean / nu_upper_bound) * prior_nu_prec; - ret[0] += logdbeta(nu / nu_upper_bound, s_1, s_2) - log(nu_upper_bound); - } - - if(!strcasecmp(theta_param, "theta") || !strcasecmp(parameterization, "spde")){ - ret[0] += logmultnormvdens(2, theta_prior_mean->doubles, - theta_prior_prec->x, theta); - } - else { - double theta_prior_mean_spde[2], theta_spde[2], prior_nu_tmp; - if(!strcasecmp(prior_nu_dist, "lognormal")){ - prior_nu_tmp = exp(prior_nu_loglocation); - } - else{ - prior_nu_tmp = prior_nu_mean; - } - theta_spde[1] = lkappa; - theta_spde[0] = ltau; - theta_prior_mean_spde[1] = 0.5 * log(8.0 * prior_nu_tmp) - theta_prior_mean->doubles[1]; - theta_prior_mean_spde[0] = - theta_prior_mean->doubles[0] + 0.5 *( - lgamma(prior_nu_tmp) - 2.0 * prior_nu_tmp * theta_prior_mean_spde[1] - - (d/2.0) * log(4 * M_PI) - lgamma(prior_nu_tmp + d/2.0) - ); - - ret[0] += logmultnormvdens(2, theta_prior_mean_spde, - theta_prior_prec->x, theta_spde); - } - - break; - } - - case INLA_CGENERIC_QUIT: - default: - break; - } - - return (ret); -} \ No newline at end of file diff --git a/src/omp.h b/src/omp.h deleted file mode 100644 index f2e6345d..00000000 --- a/src/omp.h +++ /dev/null @@ -1,504 +0,0 @@ -/* - * include/omp.h.var - */ - - -//===----------------------------------------------------------------------===// -// -// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -// See https://llvm.org/LICENSE.txt for license information. -// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -// -//===----------------------------------------------------------------------===// - - -#ifndef __OMP_H -# define __OMP_H - -# include -# include - -# define KMP_VERSION_MAJOR 5 -# define KMP_VERSION_MINOR 0 -# define KMP_VERSION_BUILD 20140926 -# define KMP_BUILD_DATE "No_Timestamp" - -# ifdef __cplusplus - extern "C" { -# endif - -# define omp_set_affinity_format ompc_set_affinity_format -# define omp_get_affinity_format ompc_get_affinity_format -# define omp_display_affinity ompc_display_affinity -# define omp_capture_affinity ompc_capture_affinity - -# if defined(_WIN32) -# define __KAI_KMPC_CONVENTION __cdecl -# ifndef __KMP_IMP -# define __KMP_IMP __declspec(dllimport) -# endif -# else -# define __KAI_KMPC_CONVENTION -# ifndef __KMP_IMP -# define __KMP_IMP -# endif -# endif - - /* schedule kind constants */ - typedef enum omp_sched_t { - omp_sched_static = 1, - omp_sched_dynamic = 2, - omp_sched_guided = 3, - omp_sched_auto = 4, - omp_sched_monotonic = 0x80000000 - } omp_sched_t; - - /* set API functions */ - extern void __KAI_KMPC_CONVENTION omp_set_num_threads (int); - extern void __KAI_KMPC_CONVENTION omp_set_dynamic (int); - extern void __KAI_KMPC_CONVENTION omp_set_nested (int); - extern void __KAI_KMPC_CONVENTION omp_set_max_active_levels (int); - extern void __KAI_KMPC_CONVENTION omp_set_schedule (omp_sched_t, int); - - /* query API functions */ - extern int __KAI_KMPC_CONVENTION omp_get_num_threads (void); - extern int __KAI_KMPC_CONVENTION omp_get_dynamic (void); - extern int __KAI_KMPC_CONVENTION omp_get_nested (void); - extern int __KAI_KMPC_CONVENTION omp_get_max_threads (void); - extern int __KAI_KMPC_CONVENTION omp_get_thread_num (void); - extern int __KAI_KMPC_CONVENTION omp_get_num_procs (void); - extern int __KAI_KMPC_CONVENTION omp_in_parallel (void); - extern int __KAI_KMPC_CONVENTION omp_in_final (void); - extern int __KAI_KMPC_CONVENTION omp_get_active_level (void); - extern int __KAI_KMPC_CONVENTION omp_get_level (void); - extern int __KAI_KMPC_CONVENTION omp_get_ancestor_thread_num (int); - extern int __KAI_KMPC_CONVENTION omp_get_team_size (int); - extern int __KAI_KMPC_CONVENTION omp_get_thread_limit (void); - extern int __KAI_KMPC_CONVENTION omp_get_max_active_levels (void); - extern void __KAI_KMPC_CONVENTION omp_get_schedule (omp_sched_t *, int *); - extern int __KAI_KMPC_CONVENTION omp_get_max_task_priority (void); - - /* lock API functions */ - typedef struct omp_lock_t { - void * _lk; - } omp_lock_t; - - extern void __KAI_KMPC_CONVENTION omp_init_lock (omp_lock_t *); - extern void __KAI_KMPC_CONVENTION omp_set_lock (omp_lock_t *); - extern void __KAI_KMPC_CONVENTION omp_unset_lock (omp_lock_t *); - extern void __KAI_KMPC_CONVENTION omp_destroy_lock (omp_lock_t *); - extern int __KAI_KMPC_CONVENTION omp_test_lock (omp_lock_t *); - - /* nested lock API functions */ - typedef struct omp_nest_lock_t { - void * _lk; - } omp_nest_lock_t; - - extern void __KAI_KMPC_CONVENTION omp_init_nest_lock (omp_nest_lock_t *); - extern void __KAI_KMPC_CONVENTION omp_set_nest_lock (omp_nest_lock_t *); - extern void __KAI_KMPC_CONVENTION omp_unset_nest_lock (omp_nest_lock_t *); - extern void __KAI_KMPC_CONVENTION omp_destroy_nest_lock (omp_nest_lock_t *); - extern int __KAI_KMPC_CONVENTION omp_test_nest_lock (omp_nest_lock_t *); - - /* OpenMP 5.0 Synchronization hints*/ - typedef enum omp_sync_hint_t { - omp_sync_hint_none = 0, - omp_lock_hint_none = omp_sync_hint_none, - omp_sync_hint_uncontended = 1, - omp_lock_hint_uncontended = omp_sync_hint_uncontended, - omp_sync_hint_contended = (1<<1), - omp_lock_hint_contended = omp_sync_hint_contended, - omp_sync_hint_nonspeculative = (1<<2), - omp_lock_hint_nonspeculative = omp_sync_hint_nonspeculative, - omp_sync_hint_speculative = (1<<3), - omp_lock_hint_speculative = omp_sync_hint_speculative, - kmp_lock_hint_hle = (1<<16), - kmp_lock_hint_rtm = (1<<17), - kmp_lock_hint_adaptive = (1<<18) - } omp_sync_hint_t; - - /* lock hint type for dynamic user lock */ - typedef omp_sync_hint_t omp_lock_hint_t; - - /* hinted lock initializers */ - extern void __KAI_KMPC_CONVENTION omp_init_lock_with_hint(omp_lock_t *, omp_lock_hint_t); - extern void __KAI_KMPC_CONVENTION omp_init_nest_lock_with_hint(omp_nest_lock_t *, omp_lock_hint_t); - - /* time API functions */ - extern double __KAI_KMPC_CONVENTION omp_get_wtime (void); - extern double __KAI_KMPC_CONVENTION omp_get_wtick (void); - - /* OpenMP 4.0 */ - extern int __KAI_KMPC_CONVENTION omp_get_default_device (void); - extern void __KAI_KMPC_CONVENTION omp_set_default_device (int); - extern int __KAI_KMPC_CONVENTION omp_is_initial_device (void); - extern int __KAI_KMPC_CONVENTION omp_get_num_devices (void); - extern int __KAI_KMPC_CONVENTION omp_get_num_teams (void); - extern int __KAI_KMPC_CONVENTION omp_get_team_num (void); - extern int __KAI_KMPC_CONVENTION omp_get_cancellation (void); - - /* OpenMP 4.5 */ - extern int __KAI_KMPC_CONVENTION omp_get_initial_device (void); - extern void* __KAI_KMPC_CONVENTION omp_target_alloc(size_t, int); - extern void __KAI_KMPC_CONVENTION omp_target_free(void *, int); - extern int __KAI_KMPC_CONVENTION omp_target_is_present(const void *, int); - extern int __KAI_KMPC_CONVENTION omp_target_memcpy(void *, const void *, size_t, size_t, size_t, int, int); - extern int __KAI_KMPC_CONVENTION omp_target_memcpy_rect(void *, const void *, size_t, int, const size_t *, - const size_t *, const size_t *, const size_t *, const size_t *, int, int); - extern int __KAI_KMPC_CONVENTION omp_target_associate_ptr(const void *, const void *, size_t, size_t, int); - extern int __KAI_KMPC_CONVENTION omp_target_disassociate_ptr(const void *, int); - - /* OpenMP 5.0 */ - extern int __KAI_KMPC_CONVENTION omp_get_device_num (void); - typedef void * omp_depend_t; - - /* OpenMP 5.1 interop */ - typedef intptr_t omp_intptr_t; - - /* 0..omp_get_num_interop_properties()-1 are reserved for implementation-defined properties */ - typedef enum omp_interop_property { - omp_ipr_fr_id = -1, - omp_ipr_fr_name = -2, - omp_ipr_vendor = -3, - omp_ipr_vendor_name = -4, - omp_ipr_device_num = -5, - omp_ipr_platform = -6, - omp_ipr_device = -7, - omp_ipr_device_context = -8, - omp_ipr_targetsync = -9, - omp_ipr_first = -9 - } omp_interop_property_t; - - #define omp_interop_none 0 - - typedef enum omp_interop_rc { - omp_irc_no_value = 1, - omp_irc_success = 0, - omp_irc_empty = -1, - omp_irc_out_of_range = -2, - omp_irc_type_int = -3, - omp_irc_type_ptr = -4, - omp_irc_type_str = -5, - omp_irc_other = -6 - } omp_interop_rc_t; - - typedef enum omp_interop_fr { - omp_ifr_cuda = 1, - omp_ifr_cuda_driver = 2, - omp_ifr_opencl = 3, - omp_ifr_sycl = 4, - omp_ifr_hip = 5, - omp_ifr_level_zero = 6, - omp_ifr_last = 7 - } omp_interop_fr_t; - - typedef void * omp_interop_t; - - /*! - * The `omp_get_num_interop_properties` routine retrieves the number of implementation-defined properties available for an `omp_interop_t` object. - */ - extern int __KAI_KMPC_CONVENTION omp_get_num_interop_properties(const omp_interop_t); - /*! - * The `omp_get_interop_int` routine retrieves an integer property from an `omp_interop_t` object. - */ - extern omp_intptr_t __KAI_KMPC_CONVENTION omp_get_interop_int(const omp_interop_t, omp_interop_property_t, int *); - /*! - * The `omp_get_interop_ptr` routine retrieves a pointer property from an `omp_interop_t` object. - */ - extern void * __KAI_KMPC_CONVENTION omp_get_interop_ptr(const omp_interop_t, omp_interop_property_t, int *); - /*! - * The `omp_get_interop_str` routine retrieves a string property from an `omp_interop_t` object. - */ - extern const char * __KAI_KMPC_CONVENTION omp_get_interop_str(const omp_interop_t, omp_interop_property_t, int *); - /*! - * The `omp_get_interop_name` routine retrieves a property name from an `omp_interop_t` object. - */ - extern const char * __KAI_KMPC_CONVENTION omp_get_interop_name(const omp_interop_t, omp_interop_property_t); - /*! - * The `omp_get_interop_type_desc` routine retrieves a description of the type of a property associated with an `omp_interop_t` object. - */ - extern const char * __KAI_KMPC_CONVENTION omp_get_interop_type_desc(const omp_interop_t, omp_interop_property_t); - /*! - * The `omp_get_interop_rc_desc` routine retrieves a description of the return code associated with an `omp_interop_t` object. - */ - extern const char * __KAI_KMPC_CONVENTION omp_get_interop_rc_desc(const omp_interop_t, omp_interop_rc_t); - - /* OpenMP 5.1 device memory routines */ - - /*! - * The `omp_target_memcpy_async` routine asynchronously performs a copy between any combination of host and device pointers. - */ - extern int __KAI_KMPC_CONVENTION omp_target_memcpy_async(void *, const void *, size_t, size_t, size_t, int, - int, int, omp_depend_t *); - /*! - * The `omp_target_memcpy_rect_async` routine asynchronously performs a copy between any combination of host and device pointers. - */ - extern int __KAI_KMPC_CONVENTION omp_target_memcpy_rect_async(void *, const void *, size_t, int, const size_t *, - const size_t *, const size_t *, const size_t *, const size_t *, int, int, - int, omp_depend_t *); - /*! - * The `omp_get_mapped_ptr` routine returns the device pointer that is associated with a host pointer for a given device. - */ - extern void * __KAI_KMPC_CONVENTION omp_get_mapped_ptr(const void *, int); - extern int __KAI_KMPC_CONVENTION omp_target_is_accessible(const void *, size_t, int); - - /* kmp API functions */ - extern int __KAI_KMPC_CONVENTION kmp_get_stacksize (void); - extern void __KAI_KMPC_CONVENTION kmp_set_stacksize (int); - extern size_t __KAI_KMPC_CONVENTION kmp_get_stacksize_s (void); - extern void __KAI_KMPC_CONVENTION kmp_set_stacksize_s (size_t); - extern int __KAI_KMPC_CONVENTION kmp_get_blocktime (void); - extern int __KAI_KMPC_CONVENTION kmp_get_library (void); - extern void __KAI_KMPC_CONVENTION kmp_set_blocktime (int); - extern void __KAI_KMPC_CONVENTION kmp_set_library (int); - extern void __KAI_KMPC_CONVENTION kmp_set_library_serial (void); - extern void __KAI_KMPC_CONVENTION kmp_set_library_turnaround (void); - extern void __KAI_KMPC_CONVENTION kmp_set_library_throughput (void); - extern void __KAI_KMPC_CONVENTION kmp_set_defaults (char const *); - extern void __KAI_KMPC_CONVENTION kmp_set_disp_num_buffers (int); - - /* Intel affinity API */ - typedef void * kmp_affinity_mask_t; - - extern int __KAI_KMPC_CONVENTION kmp_set_affinity (kmp_affinity_mask_t *); - extern int __KAI_KMPC_CONVENTION kmp_get_affinity (kmp_affinity_mask_t *); - extern int __KAI_KMPC_CONVENTION kmp_get_affinity_max_proc (void); - extern void __KAI_KMPC_CONVENTION kmp_create_affinity_mask (kmp_affinity_mask_t *); - extern void __KAI_KMPC_CONVENTION kmp_destroy_affinity_mask (kmp_affinity_mask_t *); - extern int __KAI_KMPC_CONVENTION kmp_set_affinity_mask_proc (int, kmp_affinity_mask_t *); - extern int __KAI_KMPC_CONVENTION kmp_unset_affinity_mask_proc (int, kmp_affinity_mask_t *); - extern int __KAI_KMPC_CONVENTION kmp_get_affinity_mask_proc (int, kmp_affinity_mask_t *); - - /* OpenMP 4.0 affinity API */ - typedef enum omp_proc_bind_t { - omp_proc_bind_false = 0, - omp_proc_bind_true = 1, - omp_proc_bind_master = 2, - omp_proc_bind_close = 3, - omp_proc_bind_spread = 4 - } omp_proc_bind_t; - - extern omp_proc_bind_t __KAI_KMPC_CONVENTION omp_get_proc_bind (void); - - /* OpenMP 4.5 affinity API */ - extern int __KAI_KMPC_CONVENTION omp_get_num_places (void); - extern int __KAI_KMPC_CONVENTION omp_get_place_num_procs (int); - extern void __KAI_KMPC_CONVENTION omp_get_place_proc_ids (int, int *); - extern int __KAI_KMPC_CONVENTION omp_get_place_num (void); - extern int __KAI_KMPC_CONVENTION omp_get_partition_num_places (void); - extern void __KAI_KMPC_CONVENTION omp_get_partition_place_nums (int *); - - extern void * __KAI_KMPC_CONVENTION kmp_malloc (size_t); - extern void * __KAI_KMPC_CONVENTION kmp_aligned_malloc (size_t, size_t); - extern void * __KAI_KMPC_CONVENTION kmp_calloc (size_t, size_t); - extern void * __KAI_KMPC_CONVENTION kmp_realloc (void *, size_t); - extern void __KAI_KMPC_CONVENTION kmp_free (void *); - - extern void __KAI_KMPC_CONVENTION kmp_set_warnings_on(void); - extern void __KAI_KMPC_CONVENTION kmp_set_warnings_off(void); - - /* OpenMP 5.0 Tool Control */ - typedef enum omp_control_tool_result_t { - omp_control_tool_notool = -2, - omp_control_tool_nocallback = -1, - omp_control_tool_success = 0, - omp_control_tool_ignored = 1 - } omp_control_tool_result_t; - - typedef enum omp_control_tool_t { - omp_control_tool_start = 1, - omp_control_tool_pause = 2, - omp_control_tool_flush = 3, - omp_control_tool_end = 4 - } omp_control_tool_t; - - extern int __KAI_KMPC_CONVENTION omp_control_tool(int, int, void*); - - /* OpenMP 5.0 Memory Management */ - typedef uintptr_t omp_uintptr_t; - - typedef enum { - omp_atk_sync_hint = 1, - omp_atk_alignment = 2, - omp_atk_access = 3, - omp_atk_pool_size = 4, - omp_atk_fallback = 5, - omp_atk_fb_data = 6, - omp_atk_pinned = 7, - omp_atk_partition = 8 - } omp_alloctrait_key_t; - - typedef enum { - omp_atv_false = 0, - omp_atv_true = 1, - omp_atv_contended = 3, - omp_atv_uncontended = 4, - omp_atv_serialized = 5, - omp_atv_sequential = omp_atv_serialized, // (deprecated) - omp_atv_private = 6, - omp_atv_all = 7, - omp_atv_thread = 8, - omp_atv_pteam = 9, - omp_atv_cgroup = 10, - omp_atv_default_mem_fb = 11, - omp_atv_null_fb = 12, - omp_atv_abort_fb = 13, - omp_atv_allocator_fb = 14, - omp_atv_environment = 15, - omp_atv_nearest = 16, - omp_atv_blocked = 17, - omp_atv_interleaved = 18 - } omp_alloctrait_value_t; - #define omp_atv_default ((omp_uintptr_t)-1) - - typedef struct { - omp_alloctrait_key_t key; - omp_uintptr_t value; - } omp_alloctrait_t; - -# if defined(_WIN32) - // On Windows cl and icl do not support 64-bit enum, let's use integer then. - typedef omp_uintptr_t omp_allocator_handle_t; - extern __KMP_IMP omp_allocator_handle_t const omp_null_allocator; - extern __KMP_IMP omp_allocator_handle_t const omp_default_mem_alloc; - extern __KMP_IMP omp_allocator_handle_t const omp_large_cap_mem_alloc; - extern __KMP_IMP omp_allocator_handle_t const omp_const_mem_alloc; - extern __KMP_IMP omp_allocator_handle_t const omp_high_bw_mem_alloc; - extern __KMP_IMP omp_allocator_handle_t const omp_low_lat_mem_alloc; - extern __KMP_IMP omp_allocator_handle_t const omp_cgroup_mem_alloc; - extern __KMP_IMP omp_allocator_handle_t const omp_pteam_mem_alloc; - extern __KMP_IMP omp_allocator_handle_t const omp_thread_mem_alloc; - /* Preview of target memory support */ - extern __KMP_IMP omp_allocator_handle_t const llvm_omp_target_host_mem_alloc; - extern __KMP_IMP omp_allocator_handle_t const llvm_omp_target_shared_mem_alloc; - extern __KMP_IMP omp_allocator_handle_t const llvm_omp_target_device_mem_alloc; - - typedef omp_uintptr_t omp_memspace_handle_t; - extern __KMP_IMP omp_memspace_handle_t const omp_default_mem_space; - extern __KMP_IMP omp_memspace_handle_t const omp_large_cap_mem_space; - extern __KMP_IMP omp_memspace_handle_t const omp_const_mem_space; - extern __KMP_IMP omp_memspace_handle_t const omp_high_bw_mem_space; - extern __KMP_IMP omp_memspace_handle_t const omp_low_lat_mem_space; - /* Preview of target memory support */ - extern __KMP_IMP omp_memspace_handle_t const llvm_omp_target_host_mem_space; - extern __KMP_IMP omp_memspace_handle_t const llvm_omp_target_shared_mem_space; - extern __KMP_IMP omp_memspace_handle_t const llvm_omp_target_device_mem_space; -# else -# if __cplusplus >= 201103 - typedef enum omp_allocator_handle_t : omp_uintptr_t -# else - typedef enum omp_allocator_handle_t -# endif - { - omp_null_allocator = 0, - omp_default_mem_alloc = 1, - omp_large_cap_mem_alloc = 2, - omp_const_mem_alloc = 3, - omp_high_bw_mem_alloc = 4, - omp_low_lat_mem_alloc = 5, - omp_cgroup_mem_alloc = 6, - omp_pteam_mem_alloc = 7, - omp_thread_mem_alloc = 8, - /* Preview of target memory support */ - llvm_omp_target_host_mem_alloc = 100, - llvm_omp_target_shared_mem_alloc = 101, - llvm_omp_target_device_mem_alloc = 102, - KMP_ALLOCATOR_MAX_HANDLE = UINTPTR_MAX - } omp_allocator_handle_t; -# if __cplusplus >= 201103 - typedef enum omp_memspace_handle_t : omp_uintptr_t -# else - typedef enum omp_memspace_handle_t -# endif - { - omp_default_mem_space = 0, - omp_large_cap_mem_space = 1, - omp_const_mem_space = 2, - omp_high_bw_mem_space = 3, - omp_low_lat_mem_space = 4, - /* Preview of target memory support */ - llvm_omp_target_host_mem_space = 100, - llvm_omp_target_shared_mem_space = 101, - llvm_omp_target_device_mem_space = 102, - KMP_MEMSPACE_MAX_HANDLE = UINTPTR_MAX - } omp_memspace_handle_t; -# endif - extern omp_allocator_handle_t __KAI_KMPC_CONVENTION omp_init_allocator(omp_memspace_handle_t m, - int ntraits, omp_alloctrait_t traits[]); - extern void __KAI_KMPC_CONVENTION omp_destroy_allocator(omp_allocator_handle_t allocator); - - extern void __KAI_KMPC_CONVENTION omp_set_default_allocator(omp_allocator_handle_t a); - extern omp_allocator_handle_t __KAI_KMPC_CONVENTION omp_get_default_allocator(void); -# ifdef __cplusplus - extern void *__KAI_KMPC_CONVENTION omp_alloc(size_t size, omp_allocator_handle_t a = omp_null_allocator); - extern void *__KAI_KMPC_CONVENTION omp_calloc(size_t nmemb, size_t size, omp_allocator_handle_t a = omp_null_allocator); - extern void *__KAI_KMPC_CONVENTION omp_realloc(void *ptr, size_t size, - omp_allocator_handle_t allocator = omp_null_allocator, - omp_allocator_handle_t free_allocator = omp_null_allocator); - extern void __KAI_KMPC_CONVENTION omp_free(void * ptr, omp_allocator_handle_t a = omp_null_allocator); -# else - extern void *__KAI_KMPC_CONVENTION omp_alloc(size_t size, omp_allocator_handle_t a); - extern void *__KAI_KMPC_CONVENTION omp_calloc(size_t nmemb, size_t size, omp_allocator_handle_t a); - extern void *__KAI_KMPC_CONVENTION omp_realloc(void *ptr, size_t size, omp_allocator_handle_t allocator, - omp_allocator_handle_t free_allocator); - extern void __KAI_KMPC_CONVENTION omp_free(void *ptr, omp_allocator_handle_t a); -# endif - - /* OpenMP 5.0 Affinity Format */ - extern void __KAI_KMPC_CONVENTION omp_set_affinity_format(char const *); - extern size_t __KAI_KMPC_CONVENTION omp_get_affinity_format(char *, size_t); - extern void __KAI_KMPC_CONVENTION omp_display_affinity(char const *); - extern size_t __KAI_KMPC_CONVENTION omp_capture_affinity(char *, size_t, char const *); - - /* OpenMP 5.0 events */ -# if defined(_WIN32) - // On Windows cl and icl do not support 64-bit enum, let's use integer then. - typedef omp_uintptr_t omp_event_handle_t; -# else - typedef enum omp_event_handle_t { KMP_EVENT_MAX_HANDLE = UINTPTR_MAX } omp_event_handle_t; -# endif - extern void __KAI_KMPC_CONVENTION omp_fulfill_event ( omp_event_handle_t event ); - - /* OpenMP 5.0 Pause Resources */ - typedef enum omp_pause_resource_t { - omp_pause_resume = 0, - omp_pause_soft = 1, - omp_pause_hard = 2 - } omp_pause_resource_t; - extern int __KAI_KMPC_CONVENTION omp_pause_resource(omp_pause_resource_t, int); - extern int __KAI_KMPC_CONVENTION omp_pause_resource_all(omp_pause_resource_t); - - extern int __KAI_KMPC_CONVENTION omp_get_supported_active_levels(void); - - /* OpenMP 5.1 */ - extern void __KAI_KMPC_CONVENTION omp_set_num_teams(int num_teams); - extern int __KAI_KMPC_CONVENTION omp_get_max_teams(void); - extern void __KAI_KMPC_CONVENTION omp_set_teams_thread_limit(int limit); - extern int __KAI_KMPC_CONVENTION omp_get_teams_thread_limit(void); - - /* OpenMP 5.1 Display Environment */ - extern void omp_display_env(int verbose); - -# if defined(_OPENMP) && _OPENMP >= 201811 - #pragma omp begin declare variant match(device={kind(host)}) - static inline int omp_is_initial_device(void) { return 1; } - #pragma omp end declare variant - #pragma omp begin declare variant match(device={kind(nohost)}) - static inline int omp_is_initial_device(void) { return 0; } - #pragma omp end declare variant -# endif - -# undef __KAI_KMPC_CONVENTION -# undef __KMP_IMP - - /* Warning: - The following typedefs are not standard, deprecated and will be removed in a future release. - */ - typedef int omp_int_t; - typedef double omp_wtime_t; - -# ifdef __cplusplus - } -# endif - -#endif /* __OMP_H */ From 2b2c114f9f9c87445cfe3fd42ccc8480ec7737d9 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 21:27:29 +0300 Subject: [PATCH 26/47] Updating installation instructions --- README.md | 4 ++-- vignettes/build_source.rmd | 11 +++++++++-- 2 files changed, 11 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index 079ad91a..22a9af0c 100644 --- a/README.md +++ b/README.md @@ -45,9 +45,9 @@ in R. The development version can be installed using the command remotes::install_github("davidbolin/rspde", ref = "devel") ``` -The `stable` and `devel` branches require compilation, which is not the case for the `cran` branch. +*The following is intended for expert use only:* In case you want to build the source, the `stable-src` and `devel-src` branches require compilation, which is not the case for the `cran`, `stable` and `devel` branches. -For Windows operating systems, we recommend the user to install from the `cran` branch, which requires no compilation. +For Windows operating systems, we recommend the user to install from either of the `cran`, `stable` or `devel` branches, which require no compilation. The compilation is required to create a shared object to be used by `INLA`. However, the `INLA` installation comes with such a shared object. Thus, unless there is some specific reason for the user to want to compile from source, it is not required. diff --git a/vignettes/build_source.rmd b/vignettes/build_source.rmd index 4d4950fc..dc7bfbfa 100644 --- a/vignettes/build_source.rmd +++ b/vignettes/build_source.rmd @@ -20,12 +20,19 @@ knitr::opts_chunk$set( To build `rSPDE` from source you need to obtain the [GitHub version](https://github.com/davidbolin/rSPDE). If you have all the dependencies (see below how to install some of them), you can install the `rSPDE` package from source by -running the following command on `R`: +running the following command on `R` (for the development version): ```{r, eval=FALSE} -remotes::install_github("davidbolin/rspde", ref = "devel") +remotes::install_github("davidbolin/rspde", ref = "devel-src") ``` +or, if you want to install the stable version: + +```{r, eval=FALSE} +remotes::install_github("davidbolin/rspde", ref = "stable-src") +``` + + ## Dependencies on Linux The `rSPDE` package depends on the [Eigen C++ library](https://eigen.tuxfamily.org/index.php?title=Main_Page). From 261e2fcee3b6b0598fb1cbfaf3217a7ab605bea4 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 22:08:21 +0300 Subject: [PATCH 27/47] updates setup --- .github/workflows/devel_setup.yml | 7 ++++--- .github/workflows/devel_src_setup.yml | 5 +++-- .github/workflows/stable_setup.yml | 5 +++-- .github/workflows/stable_src_setup.yml | 5 +++-- 4 files changed, 13 insertions(+), 9 deletions(-) diff --git a/.github/workflows/devel_setup.yml b/.github/workflows/devel_setup.yml index 55151c37..376c06c3 100644 --- a/.github/workflows/devel_setup.yml +++ b/.github/workflows/devel_setup.yml @@ -16,10 +16,11 @@ jobs: - name: Merge with devel-src and accept all incoming changes run: | git config --local user.email "actions@github.com" - git config --local user.name "GitHub Actions" - git branch devel-src + git config --local user.name "GitHub Actions" + git config pull.rebase true + git fetch origin git checkout devel-src - git merge devel --no-edit --no-commit --no-ff + git merge devel -X theirs --no-edit --no-commit --no-ff git checkout --theirs . git add . git reset -- src/ diff --git a/.github/workflows/devel_src_setup.yml b/.github/workflows/devel_src_setup.yml index 613c974c..3ffb1890 100644 --- a/.github/workflows/devel_src_setup.yml +++ b/.github/workflows/devel_src_setup.yml @@ -17,9 +17,10 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" - git branch devel + git config pull.rebase true + git fetch origin git checkout devel - git merge devel-src --no-edit --no-commit --no-ff + git merge -X theirs devel-src --no-edit --no-commit --no-ff --allow-unrelated-histories git checkout --theirs . sed -i 's/NeedsCompilation: yes/NeedsCompilation: no/' DESCRIPTION git add . diff --git a/.github/workflows/stable_setup.yml b/.github/workflows/stable_setup.yml index 01bc968a..98d8bdcd 100644 --- a/.github/workflows/stable_setup.yml +++ b/.github/workflows/stable_setup.yml @@ -17,9 +17,10 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" - git branch stable-src + git config pull.rebase true + git fetch origin git checkout stable-src - git merge stable --no-edit --no-commit --no-ff + git merge -X theirs stable --no-edit --no-commit --no-ff git checkout --theirs . git add . git reset -- src/ diff --git a/.github/workflows/stable_src_setup.yml b/.github/workflows/stable_src_setup.yml index dd972cc1..f523a4cf 100644 --- a/.github/workflows/stable_src_setup.yml +++ b/.github/workflows/stable_src_setup.yml @@ -17,9 +17,10 @@ jobs: run: | git config --local user.email "actions@github.com" git config --local user.name "GitHub Actions" - git branch stable + git config pull.rebase true + git fetch origin git checkout stable - git merge stable-src --no-edit --no-commit --no-ff + git merge -X theirs stable-src --no-edit --no-commit --no-ff git checkout --theirs . sed -i 's/NeedsCompilation: yes/NeedsCompilation: no/' DESCRIPTION git add . From b52e23a9a84d917c0c12a6d02393b4e4a867cd35 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 22:14:20 +0300 Subject: [PATCH 28/47] src --- src/Makefile | 29 ++ src/cgeneric_aux_nonstat.cpp | 191 ++++++++ src/cgeneric_aux_nonstat_fixed.cpp | 155 ++++++ src/cgeneric_aux_nonstat_int.cpp | 114 +++++ src/cgeneric_defs.h | 68 +++ src/cgeneric_gpgraph_alpha1.c | 265 ++++++++++ src/cgeneric_mvnormdens.cpp | 49 ++ src/cgeneric_rspde_nonstat_gen_fixed.c | 165 +++++++ src/cgeneric_rspde_nonstat_general.c | 231 +++++++++ src/cgeneric_rspde_nonstat_int.c | 145 ++++++ src/cgeneric_rspde_stat_frac_model.c | 484 +++++++++++++++++++ src/cgeneric_rspde_stat_general.c | 565 ++++++++++++++++++++++ src/cgeneric_rspde_stat_int.c | 637 +++++++++++++++++++++++++ src/cgeneric_rspde_stat_parsim_fixed.c | 196 ++++++++ src/cgeneric_rspde_stat_parsim_gen.c | 347 ++++++++++++++ src/omp.h | 504 +++++++++++++++++++ 16 files changed, 4145 insertions(+) create mode 100644 src/Makefile create mode 100644 src/cgeneric_aux_nonstat.cpp create mode 100644 src/cgeneric_aux_nonstat_fixed.cpp create mode 100644 src/cgeneric_aux_nonstat_int.cpp create mode 100644 src/cgeneric_defs.h create mode 100644 src/cgeneric_gpgraph_alpha1.c create mode 100644 src/cgeneric_mvnormdens.cpp create mode 100644 src/cgeneric_rspde_nonstat_gen_fixed.c create mode 100644 src/cgeneric_rspde_nonstat_general.c create mode 100644 src/cgeneric_rspde_nonstat_int.c create mode 100644 src/cgeneric_rspde_stat_frac_model.c create mode 100644 src/cgeneric_rspde_stat_general.c create mode 100644 src/cgeneric_rspde_stat_int.c create mode 100644 src/cgeneric_rspde_stat_parsim_fixed.c create mode 100644 src/cgeneric_rspde_stat_parsim_gen.c create mode 100644 src/omp.h diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 00000000..722f9d04 --- /dev/null +++ b/src/Makefile @@ -0,0 +1,29 @@ +toInclude = ${R_LIBRARY_DIR}/INLA/include/ + +obj = cgeneric_mvnormdens.o cgeneric_aux_nonstat.o cgeneric_aux_nonstat_fixed.o cgeneric_rspde_stat_frac_model.o cgeneric_rspde_nonstat_general.o cgeneric_rspde_stat_general.o cgeneric_rspde_stat_parsim_gen.o cgeneric_rspde_stat_parsim_fixed.o cgeneric_rspde_stat_int.o cgeneric_rspde_nonstat_gen_fixed.o cgeneric_rspde_nonstat_int.o cgeneric_aux_nonstat_int.o + +all : rSPDE.so + +CC = gcc +CXX = g++ + +EIGEN_MAC = /usr/local +EIGEN_LINUX = /usr + +flags = -O2 -Wall -Wextra -fpic + +%.o: %.c + test -f ${R_LIBRARY_DIR}/INLA/include/cgeneric.h || test -f cgeneric.h || wget -O cgeneric.h https://raw.githubusercontent.com/hrue/r-inla/devel/inlaprog/src/cgeneric.h + $(CC) $(flags) -Iinclude -I$(toInclude) -c $^ -o $@ + +%.o: %.cpp + $(CXX) $(flags) -I$(toInclude) -I$(EIGEN_MAC)/include/eigen3/ -I$(EIGEN_LINUX)/include/eigen3/ -c $^ -o $@ + +rSPDE.so: $(obj) + $(CXX) -shared *.o -o ../inst/shared/rspde_cgeneric_models.so -lblas -llapack + +clean : + rm -f *.o + rm -f cgeneric.h + +.PHONY: all clean \ No newline at end of file diff --git a/src/cgeneric_aux_nonstat.cpp b/src/cgeneric_aux_nonstat.cpp new file mode 100644 index 00000000..12ed256d --- /dev/null +++ b/src/cgeneric_aux_nonstat.cpp @@ -0,0 +1,191 @@ +#include +#include +#include + +extern "C" void compute_Q(int size, double *entries_C, int *i_C, int *j_C, + int n_nonzero_C, + double *entries_G, int *i_G, int *j_G, + int n_nonzero_G, + double *entries_B_kappa, double *entries_B_tau, + int ncol_B, int rspde_order, double *theta_entries, + double *rat_p, double *rat_r, double rat_k, + double *Q_out, + int *graph_i, int *graph_j, int M, + int matern_par, double start_nu, double nu, double d); + +void compute_Q(int size, double *entries_C, int *i_C, int *j_C, + int n_nonzero_C, + double *entries_G, int *i_G, int *j_G, + int n_nonzero_G, + double *entries_B_kappa, double *entries_B_tau, + int ncol_B, int rspde_order, double *theta_entries, + double *rat_p, double *rat_r, double rat_k, + double *Q_out, + int *graph_i, int *graph_j, int M, + int matern_par, double start_nu, double nu, double d) { + + double alpha = nu + d/2.0; + int m_alpha = (int) floor(alpha); + + + typedef Eigen::Triplet Trip; + std::vector trp_C, trp_G, trp_Q; + int k, i, j; + + + // Assemble C and G + Eigen::SparseMatrix C(size,size), G(size,size), Q_graph(size*(rspde_order+1), size*(rspde_order+1)); + + for(k = 0; k < n_nonzero_C; k++){ + trp_C.push_back(Trip(i_C[k],j_C[k],entries_C[k])); + } + + for(k = 0; k < n_nonzero_G; k++){ + trp_G.push_back(Trip(i_G[k],j_G[k],entries_G[k])); + } + + C.setFromTriplets(trp_C.begin(), trp_C.end()); + G.setFromTriplets(trp_G.begin(), trp_G.end()); + + for(k = 0; k < M; k++){ + trp_Q.push_back(Trip(graph_i[k],graph_j[k],1)); + } + + Q_graph.setFromTriplets(trp_Q.begin(), trp_Q.end()); + + Q_graph = Q_graph + Eigen::SparseMatrix(Q_graph.transpose()); + + // Assemble B_kappa and B_tau + + Eigen::MatrixXd B_kappa(size, ncol_B), B_tau(size, ncol_B); + + for(i = 0; i < size; i++){ + for(j = 0; j < ncol_B; j++){ + B_tau(i,j) = entries_B_tau[i*ncol_B + j]; + B_kappa(i,j) = entries_B_kappa[i*ncol_B + j]; + } + } + + if(matern_par == 1){ + B_kappa.col(0) += 0.5 * log( 8 * nu) * Eigen::VectorXd::Constant(B_kappa.rows(), 1) - + 0.5 * log(8 * start_nu) * Eigen::VectorXd::Constant(B_kappa.rows(), 1); + B_tau.col(0) += 0.5 * (lgamma(start_nu + d/2.0) - + lgamma(start_nu) - lgamma(nu + d/2.0) + lgamma(nu)) * Eigen::VectorXd::Constant(B_kappa.rows(),1) + + start_nu * B_kappa.col(0) - nu * B_kappa.col(0); + for(i = 1; i < B_tau.cols(); i++){ + B_tau.col(i) += start_nu * B_kappa.col(i) - nu * B_kappa.col(i); + } + } else if(matern_par == 2){ + B_tau.col(0) += 0.5 * (lgamma(start_nu + d/2.0) - + lgamma(start_nu) - lgamma(nu + d/2.0) + lgamma(nu)) * Eigen::VectorXd::Constant(B_kappa.rows(),1) + + start_nu * B_kappa.col(0) - nu * B_kappa.col(0); + for(i = 1; i < B_tau.cols(); i++){ + B_tau.col(i) += start_nu * B_kappa.col(i) - nu * B_kappa.col(i); + } + } + + + // get kappa and tau + + Eigen::VectorXd theta(ncol_B); + theta(0) = 1; + for(k = 1; k < ncol_B; k++){ + theta(k) = theta_entries[k-1]; + } + + + Eigen::VectorXd kappa = (B_kappa * theta).array().exp(); + Eigen::VectorXd tau = (B_tau * theta).array().exp(); + + // Create vector of the parts of Q + + Eigen::VectorXd Cdiag = C.diagonal(); + + Eigen::SparseMatrix L(size,size), CinvL(size,size); + + L = kappa.cwiseProduct(kappa).cwiseProduct(Cdiag).asDiagonal(); + L = L + G; + + // Scaling L + + double factor = pow(kappa.minCoeff(),2); + + L = L / factor; + + if(m_alpha > 0){ + CinvL = C.cwiseInverse() * L; + } + + int m; + + // Assemble first part of Q + + Eigen::SparseMatrix tau_matrix(size, size); + tau_matrix = tau.asDiagonal(); + + Eigen::SparseMatrix Q_tmp(size,size), Q((rspde_order+1)*size, (rspde_order+1)*size); + + for(k = 0; k < rspde_order; k++){ + Q_tmp = (L - rat_p[k] * C)/rat_r[k]; + if(m_alpha>0){ + for(m = 0; m < m_alpha; m++){ + Q_tmp = Q_tmp * CinvL; + } + } + + Q_tmp = tau_matrix * Q_tmp * tau_matrix; + + for (m=0; m < Q_tmp.outerSize(); ++m) + { + for (Eigen::SparseMatrix::InnerIterator it(Q_tmp,m); it; ++it) + { + Q.insert(it.row() + size*k, it.col() + size*k) = it.value(); + } + } + } + + + // Assemble the K part + + if(m_alpha == 0){ + Q_tmp = C.cwiseInverse(); + } else if(m_alpha == 1){ + Q_tmp = L; + } else{ + Q_tmp = L; + for(m = 0; m < m_alpha-1; m++){ + Q_tmp = Q_tmp * CinvL; + } + } + + Q_tmp = tau_matrix * Q_tmp * tau_matrix; + + + for (m=0; m < Q_tmp.outerSize(); ++m) { + for (Eigen::SparseMatrix::InnerIterator it(Q_tmp,m); it; ++it) + { + Q.insert(it.row() + size*rspde_order, it.col() + size*rspde_order) = it.value()/rat_k; + } + } + + + Q = Q + 0 * Q_graph; + + Q = pow(factor, alpha) * Q; + + Eigen::SparseMatrix Q_triang((rspde_order+1)*size, (rspde_order+1)*size); + Q_triang = Q.triangularView(); + + + int count = 0; + + for (m=0; m < Q_triang.outerSize(); ++m) + { + for (Eigen::SparseMatrix::InnerIterator it(Q_triang,m); it; ++it) + { + Q_out[count] = it.value(); + count++; + } + } + + } \ No newline at end of file diff --git a/src/cgeneric_aux_nonstat_fixed.cpp b/src/cgeneric_aux_nonstat_fixed.cpp new file mode 100644 index 00000000..d11cf627 --- /dev/null +++ b/src/cgeneric_aux_nonstat_fixed.cpp @@ -0,0 +1,155 @@ +#include +#include +#include + +extern "C" void compute_Q_fixednu(int size, double *entries_C, int *i_C, int *j_C, + int n_nonzero_C, + double *entries_G, int *i_G, int *j_G, + int n_nonzero_G, + double *entries_B_kappa, double *entries_B_tau, + int ncol_B, int rspde_order, double *theta_entries, + double *rat_p, double *rat_r, double rat_k, + int m_alpha, double *Q_out, double alpha); + +void compute_Q_fixednu(int size, double *entries_C, int *i_C, int *j_C, + int n_nonzero_C, + double *entries_G, int *i_G, int *j_G, + int n_nonzero_G, + double *entries_B_kappa, double *entries_B_tau, + int ncol_B, int rspde_order, double *theta_entries, + double *rat_p, double *rat_r, double rat_k, + int m_alpha, double *Q_out, double alpha) { + + + typedef Eigen::Triplet Trip; + std::vector trp_C, trp_G; + int k, i, j; + + + // Assemble C and G + Eigen::SparseMatrix C(size,size), G(size,size), Q_graph(size*(rspde_order+1), size*(rspde_order+1)); + + for(k = 0; k < n_nonzero_C; k++){ + trp_C.push_back(Trip(i_C[k],j_C[k],entries_C[k])); + } + + for(k = 0; k < n_nonzero_G; k++){ + trp_G.push_back(Trip(i_G[k],j_G[k],entries_G[k])); + } + + C.setFromTriplets(trp_C.begin(), trp_C.end()); + G.setFromTriplets(trp_G.begin(), trp_G.end()); + + // Assemble B_kappa and B_tau + + Eigen::MatrixXd B_kappa(size, ncol_B), B_tau(size, ncol_B); + + for(i = 0; i < size; i++){ + for(j = 0; j < ncol_B; j++){ + B_tau(i,j) = entries_B_tau[i*ncol_B + j]; + B_kappa(i,j) = entries_B_kappa[i*ncol_B + j]; + } + } + + // get kappa and tau + + Eigen::VectorXd theta(ncol_B); + theta(0) = 1; + for(k = 1; k < ncol_B; k++){ + theta(k) = theta_entries[k-1]; + } + + + Eigen::VectorXd kappa = (B_kappa * theta).array().exp(); + Eigen::VectorXd tau = (B_tau * theta).array().exp(); + + // Create vector of the parts of Q + + Eigen::VectorXd Cdiag = C.diagonal(); + + Eigen::SparseMatrix L(size,size), CinvL(size,size); + + L = kappa.cwiseProduct(kappa).cwiseProduct(Cdiag).asDiagonal(); + L = L + G; + + // Scaling L + + double factor = pow(kappa.minCoeff(),2); + + L = L / factor; + + if(m_alpha > 0){ + CinvL = C.cwiseInverse() * L; + } + + int m; + + // Assemble first part of Q + + Eigen::SparseMatrix tau_matrix(size, size); + tau_matrix = tau.asDiagonal(); + + Eigen::SparseMatrix Q_tmp(size,size), Q((rspde_order+1)*size, (rspde_order+1)*size); + + for(k = 0; k < rspde_order; k++){ + Q_tmp = (L - rat_p[k] * C)/rat_r[k]; + if(m_alpha>0){ + for(m = 0; m < m_alpha; m++){ + Q_tmp = Q_tmp * CinvL; + } + } + + Q_tmp = tau_matrix * Q_tmp * tau_matrix; + + for (m=0; m < Q_tmp.outerSize(); ++m) + { + for (Eigen::SparseMatrix::InnerIterator it(Q_tmp,m); it; ++it) + { + Q.insert(it.row() + size*k, it.col() + size*k) = it.value(); + } + } + } + + + // Assemble the K part + + if(m_alpha == 0){ + Q_tmp = C.cwiseInverse(); + } else if(m_alpha == 1){ + Q_tmp = L; + } else{ + Q_tmp = L; + for(m = 0; m < m_alpha-1; m++){ + Q_tmp = Q_tmp * CinvL; + } + } + + Q_tmp = tau_matrix * Q_tmp * tau_matrix; + + + for (m=0; m < Q_tmp.outerSize(); ++m) { + for (Eigen::SparseMatrix::InnerIterator it(Q_tmp,m); it; ++it) + { + Q.insert(it.row() + size*rspde_order, it.col() + size*rspde_order) = it.value()/rat_k; + } + } + + + Q = pow(factor, alpha) * Q; + + Eigen::SparseMatrix Q_triang((rspde_order+1)*size, (rspde_order+1)*size); + Q_triang = Q.triangularView(); + + + int count = 0; + + for (m=0; m < Q_triang.outerSize(); ++m) + { + for (Eigen::SparseMatrix::InnerIterator it(Q_triang,m); it; ++it) + { + Q_out[count] = it.value(); + count++; + } + } + + } \ No newline at end of file diff --git a/src/cgeneric_aux_nonstat_int.cpp b/src/cgeneric_aux_nonstat_int.cpp new file mode 100644 index 00000000..df463445 --- /dev/null +++ b/src/cgeneric_aux_nonstat_int.cpp @@ -0,0 +1,114 @@ +#include +#include +#include + +extern "C" void compute_Q_integer(int size, double *entries_C, int *i_C, int *j_C, + int n_nonzero_C, + double *entries_G, int *i_G, int *j_G, + int n_nonzero_G, + double *entries_B_kappa, double *entries_B_tau, + int ncol_B, double *theta_entries, + double *Q_out, int alpha); + +void compute_Q_integer(int size, double *entries_C, int *i_C, int *j_C, + int n_nonzero_C, + double *entries_G, int *i_G, int *j_G, + int n_nonzero_G, + double *entries_B_kappa, double *entries_B_tau, + int ncol_B, double *theta_entries, + double *Q_out, int alpha) { + + + typedef Eigen::Triplet Trip; + std::vector trp_C, trp_G; + int k, i, j; + + + // Assemble C and G + Eigen::SparseMatrix C(size,size), G(size,size); + + for(k = 0; k < n_nonzero_C; k++){ + trp_C.push_back(Trip(i_C[k],j_C[k],entries_C[k])); + } + + for(k = 0; k < n_nonzero_G; k++){ + trp_G.push_back(Trip(i_G[k],j_G[k],entries_G[k])); + } + + C.setFromTriplets(trp_C.begin(), trp_C.end()); + G.setFromTriplets(trp_G.begin(), trp_G.end()); + + // Assemble B_kappa and B_tau + + Eigen::MatrixXd B_kappa(size, ncol_B), B_tau(size, ncol_B); + + for(i = 0; i < size; i++){ + for(j = 0; j < ncol_B; j++){ + B_tau(i,j) = entries_B_tau[i*ncol_B + j]; + B_kappa(i,j) = entries_B_kappa[i*ncol_B + j]; + } + } + + // get kappa and tau + + Eigen::VectorXd theta(ncol_B); + theta(0) = 1; + for(k = 1; k < ncol_B; k++){ + theta(k) = theta_entries[k-1]; + } + + + Eigen::VectorXd kappa = (B_kappa * theta).array().exp(); + Eigen::VectorXd tau = (B_tau * theta).array().exp(); + + // Create vector of the parts of Q + + Eigen::VectorXd Cdiag = C.diagonal(); + + Eigen::SparseMatrix L(size,size), CinvL(size,size); + + L = kappa.cwiseProduct(kappa).cwiseProduct(Cdiag).asDiagonal(); + L = L + G; + + if(alpha > 1){ + CinvL = C.cwiseInverse() * L; + } + + int m; + + // Assemble first part of Q + + Eigen::SparseMatrix tau_matrix(size, size); + tau_matrix = tau.asDiagonal(); + + Eigen::SparseMatrix Q(size,size); + + Q = L; + + if(alpha > 1){ + for(k = 1; k < alpha; k++){ + Q = Q * CinvL; + } + } + + Q = tau_matrix * Q * tau_matrix; + + + + + Eigen::SparseMatrix Q_triang(size, size); + Q_triang = Q.triangularView(); + + + int count = 0; + + for (m=0; m < Q_triang.outerSize(); ++m) + { + for (Eigen::SparseMatrix::InnerIterator it(Q_triang,m); it; ++it) + { + Q_out[count] = it.value(); + count++; + } + } + + } \ No newline at end of file diff --git a/src/cgeneric_defs.h b/src/cgeneric_defs.h new file mode 100644 index 00000000..cfb6d8d6 --- /dev/null +++ b/src/cgeneric_defs.h @@ -0,0 +1,68 @@ +#include +#include +#include +#include +#include + +#include "cgeneric.h" + +#define Calloc(n_, type_) (type_ *)calloc((n_), sizeof(type_)) +#define SQR(x) ((x)*(x)) + +// https://stackoverflow.com/questions/9330915/number-of-combinations-n-choose-r-in-c + +double nChoosek( int n, int k ); +double cut_decimals(double nu); + +void daxpy_(int* N, double* DA, double* DX, int* INCX, double* DY, int* INCY); + +void dscal_(int* N, double* DA, double* DX,int* INCX); + +void dcopy_(int* N, double* DX, int* INCX, double* DY,int* INCY); + +void daxpby_(int* N, double* DA, double* DX, int* INCX, double* DB, double* DY, int* INCY, double* DZ); + +void dgesv_(int *n, int *nrhs, double *a, int *lda, + int *ipivot, double *b, int *ldb, int *info) ; + +void dgemv_(char* trans, int* M, int* N, double* alpha, double* A, + int* LDA, double* x, int* incx, + double* beta, double* y, int* inc); + +double * markov_approx_coeff(double beta, double kappa, int d); + +double pnorm(double x, double mu, double sd); + +double logdbeta(double x, double s_1, double s_2); + +double logmultnormvdens(int npar, double *entries_mean, + double *entries_prec, + double *entries_val); + +void compute_Q(int size, double *entries_C, int *i_C, int *j_C, + int n_nonzero_C, + double *entries_G, int *i_G, int *j_G, + int n_nonzero_G, + double *entries_B_kappa, double *entries_B_tau, + int ncol_B, int rspde_order, double *theta_entries, + double *rat_p, double *rat_r, double rat_k, + double *Q_out, + int *graph_i, int *graph_j, int M, + int matern_par, double start_nu, double nu, double d); + +void compute_Q_fixednu(int size, double *entries_C, int *i_C, int *j_C, + int n_nonzero_C, + double *entries_G, int *i_G, int *j_G, + int n_nonzero_G, + double *entries_B_kappa, double *entries_B_tau, + int ncol_B, int rspde_order, double *theta_entries, + double *rat_p, double *rat_r, double rat_k, + int m_alpha, double *Q_out, double alpha); + +void compute_Q_integer(int size, double *entries_C, int *i_C, int *j_C, + int n_nonzero_C, + double *entries_G, int *i_G, int *j_G, + int n_nonzero_G, + double *entries_B_kappa, double *entries_B_tau, + int ncol_B, double *theta_entries, + double *Q_out, int alpha); \ No newline at end of file diff --git a/src/cgeneric_gpgraph_alpha1.c b/src/cgeneric_gpgraph_alpha1.c new file mode 100644 index 00000000..eacc281e --- /dev/null +++ b/src/cgeneric_gpgraph_alpha1.c @@ -0,0 +1,265 @@ +#include "cgeneric_defs.h" +#include "stdio.h" + +// This version uses 'padded' matrices with zeroes +double *inla_cgeneric_gpgraph_alpha1_model(inla_cgeneric_cmd_tp cmd, double *theta, inla_cgeneric_data_tp * data) { + + double *ret = NULL; + + double lkappa, lsigma, kappa, sigma; + + double c1, c2, c_1, c_2, one_m_c2, l_e; + + int N, M, i, j, k; + + char *parameterization; + + // the size of the model + assert(data->n_ints == 7); + + // the number of doubles + assert(data->n_doubles == 9); + + assert(!strcasecmp(data->ints[0]->name, "n")); // this will always be the case + N = data->ints[0]->ints[0]; // this will always be the case + assert(N > 0); + + assert(!strcasecmp(data->ints[1]->name, "debug")); // this will always be the case + int debug = data->ints[1]->ints[0]; // this will always be the case + + if(debug == 1){ + debug = 1; + } + + assert(!strcasecmp(data->ints[2]->name, "prec_graph_i")); + inla_cgeneric_vec_tp *graph_i = data->ints[2]; + M = graph_i->len; + + assert(!strcasecmp(data->ints[3]->name, "prec_graph_j")); + inla_cgeneric_vec_tp *graph_j = data->ints[3]; + assert(M == graph_j->len); + + assert(!strcasecmp(data->ints[4]->name, "index_graph")); + inla_cgeneric_vec_tp *idx_ij = data->ints[4]; + int M_full = idx_ij->len; + + assert(!strcasecmp(data->ints[5]->name, "count_idx")); + inla_cgeneric_vec_tp *count_idx = data->ints[5]; + assert(M == count_idx->len); + + assert(!strcasecmp(data->ints[6]->name, "stationary_endpoints")); + inla_cgeneric_vec_tp *stationary_endpoints = data->ints[6]; + + assert(!strcasecmp(data->doubles[0]->name, "EtV2")); + inla_cgeneric_vec_tp *EtV2 = data->doubles[0]; + + int nE = EtV2 -> len; + + assert(!strcasecmp(data->doubles[1]->name, "EtV3")); + inla_cgeneric_vec_tp *EtV3 = data->doubles[1]; + + assert(nE == EtV3 -> len); + + assert(!strcasecmp(data->doubles[2]->name, "El")); + inla_cgeneric_vec_tp *El = data->doubles[2]; + + // prior parameters + assert(!strcasecmp(data->doubles[3]->name, "start_theta")); + double start_theta = data->doubles[3]->doubles[0]; + + assert(!strcasecmp(data->doubles[4]->name, "start_lsigma")); + double start_lsigma = data->doubles[4]->doubles[0]; + + assert(!strcasecmp(data->doubles[5]->name, "prior_theta_meanlog")); + double prior_theta_meanlog = data->doubles[5]->doubles[0]; + + assert(!strcasecmp(data->doubles[6]->name, "prior_theta_sdlog")); + double prior_theta_sdlog = data->doubles[6]->doubles[0]; + + assert(!strcasecmp(data->doubles[7]->name, "prior_sigma_meanlog")); + double prior_sigma_meanlog = data->doubles[7]->doubles[0]; + + assert(!strcasecmp(data->doubles[8]->name, "prior_sigma_sdlog")); + double prior_sigma_sdlog = data->doubles[8]->doubles[0]; + + assert(!strcasecmp(data->chars[2]->name, "parameterization")); + parameterization = &data->chars[2]->chars[0]; + + if (theta) { + // interpretable parameters + + if(!strcasecmp(parameterization, "matern")){ + lkappa = log(2.0) - theta[1]; + } else { + lkappa = theta[1]; + } + lsigma = theta[0]; + kappa = exp(lkappa); + sigma = exp(lsigma); + } + else { + lsigma = lkappa = sigma = kappa = NAN; + } + + switch (cmd) { + case INLA_CGENERIC_VOID: + { + assert(!(cmd == INLA_CGENERIC_VOID)); + break; + } + + case INLA_CGENERIC_GRAPH: + { + k=2; + ret = Calloc(k + 2 * M, double); + ret[0] = N; /* dimension */ + ret[1] = M; /* number of (i <= j) */ + for (i = 0; i < M; i++) { + ret[k++] = graph_i->ints[i]; + } + for (i = 0; i < M; i++) { + ret[k++] = graph_j->ints[i]; + } + break; + } + + + case INLA_CGENERIC_Q: + { + k = 2; + ret = Calloc(k + M, double); + ret[0] = -1; /* REQUIRED */ + ret[1] = M; /* REQUIRED */ + + double *raw_entries; + raw_entries = Calloc(M_full, double); + + // int count=0; + // for(i = 0; i < nE; i++){ + // l_e = El->doubles[i]; + // c1 = exp(-kappa*l_e); + // c2 = SQR(c1); + // one_m_c2 = 1-c2; + // c_1 = 0.5 + c2/one_m_c2; + // c_2 = -c1/one_m_c2; + + // if(EtV2->doubles[i] != EtV3->doubles[i]){ + + // ret[k + idx_ij->ints[count]] = c_1; + // ret[k + idx_ij->ints[count + 1]] = c_1; + // ret[k + idx_ij->ints[count + 2]] = c_2; + // count += 3; + // }else{ + // ret[k + idx_ij->ints[count]] = tanh(0.5 * kappa * l_e); + // count++; + // } + // } + + // if(stationary_endpoints->ints[0]>=0){ + // int stat_endpt_len = stationary_endpoints->len; + // for(i = 0; i < stat_endpt_len; i++){ + // ret[k+idx_ij->ints[count+i]] = 0.5; + // } + // count += stat_endpt_len; + // } + + // assert(count == M); + + // double fact = 2*kappa / (pow(sigma,2)); + + // int one=1; + // dscal_(&M, &fact, &ret[k], &one); + + int count=0; + for(i = 0; i < nE; i++){ + l_e = El->doubles[i]; + c1 = exp(-kappa*l_e); + c2 = SQR(c1); + one_m_c2 = 1-c2; + c_1 = 0.5 + c2/one_m_c2; + c_2 = -c1/one_m_c2; + + if(EtV2->doubles[i] != EtV3->doubles[i]){ + + raw_entries[idx_ij->ints[count]] = c_1; + raw_entries[idx_ij->ints[count + 1]] = c_1; + raw_entries[idx_ij->ints[count + 2]] = c_2; + count += 3; + }else{ + raw_entries[idx_ij->ints[count]] = tanh(0.5 * kappa * l_e); + count++; + } + } + + if(stationary_endpoints->ints[0]>=0){ + int stat_endpt_len = stationary_endpoints->len; + for(i = 0; i < stat_endpt_len; i++){ + raw_entries[idx_ij->ints[count+i]] = 0.5; + } + count += stat_endpt_len; + } + + assert(count == M_full); + + double fact = 2*kappa / (pow(sigma,2)); + + int one=1; + dscal_(&M_full, &fact, &raw_entries[0], &one); + + count = 0; + for(i = 0; i < M; i++){ + for(j = 0; j < count_idx->ints[i]; j++){ + // ret[k + i] += raw_entries[count]; + ret[k + i] += raw_entries[count]; + count++; + } + } + assert(M_full == count); + + break; + } + + case INLA_CGENERIC_MU: + { + ret = Calloc(1, double); + ret[0] = 0.0; + break; + } + + case INLA_CGENERIC_INITIAL: + { + // return c(P, initials) + // where P is the number of hyperparameters + ret = Calloc(3, double); + ret[0] = 2; + ret[1] = start_lsigma; + ret[2] = start_theta; + break; + } + + case INLA_CGENERIC_LOG_NORM_CONST: + { + break; + } + + case INLA_CGENERIC_LOG_PRIOR: + { + ret = Calloc(1, double); + + ret[0] = 0.0; + + ret[0] += -0.5 * SQR(theta[1] - prior_theta_meanlog)/(SQR(prior_theta_sdlog)) - + log(prior_theta_sdlog) - 0.5 * log(2.0 * M_PI); + + ret[0] += -0.5 * SQR(lsigma - prior_sigma_meanlog)/(SQR(prior_sigma_sdlog)) - + log(prior_sigma_sdlog) - 0.5 * log(2.0 * M_PI); + break; + } + + case INLA_CGENERIC_QUIT: + default: + break; + } + + return (ret); +} \ No newline at end of file diff --git a/src/cgeneric_mvnormdens.cpp b/src/cgeneric_mvnormdens.cpp new file mode 100644 index 00000000..b35975ed --- /dev/null +++ b/src/cgeneric_mvnormdens.cpp @@ -0,0 +1,49 @@ +#include +#include +#include + +extern "C" double logmultnormvdens(int npar, double *entries_mean, + double *entries_prec, + double *entries_val); + +double logmultnormvdens(int npar, double *entries_mean, + double *entries_prec, + double *entries_val) { + + int i, j, k; + + Eigen::MatrixXd prec_matrix(npar, npar); + + for(i = 0; i < npar; i++){ + for(j = 0; j < npar; j++){ + prec_matrix(i,j) = entries_prec[i*npar + j]; + } + } + + Eigen::VectorXd mean_vec(npar); + for(k = 0; k < npar; k++){ + mean_vec(k) = entries_mean[k]; + } + + Eigen::VectorXd val_vec(npar); + for(k = 0; k < npar; k++){ + val_vec(k) = entries_val[k]; + } + + Eigen::LLT chol(prec_matrix); + + double logdens; + + Eigen::VectorXd centered_vec(npar); + + centered_vec = val_vec - mean_vec; + + logdens = -0.5 * centered_vec.cwiseProduct(prec_matrix * centered_vec).sum(); + + logdens -= npar/2.0 * log(2 * M_PI); + + logdens += chol.matrixL().toDenseMatrix().diagonal().array().log().sum(); + + return logdens; + + } \ No newline at end of file diff --git a/src/cgeneric_rspde_nonstat_gen_fixed.c b/src/cgeneric_rspde_nonstat_gen_fixed.c new file mode 100644 index 00000000..b6b26aad --- /dev/null +++ b/src/cgeneric_rspde_nonstat_gen_fixed.c @@ -0,0 +1,165 @@ +#include "cgeneric_defs.h" +#include "stdio.h" +// #include "gsl/gsl_vector_double.h" + + +// This version uses 'padded' matrices with zeroes +double *inla_cgeneric_rspde_nonstat_fixed_model(inla_cgeneric_cmd_tp cmd, double *theta, inla_cgeneric_data_tp * data) { + + double *ret = NULL; + + int k, i; + + assert(!strcasecmp(data->ints[0]->name, "n")); // this will always be the case + int N = data->ints[0]->ints[0]; // this will always be the case + assert(N > 0); + + assert(!strcasecmp(data->ints[1]->name, "debug")); // this will always be the case + int debug = data->ints[1]->ints[0]; // this will always be the case + + if(debug == 1){ + debug = 1; + } + + assert(!strcasecmp(data->ints[2]->name, "graph_opt_i")); + inla_cgeneric_vec_tp *graph_i = data->ints[2]; + int M = graph_i->len; + + assert(!strcasecmp(data->ints[3]->name, "graph_opt_j")); + inla_cgeneric_vec_tp *graph_j = data->ints[3]; + assert(M == graph_j->len); + + assert(!strcasecmp(data->ints[4]->name, "rspde_order")); + int rspde_order = data->ints[4]->ints[0]; + + + assert(!strcasecmp(data->doubles[0]->name, "d")); + double d = data->doubles[0]->doubles[0]; + + assert(!strcasecmp(data->doubles[1]->name, "r_ratapprox")); + double *r = data->doubles[1]->doubles; + + assert(!strcasecmp(data->doubles[2]->name, "p_ratapprox")); + double *p = data->doubles[2]->doubles; + + assert(!strcasecmp(data->doubles[3]->name, "k_ratapprox")); + double k_rat = data->doubles[3]->doubles[0]; + + assert(!strcasecmp(data->doubles[4]->name, "nu")); + double nu = data->doubles[4]->doubles[0]; + + double alpha = nu + d / 2.0; + int m_alpha = floor(alpha); + + assert(!strcasecmp(data->smats[0]->name, "C")); + inla_cgeneric_smat_tp *C = data->smats[0]; + + assert(!strcasecmp(data->smats[1]->name, "G")); + inla_cgeneric_smat_tp *G = data->smats[1]; + + int n_mesh = C->ncol; + + assert(!strcasecmp(data->mats[0]->name, "B_tau")); + inla_cgeneric_mat_tp *B_tau = data->mats[0]; + + assert(!strcasecmp(data->mats[1]->name, "B_kappa")); + inla_cgeneric_mat_tp *B_kappa = data->mats[1]; + + int n_par = B_tau->ncol; + + // Starting values + + assert(!strcasecmp(data->doubles[5]->name, "start.theta")); + inla_cgeneric_vec_tp *start_theta = data->doubles[5]; + + assert(!strcasecmp(data->doubles[6]->name, "theta.prior.mean")); + inla_cgeneric_vec_tp *theta_prior_mean = data->doubles[6]; + + assert(!strcasecmp(data->mats[2]->name, "theta.prior.prec")); + inla_cgeneric_mat_tp *theta_prior_prec = data->mats[2]; + + switch (cmd) { + case INLA_CGENERIC_VOID: + { + assert(!(cmd == INLA_CGENERIC_VOID)); + break; + } + + case INLA_CGENERIC_GRAPH: + { + k=2; + ret = Calloc(k + 2 * M, double); + ret[0] = N; /* dimension */ + ret[1] = M; /* number of (i <= j) */ + for (i = 0; i < M; i++) { + ret[k++] = graph_i->ints[i]; + } + for (i = 0; i < M; i++) { + ret[k++] = graph_j->ints[i]; + } + break; + } + + case INLA_CGENERIC_Q: + { + k = 2; + ret = Calloc(k + M, double); + ret[0] = -1; /* REQUIRED */ + ret[1] = M; /* REQUIRED */ + + compute_Q_fixednu(n_mesh, C->x, C->i, C->j, + C->n, + G->x, G->i, G->j, + G->n, + B_kappa->x, B_tau->x, + B_kappa->ncol, rspde_order, + theta, p, r, k_rat, + m_alpha, &ret[k], + alpha); + + break; + } + + case INLA_CGENERIC_MU: + { + ret = Calloc(1, double); + ret[0] = 0.0; + break; + } + + case INLA_CGENERIC_INITIAL: + { + // return c(P, initials) + // where P is the number of hyperparameters + ret = Calloc(n_par, double); + ret[0] = n_par-1; + for(i=1; idoubles[i-1]; + } + break; + } + + case INLA_CGENERIC_LOG_NORM_CONST: + { + break; + } + + case INLA_CGENERIC_LOG_PRIOR: + { + ret = Calloc(1, double); + + ret[0] = 0.0; + + ret[0] += logmultnormvdens(n_par-1, theta_prior_mean->doubles, + theta_prior_prec->x, theta); + + break; + } + + case INLA_CGENERIC_QUIT: + default: + break; + } + + return (ret); +} \ No newline at end of file diff --git a/src/cgeneric_rspde_nonstat_general.c b/src/cgeneric_rspde_nonstat_general.c new file mode 100644 index 00000000..9d799109 --- /dev/null +++ b/src/cgeneric_rspde_nonstat_general.c @@ -0,0 +1,231 @@ +#include "cgeneric_defs.h" +#include "stdio.h" +// #include "gsl/gsl_vector_double.h" + + +// This version uses 'padded' matrices with zeroes +double *inla_cgeneric_rspde_nonstat_general_model(inla_cgeneric_cmd_tp cmd, double *theta, inla_cgeneric_data_tp * data) { + + double *ret = NULL; + + char *prior_nu_dist; + + int k, i; + + assert(!strcasecmp(data->ints[0]->name, "n")); // this will always be the case + int N = data->ints[0]->ints[0]; // this will always be the case + assert(N > 0); + + assert(!strcasecmp(data->ints[1]->name, "debug")); // this will always be the case + int debug = data->ints[1]->ints[0]; // this will always be the case + + if(debug == 1){ + debug = 1; + } + + assert(!strcasecmp(data->ints[2]->name, "graph_opt_i")); + inla_cgeneric_vec_tp *graph_i = data->ints[2]; + int M = graph_i->len; + + assert(!strcasecmp(data->ints[3]->name, "graph_opt_j")); + inla_cgeneric_vec_tp *graph_j = data->ints[3]; + assert(M == graph_j->len); + + assert(!strcasecmp(data->ints[4]->name, "rspde_order")); + int rspde_order = data->ints[4]->ints[0]; + + assert(!strcasecmp(data->ints[5]->name, "matern_par")); + int matern_par = data->ints[5]->ints[0]; + + + assert(!strcasecmp(data->doubles[0]->name, "d")); + double d = data->doubles[0]->doubles[0]; + + assert(!strcasecmp(data->doubles[1]->name, "nu_upper_bound")); + double nu_upper_bound = data->doubles[1]->doubles[0]; + + assert(!strcasecmp(data->mats[0]->name, "rational_table")); + inla_cgeneric_mat_tp *rational_table = data->mats[0]; + assert(rational_table->nrow == 999); + + assert(!strcasecmp(data->smats[0]->name, "C")); + inla_cgeneric_smat_tp *C = data->smats[0]; + + assert(!strcasecmp(data->smats[1]->name, "G")); + inla_cgeneric_smat_tp *G = data->smats[1]; + + int n_mesh = C->ncol; + + assert(!strcasecmp(data->mats[1]->name, "B_tau")); + inla_cgeneric_mat_tp *B_tau = data->mats[1]; + + assert(!strcasecmp(data->mats[2]->name, "B_kappa")); + inla_cgeneric_mat_tp *B_kappa = data->mats[2]; + + int n_par = B_tau->ncol; + + // Prior param + + assert(!strcasecmp(data->doubles[2]->name, "prior.nu.loglocation")); + double prior_nu_loglocation = data->doubles[2]->doubles[0]; + + assert(!strcasecmp(data->doubles[3]->name, "prior.nu.logscale")); + double prior_nu_logscale = data->doubles[3]->doubles[0]; + + assert(!strcasecmp(data->doubles[4]->name, "prior.nu.mean")); + double prior_nu_mean = data->doubles[4]->doubles[0]; + + assert(!strcasecmp(data->doubles[5]->name, "prior.nu.prec")); + double prior_nu_prec = data->doubles[5]->doubles[0]; + + // Nu prior + + assert(!strcasecmp(data->chars[2]->name, "prior.nu.dist")); + prior_nu_dist = &data->chars[2]->chars[0]; + + // Starting values + + assert(!strcasecmp(data->doubles[6]->name, "start.nu")); + double start_nu = data->doubles[6]->doubles[0]; + + assert(!strcasecmp(data->doubles[7]->name, "start.theta")); + inla_cgeneric_vec_tp *start_theta = data->doubles[7]; + + assert(!strcasecmp(data->doubles[8]->name, "theta.prior.mean")); + inla_cgeneric_vec_tp *theta_prior_mean = data->doubles[8]; + + assert(!strcasecmp(data->mats[3]->name, "theta.prior.prec")); + inla_cgeneric_mat_tp *theta_prior_prec = data->mats[3]; + + double lnu, nu; + + if (theta) { + // interpretable parameters + lnu = theta[n_par-1]; + nu = (exp(lnu)/(1.0 + exp(lnu))) * nu_upper_bound; + } + else { + lnu = nu = NAN; + } + + + + switch (cmd) { + case INLA_CGENERIC_VOID: + { + assert(!(cmd == INLA_CGENERIC_VOID)); + break; + } + + case INLA_CGENERIC_GRAPH: + { + k=2; + ret = Calloc(k + 2 * M, double); + ret[0] = N; /* dimension */ + ret[1] = M; /* number of (i <= j) */ + for (i = 0; i < M; i++) { + ret[k++] = graph_i->ints[i]; + } + for (i = 0; i < M; i++) { + ret[k++] = graph_j->ints[i]; + } + break; + } + + case INLA_CGENERIC_Q: + { + k = 2; + ret = Calloc(k + M, double); + ret[0] = -1; /* REQUIRED */ + ret[1] = M; /* REQUIRED */ + + int n_terms = 2*rspde_order + 2; + + double new_alpha = nu + d/2.0; + + int row_nu = (int)round(1000*cut_decimals(new_alpha))-1; + + double *rat_coef = Calloc(n_terms-1, double); + + rat_coef = &rational_table->x[row_nu*n_terms+1]; + + double *r, *p, k_rat; + + r = Calloc(rspde_order, double); + p = Calloc(rspde_order, double); + + r = &rat_coef[0]; + p = &rat_coef[rspde_order]; + k_rat = rat_coef[2*rspde_order]; + + compute_Q(n_mesh, C->x, C->i, C->j, + C->n, + G->x, G->i, G->j, + G->n, + B_kappa->x, B_tau->x, + B_kappa->ncol, rspde_order, + theta, p, r, k_rat, &ret[k], + graph_i->ints, graph_j->ints, + M, matern_par, start_nu, nu, + d); + + break; + } + + case INLA_CGENERIC_MU: + { + ret = Calloc(1, double); + ret[0] = 0.0; + break; + } + + case INLA_CGENERIC_INITIAL: + { + // return c(P, initials) + // where P is the number of hyperparameters + ret = Calloc(n_par+1, double); + ret[0] = n_par; + for(i=1; idoubles[i-1]; + } + ret[n_par] = log(start_nu/(nu_upper_bound - start_nu)); + break; + } + + case INLA_CGENERIC_LOG_NORM_CONST: + { + break; + } + + case INLA_CGENERIC_LOG_PRIOR: + { + ret = Calloc(1, double); + + ret[0] = 0.0; + + if(!strcasecmp(prior_nu_dist, "lognormal")){ + ret[0] += -0.5 * SQR(lnu - prior_nu_loglocation)/(SQR(prior_nu_logscale)); + ret[0] += -log(prior_nu_logscale) - 0.5 * log(2.0*M_PI); + ret[0] -= log(pnorm(log(nu_upper_bound), prior_nu_loglocation, prior_nu_logscale)); + + } + else { // if(!strcasecmp(prior_nu_dist, "beta")){ + double s_1 = (prior_nu_mean / nu_upper_bound) * prior_nu_prec; + double s_2 = (1 - prior_nu_mean / nu_upper_bound) * prior_nu_prec; + ret[0] += logdbeta(nu / nu_upper_bound, s_1, s_2) - log(nu_upper_bound); + } + + ret[0] += logmultnormvdens(n_par-1, theta_prior_mean->doubles, + theta_prior_prec->x, theta); + + + break; + } + + case INLA_CGENERIC_QUIT: + default: + break; + } + + return (ret); +} \ No newline at end of file diff --git a/src/cgeneric_rspde_nonstat_int.c b/src/cgeneric_rspde_nonstat_int.c new file mode 100644 index 00000000..6311d85f --- /dev/null +++ b/src/cgeneric_rspde_nonstat_int.c @@ -0,0 +1,145 @@ +#include "cgeneric_defs.h" +#include "stdio.h" +// #include "gsl/gsl_vector_double.h" + + +// This version uses 'padded' matrices with zeroes +double *inla_cgeneric_rspde_nonstat_int_model(inla_cgeneric_cmd_tp cmd, double *theta, inla_cgeneric_data_tp * data) { + + double *ret = NULL; + + int k, i; + + assert(!strcasecmp(data->ints[0]->name, "n")); // this will always be the case + int N = data->ints[0]->ints[0]; // this will always be the case + assert(N > 0); + + assert(!strcasecmp(data->ints[1]->name, "debug")); // this will always be the case + int debug = data->ints[1]->ints[0]; // this will always be the case + + if(debug == 1){ + debug = 1; + } + + assert(!strcasecmp(data->ints[2]->name, "graph_opt_i")); + inla_cgeneric_vec_tp *graph_i = data->ints[2]; + int M = graph_i->len; + + assert(!strcasecmp(data->ints[3]->name, "graph_opt_j")); + inla_cgeneric_vec_tp *graph_j = data->ints[3]; + assert(M == graph_j->len); + + assert(!strcasecmp(data->ints[4]->name, "alpha")); + int alpha = data->ints[4]->ints[0]; + + assert(!strcasecmp(data->smats[0]->name, "C")); + inla_cgeneric_smat_tp *C = data->smats[0]; + + assert(!strcasecmp(data->smats[1]->name, "G")); + inla_cgeneric_smat_tp *G = data->smats[1]; + + int n_mesh = C->ncol; + + assert(!strcasecmp(data->mats[0]->name, "B_tau")); + inla_cgeneric_mat_tp *B_tau = data->mats[0]; + + assert(!strcasecmp(data->mats[1]->name, "B_kappa")); + inla_cgeneric_mat_tp *B_kappa = data->mats[1]; + + int n_par = B_tau->ncol; + + // Starting values + + assert(!strcasecmp(data->doubles[0]->name, "start.theta")); + inla_cgeneric_vec_tp *start_theta = data->doubles[0]; + + assert(!strcasecmp(data->doubles[1]->name, "theta.prior.mean")); + inla_cgeneric_vec_tp *theta_prior_mean = data->doubles[1]; + + assert(!strcasecmp(data->mats[2]->name, "theta.prior.prec")); + inla_cgeneric_mat_tp *theta_prior_prec = data->mats[2]; + + switch (cmd) { + case INLA_CGENERIC_VOID: + { + assert(!(cmd == INLA_CGENERIC_VOID)); + break; + } + + case INLA_CGENERIC_GRAPH: + { + k=2; + ret = Calloc(k + 2 * M, double); + ret[0] = N; /* dimension */ + ret[1] = M; /* number of (i <= j) */ + for (i = 0; i < M; i++) { + ret[k++] = graph_i->ints[i]; + } + for (i = 0; i < M; i++) { + ret[k++] = graph_j->ints[i]; + } + break; + } + + case INLA_CGENERIC_Q: + { + k = 2; + ret = Calloc(k + M, double); + ret[0] = -1; /* REQUIRED */ + ret[1] = M; /* REQUIRED */ + + compute_Q_integer(n_mesh, C->x, C->i, C->j, + C->n, + G->x, G->i, G->j, + G->n, + B_kappa->x, B_tau->x, + B_kappa->ncol, + theta, &ret[k], + alpha); + + break; + } + + case INLA_CGENERIC_MU: + { + ret = Calloc(1, double); + ret[0] = 0.0; + break; + } + + case INLA_CGENERIC_INITIAL: + { + // return c(P, initials) + // where P is the number of hyperparameters + ret = Calloc(n_par, double); + ret[0] = n_par-1; + for(i=1; idoubles[i-1]; + } + break; + } + + case INLA_CGENERIC_LOG_NORM_CONST: + { + break; + } + + case INLA_CGENERIC_LOG_PRIOR: + { + ret = Calloc(1, double); + + ret[0] = 0.0; + + ret[0] += logmultnormvdens(n_par-1, theta_prior_mean->doubles, + theta_prior_prec->x, theta); + + break; + } + + case INLA_CGENERIC_QUIT: + default: + break; + } + + return (ret); +} \ No newline at end of file diff --git a/src/cgeneric_rspde_stat_frac_model.c b/src/cgeneric_rspde_stat_frac_model.c new file mode 100644 index 00000000..3de59cc6 --- /dev/null +++ b/src/cgeneric_rspde_stat_frac_model.c @@ -0,0 +1,484 @@ +#include "cgeneric_defs.h" +// #include "stdio.h" +// #include "gsl/gsl_vector_double.h" + +// This version uses 'padded' matrices with zeroes +double *inla_cgeneric_rspde_stat_frac_model(inla_cgeneric_cmd_tp cmd, double *theta, inla_cgeneric_data_tp * data) { + + double *ret = NULL; + double ltau, lkappa, tau, kappa; + double alpha, nu; + int m_alpha; + int N, M, i, k, j, rspde_order, d; + int full_size, less_size; + int one = 1; + char *parameterization, *theta_param; + + assert(!strcasecmp(data->ints[0]->name, "n")); // this will always be the case + N = data->ints[0]->ints[0]; // this will always be the case + assert(N > 0); + + assert(!strcasecmp(data->ints[1]->name, "debug")); // this will always be the case + int debug = data->ints[1]->ints[0]; // this will always be the case + + if(debug == 1){ + debug = 1; + } + + assert(!strcasecmp(data->ints[2]->name, "graph_opt_i")); + inla_cgeneric_vec_tp *graph_i = data->ints[2]; + M = graph_i->len; + + assert(!strcasecmp(data->ints[3]->name, "graph_opt_j")); + inla_cgeneric_vec_tp *graph_j = data->ints[3]; + assert(M == graph_j->len); + + assert(!strcasecmp(data->ints[4]->name, "rspde.order")); + rspde_order = data->ints[4]->ints[0]; + + assert(!strcasecmp(data->ints[5]->name, "d")); + d = data->ints[5]->ints[0]; + + assert(!strcasecmp(data->chars[2]->name, "parameterization")); + parameterization = &data->chars[2]->chars[0]; + + assert(!strcasecmp(data->chars[3]->name, "prior.theta.param")); + theta_param = &data->chars[3]->chars[0]; + + assert(!strcasecmp(data->doubles[0]->name, "nu")); + nu = data->doubles[0]->doubles[0]; + + alpha = nu + d / 2.0; + m_alpha = floor(alpha); + + assert(!strcasecmp(data->doubles[1]->name, "matrices_less")); + inla_cgeneric_vec_tp *fem_less = data->doubles[1]; + + assert(!strcasecmp(data->doubles[2]->name, "matrices_full")); + inla_cgeneric_vec_tp *fem_full = data->doubles[2]; + full_size = (fem_full->len)/(m_alpha+2); + less_size = (fem_less->len)/(m_alpha+1); + assert(M == rspde_order * full_size + less_size); + + + assert(!strcasecmp(data->doubles[3]->name, "r_ratapprox")); + double *r = data->doubles[3]->doubles; + + assert(!strcasecmp(data->doubles[4]->name, "p_ratapprox")); + double *p = data->doubles[4]->doubles; + + assert(!strcasecmp(data->doubles[5]->name, "k_ratapprox")); + double k_rat = data->doubles[5]->doubles[0]; + + // prior parameters + + assert(!strcasecmp(data->doubles[6]->name, "theta.prior.mean")); + inla_cgeneric_vec_tp *theta_prior_mean = data->doubles[6]; + + assert(!strcasecmp(data->mats[0]->name, "theta.prior.prec")); + inla_cgeneric_mat_tp *theta_prior_prec = data->mats[0]; + + assert(!strcasecmp(data->doubles[7]->name, "start.theta")); + inla_cgeneric_vec_tp *start_theta = data->doubles[7]; + + if (theta) { + // interpretable parameters + if(!strcasecmp(parameterization, "matern")){ + lkappa = 0.5 * log(8.0 * nu) - theta[1]; + ltau = - theta[0] + 0.5 *( + lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) + ); + + } else if(!strcasecmp(parameterization, "matern2")) { + lkappa = - theta[1]; + ltau = - 0.5 * theta[0] + 0.5 *( + lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) + ); + } else { + ltau = theta[0]; + lkappa = theta[1]; + } + tau = exp(ltau); + kappa = exp(lkappa); + + } + else { + ltau = lkappa = tau = kappa = NAN; + } + + switch (cmd) { + case INLA_CGENERIC_VOID: + { + assert(!(cmd == INLA_CGENERIC_VOID)); + break; + } + + case INLA_CGENERIC_GRAPH: + { + k=2; + ret = Calloc(k + 2 * M, double); + ret[0] = N; /* dimension */ + ret[1] = M; /* number of (i <= j) */ + for (i = 0; i < M; i++) { + ret[k++] = graph_i->ints[i]; + } + for (i = 0; i < M; i++) { + ret[k++] = graph_j->ints[i]; + } + break; + } + + case INLA_CGENERIC_Q: + { + k = 2; + ret = Calloc(k + M, double); + ret[0] = -1; /* REQUIRED */ + ret[1] = M; /* REQUIRED */ + + // FORTRAN IMPLEMENTATION + + double multQ = pow(kappa, 2*alpha) * SQR(tau); + + switch(m_alpha){ + case 0: + { + double fact_mult; + for(j = 0; j < rspde_order; j++){ + fact_mult = multQ * (1-p[j])/r[j]; + dcopy_(&full_size, &fem_full->doubles[0], &one, &ret[k + j*full_size], &one); + dscal_(&full_size, &fact_mult, &ret[k+ j*full_size], &one); + fact_mult = multQ / (r[j] * SQR(kappa)); + daxpy_(&full_size, &fact_mult, &fem_full->doubles[full_size], &one, &ret[k+j*full_size], &one); + } + // dcopy_(&less_size, &fem_less->doubles[0], &one, &ret[k+rspde_order * full_size], &one); + // fact_mult = multQ/k_rat; + // dscal_(&less_size, &fact_mult, &ret[k+rspde_order * full_size], &one); + for(i = 0; i < less_size; i++){ + if(fem_less->doubles[i] != 0){ + ret[k+rspde_order*full_size + i] = multQ * ( + 1/(k_rat * fem_less->doubles[i]) + ); + } + } + break; + } + case 1: + { + double *Malpha2, fact_mult; + Malpha2 = Calloc(full_size, double); + for(j = 0; j < rspde_order; j++){ + dcopy_(&full_size, &fem_full->doubles[0], &one, &ret[k+j*full_size], &one); + fact_mult = 1/SQR(kappa); + daxpy_(&full_size, &fact_mult, &fem_full->doubles[full_size], &one, &ret[k+j*full_size], &one); + fact_mult = multQ * (1-p[j])/r[j]; + dscal_(&full_size, &fact_mult, &ret[k+j*full_size], &one); + dcopy_(&full_size, &fem_full->doubles[full_size], &one, Malpha2, &one); + fact_mult = 1/SQR(kappa); + daxpy_(&full_size, &fact_mult, &fem_full->doubles[2*full_size], &one, Malpha2, &one); + fact_mult = multQ/(SQR(kappa) * r[j]); + daxpy_(&full_size, &fact_mult, Malpha2, &one, &ret[k + j*full_size], &one); + } + + free(Malpha2); + + dcopy_(&less_size, &fem_less->doubles[0], &one, &ret[k+rspde_order*full_size], &one); + fact_mult = multQ/k_rat; + dscal_(&less_size, &fact_mult, &ret[k+rspde_order*full_size], &one); + fact_mult = multQ/(k_rat * SQR(kappa)); + daxpy_(&less_size, &fact_mult, &fem_less->doubles[less_size], &one, &ret[k+rspde_order*full_size], &one); + break; + } + default: + { + double *Malpha2, fact_mult; + Malpha2 = Calloc(full_size, double); + for(j = 0; j < rspde_order; j++){ + dcopy_(&full_size, &fem_full->doubles[0],&one, &ret[k+j*full_size], &one); + fact_mult = m_alpha/SQR(kappa); + daxpy_(&full_size, &fact_mult, &fem_full->doubles[full_size], &one, &ret[k+j*full_size], &one); + for(i = 2; i<= m_alpha; i++){ + fact_mult = nChoosek(m_alpha, i)/(pow(kappa, 2*i)); + daxpy_(&full_size, &fact_mult, &fem_full->doubles[i*full_size], &one, &ret[k+j*full_size], &one); + } + fact_mult = multQ * (1-p[j])/r[j]; + dscal_(&full_size, &fact_mult, &ret[k+j*full_size], &one); + dcopy_(&full_size, &fem_full->doubles[full_size], &one, Malpha2, &one); + fact_mult = m_alpha/SQR(kappa); + daxpy_(&full_size, &fact_mult, &fem_full->doubles[2*full_size], &one, Malpha2, &one); + for(i = 2; i<= m_alpha; i++){ + fact_mult = nChoosek(m_alpha, i)/(pow(kappa, 2*i)); + daxpy_(&full_size, &fact_mult, &fem_full->doubles[(i+1)*full_size], &one, Malpha2, &one); + } + fact_mult = multQ/(SQR(kappa) * r[j]); + daxpy_(&full_size, &fact_mult, Malpha2, &one, &ret[k + j*full_size], &one); + } + + free(Malpha2); + + dcopy_(&less_size, &fem_less->doubles[0], &one, &ret[k+rspde_order*full_size], &one); + fact_mult = multQ/k_rat; + dscal_(&less_size, &fact_mult, &ret[k+rspde_order*full_size], &one); + fact_mult = multQ * m_alpha/(k_rat * SQR(kappa)); + daxpy_(&less_size, &fact_mult, &fem_less->doubles[less_size], &one, &ret[k+rspde_order*full_size], &one); + for(j = 2; j<= m_alpha; j++){ + fact_mult = multQ * nChoosek(m_alpha, j)/(k_rat * pow(SQR(kappa),j)); + daxpy_(&less_size, &fact_mult, &fem_less->doubles[j*less_size], &one, &ret[k+rspde_order*full_size], &one); + } + break; + } + } + + // GSL IMPLEMENTATION + + // gsl_vector * FEM1 = gsl_vector_calloc(full_size); // C, then G, G_2, etc. + // gsl_vector * FEM2 = gsl_vector_calloc(full_size); // G, then G_2, G_3, etc., then part to be returned + + + + // switch(new_m_alpha){ + // case 0: + // { + // dcopy_(&full_size, &fem_full->doubles[0], &one, &FEM1->data[0], &one); + // for(j = 0; j < rspde_order; j++){ + // dcopy_(&full_size, &fem_full->doubles[full_size], &one, &FEM2->data[0], &one); + // gsl_vector_axpby(multQ * (1-p[j])/r[j], FEM1, multQ / (r[j] * SQR(kappa)), FEM2); + // dcopy_(&full_size, &FEM2->data[0], &one, &ret[k + j*full_size], &one); + // } + // gsl_vector_free(FEM1); + // gsl_vector_free(FEM2); + // gsl_vector * FEM1 = gsl_vector_calloc(less_size); // C, then G, G_2, etc. + // dcopy_(&less_size, &fem_less->doubles[0], &one, &FEM1->data[0], &one); + // gsl_vector_scale(FEM1, multQ/k_rat); + // dcopy_(&less_size, &FEM1->data[0], &one, &ret[k + rspde_order * full_size], &one); + // gsl_vector_free(FEM1); + // break; + // } + // case 1: + // { + // dcopy_(&full_size, &fem_full->doubles[0], &one, &FEM1->data[0], &one); + // dcopy_(&full_size, &fem_full->doubles[full_size], &one, &FEM2->data[0], &one); + // gsl_vector_axpby(1/SQR(kappa), FEM2, 1, FEM1); // FEM1 = M_alpha + // gsl_vector * FEM3 = gsl_vector_calloc(full_size); + // dcopy_(&full_size, &fem_full->doubles[2 * full_size], &one, &FEM3->data[0], &one); + // gsl_vector_axpby(1/SQR(kappa), FEM3, 1, FEM2); // FEM2 = M_alpha2 + // gsl_vector_memcpy(FEM3, FEM2); + // for(j = 0; j < rspde_order; j++){ + // gsl_vector_axpby(multQ * (1-p[j])/r[j], FEM1, multQ/(SQR(kappa) * r[j]), FEM2); //FEM2 -> part of Q + // dcopy_(&full_size, &FEM2->data[0], &one, &ret[k + j*full_size], &one); + // gsl_vector_memcpy(FEM2, FEM3); + // } + // // Add k part + // gsl_vector_free(FEM1); + // gsl_vector_free(FEM2); + // gsl_vector_free(FEM3); + // gsl_vector * FEM1 = gsl_vector_calloc(less_size); + // gsl_vector * FEM2 = gsl_vector_calloc(less_size); + // dcopy_(&less_size, &fem_less->doubles[0], &one, &FEM1->data[0], &one); // copy C back to FEM1 + // dcopy_(&less_size, &fem_less->doubles[less_size], &one, &FEM2->data[0], &one); + // gsl_vector_axpby(multQ/(k_rat * SQR(kappa)), FEM2, multQ/k_rat, FEM1); + // dcopy_(&less_size, &FEM1->data[0], &one, &ret[k + rspde_order * full_size], &one); + // gsl_vector_free(FEM1); + // gsl_vector_free(FEM2); + // break; + // } + // default: + // { + // dcopy_(&full_size, &fem_full->doubles[0], &one, &FEM1->data[0], &one); + // gsl_vector * FEM3 = gsl_vector_calloc(full_size); + // dcopy_(&full_size, &fem_full->doubles[full_size], &one, &FEM2->data[0], &one); + // gsl_vector_axpby(new_m_alpha/SQR(kappa), FEM2, 1, FEM1); // FEM1 = M_alpha + // for(j = 2; j<= new_m_alpha; j++){ + // dcopy_(&full_size, &fem_full->doubles[j * full_size], &one, &FEM3->data[0], &one); + // gsl_vector_axpby(nChoosek(new_m_alpha, j)/(pow(kappa, 2*j)), FEM3, 1, FEM1); + // } + // dcopy_(&full_size, &fem_full->doubles[2 * full_size], &one, &FEM3->data[0], &one); + // gsl_vector_axpby(new_m_alpha/SQR(kappa), FEM3, 1, FEM2); // FEM2 = M_alpha2 + // for(j = 2; j<= new_m_alpha; j++){ + // dcopy_(&full_size, &fem_full->doubles[(j+1) * full_size], &one, &FEM3->data[0], &one); + // gsl_vector_axpby(nChoosek(new_m_alpha, j)/(pow(kappa,2*j)), FEM3, 1, FEM2); + // } + + + // gsl_vector_memcpy(FEM3, FEM2); + // for(j = 0; j < rspde_order; j++){ + // gsl_vector_axpby(multQ * (1-p[j])/r[j], FEM1, multQ/(SQR(kappa) * r[j]), FEM2); //FEM2 -> part of Q + // dcopy_(&full_size, &FEM2->data[0], &one, &ret[k + j*full_size], &one); + // gsl_vector_memcpy(FEM2, FEM3); + // } + // // Add k part + // gsl_vector_free(FEM1); + // gsl_vector_free(FEM2); + // gsl_vector_free(FEM3); + // gsl_vector * FEM1 = gsl_vector_calloc(less_size); + // gsl_vector * FEM2 = gsl_vector_calloc(less_size); + // dcopy_(&less_size, &fem_less->doubles[0], &one, &FEM1->data[0], &one); // copy C back to FEM1 + // dcopy_(&less_size, &fem_less->doubles[less_size], &one, &FEM2->data[0], &one); + // gsl_vector_axpby(multQ * new_m_alpha/(k_rat * SQR(kappa)), FEM2, multQ/k_rat, FEM1); + // for(j = 2; j<= new_m_alpha; j++){ + // dcopy_(&less_size, &fem_less->doubles[j * less_size], &one, &FEM2->data[0], &one); + // gsl_vector_axpby(multQ * nChoosek(new_m_alpha, j)/(k_rat * pow(SQR(kappa),j)), FEM2, 1, FEM1); + // } + // dcopy_(&less_size, &FEM1->data[0], &one, &ret[k + rspde_order * full_size], &one); + // gsl_vector_free(FEM1); + // gsl_vector_free(FEM2); + // break; + // } + // } + + // DIRECT C IMPLEMENTATION + + // double *Malpha, *Malpha2; + + + // // double multQ = pow(kappa, 2*new_alpha) * SQR(tau); + + // if(new_m_alpha == 0){ + // for(j = 0; j < rspde_order; j++){ + // for(i = 0; i < full_size; i++){ + // ret[k + j*full_size + i] = multQ * ( + // (fem_full->doubles[i] + (fem_full->doubles[full_size+i])/(SQR(kappa))) - + // (p[j] * fem_full->doubles[i]) + // ) / r[j]; + // } + // } + + // // Kpart + // for(i = 0; i < less_size; i++){ + // ret[k+rspde_order*full_size + i] = multQ * ( + // fem_less->doubles[i]/k_rat + // ); + // } + + // } else{ + + // Malpha = Calloc(full_size, double); + // Malpha2 = Calloc(full_size, double); + + // if(new_m_alpha == 1){ + // // for(i = 0; i < full_size; i++){ + // // Malpha[i] = fem_full->doubles[i] + (fem_full->doubles[full_size+i])/(SQR(kappa)); + // // Malpha2[i] = fem_full->doubles[full_size+i] + (fem_full->doubles[2*full_size+i])/(SQR(kappa)); + // // } + // for(i = 0; i < full_size; i++){ + // Malpha[i] = fem_full->doubles[i] + (fem_full->doubles[full_size+i])/(SQR(kappa)); + // } + // for(i = 0; i < full_size; i++){ + // Malpha2[i] = fem_full->doubles[full_size+i] + (fem_full->doubles[2*full_size+i])/(SQR(kappa)); + // } + // } else if(new_m_alpha > 1){ + // // for(i = 0; i < full_size; i++){ + // // Malpha[i] = fem_full->doubles[i] + new_m_alpha * (fem_full->doubles[full_size+i])/(SQR(kappa)); + // // for(j = 2; j <= new_m_alpha; j++){ + // // Malpha[i] += nChoosek(new_m_alpha, j) * (fem_full->doubles[j*full_size+i])/(pow(kappa, 2*j)); + // // } + + // // Malpha2[i] = fem_full->doubles[full_size+i] + new_m_alpha * (fem_full->doubles[2*full_size+i])/(SQR(kappa)); + // // for(j = 2; j <= new_m_alpha ; j++){ + // // Malpha2[i] += nChoosek(new_m_alpha, j) * (fem_full->doubles[(j+1)*full_size + i])/(pow(kappa,2*j)); + // // } + // // } + + // for(i = 0; i < full_size; i++){ + // Malpha[i] = fem_full->doubles[i] + new_m_alpha * (fem_full->doubles[full_size+i])/(SQR(kappa)); + // for(j = 2; j <= new_m_alpha; j++){ + // Malpha[i] += nChoosek(new_m_alpha, j) * (fem_full->doubles[j*full_size+i])/(pow(kappa, 2*j)); + // } + // } + // for(i = 0; i < full_size; i++){ + // Malpha2[i] = fem_full->doubles[full_size+i] + new_m_alpha * (fem_full->doubles[2*full_size+i])/(SQR(kappa)); + // for(j = 2; j <= new_m_alpha ; j++){ + // Malpha2[i] += nChoosek(new_m_alpha, j) * (fem_full->doubles[(j+1)*full_size + i])/(pow(kappa,2*j)); + // } + // } + // } + + // for(j = 0; j < rspde_order; j++){ + // for(i = 0; i < full_size; i++){ + // ret[k + j * full_size + i] = multQ * ( + // (1-p[j]) * Malpha[i] + (Malpha2[i])/(SQR(kappa)) + // )/(r[j]); + // } + // } + + // if(new_m_alpha == 1){ + + // for(i = 0; i < less_size; i++){ + // ret[k+rspde_order*full_size + i] = multQ/(k_rat) * ( + // fem_less->doubles[i] + (fem_less->doubles[less_size+i])/(SQR(kappa)) + // ); + // } + // } else{ + + // for(i = 0; i < less_size; i++){ + // ret[k+rspde_order*full_size + i] = multQ/(k_rat) * ( + // fem_less->doubles[i] + (new_m_alpha/SQR(kappa)) * fem_less->doubles[less_size+i] + // ); + // for(j = 2; j <= new_m_alpha ; j++){ + // ret[k+rspde_order*full_size + i] += multQ/(k_rat) * ( + // nChoosek(new_m_alpha,j)*(fem_less->doubles[i + j*less_size])/(pow(kappa,2*j)) + // ); + // } + // } + // } + + // } + + break; + } + + case INLA_CGENERIC_MU: + { + ret = Calloc(1, double); + ret[0] = 0.0; + break; + } + + case INLA_CGENERIC_INITIAL: + { + // return c(P, initials) + // where P is the number of hyperparameters + ret = Calloc(3, double); + ret[0] = 2; + ret[1] = start_theta->doubles[0]; + ret[2] = start_theta->doubles[1]; + break; + } + + case INLA_CGENERIC_LOG_NORM_CONST: + { + break; + } + + case INLA_CGENERIC_LOG_PRIOR: + { + ret = Calloc(1, double); + + ret[0] = 0.0; + + if(!strcasecmp(theta_param, "theta") || !strcasecmp(parameterization, "spde")){ + ret[0] += logmultnormvdens(2, theta_prior_mean->doubles, + theta_prior_prec->x, theta); + } + else { + double theta_prior_mean_spde[2], theta_spde[2]; + theta_spde[1] = lkappa; + theta_spde[0] = ltau; + theta_prior_mean_spde[1] = 0.5 * log(8.0 * nu) - theta_prior_mean->doubles[1]; + theta_prior_mean_spde[0] = - theta_prior_mean->doubles[0] + 0.5 *( + lgamma(nu) - 2.0 * nu * theta_prior_mean_spde[1] - + (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) + ); + + ret[0] += logmultnormvdens(2, theta_prior_mean_spde, + theta_prior_prec->x, theta_spde); + } + break; + } + + case INLA_CGENERIC_QUIT: + default: + break; + } + + return (ret); +} \ No newline at end of file diff --git a/src/cgeneric_rspde_stat_general.c b/src/cgeneric_rspde_stat_general.c new file mode 100644 index 00000000..b7b826fb --- /dev/null +++ b/src/cgeneric_rspde_stat_general.c @@ -0,0 +1,565 @@ +#include "cgeneric_defs.h" +#include "stdio.h" +// #include "gsl/gsl_vector_double.h" + +double cut_decimals(double nu){ + double temp = nu - floor(nu); + if(temp < pow(10,-3)){ + temp = pow(10,-3); + } + if(temp > 0.999){ + temp = 0.999; + } + return temp; +} + +double pnorm(double x, double mu, double sd) +{ + return (1 + erf((x-mu) / (sd * sqrt(2.0))))/(2.0); +} + +double logdbeta(double x, double s_1, double s_2){ + double tmp = lgamma(s_1 + s_2) - lgamma(s_1) - lgamma(s_2); + tmp += (s_1-1)*log(x) + (s_2-1)*log(1-x); + return tmp; +} + +// This version uses 'padded' matrices with zeroes +double *inla_cgeneric_rspde_stat_general_model(inla_cgeneric_cmd_tp cmd, double *theta, inla_cgeneric_data_tp * data) { + + double *ret = NULL; + double ltau, lkappa, tau, kappa, lnu, nu; + double alpha, nu_upper_bound; + int m_alpha; + double prior_nu_mean, prior_nu_loglocation, prior_nu_prec; + double prior_nu_logscale; + double start_nu; + int N, M, i, k, j, rspde_order; + double d; + char *prior_nu_dist, *parameterization, *theta_param; + int full_size, less_size; + int one = 1; + + + assert(!strcasecmp(data->ints[0]->name, "n")); // this will always be the case + N = data->ints[0]->ints[0]; // this will always be the case + assert(N > 0); + + assert(!strcasecmp(data->ints[1]->name, "debug")); // this will always be the case + int debug = data->ints[1]->ints[0]; // this will always be the case + + if(debug == 1){ + debug = 1; + } + + assert(!strcasecmp(data->ints[2]->name, "graph_opt_i")); + inla_cgeneric_vec_tp *graph_i = data->ints[2]; + M = graph_i->len; + + assert(!strcasecmp(data->ints[3]->name, "graph_opt_j")); + inla_cgeneric_vec_tp *graph_j = data->ints[3]; + assert(M == graph_j->len); + + assert(!strcasecmp(data->ints[4]->name, "rspde.order")); + rspde_order = data->ints[4]->ints[0]; + + assert(!strcasecmp(data->chars[2]->name, "prior.nu.dist")); + prior_nu_dist = &data->chars[2]->chars[0]; + + assert(!strcasecmp(data->chars[4]->name, "prior.theta.param")); + theta_param = &data->chars[4]->chars[0]; + + assert(!strcasecmp(data->chars[3]->name, "parameterization")); + parameterization = &data->chars[3]->chars[0]; + + assert(!strcasecmp(data->doubles[0]->name, "d")); + d = data->doubles[0]->doubles[0]; + + assert(!strcasecmp(data->doubles[1]->name, "nu.upper.bound")); + nu_upper_bound = data->doubles[1]->doubles[0]; + + alpha = nu_upper_bound + d / 2.0; + m_alpha = floor(alpha); + + assert(!strcasecmp(data->doubles[2]->name, "matrices_less")); + inla_cgeneric_vec_tp *fem_less = data->doubles[2]; + + assert(!strcasecmp(data->doubles[3]->name, "matrices_full")); + inla_cgeneric_vec_tp *fem_full = data->doubles[3]; + full_size = (fem_full->len)/(m_alpha+2); + less_size = (fem_less->len)/(m_alpha+1); + assert(M == rspde_order * full_size + less_size); + + + assert(!strcasecmp(data->mats[0]->name, "rational_table")); + inla_cgeneric_mat_tp *rational_table = data->mats[0]; + assert(rational_table->nrow == 999); + + // prior parameters + assert(!strcasecmp(data->doubles[4]->name, "start.theta")); + inla_cgeneric_vec_tp *start_theta = data->doubles[4]; + + assert(!strcasecmp(data->doubles[5]->name, "theta.prior.mean")); + inla_cgeneric_vec_tp *theta_prior_mean = data->doubles[5]; + + assert(!strcasecmp(data->mats[1]->name, "theta.prior.prec")); + inla_cgeneric_mat_tp *theta_prior_prec = data->mats[1]; + + assert(!strcasecmp(data->doubles[6]->name, "prior.nu.loglocation")); + prior_nu_loglocation = data->doubles[6]->doubles[0]; + + assert(!strcasecmp(data->doubles[7]->name, "prior.nu.mean")); + prior_nu_mean = data->doubles[7]->doubles[0]; + + assert(!strcasecmp(data->doubles[8]->name, "prior.nu.prec")); + prior_nu_prec = data->doubles[8]->doubles[0]; + + assert(!strcasecmp(data->doubles[9]->name, "prior.nu.logscale")); + prior_nu_logscale = data->doubles[9]->doubles[0]; + + assert(!strcasecmp(data->doubles[10]->name, "start.nu")); + start_nu = data->doubles[10]->doubles[0]; + + if (theta) { + // interpretable parameters + lnu = theta[2]; + nu = (exp(lnu)/(1.0 + exp(lnu))) * nu_upper_bound; + if(!strcasecmp(parameterization, "matern")){ + lkappa = 0.5 * log(8.0 * nu) - theta[1]; + ltau = - theta[0] + 0.5 *( + lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) + ); + } else if(!strcasecmp(parameterization, "matern2")) { + lkappa = - theta[1]; + ltau = - 0.5 * theta[0] + 0.5 *( + lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) + ); + } else { + ltau = theta[0]; + lkappa = theta[1]; + } + tau = exp(ltau); + kappa = exp(lkappa); + } + else { + ltau = lkappa = lnu = tau = kappa = nu = NAN; + } + + switch (cmd) { + case INLA_CGENERIC_VOID: + { + assert(!(cmd == INLA_CGENERIC_VOID)); + break; + } + + case INLA_CGENERIC_GRAPH: + { + k=2; + ret = Calloc(k + 2 * M, double); + ret[0] = N; /* dimension */ + ret[1] = M; /* number of (i <= j) */ + for (i = 0; i < M; i++) { + ret[k++] = graph_i->ints[i]; + } + for (i = 0; i < M; i++) { + ret[k++] = graph_j->ints[i]; + } + break; + } + + case INLA_CGENERIC_Q: + { + k = 2; + ret = Calloc(k + M, double); + ret[0] = -1; /* REQUIRED */ + ret[1] = M; /* REQUIRED */ + + int n_terms = 2*rspde_order + 2; + + double new_alpha = nu + d / 2.0; + + int new_m_alpha = (int) floor(new_alpha); + + double multQ = pow(kappa, 2*new_alpha) * SQR(tau); + + int row_nu = (int)round(1000*cut_decimals(new_alpha))-1; + + double *rat_coef = Calloc(n_terms-1, double); + + rat_coef = &rational_table->x[row_nu*n_terms+1]; + + double *r, *p, k_rat; + + r = Calloc(rspde_order, double); + p = Calloc(rspde_order, double); + + r = &rat_coef[0]; + p = &rat_coef[rspde_order]; + k_rat = rat_coef[2*rspde_order]; + + // FORTRAN IMPLEMENTATION + + + + switch(new_m_alpha){ + case 0: + { + double fact_mult; + for(j = 0; j < rspde_order; j++){ + fact_mult = multQ * (1-p[j])/r[j]; + dcopy_(&full_size, &fem_full->doubles[0], &one, &ret[k + j*full_size], &one); + dscal_(&full_size, &fact_mult, &ret[k+ j*full_size], &one); + fact_mult = multQ / (r[j] * SQR(kappa)); + daxpy_(&full_size, &fact_mult, &fem_full->doubles[full_size], &one, &ret[k+j*full_size], &one); + } + // dcopy_(&less_size, &fem_less->doubles[0], &one, &ret[k+rspde_order * full_size], &one); + // fact_mult = multQ/k_rat; + // dscal_(&less_size, &fact_mult, &ret[k+rspde_order * full_size], &one); + for(i = 0; i < less_size; i++){ + if(fem_less->doubles[i] != 0){ + ret[k+rspde_order*full_size + i] = multQ * ( + 1/(k_rat * fem_less->doubles[i]) + ); + } + } + break; + } + case 1: + { + double *Malpha2, fact_mult; + Malpha2 = Calloc(full_size, double); + for(j = 0; j < rspde_order; j++){ + dcopy_(&full_size, &fem_full->doubles[0], &one, &ret[k+j*full_size], &one); + fact_mult = 1/SQR(kappa); + daxpy_(&full_size, &fact_mult, &fem_full->doubles[full_size], &one, &ret[k+j*full_size], &one); + fact_mult = multQ * (1-p[j])/r[j]; + dscal_(&full_size, &fact_mult, &ret[k+j*full_size], &one); + dcopy_(&full_size, &fem_full->doubles[full_size], &one, Malpha2, &one); + fact_mult = 1/SQR(kappa); + daxpy_(&full_size, &fact_mult, &fem_full->doubles[2*full_size], &one, Malpha2, &one); + fact_mult = multQ/(SQR(kappa) * r[j]); + daxpy_(&full_size, &fact_mult, Malpha2, &one, &ret[k + j*full_size], &one); + } + + free(Malpha2); + + dcopy_(&less_size, &fem_less->doubles[0], &one, &ret[k+rspde_order*full_size], &one); + fact_mult = multQ/k_rat; + dscal_(&less_size, &fact_mult, &ret[k+rspde_order*full_size], &one); + fact_mult = multQ/(k_rat * SQR(kappa)); + daxpy_(&less_size, &fact_mult, &fem_less->doubles[less_size], &one, &ret[k+rspde_order*full_size], &one); + break; + } + default: + { + double *Malpha2, fact_mult; + Malpha2 = Calloc(full_size, double); + for(j = 0; j < rspde_order; j++){ + dcopy_(&full_size, &fem_full->doubles[0],&one, &ret[k+j*full_size], &one); + fact_mult = new_m_alpha/SQR(kappa); + daxpy_(&full_size, &fact_mult, &fem_full->doubles[full_size], &one, &ret[k+j*full_size], &one); + for(i = 2; i<= new_m_alpha; i++){ + fact_mult = nChoosek(new_m_alpha, i)/(pow(kappa, 2*i)); + daxpy_(&full_size, &fact_mult, &fem_full->doubles[i*full_size], &one, &ret[k+j*full_size], &one); + } + fact_mult = multQ * (1-p[j])/r[j]; + dscal_(&full_size, &fact_mult, &ret[k+j*full_size], &one); + dcopy_(&full_size, &fem_full->doubles[full_size], &one, Malpha2, &one); + fact_mult = new_m_alpha/SQR(kappa); + daxpy_(&full_size, &fact_mult, &fem_full->doubles[2*full_size], &one, Malpha2, &one); + for(i = 2; i<= new_m_alpha; i++){ + fact_mult = nChoosek(new_m_alpha, i)/(pow(kappa, 2*i)); + daxpy_(&full_size, &fact_mult, &fem_full->doubles[(i+1)*full_size], &one, Malpha2, &one); + } + fact_mult = multQ/(SQR(kappa) * r[j]); + daxpy_(&full_size, &fact_mult, Malpha2, &one, &ret[k + j*full_size], &one); + } + + free(Malpha2); + + dcopy_(&less_size, &fem_less->doubles[0], &one, &ret[k+rspde_order*full_size], &one); + fact_mult = multQ/k_rat; + dscal_(&less_size, &fact_mult, &ret[k+rspde_order*full_size], &one); + fact_mult = multQ * new_m_alpha/(k_rat * SQR(kappa)); + daxpy_(&less_size, &fact_mult, &fem_less->doubles[less_size], &one, &ret[k+rspde_order*full_size], &one); + for(j = 2; j<= new_m_alpha; j++){ + fact_mult = multQ * nChoosek(new_m_alpha, j)/(k_rat * pow(SQR(kappa),j)); + daxpy_(&less_size, &fact_mult, &fem_less->doubles[j*less_size], &one, &ret[k+rspde_order*full_size], &one); + } + break; + } + } + + // GSL IMPLEMENTATION + + // gsl_vector * FEM1 = gsl_vector_calloc(full_size); // C, then G, G_2, etc. + // gsl_vector * FEM2 = gsl_vector_calloc(full_size); // G, then G_2, G_3, etc., then part to be returned + + + + // switch(new_m_alpha){ + // case 0: + // { + // dcopy_(&full_size, &fem_full->doubles[0], &one, &FEM1->data[0], &one); + // for(j = 0; j < rspde_order; j++){ + // dcopy_(&full_size, &fem_full->doubles[full_size], &one, &FEM2->data[0], &one); + // gsl_vector_axpby(multQ * (1-p[j])/r[j], FEM1, multQ / (r[j] * SQR(kappa)), FEM2); + // dcopy_(&full_size, &FEM2->data[0], &one, &ret[k + j*full_size], &one); + // } + // gsl_vector_free(FEM1); + // gsl_vector_free(FEM2); + // gsl_vector * FEM1 = gsl_vector_calloc(less_size); // C, then G, G_2, etc. + // dcopy_(&less_size, &fem_less->doubles[0], &one, &FEM1->data[0], &one); + // gsl_vector_scale(FEM1, multQ/k_rat); + // dcopy_(&less_size, &FEM1->data[0], &one, &ret[k + rspde_order * full_size], &one); + // gsl_vector_free(FEM1); + // break; + // } + // case 1: + // { + // dcopy_(&full_size, &fem_full->doubles[0], &one, &FEM1->data[0], &one); + // dcopy_(&full_size, &fem_full->doubles[full_size], &one, &FEM2->data[0], &one); + // gsl_vector_axpby(1/SQR(kappa), FEM2, 1, FEM1); // FEM1 = M_alpha + // gsl_vector * FEM3 = gsl_vector_calloc(full_size); + // dcopy_(&full_size, &fem_full->doubles[2 * full_size], &one, &FEM3->data[0], &one); + // gsl_vector_axpby(1/SQR(kappa), FEM3, 1, FEM2); // FEM2 = M_alpha2 + // gsl_vector_memcpy(FEM3, FEM2); + // for(j = 0; j < rspde_order; j++){ + // gsl_vector_axpby(multQ * (1-p[j])/r[j], FEM1, multQ/(SQR(kappa) * r[j]), FEM2); //FEM2 -> part of Q + // dcopy_(&full_size, &FEM2->data[0], &one, &ret[k + j*full_size], &one); + // gsl_vector_memcpy(FEM2, FEM3); + // } + // // Add k part + // gsl_vector_free(FEM1); + // gsl_vector_free(FEM2); + // gsl_vector_free(FEM3); + // gsl_vector * FEM1 = gsl_vector_calloc(less_size); + // gsl_vector * FEM2 = gsl_vector_calloc(less_size); + // dcopy_(&less_size, &fem_less->doubles[0], &one, &FEM1->data[0], &one); // copy C back to FEM1 + // dcopy_(&less_size, &fem_less->doubles[less_size], &one, &FEM2->data[0], &one); + // gsl_vector_axpby(multQ/(k_rat * SQR(kappa)), FEM2, multQ/k_rat, FEM1); + // dcopy_(&less_size, &FEM1->data[0], &one, &ret[k + rspde_order * full_size], &one); + // gsl_vector_free(FEM1); + // gsl_vector_free(FEM2); + // break; + // } + // default: + // { + // dcopy_(&full_size, &fem_full->doubles[0], &one, &FEM1->data[0], &one); + // gsl_vector * FEM3 = gsl_vector_calloc(full_size); + // dcopy_(&full_size, &fem_full->doubles[full_size], &one, &FEM2->data[0], &one); + // gsl_vector_axpby(new_m_alpha/SQR(kappa), FEM2, 1, FEM1); // FEM1 = M_alpha + // for(j = 2; j<= new_m_alpha; j++){ + // dcopy_(&full_size, &fem_full->doubles[j * full_size], &one, &FEM3->data[0], &one); + // gsl_vector_axpby(nChoosek(new_m_alpha, j)/(pow(kappa, 2*j)), FEM3, 1, FEM1); + // } + // dcopy_(&full_size, &fem_full->doubles[2 * full_size], &one, &FEM3->data[0], &one); + // gsl_vector_axpby(new_m_alpha/SQR(kappa), FEM3, 1, FEM2); // FEM2 = M_alpha2 + // for(j = 2; j<= new_m_alpha; j++){ + // dcopy_(&full_size, &fem_full->doubles[(j+1) * full_size], &one, &FEM3->data[0], &one); + // gsl_vector_axpby(nChoosek(new_m_alpha, j)/(pow(kappa,2*j)), FEM3, 1, FEM2); + // } + + + // gsl_vector_memcpy(FEM3, FEM2); + // for(j = 0; j < rspde_order; j++){ + // gsl_vector_axpby(multQ * (1-p[j])/r[j], FEM1, multQ/(SQR(kappa) * r[j]), FEM2); //FEM2 -> part of Q + // dcopy_(&full_size, &FEM2->data[0], &one, &ret[k + j*full_size], &one); + // gsl_vector_memcpy(FEM2, FEM3); + // } + // // Add k part + // gsl_vector_free(FEM1); + // gsl_vector_free(FEM2); + // gsl_vector_free(FEM3); + // gsl_vector * FEM1 = gsl_vector_calloc(less_size); + // gsl_vector * FEM2 = gsl_vector_calloc(less_size); + // dcopy_(&less_size, &fem_less->doubles[0], &one, &FEM1->data[0], &one); // copy C back to FEM1 + // dcopy_(&less_size, &fem_less->doubles[less_size], &one, &FEM2->data[0], &one); + // gsl_vector_axpby(multQ * new_m_alpha/(k_rat * SQR(kappa)), FEM2, multQ/k_rat, FEM1); + // for(j = 2; j<= new_m_alpha; j++){ + // dcopy_(&less_size, &fem_less->doubles[j * less_size], &one, &FEM2->data[0], &one); + // gsl_vector_axpby(multQ * nChoosek(new_m_alpha, j)/(k_rat * pow(SQR(kappa),j)), FEM2, 1, FEM1); + // } + // dcopy_(&less_size, &FEM1->data[0], &one, &ret[k + rspde_order * full_size], &one); + // gsl_vector_free(FEM1); + // gsl_vector_free(FEM2); + // break; + // } + // } + + // DIRECT C IMPLEMENTATION + + // double *Malpha, *Malpha2; + + + // // double multQ = pow(kappa, 2*new_alpha) * SQR(tau); + + // if(new_m_alpha == 0){ + // for(j = 0; j < rspde_order; j++){ + // for(i = 0; i < full_size; i++){ + // ret[k + j*full_size + i] = multQ * ( + // (fem_full->doubles[i] + (fem_full->doubles[full_size+i])/(SQR(kappa))) - + // (p[j] * fem_full->doubles[i]) + // ) / r[j]; + // } + // } + + // // Kpart + // for(i = 0; i < less_size; i++){ + // ret[k+rspde_order*full_size + i] = multQ * ( + // fem_less->doubles[i]/k_rat + // ); + // } + + // } else{ + + // Malpha = Calloc(full_size, double); + // Malpha2 = Calloc(full_size, double); + + // if(new_m_alpha == 1){ + // // for(i = 0; i < full_size; i++){ + // // Malpha[i] = fem_full->doubles[i] + (fem_full->doubles[full_size+i])/(SQR(kappa)); + // // Malpha2[i] = fem_full->doubles[full_size+i] + (fem_full->doubles[2*full_size+i])/(SQR(kappa)); + // // } + // for(i = 0; i < full_size; i++){ + // Malpha[i] = fem_full->doubles[i] + (fem_full->doubles[full_size+i])/(SQR(kappa)); + // } + // for(i = 0; i < full_size; i++){ + // Malpha2[i] = fem_full->doubles[full_size+i] + (fem_full->doubles[2*full_size+i])/(SQR(kappa)); + // } + // } else if(new_m_alpha > 1){ + // // for(i = 0; i < full_size; i++){ + // // Malpha[i] = fem_full->doubles[i] + new_m_alpha * (fem_full->doubles[full_size+i])/(SQR(kappa)); + // // for(j = 2; j <= new_m_alpha; j++){ + // // Malpha[i] += nChoosek(new_m_alpha, j) * (fem_full->doubles[j*full_size+i])/(pow(kappa, 2*j)); + // // } + + // // Malpha2[i] = fem_full->doubles[full_size+i] + new_m_alpha * (fem_full->doubles[2*full_size+i])/(SQR(kappa)); + // // for(j = 2; j <= new_m_alpha ; j++){ + // // Malpha2[i] += nChoosek(new_m_alpha, j) * (fem_full->doubles[(j+1)*full_size + i])/(pow(kappa,2*j)); + // // } + // // } + + // for(i = 0; i < full_size; i++){ + // Malpha[i] = fem_full->doubles[i] + new_m_alpha * (fem_full->doubles[full_size+i])/(SQR(kappa)); + // for(j = 2; j <= new_m_alpha; j++){ + // Malpha[i] += nChoosek(new_m_alpha, j) * (fem_full->doubles[j*full_size+i])/(pow(kappa, 2*j)); + // } + // } + // for(i = 0; i < full_size; i++){ + // Malpha2[i] = fem_full->doubles[full_size+i] + new_m_alpha * (fem_full->doubles[2*full_size+i])/(SQR(kappa)); + // for(j = 2; j <= new_m_alpha ; j++){ + // Malpha2[i] += nChoosek(new_m_alpha, j) * (fem_full->doubles[(j+1)*full_size + i])/(pow(kappa,2*j)); + // } + // } + // } + + // for(j = 0; j < rspde_order; j++){ + // for(i = 0; i < full_size; i++){ + // ret[k + j * full_size + i] = multQ * ( + // (1-p[j]) * Malpha[i] + (Malpha2[i])/(SQR(kappa)) + // )/(r[j]); + // } + // } + + // if(new_m_alpha == 1){ + + // for(i = 0; i < less_size; i++){ + // ret[k+rspde_order*full_size + i] = multQ/(k_rat) * ( + // fem_less->doubles[i] + (fem_less->doubles[less_size+i])/(SQR(kappa)) + // ); + // } + // } else{ + + // for(i = 0; i < less_size; i++){ + // ret[k+rspde_order*full_size + i] = multQ/(k_rat) * ( + // fem_less->doubles[i] + (new_m_alpha/SQR(kappa)) * fem_less->doubles[less_size+i] + // ); + // for(j = 2; j <= new_m_alpha ; j++){ + // ret[k+rspde_order*full_size + i] += multQ/(k_rat) * ( + // nChoosek(new_m_alpha,j)*(fem_less->doubles[i + j*less_size])/(pow(kappa,2*j)) + // ); + // } + // } + // } + + // } + + break; + } + + case INLA_CGENERIC_MU: + { + ret = Calloc(1, double); + ret[0] = 0.0; + break; + } + + case INLA_CGENERIC_INITIAL: + { + // return c(P, initials) + // where P is the number of hyperparameters + ret = Calloc(4, double); + ret[0] = 3; + ret[1] = start_theta->doubles[0]; + ret[2] = start_theta->doubles[1]; + ret[3] = log(start_nu/(nu_upper_bound - start_nu)); + break; + } + + case INLA_CGENERIC_LOG_NORM_CONST: + { + break; + } + + case INLA_CGENERIC_LOG_PRIOR: + { + ret = Calloc(1, double); + + ret[0] = 0.0; + + if(!strcasecmp(prior_nu_dist, "lognormal")){ + ret[0] += -0.5 * SQR(lnu - prior_nu_loglocation)/(SQR(prior_nu_logscale)); + ret[0] += -log(prior_nu_logscale) - 0.5 * log(2.0*M_PI); + ret[0] -= log(pnorm(log(nu_upper_bound), prior_nu_loglocation, prior_nu_logscale)); + } + else { // if(!strcasecmp(prior_nu_dist, "beta")){ + double s_1 = (prior_nu_mean / nu_upper_bound) * prior_nu_prec; + double s_2 = (1 - prior_nu_mean / nu_upper_bound) * prior_nu_prec; + ret[0] += logdbeta(nu / nu_upper_bound, s_1, s_2) - log(nu_upper_bound); + } + + if(!strcasecmp(theta_param, "theta") || !strcasecmp(parameterization, "spde")){ + ret[0] += logmultnormvdens(2, theta_prior_mean->doubles, + theta_prior_prec->x, theta); + } + else { + double theta_prior_mean_spde[2], theta_spde[2], prior_nu_tmp; + if(!strcasecmp(prior_nu_dist, "lognormal")){ + prior_nu_tmp = exp(prior_nu_loglocation); + } + else{ + prior_nu_tmp = prior_nu_mean; + } + theta_spde[1] = lkappa; + theta_spde[0] = ltau; + theta_prior_mean_spde[1] = 0.5 * log(8.0 * prior_nu_tmp) - theta_prior_mean->doubles[1]; + theta_prior_mean_spde[0] = - theta_prior_mean->doubles[0] + 0.5 *( + lgamma(prior_nu_tmp) - 2.0 * prior_nu_tmp * theta_prior_mean_spde[1] - + (d/2.0) * log(4 * M_PI) - lgamma(prior_nu_tmp + d/2.0) + ); + + ret[0] += logmultnormvdens(2, theta_prior_mean_spde, + theta_prior_prec->x, theta_spde); + } + + break; + } + + case INLA_CGENERIC_QUIT: + default: + break; + } + + return (ret); +} \ No newline at end of file diff --git a/src/cgeneric_rspde_stat_int.c b/src/cgeneric_rspde_stat_int.c new file mode 100644 index 00000000..1d5c9061 --- /dev/null +++ b/src/cgeneric_rspde_stat_int.c @@ -0,0 +1,637 @@ +#include "cgeneric_defs.h" +// #include "stdio.h" +// #include "gsl/gsl_vector_double.h" + +double nChoosek( int n, int k ){ + if (k > n) return 0; + if (k * 2 > n) k = n-k; + if (k == 0) return 1; + + int result = n; + for( int i = 2; i <= k; ++i ) { + result *= (n-i+1); + result /= i; + } + return (double) result; +} + +// This version uses 'padded' matrices with zeroes +double *inla_cgeneric_rspde_stat_int_model(inla_cgeneric_cmd_tp cmd, double *theta, inla_cgeneric_data_tp * data) { + + double *ret = NULL; + double ltau, lkappa, tau, kappa; + double nu; + char *parameterization, *theta_param; + + int N, M, i, k, j; + + assert(!strcasecmp(data->ints[0]->name, "n")); // this will always be the case + N = data->ints[0]->ints[0]; // this will always be the case + assert(N > 0); + + assert(!strcasecmp(data->ints[1]->name, "debug")); // this will always be the case + int debug = data->ints[1]->ints[0]; // this will always be the case + + if(debug == 1){ + debug = 1; + } + + assert(!strcasecmp(data->ints[2]->name, "m_alpha")); + int m_alpha = data->ints[2]->ints[0]; + + assert(!strcasecmp(data->ints[3]->name, "graph_opt_i")); + inla_cgeneric_vec_tp *graph_i = data->ints[3]; + M = graph_i->len; + + assert(!strcasecmp(data->ints[4]->name, "graph_opt_j")); + inla_cgeneric_vec_tp *graph_j = data->ints[4]; + assert(M == graph_j->len); + + assert(!strcasecmp(data->chars[2]->name, "parameterization")); + parameterization = &data->chars[2]->chars[0]; + + assert(!strcasecmp(data->chars[3]->name, "prior.theta.param")); + theta_param = &data->chars[3]->chars[0]; + + // assert(!strcasecmp(data->ints[5]->name, "positions_C")); + // inla_cgeneric_vec_tp *positions_C = data->ints[5]; + + // assert(!strcasecmp(data->ints[6]->name, "positions_G")); + // inla_cgeneric_vec_tp *positions_G = data->ints[6]; + + assert(!strcasecmp(data->doubles[0]->name, "matrices_less")); + inla_cgeneric_vec_tp *fem = data->doubles[0]; + assert(M*(m_alpha+1) == fem->len); + + // prior parameters + assert(!strcasecmp(data->doubles[1]->name, "theta.prior.mean")); + inla_cgeneric_vec_tp *theta_prior_mean = data->doubles[1]; + + assert(!strcasecmp(data->mats[0]->name, "theta.prior.prec")); + inla_cgeneric_mat_tp *theta_prior_prec = data->mats[0]; + + assert(!strcasecmp(data->doubles[2]->name, "start.theta")); + inla_cgeneric_vec_tp *start_theta = data->doubles[2]; + + assert(!strcasecmp(data->doubles[3]->name, "nu")); + nu = data->doubles[3]->doubles[0]; + + int d = (int) 2 * (m_alpha - nu); + + if (theta) { + // interpretable parameters + if(!strcasecmp(parameterization, "matern")){ + lkappa = 0.5 * log(8.0 * nu) - theta[1]; + ltau = - theta[0] + 0.5 *( + lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) + ); + } else if(!strcasecmp(parameterization, "matern2")) { + lkappa = - theta[1]; + ltau = - 0.5 * theta[0] + 0.5 *( + lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) + ); + } else { + ltau = theta[0]; + lkappa = theta[1]; + } + tau = exp(ltau); + kappa = exp(lkappa); + } + else { + ltau = lkappa = tau = kappa = NAN; + } + + switch (cmd) { + case INLA_CGENERIC_VOID: + { + assert(!(cmd == INLA_CGENERIC_VOID)); + break; + } + + case INLA_CGENERIC_GRAPH: + { + k=2; + ret = Calloc(k + 2 * M, double); + ret[0] = N; /* dimension */ + ret[1] = M; /* number of (i <= j) */ + for (i = 0; i < M; i++) { + ret[k++] = graph_i->ints[i]; + } + for (i = 0; i < M; i++) { + ret[k++] = graph_j->ints[i]; + } + break; + } + + case INLA_CGENERIC_Q: + { + k = 2; + ret = Calloc(k + M, double); + ret[0] = -1; /* REQUIRED */ + ret[1] = M; /* REQUIRED */ + + // int one = 1; + // gsl_vector * GC = gsl_vector_calloc (M); // First G then C + // gsl_vector * retG2 = gsl_vector_calloc (M); // first G2 then return + + // dcopy_(&M, &fem->doubles[2*M], &one, &retG2->data[0], &one); + // dcopy_(&M, &fem->doubles[M], &one, &GC->data[0], &one); + // gsl_vector_axpby(2*SQR(tau)*SQR(kappa), GC, SQR(tau), retG2); + // dcopy_(&M, &fem->doubles[0], &one, &GC->data[0], &one); + // gsl_vector_axpby(SQR(tau)*SQR(kappa*kappa), GC, 1, retG2); + // dcopy_(&M, &retG2->data[0], &one, &ret[k], &one); + + + // gsl_vector * retV = gsl_vector_calloc(M); + // gsl_vector_memcpy(retV, G2); + + // gsl_vector_axpby(2*SQR(tau)*SQR(kappa), G, SQR(tau), retV); + // gsl_vector_axpby(SQR(tau)*SQR(kappa*kappa), C, 1, retV); + // dcopy_(&M, &retV->data[0], &one, &ret[k], &one); + + + // dscal_(&M, &sqtau, &ret[k], &one); + // for(i = 0; i < positions_C->len; i++){ + // ret[k + positions_G->ints[i]-1] += 2*SQR(tau) * SQR(kappa) * fem->doubles[M+positions_G->ints[i]-1]; + // ret[k + positions_C->ints[i]-1] += SQR(tau) * SQR(kappa * kappa) * fem->doubles[positions_C->ints[i]-1]; + // } + // for(i = positions_C->len; ilen; i++){ + // ret[k + positions_G->ints[i]-1] += 2*SQR(tau) * SQR(kappa) * fem->doubles[M+positions_G->ints[i]-1]; + // } + + // Direct version: + + // if(m_alpha == 1){ + // for (i = 0; i < M; i++) { + // ret[k + i] = SQR(tau) * (SQR(kappa) * fem->doubles[i] + fem->doubles[M+i]); + // } + // } + // else if(m_alpha > 1){ + // for (i = 0; i < M; i++) { + // ret[k + i] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[i] + m_alpha * + // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[M+i]); + + // if(m_alpha>=2){ + // for(j = 0; j <= (m_alpha-2); j++){ + // ret[k + i] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(j+2)*M+i]); + // } + // } + + // } + // } + + // Currently the faster version: + + // if(m_alpha == 1){ + // for (i = 0; i < M; i++) { + // ret[k + i] = SQR(tau) * (SQR(kappa) * fem->doubles[2*i] + fem->doubles[2*i+1]); + // } + // } + // else if(m_alpha > 1){ + // int quot = M/4; + // int remainder = M%4; + // for (i = 0; i < quot; i++) { + // ret[k + 4*i] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (4*i)] + m_alpha * + // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (4*i) + 1]); + + // if(m_alpha>=2){ + // for(j = 0; j <= (m_alpha-2); j++){ + // ret[k + 4*i] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(4*i)+(j+2)]); + // } + // } + + // ret[k + 4*i+1] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (4*i+1)] + m_alpha * + // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (4*i+1) + 1]); + + // if(m_alpha>=2){ + // for(j = 0; j <= (m_alpha-2); j++){ + // ret[k + 4*i+1] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(4*i+1)+(j+2)]); + // } + // } + + // ret[k + 4*i + 2] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (4*i+2)] + m_alpha * + // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (4*i+2) + 1]); + + // if(m_alpha>=2){ + // for(j = 0; j <= (m_alpha-2); j++){ + // ret[k + 4*i + 2] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(4*i+2)+(j+2)]); + // } + // } + + // ret[k + 4*i + 3] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (4*i+3)] + m_alpha * + // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (4*i+3) + 1]); + + // if(m_alpha>=2){ + // for(j = 0; j <= (m_alpha-2); j++){ + // ret[k + 4*i + 3] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(4*i+3)+(j+2)]); + // } + // } + // } + + // if(remainder > 0){ + // for(i = 0; i < remainder; i++){ + // ret[k+4*quot + i] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (4*quot+i)] + m_alpha * + // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (4*quot+i)+1]); + // if(m_alpha>=2){ + // for(j = 0; j <= (m_alpha-2); j++){ + // ret[k + 4*quot + i] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(4*quot+i)+(j+2)]); + // } + // } + // } + // } + + // } + +// THE FASTEST!!! + + // if(m_alpha == 1){ + // for (i = 0; i < M; i++) { + // ret[k + i] = SQR(tau) * (SQR(kappa) * fem->doubles[2*i] + fem->doubles[2*i+1]); + // } + // } + // else if(m_alpha > 1){ + // int quot = M/3; + // int remainder = M%3; + // for (i = 0; i < quot; i++) { + // ret[k + 3*i] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (3*i)] + m_alpha * + // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (3*i) + 1]); + + // if(m_alpha>=2){ + // for(j = 0; j <= (m_alpha-2); j++){ + // ret[k + 3*i] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(3*i)+(j+2)]); + // } + // } + + // ret[k + 3*i+1] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (3*i+1)] + m_alpha * + // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (3*i+1) + 1]); + + // if(m_alpha>=2){ + // for(j = 0; j <= (m_alpha-2); j++){ + // ret[k + 3*i+1] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(3*i+1)+(j+2)]); + // } + // } + + // ret[k + 3*i + 2] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (3*i+2)] + m_alpha * + // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (3*i+2) + 1]); + + // if(m_alpha>=2){ + // for(j = 0; j <= (m_alpha-2); j++){ + // ret[k + 3*i + 2] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(3*i+2)+(j+2)]); + // } + // } + // } + // if(remainder > 0){ + // for(i = 0; i < remainder; i++){ + // ret[k+3*quot + i] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (3*quot+i)] + m_alpha * + // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (3*quot+i)+1]); + // if(m_alpha>=2){ + // for(j = 0; j <= (m_alpha-2); j++){ + // ret[k + 3*quot + i] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(3*quot+i)+(j+2)]); + // } + // } + // } + // } + + // } + + + // Testing other splits: + + // if(m_alpha == 1){ + // for (i = 0; i < M; i++) { + // ret[k + i] = SQR(tau) * (SQR(kappa) * fem->doubles[2*i] + fem->doubles[2*i+1]); + // } + // } + // else if(m_alpha > 1){ + // int quot = M/6; + // int remainder = M%6; + // for (i = 0; i < quot; i++) { + // ret[k + 6*i] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (6*i)] + m_alpha * + // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (6*i) + 1]); + + // if(m_alpha>=2){ + // for(j = 0; j <= (m_alpha-2); j++){ + // ret[k + 6*i] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(6*i)+(j+2)]); + // } + // } + + // ret[k + 6*i+1] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (6*i+1)] + m_alpha * + // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (6*i+1) + 1]); + + // if(m_alpha>=2){ + // for(j = 0; j <= (m_alpha-2); j++){ + // ret[k + 6*i+1] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(6*i+1)+(j+2)]); + // } + // } + + // ret[k + 6*i + 2] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (6*i+2)] + m_alpha * + // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (6*i+2) + 1]); + + // if(m_alpha>=2){ + // for(j = 0; j <= (m_alpha-2); j++){ + // ret[k + 6*i + 2] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(6*i+2)+(j+2)]); + // } + // } + + // ret[k + 6*i + 3] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (6*i+3)] + m_alpha * + // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (6*i+3) + 1]); + + // if(m_alpha>=2){ + // for(j = 0; j <= (m_alpha-2); j++){ + // ret[k + 6*i + 3] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(6*i+3)+(j+2)]); + // } + // } + + // ret[k + 6*i + 4] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (6*i+4)] + m_alpha * + // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (6*i+4) + 1]); + + // if(m_alpha>=2){ + // for(j = 0; j <= (m_alpha-2); j++){ + // ret[k + 6*i + 4] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(6*i+4)+(j+2)]); + // } + // } + + // ret[k + 6*i + 5] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (6*i+5)] + m_alpha * + // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (6*i+5) + 1]); + + // if(m_alpha>=2){ + // for(j = 0; j <= (m_alpha-2); j++){ + // ret[k + 6*i + 5] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(6*i+5)+(j+2)]); + // } + // } + // } + + // for(i = 0; i < remainder; i++){ + // ret[k+6*quot + i] = SQR(tau)*(pow(kappa, 2 * m_alpha) * fem->doubles[(m_alpha+1) * (6*quot+i)] + m_alpha * + // pow(kappa, 2 * (m_alpha-1)) * fem->doubles[(m_alpha+1) * (6*quot+i)+1]); + // if(m_alpha>=2){ + // for(j = 0; j <= (m_alpha-2); j++){ + // ret[k + 6*quot + i] += SQR(tau) * (pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2) * fem->doubles[(m_alpha+1)*(6*quot+i)+(j+2)]); + // } + // } + // } + + // } + + + // // Fortran implementation + // double sqtau, sqtaukappa, sqtaukappatmp, sqkappatau1, sqkappatau2; + // int one=1; + // sqtau = SQR(tau); + // sqtaukappa = SQR(tau) * SQR(kappa); + // sqkappatau1 = SQR(tau) * SQR(kappa*kappa); + // sqkappatau2 = SQR(tau) * 2 * SQR(kappa); + // if(m_alpha == 1){ + // dcopy_(&M, &fem->doubles[0], &one, &ret[k], &one); + // dscal_(&M, &sqtaukappa, &ret[k], &one); + // daxpy_(&M, &sqtau, &fem->doubles[M], &one, &ret[k], &one); + // } else if (m_alpha == 2){ + // dcopy_(&M, &fem->doubles[0], &one, &ret[k], &one); + // dscal_(&M, &sqkappatau1, &ret[k], &one); + // daxpy_(&M, &sqkappatau2, &fem->doubles[M], &one, &ret[k], &one); + // daxpy_(&M, &sqtau, &fem->doubles[2*M], &one, &ret[k], &one); + // } else{ + // sqkappatau1 = SQR(tau) * pow(kappa, 2 * m_alpha); + // sqkappatau2 = SQR(tau) * m_alpha * pow(kappa, 2 * (m_alpha - 1)); + // dcopy_(&M, &fem->doubles[0], &one, &ret[k], &one); + // dscal_(&M, &sqkappatau1, &ret[k], &one); + // daxpy_(&M, &sqkappatau2, &fem->doubles[M], &one, &ret[k], &one); + // if(m_alpha>=2){ + // for(j = 2; j<= m_alpha; j++){ + // sqtaukappatmp = SQR(tau) * pow(kappa, 2*(m_alpha-j)) * nChoosek(m_alpha, j); + // daxpy_(&M, &sqtaukappatmp, &fem->doubles[j*M], &one, &ret[k], &one); + // } + // } + // } + + // More compact + int one = 1; + double sqkappatau1 = SQR(tau) * pow(kappa, 2 * m_alpha); + double sqkappatau2 = SQR(tau) * m_alpha * pow(kappa, 2 * (m_alpha - 1)); + double sqtaukappatmp; + dcopy_(&M, &fem->doubles[0], &one, &ret[k], &one); + dscal_(&M, &sqkappatau1, &ret[k], &one); + daxpy_(&M, &sqkappatau2, &fem->doubles[M], &one, &ret[k], &one); + if(m_alpha>=2){ + for(j = 2; j<= m_alpha; j++){ + sqtaukappatmp = SQR(tau) * pow(kappa, 2*(m_alpha-j)) * nChoosek(m_alpha, j); + daxpy_(&M, &sqtaukappatmp, &fem->doubles[j*M], &one, &ret[k], &one); + } + } + + // Fortran matrix product version + + // double sqtau, sqtaukappa, sqtaukappatmp, sqkappatau1, sqkappatau2; + // int one=1; + + // dcopy_(&M, &fem->doubles[0], &one, &ret[k], &one); + // if(m_alpha == 1){ + + // sqtau = SQR(tau); + // sqtaukappa = SQR(tau) * SQR(kappa); + // double *coeff_vec; + // coeff_vec = Calloc(2, double); + // coeff_vec[0] = sqtaukappa; + // coeff_vec[1] = sqtau; + + // int two = 2; + // double d_one = 1.0, d_zero = 0.0; + + // char char_tmp; + // char_tmp = 'T'; + + // dgemv_(&char_tmp, &two, &M, &d_one, &fem->doubles[0], &two, coeff_vec, &one, &d_zero, &ret[k], &one); + + + + // } else if (m_alpha == 2){ + + // sqtau = SQR(tau); + // sqkappatau1 = SQR(tau) * SQR(kappa*kappa); + // sqkappatau2 = SQR(tau) * 2.0 * SQR(kappa); + // double *coeff_vec; + // coeff_vec = Calloc(3, double); + // coeff_vec[0] = sqkappatau1; + // coeff_vec[1] = sqkappatau2; + // coeff_vec[2] = sqtau; + + // int three = 3; + // double d_one = 1.0, d_zero = 0.0; + + // char char_tmp; + // char_tmp = 'T'; + + // dgemv_(&char_tmp, &three, &M, &d_one, &fem->doubles[0], &three, coeff_vec, &one, &d_zero, &ret[k], &one); + + // } else{ + + // double sqkappatau1 = SQR(tau) * pow(kappa, 2 * m_alpha); + // double sqkappatau2 = SQR(tau) * m_alpha * pow(kappa, 2 * (m_alpha - 1)); + // double *coeff_vec; + // coeff_vec = Calloc(m_alpha+1, double); + // coeff_vec[0] = sqkappatau1; + // coeff_vec[1] = sqkappatau2; + + // if(m_alpha>=2){ + // for(j = 2; j<= m_alpha; j++){ + // sqtaukappatmp = SQR(tau) * pow(kappa, 2.0*(m_alpha-j)) * nChoosek(m_alpha, j); + // coeff_vec[j] = sqtaukappatmp; + // } + // } + + // int m_alpha_plus_one = m_alpha+1; + // double d_one = 1.0, d_zero = 0.0; + + // char char_tmp; + // char_tmp = 'T'; + + // dgemv_(&char_tmp, &m_alpha_plus_one, &M, &d_one, &fem->doubles[0], &m_alpha_plus_one, coeff_vec, &one, &d_zero, &ret[k], &one); + + // } + + // Version using sparsity + + // double sqtau = SQR(tau); + // int one=1; + // if(m_alpha == 1){ + // // int one=1; + // dcopy_(&M, &fem->doubles[0], &one, &ret[k], &one); + // dscal_(&M, &sqtau, &ret[k], &one); + // } else if (m_alpha == 2){ + // // int one=1; + // dcopy_(&M, &fem->doubles[2*M], &one, &ret[k], &one); + // dscal_(&M, &sqtau, &ret[k], &one); + // for(i = 0; i < positions_C->len; i++){ + // ret[k + positions_G->ints[i]-1] += 2*SQR(tau) * SQR(kappa) * fem->doubles[M+positions_G->ints[i]-1]; + // ret[k + positions_C->ints[i]-1] += SQR(tau) * SQR(kappa * kappa) * fem->doubles[positions_C->ints[i]-1]; + // } + // for(i = positions_C->len; ilen; i++){ + // ret[k + positions_G->ints[i]-1] += 2*SQR(tau) * SQR(kappa) * fem->doubles[M+positions_G->ints[i]-1]; + // } + + // } else{ + // // int one=1; + // } + + + + + + // switch(m_alpha){ + // double sqtau = SQR(tau); + // double sqtaukappa = SQR(tau) * SQR(kappa); + // double sqkappatau1 = SQR(tau) * SQR(kappa*kappa); + // double sqkappatau2 = SQR(tau) * 2 * SQR(kappa); + // double sqtaukappatmp; + // int one=1; + // dcopy_(&M, &fem->doubles[M], &one, &ret[k], &one); + // dscal_(&M, &sqtau, &ret[k], &one); + // daxpy_(&M, &sqtaukappa, &fem->doubles[0], &one, &ret[k], &one); + + // case 1: + // { + // dscal_(&M, &sqtaukappa, &ret[k], &one); + // daxpy_(&M, &sqtau, &fem->doubles[M], &one, &ret[k], &one); + // break; + // } case 2: + // { + // dscal_(&M, &sqkappatau1, &ret[k], &one); + // daxpy_(&M, &sqkappatau2, &fem->doubles[M], &one, &ret[k], &one); + // daxpy_(&M, &sqtau, &fem->doubles[2*M], &one, &ret[k], &one); + // break; + // } + // default: + // { + // dscal_(&M, &sqkappatau1, &ret[k], &one); + // daxpy_(&M, &sqkappatau2, &fem->doubles[M], &one, &ret[k], &one); + // if(m_alpha>=2){ + // for(j = 2; j<= m_alpha; j++){ + // sqkappatau1 = SQR(tau) * pow(kappa, 2 * m_alpha); + // sqkappatau2 = SQR(tau) * m_alpha * pow(kappa, 2 * (m_alpha - 1)); + // sqtaukappatmp = SQR(tau) * pow(kappa, 2*(m_alpha-j)) * nChoosek(m_alpha, j); + // daxpy_(&M, &sqtaukappatmp, &fem->doubles[j*M], &one, &ret[k], &one); + // } + // } + // break; + // } + // } + + + // if(m_alpha == 1){ + // double sqtau = SQR(tau); + // double sqtaukappa = SQR(tau) * SQR(kappa); + // int one=1; + // daxpby_(&M, &sqtaukappa, &fem->doubles[0], &one, &sqtau, &fem->doubles[M], &one, &ret[k]); + // } else { + // int one=1; + // double sqkappatau1 = SQR(tau) * pow(kappa, 2 * m_alpha); + // double sqkappatau2 = SQR(tau) * m_alpha * pow(kappa, 2 * (m_alpha - 1)); + // daxpby_(&M, &sqkappatau2, &fem->doubles[M], &one ,&sqkappatau1, &fem->doubles[0], &one, &ret[k]); + // if(m_alpha>=2){ + // for(j = 0; j<= (m_alpha-2); j++){ + // double sqtaukappatmp = SQR(tau) * pow(kappa, 2*(m_alpha-j-2)) * nChoosek(m_alpha, j+2); + // daxpy_(&M, &sqtaukappatmp, &fem->doubles[(j+2)*M], &one, &ret[k], &one); + // } + // } + // } + + break; + } + + case INLA_CGENERIC_MU: + { + ret = Calloc(1, double); + ret[0] = 0.0; + break; + } + + case INLA_CGENERIC_INITIAL: + { + // return c(P, initials) + // where P is the number of hyperparameters + ret = Calloc(3, double); + ret[0] = 2; + ret[1] = start_theta->doubles[0]; + ret[2] = start_theta->doubles[1]; + break; + } + + case INLA_CGENERIC_LOG_NORM_CONST: + { + break; + } + + case INLA_CGENERIC_LOG_PRIOR: + { + ret = Calloc(1, double); + + ret[0] = 0.0; + + if(!strcasecmp(theta_param, "theta") || !strcasecmp(parameterization, "spde")){ + ret[0] += logmultnormvdens(2, theta_prior_mean->doubles, + theta_prior_prec->x, theta); + } + else { + double theta_prior_mean_spde[2], theta_spde[2]; + theta_spde[1] = lkappa; + theta_spde[0] = ltau; + theta_prior_mean_spde[1] = 0.5 * log(8.0 * nu) - theta_prior_mean->doubles[1]; + theta_prior_mean_spde[0] = - theta_prior_mean->doubles[0] + 0.5 *( + lgamma(nu) - 2.0 * nu * theta_prior_mean_spde[1] - + (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) + ); + + ret[0] += logmultnormvdens(2, theta_prior_mean_spde, + theta_prior_prec->x, theta_spde); + } + + break; + } + + case INLA_CGENERIC_QUIT: + default: + break; + } + + return (ret); +} \ No newline at end of file diff --git a/src/cgeneric_rspde_stat_parsim_fixed.c b/src/cgeneric_rspde_stat_parsim_fixed.c new file mode 100644 index 00000000..6b4c806d --- /dev/null +++ b/src/cgeneric_rspde_stat_parsim_fixed.c @@ -0,0 +1,196 @@ + +#include "cgeneric_defs.h" +#include + + +// This version uses 'padded' matrices with zeroes +double *inla_cgeneric_rspde_stat_parsim_fixed_model(inla_cgeneric_cmd_tp cmd, double *theta, inla_cgeneric_data_tp * data) { + double *ret = NULL; + double ltau, lkappa, tau, kappa, nu; + double alpha; + int m_alpha; + int N, M, i, k; + double d; + char *parameterization, *theta_param; + int fem_size; + int one = 1; + + assert(!strcasecmp(data->ints[0]->name, "n")); // this will always be the case + N = data->ints[0]->ints[0]; // this will always be the case + assert(N > 0); + + assert(!strcasecmp(data->ints[1]->name, "debug")); // this will always be the case + int debug = data->ints[1]->ints[0]; // this will always be the case + + if(debug == 1){ + debug = 1; + } + + assert(!strcasecmp(data->ints[2]->name, "graph_opt_i")); + inla_cgeneric_vec_tp *graph_i = data->ints[2]; + M = graph_i->len; + + assert(!strcasecmp(data->ints[3]->name, "graph_opt_j")); + inla_cgeneric_vec_tp *graph_j = data->ints[3]; + assert(M == graph_j->len); + + assert(!strcasecmp(data->chars[2]->name, "parameterization")); + parameterization = &data->chars[2]->chars[0]; + + assert(!strcasecmp(data->chars[3]->name, "prior.theta.param")); + theta_param = &data->chars[3]->chars[0]; + + assert(!strcasecmp(data->doubles[0]->name, "d")); + d = data->doubles[0]->doubles[0]; + + assert(!strcasecmp(data->doubles[1]->name, "nu")); + nu = data->doubles[1]->doubles[0]; + + alpha = nu + d / 2.0; + m_alpha = (int) floor(alpha); + + assert(!strcasecmp(data->doubles[2]->name, "matrices_full")); + inla_cgeneric_vec_tp *fem = data->doubles[2]; + + fem_size = (fem->len)/(m_alpha+2); + assert(M == fem_size); + + // prior parameters + assert(!strcasecmp(data->doubles[3]->name, "theta.prior.mean")); + inla_cgeneric_vec_tp *theta_prior_mean = data->doubles[3]; + + assert(!strcasecmp(data->mats[0]->name, "theta.prior.prec")); + inla_cgeneric_mat_tp *theta_prior_prec = data->mats[0]; + + assert(!strcasecmp(data->doubles[4]->name, "start.theta")); + inla_cgeneric_vec_tp *start_theta = data->doubles[4]; + + if (theta) { + // interpretable parameters + if(!strcasecmp(parameterization, "matern")){ + lkappa = 0.5 * log(8.0 * nu) - theta[1]; + ltau = - theta[0] + 0.5 *( + lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) + ); + } else if(!strcasecmp(parameterization, "matern2")) { + lkappa = - theta[1]; + ltau = - 0.5 * theta[0] + 0.5 *( + lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) + ); + } else { + ltau = theta[0]; + lkappa = theta[1]; + } + tau = exp(ltau); + kappa = exp(lkappa); + + } + else { + ltau = lkappa = tau = kappa = NAN; + } + + switch (cmd) { + case INLA_CGENERIC_VOID: + { + assert(!(cmd == INLA_CGENERIC_VOID)); + break; + } + + case INLA_CGENERIC_GRAPH: + { + k=2; + ret = Calloc(k + 2 * M, double); + ret[0] = N; /* dimension */ + ret[1] = M; /* number of (i <= j) */ + for (i = 0; i < M; i++) { + ret[k++] = graph_i->ints[i]; + } + for (i = 0; i < M; i++) { + ret[k++] = graph_j->ints[i]; + } + break; + } + + case INLA_CGENERIC_Q: + { + k = 2; + ret = Calloc(k + M, double); + ret[0] = -1; /* REQUIRED */ + ret[1] = M; /* REQUIRED */ + + + double *coeff; + + coeff = Calloc(m_alpha+2, double); + + coeff = markov_approx_coeff(alpha/2.0, kappa, (int)d); + + // FORTRAN IMPLEMENTATION + + dcopy_(&M, &fem->doubles[0], &one, &ret[k], &one); + coeff[0] = coeff[0] * SQR(tau); + dscal_(&M, &coeff[0], &ret[k], &one); + + for(i = 1; i < m_alpha + 2; i++){ + coeff[i] = coeff[i] * SQR(tau); + daxpy_(&M, &coeff[i], &fem->doubles[i*M], &one, &ret[k], &one); + } + break; + } + + case INLA_CGENERIC_MU: + { + ret = Calloc(1, double); + ret[0] = 0.0; + break; + } + + case INLA_CGENERIC_INITIAL: + { + // return c(P, initials) + // where P is the number of hyperparameters + ret = Calloc(3, double); + ret[0] = 2; + ret[1] = start_theta->doubles[0]; + ret[2] = start_theta->doubles[1]; + break; + } + + case INLA_CGENERIC_LOG_NORM_CONST: + { + break; + } + + case INLA_CGENERIC_LOG_PRIOR: + { + ret = Calloc(1, double); + + ret[0] = 0.0; + + if(!strcasecmp(theta_param, "theta") || !strcasecmp(parameterization, "spde")){ + ret[0] += logmultnormvdens(2, theta_prior_mean->doubles, + theta_prior_prec->x, theta); + } + else { + double theta_prior_mean_spde[2], theta_spde[2]; + theta_spde[1] = lkappa; + theta_spde[0] = ltau; + theta_prior_mean_spde[1] = 0.5 * log(8.0 * nu) - theta_prior_mean->doubles[1]; + theta_prior_mean_spde[0] = - theta_prior_mean->doubles[0] + 0.5 *( + lgamma(nu) - 2.0 * nu * theta_prior_mean_spde[1] - + (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) + ); + + ret[0] += logmultnormvdens(2, theta_prior_mean_spde, + theta_prior_prec->x, theta_spde); + } + break; + } + + case INLA_CGENERIC_QUIT: + default: + break; + } + + return (ret); +} \ No newline at end of file diff --git a/src/cgeneric_rspde_stat_parsim_gen.c b/src/cgeneric_rspde_stat_parsim_gen.c new file mode 100644 index 00000000..3d100e09 --- /dev/null +++ b/src/cgeneric_rspde_stat_parsim_gen.c @@ -0,0 +1,347 @@ +#include "cgeneric_defs.h" +// #include + +// Creates a diagonal matrix with the elements of the vector as diagonal entries +void diag(double *vec_long, double *vec_short, int n){ //n = size of vec_short + int nplusone = n+1, one = 1; + dcopy_(&n, vec_short, &one, vec_long, &nplusone); +} + +// Mat should be given by column! +int solveAb(double *mat, double *vec, int size){ // compute A^{-1}b, where b is a vector + int one=1; + int ipivot[size]; + int info; + dgesv_(&size, &one, mat, &size, ipivot, vec, &size, &info); + return(info); +} + +//Get diagonal of a square matrix +// n is the size (number of columns) of the matrix +void getDiag(double *mat, double *destvec, int n){ + int nplusone = n+1, one = 1; + dcopy_(&n, mat, &nplusone, destvec, &one); +} + +// Computes solve(solve(diag(sqrt(diag(B))),B),solve(diag(sqrt(diag(B))),c)) +// This will also change the matrix mat (but for our application there is no problem)! +int CrazySolve(double *mat, double *in_out_vec, int size){ + double *tmp_vec, *tmp_mat; + int i, ipivot[size]; + tmp_vec = Calloc(size, double); + int info; + getDiag(mat, tmp_vec, size); + for(i = 0; i < size; i++){ + tmp_vec[i] = sqrt(tmp_vec[i]); + } + tmp_mat = Calloc(size*size, double); + diag(tmp_mat, tmp_vec, size); + solveAb(tmp_mat, in_out_vec, size); + + dgesv_(&size, &size, tmp_mat, &size, ipivot, mat, &size, &info); + + solveAb(mat, in_out_vec, size); + + free(tmp_vec); + free(tmp_mat); + return(info); +} + +double kappa_integral(int n, double beta, double kappa){ + double y; + int k; + y = 0; + for(k = 0; k <= n; k++){ + y += (2*(k%2) - 1) * nChoosek(n,k)/(n-k-beta+1); + } + return(y*pow(kappa, 2*(n-beta+1))); +} + +double * markov_approx_coeff(double beta, double kappa, int d){ + double nu = 2*beta - d/2.0; + double alpha = nu + d/2.0; + double L = alpha - floor(alpha); + int p = (int)ceil(alpha); + int i,j; + double *Bmat; + Bmat = Calloc( SQR(p+1), double); + double *c_vec; + c_vec = Calloc(p+1, double); + for(i = 0; i <= p; i++){ + c_vec[i] = 1.0; + } + for (i = 0; i <= p; i++){ + c_vec[i] = 2*kappa_integral(i,-alpha+2.0*p+1.0+L,kappa); + for (j = 0; j <= p; j++){ + Bmat[j+i*(p+1)] = 2*kappa_integral(i+j,2.0*p+1.0+L,kappa); + } + } + int info; + info = CrazySolve(Bmat, c_vec, p+1); + assert(info == 0); + // double fact = exp(lgamma(nu))/(signgam*exp(lgamma(alpha))*pow((4.0*M_PI),d/2.0)*pow(kappa,(2*nu))); + // for(i = 0; i <= p; i++){ + // c_vec[i] *= fact; + // } + return(c_vec); +} + + +double *inla_cgeneric_rspde_stat_parsim_gen_model(inla_cgeneric_cmd_tp cmd, double *theta, inla_cgeneric_data_tp * data) { + + double *ret = NULL; + double ltau, lkappa, tau, kappa, lnu, nu; + double alpha, nu_upper_bound; + int m_alpha; + double prior_nu_mean, prior_nu_loglocation, prior_nu_prec; + double prior_nu_logscale; + double start_nu; + int N, M, i, k, j; + double d; + char *prior_nu_dist, *parameterization, *theta_param; + int fem_size; + int one = 1; +// double *coeff; + + + assert(!strcasecmp(data->ints[0]->name, "n")); // this will always be the case + N = data->ints[0]->ints[0]; // this will always be the case + assert(N > 0); + + assert(!strcasecmp(data->ints[1]->name, "debug")); // this will always be the case + int debug = data->ints[1]->ints[0]; // this will always be the case + + if(debug == 1){ + debug = 1; + } + + assert(!strcasecmp(data->ints[2]->name, "graph_opt_i")); + inla_cgeneric_vec_tp *graph_i = data->ints[2]; + M = graph_i->len; + + assert(!strcasecmp(data->ints[3]->name, "graph_opt_j")); + inla_cgeneric_vec_tp *graph_j = data->ints[3]; + assert(M == graph_j->len); + + assert(!strcasecmp(data->chars[2]->name, "prior.nu.dist")); + prior_nu_dist = &data->chars[2]->chars[0]; + + assert(!strcasecmp(data->chars[3]->name, "parameterization")); + parameterization = &data->chars[3]->chars[0]; + + assert(!strcasecmp(data->chars[4]->name, "prior.theta.param")); + theta_param = &data->chars[4]->chars[0]; + + assert(!strcasecmp(data->doubles[0]->name, "d")); + d = data->doubles[0]->doubles[0]; + + assert(!strcasecmp(data->doubles[1]->name, "nu.upper.bound")); + nu_upper_bound = data->doubles[1]->doubles[0]; + + alpha = nu_upper_bound + d / 2.0; + m_alpha = floor(alpha); + + assert(!strcasecmp(data->doubles[2]->name, "matrices_full")); + inla_cgeneric_vec_tp *fem = data->doubles[2]; + + fem_size = (fem->len)/(m_alpha+2); + assert(M == fem_size); + + // prior parameters + + assert(!strcasecmp(data->doubles[3]->name, "theta.prior.mean")); + inla_cgeneric_vec_tp *theta_prior_mean = data->doubles[3]; + + assert(!strcasecmp(data->mats[0]->name, "theta.prior.prec")); + inla_cgeneric_mat_tp *theta_prior_prec = data->mats[0]; + + assert(!strcasecmp(data->doubles[4]->name, "prior.nu.loglocation")); + prior_nu_loglocation = data->doubles[4]->doubles[0]; + + assert(!strcasecmp(data->doubles[5]->name, "prior.nu.mean")); + prior_nu_mean = data->doubles[5]->doubles[0]; + + assert(!strcasecmp(data->doubles[6]->name, "prior.nu.prec")); + prior_nu_prec = data->doubles[6]->doubles[0]; + + assert(!strcasecmp(data->doubles[7]->name, "prior.nu.logscale")); + prior_nu_logscale = data->doubles[7]->doubles[0]; + + assert(!strcasecmp(data->doubles[8]->name, "start.theta")); + inla_cgeneric_vec_tp *start_theta = data->doubles[8]; + + assert(!strcasecmp(data->doubles[9]->name, "start.nu")); + start_nu = data->doubles[9]->doubles[0]; + + if (theta) { + // interpretable parameters + lnu = theta[2]; + nu = (exp(lnu)/(1.0 + exp(lnu))) * nu_upper_bound; + if(!strcasecmp(parameterization, "matern")){ + lkappa = 0.5 * log(8.0 * nu) - theta[1]; + ltau = - theta[0] + 0.5 *( + lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) + ); + } else if(!strcasecmp(parameterization, "matern2")) { + lkappa = - theta[1]; + ltau = - 0.5 * theta[0] + 0.5 *( + lgamma(nu) - 2.0 * nu * lkappa - (d/2.0) * log(4 * M_PI) - lgamma(nu + d/2.0) + ); + } else { + ltau = theta[0]; + lkappa = theta[1]; + } + tau = exp(ltau); + kappa = exp(lkappa); + } + else { + ltau = lkappa = lnu = tau = kappa = nu = NAN; + } + + switch (cmd) { + case INLA_CGENERIC_VOID: + { + assert(!(cmd == INLA_CGENERIC_VOID)); + break; + } + + case INLA_CGENERIC_GRAPH: + { + k=2; + ret = Calloc(k + 2 * M, double); + ret[0] = N; /* dimension */ + ret[1] = M; /* number of (i <= j) */ + for (i = 0; i < M; i++) { + ret[k++] = graph_i->ints[i]; + } + for (i = 0; i < M; i++) { + ret[k++] = graph_j->ints[i]; + } + break; + } + + case INLA_CGENERIC_Q: + { + k = 2; + ret = Calloc(k + M, double); + ret[0] = -1; /* REQUIRED */ + ret[1] = M; /* REQUIRED */ + + double new_alpha = nu + d / 2.0; + int new_m_alpha = (int) floor(new_alpha); + + if(new_alpha / 2.0 == (int) new_alpha/2.0){ + double sqkappatau1 = SQR(tau) * pow(kappa, 2 * new_m_alpha); + double sqkappatau2 = SQR(tau) * new_m_alpha * pow(kappa, 2 * (new_m_alpha - 1)); + double sqtaukappatmp; + dcopy_(&M, &fem->doubles[0], &one, &ret[k], &one); + dscal_(&M, &sqkappatau1, &ret[k], &one); + daxpy_(&M, &sqkappatau2, &fem->doubles[M], &one, &ret[k], &one); + if(new_m_alpha>=2){ + for(j = 2; j<= new_m_alpha; j++){ + sqtaukappatmp = SQR(tau) * pow(kappa, 2*(new_m_alpha-j)) * nChoosek(new_m_alpha, j); + daxpy_(&M, &sqtaukappatmp, &fem->doubles[j*M], &one, &ret[k], &one); + } + } + } else { + + double *coeff; + + coeff = Calloc(new_m_alpha+2, double); + + coeff = markov_approx_coeff(new_alpha/2.0, kappa, (int)d); + + for(i = 0; i < new_m_alpha + 2; i++){ + coeff[i] *= SQR(tau); + } + + // FORTRAN IMPLEMENTATION + + dcopy_(&M, &fem->doubles[0], &one, &ret[k], &one); + dscal_(&M, &coeff[0], &ret[k], &one); + + for(i = 1; i < new_m_alpha + 2; i++){ + daxpy_(&M, &coeff[i], &fem->doubles[i*M], &one, &ret[k], &one); + } + // free(coeff); + } + + + break; + } + + case INLA_CGENERIC_MU: + { + ret = Calloc(1, double); + ret[0] = 0.0; + break; + } + + case INLA_CGENERIC_INITIAL: + { + // return c(P, initials) + // where P is the number of hyperparameters + ret = Calloc(4, double); + ret[0] = 3; + ret[1] = start_theta->doubles[0]; + ret[2] = start_theta->doubles[1]; + ret[3] = log(start_nu/(nu_upper_bound - start_nu)); + break; + } + + case INLA_CGENERIC_LOG_NORM_CONST: + { + break; + } + + case INLA_CGENERIC_LOG_PRIOR: + { + ret = Calloc(1, double); + + ret[0] = 0.0; + + if(!strcasecmp(prior_nu_dist, "lognormal")){ + ret[0] += -0.5 * SQR(lnu - prior_nu_loglocation)/(SQR(prior_nu_logscale)); + ret[0] += -log(prior_nu_logscale) - 0.5 * log(2.0*M_PI); + ret[0] -= log(pnorm(log(nu_upper_bound), prior_nu_loglocation, prior_nu_logscale)); + } + else { // if(!strcasecmp(prior_nu_dist, "beta")){ + double s_1 = (prior_nu_mean / nu_upper_bound) * prior_nu_prec; + double s_2 = (1 - prior_nu_mean / nu_upper_bound) * prior_nu_prec; + ret[0] += logdbeta(nu / nu_upper_bound, s_1, s_2) - log(nu_upper_bound); + } + + if(!strcasecmp(theta_param, "theta") || !strcasecmp(parameterization, "spde")){ + ret[0] += logmultnormvdens(2, theta_prior_mean->doubles, + theta_prior_prec->x, theta); + } + else { + double theta_prior_mean_spde[2], theta_spde[2], prior_nu_tmp; + if(!strcasecmp(prior_nu_dist, "lognormal")){ + prior_nu_tmp = exp(prior_nu_loglocation); + } + else{ + prior_nu_tmp = prior_nu_mean; + } + theta_spde[1] = lkappa; + theta_spde[0] = ltau; + theta_prior_mean_spde[1] = 0.5 * log(8.0 * prior_nu_tmp) - theta_prior_mean->doubles[1]; + theta_prior_mean_spde[0] = - theta_prior_mean->doubles[0] + 0.5 *( + lgamma(prior_nu_tmp) - 2.0 * prior_nu_tmp * theta_prior_mean_spde[1] - + (d/2.0) * log(4 * M_PI) - lgamma(prior_nu_tmp + d/2.0) + ); + + ret[0] += logmultnormvdens(2, theta_prior_mean_spde, + theta_prior_prec->x, theta_spde); + } + + break; + } + + case INLA_CGENERIC_QUIT: + default: + break; + } + + return (ret); +} \ No newline at end of file diff --git a/src/omp.h b/src/omp.h new file mode 100644 index 00000000..f2e6345d --- /dev/null +++ b/src/omp.h @@ -0,0 +1,504 @@ +/* + * include/omp.h.var + */ + + +//===----------------------------------------------------------------------===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + + +#ifndef __OMP_H +# define __OMP_H + +# include +# include + +# define KMP_VERSION_MAJOR 5 +# define KMP_VERSION_MINOR 0 +# define KMP_VERSION_BUILD 20140926 +# define KMP_BUILD_DATE "No_Timestamp" + +# ifdef __cplusplus + extern "C" { +# endif + +# define omp_set_affinity_format ompc_set_affinity_format +# define omp_get_affinity_format ompc_get_affinity_format +# define omp_display_affinity ompc_display_affinity +# define omp_capture_affinity ompc_capture_affinity + +# if defined(_WIN32) +# define __KAI_KMPC_CONVENTION __cdecl +# ifndef __KMP_IMP +# define __KMP_IMP __declspec(dllimport) +# endif +# else +# define __KAI_KMPC_CONVENTION +# ifndef __KMP_IMP +# define __KMP_IMP +# endif +# endif + + /* schedule kind constants */ + typedef enum omp_sched_t { + omp_sched_static = 1, + omp_sched_dynamic = 2, + omp_sched_guided = 3, + omp_sched_auto = 4, + omp_sched_monotonic = 0x80000000 + } omp_sched_t; + + /* set API functions */ + extern void __KAI_KMPC_CONVENTION omp_set_num_threads (int); + extern void __KAI_KMPC_CONVENTION omp_set_dynamic (int); + extern void __KAI_KMPC_CONVENTION omp_set_nested (int); + extern void __KAI_KMPC_CONVENTION omp_set_max_active_levels (int); + extern void __KAI_KMPC_CONVENTION omp_set_schedule (omp_sched_t, int); + + /* query API functions */ + extern int __KAI_KMPC_CONVENTION omp_get_num_threads (void); + extern int __KAI_KMPC_CONVENTION omp_get_dynamic (void); + extern int __KAI_KMPC_CONVENTION omp_get_nested (void); + extern int __KAI_KMPC_CONVENTION omp_get_max_threads (void); + extern int __KAI_KMPC_CONVENTION omp_get_thread_num (void); + extern int __KAI_KMPC_CONVENTION omp_get_num_procs (void); + extern int __KAI_KMPC_CONVENTION omp_in_parallel (void); + extern int __KAI_KMPC_CONVENTION omp_in_final (void); + extern int __KAI_KMPC_CONVENTION omp_get_active_level (void); + extern int __KAI_KMPC_CONVENTION omp_get_level (void); + extern int __KAI_KMPC_CONVENTION omp_get_ancestor_thread_num (int); + extern int __KAI_KMPC_CONVENTION omp_get_team_size (int); + extern int __KAI_KMPC_CONVENTION omp_get_thread_limit (void); + extern int __KAI_KMPC_CONVENTION omp_get_max_active_levels (void); + extern void __KAI_KMPC_CONVENTION omp_get_schedule (omp_sched_t *, int *); + extern int __KAI_KMPC_CONVENTION omp_get_max_task_priority (void); + + /* lock API functions */ + typedef struct omp_lock_t { + void * _lk; + } omp_lock_t; + + extern void __KAI_KMPC_CONVENTION omp_init_lock (omp_lock_t *); + extern void __KAI_KMPC_CONVENTION omp_set_lock (omp_lock_t *); + extern void __KAI_KMPC_CONVENTION omp_unset_lock (omp_lock_t *); + extern void __KAI_KMPC_CONVENTION omp_destroy_lock (omp_lock_t *); + extern int __KAI_KMPC_CONVENTION omp_test_lock (omp_lock_t *); + + /* nested lock API functions */ + typedef struct omp_nest_lock_t { + void * _lk; + } omp_nest_lock_t; + + extern void __KAI_KMPC_CONVENTION omp_init_nest_lock (omp_nest_lock_t *); + extern void __KAI_KMPC_CONVENTION omp_set_nest_lock (omp_nest_lock_t *); + extern void __KAI_KMPC_CONVENTION omp_unset_nest_lock (omp_nest_lock_t *); + extern void __KAI_KMPC_CONVENTION omp_destroy_nest_lock (omp_nest_lock_t *); + extern int __KAI_KMPC_CONVENTION omp_test_nest_lock (omp_nest_lock_t *); + + /* OpenMP 5.0 Synchronization hints*/ + typedef enum omp_sync_hint_t { + omp_sync_hint_none = 0, + omp_lock_hint_none = omp_sync_hint_none, + omp_sync_hint_uncontended = 1, + omp_lock_hint_uncontended = omp_sync_hint_uncontended, + omp_sync_hint_contended = (1<<1), + omp_lock_hint_contended = omp_sync_hint_contended, + omp_sync_hint_nonspeculative = (1<<2), + omp_lock_hint_nonspeculative = omp_sync_hint_nonspeculative, + omp_sync_hint_speculative = (1<<3), + omp_lock_hint_speculative = omp_sync_hint_speculative, + kmp_lock_hint_hle = (1<<16), + kmp_lock_hint_rtm = (1<<17), + kmp_lock_hint_adaptive = (1<<18) + } omp_sync_hint_t; + + /* lock hint type for dynamic user lock */ + typedef omp_sync_hint_t omp_lock_hint_t; + + /* hinted lock initializers */ + extern void __KAI_KMPC_CONVENTION omp_init_lock_with_hint(omp_lock_t *, omp_lock_hint_t); + extern void __KAI_KMPC_CONVENTION omp_init_nest_lock_with_hint(omp_nest_lock_t *, omp_lock_hint_t); + + /* time API functions */ + extern double __KAI_KMPC_CONVENTION omp_get_wtime (void); + extern double __KAI_KMPC_CONVENTION omp_get_wtick (void); + + /* OpenMP 4.0 */ + extern int __KAI_KMPC_CONVENTION omp_get_default_device (void); + extern void __KAI_KMPC_CONVENTION omp_set_default_device (int); + extern int __KAI_KMPC_CONVENTION omp_is_initial_device (void); + extern int __KAI_KMPC_CONVENTION omp_get_num_devices (void); + extern int __KAI_KMPC_CONVENTION omp_get_num_teams (void); + extern int __KAI_KMPC_CONVENTION omp_get_team_num (void); + extern int __KAI_KMPC_CONVENTION omp_get_cancellation (void); + + /* OpenMP 4.5 */ + extern int __KAI_KMPC_CONVENTION omp_get_initial_device (void); + extern void* __KAI_KMPC_CONVENTION omp_target_alloc(size_t, int); + extern void __KAI_KMPC_CONVENTION omp_target_free(void *, int); + extern int __KAI_KMPC_CONVENTION omp_target_is_present(const void *, int); + extern int __KAI_KMPC_CONVENTION omp_target_memcpy(void *, const void *, size_t, size_t, size_t, int, int); + extern int __KAI_KMPC_CONVENTION omp_target_memcpy_rect(void *, const void *, size_t, int, const size_t *, + const size_t *, const size_t *, const size_t *, const size_t *, int, int); + extern int __KAI_KMPC_CONVENTION omp_target_associate_ptr(const void *, const void *, size_t, size_t, int); + extern int __KAI_KMPC_CONVENTION omp_target_disassociate_ptr(const void *, int); + + /* OpenMP 5.0 */ + extern int __KAI_KMPC_CONVENTION omp_get_device_num (void); + typedef void * omp_depend_t; + + /* OpenMP 5.1 interop */ + typedef intptr_t omp_intptr_t; + + /* 0..omp_get_num_interop_properties()-1 are reserved for implementation-defined properties */ + typedef enum omp_interop_property { + omp_ipr_fr_id = -1, + omp_ipr_fr_name = -2, + omp_ipr_vendor = -3, + omp_ipr_vendor_name = -4, + omp_ipr_device_num = -5, + omp_ipr_platform = -6, + omp_ipr_device = -7, + omp_ipr_device_context = -8, + omp_ipr_targetsync = -9, + omp_ipr_first = -9 + } omp_interop_property_t; + + #define omp_interop_none 0 + + typedef enum omp_interop_rc { + omp_irc_no_value = 1, + omp_irc_success = 0, + omp_irc_empty = -1, + omp_irc_out_of_range = -2, + omp_irc_type_int = -3, + omp_irc_type_ptr = -4, + omp_irc_type_str = -5, + omp_irc_other = -6 + } omp_interop_rc_t; + + typedef enum omp_interop_fr { + omp_ifr_cuda = 1, + omp_ifr_cuda_driver = 2, + omp_ifr_opencl = 3, + omp_ifr_sycl = 4, + omp_ifr_hip = 5, + omp_ifr_level_zero = 6, + omp_ifr_last = 7 + } omp_interop_fr_t; + + typedef void * omp_interop_t; + + /*! + * The `omp_get_num_interop_properties` routine retrieves the number of implementation-defined properties available for an `omp_interop_t` object. + */ + extern int __KAI_KMPC_CONVENTION omp_get_num_interop_properties(const omp_interop_t); + /*! + * The `omp_get_interop_int` routine retrieves an integer property from an `omp_interop_t` object. + */ + extern omp_intptr_t __KAI_KMPC_CONVENTION omp_get_interop_int(const omp_interop_t, omp_interop_property_t, int *); + /*! + * The `omp_get_interop_ptr` routine retrieves a pointer property from an `omp_interop_t` object. + */ + extern void * __KAI_KMPC_CONVENTION omp_get_interop_ptr(const omp_interop_t, omp_interop_property_t, int *); + /*! + * The `omp_get_interop_str` routine retrieves a string property from an `omp_interop_t` object. + */ + extern const char * __KAI_KMPC_CONVENTION omp_get_interop_str(const omp_interop_t, omp_interop_property_t, int *); + /*! + * The `omp_get_interop_name` routine retrieves a property name from an `omp_interop_t` object. + */ + extern const char * __KAI_KMPC_CONVENTION omp_get_interop_name(const omp_interop_t, omp_interop_property_t); + /*! + * The `omp_get_interop_type_desc` routine retrieves a description of the type of a property associated with an `omp_interop_t` object. + */ + extern const char * __KAI_KMPC_CONVENTION omp_get_interop_type_desc(const omp_interop_t, omp_interop_property_t); + /*! + * The `omp_get_interop_rc_desc` routine retrieves a description of the return code associated with an `omp_interop_t` object. + */ + extern const char * __KAI_KMPC_CONVENTION omp_get_interop_rc_desc(const omp_interop_t, omp_interop_rc_t); + + /* OpenMP 5.1 device memory routines */ + + /*! + * The `omp_target_memcpy_async` routine asynchronously performs a copy between any combination of host and device pointers. + */ + extern int __KAI_KMPC_CONVENTION omp_target_memcpy_async(void *, const void *, size_t, size_t, size_t, int, + int, int, omp_depend_t *); + /*! + * The `omp_target_memcpy_rect_async` routine asynchronously performs a copy between any combination of host and device pointers. + */ + extern int __KAI_KMPC_CONVENTION omp_target_memcpy_rect_async(void *, const void *, size_t, int, const size_t *, + const size_t *, const size_t *, const size_t *, const size_t *, int, int, + int, omp_depend_t *); + /*! + * The `omp_get_mapped_ptr` routine returns the device pointer that is associated with a host pointer for a given device. + */ + extern void * __KAI_KMPC_CONVENTION omp_get_mapped_ptr(const void *, int); + extern int __KAI_KMPC_CONVENTION omp_target_is_accessible(const void *, size_t, int); + + /* kmp API functions */ + extern int __KAI_KMPC_CONVENTION kmp_get_stacksize (void); + extern void __KAI_KMPC_CONVENTION kmp_set_stacksize (int); + extern size_t __KAI_KMPC_CONVENTION kmp_get_stacksize_s (void); + extern void __KAI_KMPC_CONVENTION kmp_set_stacksize_s (size_t); + extern int __KAI_KMPC_CONVENTION kmp_get_blocktime (void); + extern int __KAI_KMPC_CONVENTION kmp_get_library (void); + extern void __KAI_KMPC_CONVENTION kmp_set_blocktime (int); + extern void __KAI_KMPC_CONVENTION kmp_set_library (int); + extern void __KAI_KMPC_CONVENTION kmp_set_library_serial (void); + extern void __KAI_KMPC_CONVENTION kmp_set_library_turnaround (void); + extern void __KAI_KMPC_CONVENTION kmp_set_library_throughput (void); + extern void __KAI_KMPC_CONVENTION kmp_set_defaults (char const *); + extern void __KAI_KMPC_CONVENTION kmp_set_disp_num_buffers (int); + + /* Intel affinity API */ + typedef void * kmp_affinity_mask_t; + + extern int __KAI_KMPC_CONVENTION kmp_set_affinity (kmp_affinity_mask_t *); + extern int __KAI_KMPC_CONVENTION kmp_get_affinity (kmp_affinity_mask_t *); + extern int __KAI_KMPC_CONVENTION kmp_get_affinity_max_proc (void); + extern void __KAI_KMPC_CONVENTION kmp_create_affinity_mask (kmp_affinity_mask_t *); + extern void __KAI_KMPC_CONVENTION kmp_destroy_affinity_mask (kmp_affinity_mask_t *); + extern int __KAI_KMPC_CONVENTION kmp_set_affinity_mask_proc (int, kmp_affinity_mask_t *); + extern int __KAI_KMPC_CONVENTION kmp_unset_affinity_mask_proc (int, kmp_affinity_mask_t *); + extern int __KAI_KMPC_CONVENTION kmp_get_affinity_mask_proc (int, kmp_affinity_mask_t *); + + /* OpenMP 4.0 affinity API */ + typedef enum omp_proc_bind_t { + omp_proc_bind_false = 0, + omp_proc_bind_true = 1, + omp_proc_bind_master = 2, + omp_proc_bind_close = 3, + omp_proc_bind_spread = 4 + } omp_proc_bind_t; + + extern omp_proc_bind_t __KAI_KMPC_CONVENTION omp_get_proc_bind (void); + + /* OpenMP 4.5 affinity API */ + extern int __KAI_KMPC_CONVENTION omp_get_num_places (void); + extern int __KAI_KMPC_CONVENTION omp_get_place_num_procs (int); + extern void __KAI_KMPC_CONVENTION omp_get_place_proc_ids (int, int *); + extern int __KAI_KMPC_CONVENTION omp_get_place_num (void); + extern int __KAI_KMPC_CONVENTION omp_get_partition_num_places (void); + extern void __KAI_KMPC_CONVENTION omp_get_partition_place_nums (int *); + + extern void * __KAI_KMPC_CONVENTION kmp_malloc (size_t); + extern void * __KAI_KMPC_CONVENTION kmp_aligned_malloc (size_t, size_t); + extern void * __KAI_KMPC_CONVENTION kmp_calloc (size_t, size_t); + extern void * __KAI_KMPC_CONVENTION kmp_realloc (void *, size_t); + extern void __KAI_KMPC_CONVENTION kmp_free (void *); + + extern void __KAI_KMPC_CONVENTION kmp_set_warnings_on(void); + extern void __KAI_KMPC_CONVENTION kmp_set_warnings_off(void); + + /* OpenMP 5.0 Tool Control */ + typedef enum omp_control_tool_result_t { + omp_control_tool_notool = -2, + omp_control_tool_nocallback = -1, + omp_control_tool_success = 0, + omp_control_tool_ignored = 1 + } omp_control_tool_result_t; + + typedef enum omp_control_tool_t { + omp_control_tool_start = 1, + omp_control_tool_pause = 2, + omp_control_tool_flush = 3, + omp_control_tool_end = 4 + } omp_control_tool_t; + + extern int __KAI_KMPC_CONVENTION omp_control_tool(int, int, void*); + + /* OpenMP 5.0 Memory Management */ + typedef uintptr_t omp_uintptr_t; + + typedef enum { + omp_atk_sync_hint = 1, + omp_atk_alignment = 2, + omp_atk_access = 3, + omp_atk_pool_size = 4, + omp_atk_fallback = 5, + omp_atk_fb_data = 6, + omp_atk_pinned = 7, + omp_atk_partition = 8 + } omp_alloctrait_key_t; + + typedef enum { + omp_atv_false = 0, + omp_atv_true = 1, + omp_atv_contended = 3, + omp_atv_uncontended = 4, + omp_atv_serialized = 5, + omp_atv_sequential = omp_atv_serialized, // (deprecated) + omp_atv_private = 6, + omp_atv_all = 7, + omp_atv_thread = 8, + omp_atv_pteam = 9, + omp_atv_cgroup = 10, + omp_atv_default_mem_fb = 11, + omp_atv_null_fb = 12, + omp_atv_abort_fb = 13, + omp_atv_allocator_fb = 14, + omp_atv_environment = 15, + omp_atv_nearest = 16, + omp_atv_blocked = 17, + omp_atv_interleaved = 18 + } omp_alloctrait_value_t; + #define omp_atv_default ((omp_uintptr_t)-1) + + typedef struct { + omp_alloctrait_key_t key; + omp_uintptr_t value; + } omp_alloctrait_t; + +# if defined(_WIN32) + // On Windows cl and icl do not support 64-bit enum, let's use integer then. + typedef omp_uintptr_t omp_allocator_handle_t; + extern __KMP_IMP omp_allocator_handle_t const omp_null_allocator; + extern __KMP_IMP omp_allocator_handle_t const omp_default_mem_alloc; + extern __KMP_IMP omp_allocator_handle_t const omp_large_cap_mem_alloc; + extern __KMP_IMP omp_allocator_handle_t const omp_const_mem_alloc; + extern __KMP_IMP omp_allocator_handle_t const omp_high_bw_mem_alloc; + extern __KMP_IMP omp_allocator_handle_t const omp_low_lat_mem_alloc; + extern __KMP_IMP omp_allocator_handle_t const omp_cgroup_mem_alloc; + extern __KMP_IMP omp_allocator_handle_t const omp_pteam_mem_alloc; + extern __KMP_IMP omp_allocator_handle_t const omp_thread_mem_alloc; + /* Preview of target memory support */ + extern __KMP_IMP omp_allocator_handle_t const llvm_omp_target_host_mem_alloc; + extern __KMP_IMP omp_allocator_handle_t const llvm_omp_target_shared_mem_alloc; + extern __KMP_IMP omp_allocator_handle_t const llvm_omp_target_device_mem_alloc; + + typedef omp_uintptr_t omp_memspace_handle_t; + extern __KMP_IMP omp_memspace_handle_t const omp_default_mem_space; + extern __KMP_IMP omp_memspace_handle_t const omp_large_cap_mem_space; + extern __KMP_IMP omp_memspace_handle_t const omp_const_mem_space; + extern __KMP_IMP omp_memspace_handle_t const omp_high_bw_mem_space; + extern __KMP_IMP omp_memspace_handle_t const omp_low_lat_mem_space; + /* Preview of target memory support */ + extern __KMP_IMP omp_memspace_handle_t const llvm_omp_target_host_mem_space; + extern __KMP_IMP omp_memspace_handle_t const llvm_omp_target_shared_mem_space; + extern __KMP_IMP omp_memspace_handle_t const llvm_omp_target_device_mem_space; +# else +# if __cplusplus >= 201103 + typedef enum omp_allocator_handle_t : omp_uintptr_t +# else + typedef enum omp_allocator_handle_t +# endif + { + omp_null_allocator = 0, + omp_default_mem_alloc = 1, + omp_large_cap_mem_alloc = 2, + omp_const_mem_alloc = 3, + omp_high_bw_mem_alloc = 4, + omp_low_lat_mem_alloc = 5, + omp_cgroup_mem_alloc = 6, + omp_pteam_mem_alloc = 7, + omp_thread_mem_alloc = 8, + /* Preview of target memory support */ + llvm_omp_target_host_mem_alloc = 100, + llvm_omp_target_shared_mem_alloc = 101, + llvm_omp_target_device_mem_alloc = 102, + KMP_ALLOCATOR_MAX_HANDLE = UINTPTR_MAX + } omp_allocator_handle_t; +# if __cplusplus >= 201103 + typedef enum omp_memspace_handle_t : omp_uintptr_t +# else + typedef enum omp_memspace_handle_t +# endif + { + omp_default_mem_space = 0, + omp_large_cap_mem_space = 1, + omp_const_mem_space = 2, + omp_high_bw_mem_space = 3, + omp_low_lat_mem_space = 4, + /* Preview of target memory support */ + llvm_omp_target_host_mem_space = 100, + llvm_omp_target_shared_mem_space = 101, + llvm_omp_target_device_mem_space = 102, + KMP_MEMSPACE_MAX_HANDLE = UINTPTR_MAX + } omp_memspace_handle_t; +# endif + extern omp_allocator_handle_t __KAI_KMPC_CONVENTION omp_init_allocator(omp_memspace_handle_t m, + int ntraits, omp_alloctrait_t traits[]); + extern void __KAI_KMPC_CONVENTION omp_destroy_allocator(omp_allocator_handle_t allocator); + + extern void __KAI_KMPC_CONVENTION omp_set_default_allocator(omp_allocator_handle_t a); + extern omp_allocator_handle_t __KAI_KMPC_CONVENTION omp_get_default_allocator(void); +# ifdef __cplusplus + extern void *__KAI_KMPC_CONVENTION omp_alloc(size_t size, omp_allocator_handle_t a = omp_null_allocator); + extern void *__KAI_KMPC_CONVENTION omp_calloc(size_t nmemb, size_t size, omp_allocator_handle_t a = omp_null_allocator); + extern void *__KAI_KMPC_CONVENTION omp_realloc(void *ptr, size_t size, + omp_allocator_handle_t allocator = omp_null_allocator, + omp_allocator_handle_t free_allocator = omp_null_allocator); + extern void __KAI_KMPC_CONVENTION omp_free(void * ptr, omp_allocator_handle_t a = omp_null_allocator); +# else + extern void *__KAI_KMPC_CONVENTION omp_alloc(size_t size, omp_allocator_handle_t a); + extern void *__KAI_KMPC_CONVENTION omp_calloc(size_t nmemb, size_t size, omp_allocator_handle_t a); + extern void *__KAI_KMPC_CONVENTION omp_realloc(void *ptr, size_t size, omp_allocator_handle_t allocator, + omp_allocator_handle_t free_allocator); + extern void __KAI_KMPC_CONVENTION omp_free(void *ptr, omp_allocator_handle_t a); +# endif + + /* OpenMP 5.0 Affinity Format */ + extern void __KAI_KMPC_CONVENTION omp_set_affinity_format(char const *); + extern size_t __KAI_KMPC_CONVENTION omp_get_affinity_format(char *, size_t); + extern void __KAI_KMPC_CONVENTION omp_display_affinity(char const *); + extern size_t __KAI_KMPC_CONVENTION omp_capture_affinity(char *, size_t, char const *); + + /* OpenMP 5.0 events */ +# if defined(_WIN32) + // On Windows cl and icl do not support 64-bit enum, let's use integer then. + typedef omp_uintptr_t omp_event_handle_t; +# else + typedef enum omp_event_handle_t { KMP_EVENT_MAX_HANDLE = UINTPTR_MAX } omp_event_handle_t; +# endif + extern void __KAI_KMPC_CONVENTION omp_fulfill_event ( omp_event_handle_t event ); + + /* OpenMP 5.0 Pause Resources */ + typedef enum omp_pause_resource_t { + omp_pause_resume = 0, + omp_pause_soft = 1, + omp_pause_hard = 2 + } omp_pause_resource_t; + extern int __KAI_KMPC_CONVENTION omp_pause_resource(omp_pause_resource_t, int); + extern int __KAI_KMPC_CONVENTION omp_pause_resource_all(omp_pause_resource_t); + + extern int __KAI_KMPC_CONVENTION omp_get_supported_active_levels(void); + + /* OpenMP 5.1 */ + extern void __KAI_KMPC_CONVENTION omp_set_num_teams(int num_teams); + extern int __KAI_KMPC_CONVENTION omp_get_max_teams(void); + extern void __KAI_KMPC_CONVENTION omp_set_teams_thread_limit(int limit); + extern int __KAI_KMPC_CONVENTION omp_get_teams_thread_limit(void); + + /* OpenMP 5.1 Display Environment */ + extern void omp_display_env(int verbose); + +# if defined(_OPENMP) && _OPENMP >= 201811 + #pragma omp begin declare variant match(device={kind(host)}) + static inline int omp_is_initial_device(void) { return 1; } + #pragma omp end declare variant + #pragma omp begin declare variant match(device={kind(nohost)}) + static inline int omp_is_initial_device(void) { return 0; } + #pragma omp end declare variant +# endif + +# undef __KAI_KMPC_CONVENTION +# undef __KMP_IMP + + /* Warning: + The following typedefs are not standard, deprecated and will be removed in a future release. + */ + typedef int omp_int_t; + typedef double omp_wtime_t; + +# ifdef __cplusplus + } +# endif + +#endif /* __OMP_H */ From 834afdb150b7484fb6dda69a05066959f38d743b Mon Sep 17 00:00:00 2001 From: "Alexandre B. Simas" Date: Mon, 29 May 2023 22:15:48 +0300 Subject: [PATCH 29/47] Update README.md --- README.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 22a9af0c..ef2dd0b0 100644 --- a/README.md +++ b/README.md @@ -45,7 +45,9 @@ in R. The development version can be installed using the command remotes::install_github("davidbolin/rspde", ref = "devel") ``` -*The following is intended for expert use only:* In case you want to build the source, the `stable-src` and `devel-src` branches require compilation, which is not the case for the `cran`, `stable` and `devel` branches. +*The following is intended for expert use only:* + +In case you want to build the source, the `stable-src` and `devel-src` branches require compilation, which is not the case for the `cran`, `stable` and `devel` branches. For Windows operating systems, we recommend the user to install from either of the `cran`, `stable` or `devel` branches, which require no compilation. From 3a25d1a5c1fb87e262427cfe28cbd614acca9aab Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 22:18:17 +0300 Subject: [PATCH 30/47] update setups --- .github/workflows/devel_setup.yml | 2 +- .github/workflows/stable_setup.yml | 2 +- .github/workflows/stable_src_setup.yml | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/devel_setup.yml b/.github/workflows/devel_setup.yml index 376c06c3..2ee457d6 100644 --- a/.github/workflows/devel_setup.yml +++ b/.github/workflows/devel_setup.yml @@ -20,7 +20,7 @@ jobs: git config pull.rebase true git fetch origin git checkout devel-src - git merge devel -X theirs --no-edit --no-commit --no-ff + git merge devel -X theirs --no-edit --no-commit --no-ff --allow-unrelated-histories git checkout --theirs . git add . git reset -- src/ diff --git a/.github/workflows/stable_setup.yml b/.github/workflows/stable_setup.yml index 98d8bdcd..b0e198e6 100644 --- a/.github/workflows/stable_setup.yml +++ b/.github/workflows/stable_setup.yml @@ -20,7 +20,7 @@ jobs: git config pull.rebase true git fetch origin git checkout stable-src - git merge -X theirs stable --no-edit --no-commit --no-ff + git merge -X theirs stable --no-edit --no-commit --no-ff --allow-unrelated-histories git checkout --theirs . git add . git reset -- src/ diff --git a/.github/workflows/stable_src_setup.yml b/.github/workflows/stable_src_setup.yml index f523a4cf..cb4166da 100644 --- a/.github/workflows/stable_src_setup.yml +++ b/.github/workflows/stable_src_setup.yml @@ -20,7 +20,7 @@ jobs: git config pull.rebase true git fetch origin git checkout stable - git merge -X theirs stable-src --no-edit --no-commit --no-ff + git merge -X theirs stable-src --no-edit --no-commit --no-ff --allow-unrelated-histories git checkout --theirs . sed -i 's/NeedsCompilation: yes/NeedsCompilation: no/' DESCRIPTION git add . From 8d1c911cbe708db44125cceadea91a5d22425544 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 22:34:32 +0300 Subject: [PATCH 31/47] adjusts summary --- R/inla_rspde.R | 6 ++++-- R/inlabru_rspde.R | 3 ++- R/util.R | 9 ++++++--- 3 files changed, 12 insertions(+), 6 deletions(-) diff --git a/R/inla_rspde.R b/R/inla_rspde.R index d271fee8..06175214 100644 --- a/R/inla_rspde.R +++ b/R/inla_rspde.R @@ -1617,7 +1617,8 @@ rspde.result <- function(inla, name, rspde, compute.summary = TRUE, parameteriza f = function(z) { denstemp(z) }, lower = min_x, upper = max_x, - subdivisions = nrow(density_df) + subdivisions = nrow(density_df), + stop.on.error = FALSE )$value return(norm_const) } @@ -1737,7 +1738,8 @@ rspde.result <- function(inla, name, rspde, compute.summary = TRUE, parameteriza norm_const <- stats::integrate( f = function(z) { denstemp(z) - }, lower = min_x, upper = max_x + }, lower = min_x, upper = max_x, + stop.on.error = FALSE )$value return(norm_const) } diff --git a/R/inlabru_rspde.R b/R/inlabru_rspde.R index d052d23a..c1a3cca4 100644 --- a/R/inlabru_rspde.R +++ b/R/inlabru_rspde.R @@ -302,7 +302,8 @@ get_post_var <- function(density_df){ f = function(z) { denstemp(z) * 1/z }, lower = min_x, upper = max_x, - subdivisions = nrow(density_df) + subdivisions = nrow(density_df), + stop.on.error = FALSE )$value return(post_var) diff --git a/R/util.R b/R/util.R index 65d00ebb..0a720a5c 100644 --- a/R/util.R +++ b/R/util.R @@ -1172,7 +1172,8 @@ create_summary_from_density <- function(density_df, name) { return(1) } else { stats::integrate( - f = denstemp, lower = min_x, upper = v + f = denstemp, lower = min_x, upper = v, + stop.on.error = FALSE )$value } }) @@ -1183,13 +1184,15 @@ create_summary_from_density <- function(density_df, name) { f = function(z) { denstemp(z) * z }, lower = min_x, upper = max_x, - subdivisions = nrow(density_df) + subdivisions = nrow(density_df), + stop.on.error = FALSE )$value sd_temp <- sqrt(stats::integrate( f = function(z) { denstemp(z) * (z - mean_temp)^2 - }, lower = min_x, upper = max_x + }, lower = min_x, upper = max_x, + stop.on.error = FALSE )$value) mode_temp <- density_df[which.max(density_df[, "y"]), "x"] From c7f1f3f6275254f26721e1e7badfd6282d49a8f8 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 23:16:14 +0300 Subject: [PATCH 32/47] updates in workflow + adding devel-src and stable-src to check --- .github/workflows/R-CMD-check-windows.yaml | 3 +++ .github/workflows/R-CMD-check.yaml | 3 +++ README.md | 6 +++--- 3 files changed, 9 insertions(+), 3 deletions(-) diff --git a/.github/workflows/R-CMD-check-windows.yaml b/.github/workflows/R-CMD-check-windows.yaml index fd39b4bc..dd58a8b5 100644 --- a/.github/workflows/R-CMD-check-windows.yaml +++ b/.github/workflows/R-CMD-check-windows.yaml @@ -9,9 +9,12 @@ on: branches: - devel - stable + - devel-src + - stable-src pull_request: branches: - devel + - devel-src name: R-CMD-check-windows diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index ddf75392..0bca4163 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -6,9 +6,12 @@ on: branches: - devel - stable + - devel-src + - stable-src pull_request: branches: - devel + - devel-src name: R-CMD-check diff --git a/README.md b/README.md index ef2dd0b0..cefbb27f 100644 --- a/README.md +++ b/README.md @@ -56,7 +56,7 @@ The compilation is required to create a shared object to be used by `INLA`. Howe Finally, we have the vignette [Building the rSPDE package from source on Mac and Linux](https://davidbolin.github.io/rSPDE//articles/build_source.html) to help you if you want to build the `rSPDE` package from source on Mac or Linux. # Repository branch workflows # -The package version format for released versions is `major.minor.bugfix`. All regular development should be performed on the `devel` branch or in a feature branch, managed with `git flow feature`. Ideally, all the changes should be made on the `devel` branch. The `devel` version of the package should contain unit tests and examples for all important functions. Several functions may depend on `INLA`. Examples and tests for such functions might create problems when submitting to CRAN. To solve this problem, we created some Github Actions scripts that get the examples and tests depending on `INLA` on the `devel` branch and adapt to versions that will not fail on CRAN. Therefore, the best way to handle these situations is to avoid as much as possible to do any push to the `stable` branch. The idea is to update the `stable` branch by merges following the workflow that will be described below. +The package version format for released versions is `major.minor.bugfix`. All regular development on the `R` part of the code should be performed on the `devel` branch or in a feature branch, managed with `git flow feature`, similarly, all the development in the `C` (or `C++`) part of the code should be performed on the `devel-src` branch. After finishing the `C` (or `C++`) implementations, the changes in the `R` code, should preferably be made on the `devel` branch. After pushing to `devel`, a merge with `devel-src` will be automatically done. Similarly, after pushing to `devel-src`, a merge with `devel` will also be automatically done. Ideally, all the changes should be made on the `devel` or `devel-src` branches. The `devel` version of the package should contain unit tests and examples for all important functions. Several functions may depend on `INLA`. Examples and tests for such functions might create problems when submitting to CRAN. To solve this problem, we created some Github Actions scripts that get the examples and tests depending on `INLA` on the `devel` branch and adapt to versions that will not fail on CRAN. Therefore, the best way to handle these situations is to avoid as much as possible to do any push to the `stable` branch. The idea is to update the `stable` branch by merges following the workflow that will be described below. The examples that depend on `INLA` should have the following structure: ``` @@ -88,9 +88,9 @@ test_that("Description of the test", { }) ``` -On the `devel` branch, the vestion number is `major.minor.bugfix.9000`, where the first three components reflect the latest released version with changes present in the `default` branch. Bugfixes should be applied via the `git flow bugfix` and `git flow hotfix` methods, as indicated below. For `git flow` configuration, use `master` as the stable master branch, `devel` as the develop branch, and `v` as the version tag prefix. Hotfixes directly `stable` should be avoided whenever possible to minimize conflicts on merges. See [the `git flow` tutorial](https://www.atlassian.com/git/tutorials/comparing-workflows/gitflow-workflow) for more information. +On the `devel` and `devel-src` branches, the vestion number is `major.minor.bugfix.9000`, where the first three components reflect the latest released version with changes present in the `default` branch. Bugfixes should be applied via the `git flow bugfix` and `git flow hotfix` methods, as indicated below. For `git flow` configuration, use `master` as the stable master branch, `devel` as the develop branch, and `v` as the version tag prefix. Hotfixes directly `stable` should be avoided whenever possible to minimize conflicts on merges. See [the `git flow` tutorial](https://www.atlassian.com/git/tutorials/comparing-workflows/gitflow-workflow) for more information. -For non `master` and `devel` branches that collaborators need access to (e.g. release branches, feature branches, etc, use the `git flow publish` mechanism). +For non `devel` branches that collaborators need access to (e.g. release branches, feature branches, etc, use the `git flow publish` mechanism). * Prepare a new stable release with CRAN submission: From b8d9e12038980f44ff7e47958a3fd408251862fa Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 23:27:13 +0300 Subject: [PATCH 33/47] bugfix spde.matern.operators --- R/fractional.operators.R | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/R/fractional.operators.R b/R/fractional.operators.R index 02ccaa52..1ef51760 100644 --- a/R/fractional.operators.R +++ b/R/fractional.operators.R @@ -560,6 +560,8 @@ matern.operators <- function(kappa = NULL, make_A <- NULL } + C <- Matrix::Diagonal(dim(C)[1], rowSums(C)) + if (type == "operator") { beta <- (nu + d / 2) / 2 @@ -1291,6 +1293,9 @@ if (is.null(d) && is.null(mesh) && is.null(graph)) { if (nu < 0) { stop("nu must be positive") } + + C <- Matrix::Diagonal(dim(C)[1], rowSums(C)) + Ci <- Matrix::Diagonal(dim(C)[1], 1 / rowSums(C)) if(type == "operator"){ beta <- (nu + d / 2) / 2 @@ -1387,7 +1392,7 @@ if (is.null(d) && is.null(mesh) && is.null(graph)) { # K part if(m_alpha == 0){ - Q_tmp <- C + Q_tmp <- Ci } else if(m_alpha == 1){ Q_tmp <- L } else{ From ec3c037ac2ccb98f338ed580e168ac65aee42539 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 23:48:37 +0300 Subject: [PATCH 34/47] adjusts spde.matern.op --- R/fractional.operators.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/fractional.operators.R b/R/fractional.operators.R index 1ef51760..f136abb7 100644 --- a/R/fractional.operators.R +++ b/R/fractional.operators.R @@ -560,8 +560,6 @@ matern.operators <- function(kappa = NULL, make_A <- NULL } - C <- Matrix::Diagonal(dim(C)[1], rowSums(C)) - if (type == "operator") { beta <- (nu + d / 2) / 2 @@ -595,6 +593,8 @@ matern.operators <- function(kappa = NULL, output$loc_mesh <- loc_mesh return(output) } else { + + C <- Matrix::Diagonal(dim(C)[1], rowSums(C)) type_rational_approximation <- type_rational_approximation[[1]] out <- CBrSPDE.matern.operators( C = C, G = G, mesh = mesh, nu = nu, kappa = kappa, tau = tau, @@ -1293,9 +1293,6 @@ if (is.null(d) && is.null(mesh) && is.null(graph)) { if (nu < 0) { stop("nu must be positive") } - - C <- Matrix::Diagonal(dim(C)[1], rowSums(C)) - Ci <- Matrix::Diagonal(dim(C)[1], 1 / rowSums(C)) if(type == "operator"){ beta <- (nu + d / 2) / 2 @@ -1335,6 +1332,9 @@ if (is.null(d) && is.null(mesh) && is.null(graph)) { m_alpha <- floor(alpha) m_order <- m_alpha + 1 + C <- Matrix::Diagonal(dim(C)[1], rowSums(C)) + Ci <- Matrix::Diagonal(dim(C)[1], 1 / rowSums(C)) + L <- Matrix::Diagonal(dim(C)[1], kappa^2 * diag(C)) L <- L + G From f5943dd6e1fb0c803f751e825ae189c1754aeb1d Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Mon, 29 May 2023 23:59:09 +0300 Subject: [PATCH 35/47] adjust rSPDE vignette --- vignettes/rSPDE.Rmd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vignettes/rSPDE.Rmd b/vignettes/rSPDE.Rmd index af106496..2e5aadf3 100644 --- a/vignettes/rSPDE.Rmd +++ b/vignettes/rSPDE.Rmd @@ -186,7 +186,7 @@ nu <- 0.5 kappa <- sqrt(8 * nu) / range op <- matern.operators( mesh = mesh_2d, nu = nu, - kappa = kappa, sigma = sigma, m = 2, + range = range, sigma = sigma, m = 2, parameterization = "matern" ) tau <- op$tau From 321f22c3466f5fd213d621560b4727c7fde66fd3 Mon Sep 17 00:00:00 2001 From: davidbolin Date: Tue, 30 May 2023 00:23:00 +0300 Subject: [PATCH 36/47] adding functions for intrinsic models --- DESCRIPTION | 2 +- NAMESPACE | 2 + R/intrinsic.R | 799 ++++++++++++++++++++++++++++++ man/intrinsic.matern.operators.Rd | 128 +++++ man/variogram.intrinsic.spde.Rd | 73 +++ 5 files changed, 1003 insertions(+), 1 deletion(-) create mode 100644 R/intrinsic.R create mode 100644 man/intrinsic.matern.operators.Rd create mode 100644 man/variogram.intrinsic.spde.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 226e1a95..3f271806 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,7 +16,7 @@ URL: https://davidbolin.github.io/rSPDE/ Encoding: UTF-8 RoxygenNote: 7.2.3 Suggests: knitr, rmarkdown, INLA (>= 22.12.14), testthat, rgdal, - ggplot2, lattice, splancs, optimParallel, + ggplot2, lattice, splancs, optimParallel, RSpectral, inlabru (>= 2.7.0), sn, viridis, scoringRules, doParallel, foreach Additional_repositories: https://inla.r-inla-download.org/R/testing BugReports: https://github.com/davidbolin/rSPDE/issues diff --git a/NAMESPACE b/NAMESPACE index dc77c760..5a28459a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -43,6 +43,7 @@ export(folded.matern.covariance.2d) export(fractional.operators) export(get.initial.values.rSPDE) export(gg_df) +export(intrinsic.matern.operators) export(matern.covariance) export(matern.operators) export(precision) @@ -68,6 +69,7 @@ export(rspde.result) export(rspde_lme) export(spde.matern.loglike) export(spde.matern.operators) +export(variogram.intrinsic.spde) if (getRversion() >= "3.6.0") { S3method(inlabru::bru_get_mapper, inla_rspde) S3method(inlabru::ibm_n, bru_mapper_inla_rspde) diff --git a/R/intrinsic.R b/R/intrinsic.R new file mode 100644 index 00000000..76ad12a9 --- /dev/null +++ b/R/intrinsic.R @@ -0,0 +1,799 @@ +#' @name intrinsic.operators +#' @title Covariance-based approximations of intrinsic fields +#' @description `intrinsic.operators` is used for computing a +#' covariance-based rational SPDE approximation of intrinsic +#' fields on \eqn{R^d} defined through the SPDE +#' \deqn{(-\Delta)^{\alpha/2}u = \mathcal{W}}{(-\Delta)^{\alpha/2}u = \mathcal{W}} +#' @param alpha Smoothness parameter +#' @param G The stiffness matrix of a finite element discretization +#' of the domain of interest. +#' @param C The mass matrix of a finite element discretization of +#' the domain of interest. +#' @param mesh An inla mesh. +#' @param d The dimension of the domain. +#' @param m The order of the rational approximation, which needs +#' to be a positive integer. +#' The default value is 2. +#' @param compute_higher_order Logical. Should the higher order finite +#' element matrices be computed? +#' @param return_block_list Logical. For `type = "covariance"`, +#' should the block parts of the precision matrix be returned +#' separately as a list? +#' @param type_rational_approximation Which type of rational +#' approximation should be used? The current types are +#' "chebfun", "brasil" or "chebfunLB". +#' @param fem_mesh_matrices A list containing FEM-related matrices. +#' The list should contain elements c0, g1, g2, g3, etc. +#' @param scaling second lowest eigenvalue of g1 +#' @return `intrinsic.operators` returns an object of +#' class "CBrSPDEobj". This object is a list containing the +#' following quantities: +#' \item{C}{The mass lumped mass matrix.} +#' \item{Ci}{The inverse of `C`.} +#' \item{GCi}{The stiffness matrix G times `Ci`} +#' \item{Gk}{The stiffness matrix G along with the higher-order +#' FEM-related matrices G2, G3, etc.} +#' \item{fem_mesh_matrices}{A list containing the mass lumped mass +#' matrix, the stiffness matrix and +#' the higher-order FEM-related matrices.} +#' \item{m}{The order of the rational approximation.} +#' \item{alpha}{The fractional power of the precision operator.} +#' \item{type}{String indicating the type of approximation.} +#' \item{d}{The dimension of the domain.} +#' \item{type}{String indicating the type of approximation.} +#' @details We use the covariance-based rational approximation of the +#' fractional operator. It is assumed that a mean-zero contraint is imposed +#' so that the equation has a unique solution. This contraint needs to be +#' imposed while working with the model later. +#' @noRd +intrinsic.operators <- function(C, + G, + mesh, + alpha, + m = 2, + d, + compute_higher_order = FALSE, + return_block_list = FALSE, + type_rational_approximation = c("chebfun", + "brasil", + "chebfunLB"), + fem_mesh_matrices = NULL, + scaling = NULL) { + type_rational_approximation <- type_rational_approximation[[1]] + + if (is.null(fem_mesh_matrices)) { + if (!is.null(mesh)) { + d <- get_inla_mesh_dimension(inla_mesh = mesh) + m_alpha <- floor(alpha) + m_order <- m_alpha + 1 + + if (d > 1) { + if (compute_higher_order) { + fem <- INLA::inla.mesh.fem(mesh, order = m_alpha + 1) + } else { + fem <- INLA::inla.mesh.fem(mesh) + } + + C <- fem$c0 + G <- fem$g1 + Ci <- Matrix::Diagonal(dim(C)[1], 1 / rowSums(C)) + GCi <- G %*% Ci + CiG <- Ci %*% G + Gk <- list() + Gk[[1]] <- G + for (i in 2:m_order) { + Gk[[i]] <- fem[[paste0("g", i)]] + } + } else if (d == 1) { + fem <- INLA::inla.mesh.fem(mesh, order = 2) + C <- fem$c0 + G <- fem$g1 + Ci <- Matrix::Diagonal(dim(C)[1], 1 / rowSums(C)) + GCi <- G %*% Ci + CiG <- Ci %*% G + Gk <- list() + Gk[[1]] <- G + if (compute_higher_order) { + Gk[[2]] <- fem$g2 + if (m_order > 2) { + for (i in 3:m_order) { + Gk[[i]] <- GCi %*% Gk[[i - 1]] + } + } + } + } + } else { + m_alpha <- floor(alpha) + m_order <- m_alpha + 1 + + ## get lumped mass matrix + C <- Matrix::Diagonal(dim(C)[1], rowSums(C)) + + ## get G_k matrix: k is up to m_alpha if alpha is integer, + # k is up to m_alpha + 1 otherwise. + # inverse lumped mass matrix + Ci <- Matrix::Diagonal(dim(C)[1], 1 / rowSums(C)) + + GCi <- G %*% Ci + CiG <- Ci %*% G + # create a list to store all the G_k matrix + + Gk <- list() + + Gk[[1]] <- G + # determine how many G_k matrices we want to create + if (compute_higher_order) { + for (i in 2:m_order) { + Gk[[i]] <- GCi %*% Gk[[i - 1]] + } + } + } + + # create a list contains all the finite element related matrices + fem_mesh_matrices <- list() + fem_mesh_matrices[["c0"]] <- C + fem_mesh_matrices[["g1"]] <- G + + if (compute_higher_order) { + for (i in 1:m_order) { + fem_mesh_matrices[[paste0("g", i)]] <- Gk[[i]] + } + } + } else { + C <- fem_mesh_matrices$c0 + G <- fem_mesh_matrices$g1 + Ci <- Matrix::Diagonal(dim(C)[1], 1 / rowSums(C)) + GCi <- G %*% Ci + CiG <- Ci %*% G + m_alpha <- floor(alpha) + m_order <- m_alpha + 1 + if (!is.null(mesh)) { + d <- get_inla_mesh_dimension(inla_mesh = mesh) + } + Gk <- list() + Gk[[1]] <- G + for (i in 2:m_order) { + Gk[[i]] <- fem_mesh_matrices[[paste0("g", i)]] + } + } + if(is.null(scaling)) { + scaling <- RSpectra::eigs(as(fem$g1,"CsparseMatrix"),2, which = "SM")$values[1] + } + + L <- G / scaling + + CiL <- CiG / scaling + + if (m_alpha == 0) { + aux_mat <- Diagonal(dim(L)[1]) + } else { + aux_mat <- CiL + } + + + if (return_block_list) { + Q.int <- aux_mat + + if(alpha %% 1 == 0){ + Q.frac <- Matrix::Diagonal(dim(L)[1]) + Q <- G + + if(alpha > 1){ + for(k in 1:(alpha-1)){ + Q <- Q %*% CiG + } + } + + Q.int <- Q + } else { + if(m == 0){ + stop("Return block list does not work with m = 0, either increase m or set return_block_list to FALSE.") + } + Q.frac <- intrinsic.precision(alpha = alpha, rspde.order = m, dim = d, + fem_mesh_matrices = fem_mesh_matrices, only_fractional = TRUE, + return_block_list = TRUE, + type_rational_approx = type_rational_approximation, + scaling = scaling + ) + + Q <- Q.frac + + if (m_alpha > 0) { + for (j in seq_len(length(Q))) { + for (i in 1:m_alpha) { + Q[[j]] <- Q[[j]] %*% Q.int + } + } + } + Q.int <- list(Q.int = Q.int, order = m_alpha) + } + + } else { + Q.int <- list(Q.int = kronecker(Diagonal(m + 1), aux_mat), order = m_alpha) + + if(alpha %% 1 == 0){ + Q.frac <- Matrix::Diagonal(dim(L)[1]) + Q <- G + + if(alpha > 1){ + for(k in 1:(alpha-1)){ + Q <- Q %*% CiL + } + } + + Q.int <- list(Q.int = Q, order = m_alpha) + } else if (m > 0){ + Q.frac <- intrinsic.precision( + alpha = alpha, + rspde.order = m, dim = d, + fem_mesh_matrices = fem_mesh_matrices, only_fractional = TRUE, + type_rational_approx = type_rational_approximation, + scaling = scaling + ) + + Q <- Q.frac + + if (m_alpha > 0) { + for (i in 1:m_alpha) { + Q <- Q %*% Q.int$Q.int + } + } + } else{ + stop("m > 0 required for intrinsic fields") + } + } + + ## output + output <- list( + C = C, G = G, L = L, Ci = Ci, GCi = GCi, Gk = Gk, + fem_mesh_matrices = fem_mesh_matrices, + alpha = alpha, m = m, d = d, + Q.frac = Q.frac, Q.int = Q.int, + Q = Q, sizeC = dim(C)[1], + higher_order = compute_higher_order, + type_rational_approximation = type_rational_approximation, + return_block_list = return_block_list, + stationary = TRUE + ) + output$type <- "Covariance-Based intrinsic SPDE Approximation" + class(output) <- "CBrSPDEobj" + return(output) +} + + + +intrinsic.precision <- function(alpha, rspde.order, dim, fem_mesh_matrices, + only_fractional = FALSE, return_block_list = FALSE, + type_rational_approx = "chebfun", + scaling = NULL) { + + n_m <- rspde.order + + mt <- get_rational_coefficients(n_m, type_rational_approx) + + + m_alpha <- floor(alpha) + + row_nu <- round(1000*cut_decimals(alpha)) + r <- unlist(mt[row_nu, 2:(1+rspde.order)]) + p <- unlist(mt[row_nu, (2+rspde.order):(1+2*rspde.order)]) + k <- unlist(mt[row_nu, 2+2*rspde.order]) + + if (!only_fractional) { + if (m_alpha == 0) { + L <- fem_mesh_matrices[["g1"]] / scaling + Q <- (L - p[1] * fem_mesh_matrices[["c0"]]) / r[1] + if (length(r) > 1) { + for (i in 2:length(r)) { + Q <- bdiag(Q, (L - p[i] * fem_mesh_matrices[["c0"]]) / r[i]) + } + } + } else { + Malpha <- fem_mesh_matrices[[paste0("g", m_alpha)]] / scaling^m_alpha + Malpha2 <- fem_mesh_matrices[[paste0("g", m_alpha+1)]] / scaling^(m_alpha+1) + + Q <- 1 / r[1] * (Malpha2 - p[1] * Malpha) + + if (length(r) > 1) { + for (i in 2:length(r)) { + Q <- bdiag(Q, 1 / r[i] * (Malpha2 - p[i] * Malpha)) + } + } + } + + + # add k_part into Q + + if (m_alpha == 0) { + C <- fem_mesh_matrices[["c0"]] + Kpart <- Matrix::Diagonal(dim(C)[1], 1 / rowSums(C)) + } else { + Kpart <- fem_mesh_matrices[[paste0("g", m_alpha)]] / scaling^m_alpha + } + Kpart <- Kpart / k + + Q <- bdiag(Q, Kpart) + + Q <- Q * scaling^alpha + + return(Q) + } else { + L <- fem_mesh_matrices[["g1"]] / scaling + + if (return_block_list) { + Q <- list() + + Q[[length(Q) + 1]] <- scaling^alpha * (L - p[1] * fem_mesh_matrices[["c0"]]) / r[1] + + if (n_m > 1) { + for (i in 2:(n_m)) { + Q[[length(Q) + 1]] <- scaling^alpha * + (L - p[i] * fem_mesh_matrices[["c0"]]) / r[i] + } + } + if(m_alpha==0) { + C <- fem_mesh_matrices[["c0"]] + Kpart <- Matrix::Diagonal(dim(C)[1], 1 / rowSums(C)) + } else { + Kpart <- fem_mesh_matrices[["c0"]] + } + Q[[length(Q) + 1]] <- scaling^alpha * Kpart / k + + return(Q) + } else { + Q <- (L - p[1] * fem_mesh_matrices[["c0"]]) / r[1] + + if (n_m > 1) { + for (i in 2:(n_m)) { + temp <- (L - p[i] * fem_mesh_matrices[["c0"]]) / r[i] + Q <- bdiag(Q, temp) + } + } + if(m_alpha==0) { + C <- fem_mesh_matrices[["c0"]] + Kpart <- Matrix::Diagonal(dim(C)[1], 1 / rowSums(C)) + } else { + Kpart <- fem_mesh_matrices[["c0"]] + } + + Q <- bdiag(Q, Kpart / k) + + Q <- Q * scaling^alpha + + return(Q) + } + } +} + +#' @name intrinsic.matern.operators +#' @title Covariance-based approximations of intrinsic fields +#' @description `intrinsic.matern.operators` is used for computing a +#' covariance-based rational SPDE approximation of intrinsic +#' fields on \eqn{R^d} defined through the SPDE +#' \deqn{(-\Delta)^{\beta/2}(\kappa^2-\Delta)^{\alpha/2} (\tau u) = \mathcal{W}}{(-\Delta)^{\beta/2}(\kappa^2-\Delta)^{\alpha/2} (\tau u) = \mathcal{W}} +#' @param kappa range parameter +#' @param tau precision parameter +#' @param alpha Smoothness parameter +#' @param beta Smoothness parameter +#' @param G The stiffness matrix of a finite element discretization +#' of the domain of interest. +#' @param C The mass matrix of a finite element discretization of +#' the domain of interest. +#' @param d The dimension of the domain. +#' @param mesh An inla mesh. +#' @param graph An optional `metric_graph` object. Replaces `d`, `C` and `G`. +#' @param loc_mesh locations for the mesh for `d=1`. +#' @param m_alpha The order of the rational approximation for the Matérn part, +#' which needs to be a positive integer. The default value is 2. +#' @param m_beta The order of the rational approximation for the intrinsic part, +#' which needs to be a positive integer. The default value is 2. +#' @param compute_higher_order Logical. Should the higher order finite +#' element matrices be computed? +#' @param return_block_list Logical. For `type = "covariance"`, +#' should the block parts of the precision matrix be returned +#' separately as a list? +#' @param type_rational_approximation Which type of rational +#' approximation should be used? The current types are +#' "chebfun", "brasil" or "chebfunLB". +#' @param fem_mesh_matrices A list containing FEM-related matrices. +#' The list should contain elements c0, g1, g2, g3, etc. +#' @param scaling second lowest eigenvalue of g1 +#' @return `intrinsic.matern.operators` returns an object of +#' class "intrinsicCBrSPDEobj". This object is a list containing the +#' following quantities: +#' \item{C}{The mass lumped mass matrix.} +#' \item{Ci}{The inverse of `C`.} +#' \item{GCi}{The stiffness matrix G times `Ci`} +#' \item{Gk}{The stiffness matrix G along with the higher-order +#' FEM-related matrices G2, G3, etc.} +#' \item{fem_mesh_matrices}{A list containing the mass lumped mass +#' matrix, the stiffness matrix and +#' the higher-order FEM-related matrices.} +#' \item{m_alpha}{The order of the rational approximation for the Matérn part.} +#' \item{m_beta}{The order of the rational approximation for the intrinsic part.} +#' \item{alpha}{The fractional power of the Matérn part of the operator.} +#' \item{beta}{The fractional power of the intrinsic part of the operator.} +#' \item{type}{String indicating the type of approximation.} +#' \item{d}{The dimension of the domain.} +#' \item{A}{Matrix that sums the components in the approximation to the mesh nodes.} +#' \item{kappa}{Range parameter of the covariance function} +#' \item{tau}{Scale parameter of the covariance function.} +#' \item{type}{String indicating the type of approximation.} +#' @export +#' @details The covariance operator +#' \deqn{\tau^{-2}(-\Delta)^{\beta}(\kappa^2-\Delta)^{\alpha}}{\tau^{-2}(-\Delta)^{\beta}(\kappa^2-\Delta)^{\alpha}} +#' is approximated based on rational approximations of the two fractional +#' components. The Laplacians are equipped with homogeneous Neumann boundary +#' conditions and a zero-mean constraint is additionally imposed to obtained +#' a non-intrinsic model. +#' @examples +#' x <- seq(from = 0, to = 10, length.out = 201) +#' mesh <- inla.mesh.1d(loc = x) +#' fem <- inla.mesh.1d.fem(mesh) +#' beta <- 1 +#' alpha <- 1 +#' kappa <- 1 +#' op <- intrinsic.matern.operators(kappa = kappa, tau = 1, alpha = alpha, +#' beta = beta, G = fem$g1, C = fem$c0, d=1) +#' # Compute and plot the variogram of the model +#' Sigma <- op$A %*% solve(op$Q,t(op$A)) +#' One <- rep(1, times = ncol(Sigma)) +#' D <- diag(Sigma) +#' Gamma <- 0.5*(One %*% t(D) + D %*% t(One) - 2 * Sigma) +#' k <- 100 +#' plot(x, Gamma[k, ], type = "l") +#' lines(x, +#' variogram.intrinsic.spde(x[k], x, kappa, alpha, beta, L = 10, d = 1), +#' col=2, lty = 2) +intrinsic.matern.operators <- function(kappa = NULL, + tau = NULL, + alpha = NULL, + beta = 1, + G = NULL, + C = NULL, + d = NULL, + mesh = NULL, + graph = NULL, + loc_mesh = NULL, + m_alpha = 2, + m_beta = 2, + compute_higher_order = FALSE, + return_block_list = FALSE, + type_rational_approximation = c("chebfun", + "brasil", "chebfunLB"), + fem_mesh_matrices = NULL, + scaling = NULL) { + + if (is.null(d) && is.null(mesh) && is.null(graph)) { + stop("You should give either the dimension d, the mesh or graph!") + } + + if ((is.null(C) || is.null(G)) && is.null(mesh) && is.null(graph) &&(is.null(loc_mesh) || d != 1)) { + stop("You should either provide mesh, graph, or provide both C *and* G!") + } + + if( (is.null(C) || is.null(G)) && (is.null(graph)) && (!is.null(loc_mesh) && d==1)){ + fem <- rSPDE.fem1d(loc_mesh) + C <- fem$C + G <- fem$G + } + + has_mesh <- FALSE + has_graph <- FALSE + + if(!is.null(loc_mesh)){ + if(!is.numeric(loc_mesh)){ + stop("loc_mesh must be numerical.") + } + } + + if(!is.null(graph)){ + if(!inherits(graph, "metric_graph")){ + stop("graph should be a metric_graph object!") + } + d <- 1 + if(is.null(graph$mesh)){ + warning("The graph object did not contain a mesh, one was created with h = 0.01. Use the build_mesh() method to replace this mesh with a new one.") + graph$build_mesh(h = 0.01) + } + graph$compute_fem() + C <- graph$mesh$C + G <- graph$mesh$G + has_graph <- TRUE + } + + if (!is.null(mesh)) { + d <- get_inla_mesh_dimension(inla_mesh = mesh) + fem <- INLA::inla.mesh.fem(mesh) + C <- fem$c0 + G <- fem$g1 + has_mesh <- TRUE + } + + + if(is.null(kappa) || is.null(tau) || is.null(alpha)){ + stop("You should provide all the parameters.") + } + + + kappa <- rspde_check_user_input(kappa, "kappa" , 0) + tau <- rspde_check_user_input(tau, "tau" , 0) + + alpha <- rspde_check_user_input(alpha, "alpha" , 0) + alpha <- min(alpha, 10) + + beta <- rspde_check_user_input(beta, "beta" , 0) + beta <- min(beta, 10) + + if(alpha + beta < d/2) { + stop("One must have alpha + beta > d/2") + } + + if(!is.null(mesh)){ + make_A <- function(loc){ + return(INLA::inla.spde.make.A(mesh = mesh, loc = loc)) + } + } else if(!is.null(graph)){ + make_A <- function(loc){ + return(graph$mesh_A(loc)) + } + } else if(!is.null(loc_mesh) && d == 1){ + make_A <- function(loc){ + return(rSPDE::rSPDE.A1d(x = loc_mesh, loc = loc)) + } + } else { + make_A <- NULL + } + + if(alpha>0 && beta>0 && kappa > 0) { + op1 <- CBrSPDE.matern.operators( + C = C, G = G, mesh = mesh, nu = alpha - d/2, kappa = kappa, tau = tau, + m = m_alpha, d = d, compute_higher_order = compute_higher_order, + return_block_list = TRUE, + type_rational_approximation = type_rational_approximation[[1]] + ) + op2 <-intrinsic.operators( + C = C, G = G, mesh = mesh, alpha = beta, + m = m_beta, d = d, compute_higher_order = compute_higher_order, + return_block_list = TRUE, + type_rational_approximation = type_rational_approximation[[1]], + scaling = scaling + ) + block_list <- list() + if(is.list(op1$Q)) { + Q.list1 <- op1$Q + } else { + Q.list1 <- list(op1$Q) + } + if(is.list(op2$Q)) { + Q.list2 <- op2$Q + } else { + Q.list2 <- list(op2$Q) + } + m1 <- length(Q.list1) + m2 <- length(Q.list2) + k <- 1 + if(return_block_list) { + Q <- list() + } + for(i in 1:m1) { + for(j in 1:m2) { + if(return_block_list) { + Q[[k]] <- Q.list1[[i]]%*%op1$Ci%*%Q.list2[[j]] + } else { + if(i == 1 && j == 1) { + Q <- Q.list1[[i]]%*%op1$Ci%*%Q.list2[[j]] + } else { + Q <- bdiag(Q, Q.list1[[i]]%*%op1$Ci%*%Q.list2[[j]]) + } + } + } + } + h <- rep(rowSums(op1$C),m1*m2) + if(!return_block_list) { + Q <- rbind(cbind(Q, h), c(h,0)) + } + n <- dim(op1$C)[1] + A <- cbind(kronecker(matrix(rep(1,m1*m2) , 1, m1*m2), Diagonal(n)), + Matrix(0,ncol=1,nrow=n)) + } else if (alpha > 0 && kappa > 0) { + op1 <- CBrSPDE.matern.operators( + C = C, G = G, mesh = mesh, nu = alpha - d/2, kappa = kappa, tau = tau, + m = m_alpha, d = d, compute_higher_order = compute_higher_order, + return_block_list = TRUE, + type_rational_approximation = type_rational_approximation[[1]] + ) + if(is.list(op1$Q)) { + Q.list1 <- op1$Q + } else { + Q.list1 <- list(op1$Q) + } + m1 <- length(Q.list1) + if(!return_block_list) { + for(i in 1:m1) { + if(i == 1) { + Q <- Q.list1[[i]] + } else { + Q <- bdiag(Q, Q.list1[[i]]) + } + } + } else { + Q <- Q.list1 + } + h <- rep(rowSums(op1$C),m1) + if(!return_block_list) { + Q <- rbind(cbind(Q, h), c(h,0)) + } + n <- dim(op1$C)[1] + A <- cbind(kronecker(matrix(rep(1,m1), 1, m1), Diagonal(n)), + Matrix(0,ncol=1,nrow=n)) + } else if (beta > 0) { + if(kappa == 0) { + alpha_beta = alpha + beta + } else { + alpha_beta = beta + } + op1 <-intrinsic.operators( + C = C, G = G, mesh = mesh, alpha = alpha_beta, + m = m_beta, d = d, compute_higher_order = compute_higher_order, + return_block_list = TRUE, + type_rational_approximation = type_rational_approximation[[1]] + ) + if(is.list(op1$Q)) { + Q.list1 <- op1$Q + } else { + Q.list1 <- list(op1$Q) + } + m1 <- length(Q.list1) + if(!return_block_list) { + for(i in 1:m1) { + if(i == 1) { + Q <- Q.list1[[i]] + } else { + Q <- bdiag(Q, Q.list1[[i]]) + } + } + } else { + Q <- Q.list1 + } + h <- rep(rowSums(op1$C),m1) + if(!return_block_list) { + Q <- rbind(cbind(Q, h), c(h,0)) + } + n <- dim(op1$C)[1] + A <- cbind(kronecker(matrix(rep(1,m1), 1, m1), Diagonal(n)), + Matrix(0,ncol=1,nrow=n)) + } + + + + out <- list(C = op1$C, G = op1$G, Ci = op1$Ci, GCi = op1$GCi, + Q = Q, + alpha = alpha, beta = beta, kappa = kappa, tau = tau, + m_alpha = m_alpha, m_beta = m_beta, d = d, + type_rational_approximation = type_rational_approximation[[1]], + higher_order = compute_higher_order, + return_block_list = return_block_list, + stationary = TRUE, + has_mesh = has_mesh, + has_graph = has_graph, + make_A = make_A, + A = A, + mesh = mesh, + graph = graph + ) + out$type <- "Covariance-Based intrinsic Matern SPDE Approximation" + class(out) <- "intrinsicCBrSPDEobj" + + return(out) +} + + +#' @name variogram.intrinsic.spde +#' @title Variogram of intrinsic SPDE model +#' @description Variogram \eqn{\gamma(s_0,s)}{\gamma(s_0,s)} of intrinsic SPDE +#' model +#' \deqn{(-\Delta)^{\beta/2}(\kappa^2-\Delta)^{\alpha/2} (\tau u) = \mathcal{W}}{(-\Delta)^{\beta/2}(\kappa^2-\Delta)^{\alpha/2} (\tau u) = \mathcal{W}} +#' with Neumann boundary conditions and a mean-zero constraint on a +#' square \eqn{[0,L]^d}{[0,L]^d} for \eqn{d=1}{d=1} or \eqn{d=2}{d=2}. +#' @param s0 The location where the variogram should be evaluated, either +#' a double for 1d or a vector for 2d +#' @param s A vector (in 1d) or matrix (in 2d) with all locations where the +#' variogram is computed +#' @param kappa Range parameter. +#' @param alpha Smoothness parameter. +#' @param beta Smoothness parameter. +#' @param tau Precision parameter. +#' @param L The side length of the square domain. +#' @param N The number of terms in the Karhunen-Loeve expansion. +#' @param d The dimension (1 or 2). +#' @details The variogram is computed based on a Karhunen-Loeve expansion of the +#' covariance function. +#' +#' @return +#' @export +#' @seealso [intrinsic.matern.operators()] +#' +#' @examples +#' x <- seq(from = 0, to = 10, length.out = 201) +#' mesh <- inla.mesh.1d(loc = x) +#' fem <- inla.mesh.1d.fem(mesh) +#' beta <- 1 +#' alpha <- 1 +#' kappa <- 1 +#' op <- intrinsic.matern.operators(kappa = kappa, tau = 1, alpha = alpha, +#' beta = beta, G = fem$g1, C = fem$c0, d=1) +#' # Compute and plot the variogram of the model +#' Sigma <- op$A %*% solve(op$Q,t(op$A)) +#' One <- rep(1, times = ncol(Sigma)) +#' D <- diag(Sigma) +#' Gamma <- 0.5*(One %*% t(D) + D %*% t(One) - 2 * Sigma) +#' k <- 100 +#' plot(x, Gamma[k, ], type = "l") +#' lines(x, +#' variogram.intrinsic.spde(x[k], x, kappa, alpha, beta, L = 10, d = 1), +#' col=2, lty = 2) +variogram.intrinsic.spde <- function(s0 = NULL, + s = NULL, + kappa = NULL, + alpha = NULL, + beta = NULL, + tau = 1, + L = NULL, + N = 100, + d = NULL) { + if(is.null(kappa) || is.null(alpha) || is.null(beta)) { + stop("All model parameters must be provided.") + } + if(is.null(s0) || is.null(s) || is.null(d) || is.null(L)) { + stop("s0, s, L and d must be provided.") + } + + if(d==1) { + if(is.matrix(s)) { + n = max(dim(s)) + if(min(dim(s))>1) { + stop("s has wrong dimensions for d = 1") + } + } else { + n = length(s) + } + vario <- rep(0,n) + for(i in 1:N) { + lambda <- (i*pi/L)^(-2*beta)*((i*pi/L)^2+kappa^2)^(-alpha) + vario <- vario + 0.5*(2/L)*lambda*(cos(i*pi*s/L)-cos(i*pi*s0/L))^2 + } + } else if (d == 2) { + if(!is.matrix(s)) { + stop("s should be a matrix if d=2") + } + vario <- rep(0,dim(s)[1]) + for(i in 1:N) { + f <- i^2*pi^2/L^2 + lambda <- f^(-beta)*(f+kappa^2)^(-alpha) + e1 <- (sqrt(2)/L)*cos(i*pi*s[,1]/L) + e2 <- (sqrt(2)/L)*cos(i*pi*s0[1]/L) + vario <- vario + 0.5*lambda*(e1-e2)^2 + } + for(i in 1:N) { + f <- i^2*pi^2/L^2 + lambda <- f^(-beta)*(f+kappa^2)^(-alpha) + e1 <- (sqrt(2)/L)*cos(i*pi*s[,2]/L) + e2 <- (sqrt(2)/L)*cos(i*pi*s0[2]/L) + vario <- vario + 0.5*lambda*(e1-e2)^2 + } + for(i in 1:N) { + for(j in 1:N) { + f <- (i^2+j^2)*pi^2/L^2 + lambda <- f^(-beta)*(f+kappa^2)^(-alpha) + e1 <- (2/L)*cos(i*pi*s[,1]/L)*cos(j*pi*s[,2]/L) + e2 <- (2/L)*cos(i*pi*s0[1]/L)*cos(j*pi*s0[2]/L) + vario <- vario + 0.5*lambda*(e1-e2)^2 + } + } + } else { + stop("d should be 1 or 2.") + } + return(vario/tau^2) +} + diff --git a/man/intrinsic.matern.operators.Rd b/man/intrinsic.matern.operators.Rd new file mode 100644 index 00000000..5a894ed8 --- /dev/null +++ b/man/intrinsic.matern.operators.Rd @@ -0,0 +1,128 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/intrinsic.R +\name{intrinsic.matern.operators} +\alias{intrinsic.matern.operators} +\title{Covariance-based approximations of intrinsic fields} +\usage{ +intrinsic.matern.operators( + kappa = NULL, + tau = NULL, + alpha = NULL, + beta = 1, + G = NULL, + C = NULL, + d = NULL, + mesh = NULL, + graph = NULL, + loc_mesh = NULL, + m_alpha = 2, + m_beta = 2, + compute_higher_order = FALSE, + return_block_list = FALSE, + type_rational_approximation = c("chebfun", "brasil", "chebfunLB"), + fem_mesh_matrices = NULL, + scaling = NULL +) +} +\arguments{ +\item{kappa}{range parameter} + +\item{tau}{precision parameter} + +\item{alpha}{Smoothness parameter} + +\item{beta}{Smoothness parameter} + +\item{G}{The stiffness matrix of a finite element discretization +of the domain of interest.} + +\item{C}{The mass matrix of a finite element discretization of +the domain of interest.} + +\item{d}{The dimension of the domain.} + +\item{mesh}{An inla mesh.} + +\item{graph}{An optional \code{metric_graph} object. Replaces \code{d}, \code{C} and \code{G}.} + +\item{loc_mesh}{locations for the mesh for \code{d=1}.} + +\item{m_alpha}{The order of the rational approximation for the Matérn part, +which needs to be a positive integer. The default value is 2.} + +\item{m_beta}{The order of the rational approximation for the intrinsic part, +which needs to be a positive integer. The default value is 2.} + +\item{compute_higher_order}{Logical. Should the higher order finite +element matrices be computed?} + +\item{return_block_list}{Logical. For \code{type = "covariance"}, +should the block parts of the precision matrix be returned +separately as a list?} + +\item{type_rational_approximation}{Which type of rational +approximation should be used? The current types are +"chebfun", "brasil" or "chebfunLB".} + +\item{fem_mesh_matrices}{A list containing FEM-related matrices. +The list should contain elements c0, g1, g2, g3, etc.} + +\item{scaling}{second lowest eigenvalue of g1} +} +\value{ +\code{intrinsic.matern.operators} returns an object of +class "intrinsicCBrSPDEobj". This object is a list containing the +following quantities: +\item{C}{The mass lumped mass matrix.} +\item{Ci}{The inverse of \code{C}.} +\item{GCi}{The stiffness matrix G times \code{Ci}} +\item{Gk}{The stiffness matrix G along with the higher-order +FEM-related matrices G2, G3, etc.} +\item{fem_mesh_matrices}{A list containing the mass lumped mass +matrix, the stiffness matrix and +the higher-order FEM-related matrices.} +\item{m_alpha}{The order of the rational approximation for the Matérn part.} +\item{m_beta}{The order of the rational approximation for the intrinsic part.} +\item{alpha}{The fractional power of the Matérn part of the operator.} +\item{beta}{The fractional power of the intrinsic part of the operator.} +\item{type}{String indicating the type of approximation.} +\item{d}{The dimension of the domain.} +\item{A}{Matrix that sums the components in the approximation to the mesh nodes.} +\item{kappa}{Range parameter of the covariance function} +\item{tau}{Scale parameter of the covariance function.} +\item{type}{String indicating the type of approximation.} +} +\description{ +\code{intrinsic.matern.operators} is used for computing a +covariance-based rational SPDE approximation of intrinsic +fields on \eqn{R^d} defined through the SPDE +\deqn{(-\Delta)^{\beta/2}(\kappa^2-\Delta)^{\alpha/2} (\tau u) = \mathcal{W}}{(-\Delta)^{\beta/2}(\kappa^2-\Delta)^{\alpha/2} (\tau u) = \mathcal{W}} +} +\details{ +The covariance operator +\deqn{\tau^{-2}(-\Delta)^{\beta}(\kappa^2-\Delta)^{\alpha}}{\tau^{-2}(-\Delta)^{\beta}(\kappa^2-\Delta)^{\alpha}} +is approximated based on rational approximations of the two fractional +components. The Laplacians are equipped with homogeneous Neumann boundary +conditions and a zero-mean constraint is additionally imposed to obtained +a non-intrinsic model. +} +\examples{ +x <- seq(from = 0, to = 10, length.out = 201) +mesh <- inla.mesh.1d(loc = x) +fem <- inla.mesh.1d.fem(mesh) +beta <- 1 +alpha <- 1 +kappa <- 1 +op <- intrinsic.matern.operators(kappa = kappa, tau = 1, alpha = alpha, + beta = beta, G = fem$g1, C = fem$c0, d=1) +# Compute and plot the variogram of the model +Sigma <- op$A \%*\% solve(op$Q,t(op$A)) +One <- rep(1, times = ncol(Sigma)) +D <- diag(Sigma) +Gamma <- 0.5*(One \%*\% t(D) + D \%*\% t(One) - 2 * Sigma) +k <- 100 +plot(x, Gamma[k, ], type = "l") +lines(x, + variogram.intrinsic.spde(x[k], x, kappa, alpha, beta, L = 10, d = 1), + col=2, lty = 2) +} diff --git a/man/variogram.intrinsic.spde.Rd b/man/variogram.intrinsic.spde.Rd new file mode 100644 index 00000000..df8aaa1c --- /dev/null +++ b/man/variogram.intrinsic.spde.Rd @@ -0,0 +1,73 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/intrinsic.R +\name{variogram.intrinsic.spde} +\alias{variogram.intrinsic.spde} +\title{Variogram of intrinsic SPDE model} +\usage{ +variogram.intrinsic.spde( + s0 = NULL, + s = NULL, + kappa = NULL, + alpha = NULL, + beta = NULL, + tau = 1, + L = NULL, + N = 100, + d = NULL +) +} +\arguments{ +\item{s0}{The location where the variogram should be evaluated, either +a double for 1d or a vector for 2d} + +\item{s}{A vector (in 1d) or matrix (in 2d) with all locations where the +variogram is computed} + +\item{kappa}{Range parameter.} + +\item{alpha}{Smoothness parameter.} + +\item{beta}{Smoothness parameter.} + +\item{tau}{Precision parameter.} + +\item{L}{The side length of the square domain.} + +\item{N}{The number of terms in the Karhunen-Loeve expansion.} + +\item{d}{The dimension (1 or 2).} +} +\description{ +Variogram \eqn{\gamma(s_0,s)}{\gamma(s_0,s)} of intrinsic SPDE +model +\deqn{(-\Delta)^{\beta/2}(\kappa^2-\Delta)^{\alpha/2} (\tau u) = \mathcal{W}}{(-\Delta)^{\beta/2}(\kappa^2-\Delta)^{\alpha/2} (\tau u) = \mathcal{W}} +with Neumann boundary conditions and a mean-zero constraint on a +square \eqn{[0,L]^d}{[0,L]^d} for \eqn{d=1}{d=1} or \eqn{d=2}{d=2}. +} +\details{ +The variogram is computed based on a Karhunen-Loeve expansion of the +covariance function. +} +\examples{ +x <- seq(from = 0, to = 10, length.out = 201) +mesh <- inla.mesh.1d(loc = x) +fem <- inla.mesh.1d.fem(mesh) +beta <- 1 +alpha <- 1 +kappa <- 1 +op <- intrinsic.matern.operators(kappa = kappa, tau = 1, alpha = alpha, + beta = beta, G = fem$g1, C = fem$c0, d=1) +# Compute and plot the variogram of the model +Sigma <- op$A \%*\% solve(op$Q,t(op$A)) +One <- rep(1, times = ncol(Sigma)) +D <- diag(Sigma) +Gamma <- 0.5*(One \%*\% t(D) + D \%*\% t(One) - 2 * Sigma) +k <- 100 +plot(x, Gamma[k, ], type = "l") +lines(x, + variogram.intrinsic.spde(x[k], x, kappa, alpha, beta, L = 10, d = 1), + col=2, lty = 2) +} +\seealso{ +\code{\link[=intrinsic.matern.operators]{intrinsic.matern.operators()}} +} From 163c1bd47897422b201c6b63b9c4bba44498e56b Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Tue, 30 May 2023 01:32:02 +0300 Subject: [PATCH 37/47] Small adjusts to pass checks + moving numderiv to suggest --- DESCRIPTION | 4 +-- R/inlabru_rspde.R | 14 ---------- R/intrinsic.R | 45 ++++++++++++++++++------------- man/cross_validation.Rd | 15 ----------- man/intrinsic.matern.operators.Rd | 10 +++---- man/variogram.intrinsic.spde.Rd | 4 +-- 6 files changed, 33 insertions(+), 59 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 9b22d6ef..d64ebe38 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -10,13 +10,13 @@ Authors@R: c( Maintainer: David Bolin Description: Functions that compute rational approximations of fractional elliptic stochastic partial differential equations. The package also contains functions for common statistical usage of these approximations. The main references for rSPDE are Bolin, Simas and Xiong (2023) for the covariance-based method and Bolin and Kirchner (2020) for the operator-based rational approximation. These can be generated by the citation function in R. Depends: R (>= 3.5.0), Matrix -Imports: stats, methods, numDeriv +Imports: stats, methods License: GPL (>=3) | file LICENSE URL: https://davidbolin.github.io/rSPDE/ Encoding: UTF-8 RoxygenNote: 7.2.3 Suggests: knitr, rmarkdown, INLA (>= 22.12.14), testthat, rgdal, - ggplot2, lattice, splancs, optimParallel, RSpectral, + ggplot2, lattice, splancs, optimParallel, RSpectra, numDeriv, inlabru (>= 2.7.0), sn, viridis, scoringRules, doParallel, foreach Additional_repositories: https://inla.r-inla-download.org/R/testing BugReports: https://github.com/davidbolin/rSPDE/issues diff --git a/R/inlabru_rspde.R b/R/inlabru_rspde.R index c1a3cca4..ccd6eb19 100644 --- a/R/inlabru_rspde.R +++ b/R/inlabru_rspde.R @@ -362,20 +362,6 @@ prepare_df_pred <- function(df_pred, result, idx_test){ #' @param fit_verbose Should INLA's run during cross-validation be verbose? #' @return A data.frame with the fitted models and the corresponding scores. #' @export -#' @examples -#' \donttest{ #devel version -#' if (requireNamespace("INLA", quietly = TRUE)){ -#' library(INLA) -#' if (requireNamespace("inlabru", quietly = TRUE)){ -#' library(inlabru) -#' -#' set.seed(123) -#' -#' -#' } -#' #devel.tag -#' } -#' } cross_validation <- function(models, model_names = NULL, scores = c("mse", "crps", "scrps", "dss"), cv_type = c("k-fold", "loo", "lpo"), diff --git a/R/intrinsic.R b/R/intrinsic.R index 76ad12a9..24b4ae14 100644 --- a/R/intrinsic.R +++ b/R/intrinsic.R @@ -157,7 +157,7 @@ intrinsic.operators <- function(C, } } if(is.null(scaling)) { - scaling <- RSpectra::eigs(as(fem$g1,"CsparseMatrix"),2, which = "SM")$values[1] + scaling <- RSpectra::eigs(as(G,"CsparseMatrix"),2, which = "SM")$values[1] } L <- G / scaling @@ -428,13 +428,11 @@ intrinsic.precision <- function(alpha, rspde.order, dim, fem_mesh_matrices, #' a non-intrinsic model. #' @examples #' x <- seq(from = 0, to = 10, length.out = 201) -#' mesh <- inla.mesh.1d(loc = x) -#' fem <- inla.mesh.1d.fem(mesh) #' beta <- 1 #' alpha <- 1 #' kappa <- 1 #' op <- intrinsic.matern.operators(kappa = kappa, tau = 1, alpha = alpha, -#' beta = beta, G = fem$g1, C = fem$c0, d=1) +#' beta = beta, loc_mesh = x, d=1) #' # Compute and plot the variogram of the model #' Sigma <- op$A %*% solve(op$Q,t(op$A)) #' One <- rep(1, times = ncol(Sigma)) @@ -445,9 +443,9 @@ intrinsic.precision <- function(alpha, rspde.order, dim, fem_mesh_matrices, #' lines(x, #' variogram.intrinsic.spde(x[k], x, kappa, alpha, beta, L = 10, d = 1), #' col=2, lty = 2) -intrinsic.matern.operators <- function(kappa = NULL, - tau = NULL, - alpha = NULL, +intrinsic.matern.operators <- function(kappa, + tau, + alpha , beta = 1, G = NULL, C = NULL, @@ -476,6 +474,22 @@ intrinsic.matern.operators <- function(kappa = NULL, fem <- rSPDE.fem1d(loc_mesh) C <- fem$C G <- fem$G + + fem_mesh_matrices <- list() + fem_mesh_matrices[["c0"]] <- C + fem_mesh_matrices[["g1"]] <- G + + Gk <- list() + Gk[[1]] <- G + + m_alpha <- floor(alpha) + m_order <- m_alpha + 1 + + if (compute_higher_order) { + for (i in 1:m_order) { + fem_mesh_matrices[[paste0("g", i)]] <- Gk[[i]] + } + } } has_mesh <- FALSE @@ -511,10 +525,6 @@ intrinsic.matern.operators <- function(kappa = NULL, } - if(is.null(kappa) || is.null(tau) || is.null(alpha)){ - stop("You should provide all the parameters.") - } - kappa <- rspde_check_user_input(kappa, "kappa" , 0) tau <- rspde_check_user_input(tau, "tau" , 0) @@ -548,6 +558,7 @@ intrinsic.matern.operators <- function(kappa = NULL, if(alpha>0 && beta>0 && kappa > 0) { op1 <- CBrSPDE.matern.operators( C = C, G = G, mesh = mesh, nu = alpha - d/2, kappa = kappa, tau = tau, + fem_mesh_matrices = fem_mesh_matrices, m = m_alpha, d = d, compute_higher_order = compute_higher_order, return_block_list = TRUE, type_rational_approximation = type_rational_approximation[[1]] @@ -555,7 +566,7 @@ intrinsic.matern.operators <- function(kappa = NULL, op2 <-intrinsic.operators( C = C, G = G, mesh = mesh, alpha = beta, m = m_beta, d = d, compute_higher_order = compute_higher_order, - return_block_list = TRUE, + return_block_list = TRUE, fem_mesh_matrices = fem_mesh_matrices, type_rational_approximation = type_rational_approximation[[1]], scaling = scaling ) @@ -599,6 +610,7 @@ intrinsic.matern.operators <- function(kappa = NULL, } else if (alpha > 0 && kappa > 0) { op1 <- CBrSPDE.matern.operators( C = C, G = G, mesh = mesh, nu = alpha - d/2, kappa = kappa, tau = tau, + fem_mesh_matrices = fem_mesh_matrices, m = m_alpha, d = d, compute_higher_order = compute_higher_order, return_block_list = TRUE, type_rational_approximation = type_rational_approximation[[1]] @@ -636,7 +648,7 @@ intrinsic.matern.operators <- function(kappa = NULL, op1 <-intrinsic.operators( C = C, G = G, mesh = mesh, alpha = alpha_beta, m = m_beta, d = d, compute_higher_order = compute_higher_order, - return_block_list = TRUE, + return_block_list = TRUE, fem_mesh_matrices = fem_mesh_matrices, type_rational_approximation = type_rational_approximation[[1]] ) if(is.list(op1$Q)) { @@ -665,8 +677,6 @@ intrinsic.matern.operators <- function(kappa = NULL, Matrix(0,ncol=1,nrow=n)) } - - out <- list(C = op1$C, G = op1$G, Ci = op1$Ci, GCi = op1$GCi, Q = Q, alpha = alpha, beta = beta, kappa = kappa, tau = tau, @@ -710,19 +720,16 @@ intrinsic.matern.operators <- function(kappa = NULL, #' @details The variogram is computed based on a Karhunen-Loeve expansion of the #' covariance function. #' -#' @return #' @export #' @seealso [intrinsic.matern.operators()] #' #' @examples #' x <- seq(from = 0, to = 10, length.out = 201) -#' mesh <- inla.mesh.1d(loc = x) -#' fem <- inla.mesh.1d.fem(mesh) #' beta <- 1 #' alpha <- 1 #' kappa <- 1 #' op <- intrinsic.matern.operators(kappa = kappa, tau = 1, alpha = alpha, -#' beta = beta, G = fem$g1, C = fem$c0, d=1) +#' beta = beta, loc_mesh = x, d=1) #' # Compute and plot the variogram of the model #' Sigma <- op$A %*% solve(op$Q,t(op$A)) #' One <- rep(1, times = ncol(Sigma)) diff --git a/man/cross_validation.Rd b/man/cross_validation.Rd index 1daab99c..276b212e 100644 --- a/man/cross_validation.Rd +++ b/man/cross_validation.Rd @@ -72,18 +72,3 @@ A data.frame with the fitted models and the corresponding scores. Obtain several scores for a list of fitted models according to a folding scheme. } -\examples{ -\donttest{ #devel version -if (requireNamespace("INLA", quietly = TRUE)){ -library(INLA) -if (requireNamespace("inlabru", quietly = TRUE)){ -library(inlabru) - -set.seed(123) - - -} -#devel.tag -} -} -} diff --git a/man/intrinsic.matern.operators.Rd b/man/intrinsic.matern.operators.Rd index 5a894ed8..599a989e 100644 --- a/man/intrinsic.matern.operators.Rd +++ b/man/intrinsic.matern.operators.Rd @@ -5,9 +5,9 @@ \title{Covariance-based approximations of intrinsic fields} \usage{ intrinsic.matern.operators( - kappa = NULL, - tau = NULL, - alpha = NULL, + kappa, + tau, + alpha, beta = 1, G = NULL, C = NULL, @@ -108,13 +108,11 @@ a non-intrinsic model. } \examples{ x <- seq(from = 0, to = 10, length.out = 201) -mesh <- inla.mesh.1d(loc = x) -fem <- inla.mesh.1d.fem(mesh) beta <- 1 alpha <- 1 kappa <- 1 op <- intrinsic.matern.operators(kappa = kappa, tau = 1, alpha = alpha, - beta = beta, G = fem$g1, C = fem$c0, d=1) + beta = beta, loc_mesh = x, d=1) # Compute and plot the variogram of the model Sigma <- op$A \%*\% solve(op$Q,t(op$A)) One <- rep(1, times = ncol(Sigma)) diff --git a/man/variogram.intrinsic.spde.Rd b/man/variogram.intrinsic.spde.Rd index df8aaa1c..e7c9c55c 100644 --- a/man/variogram.intrinsic.spde.Rd +++ b/man/variogram.intrinsic.spde.Rd @@ -50,13 +50,11 @@ covariance function. } \examples{ x <- seq(from = 0, to = 10, length.out = 201) -mesh <- inla.mesh.1d(loc = x) -fem <- inla.mesh.1d.fem(mesh) beta <- 1 alpha <- 1 kappa <- 1 op <- intrinsic.matern.operators(kappa = kappa, tau = 1, alpha = alpha, - beta = beta, G = fem$g1, C = fem$c0, d=1) + beta = beta, loc_mesh = x, d=1) # Compute and plot the variogram of the model Sigma <- op$A \%*\% solve(op$Q,t(op$A)) One <- rep(1, times = ncol(Sigma)) From 5a079d16e87ee1234458f5921fa7ade18c7abf1a Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Tue, 30 May 2023 01:52:12 +0300 Subject: [PATCH 38/47] Update _pkgdown.yml --- pkgdown/_pkgdown.yml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index 73ee93fa..0d8a7378 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -58,6 +58,10 @@ reference: - rspde_lme - predict.rspde_lme - summary.rspde_lme + - title: Intrinsic models + contents: + - intrinsic.matern.operators + - variogram.intrinsic.spde - title: Log-likelihood contents: - rSPDE.matern.loglike From 2b8904a67d639b8f3007601264f97b225c61e0b6 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Tue, 30 May 2023 10:24:02 +0300 Subject: [PATCH 39/47] Adjusts on vignettes --- R/fractional.computations.R | 49 ++++++++++++++++++++++---------- R/fractional.operators.R | 23 +++++++++++---- R/rspde_lme.R | 1 - man/matern.operators.Rd | 5 +++- vignettes/rSPDE.Rmd | 56 +++++++++++++++++++++++++++++++++++-- vignettes/rspde_cov.Rmd | 22 +++++++++------ vignettes/rspde_inla.Rmd | 17 +++++++++++ vignettes/rspde_inlabru.Rmd | 22 +++++++++++++-- 8 files changed, 159 insertions(+), 36 deletions(-) diff --git a/R/fractional.computations.R b/R/fractional.computations.R index 5d7bbd14..6bc1932e 100644 --- a/R/fractional.computations.R +++ b/R/fractional.computations.R @@ -154,9 +154,9 @@ update.CBrSPDEobj <- function(object, user_nu = NULL, user_alpha = NULL, return_block_list = object$return_block_list, ...) { new_object <- object + d <- object$d if(object$stationary){ - d <- object$d fem_mesh_matrices <- object$fem_mesh_matrices @@ -278,7 +278,8 @@ update.CBrSPDEobj <- function(object, user_nu = NULL, user_alpha = NULL, type = "covariance", return_block_list = return_block_list, type_rational_approximation = type_rational_approximation, - fem_mesh_matrices = new_object$fem_mesh_matrices + fem_mesh_matrices = new_object$fem_mesh_matrices, + compute_logdet = new_object$compute_logdet ) } else{ ## get parameters @@ -1457,7 +1458,7 @@ aux_CBrSPDE.matern.loglike <- function(object, Y, A, sigma.e, mu = 0, Q <- object$Q - if(object$stationary){ + if(object$stationary && object$compute_logdet){ Q.frac <- object$Q.frac Q.fracR <- Matrix::Cholesky(Q.frac) @@ -2331,16 +2332,13 @@ construct.spde.matern.loglike <- function(object, Y, A, #' @noRd -aux_lme_CBrSPDE.matern.loglike <- function(object, y, X_cov, repl, A_list, sigma_e, beta_cov) { +aux2_lme_CBrSPDE.matern.loglike <- function(object, y, X_cov, repl, A_list, sigma_e, beta_cov) { m <- object$m Q <- object$Q # R <- tryCatch(Matrix::chol(Matrix::forceSymmetric(Q)), error=function(e){return(NULL)}) - R <- tryCatch(Matrix::Cholesky(Q), error = function(e){return(NULL)}) - if(is.null(R)){ - return(-10^100) - } + R <- Matrix::Cholesky(Q) prior.ld <- c(determinant(R, logarithm = TRUE)$modulus) @@ -2370,11 +2368,7 @@ aux_lme_CBrSPDE.matern.loglike <- function(object, y, X_cov, repl, A_list, sigma # if(is.null(R.p)){ # return(-10^100) # } - - R.p <- tryCatch(Matrix::Cholesky(Q.p), error=function(e){return(NULL)}) - if(is.null(R.p)){ - return(-10^100) - } + R.p <- Matrix::Cholesky(Q.p) posterior.ld <- c(determinant(R.p, logarithm = TRUE)$modulus) @@ -2392,7 +2386,6 @@ aux_lme_CBrSPDE.matern.loglike <- function(object, y, X_cov, repl, A_list, sigma } # mu.p <- solve(Q.p,as.vector(t(A_tmp) %*% v / sigma_e^2)) - mu.p <- solve(R.p, as.vector(t(A_tmp) %*% v / sigma_e^2), system = "A") v <- v - A_tmp%*%mu.p @@ -2405,11 +2398,24 @@ aux_lme_CBrSPDE.matern.loglike <- function(object, y, X_cov, repl, A_list, sigma return(as.double(l)) } +#' @noRd + +aux_lme_CBrSPDE.matern.loglike <- function(object, y, X_cov, repl, A_list, sigma_e, beta_cov) { + l_tmp <- tryCatch(aux2_lme_CBrSPDE.matern.loglike(object = object, + y = y, X_cov = X_cov, repl = repl, A_list = A_list, + sigma_e = sigma_e, beta_cov = beta_cov), + error = function(e){return(NULL)}) + if(is.null(l_tmp)){ + return(-10^100) + } + return(l_tmp) +} + #' @noRd -aux_lme_rSPDE.matern.loglike <- function(object, y, X_cov, repl, A_list, sigma_e, beta_cov) { +aux2_lme_rSPDE.matern.loglike <- function(object, y, X_cov, repl, A_list, sigma_e, beta_cov) { m <- object$m Q <- object$Q @@ -2474,4 +2480,17 @@ aux_lme_rSPDE.matern.loglike <- function(object, y, X_cov, repl, A_list, sigma_e } return(as.double(l)) +} + +#' @noRd + +aux_lme_rSPDE.matern.loglike <- function(object, y, X_cov, repl, A_list, sigma_e, beta_cov) { + l_tmp <- tryCatch(aux2_lme_rSPDE.matern.loglike(object = object, + y = y, X_cov = X_cov, repl = repl, A_list = A_list, + sigma_e = sigma_e, beta_cov = beta_cov), + error = function(e){return(NULL)}) + if(is.null(l_tmp)){ + return(-10^100) + } + return(l_tmp) } \ No newline at end of file diff --git a/R/fractional.operators.R b/R/fractional.operators.R index f136abb7..51312548 100644 --- a/R/fractional.operators.R +++ b/R/fractional.operators.R @@ -235,6 +235,7 @@ fractional.operators <- function(L, #' "chebfun", "brasil" or "chebfunLB". #' @param fem_mesh_matrices A list containing FEM-related matrices. #' The list should contain elements c0, g1, g2, g3, etc. +#' @param compute_logdet Should log determinants be computed while building the model? (For covariance-based models) #' @return If `type` is "covariance", then `matern.operators` #' returns an object of class "CBrSPDEobj". #' This object is a list containing the @@ -393,7 +394,8 @@ matern.operators <- function(kappa = NULL, return_block_list = FALSE, type_rational_approximation = c("chebfun", "brasil", "chebfunLB"), - fem_mesh_matrices = NULL) { + fem_mesh_matrices = NULL, + compute_logdet = FALSE) { type <- type[[1]] if (!type %in% c("covariance", "operator")) { @@ -600,7 +602,8 @@ matern.operators <- function(kappa = NULL, C = C, G = G, mesh = mesh, nu = nu, kappa = kappa, tau = tau, m = m, d = d, compute_higher_order = compute_higher_order, return_block_list = return_block_list, - type_rational_approximation = type_rational_approximation + type_rational_approximation = type_rational_approximation, + compute_logdet = compute_logdet ) out$range <- range out$tau <- tau @@ -642,6 +645,7 @@ matern.operators <- function(kappa = NULL, #' @param m The order of the rational approximation, which needs #' to be a positive integer. #' The default value is 2. +#' @param compute_logdet Should log determinants be computed while building the model? #' @return `CBrSPDE.matern.operators` returns an object of #' class "CBrSPDEobj". This object is a list containing the #' following quantities: @@ -732,7 +736,8 @@ CBrSPDE.matern.operators <- function(C, return_block_list = FALSE, type_rational_approximation = c("chebfun", "brasil", "chebfunLB"), - fem_mesh_matrices = NULL) { + fem_mesh_matrices = NULL, + compute_logdet) { type_rational_approximation <- type_rational_approximation[[1]] if (is.null(fem_mesh_matrices)) { @@ -843,10 +848,15 @@ CBrSPDE.matern.operators <- function(C, L <- (G + kappa^2 * C) / kappa^2 - Lchol <- Matrix::Cholesky(L) - logdetL <- 2 * c(determinant(Lchol, logarithm = TRUE)$modulus) + if(compute_logdet){ + Lchol <- Matrix::Cholesky(L) + logdetL <- 2 * c(determinant(Lchol, logarithm = TRUE)$modulus) - logdetC <- sum(log(diag(C))) + logdetC <- sum(log(diag(C))) + } else{ + logdetL <- NULL + logdetC <- NULL + } CiL <- GCi / kappa^2 + Diagonal(dim(GCi)[1]) @@ -952,6 +962,7 @@ CBrSPDE.matern.operators <- function(C, stationary = TRUE ) output$type <- "Covariance-Based Matern SPDE Approximation" + output$compute_logdet <- compute_logdet class(output) <- "CBrSPDEobj" return(output) } diff --git a/R/rspde_lme.R b/R/rspde_lme.R index ea04a842..822ec57e 100644 --- a/R/rspde_lme.R +++ b/R/rspde_lme.R @@ -307,7 +307,6 @@ rspde_lme <- function(formula, loc, data, if(inherits(model, "CBrSPDEobj")){ likelihood <- function(theta){ - sigma_e <- exp(theta[1]) n_cov <- ncol(X_cov) n_initial <- n_coeff_nonfixed diff --git a/man/matern.operators.Rd b/man/matern.operators.Rd index 8a4d4c0e..e48b2fef 100644 --- a/man/matern.operators.Rd +++ b/man/matern.operators.Rd @@ -24,7 +24,8 @@ matern.operators( compute_higher_order = FALSE, return_block_list = FALSE, type_rational_approximation = c("chebfun", "brasil", "chebfunLB"), - fem_mesh_matrices = NULL + fem_mesh_matrices = NULL, + compute_logdet = FALSE ) } \arguments{ @@ -78,6 +79,8 @@ approximation should be used? The current types are \item{fem_mesh_matrices}{A list containing FEM-related matrices. The list should contain elements c0, g1, g2, g3, etc.} + +\item{compute_logdet}{Should log determinants be computed while building the model? (For covariance-based models)} } \value{ If \code{type} is "covariance", then \code{matern.operators} diff --git a/vignettes/rSPDE.Rmd b/vignettes/rSPDE.Rmd index 2e5aadf3..541297b8 100644 --- a/vignettes/rSPDE.Rmd +++ b/vignettes/rSPDE.Rmd @@ -180,9 +180,9 @@ covariance. We also set $\sigma=1$ and the range as $0.2$. ```{r, message=FALSE} library(rSPDE) -sigma <- 1 +sigma <- 1.3 range <- 0.2 -nu <- 0.5 +nu <- 0.6 kappa <- sqrt(8 * nu) / range op <- matern.operators( mesh = mesh_2d, nu = nu, @@ -324,6 +324,27 @@ result_df <- data.frame( print(result_df) ``` +We can also obtain the summary in the `matern` parameterization by setting the `parameterization` argument to `matern`: + +```{r} +result_fit_matern <- rspde.result(rspde_fit, "field", rspde_model, + parameterization = "matern") +summary(result_fit_matern) +result_df_matern <- data.frame( + parameter = c("sigma", "range", "nu"), + true = c(sigma, range, nu), mean = c( + result_fit_matern$summary.std.dev$mean, + result_fit_matern$summary.range$mean, + result_fit_matern$summary.nu$mean + ), + mode = c( + result_fit_matern$summary.std.dev$mode, + result_fit_matern$summary.range$mode, + result_fit_matern$summary.nu$mode + ) +) +print(result_df_matern) +``` ## Kriging with `R-INLA` implementation of the rational SPDE approach @@ -498,6 +519,28 @@ print(result_df) ``` +Let us obtain a summary in the `matern` parameterization by setting the `parameterization` argument to `matern`: + +```{r} +result_fit_matern <- rspde.result(rspde_bru_fit, "field", rspde_model, + parameterization = "matern") +summary(result_fit_matern) +result_df_matern <- data.frame( + parameter = c("sigma", "range", "nu"), + true = c(sigma, range, nu), mean = c( + result_fit_matern$summary.std.dev$mean, + result_fit_matern$summary.range$mean, + result_fit_matern$summary.nu$mean + ), + mode = c( + result_fit_matern$summary.std.dev$mode, + result_fit_matern$summary.range$mode, + result_fit_matern$summary.nu$mode + ) +) +print(result_df_matern) +``` + ## Kriging with `inlabru` implementation of the rational SPDE approach Let us now obtain predictions (i.e., do kriging) of the latent field on @@ -577,7 +620,16 @@ toy_df_rspde <- data.frame(coord1 = loc_2d_mesh[,1], ```{r} fit_rspde <- rspde_lme(y ~ -1, data = toy_df_rspde, loc = c("coord1", "coord2"), model = op_est, parallel = TRUE) +``` +We can obtain the summary: + +```{r} +summary(fit_rspde) +``` + +Let us compare with the true values: +```{r} print(data.frame( sigma = c(sigma, fit_rspde$matern_coeff$random_effects[2]), range = c(range, fit_rspde$matern_coeff$random_effects[3]), diff --git a/vignettes/rspde_cov.Rmd b/vignettes/rspde_cov.Rmd index 8454a34e..bce40276 100644 --- a/vignettes/rspde_cov.Rmd +++ b/vignettes/rspde_cov.Rmd @@ -424,8 +424,8 @@ obs.loc <- runif(n.obs) A <- rSPDE.A1d(s, obs.loc) ``` -We now generate the observations as $Y_i = 2 + x1 + u(s_i) + \varepsilon_i$, where $\varepsilon_i \sim N(0,\sigma_e^2)$ is Gaussian measurement noise, $x1$ is a covariate giving the observation location. We will assume that the latent process has a Matérn covariance -with $\kappa=20, \sigma=2$ and $\nu=0.8$: +We now generate the observations as $Y_i = 2 - x1 + u(s_i) + \varepsilon_i$, where $\varepsilon_i \sim N(0,\sigma_e^2)$ is Gaussian measurement noise, $x1$ is a covariate giving the observation location. We will assume that the latent process has a Matérn covariance +with $\kappa=20, \sigma=1.3$ and $\nu=0.8$: ```{r} kappa <- 20 sigma <- 1.3 @@ -473,7 +473,8 @@ summary(fit) Let us compare the parameters of the latent model: ```{r} print(data.frame( - sigma = c(sigma, fit$matern_coeff$random_effects[2]), range = c(r, fit$matern_coeff$random_effects[3]), + sigma = c(sigma, fit$matern_coeff$random_effects[2]), + range = c(r, fit$matern_coeff$random_effects[3]), nu = c(nu, fit$matern_coeff$random_effects[1]), row.names = c("Truth", "Estimates") )) @@ -599,7 +600,7 @@ print(data.frame( print(fit_repl$fitting_time) ``` -We can obtain better estimates of the Hessian by setting `improve_hessian` to `FALSE`, however this might make the process take longer: +We can obtain better estimates of the Hessian by setting `improve_hessian` to `TRUE`, however this might make the process take longer: ```{r} fit_repl2 <- rspde_lme(y_vec ~ -1, model = op_cov_est, repl = repl, @@ -872,8 +873,8 @@ df_data_ns <- data.frame(y= y, x_coord = loc_mesh[,1], y_coord = loc_mesh[,2]) ```{r} fit_ns <- rspde_lme(y ~ -1, model = op_cov_ns_est, - data = df_data_ns, loc = c("x_coord", "y_coord"))#, - #parallel = TRUE) + data = df_data_ns, loc = c("x_coord", "y_coord"), + parallel = TRUE) ``` Let us get the summary: @@ -886,7 +887,8 @@ Let us now compare with the true values: ```{r} print(data.frame( - theta1 = c(true_theta[1], fit_ns$coeff$random_effects[2]), theta2 = c(true_theta[2], fit_ns$coeff$random_effects[3]), + theta1 = c(true_theta[1], fit_ns$coeff$random_effects[2]), + theta2 = c(true_theta[2], fit_ns$coeff$random_effects[3]), theta3 = c(true_theta[3], fit_ns$coeff$random_effects[4]), alpha = c(alpha, fit_ns$coeff$random_effects[1])), row.names = c("Truth", "Estimates") @@ -930,7 +932,8 @@ rational.order(op_cov_2d_type) <- 1 Let us fit a model using the data from the previous example: ```{r} -fit_order1 <- rspde_lme(y ~ -1, model = op_cov_2d_type, data = df_data_2d,repl = repl, +fit_order1 <- rspde_lme(y ~ -1, model = op_cov_2d_type, + data = df_data_2d,repl = repl, loc = c("x_coord", "y_coord"), parallel = TRUE) ``` @@ -961,7 +964,8 @@ rational.type(op_cov_2d_type) <- "brasil" Let us now fit this model, with the data from the previous example, with `brasil` rational approximation: ```{r} -fit_brasil <- rspde_lme(y ~ -1, model = op_cov_2d_type, data = df_data_2d,repl = repl, +fit_brasil <- rspde_lme(y ~ -1, model = op_cov_2d_type, + data = df_data_2d,repl = repl, loc = c("x_coord", "y_coord"), parallel = TRUE) ``` diff --git a/vignettes/rspde_inla.Rmd b/vignettes/rspde_inla.Rmd index a9218414..48346cb3 100644 --- a/vignettes/rspde_inla.Rmd +++ b/vignettes/rspde_inla.Rmd @@ -411,6 +411,23 @@ facet_wrap(~parameter, scales = "free") + labs(y = "Density") This function is reminiscent to the `inla.spde.result()` function with the main difference that it has the `summary()` and `plot()` methods implemented. +We can also obtain the results for the `matern` parameterization by setting the `parameterization` argument to `matern`: + +```{r get_result_matern} +result_fit_matern <- rspde.result(rspde_fit, "field", + rspde_model, parameterization = "matern") +summary(result_fit_matern) +``` + +In a similar manner, we can obtain posterior plots on the `matern` parameterization: + +```{r plot_post_matern, fig.align='center'} +posterior_df_fit_matern <- gg_df(result_fit_matern) + +ggplot(posterior_df_fit_matern) + geom_line(aes(x = x, y = y)) + +facet_wrap(~parameter, scales = "free") + labs(y = "Density") +``` + ### Predictions diff --git a/vignettes/rspde_inlabru.Rmd b/vignettes/rspde_inlabru.Rmd index f02235e6..d7f96f0f 100644 --- a/vignettes/rspde_inlabru.Rmd +++ b/vignettes/rspde_inlabru.Rmd @@ -318,7 +318,8 @@ We can obtain outputs with respect to parameters in the original scale by using the function `rspde.result()`: ```{r get_result} -result_fit <- rspde.result(rspde_fit, "field", rspde_model, parameterization = "matern") +result_fit <- rspde.result(rspde_fit, "field", + rspde_model) summary(result_fit) ``` @@ -331,6 +332,23 @@ ggplot(posterior_df_fit) + geom_line(aes(x = x, y = y)) + facet_wrap(~parameter, scales = "free") + labs(y = "Density") ``` +We can also obtain the summary on a different parameterization by setting the `parameterization` argument on the `rspde.result()` function: + +```{r get_result_matern} +result_fit_matern <- rspde.result(rspde_fit, "field", + rspde_model, parameterization = "matern") +summary(result_fit_matern) +``` + +In a similar manner, we can obtain posterior plots on the `matern` parameterization: + +```{r plot_post_matern, fig.align='center'} +posterior_df_fit_matern <- gg_df(result_fit_matern) + +ggplot(posterior_df_fit_matern) + geom_line(aes(x = x, y = y)) + +facet_wrap(~parameter, scales = "free") + labs(y = "Density") +``` + ### Predictions Let us now obtain predictions (i.e. do kriging) of the expected precipitation on @@ -600,7 +618,7 @@ result_df <- data.frame( print(result_df) ``` -We can also obtain the summary on a different parameterization by setting the `parameterization` argument on the `rspde.result()` function: +Let us also obtain the summary on the `matern` parameterization: ```{r} result_fit_rep_matern <- rspde.result(rspde_fit.rep, "field", rspde_model.rep, From 1a7dfaa7205330c9179738cb03b634850b035c4e Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Tue, 30 May 2023 10:44:39 +0300 Subject: [PATCH 40/47] adjusts --- R/fractional.computations.R | 38 ++++++++++++++++++++--------------- tests/testthat/test.CBrSPDE.R | 2 +- 2 files changed, 23 insertions(+), 17 deletions(-) diff --git a/R/fractional.computations.R b/R/fractional.computations.R index 6bc1932e..59b4ec08 100644 --- a/R/fractional.computations.R +++ b/R/fractional.computations.R @@ -1340,24 +1340,30 @@ CBrSPDE.matern.loglike <- function(object, Y, A, sigma.e, mu = 0, nugget <- sigma.e^2 } - Q.frac <- object$Q.frac - - Q.fracR <- Matrix::Cholesky(Q.frac) - - logdetL <- object$logdetL - logdetC <- object$logdetC - Q.int.order <- object$Q.int$order - - if (Q.int.order > 0) { - # logQ <- 2 * sum(log(diag(Q.fracR))) + (Q.int.order) * - # (m + 1) * (logdetL - logdetC) - - logQ <- 2 * c(determinant(Q.fracR, logarithm = TRUE)$modulus) + (Q.int.order) * - (m + 1) * (logdetL - logdetC) + if(object$compute_logdet){ + Q.frac <- object$Q.frac + + Q.fracR <- Matrix::Cholesky(Q.frac) + + logdetL <- object$logdetL + logdetC <- object$logdetC + Q.int.order <- object$Q.int$order + + if (Q.int.order > 0) { + # logQ <- 2 * sum(log(diag(Q.fracR))) + (Q.int.order) * + # (m + 1) * (logdetL - logdetC) + + logQ <- 2 * c(determinant(Q.fracR, logarithm = TRUE)$modulus) + (Q.int.order) * + (m + 1) * (logdetL - logdetC) + } else { + logQ <- 2 * c(determinant(Q.fracR, logarithm = TRUE)$modulus) + } } else { - logQ <- 2 * c(determinant(Q.fracR, logarithm = TRUE)$modulus) + Q <- object$Q + Q.R <- Matrix::Cholesky(Q) + + logQ <- 2 * c(determinant(Q.R, logarithm = TRUE)$modulus) } - ## compute Q_x|y Q <- object$Q if(object$alpha %% 1 == 0){ diff --git a/tests/testthat/test.CBrSPDE.R b/tests/testthat/test.CBrSPDE.R index 78678616..a80f380d 100644 --- a/tests/testthat/test.CBrSPDE.R +++ b/tests/testthat/test.CBrSPDE.R @@ -49,7 +49,7 @@ test_that("Checking loglike of CBrSPDE", { ) op1 <- matern.operators( - kappa = kappa, sigma = sigma, nu = nu, + range = range, sigma = sigma, nu = nu, loc_mesh = s, d = 1, type = "operator", parameterization = "matern" ) From d16e438e0e9b761c2e64efb1bcf3fcd7aa9a8a11 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Tue, 30 May 2023 11:01:53 +0300 Subject: [PATCH 41/47] small adjusts --- R/fractional.operators.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/fractional.operators.R b/R/fractional.operators.R index 51312548..16528256 100644 --- a/R/fractional.operators.R +++ b/R/fractional.operators.R @@ -737,7 +737,7 @@ CBrSPDE.matern.operators <- function(C, type_rational_approximation = c("chebfun", "brasil", "chebfunLB"), fem_mesh_matrices = NULL, - compute_logdet) { + compute_logdet = FALSE) { type_rational_approximation <- type_rational_approximation[[1]] if (is.null(fem_mesh_matrices)) { From cc19061ed45d5474d96a49764f66aa9cde248cd2 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Wed, 31 May 2023 15:35:59 +0300 Subject: [PATCH 42/47] Adding logo and changing pkgdown actions to linux --- .github/workflows/pkgdown.yaml | 13 +++++-------- README.md | 3 ++- vignettes/rSPDE.Rmd | 6 +++--- 3 files changed, 10 insertions(+), 12 deletions(-) diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 39b2f753..479ec4fa 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -7,11 +7,11 @@ name: pkgdown jobs: pkgdown: - runs-on: macOS-latest + runs-on: ubuntu-20.04 env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - uses: r-lib/actions/setup-r@v2 with: @@ -20,13 +20,10 @@ jobs: - uses: r-lib/actions/setup-pandoc@v2 - - name: Install system dependencies on MacOS (X11, gdal) + - name: Install system dependencies on Linux (GL) + if: runner.os == 'Linux' run: | - brew install --cask xquartz - brew install pkg-config - brew install proj@9 - brew install gdal - brew install eigen + sudo apt-get update -y && sudo apt-get install -y libglu1-mesa-dev libeigen3-dev - uses: r-lib/actions/setup-r-dependencies@v2 with: diff --git a/README.md b/README.md index cefbb27f..f873f5bd 100644 --- a/README.md +++ b/README.md @@ -1,9 +1,10 @@ -# Description # +# rSPDE [![CRAN_Status_Badge](http://www.r-pkg.org/badges/version-last-release/rSPDE)](https://cran.r-project.org/package=rSPDE) [![CRAN_Downloads](https://cranlogs.r-pkg.org/badges/grand-total/rSPDE)](https://cranlogs.r-pkg.org/badges/grand-total/rSPDE) [![R-CMD-check](https://github.com/davidbolin/rSPDE/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/davidbolin/rSPDE/actions/workflows/R-CMD-check.yaml) +# Description # `rSPDE` is an R package used for computing rational approximations of fractional SPDEs. These rational approximations can be used for computationally efficient statistical inference. Basic statistical operations such as likelihood evaluations and kriging predictions using the fractional approximations are also implemented. The package also contains interfaces to [R-INLA][ref4] and [inlabru][ref8]. diff --git a/vignettes/rSPDE.Rmd b/vignettes/rSPDE.Rmd index 541297b8..291bde39 100644 --- a/vignettes/rSPDE.Rmd +++ b/vignettes/rSPDE.Rmd @@ -180,9 +180,9 @@ covariance. We also set $\sigma=1$ and the range as $0.2$. ```{r, message=FALSE} library(rSPDE) -sigma <- 1.3 -range <- 0.2 -nu <- 0.6 +sigma <- 2 +range <- 0.25 +nu <- 1.3 kappa <- sqrt(8 * nu) / range op <- matern.operators( mesh = mesh_2d, nu = nu, From 55b5182c4d35a43813a98006eeda51fd53394729 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Tue, 6 Jun 2023 16:58:02 +0300 Subject: [PATCH 43/47] Addressing issues from new Matrix pkg --- NEWS.md | 1 + R/fractional.computations.R | 28 ++++++++-------- R/fractional.operators.R | 2 +- R/operator.operations.R | 40 +++++++++++++---------- R/util.R | 15 +++++++++ tests/testthat/test.operator.operations.R | 14 ++++---- 6 files changed, 61 insertions(+), 39 deletions(-) diff --git a/NEWS.md b/NEWS.md index 8c18feef..0f9fa43a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,6 +3,7 @@ * Bugfix on Q for small values of nu in dimension 1. * Adding parameterization option for rspde.result. * Bugfix on which_repl in rspde_lme. +* Addressing issues related to the new version of the Matrix package. # rSPDE 2.3.1 * Adding references in DESCRIPTION. diff --git a/R/fractional.computations.R b/R/fractional.computations.R index 59b4ec08..6720bf19 100644 --- a/R/fractional.computations.R +++ b/R/fractional.computations.R @@ -1009,7 +1009,7 @@ rSPDE.loglike <- function(obj, R <- Matrix::Cholesky(obj$Pl) - prior.ld <- 4 * c(determinant(R, logarithm = TRUE)$modulus) - + prior.ld <- 4 * c(determinant(R, logarithm = TRUE, sqrt = TRUE)$modulus) - sum(log(diag(obj$C))) @@ -1019,7 +1019,7 @@ rSPDE.loglike <- function(obj, R.post <- Matrix::Cholesky(Q.post) - posterior.ld <- 2 * c(determinant(R.post, logarithm = TRUE)$modulus) + posterior.ld <- 2 * c(determinant(R.post, logarithm = TRUE, sqrt = TRUE)$modulus) AtY <- t(A) %*% Q.e %*% Y @@ -1353,16 +1353,16 @@ CBrSPDE.matern.loglike <- function(object, Y, A, sigma.e, mu = 0, # logQ <- 2 * sum(log(diag(Q.fracR))) + (Q.int.order) * # (m + 1) * (logdetL - logdetC) - logQ <- 2 * c(determinant(Q.fracR, logarithm = TRUE)$modulus) + (Q.int.order) * + logQ <- 2 * c(determinant(Q.fracR, logarithm = TRUE, sqrt = TRUE)$modulus) + (Q.int.order) * (m + 1) * (logdetL - logdetC) } else { - logQ <- 2 * c(determinant(Q.fracR, logarithm = TRUE)$modulus) + logQ <- 2 * c(determinant(Q.fracR, logarithm = TRUE, sqrt = TRUE)$modulus) } } else { Q <- object$Q Q.R <- Matrix::Cholesky(Q) - logQ <- 2 * c(determinant(Q.R, logarithm = TRUE)$modulus) + logQ <- 2 * c(determinant(Q.R, logarithm = TRUE, sqrt = TRUE)$modulus) } ## compute Q_x|y Q <- object$Q @@ -1385,7 +1385,7 @@ CBrSPDE.matern.loglike <- function(object, Y, A, sigma.e, mu = 0, mu_xgiveny <- mu + mu_xgiveny ## compute log|Q_xgiveny| - log_Q_xgiveny <- 2 * determinant(R, logarithm = TRUE)$modulus + log_Q_xgiveny <- 2 * determinant(R, logarithm = TRUE, sqrt = TRUE)$modulus ## compute mu_x|y*Q*mu_x|y if (n.rep > 1) { mu_part <- sum(colSums((mu_xgiveny - mu) * (Q %*% (mu_xgiveny - mu)))) @@ -1477,15 +1477,15 @@ aux_CBrSPDE.matern.loglike <- function(object, Y, A, sigma.e, mu = 0, # logQ <- 2 * sum(log(diag(Q.fracR))) + (Q.int.order) * # (m + 1) * (logdetL - logdetC) - logQ <- 2 * c(determinant(Q.fracR, logarithm = TRUE)$modulus) + (Q.int.order) * + logQ <- 2 * c(determinant(Q.fracR, logarithm = TRUE, sqrt = TRUE)$modulus) + (Q.int.order) * (m + 1) * (logdetL - logdetC) } else { - logQ <- 2 * c(determinant(Q.fracR, logarithm = TRUE)$modulus) + logQ <- 2 * c(determinant(Q.fracR, logarithm = TRUE, sqrt = TRUE)$modulus) } } else { Q.R <- Matrix::Cholesky(Q) - logQ <- 2 * c(determinant(Q.R, logarithm = TRUE)$modulus) + logQ <- 2 * c(determinant(Q.R, logarithm = TRUE, sqrt = TRUE)$modulus) } @@ -1510,7 +1510,7 @@ aux_CBrSPDE.matern.loglike <- function(object, Y, A, sigma.e, mu = 0, mu_xgiveny <- mu + mu_xgiveny ## compute log|Q_xgiveny| - log_Q_xgiveny <- 2 * determinant(R, logarithm = TRUE)$modulus + log_Q_xgiveny <- 2 * determinant(R, logarithm = TRUE, sqrt = TRUE)$modulus ## compute mu_x|y*Q*mu_x|y if (n.rep > 1) { mu_part <- sum(colSums((mu_xgiveny - mu) * (Q %*% (mu_xgiveny - mu)))) @@ -2346,7 +2346,7 @@ aux2_lme_CBrSPDE.matern.loglike <- function(object, y, X_cov, repl, A_list, sigm # R <- tryCatch(Matrix::chol(Matrix::forceSymmetric(Q)), error=function(e){return(NULL)}) R <- Matrix::Cholesky(Q) - prior.ld <- c(determinant(R, logarithm = TRUE)$modulus) + prior.ld <- c(determinant(R, logarithm = TRUE, sqrt = TRUE)$modulus) repl_val <- unique(repl) @@ -2376,7 +2376,7 @@ aux2_lme_CBrSPDE.matern.loglike <- function(object, y, X_cov, repl, A_list, sigm # } R.p <- Matrix::Cholesky(Q.p) - posterior.ld <- c(determinant(R.p, logarithm = TRUE)$modulus) + posterior.ld <- c(determinant(R.p, logarithm = TRUE, sqrt = TRUE)$modulus) # l <- l + sum(log(diag(R))) - sum(log(diag(R.p))) - n.o*log(sigma_e) @@ -2431,7 +2431,7 @@ aux2_lme_rSPDE.matern.loglike <- function(object, y, X_cov, repl, A_list, sigma_ return(-10^100) } - prior.ld <- 2 * c(determinant(R, logarithm = TRUE)$modulus) - + prior.ld <- 2 * c(determinant(R, logarithm = TRUE, sqrt = TRUE)$modulus) - sum(log(diag(object$C)))/2 repl_val <- unique(repl) @@ -2477,7 +2477,7 @@ aux2_lme_rSPDE.matern.loglike <- function(object, y, X_cov, repl, A_list, sigma_ v <- v - A_tmp%*%mu.p - posterior.ld <- c(determinant(R.post, logarithm = TRUE)$modulus) + posterior.ld <- c(determinant(R.post, logarithm = TRUE, sqrt = TRUE)$modulus) l <- l + prior.ld - posterior.ld - n.o*log(sigma_e) diff --git a/R/fractional.operators.R b/R/fractional.operators.R index 16528256..bb5387ed 100644 --- a/R/fractional.operators.R +++ b/R/fractional.operators.R @@ -850,7 +850,7 @@ CBrSPDE.matern.operators <- function(C, if(compute_logdet){ Lchol <- Matrix::Cholesky(L) - logdetL <- 2 * c(determinant(Lchol, logarithm = TRUE)$modulus) + logdetL <- 2 * c(determinant(Lchol, logarithm = TRUE, sqrt = TRUE)$modulus) logdetC <- sum(log(diag(C))) } else{ diff --git a/R/operator.operations.R b/R/operator.operations.R index 0ab11058..9e628e29 100644 --- a/R/operator.operations.R +++ b/R/operator.operations.R @@ -47,6 +47,7 @@ NULL #' @rdname operator.operations #' @export Pr.mult <- function(obj, v, transpose = FALSE) { + orig_v <- v if (!inherits(obj, "rSPDEobj")) { stop("obj is not of class rSPDE.obj") } @@ -65,13 +66,14 @@ Pr.mult <- function(obj, v, transpose = FALSE) { if (!transpose) { v <- obj$Pr.factors$Phi %*% v } - return(v) + return(return_same_input_type_matrix_vector(v,orig_v)) } #' @rdname operator.operations #' @export Pr.solve <- function(obj, v, transpose = FALSE) { + orig_v <- v if (!inherits(obj, "rSPDEobj")) { stop("obj is not of class rSPDE.obj") } @@ -90,12 +92,13 @@ Pr.solve <- function(obj, v, transpose = FALSE) { if (transpose) { v <- solve(obj$Pr.factors$Phi, v) } - return(v) + return(return_same_input_type_matrix_vector(v,orig_v)) } #' @rdname operator.operations #' @export Pl.mult <- function(obj, v, transpose = FALSE) { + orig_v <- v if (!inherits(obj, "rSPDEobj")) { stop("obj is not of class rSPDE.obj") } @@ -125,12 +128,13 @@ Pl.mult <- function(obj, v, transpose = FALSE) { v <- obj$C %*% v } v <- obj$Pl.factors$scaling * v - return(v) + return(return_same_input_type_matrix_vector(v,orig_v)) } #' @rdname operator.operations #' @export Pl.solve <- function(obj, v, transpose = FALSE) { + orig_v <- v if (!inherits(obj, "rSPDEobj")) { stop("obj is not of class rSPDE.obj") } @@ -160,17 +164,18 @@ Pl.solve <- function(obj, v, transpose = FALSE) { v <- obj$Ci %*% v } v <- v / obj$Pl.factors$scaling - return(v) + return(return_same_input_type_matrix_vector(v,orig_v)) } #' @rdname operator.operations #' @export Q.mult <- function(obj, v) { + orig_v <- v if (inherits(obj, "rSPDEobj")) { v <- Pl.mult(obj, v) v <- obj$Ci %*% v v <- Pl.mult(obj, v, transpose = TRUE) - return(v) + return(return_same_input_type_matrix_vector(v,orig_v)) } else if (inherits(obj, "CBrSPDEobj")) { Q.int <- obj$Q.int order_Q_int <- Q.int$order @@ -182,7 +187,7 @@ Q.mult <- function(obj, v) { v <- Q.int %*% v } } - return(v) + return(return_same_input_type_matrix_vector(v,orig_v)) } else { stop("obj is not of class rSPDEobj") } @@ -191,11 +196,12 @@ Q.mult <- function(obj, v) { #' @rdname operator.operations #' @export Q.solve <- function(obj, v) { + orig_v <- v if (inherits(obj, "rSPDEobj")) { v <- Pl.solve(obj, v, transpose = TRUE) v <- obj$C %*% v v <- Pl.solve(obj, v) - return(v) + return(return_same_input_type_matrix_vector(v,orig_v)) } else if (inherits(obj, "CBrSPDEobj")) { Q.int <- obj$Q.int Q.frac <- obj$Q.frac @@ -208,7 +214,7 @@ Q.solve <- function(obj, v) { } } v <- solve(Q.frac, prod_tmp) - return(v) + return(return_same_input_type_matrix_vector(v,orig_v)) } else { stop("obj is not of class rSPDEobj nor CBrSPDEobj") } @@ -217,6 +223,7 @@ Q.solve <- function(obj, v) { #' @rdname operator.operations #' @export Qsqrt.mult <- function(obj, v, transpose = FALSE) { + orig_v <- v if (!inherits(obj, "rSPDEobj")) { stop("obj is not of class rSPDE.obj") } @@ -227,12 +234,13 @@ Qsqrt.mult <- function(obj, v, transpose = FALSE) { v <- Pl.mult(obj, v) v <- sqrt(obj$Ci) %*% v } - return(v) + return(return_same_input_type_matrix_vector(v,orig_v)) } #' @rdname operator.operations #' @export Qsqrt.solve <- function(obj, v, transpose = FALSE) { + orig_v <- v if (!inherits(obj, "rSPDEobj")) { stop("obj is not of class rSPDE.obj") } @@ -243,33 +251,31 @@ Qsqrt.solve <- function(obj, v, transpose = FALSE) { v <- sqrt(obj$C) %*% v v <- Pl.solve(obj, v) } - return(v) + return(return_same_input_type_matrix_vector(v,orig_v)) } #' @rdname operator.operations #' @export Sigma.mult <- function(obj, v) { + orig_v <- v if (!inherits(obj, "rSPDEobj")) { stop("obj is not of class rSPDE.obj") } v <- Pr.mult(obj, v, transpose = TRUE) v <- Q.solve(obj, v) v <- Pr.mult(obj, v) - return(v) + return(return_same_input_type_matrix_vector(v,orig_v)) } #' @rdname operator.operations #' @export Sigma.solve <- function(obj, v) { + orig_v <- v if (!inherits(obj, "rSPDEobj")) { stop("obj is not of class rSPDE.obj") } v <- Pr.solve(obj, v) v <- Q.mult(obj, v) v <- Pr.solve(obj, v, transpose = TRUE) - return(v) -} - -#' @rdname operator.operations -#' @export -#' + return(return_same_input_type_matrix_vector(v,orig_v)) +} \ No newline at end of file diff --git a/R/util.R b/R/util.R index 0a720a5c..02b47200 100644 --- a/R/util.R +++ b/R/util.R @@ -2064,4 +2064,19 @@ change_parameterization_lme <- function(likelihood, d, nu, par, hessian # hess_tmp <- diag(c(1/sigma, 1/range)) %*% hess_tmp %*% diag(c(1/sigma, 1/range)) return(list(coeff = c(sigma, range), std_random = std_err)) +} + + + +#' @noRd +#' + +return_same_input_type_matrix_vector <- function(v, orig_v){ + if(isS4(orig_v)){ + return(v) + } else{ + v_out <- as.matrix(v) + dim(v_out) <- dim(orig_v) + return(v_out) + } } \ No newline at end of file diff --git a/tests/testthat/test.operator.operations.R b/tests/testthat/test.operator.operations.R index 24779d7c..f2ac1508 100644 --- a/tests/testthat/test.operator.operations.R +++ b/tests/testthat/test.operator.operations.R @@ -16,13 +16,13 @@ test_that("Operator algebra", { # Pr multiplication - expect_equal(op$Pr %*% v, Pr.mult(op, v), tolerance = 1e-10) - expect_equal(t(op$Pr) %*% v, Pr.mult(op, v, transpose = TRUE), + expect_equal(as.vector(op$Pr %*% v), Pr.mult(op, v), tolerance = 1e-10) + expect_equal(as.vector(t(op$Pr) %*% v), Pr.mult(op, v, transpose = TRUE), tolerance = 1e-10) # Pl multiplication - expect_equal(op$Pl %*% v, Pl.mult(op, v), tolerance = 1e-10) - expect_equal(t(op$Pl) %*% v, Pl.mult(op, v, transpose = TRUE), + expect_equal(as.vector(op$Pl %*% v), Pl.mult(op, v), tolerance = 1e-10) + expect_equal(as.vector(t(op$Pl) %*% v), Pl.mult(op, v, transpose = TRUE), tolerance = 1e-10) # Pr solve @@ -36,13 +36,13 @@ test_that("Operator algebra", { tolerance = 1e-10) # Q mult - expect_equal(op$Q %*% v, Q.mult(op, v), tolerance = 1e-10) + expect_equal(as.vector(op$Q %*% v), Q.mult(op, v), tolerance = 1e-10) expect_equal(solve(op$Q, v), Q.solve(op, v), tolerance = 1e-10) # Qr mult - expect_equal(sqrt(op$Ci) %*% op$Pl %*% v, Qsqrt.mult(op, v), + expect_equal(as.vector(sqrt(op$Ci) %*% op$Pl %*% v), Qsqrt.mult(op, v), tolerance = 1e-10) - expect_equal(t(sqrt(op$Ci) %*% op$Pl) %*% v, Qsqrt.mult(op, v, + expect_equal(as.vector(t(sqrt(op$Ci) %*% op$Pl) %*% v), Qsqrt.mult(op, v, transpose = TRUE), tolerance = 1e-10) # Qr solve From 95e51c80cc764e2fa5f591690f4c0a46f4fdcf0e Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Tue, 6 Jun 2023 17:23:15 +0300 Subject: [PATCH 44/47] Adjusts operators.operations.test --- tests/testthat/test.operator.operations.R | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/tests/testthat/test.operator.operations.R b/tests/testthat/test.operator.operations.R index f2ac1508..e744de6b 100644 --- a/tests/testthat/test.operator.operations.R +++ b/tests/testthat/test.operator.operations.R @@ -26,18 +26,18 @@ test_that("Operator algebra", { tolerance = 1e-10) # Pr solve - expect_equal(solve(op$Pr, v), Pr.solve(op, v), tolerance = 1e-10) - expect_equal(solve(t(op$Pr), v), Pr.solve(op, v, transpose = TRUE), + expect_equal(as.vector(solve(op$Pr, v)), Pr.solve(op, v), tolerance = 1e-10) + expect_equal(as.vector(solve(t(op$Pr), v)), Pr.solve(op, v, transpose = TRUE), tolerance = 1e-10) # Pl solve - expect_equal(solve(op$Pl, v), Pl.solve(op, v), tolerance = 1e-10) - expect_equal(solve(t(op$Pl), v), Pl.solve(op, v, transpose = TRUE), + expect_equal(as.vector(solve(op$Pl, v)), Pl.solve(op, v), tolerance = 1e-10) + expect_equal(as.vector(solve(t(op$Pl), v)), Pl.solve(op, v, transpose = TRUE), tolerance = 1e-10) # Q mult expect_equal(as.vector(op$Q %*% v), Q.mult(op, v), tolerance = 1e-10) - expect_equal(solve(op$Q, v), Q.solve(op, v), tolerance = 1e-10) + expect_equal(as.vector(solve(op$Q, v)), Q.solve(op, v), tolerance = 1e-10) # Qr mult expect_equal(as.vector(sqrt(op$Ci) %*% op$Pl %*% v), Qsqrt.mult(op, v), @@ -46,8 +46,8 @@ test_that("Operator algebra", { transpose = TRUE), tolerance = 1e-10) # Qr solve - expect_equal(solve(sqrt(op$Ci) %*% op$Pl, v), Qsqrt.solve(op, v), + expect_equal(as.vector(solve(sqrt(op$Ci) %*% op$Pl, v)), Qsqrt.solve(op, v), tolerance = 1e-10) - expect_equal(solve(t(sqrt(op$Ci) %*% op$Pl), v), Qsqrt.solve(op, v, + expect_equal(as.vector(solve(t(sqrt(op$Ci) %*% op$Pl), v)), Qsqrt.solve(op, v, transpose = TRUE), tolerance = 1e-10) }) From 83bdc5c7bc559c5a0bf8e52ee0cab6ff1cbf3c10 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Sun, 25 Jun 2023 18:04:13 +0300 Subject: [PATCH 45/47] Updating references --- README.md | 2 +- inst/CITATION | 26 ++++++++++++++++---------- vignettes/rSPDE.Rmd | 14 +++++++------- vignettes/rspde_cov.Rmd | 14 +++++++------- vignettes/rspde_inla.Rmd | 14 +++++++------- vignettes/rspde_inlabru.Rmd | 14 +++++++------- 6 files changed, 45 insertions(+), 39 deletions(-) diff --git a/README.md b/README.md index f873f5bd..520e6a3f 100644 --- a/README.md +++ b/README.md @@ -25,7 +25,7 @@ shiny::runGitHub("davidbolin/rSPDE", subdir="shiny_app") ``` # References # -Z. Xiong, A. Simas, D. Bolin (2022) [Covariance-based rational approximations of fractional SPDEs for computationally efficient Bayesian inference][ref9]. ArXiv:2209.04670 +D. Bolin, A. B. Simas, Z. Xiong (2023) [Covariance-based rational approximations of fractional SPDEs for computationally efficient Bayesian inference][ref9]. Journal of Computational and Graphical Statistics, in press. D. Bolin and K. Kirchner (2020) [The rational SPDE approach for Gaussian random fields with general smoothness][ref]. Journal of Computational and Graphical Statistics, 29:2, 274-285. diff --git a/inst/CITATION b/inst/CITATION index 87e92239..bcdde4ab 100644 --- a/inst/CITATION +++ b/inst/CITATION @@ -17,18 +17,24 @@ bibentry( bibtype = "Manual", bibentry(bibtype = "Article", title = "Covariance-based rational approximations of fractional SPDEs for computationally efficient Bayesian inference", - author = c(person(given = "Zhen", - family = "Xiong", - email = "zhen.xiong@kaust.edu.sa"), + author = c(person(given = "David", + family = "Bolin", + email = "davidbolin@gmail.com"), person(given = "Alexandre B.", family = "Simas", email = "alexandre.simas@kaust.edu.sa"), - person(given = "David", - family = "Bolin", - email = "davidbolin@gmail.com")), - journal = "arXiv preprint arXiv:2209.04670", - year = "2022", - doi = "10.48550/arXiv.2209.04670" + person(given = "Zhen", + family = "Xiong", + email = "zhen.xiong@kaust.edu.sa")), + + journal = "Journal of Computational and Graphical Statistics", + year = "2023", + doi = "10.48550/arXiv.2209.04670", + note ="(in press)", + paste0("David Bolin, Alexandre B. Simas, Zhen Xiong (2023), ", + "Covariance-based rational approximations of fractional SPDEs for computationally efficient Bayesian inference. ", + "Journal of Computational and Graphical Statistics, ", + "in press.") ) bibentry(bibtype = "Article", @@ -47,7 +53,7 @@ bibentry(bibtype = "Article", doi = "10.1080/10618600.2019.1665537", textVersion = paste0("David Bolin, Kristin Kirchner (2020), ", - "The rational SPDE approach for Gaussian random fields with general smoothness ", + "The rational SPDE approach for Gaussian random fields with general smoothness. ", "Journal of Computational and Graphical Statistics, ", "29:2, 274-285.") ) \ No newline at end of file diff --git a/vignettes/rSPDE.Rmd b/vignettes/rSPDE.Rmd index 291bde39..3e4a20ec 100644 --- a/vignettes/rSPDE.Rmd +++ b/vignettes/rSPDE.Rmd @@ -85,16 +85,16 @@ references: - id: xiong22 title: "Covariance-based rational approximations of fractional SPDEs for computationally efficient Bayesian inference" author: - - family: Xiong - given: Zhen - - family: Simas - given: Alexandre B. - family: Bolin given: David - container-title: arXiv:2209.04670 - type: preprint + - family: Simas + given: Alexandre B. + - family: Xiong + given: Zhen + container-title: Journal of Computational and Graphical Statistics + type: article-journal issued: - year: 2022 + year: 2023 --- ```{r setup, include = FALSE} diff --git a/vignettes/rspde_cov.Rmd b/vignettes/rspde_cov.Rmd index bce40276..76c1da4b 100644 --- a/vignettes/rspde_cov.Rmd +++ b/vignettes/rspde_cov.Rmd @@ -97,16 +97,16 @@ references: - id: xiong22 title: "Covariance-based rational approximations of fractional SPDEs for computationally efficient Bayesian inference" author: - - family: Xiong - given: Zhen - - family: Simas - given: Alexandre B. - family: Bolin given: David - container-title: arXiv:2209.04670 - type: preprint + - family: Simas + given: Alexandre B. + - family: Xiong + given: Zhen + container-title: Journal of Computational and Graphical Statistics + type: article-journal issued: - year: 2022 + year: 2023 --- ```{r setup, include=FALSE} diff --git a/vignettes/rspde_inla.Rmd b/vignettes/rspde_inla.Rmd index 48346cb3..05f15c3c 100644 --- a/vignettes/rspde_inla.Rmd +++ b/vignettes/rspde_inla.Rmd @@ -25,16 +25,16 @@ references: - id: xiong22 title: "Covariance-based rational approximations of fractional SPDEs for computationally efficient Bayesian inference" author: - - family: Xiong - given: Zhen - - family: Simas - given: Alexandre B. - family: Bolin given: David - container-title: arXiv:2209.04670 - type: preprint + - family: Simas + given: Alexandre B. + - family: Xiong + given: Zhen + container-title: Journal of Computational and Graphical Statistics + type: article-journal issued: - year: 2022 + year: 2023 - id: lindgren11 title: "An explicit link between Gaussian fields and Gaussian Markov random fields: the stochastic partial differential equation approach" author: diff --git a/vignettes/rspde_inlabru.Rmd b/vignettes/rspde_inlabru.Rmd index d7f96f0f..c96996e2 100644 --- a/vignettes/rspde_inlabru.Rmd +++ b/vignettes/rspde_inlabru.Rmd @@ -41,16 +41,16 @@ references: - id: xiong22 title: "Covariance-based rational approximations of fractional SPDEs for computationally efficient Bayesian inference" author: - - family: Xiong - given: Zhen - - family: Simas - given: Alexandre B. - family: Bolin given: David - container-title: arXiv:2209.04670 - type: preprint + - family: Simas + given: Alexandre B. + - family: Xiong + given: Zhen + container-title: Journal of Computational and Graphical Statistics + type: article-journal issued: - year: 2022 + year: 2023 - id: Hofreither21 title: "An algorithm for best rational approximation based on barycentric rational interpolation" author: From 429fee334bff714ead78f964ac71d3f3c2e79735 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Sun, 25 Jun 2023 18:09:33 +0300 Subject: [PATCH 46/47] Increment version number to 2.3.2 --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index d64ebe38..80f29693 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,7 +2,7 @@ Package: rSPDE Type: Package Title: Rational Approximations of Fractional Stochastic Partial Differential Equations -Version: 2.3.1.9000 +Version: 2.3.2 Authors@R: c( person("David", "Bolin", email = "davidbolin@gmail.com", role = c("cre", "aut")), person("Alexandre", "Simas", email = "alexandre.impa@gmail.com", role = "aut"), diff --git a/NEWS.md b/NEWS.md index 0f9fa43a..0cf39488 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# rSPDE (development version) +# rSPDE 2.3.2 * Small improvement on speed for rspde_lme. * Bugfix on Q for small values of nu in dimension 1. * Adding parameterization option for rspde.result. From 7f30321063b4017a6306a4b9e2d94c18caf40f61 Mon Sep 17 00:00:00 2001 From: vpnsctl Date: Sun, 25 Jun 2023 18:12:49 +0300 Subject: [PATCH 47/47] Adjusts on inla tests --- README.md | 6 ++-- tests/testthat/test.inla_rspde.R | 48 +++++++++++--------------------- 2 files changed, 18 insertions(+), 36 deletions(-) diff --git a/README.md b/README.md index 520e6a3f..b54004cb 100644 --- a/README.md +++ b/README.md @@ -75,10 +75,8 @@ The tests that depend on `INLA` should have the following structure: ``` test_that("Description of the test", { testthat::skip_on_cran() - inla_installed <- "INLA" %in% rownames(installed.packages()) - if(!inla_installed){ - testthat::skip("INLA not installed") - } + if (!requireNamespace("INLA", quietly=TRUE)) + testthat::skip(message = 'INLA package is not installed. (see www.r-inla.org/download-install)') old_threads <- INLA::inla.getOption("num.threads") INLA::inla.setOption(num.threads = "1:1") diff --git a/tests/testthat/test.inla_rspde.R b/tests/testthat/test.inla_rspde.R index 2b411e2f..c59e7c81 100644 --- a/tests/testthat/test.inla_rspde.R +++ b/tests/testthat/test.inla_rspde.R @@ -3,10 +3,8 @@ context("inla_rspde") test_that("testing cgeneric_integer", { testthat::skip_on_cran() - inla_installed <- "INLA" %in% rownames(installed.packages()) - if(!inla_installed){ - testthat::skip("INLA not installed") - } +if (!requireNamespace("INLA", quietly=TRUE)) + testthat::skip(message = 'INLA package is not installed. (see www.r-inla.org/download-install)') old_threads <- INLA::inla.getOption("num.threads") INLA::inla.setOption(num.threads = "1:1") @@ -61,10 +59,8 @@ testthat::expect_equal(sum( (Q_tmp2 - Q_tmp$Q)^2), 0) test_that("testing cgeneric_parsimonious_fixed", { testthat::skip_on_cran() - inla_installed <- "INLA" %in% rownames(installed.packages()) - if(!inla_installed){ - testthat::skip("INLA not installed") - } +if (!requireNamespace("INLA", quietly=TRUE)) + testthat::skip(message = 'INLA package is not installed. (see www.r-inla.org/download-install)') old_threads <- INLA::inla.getOption("num.threads") INLA::inla.setOption(num.threads = "1:1") @@ -122,10 +118,8 @@ testthat::expect_equal(sum((Q_tmp$Q - Q_tmp2)^2), 0) test_that("testing cgeneric_parsimonious_gen", { testthat::skip_on_cran() - inla_installed <- "INLA" %in% rownames(installed.packages()) - if(!inla_installed){ - testthat::skip("INLA not installed") - } +if (!requireNamespace("INLA", quietly=TRUE)) + testthat::skip(message = 'INLA package is not installed. (see www.r-inla.org/download-install)') old_threads <- INLA::inla.getOption("num.threads") INLA::inla.setOption(num.threads = "1:1") @@ -182,10 +176,8 @@ testthat::expect_equal(sum((Q_tmp$Q - Q_tmp2)^2), 0) test_that("testing cgeneric_rspde_fixed_gen", { testthat::skip_on_cran() - inla_installed <- "INLA" %in% rownames(installed.packages()) - if(!inla_installed){ - testthat::skip("INLA not installed") - } +if (!requireNamespace("INLA", quietly=TRUE)) + testthat::skip(message = 'INLA package is not installed. (see www.r-inla.org/download-install)') old_threads <- INLA::inla.getOption("num.threads") INLA::inla.setOption(num.threads = "1:1") @@ -239,10 +231,8 @@ testthat::expect_equal(sum((Q_tmp$Q - Q_tmp2)^2), 0) test_that("testing cgeneric_rspde_gen", { testthat::skip_on_cran() - inla_installed <- "INLA" %in% rownames(installed.packages()) - if(!inla_installed){ - testthat::skip("INLA not installed") - } +if (!requireNamespace("INLA", quietly=TRUE)) + testthat::skip(message = 'INLA package is not installed. (see www.r-inla.org/download-install)') old_threads <- INLA::inla.getOption("num.threads") INLA::inla.setOption(num.threads = "1:1") @@ -289,10 +279,8 @@ testthat::expect_equal(sum( (Q_1 - Q_tmp$Q)^2), 0) test_that("testing cgeneric_nonstat_gen", { testthat::skip_on_cran() - inla_installed <- "INLA" %in% rownames(installed.packages()) - if(!inla_installed){ - testthat::skip("INLA not installed") - } +if (!requireNamespace("INLA", quietly=TRUE)) + testthat::skip(message = 'INLA package is not installed. (see www.r-inla.org/download-install)') old_threads <- INLA::inla.getOption("num.threads") INLA::inla.setOption(num.threads = "1:1") @@ -349,10 +337,8 @@ testthat::expect_equal(sum( (Q_tmp2 - Q_tmp$Q)^2), 0) test_that("testing cgeneric_nonstat_fixed", { testthat::skip_on_cran() - inla_installed <- "INLA" %in% rownames(installed.packages()) - if(!inla_installed){ - testthat::skip("INLA not installed") - } +if (!requireNamespace("INLA", quietly=TRUE)) + testthat::skip(message = 'INLA package is not installed. (see www.r-inla.org/download-install)') old_threads <- INLA::inla.getOption("num.threads") INLA::inla.setOption(num.threads = "1:1") @@ -408,10 +394,8 @@ testthat::expect_equal(sum( (Q_tmp2 - Q_tmp$Q)^2), 0) test_that("testing cgeneric_nonstat_integer", { testthat::skip_on_cran() - inla_installed <- "INLA" %in% rownames(installed.packages()) - if(!inla_installed){ - testthat::skip("INLA not installed") - } +if (!requireNamespace("INLA", quietly=TRUE)) + testthat::skip(message = 'INLA package is not installed. (see www.r-inla.org/download-install)') old_threads <- INLA::inla.getOption("num.threads") INLA::inla.setOption(num.threads = "1:1")