├── .github ├── .gitignore └── workflows │ ├── test-coverage.yaml │ ├── R-CMD-check.yaml │ └── rhub.yaml ├── R ├── is_formula.R ├── transformations.R ├── ContourFunctions_cf_func.R ├── GauPro_selector.R ├── lhs_maximinLHS.R ├── sqrt_matrix.R ├── convert_X_with_formula_back.R ├── trend_base.R ├── find_kernel_factor_dims.R ├── find_kernel_factor_dims2.R ├── gradfuncarray.R ├── find_kernel_cts_dims.R ├── corr.R ├── grad_share.R ├── optim_share2.R ├── gpkm.R ├── convert_X_with_formula.R └── Gaussian_hessian.R ├── tests ├── testthat.R └── testthat │ ├── test_1D.R │ ├── test_Gauss_GauPro_LOO.R │ ├── test_kernel_model_LOO.R │ └── test_predictions.R ├── scratch ├── Javier │ ├── NMC_ok.csv │ └── GPR.R ├── Makevars_orig ├── Makevars_orig.win ├── check_depends_only.R ├── scratch_noiseless.R ├── solvewithchol.R ├── BestUnbiasedLinearPredictors.R ├── scratch_formuladf_attenu.R ├── scratch_airquality.R ├── scratch_compare_corr_gauss_matrix.R ├── scratch_kernel_model_update_fast.R ├── EI_tdist.R ├── scratch_arma_cube_vec_multiply.R ├── plot2D_two_factors.R ├── plotLOO_issue.R ├── peak_example.R ├── scratchOTL.R ├── fastfit.R ├── scratch_chol_backsolve.R ├── ToDo.md ├── scratch_kernel_model_piston.R ├── scratch_kernel_model_1D.R ├── parametersvsadaptive.Rmd ├── scratch_comparer.R ├── scratch_hessian.R ├── ExampleForArwed.R ├── scratch_kernel_check_useC.R ├── scratch_plot_LOO.R ├── FactorSpeedTest.R ├── scratch_kernel_model_LOO2.R ├── scratch_kernel_model_LOO.R ├── EGO.R ├── run_time_experiment.R ├── Welch.R ├── scratch_kernel_Gaussian_logl.R ├── scratch_speedupgrad.R ├── scratch_kernel_grad.R ├── scratch_LOO.R ├── scratch_kernel_Gaussian.R ├── FactorKernelCheckDeriv.R ├── scratch_KnowledgeGradient.R ├── scratch_grad_dist.R ├── scratch_kernel_Gaussian_beta.R ├── scratch_trend.R ├── scratch_kernel_Exponential.R ├── scratch_kernel_Matern32.R ├── scratch_kernel_Matern52.R ├── scratch_bernoulli_first_attempt.R ├── scratch_kernel_RatQuad.R ├── BestUnbiasedLinearPredictors.Rmd ├── scratch_kernel_Gaussian_l.R ├── scratch_kernel_Sum.R ├── scratch_kernel_product.R ├── gradfuncarray.cpp ├── RanApley_se_adjust_test.R ├── scratch_kernel_White.R ├── corr_gauss_matrix_par_test.cpp └── deprecated_kernelmodel_maxEIwithfactorsoriginal.R ├── tools ├── README-trends-1.png ├── README-plot_dm-1.png ├── README-plotsine-1.png ├── README-kernelmatern52-1.png ├── README-plotdeviance-1.png ├── README-plotsawtooth-1.png ├── README-plotsawtooth-2.png ├── README-combine_periodic-1.png ├── README-oldvignettedata-1.png ├── README-kernelexponential-1.png ├── README-oldvignettedata_plot-1.png ├── README-oldvignettedata_plot1D-1.png ├── README-oldvignettedata_cool1Dplot-1.png ├── README-oldvignettedata_maternplot-1.png ├── README-oldvignettedata_trendplot-1.png ├── README-diamond_construct_kernel_fit-1.png └── README-oldvignettedata_exponentialplot-1.png ├── revdep ├── .gitignore └── email.yml ├── .gitignore ├── .Rbuildignore ├── src ├── corr.h ├── armadillotest.cpp ├── armadillotest2.cpp ├── Makevars.win ├── Makevars ├── corr_gauss_dCdX.cpp ├── gradfuncarray.cpp ├── deviance.cpp ├── arma_cube_vec_multiply.cpp ├── Gaussian_deviance.cpp ├── pred_mean.cpp └── deviance_grad.cpp ├── man ├── summary.GauPro.Rd ├── print.summary.GauPro.Rd ├── corr_cubic_matrix_symC.Rd ├── plus-.GauPro_kernel.Rd ├── corr_gauss_matrix_symC.Rd ├── times-.GauPro_kernel.Rd ├── corr_gauss_matrix.Rd ├── corr_matern32_matrix_symC.Rd ├── corr_matern52_matrix_symC.Rd ├── corr_exponential_matrix_symC.Rd ├── GauPro.Rd ├── sqrt_matrix.Rd ├── Gaussian_devianceC.Rd ├── Gaussian_hessianCC.Rd ├── corr_gauss_matrixC.Rd ├── corr_gauss_dCdX.Rd ├── predict.GauPro_base.Rd ├── kernel_gauss_dC.Rd ├── kernel_matern32_dC.Rd ├── kernel_matern52_dC.Rd ├── kernel_cubic_dC.Rd ├── corr_gauss_matrix_sym_armaC.Rd ├── kernel_exponential_dC.Rd ├── predict.GauPro.Rd ├── arma_mult_cube_vec.Rd ├── gradfuncarray.Rd ├── gradfuncarrayR.Rd ├── corr_orderedfactor_matrix_symC.Rd ├── corr_gauss_matrix_armaC.Rd ├── Gaussian_hessianC.Rd ├── Gaussian_hessianR.Rd ├── corr_latentfactor_matrix_symC.Rd ├── kernel_orderedFactor_dC.Rd ├── kernel_latentFactor_dC.Rd ├── corr_orderedfactor_matrixmatrixC.Rd ├── corr_latentfactor_matrixmatrixC.Rd ├── GauPro_trend.Rd ├── GauPro_kernel.Rd └── gpkm.Rd ├── GauPro.Rproj ├── vignettes ├── CrossValidationErrorCorrection.R └── GauPro.R ├── DESCRIPTION ├── cran-comments.md ├── NAMESPACE └── NEWS.md /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /R/is_formula.R: -------------------------------------------------------------------------------- 1 | is.formula <- function(x){ 2 | inherits(x,"formula") 3 | } 4 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(GauPro) 3 | 4 | test_check("GauPro") 5 | -------------------------------------------------------------------------------- /scratch/Javier/NMC_ok.csv: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CollinErickson/GauPro/HEAD/scratch/Javier/NMC_ok.csv -------------------------------------------------------------------------------- /tools/README-trends-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CollinErickson/GauPro/HEAD/tools/README-trends-1.png -------------------------------------------------------------------------------- /tools/README-plot_dm-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CollinErickson/GauPro/HEAD/tools/README-plot_dm-1.png -------------------------------------------------------------------------------- /tools/README-plotsine-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CollinErickson/GauPro/HEAD/tools/README-plotsine-1.png -------------------------------------------------------------------------------- /scratch/Makevars_orig: -------------------------------------------------------------------------------- 1 | PKG_LIBS = `$(R_HOME)/bin/Rscript -e "Rcpp:::LdFlags()"` $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 2 | -------------------------------------------------------------------------------- /tools/README-kernelmatern52-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CollinErickson/GauPro/HEAD/tools/README-kernelmatern52-1.png -------------------------------------------------------------------------------- /tools/README-plotdeviance-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CollinErickson/GauPro/HEAD/tools/README-plotdeviance-1.png -------------------------------------------------------------------------------- /tools/README-plotsawtooth-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CollinErickson/GauPro/HEAD/tools/README-plotsawtooth-1.png -------------------------------------------------------------------------------- /tools/README-plotsawtooth-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CollinErickson/GauPro/HEAD/tools/README-plotsawtooth-2.png -------------------------------------------------------------------------------- /revdep/.gitignore: -------------------------------------------------------------------------------- 1 | checks 2 | library 3 | checks.noindex 4 | library.noindex 5 | cloud.noindex 6 | data.sqlite 7 | *.html 8 | -------------------------------------------------------------------------------- /tools/README-combine_periodic-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CollinErickson/GauPro/HEAD/tools/README-combine_periodic-1.png -------------------------------------------------------------------------------- /tools/README-oldvignettedata-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CollinErickson/GauPro/HEAD/tools/README-oldvignettedata-1.png -------------------------------------------------------------------------------- /tools/README-kernelexponential-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CollinErickson/GauPro/HEAD/tools/README-kernelexponential-1.png -------------------------------------------------------------------------------- /revdep/email.yml: -------------------------------------------------------------------------------- 1 | release_date: ??? 2 | rel_release_date: ??? 3 | my_news_url: ??? 4 | release_version: ??? 5 | release_details: ??? 6 | -------------------------------------------------------------------------------- /scratch/Makevars_orig.win: -------------------------------------------------------------------------------- 1 | PKG_LIBS = $(shell $(R_HOME)/bin/Rscript.exe -e "Rcpp:::LdFlags()") $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 2 | -------------------------------------------------------------------------------- /tools/README-oldvignettedata_plot-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CollinErickson/GauPro/HEAD/tools/README-oldvignettedata_plot-1.png -------------------------------------------------------------------------------- /tools/README-oldvignettedata_plot1D-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CollinErickson/GauPro/HEAD/tools/README-oldvignettedata_plot1D-1.png -------------------------------------------------------------------------------- /tools/README-oldvignettedata_cool1Dplot-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CollinErickson/GauPro/HEAD/tools/README-oldvignettedata_cool1Dplot-1.png -------------------------------------------------------------------------------- /tools/README-oldvignettedata_maternplot-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CollinErickson/GauPro/HEAD/tools/README-oldvignettedata_maternplot-1.png -------------------------------------------------------------------------------- /tools/README-oldvignettedata_trendplot-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CollinErickson/GauPro/HEAD/tools/README-oldvignettedata_trendplot-1.png -------------------------------------------------------------------------------- /tools/README-diamond_construct_kernel_fit-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CollinErickson/GauPro/HEAD/tools/README-diamond_construct_kernel_fit-1.png -------------------------------------------------------------------------------- /tools/README-oldvignettedata_exponentialplot-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CollinErickson/GauPro/HEAD/tools/README-oldvignettedata_exponentialplot-1.png -------------------------------------------------------------------------------- /R/transformations.R: -------------------------------------------------------------------------------- 1 | transform_to_0_1 = function(Xin) { 2 | if (is.numeric(Xin)) {(Xin - min(Xin)) / (max(Xin) - min(Xin))} 3 | else if (is.matrix(Xin)) {apply(Xin, 2, function(Xin2){(Xin2 - min(Xin2)) / (max(Xin2) - min(Xin2))})} 4 | } 5 | -------------------------------------------------------------------------------- /scratch/check_depends_only.R: -------------------------------------------------------------------------------- 1 | Sys.getenv("_R_CHECK_DEPENDS_ONLY_") 2 | Sys.setenv("_R_CHECK_DEPENDS_ONLY_"=TRUE) 3 | Sys.getenv("_R_CHECK_DEPENDS_ONLY_") 4 | Sys.setenv("_R_CHECK_DEPENDS_ONLY_"="") 5 | Sys.getenv("_R_CHECK_DEPENDS_ONLY_") 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | src/*.o 6 | src/*.so 7 | src/*.dll 8 | inst/doc 9 | CRAN-RELEASE 10 | scratch/rm_Windows.R 11 | tests/testthat/Rplots.pdf 12 | CRAN-SUBMISSION 13 | /doc/ 14 | /Meta/ 15 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | scratch 4 | ^README\.Rmd$ 5 | ^README-.*\.png$ 6 | cran-comments.md 7 | ^CRAN-RELEASE$ 8 | 9 | \.o$ 10 | \.so$ 11 | \.dll$ 12 | ^\.github$ 13 | ^revdep$ 14 | ^CRAN-SUBMISSION$ 15 | ^doc$ 16 | ^Meta$ 17 | -------------------------------------------------------------------------------- /src/corr.h: -------------------------------------------------------------------------------- 1 | using namespace Rcpp; 2 | using namespace arma; 3 | 4 | #ifndef PKG_FOO1_H 5 | #define PKG_FOO1_H 6 | 7 | Rcpp::NumericMatrix corr_gauss_matrix_symC(NumericMatrix x, NumericVector theta); 8 | 9 | arma::mat corr_gauss_matrix_sym_armaC(arma::mat x, arma::vec theta); 10 | 11 | #endif 12 | -------------------------------------------------------------------------------- /scratch/scratch_noiseless.R: -------------------------------------------------------------------------------- 1 | d <- 1 2 | n <- 20 3 | X <- matrix(runif(d*n), ncol=d) 4 | Y <- X[,1]^1.3 - cos(5*sqrt(.2+X[,1])) 5 | cbind(X, Y) 6 | plot(X, Y) 7 | 8 | gp <- GauPro_kernel_model$new(X, Y, kernel=Matern52$new(0), nug.max=0, nug.min=0) 9 | gp$plot1D() 10 | gp$nug 11 | cbind(Y, gp$pred(X)) 12 | -------------------------------------------------------------------------------- /R/ContourFunctions_cf_func.R: -------------------------------------------------------------------------------- 1 | ContourFunctions_cf_func <- function(...) { 2 | if (requireNamespace("ContourFunctions")) { 3 | ContourFunctions::cf_func(...) 4 | } else { 5 | message(paste0("The R package ContourFunctions is not available. ", 6 | "Please install and try again.")) 7 | return(NULL) 8 | } 9 | } 10 | -------------------------------------------------------------------------------- /scratch/solvewithchol.R: -------------------------------------------------------------------------------- 1 | if (F) { 2 | backsolve(kchol, backsolve(kchol, Z, transpose = T)) 3 | } 4 | # 5 | # If kchol <- chol(k), 6 | # then solvewithchol(kchol, Z) is same as solve(k, Z) 7 | solvewithchol <- function(kchol, Z) { 8 | backsolve(kchol, backsolve(kchol, Z, transpose = T)) 9 | } 10 | 11 | calc_inv_from_chol <- FALSE 12 | -------------------------------------------------------------------------------- /src/armadillotest.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace arma; 3 | 4 | 5 | // [[Rcpp::export]] 6 | arma::mat cholC (arma::mat x) { 7 | return(chol(x)) ; 8 | } 9 | 10 | 11 | // You can include R code blocks in C++ files processed with sourceCpp 12 | // (useful for testing and development). The R code will be automatically 13 | // run after the compilation. 14 | // 15 | 16 | /*** R 17 | */ 18 | -------------------------------------------------------------------------------- /src/armadillotest2.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace arma; 3 | 4 | 5 | // [[Rcpp::export]] 6 | arma::mat solveC (arma::mat A, arma::vec b) { 7 | return(solve(A,b)) ; 8 | } 9 | 10 | 11 | 12 | // You can include R code blocks in C++ files processed with sourceCpp 13 | // (useful for testing and development). The R code will be automatically 14 | // run after the compilation. 15 | // 16 | 17 | /*** R 18 | */ 19 | -------------------------------------------------------------------------------- /scratch/BestUnbiasedLinearPredictors.R: -------------------------------------------------------------------------------- 1 | ## ----setup, include = FALSE--------------------------------------------------- 2 | knitr::opts_chunk$set( 3 | collapse = TRUE, 4 | comment = "#>" 5 | ) 6 | 7 | ## ---- fig.show='hold'--------------------------------------------------------- 8 | plot(1:10) 9 | plot(10:1) 10 | 11 | ## ---- echo=FALSE, results='asis'---------------------------------------------- 12 | knitr::kable(head(mtcars, 10)) 13 | 14 | -------------------------------------------------------------------------------- /scratch/scratch_formuladf_attenu.R: -------------------------------------------------------------------------------- 1 | library(dplyr) 2 | x <- datasets::attenu[,c(1,2,4)] 3 | y <- datasets::attenu[,5] 4 | str(x) 5 | str(y) 6 | 7 | gp <- GauPro::GauPro_kernel_model$new(X=x, Z=y, kernel='m52') 8 | gp$plot() 9 | gp$plotmarginalrandom() 10 | gp$plotLOO() 11 | 12 | gpdf <- GauPro::GauPro_kernel_model$new(datasets::attenu, accel ~ event + mag + dist) 13 | gpdf 14 | gpdf$plotmarginal() 15 | gpdf$plotLOO() 16 | summary(gpdf) 17 | gpdf$importance() 18 | -------------------------------------------------------------------------------- /man/summary.GauPro.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/GauPro_S3.R 3 | \name{summary.GauPro} 4 | \alias{summary.GauPro} 5 | \title{Summary for GauPro object} 6 | \usage{ 7 | \method{summary}{GauPro}(object, ...) 8 | } 9 | \arguments{ 10 | \item{object}{GauPro R6 object} 11 | 12 | \item{...}{Additional arguments passed to summary} 13 | } 14 | \value{ 15 | Summary 16 | } 17 | \description{ 18 | Summary for GauPro object 19 | } 20 | -------------------------------------------------------------------------------- /man/print.summary.GauPro.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/GauPro_S3.R 3 | \name{print.summary.GauPro} 4 | \alias{print.summary.GauPro} 5 | \title{Print summary.GauPro} 6 | \usage{ 7 | \method{print}{summary.GauPro}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{summary.GauPro object} 11 | 12 | \item{...}{Additional args} 13 | } 14 | \value{ 15 | prints, returns invisible object 16 | } 17 | \description{ 18 | Print summary.GauPro 19 | } 20 | -------------------------------------------------------------------------------- /GauPro.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageRoxygenize: rd,collate,namespace,vignette 22 | -------------------------------------------------------------------------------- /scratch/scratch_airquality.R: -------------------------------------------------------------------------------- 1 | aq <- airquality 2 | # Add column for day number 3 | aq$daynum <- 1:nrow(aq) 4 | aq <- aq[, -c(5, 6)] 5 | aq 6 | pairs(aq) 7 | # Remove all NA values 8 | aq <- aq[!(is.na(aq$Ozone) | is.na(aq$Solar.R)), ] 9 | pairs(aq) 10 | # Fit Ozone as a factor of the other inputs 11 | gpaq <- gpkm(Ozone ~ ., data=aq, kernel=Matern32, restarts = 20) 12 | gpaq 13 | summary(gpaq) 14 | gpaq$plotmarginalrandom() 15 | gpaq$plotLOO() 16 | gpaq$kernel$k(gpaq$X) 17 | gpaq$kernel$k(gpaq$X, gpaq$X) 18 | -------------------------------------------------------------------------------- /man/corr_cubic_matrix_symC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{corr_cubic_matrix_symC} 4 | \alias{corr_cubic_matrix_symC} 5 | \title{Correlation Cubic matrix in C (symmetric)} 6 | \usage{ 7 | corr_cubic_matrix_symC(x, theta) 8 | } 9 | \arguments{ 10 | \item{x}{Matrix x} 11 | 12 | \item{theta}{Theta vector} 13 | } 14 | \value{ 15 | Correlation matrix 16 | } 17 | \description{ 18 | Correlation Cubic matrix in C (symmetric) 19 | } 20 | \examples{ 21 | corr_cubic_matrix_symC(matrix(c(1,0,0,1),2,2),c(1,1)) 22 | } 23 | -------------------------------------------------------------------------------- /man/plus-.GauPro_kernel.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/GauPro_S3.R 3 | \name{+.GauPro_kernel} 4 | \alias{+.GauPro_kernel} 5 | \title{Kernel sum} 6 | \usage{ 7 | \method{+}{GauPro_kernel}(k1, k2) 8 | } 9 | \arguments{ 10 | \item{k1}{First kernel} 11 | 12 | \item{k2}{Second kernel} 13 | } 14 | \value{ 15 | Kernel which is sum of two kernels 16 | } 17 | \description{ 18 | Kernel sum 19 | } 20 | \examples{ 21 | k1 <- Exponential$new(beta=1) 22 | k2 <- Matern32$new(beta=0) 23 | k <- k1 + k2 24 | k$k(matrix(c(2,1), ncol=1)) 25 | } 26 | -------------------------------------------------------------------------------- /man/corr_gauss_matrix_symC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{corr_gauss_matrix_symC} 4 | \alias{corr_gauss_matrix_symC} 5 | \title{Correlation Gaussian matrix in C (symmetric)} 6 | \usage{ 7 | corr_gauss_matrix_symC(x, theta) 8 | } 9 | \arguments{ 10 | \item{x}{Matrix x} 11 | 12 | \item{theta}{Theta vector} 13 | } 14 | \value{ 15 | Correlation matrix 16 | } 17 | \description{ 18 | Correlation Gaussian matrix in C (symmetric) 19 | } 20 | \examples{ 21 | corr_gauss_matrix_symC(matrix(c(1,0,0,1),2,2),c(1,1)) 22 | } 23 | -------------------------------------------------------------------------------- /man/times-.GauPro_kernel.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/GauPro_S3.R 3 | \name{*.GauPro_kernel} 4 | \alias{*.GauPro_kernel} 5 | \title{Kernel product} 6 | \usage{ 7 | \method{*}{GauPro_kernel}(k1, k2) 8 | } 9 | \arguments{ 10 | \item{k1}{First kernel} 11 | 12 | \item{k2}{Second kernel} 13 | } 14 | \value{ 15 | Kernel which is product of two kernels 16 | } 17 | \description{ 18 | Kernel product 19 | } 20 | \examples{ 21 | k1 <- Exponential$new(beta=1) 22 | k2 <- Matern32$new(beta=0) 23 | k <- k1 * k2 24 | k$k(matrix(c(2,1), ncol=1)) 25 | } 26 | -------------------------------------------------------------------------------- /man/corr_gauss_matrix.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/corr.R 3 | \name{corr_gauss_matrix} 4 | \alias{corr_gauss_matrix} 5 | \title{Gaussian correlation} 6 | \usage{ 7 | corr_gauss_matrix(x, x2 = NULL, theta) 8 | } 9 | \arguments{ 10 | \item{x}{First data matrix} 11 | 12 | \item{x2}{Second data matrix} 13 | 14 | \item{theta}{Correlation parameter} 15 | } 16 | \value{ 17 | Correlation matrix 18 | } 19 | \description{ 20 | Gaussian correlation 21 | } 22 | \examples{ 23 | corr_gauss_matrix(matrix(1:10,ncol=1), matrix(6:15,ncol=1), 1e-2) 24 | } 25 | -------------------------------------------------------------------------------- /man/corr_matern32_matrix_symC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{corr_matern32_matrix_symC} 4 | \alias{corr_matern32_matrix_symC} 5 | \title{Correlation Matern 3/2 matrix in C (symmetric)} 6 | \usage{ 7 | corr_matern32_matrix_symC(x, theta) 8 | } 9 | \arguments{ 10 | \item{x}{Matrix x} 11 | 12 | \item{theta}{Theta vector} 13 | } 14 | \value{ 15 | Correlation matrix 16 | } 17 | \description{ 18 | Correlation Matern 3/2 matrix in C (symmetric) 19 | } 20 | \examples{ 21 | corr_gauss_matrix_symC(matrix(c(1,0,0,1),2,2),c(1,1)) 22 | } 23 | -------------------------------------------------------------------------------- /man/corr_matern52_matrix_symC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{corr_matern52_matrix_symC} 4 | \alias{corr_matern52_matrix_symC} 5 | \title{Correlation Gaussian matrix in C (symmetric)} 6 | \usage{ 7 | corr_matern52_matrix_symC(x, theta) 8 | } 9 | \arguments{ 10 | \item{x}{Matrix x} 11 | 12 | \item{theta}{Theta vector} 13 | } 14 | \value{ 15 | Correlation matrix 16 | } 17 | \description{ 18 | Correlation Gaussian matrix in C (symmetric) 19 | } 20 | \examples{ 21 | corr_matern52_matrix_symC(matrix(c(1,0,0,1),2,2),c(1,1)) 22 | } 23 | -------------------------------------------------------------------------------- /man/corr_exponential_matrix_symC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{corr_exponential_matrix_symC} 4 | \alias{corr_exponential_matrix_symC} 5 | \title{Correlation Gaussian matrix in C (symmetric)} 6 | \usage{ 7 | corr_exponential_matrix_symC(x, theta) 8 | } 9 | \arguments{ 10 | \item{x}{Matrix x} 11 | 12 | \item{theta}{Theta vector} 13 | } 14 | \value{ 15 | Correlation matrix 16 | } 17 | \description{ 18 | Correlation Gaussian matrix in C (symmetric) 19 | } 20 | \examples{ 21 | corr_gauss_matrix_symC(matrix(c(1,0,0,1),2,2),c(1,1)) 22 | } 23 | -------------------------------------------------------------------------------- /scratch/scratch_compare_corr_gauss_matrix.R: -------------------------------------------------------------------------------- 1 | d <- 6 2 | x1 <- matrix(runif(100*d), ncol=d) 3 | x2 <- matrix(runif(1e4*d), ncol=d) 4 | th <- runif(d) 5 | t1 <- corr_gauss_matrixC(x1, x2, th) 6 | t2 <- corr_gauss_matrix_armaC(x1, x2, th) 7 | identical(t1, t2) 8 | microbenchmark::microbenchmark(corr_gauss_matrixC(x1, x2, th), corr_gauss_matrix_armaC(x1, x2, th)) 9 | 10 | x3 <- matrix(runif(1e3*6), ncol=) 11 | t3 <- corr_gauss_matrix_symC(x3, th) 12 | t4 <- corr_gauss_matrix_sym_armaC(x3, th) 13 | identical(t3, t4) 14 | microbenchmark::microbenchmark(corr_gauss_matrix_symC(x3, th), corr_gauss_matrix_sym_armaC(x3, th), times=50) 15 | -------------------------------------------------------------------------------- /man/GauPro.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/GauPro_selector.R 3 | \name{GauPro} 4 | \alias{GauPro} 5 | \title{GauPro_selector} 6 | \usage{ 7 | GauPro(..., type = "Gauss") 8 | } 9 | \arguments{ 10 | \item{...}{Pass on} 11 | 12 | \item{type}{Type of Gaussian process, or the kind of correlation function.} 13 | } 14 | \value{ 15 | A GauPro object 16 | } 17 | \description{ 18 | GauPro_selector 19 | } 20 | \examples{ 21 | n <- 12 22 | x <- matrix(seq(0,1,length.out = n), ncol=1) 23 | #y <- sin(2*pi*x) + rnorm(n,0,1e-1) 24 | y <- (2*x) \%\%1 25 | gp <- GauPro(X=x, Z=y, parallel=FALSE) 26 | } 27 | -------------------------------------------------------------------------------- /scratch/scratch_kernel_model_update_fast.R: -------------------------------------------------------------------------------- 1 | # Testing update_fast 2 | n <- 50 3 | x <- lhs::maximinLHS(n=n, k=2) 4 | y <- TestFunctions::banana(x) 5 | x2 <- matrix(c(.5,.5), 1,2) 6 | y2 <- TestFunctions::banana(x2) 7 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian) 8 | gp$update_fast(Xnew = x2, Znew = y2) 9 | 10 | microbenchmark::microbenchmark({ 11 | add20=for (i in 1:20) { 12 | x3 <- matrix(runif(2), 1, 2) 13 | y3 <- TestFunctions::banana(x3) 14 | gp$update_fast(Xnew = x3, Znew = y3) 15 | # gp$update(Xnew = x3, Znew = y3) 16 | # gp$update(Xnew = x3, Znew = y3, no_update = T) 17 | }}, times=1 18 | ) 19 | -------------------------------------------------------------------------------- /man/sqrt_matrix.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/sqrt_matrix.R 3 | \name{sqrt_matrix} 4 | \alias{sqrt_matrix} 5 | \title{Find the square root of a matrix} 6 | \usage{ 7 | sqrt_matrix(mat, symmetric) 8 | } 9 | \arguments{ 10 | \item{mat}{Matrix to find square root matrix of} 11 | 12 | \item{symmetric}{Is it symmetric? Passed to eigen.} 13 | } 14 | \value{ 15 | Square root of mat 16 | } 17 | \description{ 18 | Same thing as 'expm::sqrtm', but faster. 19 | } 20 | \examples{ 21 | mat <- matrix(c(1,.1,.1,1), 2, 2) 22 | smat <- sqrt_matrix(mat=mat, symmetric=TRUE) 23 | smat \%*\% smat 24 | } 25 | -------------------------------------------------------------------------------- /R/GauPro_selector.R: -------------------------------------------------------------------------------- 1 | #' GauPro_selector 2 | #' 3 | #' @param type Type of Gaussian process, or the kind of correlation function. 4 | #' @param ... Pass on 5 | #' 6 | #' @return A GauPro object 7 | #' @export 8 | #' 9 | #' @examples 10 | #' n <- 12 11 | #' x <- matrix(seq(0,1,length.out = n), ncol=1) 12 | #' #y <- sin(2*pi*x) + rnorm(n,0,1e-1) 13 | #' y <- (2*x) %%1 14 | #' gp <- GauPro(X=x, Z=y, parallel=FALSE) 15 | GauPro <- function(..., type="Gauss") { 16 | if (type!= "Gauss") {stop("This only works with type='Gauss'. Instead try GauPro_kernel_model$new(x,y, kernel=)")} 17 | gp <- GauPro_Gauss$new(...) 18 | return(gp) 19 | } 20 | -------------------------------------------------------------------------------- /man/Gaussian_devianceC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{Gaussian_devianceC} 4 | \alias{Gaussian_devianceC} 5 | \title{Calculate the Gaussian deviance in C} 6 | \usage{ 7 | Gaussian_devianceC(theta, nug, X, Z) 8 | } 9 | \arguments{ 10 | \item{theta}{Theta vector} 11 | 12 | \item{nug}{Nugget} 13 | 14 | \item{X}{Matrix X} 15 | 16 | \item{Z}{Matrix Z} 17 | } 18 | \value{ 19 | Correlation matrix 20 | } 21 | \description{ 22 | Calculate the Gaussian deviance in C 23 | } 24 | \examples{ 25 | Gaussian_devianceC(c(1,1), 1e-8, matrix(c(1,0,0,1),2,2), matrix(c(1,0),2,1)) 26 | } 27 | -------------------------------------------------------------------------------- /man/Gaussian_hessianCC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{Gaussian_hessianCC} 4 | \alias{Gaussian_hessianCC} 5 | \title{Gaussian hessian in C} 6 | \usage{ 7 | Gaussian_hessianCC(XX, X, Z, Kinv, mu_hat, theta) 8 | } 9 | \arguments{ 10 | \item{XX}{point to find Hessian at} 11 | 12 | \item{X}{matrix of data points} 13 | 14 | \item{Z}{matrix of output} 15 | 16 | \item{Kinv}{inverse of correlation matrix} 17 | 18 | \item{mu_hat}{mean estimate} 19 | 20 | \item{theta}{correlation parameters} 21 | } 22 | \value{ 23 | Hessian matrix 24 | } 25 | \description{ 26 | Gaussian hessian in C 27 | } 28 | -------------------------------------------------------------------------------- /man/corr_gauss_matrixC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{corr_gauss_matrixC} 4 | \alias{corr_gauss_matrixC} 5 | \title{Correlation Gaussian matrix in C using Rcpp} 6 | \usage{ 7 | corr_gauss_matrixC(x, y, theta) 8 | } 9 | \arguments{ 10 | \item{x}{Matrix x} 11 | 12 | \item{y}{Matrix y, must have same number of columns as x} 13 | 14 | \item{theta}{Theta vector} 15 | } 16 | \value{ 17 | Correlation matrix 18 | } 19 | \description{ 20 | Correlation Gaussian matrix in C using Rcpp 21 | } 22 | \examples{ 23 | corr_gauss_matrixC(matrix(c(1,0,0,1),2,2), matrix(c(1,0,1,1),2,2), c(1,1)) 24 | } 25 | -------------------------------------------------------------------------------- /src/Makevars.win: -------------------------------------------------------------------------------- 1 | 2 | ## With R 3.1.0 or later, you can uncomment the following line to tell R to 3 | ## enable compilation with C++11 (where available) 4 | ## 5 | ## Also, OpenMP support in Armadillo prefers C++11 support. However, for wider 6 | ## availability of the package we do not yet enforce this here. It is however 7 | ## recommended for client packages to set it. 8 | ## 9 | ## And with R 3.4.0, and RcppArmadillo 0.7.960.*, we turn C++11 on as OpenMP 10 | ## support within Armadillo prefers / requires it 11 | CXX_STD = CXX17 12 | 13 | PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) 14 | PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 15 | -------------------------------------------------------------------------------- /scratch/EI_tdist.R: -------------------------------------------------------------------------------- 1 | EI_tdist <- function(target, y, s, df, minimize=TRUE) { 2 | if (!minimize) { 3 | target <- -target 4 | y <- -y 5 | } 6 | z <- (target - y) / s 7 | (target - y) * pt(z, df) + df / (df - 1) * (1 + z^2/df) * s * dt(z, df) 8 | } 9 | if (F) { 10 | EI_tdist(0, 1, 1, 10, F) 11 | EI_tdist(0, 1, 1, 10, T) 12 | # Vary df 13 | curve(EI_tdist(0, 1, 1, x, T), 3, 30) 14 | curve(EI_tdist(0, 1, 1, x, F), 3, 30) 15 | # Vary mean 16 | curve(EI_tdist(0, x, 1, 10, T), -5, 5) 17 | curve(EI_tdist(0, x, 1, 10, F), -5, 5) 18 | # Vary s 19 | curve(EI_tdist(0, 1, x, 10, T), .01, 3) 20 | curve(EI_tdist(0, 1, x, 10, T), .01, 3) 21 | } 22 | -------------------------------------------------------------------------------- /R/lhs_maximinLHS.R: -------------------------------------------------------------------------------- 1 | lhs_maximinLHS <- function(n, k) { 2 | 3 | if (requireNamespace("lhs", quietly = TRUE)) { 4 | lhs <- lhs::maximinLHS(n=n, k=k) 5 | } else { 6 | message("lhs package not available, using worse option. Please install lhs.") 7 | # Increasing lhs 8 | lhs <- (matrix(data=1:n, byrow=F, 9 | nrow=n, ncol=k) - 1 + 10 | matrix(data=runif(n*k), 11 | nrow=n, ncol=k) 12 | ) / n 13 | # Randomize each column 14 | for (i in 1:k) { 15 | lhs[, i] <- lhs[sample(1:n, n, replace=F), i] 16 | } 17 | } 18 | lhs 19 | } 20 | if (F) { 21 | ceiling(lhs_maximinLHS(10, 3)*10) 22 | } 23 | -------------------------------------------------------------------------------- /src/Makevars: -------------------------------------------------------------------------------- 1 | 2 | ## With R 3.1.0 or later, you can uncomment the following line to tell R to 3 | ## enable compilation with C++11 (where available) 4 | ## 5 | ## Also, OpenMP support in Armadillo prefers C++11 support. However, for wider 6 | ## availability of the package we do not yet enforce this here. It is however 7 | ## recommended for client packages to set it. 8 | ## 9 | ## And with R 3.4.0, and RcppArmadillo 0.7.960.*, we turn C++11 on as OpenMP 10 | ## support within Armadillo prefers / requires it 11 | CXX_STD = CXX17 12 | 13 | PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) 14 | PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 15 | 16 | CXX=clang++ 17 | -------------------------------------------------------------------------------- /scratch/scratch_arma_cube_vec_multiply.R: -------------------------------------------------------------------------------- 1 | n <- 50 2 | x <- lhs::maximinLHS(n=n, k=2) 3 | y <- TestFunctions::banana(x) 4 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian) 5 | xx <- matrix(runif(2e5),ncol=2) 6 | gp$pred(XX = xx, se=T) 7 | pv <- profvis::profvis(gp$pred(XX = xx, se=T)) 8 | pv 9 | 10 | 11 | system.time(replicate(10,gp$pred(XX=xx, se=T))) # 23.01 0.06 25.42 before changing df to cbind 12 | system.time(replicate(10,gp$pred(XX=xx, se=T))) # 12.50 0.02 13.12 after changing df to list 13 | 14 | microbenchmark::microbenchmark(as.data.frame(tc), as.data.frame.matrix(tc)) 15 | microbenchmark::microbenchmark(data.frame(c1,c2,c3), {(list(c1,c2,c3))}, cbind(c1,c2,c3)) 16 | -------------------------------------------------------------------------------- /scratch/plot2D_two_factors.R: -------------------------------------------------------------------------------- 1 | library(dplyr) 2 | library(GauPro) 3 | 4 | # numeric x1/x2 5 | n <- 30 6 | x1 <- runif(n) 7 | x2 <- runif(n) 8 | y <- x1*x2 + .02*rnorm(length(x1)) 9 | df <- data.frame(x1, x2, y) 10 | df 11 | pairs(df) 12 | gp <- gpkm(y ~ x1 + x2, df) 13 | gp 14 | gp$plot2D() 15 | 16 | 17 | # factor x1/x2 18 | x1 <- sample(c('a', 'b'), 10, T) 19 | x2 <- sample(c('c', 'd'), 10, T) 20 | y <- as.numeric((x1 == 'a') & (x2 == 'c')) + rnorm(length(x1)) 21 | df <- data.frame(x1, x2, y) 22 | df 23 | gp <- gpkm(y ~ x1 + x2, df, 24 | kernel=k_GowerFactorKernel(D=1, nlevels=2, xindex=1)* 25 | k_GowerFactorKernel(D=2, nlevels=2, xindex=2)) 26 | gp 27 | gp$plot2D() 28 | -------------------------------------------------------------------------------- /scratch/plotLOO_issue.R: -------------------------------------------------------------------------------- 1 | # https://github.com/CollinErickson/GauPro/issues/3 2 | # Tried to check his issue, but found a different issue. 3 | 4 | n <- 50 5 | f <- function(a,b,c) {a+b*c+100} 6 | smooth_x_rt <- data.frame(a=runif(n), b=rnorm(n), c=rexp(n)) 7 | results <- data.frame(RT_2=with(smooth_x_rt, f(a,b,c)), RT=rnorm(n, sd=.1)) 8 | 9 | gp <- GauPro::gpkm(smooth_x_rt, results$RT_2 - results$RT, kernel = "matern52", 10 | parallel = TRUE, normalize = TRUE, verbose = 0) 11 | gp$plot() 12 | gp$plotLOO() 13 | 14 | 15 | n2 <- 1000 16 | x <- data.frame(a=runif(n2), b=rnorm(n2), rexp(n)) 17 | predx <- gp$pred(x) 18 | fx <- f(x[,1], x[,2], x[,3]) 19 | plot(predx, fx); abline(a=0, b=1) 20 | 21 | -------------------------------------------------------------------------------- /man/corr_gauss_dCdX.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{corr_gauss_dCdX} 4 | \alias{corr_gauss_dCdX} 5 | \title{Correlation Gaussian matrix gradient in C using Armadillo} 6 | \usage{ 7 | corr_gauss_dCdX(XX, X, theta, s2) 8 | } 9 | \arguments{ 10 | \item{XX}{Matrix XX to get gradient for} 11 | 12 | \item{X}{Matrix X GP was fit to} 13 | 14 | \item{theta}{Theta vector} 15 | 16 | \item{s2}{Variance parameter} 17 | } 18 | \value{ 19 | 3-dim array of correlation derivative 20 | } 21 | \description{ 22 | Correlation Gaussian matrix gradient in C using Armadillo 23 | } 24 | \examples{ 25 | # corr_gauss_dCdX(matrix(c(1,0,0,1),2,2),c(1,1)) 26 | } 27 | -------------------------------------------------------------------------------- /R/sqrt_matrix.R: -------------------------------------------------------------------------------- 1 | #' Find the square root of a matrix 2 | #' 3 | #' Same thing as 'expm::sqrtm', but faster. 4 | #' 5 | #' @param mat Matrix to find square root matrix of 6 | #' @param symmetric Is it symmetric? Passed to eigen. 7 | #' 8 | #' @return Square root of mat 9 | #' @export 10 | #' 11 | #' @examples 12 | #' mat <- matrix(c(1,.1,.1,1), 2, 2) 13 | #' smat <- sqrt_matrix(mat=mat, symmetric=TRUE) 14 | #' smat %*% smat 15 | sqrt_matrix = function(mat, symmetric) { 16 | e <- eigen(mat, symmetric=symmetric) 17 | V <- e$vectors 18 | if (length(V) == 1) { # diag in 1D is scalar and doesn't work correctly 19 | B <- sqrt(e$values) * V %*% t(V) 20 | } else { 21 | B <- V %*% diag(sqrt(e$values)) %*% t(V) 22 | } 23 | B 24 | } 25 | -------------------------------------------------------------------------------- /scratch/peak_example.R: -------------------------------------------------------------------------------- 1 | # Read in data 2 | df <- read.csv("C:\\Users\\colli\\Downloads\\peak_example.csv") 3 | 4 | # Try untransformed first 5 | # Fit model 6 | gp <- gpkm(df, y ~ x) 7 | 8 | # Check fit, make sure it looks reasonable 9 | gp$plot() 10 | 11 | # Transform into reasonable ranges 12 | df$y2 <- df$y/max(df$y) 13 | df$x2 <- (df$x - min(df$x)) / (max(df$x) - min(df$x)) 14 | 15 | library(GauPro) 16 | # Fit model 17 | gp <- gpkm(df, y2 ~ x2) 18 | 19 | # Check fit, make sure it looks reasonable 20 | gp$plot() 21 | 22 | # Find x that gives maximum 23 | gpmax <- gp$optimize_fn(fn=function(x) {gp$predict(x)}) 24 | 25 | # Check the prediction at that point, get an estimate of the std error 26 | gp$predict(gpmax$par$x2, se.fit=T) 27 | -------------------------------------------------------------------------------- /man/predict.GauPro_base.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/GauPro_base.R 3 | \name{predict.GauPro_base} 4 | \alias{predict.GauPro_base} 5 | \title{Predict for class GauPro_base} 6 | \usage{ 7 | \method{predict}{GauPro_base}(object, XX, se.fit = F, covmat = F, split_speed = T, ...) 8 | } 9 | \arguments{ 10 | \item{object}{Object of class GauPro_base} 11 | 12 | \item{XX}{Points to predict at} 13 | 14 | \item{se.fit}{Should the se be returned?} 15 | 16 | \item{covmat}{Should the covariance matrix be returned?} 17 | 18 | \item{split_speed}{Should the predictions be split up for speed} 19 | 20 | \item{...}{Additional parameters} 21 | } 22 | \value{ 23 | Prediction from object at XX 24 | } 25 | \description{ 26 | Predict mean and se for given matrix 27 | } 28 | -------------------------------------------------------------------------------- /man/kernel_gauss_dC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{kernel_gauss_dC} 4 | \alias{kernel_gauss_dC} 5 | \title{Derivative of Gaussian kernel covariance matrix in C} 6 | \usage{ 7 | kernel_gauss_dC(x, theta, C_nonug, s2_est, beta_est, lenparams_D, s2_nug) 8 | } 9 | \arguments{ 10 | \item{x}{Matrix x} 11 | 12 | \item{theta}{Theta vector} 13 | 14 | \item{C_nonug}{cov mat without nugget} 15 | 16 | \item{s2_est}{whether s2 is being estimated} 17 | 18 | \item{beta_est}{Whether theta/beta is being estimated} 19 | 20 | \item{lenparams_D}{Number of parameters the derivative is being calculated for} 21 | 22 | \item{s2_nug}{s2 times the nug} 23 | } 24 | \value{ 25 | Correlation matrix 26 | } 27 | \description{ 28 | Derivative of Gaussian kernel covariance matrix in C 29 | } 30 | -------------------------------------------------------------------------------- /man/kernel_matern32_dC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{kernel_matern32_dC} 4 | \alias{kernel_matern32_dC} 5 | \title{Derivative of Matern 5/2 kernel covariance matrix in C} 6 | \usage{ 7 | kernel_matern32_dC(x, theta, C_nonug, s2_est, beta_est, lenparams_D, s2_nug) 8 | } 9 | \arguments{ 10 | \item{x}{Matrix x} 11 | 12 | \item{theta}{Theta vector} 13 | 14 | \item{C_nonug}{cov mat without nugget} 15 | 16 | \item{s2_est}{whether s2 is being estimated} 17 | 18 | \item{beta_est}{Whether theta/beta is being estimated} 19 | 20 | \item{lenparams_D}{Number of parameters the derivative is being calculated for} 21 | 22 | \item{s2_nug}{s2 times the nug} 23 | } 24 | \value{ 25 | Correlation matrix 26 | } 27 | \description{ 28 | Derivative of Matern 5/2 kernel covariance matrix in C 29 | } 30 | -------------------------------------------------------------------------------- /man/kernel_matern52_dC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{kernel_matern52_dC} 4 | \alias{kernel_matern52_dC} 5 | \title{Derivative of Matern 5/2 kernel covariance matrix in C} 6 | \usage{ 7 | kernel_matern52_dC(x, theta, C_nonug, s2_est, beta_est, lenparams_D, s2_nug) 8 | } 9 | \arguments{ 10 | \item{x}{Matrix x} 11 | 12 | \item{theta}{Theta vector} 13 | 14 | \item{C_nonug}{cov mat without nugget} 15 | 16 | \item{s2_est}{whether s2 is being estimated} 17 | 18 | \item{beta_est}{Whether theta/beta is being estimated} 19 | 20 | \item{lenparams_D}{Number of parameters the derivative is being calculated for} 21 | 22 | \item{s2_nug}{s2 times the nug} 23 | } 24 | \value{ 25 | Correlation matrix 26 | } 27 | \description{ 28 | Derivative of Matern 5/2 kernel covariance matrix in C 29 | } 30 | -------------------------------------------------------------------------------- /scratch/scratchOTL.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | # higher dim test 4 | n <- 21 5 | d <- 6 6 | x <- matrix(runif(n*d), ncol=d) 7 | f1 <- function(a) {sum(sin(1:d*pi/a))} 8 | f1 <- function(a) {sum(sin(1*pi/a[1:5]))} 9 | f1 <- TestFunctions::OTL_Circuit 10 | y <- apply(x,1,f1) #+ rnorm(n,0,.1) 11 | system.time(gp <- GauPro(x,y, verbose=0));c(gp$theta,gp$nug) 12 | summary(gp$predict(matrix(runif(6*1e3), ncol=6))) 13 | 14 | microbenchmark::microbenchmark(GauPro$new(x,y, useOptim2=F), GauPro$new(x,y, useOptim2=T), times = 10) 15 | microbenchmark::microbenchmark(GauPro$new(x,y), times = 100) 16 | nn <- 2000 17 | gp$pred(matrix(runif(nn*d),ncol=d)) 18 | gp$grad(matrix(runif(nn*d),ncol=d)) 19 | gp$grad_norm(matrix(runif(nn*d),ncol=d)) 20 | plot(y,gp$pred(x));abline(a=0,b=1) 21 | 22 | mod <- UGP::IGP(X=x,Z=y, package='GauPro') 23 | summary(mod$predict(matrix(runif(6*1e3), ncol=6))) 24 | -------------------------------------------------------------------------------- /scratch/fastfit.R: -------------------------------------------------------------------------------- 1 | # Plan was to try to initial fit on subset of data, then go to all data 2 | # for final steps. 3 | # Didn't work, the final step ended up using just as many steps. 4 | 5 | fastfit <- function(self) { 6 | # Save all data 7 | fullX <- self$X 8 | fullZ <- self$Z 9 | # Fit on subset of data 10 | n1 <- 75 11 | stopifnot(n1 < nrow(fullX)) 12 | inds1 <- sample(1:nrow(fullX), n1, replace=FALSE) 13 | X1 <- fullX[inds1, ] 14 | Z1 <- fullZ[inds1] 15 | self$X <- X1 16 | self$Z <- Z1 17 | self$N <- nrow(self$X) 18 | # self$update_K_and_estimates() 19 | self$update_K_and_estimates() # Need to get mu_hat before starting 20 | system.time(self$update()) 21 | # Now go back to all data 22 | self$X <- fullX 23 | self$Z <- fullZ 24 | self$N <- nrow(self$X) 25 | # debugonce(self$optim) 26 | system.time(self$update()) 27 | } 28 | -------------------------------------------------------------------------------- /man/kernel_cubic_dC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{kernel_cubic_dC} 4 | \alias{kernel_cubic_dC} 5 | \title{Derivative of cubic kernel covariance matrix in C} 6 | \usage{ 7 | kernel_cubic_dC(x, theta, C_nonug, s2_est, beta_est, lenparams_D, s2_nug, s2) 8 | } 9 | \arguments{ 10 | \item{x}{Matrix x} 11 | 12 | \item{theta}{Theta vector} 13 | 14 | \item{C_nonug}{cov mat without nugget} 15 | 16 | \item{s2_est}{whether s2 is being estimated} 17 | 18 | \item{beta_est}{Whether theta/beta is being estimated} 19 | 20 | \item{lenparams_D}{Number of parameters the derivative is being calculated for} 21 | 22 | \item{s2_nug}{s2 times the nug} 23 | 24 | \item{s2}{s2} 25 | } 26 | \value{ 27 | Correlation matrix 28 | } 29 | \description{ 30 | Derivative of cubic kernel covariance matrix in C 31 | } 32 | -------------------------------------------------------------------------------- /man/corr_gauss_matrix_sym_armaC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{corr_gauss_matrix_sym_armaC} 4 | \alias{corr_gauss_matrix_sym_armaC} 5 | \title{Correlation Gaussian matrix in C using Armadillo (symmetric)} 6 | \usage{ 7 | corr_gauss_matrix_sym_armaC(x, theta) 8 | } 9 | \arguments{ 10 | \item{x}{Matrix x} 11 | 12 | \item{theta}{Theta vector} 13 | } 14 | \value{ 15 | Correlation matrix 16 | } 17 | \description{ 18 | About 30% faster than Rcpp version. 19 | } 20 | \examples{ 21 | corr_gauss_matrix_sym_armaC(matrix(c(1,0,0,1),2,2),c(1,1)) 22 | 23 | x3 <- matrix(runif(1e3*6), ncol=6) 24 | th <- runif(6) 25 | t3 <- corr_gauss_matrix_symC(x3, th) 26 | t4 <- corr_gauss_matrix_sym_armaC(x3, th) 27 | identical(t3, t4) 28 | # microbenchmark::microbenchmark(corr_gauss_matrix_symC(x3, th), 29 | # corr_gauss_matrix_sym_armaC(x3, th), times=50) 30 | } 31 | -------------------------------------------------------------------------------- /R/convert_X_with_formula_back.R: -------------------------------------------------------------------------------- 1 | convert_X_with_formula_back <- function(gpdf, x) { 2 | 3 | par <- x 4 | 5 | if (is.matrix(par)) { 6 | pardf <- as.data.frame(par) 7 | } else if (is.numeric(par)) { 8 | pardf <- as.data.frame(matrix(par, nrow=1)) 9 | } 10 | colnames(pardf) <- colnames(gpdf$X) 11 | pardf 12 | 13 | # Convert factor indexes back to factor 14 | for (i in seq_along(gpdf$convert_formula_data$factors)) { 15 | pardf[[gpdf$convert_formula_data$factors[[i]]$index]] <- 16 | gpdf$convert_formula_data$factors[[i]]$levels[ 17 | pardf[[gpdf$convert_formula_data$factors[[i]]$index]]] 18 | } 19 | # Convert char indexes back to char 20 | for (i in seq_along(gpdf$convert_formula_data$chars)) { 21 | pardf[[gpdf$convert_formula_data$chars[[i]]$index]] <- 22 | gpdf$convert_formula_data$chars[[i]]$vals[ 23 | pardf[[gpdf$convert_formula_data$chars[[i]]$index]]] 24 | } 25 | 26 | pardf 27 | } 28 | -------------------------------------------------------------------------------- /man/kernel_exponential_dC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{kernel_exponential_dC} 4 | \alias{kernel_exponential_dC} 5 | \title{Derivative of Matern 5/2 kernel covariance matrix in C} 6 | \usage{ 7 | kernel_exponential_dC( 8 | x, 9 | theta, 10 | C_nonug, 11 | s2_est, 12 | beta_est, 13 | lenparams_D, 14 | s2_nug, 15 | s2 16 | ) 17 | } 18 | \arguments{ 19 | \item{x}{Matrix x} 20 | 21 | \item{theta}{Theta vector} 22 | 23 | \item{C_nonug}{cov mat without nugget} 24 | 25 | \item{s2_est}{whether s2 is being estimated} 26 | 27 | \item{beta_est}{Whether theta/beta is being estimated} 28 | 29 | \item{lenparams_D}{Number of parameters the derivative is being calculated for} 30 | 31 | \item{s2_nug}{s2 times the nug} 32 | 33 | \item{s2}{s2 parameter} 34 | } 35 | \value{ 36 | Correlation matrix 37 | } 38 | \description{ 39 | Derivative of Matern 5/2 kernel covariance matrix in C 40 | } 41 | -------------------------------------------------------------------------------- /man/predict.GauPro.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/GauPro_S3.R 3 | \name{predict.GauPro} 4 | \alias{predict.GauPro} 5 | \title{Predict for class GauPro} 6 | \usage{ 7 | \method{predict}{GauPro}(object, XX, se.fit = F, covmat = F, split_speed = T, ...) 8 | } 9 | \arguments{ 10 | \item{object}{Object of class GauPro} 11 | 12 | \item{XX}{new points to predict} 13 | 14 | \item{se.fit}{Should standard error be returned (and variance)?} 15 | 16 | \item{covmat}{Should the covariance matrix be returned?} 17 | 18 | \item{split_speed}{Should the calculation be split up to speed it up?} 19 | 20 | \item{...}{Additional parameters} 21 | } 22 | \value{ 23 | Prediction from object at XX 24 | } 25 | \description{ 26 | Predict for class GauPro 27 | } 28 | \examples{ 29 | n <- 12 30 | x <- matrix(seq(0,1,length.out = n), ncol=1) 31 | y <- sin(2*pi*x) + rnorm(n,0,1e-1) 32 | gp <- GauPro(X=x, Z=y, parallel=FALSE) 33 | predict(gp, .448) 34 | } 35 | -------------------------------------------------------------------------------- /man/arma_mult_cube_vec.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{arma_mult_cube_vec} 4 | \alias{arma_mult_cube_vec} 5 | \title{Cube multiply over first dimension} 6 | \usage{ 7 | arma_mult_cube_vec(cub, v) 8 | } 9 | \arguments{ 10 | \item{cub}{A cube (3D array)} 11 | 12 | \item{v}{A vector} 13 | } 14 | \value{ 15 | Transpose of multiplication over first dimension of cub time v 16 | } 17 | \description{ 18 | The result is transposed since that is what apply will give you 19 | } 20 | \examples{ 21 | d1 <- 10 22 | d2 <- 1e2 23 | d3 <- 2e2 24 | aa <- array(data = rnorm(d1*d2*d3), dim = c(d1, d2, d3)) 25 | bb <- rnorm(d3) 26 | t1 <- apply(aa, 1, function(U) {U\%*\%bb}) 27 | t2 <- arma_mult_cube_vec(aa, bb) 28 | dd <- t1 - t2 29 | 30 | summary(dd) 31 | image(dd) 32 | table(dd) 33 | # microbenchmark::microbenchmark(apply(aa, 1, function(U) {U\%*\%bb}), 34 | # arma_mult_cube_vec(aa, bb)) 35 | } 36 | -------------------------------------------------------------------------------- /tests/testthat/test_1D.R: -------------------------------------------------------------------------------- 1 | test_that("GauPro_Gauss will give deprecation warning on first time", { 2 | n <- 12 3 | x <- matrix(seq(0,1,length.out = n), ncol=1) 4 | y <- sin(2*pi*x) + rnorm(n,0,1e-1) 5 | expect_no_error({expect_warning({gp <- GauPro_Gauss$new(X=x, Z=y, parallel=FALSE)})}) 6 | }) 7 | 8 | test_that("1D data works", { 9 | n <- 12 10 | x <- matrix(seq(0,1,length.out = n), ncol=1) 11 | y <- sin(2*pi*x) + rnorm(n,0,1e-1) 12 | gp <- GauPro(X=x, Z=y, parallel=FALSE) 13 | expect_that(gp, is_a("GauPro_base")) 14 | expect_that(gp, is_a("R6")) 15 | expect_no_error(predict(gp, x)) 16 | }) 17 | 18 | test_that("corr works", { 19 | m1 <- outer(1:10, 1:10, Vectorize(function(i,j) {exp(-sum((1e-2) * (i-j-5)^2))})) 20 | m2 <- corr_gauss_matrixC(matrix(1:10,ncol=1), matrix(6:15,ncol=1), 1e-2) 21 | m3 <- corr_gauss_matrix(matrix(1:10,ncol=1), matrix(6:15,ncol=1), 1e-2) 22 | expect_equal(m1, m2) 23 | expect_equal(m1, m3) 24 | expect_equal(m2, m3) 25 | }) 26 | -------------------------------------------------------------------------------- /man/gradfuncarray.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{gradfuncarray} 4 | \alias{gradfuncarray} 5 | \title{Calculate gradfunc in optimization to speed up. 6 | NEEDS TO APERM dC_dparams 7 | Doesn't need to be exported, should only be useful in functions.} 8 | \usage{ 9 | gradfuncarray(dC_dparams, Cinv, Cinv_yminusmu) 10 | } 11 | \arguments{ 12 | \item{dC_dparams}{Derivative matrix for covariance function wrt kernel parameters} 13 | 14 | \item{Cinv}{Inverse of covariance matrix} 15 | 16 | \item{Cinv_yminusmu}{Vector that is the inverse of C times y minus the mean.} 17 | } 18 | \value{ 19 | Vector, one value for each parameter 20 | } 21 | \description{ 22 | Calculate gradfunc in optimization to speed up. 23 | NEEDS TO APERM dC_dparams 24 | Doesn't need to be exported, should only be useful in functions. 25 | } 26 | \examples{ 27 | gradfuncarray(array(dim=c(2,4,4), data=rnorm(32)), matrix(rnorm(16),4,4), rnorm(4)) 28 | } 29 | -------------------------------------------------------------------------------- /scratch/scratch_chol_backsolve.R: -------------------------------------------------------------------------------- 1 | n <- 500 2 | d <- 1 3 | kern <- GauPro::Gaussian$new(D=d, beta=2) 4 | X <- matrix(runif(n*d), ncol=d) 5 | kmat <- kern$k(x=X) 6 | diag(kmat) <- diag(kmat) + 1e-4 7 | kchol <- chol(kmat) 8 | t(kchol) %*% kchol # equals kmat 9 | kinv <- chol2inv(kchol) 10 | Z <- rnorm(n) 11 | kinv %*% Z 12 | # backsolve(kchol, backsolve(kchol, Z), transpose = T) 13 | # forwardsolve(kchol, backsolve(kchol, Z), transpose = T) 14 | # This is it 15 | backsolve(kchol, backsolve(kchol, Z, transpose = T)) 16 | plot(kinv %*% Z, backsolve(kchol, backsolve(kchol, Z, transpose = T))) 17 | # backsolves are way faster than chol2inv 18 | microbenchmark::microbenchmark( 19 | chol2inv(kchol), 20 | backsolve(kchol, backsolve(kchol, Z, transpose = T)) 21 | ) 22 | # Can cut time in half by using backsolves 23 | microbenchmark::microbenchmark( 24 | {kchol <- chol(kmat); chol2inv(kchol)}, 25 | {kchol <- chol(kmat); backsolve(kchol, backsolve(kchol, Z, transpose = T))}, times=100 26 | ) 27 | -------------------------------------------------------------------------------- /scratch/ToDo.md: -------------------------------------------------------------------------------- 1 | # GauPro to do 2 | 3 | * EI/CorEI/AugEI/qEI: nopt, test, doc 4 | * Use t-dist 5 | 6 | * Add documentation for kernels, esp. factor ones 7 | 8 | * Add readme/documentation for trends 9 | 10 | * Speed up triangle, ratquad, periodic, powerexp k/grad 11 | 12 | * Knowledge gradient: multiple starts for optim 13 | 14 | * Plot2D: 15 | add axis names, either X1/X2 or colnames (need to add option to CF::gcf_grid) 16 | fix for factors 17 | 18 | * Make gpkm doc look good. Look into R7. 19 | 20 | * sparse pseudo-input GP. See Snelson 2006. Inherit. Change pred_one_matrix, 21 | deviance, etc. 22 | 23 | * Student-t process: Inherit, change pred and deviance. 24 | 25 | * kernel should take in X, Z and set params based on that. E.g., s2 max is 26 | diff(range(Z))^2. Or else give message to normalize. 27 | 28 | * Standardize for X. 29 | 30 | * change kernels to functions k_: documentation, tests, examples, readme 31 | 32 | * change trends from R6 to function t_ 33 | 34 | * gpk$plot1D(ymax=1000) doesn't use ymax? 35 | -------------------------------------------------------------------------------- /scratch/scratch_kernel_model_piston.R: -------------------------------------------------------------------------------- 1 | 2 | f <- TestFunctions::piston 3 | d <- 7 4 | n <- 30 5 | x <- lhs::randomLHS(n=n,k=d) 6 | y <- f(x) + rnorm(nrow(x), 0,1e-1) 7 | # y 8 | # system.time({gp <- GauPro_kernel_model$new(X=x, Z=y, kernel = Matern52$new(D=d), verbose = 5)}) 9 | system.time({gp <- GauPro_kernel_model$new(X=x, Z=y, kernel = Gaussian$new(D=d), verbose = 5)}) 10 | plot(gp$pred_LOO(), y) 11 | gp$plotmarginal() 12 | gp$plotmarginal(gp$X[1,]) 13 | plot(gp) 14 | gp$plotmarginalrandom() 15 | gp$EI(runif(7)) 16 | gp$EI(lhs::randomLHS(n=100, k=ncol(x))) 17 | xmx <- c(1.2770051, -0.2920814, 0.9825472, -0.2937785, -1.3244573, 6.8359251, -11.4165417) 18 | optim(par=xmx, fn=function(xx){ei <- -gp$EI(xx); cat(xx, ei, "\n"); ei}) 19 | gp$maxEI() 20 | gp$maxEI(minimize = T) 21 | f(gp$maxEI()) 22 | f(gp$maxEI(minimize = T)) 23 | gp$maxqEI(5) 24 | f(gp$maxqEI(5)) 25 | gp$maxqEI(5, minimize = T) 26 | f(gp$maxqEI(5, minimize = T)) 27 | 28 | reldiff <- function(a,b) {abs(a-b)/max(abs(c(a,b)))} 29 | 30 | -------------------------------------------------------------------------------- /scratch/scratch_kernel_model_1D.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | f <- function(x) {abs(sin(2*pi*x^1.3))^1.3} 4 | # f <- function(x) sin(2*pi*x) 5 | d <- 1 6 | n <- 7 7 | x <- lhs::randomLHS(n=n,k=d) 8 | noisesd <- 1e-16 9 | y <- f(x) + rnorm(n,0, noisesd) 10 | plot(x,y) 11 | # y 12 | system.time({gp <- GauPro_kernel_model$new(X=x, Z=y, kernel = Matern52$new(D=d), verbose = 5)}) 13 | # system.time({gp <- GauPro_kernel_model$new(X=x, Z=y, kernel = Gaussian$new(D=d), verbose = 5, restarts = 0)}) 14 | plot(gp) 15 | gp$plot1D() 16 | gp$cool1Dplot() 17 | gp$pred(matrix(c(.1,.2,.3,.4,.5), ncol=1), se.fit = T, mean_dist = T) 18 | gp$pred(matrix(c(.1,.2,.3,.4,.5), ncol=1), se.fit = T, mean_dist = F) 19 | curve(gp$EI(matrix(x,ncol=1)) %>% {./(max(.)-min(.))}, add=T, col=3) 20 | gp$EI(matrix(seq(0,1,l=101),ncol=1)) %T>% plot %>% summary 21 | gp$maxqEI(5) 22 | 23 | # Run EI 24 | for (i in 1:15) { 25 | x.ei <- gp$maxEI(lower=0, upper=1, minimize = F) 26 | gp$update(Xnew=x.ei, Znew=f(x.ei) + rnorm(1,0, noisesd)) 27 | gp$cool1Dplot() 28 | } 29 | -------------------------------------------------------------------------------- /man/gradfuncarrayR.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/gradfuncarray.R 3 | \name{gradfuncarrayR} 4 | \alias{gradfuncarrayR} 5 | \title{Calculate gradfunc in optimization to speed up. 6 | NEEDS TO APERM dC_dparams 7 | Doesn't need to be exported, should only be useful in functions.} 8 | \usage{ 9 | gradfuncarrayR(dC_dparams, Cinv, Cinv_yminusmu) 10 | } 11 | \arguments{ 12 | \item{dC_dparams}{Derivative matrix for covariance function wrt kernel parameters} 13 | 14 | \item{Cinv}{Inverse of covariance matrix} 15 | 16 | \item{Cinv_yminusmu}{Vector that is the inverse of C times y minus the mean.} 17 | } 18 | \value{ 19 | Vector, one value for each parameter 20 | } 21 | \description{ 22 | Calculate gradfunc in optimization to speed up. 23 | NEEDS TO APERM dC_dparams 24 | Doesn't need to be exported, should only be useful in functions. 25 | } 26 | \examples{ 27 | a1 <- array(dim=c(2,4,4), data=rnorm(32)) 28 | a2 <- matrix(rnorm(16),4,4) 29 | a3 <- rnorm(4) 30 | #gradfuncarray(a1, a2, a3) 31 | #gradfuncarrayR(a1, a2, a3) 32 | } 33 | -------------------------------------------------------------------------------- /vignettes/CrossValidationErrorCorrection.R: -------------------------------------------------------------------------------- 1 | ## ----results='hide', echo=FALSE----------------------------------------------- 2 | set.seed(0) 3 | 4 | ## ----------------------------------------------------------------------------- 5 | n <- 200 6 | m1 <- matrix(runif(n*n),ncol=n) 7 | b1 <- runif(n) 8 | if (requireNamespace("microbenchmark", quietly = TRUE)) { 9 | microbenchmark::microbenchmark(solve(m1, b1), m1 %*% b1) 10 | } 11 | 12 | ## ----------------------------------------------------------------------------- 13 | set.seed(0) 14 | corr <- function(x,y) {exp(sum(-30*(x-y)^2))} 15 | n <- 200 16 | d <- 2 17 | X <- matrix(runif(n*d),ncol=2) 18 | R <- outer(1:n,1:n, Vectorize(function(i,j) {corr(X[i,], X[j,])})) 19 | Rinv <- solve(R) 20 | A <- R[-n,-n] 21 | Ainv <- solve(A) 22 | E <- Rinv[-n, -n] 23 | b <- R[n,-n] 24 | g <- Rinv[n,-n] 25 | Ainv_shortcut <- E + E %*% b %*% g / (1-sum(g*b)) 26 | summary(c(Ainv - Ainv_shortcut)) 27 | if (requireNamespace("microbenchmark", quietly = TRUE)) { 28 | microbenchmark::microbenchmark(solve(A), E + E %*% b %*% g / (1-sum(g*b))) 29 | } 30 | 31 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/master/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | 9 | name: test-coverage 10 | 11 | jobs: 12 | test-coverage: 13 | runs-on: ubuntu-latest 14 | env: 15 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 16 | 17 | steps: 18 | - uses: actions/checkout@v2 19 | 20 | - uses: r-lib/actions/setup-r@v2 21 | with: 22 | use-public-rspm: true 23 | 24 | - uses: r-lib/actions/setup-r-dependencies@v2 25 | with: 26 | extra-packages: covr 27 | 28 | - name: Install dependencies 29 | run: | 30 | install.packages(c("remotes"),dependencies=TRUE) 31 | remotes::install_github("collinerickson/mixopt") 32 | shell: Rscript {0} 33 | 34 | - name: Test coverage 35 | run: covr::codecov() 36 | shell: Rscript {0} 37 | -------------------------------------------------------------------------------- /man/corr_orderedfactor_matrix_symC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{corr_orderedfactor_matrix_symC} 4 | \alias{corr_orderedfactor_matrix_symC} 5 | \title{Correlation ordered factor matrix in C (symmetric)} 6 | \usage{ 7 | corr_orderedfactor_matrix_symC(x, theta, xindex, offdiagequal) 8 | } 9 | \arguments{ 10 | \item{x}{Matrix x} 11 | 12 | \item{theta}{Theta vector} 13 | 14 | \item{xindex}{Index to use} 15 | 16 | \item{offdiagequal}{What to set off-diagonal values with matching values to.} 17 | } 18 | \value{ 19 | Correlation matrix 20 | } 21 | \description{ 22 | Correlation ordered factor matrix in C (symmetric) 23 | } 24 | \examples{ 25 | corr_orderedfactor_matrix_symC(matrix(c(1,.5, 2,1.6, 1,0),ncol=2,byrow=TRUE), 26 | c(1.5,1.8), 1, 1-1e-6) 27 | corr_orderedfactor_matrix_symC(matrix(c(0,0,0,1,0,0,0,2,0,0,0,3,0,0,0,4), 28 | ncol=4, byrow=TRUE), 29 | c(0.101, -0.714, 0.114, -0.755, 0.117, -0.76, 0.116, -0.752), 30 | 4, 1-1e-6) * 6.85 31 | } 32 | -------------------------------------------------------------------------------- /man/corr_gauss_matrix_armaC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{corr_gauss_matrix_armaC} 4 | \alias{corr_gauss_matrix_armaC} 5 | \title{Correlation Gaussian matrix in C using Armadillo} 6 | \usage{ 7 | corr_gauss_matrix_armaC(x, y, theta, s2 = 1) 8 | } 9 | \arguments{ 10 | \item{x}{Matrix x} 11 | 12 | \item{y}{Matrix y, must have same number of columns as x} 13 | 14 | \item{theta}{Theta vector} 15 | 16 | \item{s2}{Variance to multiply matrix by} 17 | } 18 | \value{ 19 | Correlation matrix 20 | } 21 | \description{ 22 | 20-25% faster than Rcpp version. 23 | } 24 | \examples{ 25 | corr_gauss_matrix_armaC(matrix(c(1,0,0,1),2,2),matrix(c(1,0,1,1),2,2),c(1,1)) 26 | 27 | x1 <- matrix(runif(100*6), nrow=100, ncol=6) 28 | x2 <- matrix(runif(1e4*6), ncol=6) 29 | th <- runif(6) 30 | t1 <- corr_gauss_matrixC(x1, x2, th) 31 | t2 <- corr_gauss_matrix_armaC(x1, x2, th) 32 | identical(t1, t2) 33 | # microbenchmark::microbenchmark(corr_gauss_matrixC(x1, x2, th), 34 | # corr_gauss_matrix_armaC(x1, x2, th)) 35 | } 36 | -------------------------------------------------------------------------------- /man/Gaussian_hessianC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Gaussian_hessian.R 3 | \name{Gaussian_hessianC} 4 | \alias{Gaussian_hessianC} 5 | \title{Calculate Hessian for a GP with Gaussian correlation} 6 | \usage{ 7 | Gaussian_hessianC(XX, X, Z, Kinv, mu_hat, theta) 8 | } 9 | \arguments{ 10 | \item{XX}{The vector at which to calculate the Hessian} 11 | 12 | \item{X}{The input points} 13 | 14 | \item{Z}{The output values} 15 | 16 | \item{Kinv}{The inverse of the correlation matrix} 17 | 18 | \item{mu_hat}{Estimate of mu} 19 | 20 | \item{theta}{Theta parameters for the correlation} 21 | } 22 | \value{ 23 | Matrix, the Hessian at XX 24 | } 25 | \description{ 26 | Calculate Hessian for a GP with Gaussian correlation 27 | } 28 | \examples{ 29 | set.seed(0) 30 | n <- 40 31 | x <- matrix(runif(n*2), ncol=2) 32 | f1 <- function(a) {sin(2*pi*a[1]) + sin(6*pi*a[2])} 33 | y <- apply(x,1,f1) + rnorm(n,0,.01) 34 | gp <- GauPro(x,y, verbose=2, parallel=FALSE);gp$theta 35 | gp$hessian(c(.2,.75), useC=TRUE) # Should be -38.3, -5.96, -5.96, -389.4 as 2x2 matrix 36 | } 37 | -------------------------------------------------------------------------------- /man/Gaussian_hessianR.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Gaussian_hessian.R 3 | \name{Gaussian_hessianR} 4 | \alias{Gaussian_hessianR} 5 | \title{Calculate Hessian for a GP with Gaussian correlation} 6 | \usage{ 7 | Gaussian_hessianR(XX, X, Z, Kinv, mu_hat, theta) 8 | } 9 | \arguments{ 10 | \item{XX}{The vector at which to calculate the Hessian} 11 | 12 | \item{X}{The input points} 13 | 14 | \item{Z}{The output values} 15 | 16 | \item{Kinv}{The inverse of the correlation matrix} 17 | 18 | \item{mu_hat}{Estimate of mu} 19 | 20 | \item{theta}{Theta parameters for the correlation} 21 | } 22 | \value{ 23 | Matrix, the Hessian at XX 24 | } 25 | \description{ 26 | Calculate Hessian for a GP with Gaussian correlation 27 | } 28 | \examples{ 29 | set.seed(0) 30 | n <- 40 31 | x <- matrix(runif(n*2), ncol=2) 32 | f1 <- function(a) {sin(2*pi*a[1]) + sin(6*pi*a[2])} 33 | y <- apply(x,1,f1) + rnorm(n,0,.01) 34 | gp <- GauPro(x,y, verbose=2, parallel=FALSE);gp$theta 35 | gp$hessian(c(.2,.75), useC=FALSE) # Should be -38.3, -5.96, -5.96, -389.4 as 2x2 matrix 36 | } 37 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/master/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | 9 | name: R-CMD-check 10 | 11 | jobs: 12 | R-CMD-check: 13 | runs-on: ubuntu-latest 14 | env: 15 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 16 | R_KEEP_PKG_SOURCE: yes 17 | steps: 18 | - uses: actions/checkout@v2 19 | 20 | - uses: r-lib/actions/setup-r@v2 21 | with: 22 | use-public-rspm: true 23 | 24 | - uses: r-lib/actions/setup-r-dependencies@v2 25 | with: 26 | extra-packages: rcmdcheck 27 | 28 | - uses: r-lib/actions/setup-pandoc@v2 29 | 30 | - name: Install dependencies 31 | run: | 32 | install.packages(c("remotes"),dependencies=TRUE) 33 | remotes::install_github("collinerickson/mixopt") 34 | shell: Rscript {0} 35 | 36 | - uses: r-lib/actions/check-r-package@v2 37 | -------------------------------------------------------------------------------- /scratch/parametersvsadaptive.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Parameter vs adaptive" 3 | author: "Collin Erickson" 4 | date: "July 29, 2016" 5 | output: html_document 6 | --- 7 | 8 | 9 | ```{r} 10 | set.seed(0) 11 | x <- c(0,.1, .3,.5,.8, 1) 12 | x <- c(0,.1,.2,.3,1) 13 | f <- function(x) (sin(2*pi*x)) + rnorm(length(x), 0,.05) 14 | f <- function (x) (2*x) %%1 15 | f <- function(xx) sin(10*pi*xx) 16 | y <- f(x) 17 | plot(x,y) 18 | ``` 19 | 20 | ```{r} 21 | library(GauPro) 22 | gp <- GauPro$new() 23 | gp$fit(X=x, Z=y) 24 | gp$all_update() 25 | gp$cool1Dplot() 26 | ``` 27 | 28 | ```{r} 29 | thetas <- c(2,3,4,5,6,7,8,9,10) 30 | preds <- c() 31 | predat <- .5 32 | maxvarat <- c() 33 | for (theta in thetas) { 34 | gp$theta <- theta 35 | gp$update_params() 36 | pred <- gp$pred(predat)$mean 37 | preds <- c(preds, pred) 38 | mv1 <- optimize(function(xx) {gp$pred(xx)$s2}, c(.4,.78), maximum = T)$max 39 | maxvarat <- c(maxvarat, mv1) 40 | } 41 | preds 42 | maxvarat 43 | #curve(Vectorize(function(th){gp$theta <- th;gp$update_params();optimize(function(xx) {gp$pred(xx)$s2}, c(.4,.78), maximum = T)$max}),.5,30) 44 | curve(sapply(x,tc),.1,10) 45 | ``` 46 | 47 | -------------------------------------------------------------------------------- /man/corr_latentfactor_matrix_symC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{corr_latentfactor_matrix_symC} 4 | \alias{corr_latentfactor_matrix_symC} 5 | \title{Correlation Latent factor matrix in C (symmetric)} 6 | \usage{ 7 | corr_latentfactor_matrix_symC(x, theta, xindex, latentdim, offdiagequal) 8 | } 9 | \arguments{ 10 | \item{x}{Matrix x} 11 | 12 | \item{theta}{Theta vector} 13 | 14 | \item{xindex}{Index to use} 15 | 16 | \item{latentdim}{Number of latent dimensions} 17 | 18 | \item{offdiagequal}{What to set off-diagonal values with matching values to.} 19 | } 20 | \value{ 21 | Correlation matrix 22 | } 23 | \description{ 24 | Correlation Latent factor matrix in C (symmetric) 25 | } 26 | \examples{ 27 | corr_latentfactor_matrix_symC(matrix(c(1,.5, 2,1.6, 1,0),ncol=2,byrow=TRUE), 28 | c(1.5,1.8), 1, 1, 1-1e-6) 29 | corr_latentfactor_matrix_symC(matrix(c(0,0,0,1,0,0,0,2,0,0,0,3,0,0,0,4), 30 | ncol=4, byrow=TRUE), 31 | c(0.101, -0.714, 0.114, -0.755, 0.117, -0.76, 0.116, -0.752), 32 | 4, 2, 1-1e-6) * 6.85 33 | } 34 | -------------------------------------------------------------------------------- /scratch/scratch_comparer.R: -------------------------------------------------------------------------------- 1 | library(comparer) 2 | n <- 30 3 | d <- 2 4 | f <- TestFunctions::banana 5 | x <- matrix(runif(n*d), n,d) 6 | y <- f(x) 7 | nn <- 300 8 | xx <- matrix(runif(nn*d), nn,d) 9 | yy <- f(xx) 10 | mbc(Gaussian, Matern32, Matern52, evaluator={GauPro_kernel_model$new(X=x,Z=y,kernel=.)$predict(xx)}, target=yy) 11 | mbc(Gaussian, Matern32, Matern52, 12 | evaluator={GauPro_kernel_model$new(X=x,Z=y,kernel=.)$predict(xx)}, 13 | target="yy", inputi={xx <- matrix(runif(nn*d), nn,d);yy <- f(xx)}) 14 | mbc(Gaussian, Matern32, Matern52, 15 | evaluator={GauPro_kernel_model$new(X=x,Z=y,kernel=.)$predict(xx, se=T)}, 16 | target="yy", inputi={xx <- matrix(runif(nn*d), nn,d);yy <- f(xx)}, metric=c('mis90', 'rmse')) 17 | # Use different kinds of model 18 | mbc(KGauss=GauPro_kernel_model$new(X=x,Z=y,kernel=Gaussian), 19 | Kmat32=GauPro_kernel_model$new(X=x,Z=y,kernel=Matern32), 20 | Kmat52=GauPro_kernel_model$new(X=x,Z=y,kernel=Matern52), 21 | GPG=GauPro_Gauss$new(X=x,Z=y), GPGLOO=GauPro_Gauss_LOO$new(X=x,Z=y), times=5, 22 | inputi={x <- matrix(runif(n*d), n,d);y <- f(x)}, 23 | post=function(x)x$predict(xx,se=T), target=yy, metric=c("rmse","mis90")) 24 | 25 | -------------------------------------------------------------------------------- /scratch/scratch_hessian.R: -------------------------------------------------------------------------------- 1 | # 1D hessian test 2 | n <- 12 3 | x <- matrix(seq(0,1,length.out = n), ncol=1) 4 | y <- sin(2*pi*x) + rnorm(n,0,1e-2) 5 | #y <- sqrt(x)-x 6 | y <- (2*x) %%1 7 | plot(x,y) 8 | gp <- GauPro(X=x, Z=y) 9 | curve(gp$pred(x));points(x,y) 10 | curve(gp$pred(x)+2*gp$pred(x,T)$se,col=2,add=T);curve(gp$pred(x)-2*gp$pred(x,T)$se,col=2,add=T) 11 | gp$hessian(.35, useC=F) 12 | gp$hessian(.35, useC=T) 13 | 14 | 15 | # 2D surface to test Hessian 16 | n <- 40 17 | x <- matrix(runif(n*2), ncol=2) 18 | f1 <- function(a) {sin(2*pi*a[1]) + sin(6*pi*a[2])} 19 | #f1 <- TestFunctions::branin 20 | #f1 <- TestFunctions::RFF_get(D=2) 21 | y <- apply(x,1,f1) + rnorm(n,0,.01) 22 | system.time(cf::cf_data(x,y)) 23 | gp <- GauPro(x,y, verbose=2);gp$theta 24 | system.time(cf::cf_func(gp$pred, pts=x)) 25 | # They give same numerical answer 26 | gp$hessian(c(.2,.75)) 27 | gp$hessian(c(.2,.75), useC=F) 28 | gp$hessian(c(.2,.75), useC=T) 29 | numDeriv::hessian(gp$predict, c(.2,.75)) 30 | 31 | max_eigen <- function(x) { 32 | evals <- eigen(gp$hessian(x), symmetric = T, only.values = T) 33 | maxeval <- evals$val[which.max(abs(evals$val))] 34 | maxeval 35 | } 36 | cf::cf(max_eigen, batchmax=1, n=40) 37 | -------------------------------------------------------------------------------- /R/trend_base.R: -------------------------------------------------------------------------------- 1 | # Trend functions should implement: 2 | # mu prediction for new matrix 3 | # update_params 4 | # get_optim_functions: return optim.func, optim.grad, optim.fngr 5 | # param_optim_lower - lower bound of params 6 | # param_optim_upper - upper 7 | # param_optim_start - current param values 8 | # param_optim_start0 - some central param values that can be used for optimization restarts 9 | # param_optim_jitter - how to jitter params in optimization 10 | 11 | 12 | 13 | 14 | #' Trend R6 class 15 | #' 16 | #' @docType class 17 | #' @importFrom R6 R6Class 18 | # @export 19 | #' @useDynLib GauPro, .registration = TRUE 20 | #' @importFrom Rcpp evalCpp 21 | #' @importFrom stats optim 22 | # @keywords data, kriging, Gaussian process, regression 23 | #' @return Object of \code{\link[R6]{R6Class}} with methods for fitting GP model. 24 | #' @format \code{\link[R6]{R6Class}} object. 25 | #' @field D Number of input dimensions of data 26 | #' @examples 27 | #' #k <- GauPro_trend$new() 28 | GauPro_trend <- R6::R6Class( 29 | classname = "GauPro_trend", 30 | public = list( 31 | # Gradient is -2 * t(yminusmu) %*% Siginv %*% du/db 32 | D = NULL 33 | ), 34 | private = list( 35 | 36 | ) 37 | ) 38 | -------------------------------------------------------------------------------- /man/kernel_orderedFactor_dC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{kernel_orderedFactor_dC} 4 | \alias{kernel_orderedFactor_dC} 5 | \title{Derivative of covariance matrix of X with respect to kernel 6 | parameters for the Ordered Factor Kernel} 7 | \usage{ 8 | kernel_orderedFactor_dC( 9 | x, 10 | pf, 11 | C_nonug, 12 | s2_est, 13 | p_est, 14 | lenparams_D, 15 | s2_nug, 16 | xindex, 17 | nlevels, 18 | s2 19 | ) 20 | } 21 | \arguments{ 22 | \item{x}{Matrix x} 23 | 24 | \item{pf}{pf vector} 25 | 26 | \item{C_nonug}{cov mat without nugget} 27 | 28 | \item{s2_est}{whether s2 is being estimated} 29 | 30 | \item{p_est}{Whether theta/beta is being estimated} 31 | 32 | \item{lenparams_D}{Number of parameters the derivative is being calculated for} 33 | 34 | \item{s2_nug}{s2 times the nug} 35 | 36 | \item{xindex}{Which column of x is the indexing variable} 37 | 38 | \item{nlevels}{Number of levels} 39 | 40 | \item{s2}{Value of s2} 41 | } 42 | \value{ 43 | Correlation matrix 44 | } 45 | \description{ 46 | Derivative of covariance matrix of X with respect to kernel 47 | parameters for the Ordered Factor Kernel 48 | } 49 | -------------------------------------------------------------------------------- /scratch/ExampleForArwed.R: -------------------------------------------------------------------------------- 1 | # Install from my GitHub for most up to date 2 | # devtools::install_github("CollinErickson/GauPro") 3 | 4 | # Make fake data 5 | n <- 20 6 | x <- runif(n) 7 | y <- 1.4*x^1.2 - 2.8*sin(2*x) + rnorm(n, 0, 1) 8 | plot(x,y) 9 | 10 | 11 | # Set parameters 12 | lambda <- 1/4 13 | tau_sq <- 4 14 | nug <- 1 15 | 16 | # Load library 17 | library(GauPro) 18 | # Mean/trend function is 0 19 | gp_mean <- GauPro::trend_0$new() 20 | # Kernel with fixed parameters 21 | gp_kernel <- GauPro::Gaussian$new(D=1, 22 | beta=log(1/lambda, 10), beta_est=F, 23 | s2=tau_sq, s2_est=F) 24 | # Fit GP. If nugget is set, there's nothing to estimate 25 | gp <- GauPro::GauPro_kernel_model$new(trend=gp_mean, 26 | kernel=gp_kernel, 27 | X=matrix(x, ncol=1), 28 | Z=y, 29 | nug=nug, nug.est=F) 30 | gp$nug 31 | 32 | # Plot what samples look like 33 | gp$cool1Dplot() 34 | 35 | # Get samples at specific points 36 | # This does 5 samples at 100 points from 0 to 1. 37 | gp$sample(XX=matrix(seq(0, 1, l=100), ncol=1), 5) 38 | -------------------------------------------------------------------------------- /man/kernel_latentFactor_dC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{kernel_latentFactor_dC} 4 | \alias{kernel_latentFactor_dC} 5 | \title{Derivative of covariance matrix of X with respect to kernel 6 | parameters for the Latent Factor Kernel} 7 | \usage{ 8 | kernel_latentFactor_dC( 9 | x, 10 | pf, 11 | C_nonug, 12 | s2_est, 13 | p_est, 14 | lenparams_D, 15 | s2_nug, 16 | latentdim, 17 | xindex, 18 | nlevels, 19 | s2 20 | ) 21 | } 22 | \arguments{ 23 | \item{x}{Matrix x} 24 | 25 | \item{pf}{pf vector} 26 | 27 | \item{C_nonug}{cov mat without nugget} 28 | 29 | \item{s2_est}{whether s2 is being estimated} 30 | 31 | \item{p_est}{Whether theta/beta is being estimated} 32 | 33 | \item{lenparams_D}{Number of parameters the derivative is being calculated for} 34 | 35 | \item{s2_nug}{s2 times the nug} 36 | 37 | \item{latentdim}{Number of latent dimensions} 38 | 39 | \item{xindex}{Which column of x is the indexing variable} 40 | 41 | \item{nlevels}{Number of levels} 42 | 43 | \item{s2}{Value of s2} 44 | } 45 | \value{ 46 | Correlation matrix 47 | } 48 | \description{ 49 | Derivative of covariance matrix of X with respect to kernel 50 | parameters for the Latent Factor Kernel 51 | } 52 | -------------------------------------------------------------------------------- /src/corr_gauss_dCdX.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | 4 | //' Correlation Gaussian matrix gradient in C using Armadillo 5 | //' @param XX Matrix XX to get gradient for 6 | //' @param X Matrix X GP was fit to 7 | //' @param theta Theta vector 8 | //' @param s2 Variance parameter 9 | //' @return 3-dim array of correlation derivative 10 | //' @examples 11 | //' # corr_gauss_dCdX(matrix(c(1,0,0,1),2,2),c(1,1)) 12 | //' @export 13 | // [[Rcpp::export]] 14 | arma::cube corr_gauss_dCdX(arma::mat XX, arma::mat X, arma::vec theta, double s2) { 15 | int nn = XX.n_rows; 16 | int d = XX.n_cols; 17 | int n = X.n_rows; 18 | arma::cube dC_dx(nn, d, n); 19 | double tsum = 0; 20 | for (int i = 0; i < nn; i++) { 21 | for (int j = 0; j < d; j++) { 22 | for (int k = 0; k < n; k++) { 23 | // dC_dx(i, j, k) = -2 * theta(j) * (XX(i, j) - X(k, j)) * s2 * exp(-sum(theta * (XX(i,) - X(k,)) ^ 2)); 24 | tsum = 0; 25 | for (int l = 0; l < d; l++) { 26 | // sum(theta * (XX(i,) - X(k,)) ^ 2) 27 | tsum += theta(l) * pow(XX(i,l) - X(k,l), 2); 28 | } 29 | dC_dx(i, j, k) = -2 * theta(j) * (XX(i, j) - X(k, j)) * s2 * exp(-tsum); 30 | } 31 | } 32 | } 33 | 34 | return dC_dx; 35 | } 36 | 37 | -------------------------------------------------------------------------------- /scratch/scratch_kernel_check_useC.R: -------------------------------------------------------------------------------- 1 | compM <- comparer::mbc( 2 | times=10, 3 | R={ 4 | useCM <<- F 5 | gp1 <- GauPro_kernel_model$new( 6 | X=Xmat, Z=y, verbose=3, kernel=Exponential 7 | ) 8 | gp1$deviance() 9 | }, 10 | C={ 11 | useCM <<- T 12 | gp1 <- GauPro_kernel_model$new( 13 | X=Xmat, Z=y, verbose=3, kernel=Exponential 14 | ) 15 | gp1$deviance() 16 | } 17 | ) 18 | compM 19 | 20 | compMb <- comparer::mbc( 21 | times=5, 22 | R={ 23 | useCM <<- F 24 | gp1 <- GauPro_kernel_model$new( 25 | X=Xmat, Z=y, verbose=3, 26 | kernel=IgnoreIndsKernel$new(ignoreinds = 3:4, Exponential$new(D=2)) * 27 | LatentFactorKernel$new(D=4, nlevels = 2, latentdim = 1, xindex = 3) * 28 | LatentFactorKernel$new(D=4, nlevels = 4, latentdim = 2, xindex = 4) 29 | ) 30 | gp1$deviance() 31 | }, 32 | C={ 33 | useCM <<- T 34 | gp1 <- GauPro_kernel_model$new( 35 | X=Xmat, Z=y, verbose=3, 36 | kernel=IgnoreIndsKernel$new(ignoreinds = 3:4, Exponential$new(D=2)) * 37 | LatentFactorKernel$new(D=4, nlevels = 2, latentdim = 1, xindex = 3) * 38 | LatentFactorKernel$new(D=4, nlevels = 4, latentdim = 2, xindex = 4) 39 | ) 40 | gp1$deviance() 41 | } 42 | ) 43 | compMb 44 | -------------------------------------------------------------------------------- /src/gradfuncarray.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | 4 | 5 | //' Calculate gradfunc in optimization to speed up. 6 | //' NEEDS TO APERM dC_dparams 7 | //' Doesn't need to be exported, should only be useful in functions. 8 | //' @param dC_dparams Derivative matrix for covariance function wrt kernel parameters 9 | //' @param Cinv Inverse of covariance matrix 10 | //' @param Cinv_yminusmu Vector that is the inverse of C times y minus the mean. 11 | //' @return Vector, one value for each parameter 12 | //' @examples 13 | //' gradfuncarray(array(dim=c(2,4,4), data=rnorm(32)), matrix(rnorm(16),4,4), rnorm(4)) 14 | //' @export 15 | // [[Rcpp::export]] 16 | arma::vec gradfuncarray(arma::cube dC_dparams, arma::mat Cinv, arma::vec Cinv_yminusmu) { 17 | int d1 = dC_dparams.n_rows; 18 | int d2 = dC_dparams.n_cols; 19 | int d3 = dC_dparams.n_slices; 20 | arma::vec out(d1); 21 | double t1; 22 | double t2; 23 | for (int i = 0; i < d1; i++) { 24 | t1 = 0; 25 | t2 = 0; 26 | for (int j = 0; j < d2; j++) { 27 | for (int k = 0; k < d3; k++) { 28 | t1 += Cinv(j, k) * dC_dparams(i, j, k); 29 | t2 += Cinv_yminusmu(j) * dC_dparams(i, j, k) * Cinv_yminusmu(k); 30 | } 31 | } 32 | out(i) = t1 - t2; 33 | } 34 | return out; 35 | } 36 | -------------------------------------------------------------------------------- /scratch/scratch_plot_LOO.R: -------------------------------------------------------------------------------- 1 | ploo <- gp$pred_LOO(se.fit = T) 2 | gp$Z 3 | loodf <- cbind(ploo, Z=gp$Z) 4 | loodf 5 | loodf$upper <- loodf$fit + 1.96 * loodf$se.fit 6 | loodf$lower <- loodf$fit - 1.96 * loodf$se.fit 7 | ggplot(loodf, aes(fit, Z)) + 8 | stat_smooth() + 9 | geom_abline(slope=1, intercept=0, color="red") + 10 | geom_segment(aes(x=lower, xend=upper, yend=Z), color="green") + 11 | geom_point() 12 | # Add text with coverage, R-sq 13 | coveragevec <- with(loodf, upper >= Z & lower <= Z) 14 | coverage <- mean(coveragevec) 15 | coverage 16 | rsq <- with(loodf, 1 - (sum((fit-Z)^2)) / (sum((mean(Z)-Z)^2))) 17 | rsq 18 | ggplot(loodf, aes(fit, Z)) + 19 | stat_smooth() + 20 | geom_abline(slope=1, intercept=0, color="red") + 21 | geom_segment(aes(x=lower, xend=upper, yend=Z), color="green") + 22 | geom_point() + 23 | # geom_text(x=min(loodf$fit), y=max(loodf$Z), label="abc") + 24 | geom_text(x=-Inf, y=Inf, label=paste("Coverage:", signif(coverage,5)), hjust=0, vjust=1) + 25 | geom_text(x=-Inf, y=Inf, label=paste("R-sq: ", signif(rsq,5)), hjust=0, vjust=2.2) + 26 | # geom_text(x=Inf, y=-Inf, label="def", hjust=1, vjust=0) 27 | xlab("Predicted values (fit)") + 28 | ylab("Actual values (Z)") + 29 | ggtitle("Calibration of leave-one-out (LOO) predictions") 30 | -------------------------------------------------------------------------------- /R/find_kernel_factor_dims.R: -------------------------------------------------------------------------------- 1 | # Change this so Factor/Latent are one group and Ordered are other 2 | find_kernel_factor_dims <- function (kern) { 3 | if (("GauPro_kernel_product" %in% class(kern)) || ("GauPro_kernel_sum" %in% class(kern))) { 4 | return(c(find_kernel_factor_dims(kern$k1), 5 | find_kernel_factor_dims(kern$k2))) 6 | } 7 | if (("GauPro_kernel_FactorKernel" %in% class(kern)) || 8 | ("GauPro_kernel_LatentFactorKernel" %in% class(kern)) || 9 | ("GauPro_kernel_OrderedFactorKernel" %in% class(kern)) || 10 | ("GauPro_kernel_GowerFactorKernel" %in% class(kern))) { 11 | return((c(kern$xindex, kern$nlevels))) 12 | } 13 | if (("GauPro_kernel_IgnoreInds" %in% class(kern))) { 14 | t1 <- find_kernel_factor_dims(kern$kernel) 15 | if (is.null(t1)) { 16 | return(NULL) 17 | } 18 | for (i in 1:(length(t1)/2)) { 19 | # t1[2*i-1] <- t1[2*i-1] + sum(t1[2*i-1] <= kern$ignoreinds) 20 | t1[2*i-1] <- setdiff((1:(t1[1]+max(kern$ignoreinds))), 21 | kern$ignoreinds)[t1[2*i-1]] 22 | } 23 | return(t1) 24 | } 25 | return(NULL) 26 | } 27 | if (F) { 28 | k1 <- Gaussian$new(D=2) 29 | find_kernel_factor_dims(k1) 30 | k1 <- OrderedFactorKernel$new(D=2, xindex = 2, nlevels = 3) 31 | find_kernel_factor_dims(k1) 32 | 33 | } 34 | -------------------------------------------------------------------------------- /man/corr_orderedfactor_matrixmatrixC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{corr_orderedfactor_matrixmatrixC} 4 | \alias{corr_orderedfactor_matrixmatrixC} 5 | \title{Correlation ordered factor matrix in C (symmetric)} 6 | \usage{ 7 | corr_orderedfactor_matrixmatrixC(x, y, theta, xindex, offdiagequal) 8 | } 9 | \arguments{ 10 | \item{x}{Matrix x} 11 | 12 | \item{y}{Matrix y} 13 | 14 | \item{theta}{Theta vector} 15 | 16 | \item{xindex}{Index to use} 17 | 18 | \item{offdiagequal}{What to set off-diagonal values with matching values to.} 19 | } 20 | \value{ 21 | Correlation matrix 22 | } 23 | \description{ 24 | Correlation ordered factor matrix in C (symmetric) 25 | } 26 | \examples{ 27 | corr_orderedfactor_matrixmatrixC(matrix(c(1,.5, 2,1.6, 1,0),ncol=2,byrow=TRUE), 28 | matrix(c(2,1.6, 1,0),ncol=2,byrow=TRUE), 29 | c(1.5,1.8), 1, 1-1e-6) 30 | corr_orderedfactor_matrixmatrixC(matrix(c(0,0,0,1,0,0,0,2,0,0,0,3,0,0,0,4), 31 | ncol=4, byrow=TRUE), 32 | matrix(c(0,0,0,2,0,0,0,4,0,0,0,1), 33 | ncol=4, byrow=TRUE), 34 | c(0.101, -0.714, 0.114, -0.755, 0.117, -0.76, 0.116, -0.752), 35 | 4, 1-1e-6) * 6.85 36 | } 37 | -------------------------------------------------------------------------------- /scratch/FactorSpeedTest.R: -------------------------------------------------------------------------------- 1 | # Ordered is way slower than latent 2 | 3 | library(dplyr) 4 | n <- 163*2 5 | # Non-ordered data 6 | xdf <- tibble( 7 | a=rnorm(n), 8 | b=runif(n), 9 | c=sample(letters[1:5], n, T), 10 | d=factor(sample(letters[6:9], n, T)), 11 | e=rexp(n), 12 | # f=rnorm(n), 13 | z=a*b + a^2*ifelse(c %in% c('a', 'b'), 1, .5) + 14 | e*ifelse(d %in% c('g','h'), 1, -1) + 15 | ifelse(paste0(d,e) %in% c('af', 'ah', 'cf', 'cg', 'ci'),4,0) + 16 | rnorm(n, 1e-3) 17 | ) 18 | # Ordered data 19 | xdf <- tibble( 20 | a=rnorm(n), 21 | b=runif(n), 22 | c=sample(letters[1:5], n, T), 23 | d=ordered(sample(letters[6:9], n, T)), 24 | e=rexp(n), 25 | # f=rnorm(n), 26 | z=a*b + a^2*ifelse(c %in% c('a', 'b'), 1, .5) + 27 | e*ifelse(d %in% c('g','h'), 1, -1) + 28 | ifelse(paste0(d,e) %in% c('af', 'ah', 'cf', 'cg', 'ci'),4,0) + 29 | rnorm(n, 1e-3) 30 | ) 31 | 32 | # Time fit 33 | system.time(expect_error(gpdf <- GauPro_kernel_model$new(z ~ ., data=xdf, kernel='gauss'), NA)) 34 | # system.time(expect_error(gpdf <- GauPro_kernel_model$new(z ~ ., data=xdf, kernel='matern52'), NA)) 35 | 36 | # Latent 37 | # .83, 1.11 38 | # Ordered 39 | # 15.3, 12.7 40 | # Ordered after adding k 41 | # 5.0, 3.0, 4.9 42 | # After adding dc_dparams 43 | # 1.4, 1.8, 1.1, 1.0, 1.5, 1.2 44 | # .7, .75, .83, .77 45 | 46 | # pv shows most of time is in k/kone since it does outer 47 | -------------------------------------------------------------------------------- /man/corr_latentfactor_matrixmatrixC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{corr_latentfactor_matrixmatrixC} 4 | \alias{corr_latentfactor_matrixmatrixC} 5 | \title{Correlation Latent factor matrix in C (symmetric)} 6 | \usage{ 7 | corr_latentfactor_matrixmatrixC(x, y, theta, xindex, latentdim, offdiagequal) 8 | } 9 | \arguments{ 10 | \item{x}{Matrix x} 11 | 12 | \item{y}{Matrix y} 13 | 14 | \item{theta}{Theta vector} 15 | 16 | \item{xindex}{Index to use} 17 | 18 | \item{latentdim}{Number of latent dimensions} 19 | 20 | \item{offdiagequal}{What to set off-diagonal values with matching values to.} 21 | } 22 | \value{ 23 | Correlation matrix 24 | } 25 | \description{ 26 | Correlation Latent factor matrix in C (symmetric) 27 | } 28 | \examples{ 29 | corr_latentfactor_matrixmatrixC(matrix(c(1,.5, 2,1.6, 1,0),ncol=2,byrow=TRUE), 30 | matrix(c(2,1.6, 1,0),ncol=2,byrow=TRUE), 31 | c(1.5,1.8), 1, 1, 1-1e-6) 32 | corr_latentfactor_matrixmatrixC(matrix(c(0,0,0,1,0,0,0,2,0,0,0,3,0,0,0,4), 33 | ncol=4, byrow=TRUE), 34 | matrix(c(0,0,0,2,0,0,0,4,0,0,0,1), 35 | ncol=4, byrow=TRUE), 36 | c(0.101, -0.714, 0.114, -0.755, 0.117, -0.76, 0.116, -0.752), 37 | 4, 2, 1-1e-6) * 6.85 38 | } 39 | -------------------------------------------------------------------------------- /man/GauPro_trend.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/trend_base.R 3 | \docType{class} 4 | \name{GauPro_trend} 5 | \alias{GauPro_trend} 6 | \title{Trend R6 class} 7 | \format{ 8 | \code{\link[R6]{R6Class}} object. 9 | } 10 | \value{ 11 | Object of \code{\link[R6]{R6Class}} with methods for fitting GP model. 12 | } 13 | \description{ 14 | Trend R6 class 15 | 16 | Trend R6 class 17 | } 18 | \examples{ 19 | #k <- GauPro_trend$new() 20 | } 21 | \section{Public fields}{ 22 | \if{html}{\out{
}} 23 | \describe{ 24 | \item{\code{D}}{Number of input dimensions of data} 25 | } 26 | \if{html}{\out{
}} 27 | } 28 | \section{Methods}{ 29 | \subsection{Public methods}{ 30 | \itemize{ 31 | \item \href{#method-GauPro_trend-clone}{\code{GauPro_trend$clone()}} 32 | } 33 | } 34 | \if{html}{\out{
}} 35 | \if{html}{\out{}} 36 | \if{latex}{\out{\hypertarget{method-GauPro_trend-clone}{}}} 37 | \subsection{Method \code{clone()}}{ 38 | The objects of this class are cloneable with this method. 39 | \subsection{Usage}{ 40 | \if{html}{\out{
}}\preformatted{GauPro_trend$clone(deep = FALSE)}\if{html}{\out{
}} 41 | } 42 | 43 | \subsection{Arguments}{ 44 | \if{html}{\out{
}} 45 | \describe{ 46 | \item{\code{deep}}{Whether to make a deep clone.} 47 | } 48 | \if{html}{\out{
}} 49 | } 50 | } 51 | } 52 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: GauPro 2 | Type: Package 3 | Title: Gaussian Process Fitting 4 | Version: 0.2.17.9000 5 | Authors@R: person(given = "Collin", 6 | family = "Erickson", 7 | role = c("aut", "cre"), 8 | email = "collinberickson@gmail.com") 9 | Maintainer: Collin Erickson 10 | Description: Fits a Gaussian process model to data. Gaussian processes 11 | are commonly used in computer experiments to fit an interpolating model. 12 | The model is stored as an 'R6' object and can be easily updated with new 13 | data. There are options to run in parallel, and 'Rcpp' 14 | has been used to speed up calculations. 15 | For more info about Gaussian process software, see Erickson et al. (2018) 16 | . 17 | License: GPL-3 18 | LinkingTo: Rcpp, RcppArmadillo 19 | Imports: 20 | ggplot2, 21 | Rcpp, 22 | R6, 23 | lbfgs 24 | RoxygenNote: 7.3.2 25 | Depends: 26 | mixopt (> 0.1.0), 27 | numDeriv, 28 | rmarkdown, 29 | tidyr 30 | Suggests: 31 | ContourFunctions, 32 | dplyr, 33 | ggrepel, 34 | gridExtra, 35 | knitr, 36 | lhs, 37 | MASS, 38 | microbenchmark, 39 | rlang, 40 | splitfngr, 41 | testthat, 42 | testthatmulti 43 | VignetteBuilder: knitr 44 | URL: https://github.com/CollinErickson/GauPro 45 | BugReports: https://github.com/CollinErickson/GauPro/issues 46 | Encoding: UTF-8 47 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | I received an email from Brian Ripley on 2025-11-13 to fix the issues on 2 | https://cran.r-project.org/web/checks/check_results_GauPro.html before 3 | 2025-11-27. 4 | It was one test that failed on multiple systems. 5 | I made changes to tests to avoid the error. 6 | 7 | I submitted a version on 2025-11-18 that was rejected due to a documentation 8 | error. I have fixed it. 9 | 10 | 11 | ## Test environments 12 | * local Windows 11 install, R 4.5.2 13 | * R-hub builder (multiple) 14 | * Ubuntu via GitHub Actions 15 | * Win-builder (devel and release) 16 | * Mac-builder 17 | 18 | ## R CMD check results 19 | 20 | (Note to self: check Rhub with rhub::rhub_check(), then 1,3,5,20,22,30) 21 | 22 | * local Windows 11 (11/19/25): 0 errors/warnings/notes 23 | 24 | * local Windows 11, _R_CHECK_DEPENDS_ONLY_=TRUE (11/19/25): 0 errors/warnings/notes 25 | 26 | * GitHub Actions, Ubuntu (11/19/25): OK 27 | 28 | * R-Hub 29 | intel (11/19/25): OK 30 | mkl (11/19/25): OK 31 | linux (R-devel) (11/19/25): OK 32 | macos (R-devel) (11/19/25): OK 33 | ubuntu-release (11/19/25): 1 NOTE for slow test 34 | windows (R-devel) (11/19/25): OK 35 | 36 | * Win-Builder, devel (11/19/25): OK 37 | 38 | * Win-Builder, release (11/19/25): OK 39 | 40 | * macOS builder (11/19/25): OK 41 | 42 | ## Downstream dependencies 43 | 44 | * comparer: This is another one of my packages. I checked it on my 45 | laptop and it was OK. The only code change to this package was a test, so it 46 | shouldn't affect anything else. 47 | -------------------------------------------------------------------------------- /scratch/scratch_kernel_model_LOO2.R: -------------------------------------------------------------------------------- 1 | # LOO test for kernel model 2 | set.seed(0) 3 | n <- 8 4 | x <- matrix(seq(0,1,length.out = n), ncol=1) 5 | f <- Vectorize(function(x) {sin(2*pi*x) + .5*sin(4*pi*x) +rnorm(1,0,.03)}) 6 | y <- f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 7 | #y[5] <- -.6 8 | gp <- GauPro_Gauss_LOO$new(X=x, Z=y, verbose=10, nug.est=T) 9 | gp <- GauPro_kernel_model_LOO$new(X=x, Z=y, verbose=10, nug.est=T, kernel=Matern52) 10 | gp$plot1D() 11 | gp$use_LOO <- F 12 | gp$plot1D() 13 | 14 | 15 | 16 | d <- 3 17 | f <- TestFunctions::beambending 18 | n <- 10*d 19 | X <- (lhs::maximinLHS(n=n,k=d)) 20 | Z <- f(X) 21 | nn <- 1e4 22 | XX <- matrix(runif(nn*d),ncol=d) 23 | ZZ <- f(XX) 24 | gp1 <- GauPro_kernel_model$new(X=X, Z=Z, verbose=10, nug.est=T, kernel=Matern52) 25 | gp2 <- GauPro_kernel_model_LOO$new(X=X, Z=Z, verbose=10, nug.est=T, kernel=Matern52) 26 | p1 <- gp1$predict(XX, se=T) 27 | p2 <- gp2$predict(XX, se=T) 28 | plot(abs(ZZ-p1$mean), p1$se);abline(a=0,b=1,col=2) 29 | plot(abs(ZZ-p2$mean), p2$se);abline(a=0,b=1,col=2) 30 | 31 | tc <- comparer::mbc(gp1=GauPro_kernel_model$new(X=X, Z=Z, verbose=10, nug.est=T, kernel=Matern52), 32 | gp2=GauPro_kernel_model_LOO$new(X=X, Z=Z, verbose=10, nug.est=T, kernel=Matern52), 33 | inputi={X <- lhs::maximinLHS(n=n,k=d);Z <- f(X)}, 34 | # targetin=list(XX,ZZ), target="ZZ" 35 | post=function(mod) {mod$predict(XX, se=T)}, target=ZZ, 36 | times=10, metric=c('rmse', 'mis90', 'sr27') 37 | ) 38 | print(tc) 39 | plot(tc) 40 | -------------------------------------------------------------------------------- /scratch/scratch_kernel_model_LOO.R: -------------------------------------------------------------------------------- 1 | 2 | # Check banana again 3 | n <- 40 4 | d <- 2 5 | f1 <- TestFunctions::banana#function(x) {abs(sin(2*pi*x[1]))} 6 | X1 <- MaxPro::MaxProLHD(n=n,p=d, itermax = 10)$Design#t(lhs::maximinLHS(n=d,k=n)) # 7 | # X1 <- matrix(runif(n*d),n,d) 8 | Z1 <- apply(X1,1,f1) * 9.3 # + rnorm(n, 0, 1e-3) 9 | gp <- GauPro_kernel_model_LOO$new(X=X1, Z=Z1, kernel=Exponential) 10 | ContourFunctions::cf(gp$predict, pts=X1) 11 | gp_noLOO <- gp$clone(deep = T); gp_noLOO$use_LOO <- FALSE 12 | ContourFunctions::cf(gp_noLOO$predict, pts=X1) 13 | ContourFunctions::cf(gp$tmod$predict, pts=X1) 14 | # Plot se's 15 | ContourFunctions::cf(function(x) gp$pred(x, se=T)$se, pts=X1, batchmax=Inf) 16 | ContourFunctions::cf(function(x) gp_noLOO$pred(x, se=T)$se, pts=X1, batchmax=Inf) 17 | # See predicted t values 18 | nn <- 1e3 19 | XX <- matrix(runif(nn*d),nn,d) 20 | ZZ <- apply(XX, 1, f1) * 9.3 21 | ploo <- gp$pred(XX, se=T) 22 | tloo <- (ploo$mean - ZZ) / ploo$se 23 | summary(tloo) 24 | pnoloo <- gp_noLOO$pred(XX, se=T) 25 | tnoloo <- (pnoloo$mean - ZZ) / pnoloo$se 26 | summary(tnoloo) 27 | stripchart(list(LOO=tloo,no_LOO=tnoloo)) 28 | ContourFunctions::cf(function(x){z <- apply(x, 1, f1)*9.3; ploo <- gp$pred(x, se=T);tloo <- (ploo$mean - z) / ploo$se;abs(tloo)}, pts=X1, batchmax=Inf) 29 | ContourFunctions::cf(function(x){z <- apply(x, 1, f1)*9.3; ploo <- gp_noLOO$pred(x, se=T);tloo <- (ploo$mean - z) / ploo$se;abs(tloo)}, pts=X1, batchmax=Inf) 30 | qqnorm(tloo) 31 | qqline(tloo) 32 | qqnorm(tnoloo) 33 | qqline(tnoloo) 34 | plot(tloo, gp$tmod$predict(XX)) 35 | -------------------------------------------------------------------------------- /scratch/EGO.R: -------------------------------------------------------------------------------- 1 | #' EGO R6 class 2 | #' 3 | #' @docType class 4 | #' @importFrom R6 R6Class 5 | # @export 6 | #' @useDynLib GauPro, .registration = TRUE 7 | #' @importFrom Rcpp evalCpp 8 | #' @importFrom stats optim 9 | # @keywords optimization, Bayesian optimization 10 | #' @return Object of \code{\link[R6]{R6Class}} with methods for running EGO. 11 | #' @format \code{\link[R6]{R6Class}} object. 12 | #' @examples 13 | #' #e1 <- EGO$new(func=sin, n0=10, n=10, d=1) 14 | EGO <- R6::R6Class( 15 | classname = "EGO", 16 | public = list( 17 | gp = NULL, 18 | func = NULL, 19 | n0 = NULL, 20 | n = NULL, 21 | d = NULL, 22 | X = NULL, 23 | Z = NULL, 24 | initialize = function(func, n0, n, d) { 25 | self$func <- func 26 | self$n0 <- n0 27 | self$n <- n 28 | self$d <- d 29 | 30 | self$initial_run() 31 | self$run() 32 | }, 33 | initial_run = function() { 34 | self$X <- lhs::randomLHS(n=n0, k=d) 35 | self$Z <- apply(self$X, 1, self$func) 36 | self$gp <- GauPro_kernel_model$new(X=X, Z=Z, kernel=kernel) 37 | }, 38 | run = function() { 39 | for (i in 1:n) { 40 | self$run1() 41 | } 42 | }, 43 | run1 = function() { 44 | # Optimize EI with many start points 45 | 46 | # Select best 47 | Xbest 48 | Zbest <- self$func(Xbest) 49 | 50 | # Add to X and Z 51 | self$X <- rbind(self$X, Xbest) 52 | self$Z <- c(self$Z, Zbest) 53 | 54 | # Update model 55 | self$gp$update(Xall=self$X, Zall=self$Z) 56 | } 57 | ) 58 | ) 59 | -------------------------------------------------------------------------------- /scratch/run_time_experiment.R: -------------------------------------------------------------------------------- 1 | flist <- c(TestFunctions::banana, 2 | function(x) {TestFunctions::beambending(x)*1e6}, 3 | TestFunctions::piston, 4 | TestFunctions::borehole) 5 | e1 <- comparer::ffexp$new( 6 | n = c(20, 40, 80, 120, 160, 240, 320, 400, 500), 7 | FD = data.frame( 8 | d = c(2, 3, 7, 8), 9 | fi = 1:length(flist) 10 | ), 11 | k = c('Gaussian', 'Matern32'), 12 | eval_func = function(n, d, fi, k) { 13 | # browser() 14 | cat("\n", n, d, fi, k, "\n") 15 | f <- flist[[fi]] 16 | t1 <- proc.time() 17 | X <- matrix(runif(d*n), ncol=d) 18 | expect_no_warning(Z <- f(X)) 19 | Z <- Z + rnorm(length(Z), 0, range(Z)*1e-4) 20 | gp <- GauPro_kernel_model$new(X, Z, kernel=k) 21 | t2 <- proc.time() 22 | (t2 - t1)[3] 23 | } 24 | ) 25 | e1 26 | e1$run_all(15) 27 | e1$run_for_time(120, 1) #, run_order='shuffle') 28 | e1$run_all(run_order = 'random') 29 | e1 30 | e1$plot() 31 | lm(runtime ~ n + d + k, data=e1$outcleandf) %>% summary 32 | lm(runtime^(1/3) ~ n + d + k, data=e1$outcleandf) %>% summary 33 | lm(log(runtime) ~ n + d + k, data=e1$outcleandf) %>% summary 34 | e1$outcleandf %>% 35 | ggplot(aes(n, log(runtime), color=d, shape=k)) + 36 | geom_point() 37 | e1$outcleandf %>% 38 | ggplot(aes(n, runtime^(1/3), color=d, shape=k)) + 39 | geom_point() 40 | e1$outcleandf$runtime %>% summary 41 | 42 | 43 | 44 | # Can't get it to replace last of line 45 | printfunc <- function() { 46 | cat("abcdef") 47 | Sys.sleep(1) 48 | cat("\r") 49 | # cat("ghi\n") 50 | cat("ghi\033[K\n") 51 | } 52 | printfunc() 53 | -------------------------------------------------------------------------------- /tests/testthat/test_Gauss_GauPro_LOO.R: -------------------------------------------------------------------------------- 1 | context("Test GauPro_Gauss_LOO") 2 | 3 | test_that("GauPro_Gauss_LOO works", { 4 | # Check if LOO predictions match actual on banana function, i.e. check shortcut 5 | set.seed(0) 6 | n <- 80 7 | d <- 2 8 | f1 <- function(x) {abs(sin(2*pi*x[1])) + x[2]^2} 9 | X1 <- matrix(runif(n*d),n,d) 10 | Z1 <- apply(X1,1,f1) * 9.3 # + rnorm(n, 0, 1e-3) 11 | expect_error(gp <- GauPro_Gauss_LOO$new(X=X1, Z=Z1), NA) 12 | # ContourFunctions::cf(gp$predict, pts=X1) 13 | nn <- 1e3 14 | XX <- matrix(runif(nn*d),nn,d) 15 | ZZ <- apply(XX, 1, f1) * 9.3 16 | gp$use_LOO <- T 17 | # Predict 18 | expect_error(ZZhat <- gp$predict(XX, se=F), NA) 19 | expect_error(ZZhat <- gp$predict(XX, se=T), NA) 20 | # Predict mean 21 | expect_error(ZZhat <- gp$predict(XX, se=T), NA) 22 | 23 | expect_error(ZLOO <- gp$pred_LOO(se=T), NA) 24 | gp2 <- gp$clone(deep=T) 25 | loo_means <- numeric(n) 26 | loo_ses <- numeric(n) 27 | for (i in 1:n) { 28 | gpi <- gp$clone(deep=T); 29 | expect_error(gpi$update(Xall=X1[-i,],Zall=Z1[-i], no_update = TRUE), NA) 30 | if (T) { #set mu and s2 back to original values 31 | # This makes differences ~ 1e-15 instead of 1e-4, not sure if it is recommended though 32 | gpi$s2_hat <- gp$s2_hat 33 | gpi$mu_hat <- gp$mu_hat 34 | } 35 | expect_error(gpp <- gpi$predict(X1[i,],se=T), NA) 36 | loo_means[i] <- gpp$me 37 | loo_ses[i] <- gpp$se 38 | } 39 | # cbind(ZLOO$fit, loo_means) 40 | # summary(ZLOO$fit - loo_means) 41 | 42 | expect_true(max(abs(ZLOO$fit - loo_means)) < 1e-8) 43 | }) 44 | -------------------------------------------------------------------------------- /scratch/Welch.R: -------------------------------------------------------------------------------- 1 | tf <- function(x) { 2 | 5*x[12]/(1+x[1]) + 5*(x[4]-x[20])^2 + x[5] + 40*x[19]^3 - 5*x[19] + 3 | .05*x[2] + .08*x[3] -.03*x[6] + .03*x[7] -.09*x[9] -.01*x[10] -.07*x[11] + 4 | .25*x[13]^2 -.04*x[14] +.06*x[15] -.01*x[17] -.03*x[18] 5 | } 6 | X <- lhs::maximinLHS(n=100,k=20) -.5 7 | Z <- apply(X, 1, tf) 8 | gp <- GauPr_Gauss$new(X=X, Z=Z, theta_map=rep(1,20), nug.est=F, nug=1e-8) 9 | 10 | 11 | dev0 <- gp$deviance() 12 | devs <- rep(Inf, 20) 13 | llh0 <- gp$loglikelihood() 14 | llhs <- rep(-Inf, 20) 15 | avail.ind <- 1:20 16 | for (i in 1:5) { 17 | for (d in avail.ind) { 18 | gpd <- gp$clone() 19 | if (sum(gpd$theta_map[d] == gpd$theta_map) == 1) { # already unique 20 | # pass 21 | } else { # not unique 22 | #gpd$nug <- 1 23 | gpd$theta_short <- c(gpd$theta_short, gpd$theta_short[gpd$theta_map[d]]) 24 | gpd$theta_length <- gpd$theta_length + 1 25 | gpd$theta_map[d] <- max(gpd$theta_map) + 1 26 | gpd$update(restarts=20) 27 | devs[d] <- gpd$deviance() 28 | llhs[d] <- gpd$loglikelihood() 29 | } 30 | rm(gpd) 31 | } 32 | ind <- which.max(llhs) 33 | #ind <- which.min(devs) 34 | llh <- llhs[ind] 35 | dev <- devs[ind] 36 | inc2 <- 2*(llh-llh0) 37 | print(paste('best is',ind, 'llh is', llh, '2inc is', inc2)) 38 | gp$theta_short <- c(gp$theta_short, gp$theta_short[gp$theta_map[ind]]) 39 | gp$theta_length <- gp$theta_length + 1 40 | gp$theta_map[ind] <- max(gp$theta_map) + 1 41 | gp$update() 42 | dev0 <- dev 43 | llh0 <- llh 44 | devs <- rep(Inf, 20) 45 | llhs <- rep(-Inf, 20) 46 | avail.ind <- setdiff(avail.ind, ind) 47 | } 48 | -------------------------------------------------------------------------------- /scratch/scratch_kernel_Gaussian_logl.R: -------------------------------------------------------------------------------- 1 | # Check numerically that gradient is correct for 1D 2 | # For Gaussian_logl kernel 3 | set.seed(0) 4 | n <- 20 5 | x <- matrix(seq(0,1,length.out = n), ncol=1) 6 | f <- Vectorize(function(x) {sin(2*pi*x) + .5*sin(4*pi*x) +rnorm(1,0,.3)}) 7 | y <- f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 8 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian_logl$new(1), parallel=FALSE, verbose=10, nug.est=T) 9 | gp$cool1Dplot() 10 | numDeriv::grad(func = function(x)gp$deviance(params=x[1:2], nuglog=x[3]), x=c(2,1, -4)) 11 | gp$deviance_grad(params = c(2,1), nug.update=T, nuglog=-4) 12 | numDeriv::grad(func = function(x)gp$deviance(params=x[1:2], nuglog=x[3]), x=c(gp$kernel$logl, gp$kernel$logs2, log(gp$nug,10))) 13 | gp$deviance_grad(params = c(gp$kernel$logl, gp$kernel$logs2), nug.update=T, nuglog=log(gp$nug,10)) 14 | 15 | # Check dC_dtheta 16 | m1 <- (gp$kernel$k(gp$X, logl=1) - gp$kernel$k(gp$X, logl=1-1e-6)) / 1e-6 17 | C <- gp$kernel$k(gp$X, logl=1) 18 | m2 <- gp$kernel$dC_dparams(params = c(1, 1), X = gp$X, C = C, C_nonug = C)[[1]][[1]] 19 | c(m1-m2) %>% summary 20 | 21 | 22 | 23 | 24 | # Check 2D 25 | set.seed(0) 26 | n <- 30 27 | x <- lhs::maximinLHS(n=n, k=2) 28 | f <- function(x) {sin(2*pi*x[1]) + .5*sin(4*pi*x[1]) +rnorm(1,0,.03) + x[2]^2} 29 | y <- apply(x, 1, f) #f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 30 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian_beta$new(c(1, 1)), parallel=FALSE, verbose=10, nug.est=T) 31 | ContourFunctions::cf(gp$predict, pts=x) 32 | numDeriv::grad(func = function(x)gp$deviance(params = x[1:3], nuglog=x[4]), x=c(1,1, 1, -4)) 33 | gp$deviance_grad(params = c(1,1,1), nug.update=T, nuglog=-4) 34 | -------------------------------------------------------------------------------- /R/find_kernel_factor_dims2.R: -------------------------------------------------------------------------------- 1 | # Change this so Factor/Latent are one group and Ordered are other 2 | # (xindex, nlevels, type) 3 | find_kernel_factor_dims2 <- function (kern) { 4 | if (("GauPro_kernel_product" %in% class(kern)) || ("GauPro_kernel_sum" %in% class(kern))) { 5 | return(c(find_kernel_factor_dims2(kern$k1), 6 | find_kernel_factor_dims2(kern$k2))) 7 | } 8 | if (("GauPro_kernel_FactorKernel" %in% class(kern)) || 9 | ("GauPro_kernel_LatentFactorKernel" %in% class(kern)) || 10 | ("GauPro_kernel_GowerFactorKernel" %in% class(kern))) { 11 | return((c(kern$xindex, kern$nlevels, 0))) 12 | } 13 | if (("GauPro_kernel_OrderedFactorKernel" %in% class(kern))) { 14 | return((c(kern$xindex, kern$nlevels, 1))) 15 | } 16 | if (("GauPro_kernel_IgnoreInds" %in% class(kern))) { 17 | t1 <- find_kernel_factor_dims2(kern$kernel) 18 | if (is.null(t1)) { 19 | return(NULL) 20 | } 21 | for (i in 1:(length(t1)/2)) { 22 | # t1[2*i-1] <- t1[2*i-1] + sum(t1[2*i-1] <= kern$ignoreinds) 23 | t1[2*i-1] <- setdiff((1:(t1[1]+max(kern$ignoreinds))), 24 | kern$ignoreinds)[t1[2*i-1]] 25 | } 26 | return(t1) 27 | } 28 | return(NULL) 29 | } 30 | if (F) { 31 | k1 <- Gaussian$new(D=2) 32 | find_kernel_factor_dims(k1) 33 | find_kernel_factor_dims2(k1) 34 | k1 <- OrderedFactorKernel$new(D=2, xindex = 2, nlevels = 3) 35 | find_kernel_factor_dims(k1) 36 | find_kernel_factor_dims2(k1) 37 | k1 <- OrderedFactorKernel$new(D=2, xindex = 2, nlevels = 3) * 38 | FactorKernel$new(D=2, xindex = 1, nlevels = 3) 39 | find_kernel_factor_dims(k1) 40 | find_kernel_factor_dims2(k1) 41 | 42 | } 43 | -------------------------------------------------------------------------------- /scratch/scratch_speedupgrad.R: -------------------------------------------------------------------------------- 1 | # Trying to speed grad up 2 | d <- 6 3 | n <- 60 4 | x <- lhs::optimumLHS(n=n,k=d) 5 | f <- TestFunctions::OTL_Circuit 6 | y <- f(x) 7 | gp <- GauPro::GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian) 8 | x1 <- runif(6) 9 | microbenchmark::microbenchmark(gp$grad(x1)) 10 | # mean 2838 microsec, median 846 microsec 11 | # after using Kinv down to mean 878, median 670 12 | # after using dC_dx_arma down to mean 166 median 137 13 | pv <- profvis::profvis(replicate(1000, gp$grad(x1))) 14 | pv 15 | 16 | gp$kernel$dC_dx(XX = matrix(x1,ncol=d), X=gp$X) 17 | gp$kernel$dC_dx_arma(XX = matrix(x1,ncol=d), X=gp$X) 18 | summary(c(gp$kernel$dC_dx(XX = matrix(x1,ncol=d), X=gp$X)- 19 | gp$kernel$dC_dx_arma(XX = matrix(x1,ncol=d), X=gp$X))) 20 | 21 | microbenchmark::microbenchmark(gp$kernel$dC_dx(XX = matrix(x1,ncol=d), X=gp$X), 22 | gp$kernel$dC_dx_arma(XX = matrix(x1,ncol=d), X=gp$X)) 23 | 24 | pv2 <- profvis::profvis(gp <- GauPro::GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian)) 25 | pv2 26 | # Run 10 times 27 | pv2 <- profvis::profvis(replicate(10,GauPro::GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian))) 28 | pv2 29 | 30 | # Trying to speed up optimization, solve(C, di) is bottleneck 31 | gp <- GauPro::GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian) 32 | microbenchmark::microbenchmark(gp <- GauPro::GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian), times=5) 33 | # Original: Mean 2.7088 sec, median 2.714483 sec 34 | # After using Cinv: Mean 1.567 sec, median 1.545 sec 35 | # After removing matmul: Mean 1.27 sec, median 1.26 36 | # After arma gradfuncarray: Mean .683 (1.059), median .684 (.844) on 5 (50) times 37 | -------------------------------------------------------------------------------- /src/deviance.cpp: -------------------------------------------------------------------------------- 1 | //#include 2 | #include 3 | // using namespace Rcpp; 4 | using namespace arma; 5 | 6 | 7 | // [[Rcpp::export]] 8 | double deviance_part(arma::vec theta, double nug, arma::mat X, arma::mat Z, arma::mat Kinv) { 9 | // Not faster than using R, no need for this 10 | int N = X.n_rows; 11 | //double sumKinv = sum(sum(Kinv)); 12 | double mu_hat = sum(sum(Kinv * Z)) / sum(sum(Kinv)) ; 13 | //arma::mat s2_hat_mat = trans(Z - mu_hat) * Kinv * (Z - mu_hat) / N; 14 | //double s2_hat = s2_hat_mat(1,1); 15 | //double logdetK = 2 * sum(log(diag(Kchol))); 16 | arma::mat tmat = N * log(trans(Z - mu_hat) * (Kinv * (Z - mu_hat))); 17 | return tmat(0,0); 18 | } 19 | 20 | 21 | // [[Rcpp::export]] 22 | double devianceC(arma::vec theta, double nug, arma::mat X, arma::mat Z, arma::mat K) { 23 | // Twice as fast to this compared to devianceC or just R version 24 | int N = X.n_rows; 25 | arma::mat Kchol = chol(K); 26 | double mu_hat_top = sum(sum(solve(trimatu(Kchol), solve(trimatl(Kchol.t()), Z)))); 27 | arma::vec mu_hat_bottom_half = solve(trimatl(Kchol.t()), arma::ones(N)); 28 | double mu_hat_bottom = sum(mu_hat_bottom_half.t() * mu_hat_bottom_half); 29 | double mu_hat = mu_hat_top / mu_hat_bottom; 30 | arma::vec Kinv_y = solve(trimatu(Kchol), solve(trimatl(Kchol.t()), Z - mu_hat)); 31 | double tmat = N * log(sum(trans(Z - mu_hat) * (Kinv_y))); 32 | double logdetK = 2 * sum(log(diagvec(Kchol))); 33 | return logdetK + tmat;//(0,0); 34 | } 35 | 36 | 37 | // You can include R code blocks in C++ files processed with sourceCpp 38 | // (useful for testing and development). The R code will be automatically 39 | // run after the compilation. 40 | // 41 | 42 | /*** R 43 | #timesTwo(42) 44 | */ 45 | -------------------------------------------------------------------------------- /src/arma_cube_vec_multiply.cpp: -------------------------------------------------------------------------------- 1 | // #include 2 | #include 3 | using namespace Rcpp; 4 | 5 | 6 | //' Cube multiply over first dimension 7 | //' 8 | //' The result is transposed since that is what apply will give you 9 | //' 10 | //' @param cub A cube (3D array) 11 | //' @param v A vector 12 | //' @return Transpose of multiplication over first dimension of cub time v 13 | //' @examples 14 | //' d1 <- 10 15 | //' d2 <- 1e2 16 | //' d3 <- 2e2 17 | //' aa <- array(data = rnorm(d1*d2*d3), dim = c(d1, d2, d3)) 18 | //' bb <- rnorm(d3) 19 | //' t1 <- apply(aa, 1, function(U) {U%*%bb}) 20 | //' t2 <- arma_mult_cube_vec(aa, bb) 21 | //' dd <- t1 - t2 22 | //' 23 | //' summary(dd) 24 | //' image(dd) 25 | //' table(dd) 26 | //' # microbenchmark::microbenchmark(apply(aa, 1, function(U) {U%*%bb}), 27 | //' # arma_mult_cube_vec(aa, bb)) 28 | //' @export 29 | // [[Rcpp::export]] 30 | arma::mat arma_mult_cube_vec(arma::cube cub, arma::vec v) { 31 | int d1 = cub.n_rows; 32 | int d2 = cub.n_cols; 33 | int d3 = cub.n_slices; // equals v.n_rows 34 | // int d4 = v.n_cols // should be 1 35 | arma::mat out(d2, d1); // transposed version 36 | double total; 37 | for (int i = 0; i < d1; i++) { 38 | for (int j = 0; j < d2; j++) { 39 | total = 0; 40 | for(int k = 0; k < d3; ++k) { 41 | total += cub(i,j,k) * v(k); 42 | } 43 | 44 | // out(i, j) = total; 45 | out(j, i) = total; // Transposed version 46 | } 47 | } 48 | return out; 49 | } 50 | 51 | 52 | 53 | // You can include R code blocks in C++ files processed with sourceCpp 54 | // (useful for testing and development). The R code will be automatically 55 | // run after the compilation. 56 | // 57 | 58 | /*** R 59 | */ 60 | -------------------------------------------------------------------------------- /scratch/scratch_kernel_grad.R: -------------------------------------------------------------------------------- 1 | # Check grad 2 | set.seed(0) 3 | n <- 20 4 | x <- matrix(seq(0,1,length.out = n), ncol=1) 5 | f <- Vectorize(function(x) {sin(2*pi*x) + .5*sin(4*pi*x) +rnorm(1,0,.3) + 10*x}) 6 | y <- 123 + f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 7 | kernels <- list(Gaussian$new(1), Exponential$new(1), Matern32$new(0), Matern52$new(0), Periodic$new(.1, .2, alpha_lower=.1, p_lower=.1), RatQuad$new(.1, alpha=2.4), Exponential$new(1)+ Matern32$new(0), Exponential$new(1, beta_lower=-1)* Matern32$new(0, beta_lower=-1) ) 8 | trends <- list(trend_LM$new(D=1), trend_0$new()) 9 | kernel <- kernels[[8]] 10 | trend <- trends[[2]] 11 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=kernel, trend=trend, parallel=FALSE, verbose=10, nug.est=T, restarts=1) 12 | gp$cool1Dplot() 13 | 14 | XX <- matrix(c(.5, .6), ncol=1) 15 | numDeriv::grad(gp$predict, XX) 16 | gp$grad(XX) 17 | 18 | 19 | # check 2D 20 | 21 | set.seed(0) 22 | n <- 100 23 | x <- matrix(runif(2*40), ncol=2) 24 | f <- function(x) {sin(2*pi*x[1]) + .5*sin(4*pi*x[2]) + x[2]^.7 + rnorm(1,0,1)} 25 | y <- apply(x, 1, f) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 26 | kernels <- list(Gaussian$new(0:1), Exponential$new(0:1), Matern32$new(0:1), Matern52$new(0:1), Periodic$new(alpha=.1, p=c(.2,.3), alpha_lower=.1, p_lower=c(.1,.1), p_upper=c(10,10)), RatQuad$new(c(.1,.2), alpha=2.), Exponential$new(0:1)+Matern32$new(0:1), Exponential$new(0:1)*Matern32$new(0:1)) 27 | trends <- list(trend_LM$new(D=2)) 28 | kernel <- kernels[[8]] 29 | trend <- trends[[1]] 30 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=kernel, nug=.1, trend=trend, parallel=FALSE, verbose=10, nug.est=T, restarts=0) 31 | # ContourFunctions::cf(gp$predict, pts=x, batchmax=300) #cool1Dplot() 32 | 33 | XX <- matrix(c(.5, .6, .7, .8, .9, .95), ncol=2) 34 | # numDeriv::grad(gp$predict, XX) 35 | gp$grad(XX) 36 | t(apply(XX, 1, function(xx) numDeriv::grad(gp$predict, xx))) 37 | -------------------------------------------------------------------------------- /scratch/scratch_LOO.R: -------------------------------------------------------------------------------- 1 | # LOO test for kernel model 2 | set.seed(0) 3 | n <- 8 4 | x <- matrix(seq(0,1,length.out = n), ncol=1) 5 | f <- Vectorize(function(x) {sin(2*pi*x) + .5*sin(4*pi*x) +rnorm(1,0,.03)}) 6 | y <- f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 7 | #y[5] <- -.6 8 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=RatQuad$new(1, 1.5), parallel=FALSE, verbose=10, nug.est=T) 9 | gp$cool1Dplot() 10 | 11 | # Plot LOOs on top of coolplot 12 | loo <- gp$pred_LOO() 13 | points(x, loo, col=2) 14 | plot(y, loo);abline(a=0,b=1) 15 | 16 | # Check to see if LOOs match predictions when row is actually removed 17 | gp2store <- matrix(NA, n, 4) 18 | for (i in 1:n) { 19 | gp2 <- gp$clone(deep = TRUE) 20 | gp2$update(Xall = x[-i, , drop=FALSE], Zall = y[-i], no_update = T) 21 | # gp2$cool1Dplot() 22 | gp2store[i, ] <- c(y[i], gp2$pred(x[i]), gp$pred(x[i]), loo[i]) #%>% print 23 | } 24 | pairs(gp2store) 25 | gp2store 26 | plot(gp2store[,2], gp2store[,4]);abline(a=0,b=1) 27 | gp$cool1Dplot() 28 | points(x, gp2store[,4], col=2) 29 | points(x, gp2store[,2], col=3) 30 | 31 | # Plot with se 32 | gp$cool1Dplot() 33 | loo <- gp$pred_LOO(se.fit=T) 34 | points(x, loo$fit, col=2) 35 | points(x, loo$fit + 2*loo$se, col=3) 36 | points(x, loo$fit - 2*loo$se, col=3) 37 | 38 | 39 | 40 | 41 | 42 | 43 | # LOO test for non-kernel model 44 | set.seed(0) 45 | n <- 8 46 | x <- matrix(seq(0,1,length.out = n), ncol=1) 47 | f <- Vectorize(function(x) {sin(2*pi*x) + .5*sin(4*pi*x) +rnorm(1,0,.03)}) 48 | y <- f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 49 | #y[5] <- -.6 50 | gp <- GauPro_Gauss$new(X=x, Z=y, parallel=FALSE, verbose=10, nug.est=T) 51 | gp$cool1Dplot() 52 | 53 | # Plot LOOs on top of coolplot 54 | loo <- gp$pred_LOO() 55 | points(x, loo, col=2) 56 | plot(y, loo);abline(a=0,b=1) 57 | 58 | # Plot with se 59 | gp$cool1Dplot() 60 | loo <- gp$pred_LOO(se.fit=T) 61 | points(x, loo$fit, col=2) 62 | points(x, loo$fit + 2*loo$se, col=3) 63 | points(x, loo$fit - 2*loo$se, col=3) 64 | -------------------------------------------------------------------------------- /R/gradfuncarray.R: -------------------------------------------------------------------------------- 1 | # CE 10/26/21 2 | # gradfuncarray using Rcpp kept crashing RStudio on my laptop. 3 | # Just going to use R code and hope it doesn't crash. 4 | # This probably isn't a timing bottleneck anyways. 5 | 6 | #' Calculate gradfunc in optimization to speed up. 7 | #' NEEDS TO APERM dC_dparams 8 | #' Doesn't need to be exported, should only be useful in functions. 9 | #' @param dC_dparams Derivative matrix for covariance function wrt kernel parameters 10 | #' @param Cinv Inverse of covariance matrix 11 | #' @param Cinv_yminusmu Vector that is the inverse of C times y minus the mean. 12 | #' @return Vector, one value for each parameter 13 | #' @examples 14 | #' a1 <- array(dim=c(2,4,4), data=rnorm(32)) 15 | #' a2 <- matrix(rnorm(16),4,4) 16 | #' a3 <- rnorm(4) 17 | #' #gradfuncarray(a1, a2, a3) 18 | #' #gradfuncarrayR(a1, a2, a3) 19 | #' @export 20 | gradfuncarrayR <- function(dC_dparams, Cinv, Cinv_yminusmu) { 21 | # Rcout << dC_dparams; 22 | # Rcout << "\n\nCinv\n"; 23 | # Rcout << Cinv; 24 | # Rcout << "\n\nCinv_yminusmu\n"; 25 | # Rcout << Cinv_yminusmu; 26 | # int d1 = dC_dparams.n_rows; 27 | # int d2 = dC_dparams.n_cols; 28 | # int d3 = dC_dparams.n_slices; 29 | # arma::vec out(d1); 30 | # double t1; 31 | # double t2; 32 | d1 = dim(dC_dparams)[1] 33 | d2 = dim(dC_dparams)[2] 34 | d3 = dim(dC_dparams)[3] 35 | out <- numeric(d1) 36 | if (d1 == 0L) { 37 | return(out) 38 | } 39 | for (i in 1:d1) { #int i = 0; i < d1; i++) { 40 | t1 = 0; 41 | t2 = 0; 42 | for (j in 1:d2) { #int j = 0; j < d2; j++) { 43 | for (k in 1:d3) { #int k = 0; k < d3; k++) { 44 | # t1 += Cinv(j, k) * dC_dparams(i, j, k); 45 | # t2 += Cinv_yminusmu(j) * dC_dparams(i, j, k) * Cinv_yminusmu(k); 46 | t1 <- t1 + Cinv[j, k] * dC_dparams[i, j, k]; 47 | t2 <- t2 + Cinv_yminusmu[j] * dC_dparams[i, j, k] * Cinv_yminusmu[k]; 48 | } 49 | } 50 | out[i] = t1 - t2; 51 | } 52 | return( out); 53 | } 54 | 55 | -------------------------------------------------------------------------------- /scratch/scratch_kernel_Gaussian.R: -------------------------------------------------------------------------------- 1 | # Check numerically that gradient is correct for 1D 2 | set.seed(0) 3 | n <- 20 4 | x <- matrix(seq(0,1,length.out = n), ncol=1) 5 | f <- Vectorize(function(x) {sin(2*pi*x) + .5*sin(4*pi*x) +rnorm(1,0,.03)}) 6 | y <- f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 7 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian$new(1), parallel=FALSE, verbose=10, nug.est=T) 8 | gp$cool1Dplot() 9 | numDeriv::grad(func = function(x)gp$deviance(params = x[1:2], nuglog=x[3]), x=c(100,1, -4)) 10 | gp$deviance_grad(params = c(100,1), nug.update=T, nuglog=-4) 11 | numDeriv::grad(func = function(x)gp$deviance(params=x[1:2], nuglog=x[3]), x=c(gp$kernel$theta, gp$kernel$s2, log(gp$nug,10))) 12 | gp$deviance_grad(params = c(gp$kernel$theta, gp$kernel$s2), nug.update=T, nuglog=log(gp$nug,10)) 13 | 14 | # Check dC_dtheta 15 | m1 <- (gp$kernel$k(gp$X, theta=100) - gp$kernel$k(gp$X, theta=100-1e-6)) / 1e-6 16 | C <- gp$kernel$k(gp$X, theta=100) 17 | m2 <- gp$kernel$dC_dparams(params = c(100, 1), X = gp$X, C = C, C_nonug = C)[[1]][[1]] 18 | c(m1-m2) %>% summary 19 | 20 | # Check if optim works 21 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian$new(1), parallel=FALSE, verbose=10) 22 | # gp$optim() 23 | rmse <- function(gp) { 24 | xx <- seq(0,1,l=201) 25 | zz <- f(xx) 26 | sqrt(mean((gp$predict(xx) - zz)^2)) 27 | } 28 | rmse(gp) 29 | 30 | # Check nug with grad 31 | numDeriv::grad(func = function(x) {gp$deviance(nuglog = x[3], params = x[1:2])}, x=c(100,1, -6)) 32 | gp$deviance_grad(params = c(100,1), nug.update=T, nuglog = -6) 33 | 34 | 35 | 36 | 37 | 38 | # Check 2D 39 | set.seed(0) 40 | n <- 30 41 | x <- lhs::maximinLHS(n=n, k=2) 42 | f <- function(x) {sin(2*pi*x[1]) + .5*sin(4*pi*x[1]) +rnorm(1,0,.03) + x[2]^2} 43 | y <- apply(x, 1, f) #f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 44 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian$new(c(1, 1)), parallel=FALSE, verbose=10, nug.est=T) 45 | ContourFunctions::cf(gp$predict) 46 | numDeriv::grad(func = gp$deviance, x=c(100,1)) 47 | gp$deviance_grad(params = c(100,1), nug.update=F) 48 | -------------------------------------------------------------------------------- /scratch/FactorKernelCheckDeriv.R: -------------------------------------------------------------------------------- 1 | nlev <- 3 2 | kk <- LatentFactorKernel$new(D=1, nlevels=nlev, xindex=1, latentdim=2) 3 | kk$p 4 | kmat <- outer(1:nlev, 1:nlev, Vectorize(kk$k)) 5 | kmat 6 | # Xmat <- matrix(sample(1:nlev, 19,T)) 7 | Xmat <- matrix(1:nlev, ncol=1) 8 | kk$dC_dparams(X=Xmat, nug=0) 9 | C1 <- kk$C_dC_dparams(X=Xmat, nug=0, params=c(kk$p, kk$s2))$C 10 | C2 <- kk$k(Xmat, Xmat,params=c(kk$p, kk$s2)) 11 | max(abs(c(C1 - C2))) 12 | 13 | kkpars <- c(kk$p, log(kk$s2,10)) 14 | kk$C_dC_dparams(X=Xmat, nug=0, params=kkpars)$C 15 | eps <- 1e-6 16 | kkparsplus <- kkpars 17 | kkparsplus[1] <- kkparsplus[1] + eps 18 | kkparsminus <- kkpars 19 | kkparsminus[1] <- kkparsminus[1] - eps 20 | cdcplus <- kk$C_dC_dparams(X=Xmat, nug=0, params=kkparsplus) 21 | cdcminus <- kk$C_dC_dparams(X=Xmat, nug=0, params=kkparsminus) 22 | der1 <- (cdcplus$C - cdcminus$C) / (2*eps) 23 | der2 <- .5*(cdcplus$dC_dparams + cdcminus$dC_dparams)[1,,] 24 | plot(c(der1), c(der2)); abline(a=0,b=1, col=2) 25 | plot(c(der1), c(der1) - c(der2)) 26 | 27 | 28 | # Check product error 29 | d <- 2 30 | n <- 20 31 | nlev <- 2 32 | Xmat <- matrix(runif(d*n), ncol=2) 33 | Xmat[,2] <- sample(1:nlev, n, T) 34 | k1 <- IgnoreIndsKernel$new(Matern32$new(D=1, s2_est=F), ignoreinds = 2) 35 | k2 <- LatentFactorKernel$new(D=2, nlevels = nlev, xindex = 2, latentdim = 1, s2_est = F) 36 | k <- k1*k2 37 | kpar1 <- k$k1$kernel$beta 38 | kpar2 <- k$k2$p 39 | kpar <- c(kpar1, kpar2) 40 | k_C_dC <- k$C_dC_dparams(X=Xmat, nug=0, params = kpar) 41 | eps <- 1e-6 42 | for (i in 1:length(kpar)){ 43 | kkparsplus <- kpar 44 | kkparsplus[i] <- kkparsplus[i] + eps 45 | kkparsminus <- kpar 46 | kkparsminus[i] <- kkparsminus[i] - eps 47 | debugonce(k$k2$dC_dparams) 48 | cdcplus <- k$C_dC_dparams(X=Xmat, nug=0, params=kkparsplus) 49 | cdcminus <- k$C_dC_dparams(X=Xmat, nug=0, params=kkparsminus) 50 | der1 <- (cdcplus$C - cdcminus$C) / (2*eps) 51 | der2 <- .5*(cdcplus$dC_dparams + cdcminus$dC_dparams)[i,,] 52 | print(i); print(summary(c(der1 - der2))) 53 | plot(c(der1), c(der2)); abline(a=0,b=1, col=2) 54 | plot(c(der1), c(der1) - c(der2)) 55 | } 56 | -------------------------------------------------------------------------------- /R/find_kernel_cts_dims.R: -------------------------------------------------------------------------------- 1 | 2 | find_kernel_cts_dims <- function (kern) { 3 | if (("GauPro_kernel_product" %in% class(kern)) || ("GauPro_kernel_sum" %in% class(kern))) { 4 | return(sort(unique(c(find_kernel_cts_dims(kern$k1), 5 | find_kernel_cts_dims(kern$k2))))) 6 | } 7 | if (("GauPro_kernel_FactorKernel" %in% class(kern)) || 8 | ("GauPro_kernel_LatentFactorKernel" %in% class(kern)) || 9 | ("GauPro_kernel_OrderedFactorKernel" %in% class(kern)) || 10 | ("GauPro_kernel_GowerFactorKernel" %in% class(kern))) { 11 | return(NULL) 12 | } 13 | if (("GauPro_kernel_IgnoreInds" %in% class(kern))) { 14 | t1 <- find_kernel_cts_dims(kern$kernel) 15 | if (is.null(t1)) { 16 | return(NULL) 17 | } 18 | # for (i in 1:length(t1)) { 19 | # # t1[2*i-1] <- t1[2*i-1] + sum(t1[2*i-1] <= kern$ignoreinds) 20 | # # t1[2*i-1] <- setdiff((1:(t1[1]+max(kern$ignoreinds))), 21 | # # kern$ignoreinds)[t1[2*i-1]] 22 | # t1[i] <- t1[i] + sum(??? < t1[i]) 23 | # } 24 | a <- 1:(max(kern$ignoreinds, length(kern$ignoreinds) + length(t1))) 25 | b <- a[-kern$ignoreinds] 26 | d <- b[t1] 27 | return(d) 28 | } 29 | if ("GauPro_kernel_White" %in% class(kern)) { 30 | return(NULL) 31 | } 32 | if (!("GauPro_kernel" %in% class(kern))) { 33 | stop("kern isn't a GauPro_kernel") 34 | } 35 | # All other kernels are continuous over all dimensions 36 | return(1:kern$D) 37 | } 38 | if (F) { 39 | k1 <- Gaussian$new(D=2) 40 | find_kernel_cts_dims(k1) 41 | k1 <- OrderedFactorKernel$new(D=2, xindex = 2, nlevels = 3) 42 | find_kernel_cts_dims(k1) 43 | k3 <- IgnoreIndsKernel$new(ignoreinds = 3:4, Gaussian$new(D=2)) * 44 | LatentFactorKernel$new(D=4, nlevels = 2, latentdim = 1, xindex = 3) * 45 | LatentFactorKernel$new(D=4, nlevels = 4, latentdim = 2, xindex = 4) 46 | find_kernel_cts_dims(k3) 47 | k4 <- IgnoreIndsKernel$new(ignoreinds = 1:2, Gaussian$new(D=2)) 48 | find_kernel_cts_dims(k4) 49 | k4 <- IgnoreIndsKernel$new(ignoreinds = c(1,3), Gaussian$new(D=2)) 50 | find_kernel_cts_dims(k4) 51 | } 52 | -------------------------------------------------------------------------------- /R/corr.R: -------------------------------------------------------------------------------- 1 | corr_gauss_noC <- function(a, b, theta) { 2 | exp(-sum(theta * (a-b)^2)) 3 | } 4 | 5 | corr_gauss_matrix_noC <- function(x, x2=x, theta) { 6 | #outer(x,x2, gauss_cor) 7 | outer(1:nrow(x),1:nrow(x2), Vectorize(function(i,j) corr_gauss_noC(x[i,], x2[j,], theta=theta))) 8 | } 9 | 10 | #' Gaussian correlation 11 | #' 12 | #' @param x First data matrix 13 | #' @param x2 Second data matrix 14 | #' @param theta Correlation parameter 15 | #' 16 | #' @return Correlation matrix 17 | #' @export 18 | #' 19 | #' @examples 20 | #' corr_gauss_matrix(matrix(1:10,ncol=1), matrix(6:15,ncol=1), 1e-2) 21 | corr_gauss_matrix <- function(x, x2=NULL, theta) { 22 | stopifnot(is.matrix(x), is.vector(theta)) 23 | if (is.null(x2)) { 24 | corr_gauss_matrix_symC(x, theta) 25 | } else { 26 | stopifnot(is.matrix(x2), ncol(x)==ncol(x2), ncol(x)==length(theta)) 27 | corr_gauss_matrixC(x, x2, theta) 28 | } 29 | } 30 | 31 | 32 | # corr_gauss using C++ 33 | # Rcpp::cppFunction('double corr_gaussC_wrongplace(NumericVector a, NumericVector b, NumericVector theta) { 34 | # int n = a.size(); 35 | # double total = 0; 36 | # for(int i = 0; i < n; ++i) { 37 | # total += theta[i] * pow((a[i] - b[i]), 2.0); 38 | # } 39 | # total = exp(-total); 40 | # return total; 41 | # }') 42 | # if (F) { 43 | # corr_gaussC(1:5, 6:10, 1e-2) 44 | # 45 | # system.time(replicate(1e5, corr_gaussC(1:10, 6:15, 1e-2))) 46 | # } 47 | 48 | # Rcpp::cppFunction('NumericMatrix corr_gauss_matrixC_wrongplace(NumericMatrix x, NumericMatrix y, NumericVector theta) { 49 | # int nrow = x.nrow(), ncol = y.nrow(); 50 | # int nsum = x.ncol(); 51 | # NumericMatrix out(nrow, ncol); 52 | # 53 | # for (int i = 0; i < nrow; i++) { 54 | # for (int j = 0; j < ncol; j++) { 55 | # 56 | # double total = 0; 57 | # for(int k = 0; k < nsum; ++k) { 58 | # total += theta[k] * pow((x(i,k) - y(j,k)), 2.0); 59 | # } 60 | # total = exp(-total); 61 | # 62 | # out(i, j) = total; 63 | # } 64 | # } 65 | # return out; 66 | # }') 67 | if (F) { 68 | corr_gauss_matrixC(matrix(1:6,2,3), matrix(1:9,3,3), theta=1:3) 69 | system.time(replicate(1e5, corr_gauss_matrix(matrix(1:6,2,3), matrix(1:9,3,3), theta=1:3))) 70 | } 71 | -------------------------------------------------------------------------------- /tests/testthat/test_kernel_model_LOO.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | 3 | context("Test kernel model LOO") 4 | 5 | test_that("kernel model LOO works", { 6 | # Check if LOO predictions match actual on banana function, i.e. check shortcut 7 | set.seed(0) 8 | n <- 80 9 | d <- 2 10 | f1 <- function(x) {abs(sin(2*pi*x[1])) + x[2]^2} 11 | X1 <- matrix(runif(n*d),n,d) 12 | Z1 <- apply(X1,1,f1) * 9.3 + rnorm(n, 0, 1e0) 13 | expect_error(gp <- GauPro_kernel_model_LOO$new(X=X1, Z=Z1, kernel="matern52", 14 | nug.min=1e-6), 15 | NA) 16 | # ContourFunctions::cf(gp$predict, pts=X1) 17 | nn <- 1e3 18 | XX <- matrix(runif(nn*d),nn,d) 19 | ZZ <- apply(XX, 1, f1) * 9.3 20 | gp$use_LOO <- T 21 | # Predict 22 | expect_error(ZZhat <- gp$predict(XX, se=F), NA) 23 | expect_error(ZZhat <- gp$predict(XX, se=T), NA) 24 | # Predict mean 25 | expect_error(ZZhat <- gp$predict(XX, se=T, mean_dist=T), NA) 26 | }) 27 | 28 | test_that("pred_LOO", { 29 | # Test pred_LOO 30 | n <- 80 31 | d <- 2 32 | f1 <- function(x) {abs(sin(2*pi*x[1])) + x[2]^2} 33 | X1 <- matrix(runif(n*d),n,d) 34 | Z1 <- apply(X1,1,f1) * 9.3 + rnorm(n, 0, 1e0) 35 | expect_error(gp <- GauPro_kernel_model$new(X=X1, Z=Z1, kernel="matern52", 36 | nug.min=1e-6), 37 | NA) 38 | 39 | # Make sure that the LOO predictions match LOO 40 | expect_error(ZLOO <- gp$pred_LOO(se=T), NA) 41 | gp2 <- gp$clone(deep=T) 42 | loo_means <- numeric(n) 43 | loo_ses <- numeric(n) 44 | for (i in 1:n) { 45 | gpi <- gp$clone(deep=T); 46 | expect_error(gpi$update(Xall=X1[-i,],Zall=Z1[-i], no_update = TRUE), NA) 47 | # if (T) { #set mu and s2 back to original values 48 | # # This makes differences ~ 1e-15 instead of 1e-4, not sure if it is recommended though 49 | # gpi$s2_hat <- gp$s2_hat 50 | # gpi$mu_hat <- gp$mu_hat 51 | # } 52 | expect_error(gpp <- gpi$predict(X1[i,],se=T), NA) 53 | loo_means[i] <- gpp$me 54 | loo_ses[i] <- gpp$se 55 | } 56 | # cbind(ZLOO$fit, loo_means) 57 | # summary(ZLOO$fit - loo_means) 58 | # plot(ZLOO$fit, loo_means) 59 | 60 | expect_true(max(abs(ZLOO$fit - loo_means)) < 1e-4) 61 | }) 62 | -------------------------------------------------------------------------------- /scratch/scratch_KnowledgeGradient.R: -------------------------------------------------------------------------------- 1 | n <- 100 2 | X <- matrix(runif(n), ncol=1) 3 | y <- c(3.2*X-1.4) + rnorm(n) 4 | gpld <- GauPro_kernel_model$new(X, y, kernel='m52') 5 | gpld$plot1D() 6 | gpld$EI(1) 7 | curve(gpld$EI(matrix(x, ncol=1))) 8 | gpld$maxqEI(5, 'pred') 9 | 10 | n <- 10 11 | X <- matrix(runif(n), ncol=1) 12 | # y <- c(-3.2*(X-.5)^2-1.4) + rnorm(n,0,.01) 13 | f <- function(X) {c(-3.2*(X-.5)^2-1.4) + rnorm(length(X),0,1e-2)} 14 | y <- f(X) 15 | gpld <- GauPro_kernel_model$new(X, y, kernel='m32') 16 | gpld$plot1D() 17 | gpld$EI(1) 18 | curve(gpld$EI(matrix(x, ncol=1))) 19 | gpld$maxqEI(5, 'pred') 20 | gpld$maxqEI(5, 'CL') 21 | xEI <- gpld$maxqEI(5, 'pred') 22 | gpld$update(Xnew=xEI, Znew=f(xEI)) 23 | gpld$plot1D() 24 | plot(gpld$X) 25 | 26 | 27 | # Knowledge gradient 28 | 29 | n <- 10 30 | X <- matrix(runif(n), ncol=1) 31 | # y <- c(-3.2*(X-.5)^2-1.4) + rnorm(n,0,.01) 32 | f <- function(X) {c(-3.2*(X-.5)^2-1.4) + rnorm(length(X),0,1e-2)} 33 | y <- f(X) 34 | gpkg <- GauPro_kernel_model$new(X, y, kernel='m32') 35 | gpkg$plot1D() 36 | # Find current max 37 | gpkgmax <- optim(par=gpkg$X[which.max(gpkg$Z)[1],], 38 | fn=function(xx) {-gpkg$pred(xx)}, method='Brent', lower=0, upper=1) 39 | gpkgmax 40 | # Calculate knowledge gradient at xkg 41 | xkg <- .6 42 | # Sample at xkg 43 | xkgpred <- gpkg$pred(xkg, se.fit = T) 44 | xkgpred 45 | nsamps <- 5 46 | xkgsamps <- qnorm(((1:nsamps)-.5)/nsamps, xkgpred$mean, xkgpred$se) 47 | kgs <- rep(NA, nsamps) 48 | for (i in 1:nsamps) { 49 | xkgsamp <- xkgsamps[i] 50 | # xkgsamp <- rnorm(1, xkgpred$mean, xkgpred$se) 51 | # Add samp to mod 52 | gpkgclone <- gpkg$clone(deep=TRUE) 53 | gpkgclone$update(Xnew=xkg, Znew=xkgsamp, no_update = TRUE) 54 | gpkgclone$plot1D() 55 | # Find clone max after adding sample 56 | gpkgmaxclone <- optim(par=gpkgclone$X[which.max(gpkgclone$Z)[1],], 57 | fn=function(xx) {-gpkgclone$pred(xx)}, method='Brent', lower=0, upper=1) 58 | gpkgmaxclone 59 | gpkgmaxclone$value - gpkgmax$value 60 | kgs[i] <- gpkgmaxclone$value - gpkgmax$value 61 | } 62 | kgs 63 | 64 | gpkg <- GauPro_kernel_model$new(X, y, kernel='m32') 65 | gpkg$KG(.6) 66 | curve(sapply(x, function(x) gpkg$KG(x)), n=11) 67 | system.time(curve(sapply(x, function(x) gpkg$KG(x)), n=11)) 68 | -------------------------------------------------------------------------------- /src/Gaussian_deviance.cpp: -------------------------------------------------------------------------------- 1 | // #include 2 | #include 3 | #include "corr.h" 4 | //using namespace Rcpp; 5 | using namespace arma; 6 | 7 | 8 | // [[Rcpp::export]] 9 | double Gaussian_deviance_part(arma::vec theta, double nug, arma::mat X, arma::mat Z, arma::mat Kinv) { 10 | // Not faster than using R, no need for this 11 | int N = X.n_rows; 12 | //double sumKinv = sum(sum(Kinv)); 13 | double mu_hat = sum(sum(Kinv * Z)) / sum(sum(Kinv)) ; 14 | //arma::mat s2_hat_mat = trans(Z - mu_hat) * Kinv * (Z - mu_hat) / N; 15 | //double s2_hat = s2_hat_mat(1,1); 16 | //double logdetK = 2 * sum(log(diag(Kchol))); 17 | arma::mat tmat = N * log(trans(Z - mu_hat) * (Kinv * (Z - mu_hat))); 18 | return tmat(0,0); 19 | } 20 | 21 | 22 | //' Calculate the Gaussian deviance in C 23 | //' @param X Matrix X 24 | //' @param Z Matrix Z 25 | //' @param theta Theta vector 26 | //' @param nug Nugget 27 | //' @return Correlation matrix 28 | //' @examples 29 | //' Gaussian_devianceC(c(1,1), 1e-8, matrix(c(1,0,0,1),2,2), matrix(c(1,0),2,1)) 30 | //' @export 31 | // [[Rcpp::export]] 32 | double Gaussian_devianceC(arma::vec theta, double nug, arma::mat X, arma::mat Z) { 33 | // Twice as fast to this compared to devianceC or just R version 34 | int N = X.n_rows; 35 | 36 | arma::vec nug_vec(N); 37 | for (int i =0; i% tail 57 | gpk$predict(511:1000, se.fit = T) 58 | gpk$plot1D(xmax=1000) 59 | 60 | pred <- gpk$predict(1:1000, se.fit=T) 61 | plot(datos$ciclo, datos$Capacidad, main = "LCO Kernel Matern 5/2", xlab = "Ciclo", ylab = "Capacidad [%]", xlim=c(0,1000)) 62 | plot(pred[,1], type='l') 63 | plot(datos) 64 | 65 | gpklinear <- GauPro_kernel_model$new(trend=trend_LM$new(D=1), matrix(datos$ciclo, ncol=1), datos$Capacidad , kernel=kern, parallel=FALSE) 66 | gpklinear$plot1D(xmax=1000) 67 | -------------------------------------------------------------------------------- /tests/testthat/test_predictions.R: -------------------------------------------------------------------------------- 1 | test_that("prediction with no categorical predictors", { 2 | set.seed(1) 3 | dat <- data.frame(x = runif(20), y = runif(20), z = runif(20)) 4 | gp_kern <- k_Exponential(D = 2) 5 | gp_fit <- gpkm(z ~ x + y, data = dat, kernel = gp_kern) 6 | 7 | preds <- gp_fit$pred(dat[, 1:2], se.fit = TRUE) 8 | 9 | exp_ptype <- 10 | structure( 11 | list(mean = numeric(0), s2 = numeric(0), se = numeric(0)), 12 | row.names = integer(0), 13 | class = "data.frame") 14 | 15 | expect_equal(preds[0,], exp_ptype) 16 | expect_equal(nrow(preds), nrow(dat)) 17 | 18 | }) 19 | 20 | test_that("prediction with only categorical predictors", { 21 | set.seed(1) 22 | dat <- expand.grid(x = letters[1:2], y = LETTERS[1:2]) 23 | dat$z <- runif(nrow(dat)) 24 | 25 | gp_kern <- k_FactorKernel(D = 2, nlevels= 2, xindex = 1:2) 26 | expect_message( 27 | gp_fit <- gpkm(z ~ x + y, data = dat, kernel = gp_kern), 28 | regexp = "All restarts had error, keeping initial" 29 | ) 30 | 31 | preds <- gp_fit$pred(dat[, 1:2], se.fit = TRUE) 32 | 33 | exp_ptype <- 34 | structure( 35 | list(mean = numeric(0), s2 = numeric(0), se = numeric(0)), 36 | row.names = integer(0), 37 | class = "data.frame") 38 | 39 | expect_equal(preds[0,], exp_ptype) 40 | expect_equal(nrow(preds), nrow(dat)) 41 | 42 | }) 43 | 44 | # test_that("prediction with mixed predictor types", { 45 | # # skip("Appears to cause an inf loop of warnings") 46 | # # This runs fine interactively but, during testing, is issues infinite 47 | # # warnings. 48 | # # I found that it didn't give any warnings, but it did take way longer 49 | # # for no apparent reason. 50 | # set.seed(1) 51 | # dat <- data.frame(x = runif(20), z = runif(20)) 52 | # dat$y <- rep(letters[1:2], 10) 53 | # 54 | # 55 | # gp_kern <- k_Exponential(D = 1) * k_FactorKernel(D = 2, nlevels= 2, xindex = 2) 56 | # gp_fit <- gpkm(z ~ x + y, data = dat, kernel = gp_kern) 57 | # 58 | # preds <- gp_fit$pred(dat[, c(1, 3)], se.fit = TRUE) 59 | # 60 | # exp_ptype <- 61 | # structure( 62 | # list(mean = numeric(0), s2 = numeric(0), se = numeric(0)), 63 | # row.names = integer(0), 64 | # class = "data.frame") 65 | # 66 | # expect_equal(preds[0,], exp_ptype) 67 | # expect_equal(nrow(preds), nrow(dat)) 68 | # 69 | # }) 70 | 71 | -------------------------------------------------------------------------------- /src/pred_mean.cpp: -------------------------------------------------------------------------------- 1 | 2 | #include 3 | // using namespace Rcpp; 4 | using namespace arma; 5 | 6 | // This is a simple example of exporting a C++ function to R. You can 7 | // source this function into an R session using the Rcpp::sourceCpp 8 | // function (or via the Source button on the editor toolbar). Learn 9 | // more about Rcpp at: 10 | // 11 | // http://www.rcpp.org/ 12 | // http://adv-r.had.co.nz/Rcpp.html 13 | // http://gallery.rcpp.org/ 14 | // 15 | 16 | // [[Rcpp::export]] 17 | arma::vec pred_meanC(arma::mat XX, arma::mat kx_xx, double mu_hat, arma::mat Kinv, arma::mat Z) { 18 | return mu_hat + trans(kx_xx) * Kinv * (Z - mu_hat); 19 | } 20 | 21 | // [[Rcpp::export]] 22 | arma::vec pred_var(arma::mat XX, arma::mat kxx, arma::mat kx_xx, double s2_hat, arma::mat Kinv, arma::mat Z) { 23 | return s2_hat * arma::diagvec(kxx - trans(kx_xx) * Kinv * kx_xx); 24 | } 25 | 26 | // [[Rcpp::export]] 27 | arma::mat pred_cov(arma::mat XX, arma::mat kxx, arma::mat kx_xx, double s2_hat, arma::mat Kinv, arma::mat Z) { 28 | return s2_hat * (kxx - trans(kx_xx) * Kinv * kx_xx); 29 | } 30 | 31 | 32 | // Creating versions that take in mu_hat as vector 33 | 34 | // Does prediction using full Kinv, takes O(n^2) 35 | // [[Rcpp::export]] 36 | arma::vec pred_meanC_mumat(arma::mat XX, arma::mat kx_xx, arma::mat mu_hatX, arma::mat mu_hatXX, arma::mat Kinv, arma::mat Z) { 37 | return mu_hatXX + trans(kx_xx) * Kinv * (Z - mu_hatX); 38 | } 39 | 40 | // Now I precalculate Kinv_Z_minus_mu_hatX since it doesn't depend on XX. 41 | // Makes it O(n) instead of O(n^2) 42 | // [[Rcpp::export]] 43 | arma::vec pred_meanC_mumat_fast(arma::mat XX, arma::mat kx_xx, arma::vec Kinv_Z_minus_mu_hatX, arma::mat mu_hatXX) { 44 | // return mu_hatXX + sum(kx_xx * Kinv_Z_minus_mu_hatX); 45 | arma::vec tvec = zeros(mu_hatXX.n_elem); 46 | int ncols = kx_xx.n_cols; 47 | int nrows = kx_xx.n_rows; 48 | for (int i = 0; i < ncols; i++) { 49 | tvec(i) = mu_hatXX(i, 0); 50 | for (int j = 0; j < nrows; j++) { 51 | tvec(i) += kx_xx(j, i) * Kinv_Z_minus_mu_hatX(j); 52 | } 53 | } 54 | return tvec; 55 | } 56 | 57 | 58 | // You can include R code blocks in C++ files processed with sourceCpp 59 | // (useful for testing and development). The R code will be automatically 60 | // run after the compilation. 61 | // 62 | 63 | /*** R 64 | #timesTwo(42) 65 | */ 66 | -------------------------------------------------------------------------------- /scratch/scratch_grad_dist.R: -------------------------------------------------------------------------------- 1 | # 2D test 2 | n <- 40 3 | x <- matrix(runif(n*2), ncol=2) 4 | f1 <- function(a) {sin(2*pi*a[1]) + sin(6*pi*a[2])} 5 | #f1 <- TestFunctions::branin 6 | #f1 <- TestFunctions::RFF_get(D=2) 7 | y <- apply(x,1,f1) #+ rnorm(n,0,.01) 8 | system.time(ContourFunctions::cf_data(x,y)) 9 | gp <- GauPro(x,y, verbose=2);gp$theta 10 | system.time(ContourFunctions::cf_func(gp$pred, pts=x)) 11 | plot(y,gp$pred(x));abline(a=0,b=1) 12 | 13 | xx <- runif(2) 14 | gp$grad_dist(XX=xx) 15 | 16 | 17 | # Check sample function 18 | gp <- GauPro(x,y, verbose=2);gp$theta 19 | xx <- runif(2) 20 | samp1 <- gp$sample(xx, n=5000) 21 | mean(samp1) 22 | var(samp1) 23 | gp$pred(xx, se.fit = T) 24 | samp2 <- gp$sample(rbind(xx, c(.2,.3)), n=10000) 25 | colMeans(samp2) 26 | var(samp2) 27 | gp$pred(rbind(xx, c(.2,.3)), se.fit = T) 28 | 29 | 30 | # This checks that grad_dist matches up with numerical results 31 | xx <- runif(2) 32 | gp <- GauPro(x,y) 33 | gp <- GauPro_kernel_model$new(x,y,kernel=Gaussian) 34 | gp$grad_dist(xx) 35 | gp$grad(xx) 36 | eps <- 1e-4 37 | xx3 <- rbind(xx, xx+c(eps,0), xx+c(0, eps)) 38 | # Get samples to estimate grad 39 | samp3 <- gp$sample(XX = xx3, n = 1e5) 40 | colMeans(samp3) 41 | var(samp3) 42 | # Estimate gradient in each dimension 43 | grad_est1 <- (samp3[,2] - samp3[,1]) / eps 44 | grad_est2 <- (samp3[,3] - samp3[,1]) / eps 45 | summary(grad_est1) 46 | gp$grad_dist(xx) 47 | c(mean(grad_est1), mean(grad_est2)) #var(grad_est1) 48 | var(cbind(grad_est1, grad_est2)) 49 | 50 | gp$grad_dist(matrix(c(.2,.3),ncol=2)) 51 | gp$grad_dist(matrix(c(.4,.5),ncol=2)) 52 | gp$grad_dist(matrix(c(.2,.3,.4,.5),byrow=T,ncol=2)) 53 | 54 | 55 | # > gp$grad_dist(matrix(c(.2,.3,.4,.5),byrow=T,ncol=2)) 56 | # $mean 57 | # [,1] [,2] 58 | # [1,] 2.650846 -0.5852923 59 | # [2,] -4.667038 -0.7475923 60 | # 61 | # $cov 62 | # , , 1 63 | # 64 | # [,1] [,2] 65 | # [1,] 5.260113 0.0170742872 66 | # [2,] 3.821696 -0.0002883557 67 | # 68 | # , , 2 69 | # 70 | # [,1] [,2] 71 | # [1,] 0.0170742872 0.2635080 72 | # [2,] -0.0002883557 0.2533588 73 | 74 | # Check grad dist and grad norm2 dist 75 | tx <- matrix(runif(2),ncol=2) 76 | # Next two should be equal to third 77 | gp$grad_sample(tx, n=1e5) %>% colMeans() 78 | gp$grad_sample(tx, n=1e5) %>% cov 79 | gp$grad_dist(tx) 80 | # Check grad_norm2_dist 81 | gp$grad_sample(tx, n=1e5)^2 %>% rowSums %>% {c(mean(.), var(.))} 82 | gp$grad_norm2_dist(tx) 83 | sum(gp$grad(tx)^2) +gp$grad_dist(tx)$cov[1,,] %>% eigen() %>% .$val %>% sum 84 | -------------------------------------------------------------------------------- /scratch/scratch_kernel_Gaussian_beta.R: -------------------------------------------------------------------------------- 1 | # Check numerically that gradient is correct for 1D 2 | # For Gaussian_beta kernel 3 | set.seed(0) 4 | n <- 20 5 | x <- matrix(seq(0,1,length.out = n), ncol=1) 6 | f <- Vectorize(function(x) {sin(2*pi*x) + .5*sin(4*pi*x) +rnorm(1,0,.3)}+10*x) 7 | y <- 123 + f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 8 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian$new(1), parallel=FALSE, verbose=10, nug.est=T, s2_est=F) 9 | gp$cool1Dplot() 10 | numDeriv::grad(func = function(x)gp$deviance(params=x[2:3], nuglog=x[4], trend_params=x[1]), x=c(10, 2,1, -4)) 11 | gp$deviance_grad(params = c(2,1), nug.update=T, nuglog=-4, trend_params=10) 12 | numDeriv::grad(func = function(x)gp$deviance(trend_params=x[1], params=x[2:3], nuglog=x[4]), x=c(gp$trend$m, gp$kernel$beta, gp$kernel$logs2, log(gp$nug,10))) 13 | gp$deviance_grad(params = c(gp$kernel$beta, gp$kernel$logs2), trend_params=gp$trend$m, nug.update=T, nuglog=log(gp$nug,10)) 14 | 15 | # Check dC_dparams 16 | beta <- .6 17 | s2 <- .3 18 | nug <- 1e-4*10 19 | m1 <- (gp$kernel$k(gp$X, beta=beta+1e-6, s2=s2) - gp$kernel$k(gp$X, beta=beta-1e-6, s2=s2)) / 1e-6/2 20 | C_nonug <- gp$kernel$k(gp$X, beta=beta, s2=s2) 21 | C <- C_nonug + diag(s2*nug, nrow(C_nonug)) 22 | m2 <- gp$kernel$dC_dparams(params = c(beta, log(s2,10)), X = gp$X, C = C, C_nonug = C_nonug)[[1]][[1]] 23 | c(m1-m2) %>% summary 24 | 25 | # Check if not passing C and C_nonug is okay 26 | gp$kernel$dC_dparams(params = c(beta, log(s2,10)), X = gp$X, C = C, C_nonug = C_nonug)[[1]][[1]] 27 | gp$kernel$dC_dparams(params = c(beta, log(s2,10)), X = gp$X, nug=nug)[[1]][[1]] 28 | 29 | 30 | # Check C_dC_dparams 31 | params <- c(1.2,.8) 32 | nug <- .001 33 | gp$deviance(params=params, nug=nug) 34 | gp$deviance_grad(params=params, nug=nug, nug.update=T) 35 | gp$deviance_fngr(params=params, nug=nug, nug.update=T) 36 | microbenchmark::microbenchmark(sep={gp$deviance(params=params, nug=nug);gp$deviance_grad(params=params, nug=nug, nug.update=T)}, fngr=gp$deviance_fngr(params=params, nug=nug, nug.update=T)) 37 | 38 | # Check 2D 39 | set.seed(0) 40 | n <- 30 41 | x <- lhs::maximinLHS(n=n, k=2) 42 | f <- function(x) {sin(2*pi*x[1]) + .5*sin(4*pi*x[1]) +rnorm(1,0,.03) + x[2]^2} 43 | y <- apply(x, 1, f) #f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 44 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian_beta$new(c(1, 1)), parallel=FALSE, verbose=10, nug.est=T) 45 | ContourFunctions::cf(gp$predict, pts=x) 46 | numDeriv::grad(func = function(x)gp$deviance(trend_params=x[1], params = x[2:4], nuglog=x[5]), x=c(-1.2, 1,1, 1, -4)) 47 | gp$deviance_grad(params = c(1,1,1), nug.update=T, nuglog=-4, trend_params=-1.2) 48 | -------------------------------------------------------------------------------- /man/GauPro_kernel.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/kernel_base.R 3 | \docType{class} 4 | \name{GauPro_kernel} 5 | \alias{GauPro_kernel} 6 | \title{Kernel R6 class} 7 | \format{ 8 | \code{\link[R6]{R6Class}} object. 9 | } 10 | \value{ 11 | Object of \code{\link[R6]{R6Class}} with methods for fitting GP model. 12 | } 13 | \description{ 14 | Kernel R6 class 15 | 16 | Kernel R6 class 17 | } 18 | \examples{ 19 | #k <- GauPro_kernel$new() 20 | } 21 | \section{Public fields}{ 22 | \if{html}{\out{
}} 23 | \describe{ 24 | \item{\code{D}}{Number of input dimensions of data} 25 | 26 | \item{\code{useC}}{Should C code be used when possible? Can be much faster.} 27 | } 28 | \if{html}{\out{
}} 29 | } 30 | \section{Methods}{ 31 | \subsection{Public methods}{ 32 | \itemize{ 33 | \item \href{#method-GauPro_kernel-plot}{\code{GauPro_kernel$plot()}} 34 | \item \href{#method-GauPro_kernel-print}{\code{GauPro_kernel$print()}} 35 | \item \href{#method-GauPro_kernel-clone}{\code{GauPro_kernel$clone()}} 36 | } 37 | } 38 | \if{html}{\out{
}} 39 | \if{html}{\out{}} 40 | \if{latex}{\out{\hypertarget{method-GauPro_kernel-plot}{}}} 41 | \subsection{Method \code{plot()}}{ 42 | Plot kernel decay. 43 | \subsection{Usage}{ 44 | \if{html}{\out{
}}\preformatted{GauPro_kernel$plot(X = NULL)}\if{html}{\out{
}} 45 | } 46 | 47 | \subsection{Arguments}{ 48 | \if{html}{\out{
}} 49 | \describe{ 50 | \item{\code{X}}{Matrix of points the kernel is used with. Some will be used 51 | to demonstrate how the covariance changes.} 52 | } 53 | \if{html}{\out{
}} 54 | } 55 | } 56 | \if{html}{\out{
}} 57 | \if{html}{\out{}} 58 | \if{latex}{\out{\hypertarget{method-GauPro_kernel-print}{}}} 59 | \subsection{Method \code{print()}}{ 60 | Print this object 61 | \subsection{Usage}{ 62 | \if{html}{\out{
}}\preformatted{GauPro_kernel$print()}\if{html}{\out{
}} 63 | } 64 | 65 | } 66 | \if{html}{\out{
}} 67 | \if{html}{\out{}} 68 | \if{latex}{\out{\hypertarget{method-GauPro_kernel-clone}{}}} 69 | \subsection{Method \code{clone()}}{ 70 | The objects of this class are cloneable with this method. 71 | \subsection{Usage}{ 72 | \if{html}{\out{
}}\preformatted{GauPro_kernel$clone(deep = FALSE)}\if{html}{\out{
}} 73 | } 74 | 75 | \subsection{Arguments}{ 76 | \if{html}{\out{
}} 77 | \describe{ 78 | \item{\code{deep}}{Whether to make a deep clone.} 79 | } 80 | \if{html}{\out{
}} 81 | } 82 | } 83 | } 84 | -------------------------------------------------------------------------------- /man/gpkm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/gpkm.R 3 | \name{gpkm} 4 | \alias{gpkm} 5 | \title{Gaussian process regression model} 6 | \usage{ 7 | gpkm( 8 | X, 9 | Z, 10 | kernel, 11 | trend, 12 | verbose = 0, 13 | useC = TRUE, 14 | useGrad = TRUE, 15 | parallel = FALSE, 16 | parallel_cores = "detect", 17 | nug = 1e-06, 18 | nug.min = 1e-08, 19 | nug.max = 100, 20 | nug.est = TRUE, 21 | param.est = TRUE, 22 | restarts = 0, 23 | normalize = FALSE, 24 | optimizer = "L-BFGS-B", 25 | track_optim = FALSE, 26 | formula, 27 | data, 28 | ... 29 | ) 30 | } 31 | \arguments{ 32 | \item{X}{Matrix whose rows are the input points} 33 | 34 | \item{Z}{Output points corresponding to X} 35 | 36 | \item{kernel}{The kernel to use. E.g., Gaussian$new().} 37 | 38 | \item{trend}{Trend to use. E.g., trend_constant$new().} 39 | 40 | \item{verbose}{Amount of stuff to print. 0 is little, 2 is a lot.} 41 | 42 | \item{useC}{Should C code be used when possible? Should be faster.} 43 | 44 | \item{useGrad}{Should the gradient be used?} 45 | 46 | \item{parallel}{Should code be run in parallel? Make optimization 47 | faster but uses more computer resources.} 48 | 49 | \item{parallel_cores}{When using parallel, how many cores should 50 | be used?} 51 | 52 | \item{nug}{Value for the nugget. The starting value if estimating it.} 53 | 54 | \item{nug.min}{Minimum allowable value for the nugget.} 55 | 56 | \item{nug.max}{Maximum allowable value for the nugget.} 57 | 58 | \item{nug.est}{Should the nugget be estimated?} 59 | 60 | \item{param.est}{Should the kernel parameters be estimated?} 61 | 62 | \item{restarts}{How many optimization restarts should be used when 63 | estimating parameters?} 64 | 65 | \item{normalize}{Should the data be normalized?} 66 | 67 | \item{optimizer}{What algorithm should be used to optimize the 68 | parameters.} 69 | 70 | \item{track_optim}{Should it track the parameters evaluated 71 | while optimizing?} 72 | 73 | \item{formula}{Formula for the data if giving in a data frame.} 74 | 75 | \item{data}{Data frame of data. Use in conjunction with formula.} 76 | 77 | \item{...}{Not used} 78 | } 79 | \description{ 80 | Fits a Gaussian process regression model to data. 81 | 82 | An R6 object is returned with many methods. 83 | 84 | `gpkm()` is an alias for `GauPro_kernel_model$new()`. 85 | For full documentation, see documentation for `GauPro_kernel_model`. 86 | 87 | Standard methods that work include `plot()`, `summary()`, and `predict()`. 88 | } 89 | \details{ 90 | The default kernel is a Matern 5/2 kernel, but factor/character inputs 91 | will be given factor kernels. 92 | } 93 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method("*",GauPro_kernel) 4 | S3method("+",GauPro_kernel) 5 | S3method(predict,GauPro) 6 | S3method(predict,GauPro_base) 7 | S3method(print,summary.GauPro) 8 | S3method(summary,GauPro) 9 | export(Cubic) 10 | export(Exponential) 11 | export(FactorKernel) 12 | export(GauPro) 13 | export(GauPro_Gauss) 14 | export(GauPro_Gauss_LOO) 15 | export(GauPro_base) 16 | export(GauPro_kernel_model) 17 | export(GauPro_kernel_model_LOO) 18 | export(Gaussian) 19 | export(Gaussian_devianceC) 20 | export(Gaussian_hessianC) 21 | export(Gaussian_hessianCC) 22 | export(Gaussian_hessianR) 23 | export(GowerFactorKernel) 24 | export(IgnoreIndsKernel) 25 | export(LatentFactorKernel) 26 | export(Matern32) 27 | export(Matern52) 28 | export(OrderedFactorKernel) 29 | export(Periodic) 30 | export(PowerExp) 31 | export(RatQuad) 32 | export(Triangle) 33 | export(White) 34 | export(arma_mult_cube_vec) 35 | export(corr_cubic_matrix_symC) 36 | export(corr_exponential_matrix_symC) 37 | export(corr_gauss_dCdX) 38 | export(corr_gauss_matrix) 39 | export(corr_gauss_matrixC) 40 | export(corr_gauss_matrix_armaC) 41 | export(corr_gauss_matrix_symC) 42 | export(corr_gauss_matrix_sym_armaC) 43 | export(corr_latentfactor_matrix_symC) 44 | export(corr_latentfactor_matrixmatrixC) 45 | export(corr_matern32_matrix_symC) 46 | export(corr_matern52_matrix_symC) 47 | export(corr_orderedfactor_matrix_symC) 48 | export(corr_orderedfactor_matrixmatrixC) 49 | export(gpkm) 50 | export(gradfuncarray) 51 | export(gradfuncarrayR) 52 | export(k_Cubic) 53 | export(k_Exponential) 54 | export(k_FactorKernel) 55 | export(k_Gaussian) 56 | export(k_GowerFactorKernel) 57 | export(k_IgnoreIndsKernel) 58 | export(k_LatentFactorKernel) 59 | export(k_Matern32) 60 | export(k_Matern52) 61 | export(k_OrderedFactorKernel) 62 | export(k_Periodic) 63 | export(k_PowerExp) 64 | export(k_RatQuad) 65 | export(k_Triangle) 66 | export(k_White) 67 | export(kernel_cubic_dC) 68 | export(kernel_exponential_dC) 69 | export(kernel_gauss_dC) 70 | export(kernel_latentFactor_dC) 71 | export(kernel_matern32_dC) 72 | export(kernel_matern52_dC) 73 | export(kernel_orderedFactor_dC) 74 | export(kernel_product) 75 | export(kernel_sum) 76 | export(sqrt_matrix) 77 | export(trend_0) 78 | export(trend_LM) 79 | export(trend_c) 80 | importFrom(R6,R6Class) 81 | importFrom(Rcpp,evalCpp) 82 | importFrom(ggplot2,ggplot) 83 | importFrom(mixopt,mopar_cts) 84 | importFrom(numDeriv,grad) 85 | importFrom(rmarkdown,html_vignette) 86 | importFrom(stats,binom.test) 87 | importFrom(stats,model.frame) 88 | importFrom(stats,optim) 89 | importFrom(stats,runif) 90 | importFrom(tidyr,pivot_longer) 91 | useDynLib(GauPro) 92 | useDynLib(GauPro, .registration = TRUE) 93 | -------------------------------------------------------------------------------- /scratch/scratch_trend.R: -------------------------------------------------------------------------------- 1 | # trend_c 2 | set.seed(0) 3 | n <- 20 4 | x <- matrix(seq(0,1,length.out = n), ncol=1) 5 | f <- Vectorize(function(x) {sin(2*pi*x) + .5*sin(4*pi*x) +rnorm(1,0,.3)}+10*x) 6 | y <- 123 + f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 7 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian_beta$new(1), parallel=FALSE, verbose=10, nug.est=T) 8 | gp$cool1Dplot() 9 | numDeriv::grad(func = function(x)gp$deviance(params=x[2:3], nuglog=x[4], trend_params=x[1]), x=c(10, 2,1, -4)) 10 | gp$deviance_grad(params = c(2,1), nug.update=T, nuglog=-4, trend_params=10) 11 | numDeriv::grad(func = function(x)gp$deviance(trend_params=x[1], params=x[2:3], nuglog=x[4]), x=c(gp$trend$m, gp$kernel$beta, gp$kernel$logs2, log(gp$nug,10))) 12 | gp$deviance_grad(params = c(gp$kernel$beta, gp$kernel$logs2), trend_params=gp$trend$m, nug.update=T, nuglog=log(gp$nug,10)) 13 | 14 | # trend_c 2D 15 | set.seed(0) 16 | n <- 60 17 | x <- lhs::maximinLHS(n=n, k=2) 18 | f <- TestFunctions::banana#Vectorize(function(x) {sin(2*pi*x) + .5*sin(4*pi*x) +rnorm(1,0,.3)}+10*x) 19 | y <- 0*123 + f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 20 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian_beta$new(c(0,0)), parallel=FALSE, verbose=10, nug.est=T) 21 | ContourFunctions::cf(gp$predict, batchmax=Inf, pts=x) 22 | numDeriv::grad(func = function(x)gp$deviance(params=x[2:3], nuglog=x[4], trend_params=x[1]), x=c(10, 2,1, -4)) 23 | gp$deviance_grad(params = c(2,1), nug.update=T, nuglog=-4, trend_params=10) 24 | numDeriv::grad(func = function(x)gp$deviance(trend_params=x[1], params=x[2:3], nuglog=x[4]), x=c(gp$trend$m, gp$kernel$beta, gp$kernel$logs2, log(gp$nug,10))) 25 | gp$deviance_grad(params = c(gp$kernel$beta, gp$kernel$logs2), trend_params=gp$trend$m, nug.update=T, nuglog=log(gp$nug,10)) 26 | # Check fngr 27 | gp$deviance(params = c(2,1), nuglog=-4, trend_params=10) 28 | gp$deviance_grad(params = c(2,1), nug.update=T, nuglog=-4, trend_params=10) 29 | gp$deviance_fngr(params = c(2,1), nug.update=T, nuglog=-4, trend_params=10) 30 | 31 | 32 | 33 | 34 | # trend_LM 35 | set.seed(0) 36 | n <- 20 37 | x <- matrix(seq(0,1,length.out = n), ncol=1) 38 | f <- Vectorize(function(x) {sin(2*pi*x) + .5*sin(4*pi*x) +rnorm(1,0,.3)}+10*x) 39 | y <- 123 + f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 40 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian$new(1), trend=trend_LM$new(D=1), parallel=FALSE, verbose=10, nug.est=T) 41 | gp$cool1Dplot() 42 | numDeriv::grad(func = function(x)gp$deviance(params=x[2:3], nuglog=x[4], trend_params=x[1]), x=c(10, 2,1, -4)) 43 | gp$deviance_grad(params = c(2,1), nug.update=T, nuglog=-4, trend_params=10) 44 | numDeriv::grad(func = function(x)gp$deviance(trend_params=x[1], params=x[2:3], nuglog=x[4]), x=c(gp$trend$m, gp$kernel$beta, gp$kernel$logs2, log(gp$nug,10))) 45 | gp$deviance_grad(params = c(gp$kernel$beta, gp$kernel$logs2), trend_params=gp$trend$m, nug.update=T, nuglog=log(gp$nug,10)) 46 | -------------------------------------------------------------------------------- /R/grad_share.R: -------------------------------------------------------------------------------- 1 | #grad_share <- function(fn_gr) { 2 | # function(x) { 3 | # out <- fn_gr(x) 4 | # grad_store <<- out[[2]] 5 | # out[[1]] 6 | # } 7 | #} 8 | 9 | grad_share <- function(fn_gr) { 10 | env <- new.env() 11 | env$fn <- function(x) { 12 | out <- fn_gr(x) 13 | env$x_last <- x 14 | env$fn_val <- out[[1]] 15 | env$gr_val <- out[[2]] 16 | #grad_store <<- out[[2]] 17 | #out[[1]] 18 | env$fn_val 19 | } 20 | env$gr <- function(x = NULL) { 21 | # Can check if evaluated at same value, but will only slow it down 22 | #if (!is.null(x) && !any(is.nan(x)) && x != env$x_last) {warning("gr called at different x than fn")} 23 | env$gr_val 24 | } 25 | env 26 | } 27 | 28 | 29 | fngr <- function(fn_gr, check_all=FALSE, recalculate_indices = 1) { 30 | env <- new.env() 31 | env$f <- function(i, check=check_all, recalculate = any(i==recalculate_indices)) { 32 | function(x=NULL, check_now=check, recalculate_now=recalculate) { 33 | if (recalculate_now) { 34 | out <- fn_gr(x) 35 | env$x_last <- x 36 | env$out <- out 37 | out[[1]] 38 | } else { 39 | # Can check if evaluated at same value, but will only slow it down 40 | if (check_now) { 41 | if (!is.null(x) && !any(is.nan(x)) && x != env$x_last) { 42 | warning("gr called at different x than fn") 43 | } 44 | } 45 | } 46 | env$out[[i]] 47 | } 48 | } 49 | env 50 | } 51 | 52 | quad_share <- function(x){list(sum(x^4), 4*x^3)} 53 | 54 | #grad_share(quad_share) 55 | 56 | #ptim_share <- function(par, fngr, ...) { 57 | # fn <- grad_share(fngr) 58 | # optim(par=par, fn=fn, gr=function(xx) {grad_store}, ...) 59 | #} 60 | optim_share <- function(par, fngr, ...) { 61 | env <- grad_share(fngr) 62 | optim(par=par, fn=env$fn, gr=env$gr, ...) 63 | } 64 | #optim_share(par=c(3, -5), quad_share, method="BFGS") 65 | 66 | #lbfgs_share <- function(fngr, vars, method=NULL,...) { 67 | # fn <- grad_share(fngr) 68 | # lbfgs::lbfgs(call_eval=fn, call_grad=function(xx) {grad_store}, vars=vars, ...) 69 | #} 70 | 71 | lbfgs_share <- function(fngr, vars, method=NULL,...) { 72 | env <- grad_share(fngr) 73 | lbfgs::lbfgs(call_eval=env$fn, call_grad=env$gr, vars=vars, ...) 74 | } 75 | #lbfgs_share(vars=c(3, -5), fngr=quad_share) 76 | #parallel::mclapply(1:10, function(i)lbfgs_share(vars=runif(2,-10,10), fngr=quad_share, invisible=1), mc.cores=1) 77 | 78 | make_share <- function(func, arg_fn, arg_gr) { 79 | function(fngr, ...) { 80 | env <- grad_share(fngr) 81 | args_list <- list(env$fn, env$gr, ...) 82 | names(args_list)[1] <- arg_fn 83 | names(args_list)[2] <- arg_gr 84 | do.call(what=func, args=args_list) 85 | } 86 | } 87 | # make_share(lbfgs::lbfgs, 'call_eval', 'call_grad') 88 | # make_share(lbfgs::lbfgs, 'call_eval', 'call_grad')(quad_share, vars=c(5,-4)) 89 | -------------------------------------------------------------------------------- /scratch/scratch_kernel_Exponential.R: -------------------------------------------------------------------------------- 1 | # Check numerically that gradient is correct for 1D 2 | # For Exponential kernel 3 | set.seed(0) 4 | n <- 20 5 | x <- matrix(seq(0,1,length.out = n), ncol=1) 6 | f <- Vectorize(function(x) {sin(2*pi*x) + .5*sin(4*pi*x) +rnorm(1,0,.3)}) 7 | y <- f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 8 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Exponential$new(1), parallel=FALSE, verbose=10, nug.est=T) 9 | gp$cool1Dplot() 10 | numDeriv::grad(func = function(x)gp$deviance(params=x[1:2], nuglog=x[3]), x=c(2,1, -4)) 11 | gp$deviance_grad(params = c(2,1), nug.update=T, nuglog=-4) 12 | numDeriv::grad(func = function(x)gp$deviance(params=x[1:2], nuglog=x[3]), x=c(gp$kernel$beta, gp$kernel$logs2, log(gp$nug,10))) 13 | gp$deviance_grad(params = c(gp$kernel$beta, gp$kernel$logs2), nug.update=T, nuglog=log(gp$nug,10)) 14 | 15 | # Check dC_dtheta 16 | m1 <- (gp$kernel$k(gp$X, beta=1) - gp$kernel$k(gp$X, beta=1-1e-6)) / 1e-6 17 | C_nonug <- gp$kernel$k(gp$X, beta=1) 18 | C <- C_nonug + gp$kernel$s2 * diag(gp$nug, nrow(C_nonug)) 19 | m2 <- gp$kernel$dC_dparams(params = c(1, 1), X = gp$X, C = C, C_nonug = C_nonug)[[1]][[1]] 20 | c(m1-m2) %>% summary 21 | plot(m1, m2) 22 | 23 | gp$deviance_grad() 24 | dsign <- 1 25 | mm1 <- gp$kernel$dC_dparams(C = C, C_nonug = C_nonug, X=gp$X)[[1]] 26 | dsign <- -1 27 | mm2 <- gp$kernel$dC_dparams(C = C, C_nonug = C_nonug, X=gp$X)[[1]] 28 | plot(c(mm1[[1]]), c(mm2[[1]])) 29 | 30 | 31 | # Check dC_dlogs2 32 | beta <- gp$kernel$beta 33 | s2 <- gp$kernel$s2+.2 34 | nug <- gp$nug 35 | eps <- 1e-6 36 | m1 <- (gp$kernel$k(gp$X, beta=beta, s2=s2+eps) - gp$kernel$k(gp$X, beta=beta, s2=s2-eps)) / eps / 2 37 | C_nonug <- gp$kernel$k(gp$X, beta=beta, s2=s2) 38 | C <- C_nonug + s2 * diag(nug, nrow(C_nonug)) 39 | m2 <- gp$kernel$dC_dparams(params = log(c(beta, s2),10), X = gp$X, C = C, C_nonug = C)[[1]][[2]] 40 | c(m1 * s2 * log(10) -m2) %>% summary 41 | plot(c(m1 * s2 * log(10)), c(m2)) 42 | 43 | 44 | # Check C_dC_dparams 45 | params <- c(1.2,.8) 46 | nug <- .001 47 | gp$deviance(params=params, nug=nug) 48 | gp$deviance_grad(params=params, nug=nug, nug.update=T) 49 | gp$deviance_fngr(params=params, nug=nug, nug.update=T) 50 | microbenchmark::microbenchmark(sep={gp$deviance(params=params, nug=nug);gp$deviance_grad(params=params, nug=nug, nug.update=T)}, fngr=gp$deviance_fngr(params=params, nug=nug, nug.update=T)) 51 | 52 | 53 | 54 | # Check 2D 55 | set.seed(0) 56 | n <- 30 57 | x <- lhs::maximinLHS(n=n, k=2) 58 | f <- function(x) {sin(2*pi*x[1]) + .5*sin(4*pi*x[1]) +rnorm(1,0,.03) + x[2]^2} 59 | y <- apply(x, 1, f) #f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 60 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian_beta$new(c(1, 1)), parallel=FALSE, verbose=10, nug.est=T) 61 | ContourFunctions::cf(gp$predict, pts=x) 62 | numDeriv::grad(func = function(x)gp$deviance(params = x[1:3], nuglog=x[4]), x=c(1,1, 1, -4)) 63 | gp$deviance_grad(params = c(1,1,1), nug.update=T, nuglog=-4) 64 | -------------------------------------------------------------------------------- /R/optim_share2.R: -------------------------------------------------------------------------------- 1 | # CBE 5/6/2021 2 | # When all optim restarts fail, it sticks with initial values. 3 | # It'd be better if optim could track best value along the way, 4 | # and then if there is an error, return the best value seen so far 5 | # instead of throwing an error. 6 | # In this file optim_share2 improves optim_share to do exactly this. 7 | # There is nearly no increase in runtime on the example I checked. 8 | 9 | if (F) { 10 | optim(par=2, fn=function(x) {x^2}, method="L-BFGS-B") 11 | optim(par=2, fn=function(x) {x^2}, gr=function(x){2*x}, method="L-BFGS-B") 12 | optim(par=2, fn=function(x) {ifelse(x>1,x^2, NA)}, gr=function(x){2*x}, method="L-BFGS-B") 13 | optim_share(par=2, fngr=function(x) {list(x^2, 2*x)}, method="L-BFGS-B") 14 | optim_share(par=2, fngr=function(x) {list(ifelse(x>1,x^2, NA), 2*x)}, method="L-BFGS-B") 15 | } 16 | 17 | optim_share2 <- function(par, fngr, ...) { 18 | env <- grad_share(fngr) 19 | bestx <- 0 20 | besty <- Inf 21 | # iter <- 0 22 | neval <- 0 23 | f1 <- function(x) { 24 | neval <<- neval + 1 25 | out <- env$fn(x) 26 | # iter <<- iter + 1 27 | # print(c(iter, round(x,4), out, round(bestx,4), besty)) 28 | if (!is.na(out) && out < besty) { 29 | bestx <<- x 30 | besty <<- out 31 | } 32 | out 33 | } 34 | # optim(par=par, fn=env$fn, gr=env$gr, ...) 35 | optim_out <- try({ 36 | optim(par=par, fn=f1, gr=env$gr, ...) 37 | # optim(par=par, fn=f1, gr=env$gr, control=list(factr=1e11), ...) 38 | }, silent = TRUE) 39 | if (inherits(optim_out, "try-error")) { 40 | # print('try-error') 41 | if (is.infinite(besty)) { 42 | stop(paste0("optim_share2 error on starting params: ", 43 | attr(optim_out, 'condition')$message)) 44 | } else { 45 | return(list(par=bestx, 46 | value=besty, 47 | counts=c('function'=neval, 'gradient'=NA), 48 | convergence=NA, 49 | message="FAILED OPTIM: USING BEST SEEN, SEE optim_share2 FOR DETAILS")) 50 | } 51 | } 52 | optim_out 53 | } 54 | if (F) { 55 | optim_share2(par=2, fngr=function(x) {list(ifelse(x>.1,x^2, NA), 2*x)}, method="L-BFGS-B") 56 | optim_share2(par=2, fngr=function(x) {list(ifelse(x>.1,x^4, NA), 4*x^3)}, method="L-BFGS-B") 57 | } 58 | 59 | if (F) { 60 | microbenchmark::microbenchmark(os2={use_optim_share2 <- TRUE; k2 <- FactorKernel$new(D=2, nlevels=3, xind=1); gp <- GauPro_kernel_model$new(X=X, Z=Z, kernel = k2, verbose = 5)}, 61 | os1={use_optim_share2 <- F; k2 <- FactorKernel$new(D=2, nlevels=3, xind=1); gp <- GauPro_kernel_model$new(X=X, Z=Z, kernel = k2, verbose = 5)}, times=10) 62 | 63 | use_optim_share2 <- TRUE 64 | k2 <- FactorKernel$new(D=2, nlevels=3, xind=1) 65 | gp <- GauPro_kernel_model$new(X=X, Z=Z, kernel = k2, verbose = 5) 66 | } 67 | -------------------------------------------------------------------------------- /scratch/scratch_kernel_Matern32.R: -------------------------------------------------------------------------------- 1 | # Check numerically that gradient is correct for 1D 2 | # For Matern32 kernel 3 | set.seed(0) 4 | n <- 20 5 | x <- matrix(seq(0,1,length.out = n), ncol=1) 6 | f <- Vectorize(function(x) {sin(2*pi*x) + .5*sin(4*pi*x) +rnorm(1,0,.03)}) 7 | y <- f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 8 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Matern32$new(1), parallel=FALSE, verbose=10, nug.est=T) 9 | gp$cool1Dplot() 10 | numDeriv::grad(func = function(x)gp$deviance(params=x[1:2], nuglog=x[3]), x=c(2,1, -4)) 11 | gp$deviance_grad(params = c(2,1), nug.update=T, nuglog=-4) 12 | numDeriv::grad(func = function(x)gp$deviance(params=x[1:2], nuglog=x[3]), x=c(gp$kernel$beta, gp$kernel$logs2, log(gp$nug,10))) 13 | gp$deviance_grad(params = c(gp$kernel$beta, gp$kernel$logs2), nug.update=T, nuglog=log(gp$nug,10)) 14 | 15 | # Check dC_dtheta 16 | m1 <- (gp$kernel$k(gp$X, beta=1) - gp$kernel$k(gp$X, beta=1-1e-6)) / 1e-6 17 | C_nonug <- gp$kernel$k(gp$X, beta=1) 18 | C <- C_nonug + gp$kernel$s2 * diag(gp$nug, nrow(C_nonug)) 19 | m2 <- gp$kernel$dC_dparams(params = c(1, 1), X = gp$X, C = C, C_nonug = C_nonug)[[1]][[1]] 20 | summary(c(m1-m2))# %>% summary 21 | plot(m1, m2) 22 | 23 | gp$deviance_grad() 24 | dsign <- 1 25 | mm1 <- gp$kernel$dC_dparams(C = C, C_nonug = C_nonug, X=gp$X)[[1]] 26 | dsign <- -1 27 | mm2 <- gp$kernel$dC_dparams(C = C, C_nonug = C_nonug, X=gp$X)[[1]] 28 | plot(c(mm1[[1]]), c(mm2[[1]])) 29 | 30 | 31 | # Check dC_dlogs2 32 | beta <- gp$kernel$beta 33 | s2 <- gp$kernel$s2+.2 34 | nug <- gp$nug 35 | eps <- 1e-6 36 | m1 <- (gp$kernel$k(gp$X, beta=beta, s2=s2+eps) - gp$kernel$k(gp$X, beta=beta, s2=s2-eps)) / eps / 2 37 | C_nonug <- gp$kernel$k(gp$X, beta=beta, s2=s2) 38 | C <- C_nonug + s2 * diag(nug, nrow(C_nonug)) 39 | m2 <- gp$kernel$dC_dparams(params = log(c(beta, s2),10), X = gp$X, C = C, C_nonug = C)[[1]][[2]] 40 | c(m1 * s2 * log(10) -m2) %>% summary 41 | plot(c(m1 * s2 * log(10)), c(m2)) 42 | 43 | 44 | # Check C_dC_dparams 45 | params <- c(1.2,.8) 46 | nug <- .001 47 | gp$deviance(params=params, nug=nug) 48 | gp$deviance_grad(params=params, nug=nug, nug.update=T) 49 | gp$deviance_fngr(params=params, nug=nug, nug.update=T) 50 | microbenchmark::microbenchmark(sep={gp$deviance(params=params, nug=nug);gp$deviance_grad(params=params, nug=nug, nug.update=T)}, fngr=gp$deviance_fngr(params=params, nug=nug, nug.update=T)) 51 | 52 | 53 | 54 | 55 | # Check 2D 56 | set.seed(0) 57 | n <- 30 58 | x <- lhs::maximinLHS(n=n, k=2) 59 | f <- function(x) {sin(2*pi*x[1]) + .5*sin(4*pi*x[1]) +rnorm(1,0,.03) + x[2]^2} 60 | y <- apply(x, 1, f) #f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 61 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Matern32$new(c(1, 1)), parallel=FALSE, verbose=10, nug.est=T) 62 | ContourFunctions::cf(gp$predict, pts=x, batchmax=Inf) 63 | ContourFunctions::cf(f, pts=x) 64 | numDeriv::grad(func = function(x)gp$deviance(params = x[1:3], nuglog=x[4]), x=c(1,1, 1, -4)) 65 | gp$deviance_grad(params = c(1,1,1), nug.update=T, nuglog=-4) 66 | -------------------------------------------------------------------------------- /scratch/scratch_kernel_Matern52.R: -------------------------------------------------------------------------------- 1 | # Check numerically that gradient is correct for 1D 2 | # For Matern52 kernel 3 | set.seed(0) 4 | n <- 20 5 | x <- matrix(seq(0,1,length.out = n), ncol=1) 6 | f <- Vectorize(function(x) {sin(2*pi*x) + .5*sin(4*pi*x) +rnorm(1,0,.03)}) 7 | y <- f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 8 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Matern52$new(1), parallel=FALSE, verbose=10, nug.est=T) 9 | gp$cool1Dplot() 10 | numDeriv::grad(func = function(x)gp$deviance(params=x[1:2], nuglog=x[3]), x=c(2,1, -4)) 11 | gp$deviance_grad(params = c(2,1), nug.update=T, nuglog=-4) 12 | numDeriv::grad(func = function(x)gp$deviance(params=x[1:2], nuglog=x[3]), x=c(gp$kernel$beta, gp$kernel$logs2, log(gp$nug,10))) 13 | gp$deviance_grad(params = c(gp$kernel$beta, gp$kernel$logs2), nug.update=T, nuglog=log(gp$nug,10)) 14 | 15 | # Check dC_dtheta 16 | m1 <- (gp$kernel$k(gp$X, beta=1) - gp$kernel$k(gp$X, beta=1-1e-6)) / 1e-6 17 | C_nonug <- gp$kernel$k(gp$X, beta=1) 18 | C <- C_nonug + gp$kernel$s2 * diag(gp$nug, nrow(C_nonug)) 19 | m2 <- gp$kernel$dC_dparams(params = c(1, 1), X = gp$X, C = C, C_nonug = C_nonug)[[1]][[1]] 20 | summary(c(m1-m2))# %>% summary 21 | plot(m1, m2) 22 | 23 | gp$deviance_grad() 24 | dsign <- 1 25 | mm1 <- gp$kernel$dC_dparams(C = C, C_nonug = C_nonug, X=gp$X)[[1]] 26 | dsign <- -1 27 | mm2 <- gp$kernel$dC_dparams(C = C, C_nonug = C_nonug, X=gp$X)[[1]] 28 | plot(c(mm1[[1]]), c(mm2[[1]])) 29 | 30 | 31 | # Check dC_dlogs2 32 | beta <- gp$kernel$beta 33 | s2 <- gp$kernel$s2+.2 34 | nug <- gp$nug 35 | eps <- 1e-6 36 | m1 <- (gp$kernel$k(gp$X, beta=beta, s2=s2+eps) - gp$kernel$k(gp$X, beta=beta, s2=s2-eps)) / eps / 2 37 | C_nonug <- gp$kernel$k(gp$X, beta=beta, s2=s2) 38 | C <- C_nonug + s2 * diag(nug, nrow(C_nonug)) 39 | m2 <- gp$kernel$dC_dparams(params = log(c(beta, s2),10), X = gp$X, C = C, C_nonug = C)[[1]][[2]] 40 | c(m1 * s2 * log(10) -m2) %>% summary 41 | plot(c(m1 * s2 * log(10)), c(m2)) 42 | 43 | 44 | # Check C_dC_dparams 45 | params <- c(1.2,.8) 46 | nug <- .001 47 | gp$deviance(params=params, nug=nug) 48 | gp$deviance_grad(params=params, nug=nug, nug.update=T) 49 | gp$deviance_fngr(params=params, nug=nug, nug.update=T) 50 | microbenchmark::microbenchmark(sep={gp$deviance(params=params, nug=nug);gp$deviance_grad(params=params, nug=nug, nug.update=T)}, fngr=gp$deviance_fngr(params=params, nug=nug, nug.update=T)) 51 | 52 | 53 | 54 | 55 | # Check 2D 56 | set.seed(0) 57 | n <- 60 58 | x <- lhs::maximinLHS(n=n, k=2) 59 | f <- function(x) {sin(2*pi*x[1]) + .5*sin(4*pi*x[1]) +rnorm(1,0,.03) + x[2]^2} 60 | y <- apply(x, 1, f) #f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 61 | system.time(gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Matern52$new(c(1, 1)), parallel=FALSE, verbose=10, nug.est=T)) 62 | ContourFunctions::cf(gp$predict, pts=x, batchmax=Inf) 63 | ContourFunctions::cf(f, pts=x) 64 | numDeriv::grad(func = function(x)gp$deviance(params = x[1:3], nuglog=x[4]), x=c(1,1, 1, -4)) 65 | gp$deviance_grad(params = c(1,1,1), nug.update=T, nuglog=-4) 66 | -------------------------------------------------------------------------------- /R/gpkm.R: -------------------------------------------------------------------------------- 1 | #' Gaussian process regression model 2 | #' 3 | #' @description 4 | #' Fits a Gaussian process regression model to data. 5 | #' 6 | #' An R6 object is returned with many methods. 7 | #' 8 | #' `gpkm()` is an alias for `GauPro_kernel_model$new()`. 9 | #' For full documentation, see documentation for `GauPro_kernel_model`. 10 | #' 11 | #' Standard methods that work include `plot()`, `summary()`, and `predict()`. 12 | #' 13 | #' @details 14 | #' The default kernel is a Matern 5/2 kernel, but factor/character inputs 15 | #' will be given factor kernels. 16 | #' 17 | #' @export 18 | #' @param X Matrix whose rows are the input points 19 | #' @param Z Output points corresponding to X 20 | #' @param kernel The kernel to use. E.g., Gaussian$new(). 21 | #' @param trend Trend to use. E.g., trend_constant$new(). 22 | #' @param verbose Amount of stuff to print. 0 is little, 2 is a lot. 23 | #' @param useC Should C code be used when possible? Should be faster. 24 | #' @param useGrad Should the gradient be used? 25 | #' @param parallel Should code be run in parallel? Make optimization 26 | #' faster but uses more computer resources. 27 | #' @param parallel_cores When using parallel, how many cores should 28 | #' be used? 29 | #' @param nug Value for the nugget. The starting value if estimating it. 30 | #' @param nug.min Minimum allowable value for the nugget. 31 | #' @param nug.max Maximum allowable value for the nugget. 32 | #' @param nug.est Should the nugget be estimated? 33 | #' @param param.est Should the kernel parameters be estimated? 34 | #' @param restarts How many optimization restarts should be used when 35 | #' estimating parameters? 36 | #' @param normalize Should the data be normalized? 37 | #' @param optimizer What algorithm should be used to optimize the 38 | #' parameters. 39 | #' @param track_optim Should it track the parameters evaluated 40 | #' while optimizing? 41 | #' @param formula Formula for the data if giving in a data frame. 42 | #' @param data Data frame of data. Use in conjunction with formula. 43 | #' @param ... Not used 44 | gpkm <- function(X, Z, 45 | kernel, trend, 46 | verbose=0, useC=TRUE, useGrad=TRUE, 47 | parallel=FALSE, parallel_cores="detect", 48 | nug=1e-6, nug.min=1e-8, nug.max=1e2, nug.est=TRUE, 49 | param.est = TRUE, restarts = 0, 50 | normalize = FALSE, optimizer="L-BFGS-B", 51 | track_optim=FALSE, 52 | formula, data, 53 | ...) { 54 | GauPro_kernel_model$new( 55 | X=X, Z=Z, 56 | kernel=kernel, trend=trend, 57 | verbose=verbose, useC=useC, useGrad=useGrad, 58 | parallel=parallel, parallel_cores=parallel_cores, 59 | nug=nug, nug.min=nug.min, nug.max=nug.max, nug.est=nug.est, 60 | param.est = param.est, restarts = restarts, 61 | normalize = normalize, optimizer=optimizer, 62 | track_optim=track_optim, 63 | formula=formula, data=data, 64 | ... 65 | ) 66 | } 67 | -------------------------------------------------------------------------------- /scratch/scratch_bernoulli_first_attempt.R: -------------------------------------------------------------------------------- 1 | # Scratch to test getting bernoulli working 2 | n <- 50 3 | d <- 2 4 | logistic <- function(x) 1/(1+exp(-x)) 5 | dlogistic <- function(x) logistic(x) * (1 - logistic(x)) 6 | logit <- function(p) log(p/(1-p)) 7 | # Unit vector 8 | ei <- function(i) rep(1,n) * (i == (1:n)) 9 | 10 | X <- matrix(runif(n*d), nrow=n) 11 | # w_true <- apply(X, 1, function(x) (2*(x[1]-.5)) + 2*sin(x[2]*pi) - 1) 12 | w_true <- apply(X, 1, function(x) (4*(x[1]-.5))) 13 | logistic_w_true <- logistic(w_true) 14 | y <- as.integer(runif(n) < logistic_w_true) 15 | cbind(X, w_true, logistic_w_true, y) 16 | cor(cbind(X, w_true, logistic_w_true, y)) 17 | pairs(cbind(X, w_true, logistic_w_true, y)) 18 | 19 | w <- rnorm(n, sd=1.7) 20 | w 21 | kern <- GauPro::k_Gaussian(s2=1.7^2, s2_est=F, D=d) 22 | kern$plot() 23 | gp <- gpkm(kern=kern, X, w) 24 | gp$sample(X) 25 | gp$plotmarginal() 26 | w_llh <- function(u) { 27 | -0.5*gp$D*log(2*pi) - 0.5*determinant(gp$K, logarithm = T)$modulus[1] + 28 | -0.5*sum((u - gp$mu_hatX) * solve(gp$K, u - gp$mu_hatX)) 29 | } 30 | w_llh(w) 31 | w_llh_gr <- function(u) { 32 | -0.5 * (2 * solve(gp$K, (u - gp$mu_hatX)))[,1] 33 | } 34 | # Check grad, is right 35 | list((w_llh(w + ei(50)*eps) - w_llh(w))/eps, w_llh_gr(w)) 36 | 37 | 38 | y_llh <- function(u) { 39 | sum(log(ifelse(y > 0.5, logistic(u), 1-logistic(u)))) 40 | } 41 | y_llh(w) 42 | y_llh(w_true) 43 | y_llh_gr <- function(u) { 44 | (ifelse(y > 0.5, 45 | dlogistic(u) / logistic(u), 46 | -dlogistic(u)/ (1 - logistic(u)))) 47 | } 48 | # Check grad, it's right 49 | list((y_llh(w + ei(3)*eps) - y_llh(w))/eps, y_llh_gr(w)) 50 | # Check that y_llh optim works with grad, it does, can't use default method 51 | optim(w, y_llh, y_llh_gr, control=list(fnscale=-1), method='BFGS') 52 | 53 | predict_y <- function(x) { 54 | w_pred <- gp$predict(x) 55 | logistic(w_pred) 56 | } 57 | plot(predict_y(X), w_true) 58 | # Loop over two optimization steps 59 | for (i in 1:30) { 60 | cat('step', i, mean(abs(w - w_true)), "\t", mean(abs(y - logistic(w))), '\t', mean(w), "\n") 61 | # Optimization 1: Optimize w, keep GP params constant 62 | optim_w_func <- function(u) { 63 | w_llh(u) + y_llh(u) 64 | } 65 | optim_w_func_gr <- function(u) { 66 | w_llh_gr(u) + y_llh_gr(u) 67 | } 68 | cat('\tOpt 1', optim_w_func(w), '\t', w_llh(w), '\t', y_llh(w), "\n") 69 | # w <- optim(w, optim_w_func, control=list(fnscale=-1))$par 70 | w <- optim(w, optim_w_func, optim_w_func_gr, method='BFGS', control=list(fnscale=-1))$par 71 | cat('\tOpt 1', optim_w_func(w), '\t', w_llh(w), '\t', y_llh(w), "\n") 72 | 73 | # Optimization 2: Optimize GP params, keep w constant 74 | cat('\t\tOpt 2', gp$loglikelihood(), "\n") 75 | gp$update(Zall = w) 76 | cat('\t\tOpt 2', gp$loglikelihood(), "\n") 77 | } 78 | plot(w, w_true) 79 | plot(X[,1], y) 80 | points(X[,1], logistic(w_true), col=2) 81 | # This looks wrong 82 | points(X[,1], logistic(w), col=3) 83 | points(X[,1], logistic(gp$pred(X)), col=4) 84 | -------------------------------------------------------------------------------- /R/convert_X_with_formula.R: -------------------------------------------------------------------------------- 1 | #' @importFrom stats model.frame 2 | convert_X_with_formula <- function(X, convert_formula_data, formula) { 3 | stopifnot(is.data.frame(X)) 4 | data <- X 5 | # X might not have response var 6 | stopifnot(length(as.character(formula)) == 3) 7 | z_name <- as.character(formula)[2] 8 | if (!(z_name %in% colnames(data))) { 9 | data[[z_name]] <- 1 # Can't use NA 10 | } 11 | modfr <- model.frame(formula = formula, data = data) 12 | Xdf <- modfr[,2:ncol(modfr)] 13 | 14 | # Convert factor columns to integer 15 | # for (i in 1:ncol(Xdf)) { 16 | # if (is.factor(Xdf[, i])) { 17 | # # Check that levels match 18 | # 19 | # convert_formula_data$factors[[ 20 | # length(convert_formula_data$factors)+1 21 | # ]] <- list(index=i, 22 | # levels=levels(Xdf[[i]])) 23 | # Xdf[[i]] <- as.integer(Xdf[[i]]) 24 | # } 25 | # } 26 | factorinds <- sapply( 27 | convert_formula_data$factors, 28 | function(li) {li$index} 29 | ) 30 | for (iii in seq_along(factorinds)) { 31 | i <- factorinds[iii] 32 | # Check that levels match 33 | # Convert 34 | if (is.factor(Xdf[[i]])) { 35 | Xdf[[i]] <- as.integer(Xdf[[i]]) 36 | } else { 37 | # User can give in character of the level instead of proper factor 38 | Xdf[[i]] <- sapply( 39 | Xdf[[i]], 40 | function(x) { 41 | which(x == convert_formula_data$factors[[iii]]$levels) 42 | }) 43 | } 44 | } 45 | # # Convert char columns to integer 46 | # for (i in 1:ncol(Xdf)) { 47 | # if (is.character(Xdf[, i])) { 48 | # convert_formula_data$chars[[ 49 | # length(convert_formula_data$chars)+1 50 | # ]] <- list(index=i, 51 | # vals=sort(unique(Xdf[[i]]))) 52 | # Xdf[[i]] <- sapply(Xdf[[i]], 53 | # function(x) { 54 | # which(x==convert_formula_data$chars[[ 55 | # length(convert_formula_data$chars) 56 | # ]]$vals) 57 | # }) 58 | # } 59 | # } 60 | 61 | charinds <- sapply( 62 | convert_formula_data$chars, 63 | function(li) {li$index} 64 | ) 65 | for (ind in seq_along(charinds)) { 66 | i <- charinds[ind] 67 | # Check that levels match 68 | stopifnot(Xdf[[i]] %in% convert_formula_data$chars[[ind]]$vals) 69 | # Convert 70 | Xdf[[i]] <- sapply(Xdf[[i]], 71 | function(x) { 72 | which(x==convert_formula_data$chars[[ind]]$vals) 73 | }) 74 | } 75 | X <- as.matrix(Xdf) 76 | X 77 | } 78 | 79 | 80 | if (F) { 81 | 82 | n <- 30 83 | tdf <- data.frame(a=runif(n), b=runif(n), c=factor(sample(5:6,n,T)), d=runif(n), e=sample(letters[1:3], n,T)) 84 | tdf$z <- with(tdf, a+a*b+b^2) 85 | tdf[[3]] 86 | as.integer(tdf[[3]]) 87 | tdf 88 | gpf <- GauPro_kernel_model$new(X=tdf, Z=z ~ a + b + c + e, kernel='gauss') 89 | predict(gpf, tdf) 90 | } 91 | -------------------------------------------------------------------------------- /R/Gaussian_hessian.R: -------------------------------------------------------------------------------- 1 | #' Calculate Hessian for a GP with Gaussian correlation 2 | #' 3 | #' @param XX The vector at which to calculate the Hessian 4 | #' @param X The input points 5 | #' @param Z The output values 6 | #' @param Kinv The inverse of the correlation matrix 7 | #' @param mu_hat Estimate of mu 8 | #' @param theta Theta parameters for the correlation 9 | #' 10 | #' @return Matrix, the Hessian at XX 11 | #' @export 12 | #' 13 | #' @examples 14 | #' set.seed(0) 15 | #' n <- 40 16 | #' x <- matrix(runif(n*2), ncol=2) 17 | #' f1 <- function(a) {sin(2*pi*a[1]) + sin(6*pi*a[2])} 18 | #' y <- apply(x,1,f1) + rnorm(n,0,.01) 19 | #' gp <- GauPro(x,y, verbose=2, parallel=FALSE);gp$theta 20 | #' gp$hessian(c(.2,.75), useC=FALSE) # Should be -38.3, -5.96, -5.96, -389.4 as 2x2 matrix 21 | Gaussian_hessianR <- function(XX, X, Z, Kinv, mu_hat, theta) { 22 | n <- nrow(X) # number of points already in design 23 | d <- length(XX) # input dimensions 24 | Kinv_Zmu <- Kinv %*% (Z - mu_hat) #solve(R, Z - mu_hat) 25 | #d2K <- matrix() 26 | d2ZZ <- matrix(NA, d, d) 27 | #d2r <- numeric(n) 28 | exp_sum <- numeric(n) 29 | for (j in 1:n) { 30 | exp_sum[j] <- exp(-sum(theta * (XX - X[j, ])^2)) 31 | } 32 | for (i in 1:d) { # diagonal points 33 | d2K_dxidxi <- numeric(n) 34 | for (j in 1:n) { 35 | 36 | d2Kj_dxidxi <- (-2 * theta[i] + 4 * theta[i]^2 * (XX[i] - X[j, i])^2) * exp_sum[j] 37 | d2K_dxidxi[j] <- d2Kj_dxidxi 38 | } 39 | 40 | tval <- t(d2K_dxidxi) %*% Kinv_Zmu 41 | d2ZZ[i, i] <- tval 42 | } 43 | if (d > 1) { 44 | for (i in 1:(d-1)) { # off diagonal points 45 | for (k in (i+1):d) { 46 | 47 | d2K_dxidxk <- numeric(n) 48 | for (j in 1:n) { 49 | 50 | d2Kj_dxidxk <- 4 * theta[i] * theta[k] * (XX[i] - X[j, i]) * (XX[k] - X[j, k]) * exp_sum[j] 51 | d2K_dxidxk[j] <- d2Kj_dxidxk 52 | } 53 | 54 | tval <- t(d2K_dxidxk) %*% Kinv_Zmu 55 | d2ZZ[i, k] <- tval 56 | d2ZZ[k, i] <- tval 57 | } 58 | } 59 | } 60 | 61 | 62 | hess <- d2ZZ #t(d2K) %*% solve(R, Z - mu_hat) 63 | } 64 | 65 | 66 | #' Calculate Hessian for a GP with Gaussian correlation 67 | #' 68 | #' @param XX The vector at which to calculate the Hessian 69 | #' @param X The input points 70 | #' @param Z The output values 71 | #' @param Kinv The inverse of the correlation matrix 72 | #' @param mu_hat Estimate of mu 73 | #' @param theta Theta parameters for the correlation 74 | #' 75 | #' @return Matrix, the Hessian at XX 76 | #' @export 77 | #' 78 | #' @examples 79 | #' set.seed(0) 80 | #' n <- 40 81 | #' x <- matrix(runif(n*2), ncol=2) 82 | #' f1 <- function(a) {sin(2*pi*a[1]) + sin(6*pi*a[2])} 83 | #' y <- apply(x,1,f1) + rnorm(n,0,.01) 84 | #' gp <- GauPro(x,y, verbose=2, parallel=FALSE);gp$theta 85 | #' gp$hessian(c(.2,.75), useC=TRUE) # Should be -38.3, -5.96, -5.96, -389.4 as 2x2 matrix 86 | Gaussian_hessianC <- function(XX, X, Z, Kinv, mu_hat, theta) { 87 | print("Using C version") 88 | Gaussian_hessianCC(XX, X, Z, Kinv, mu_hat, theta) 89 | } 90 | -------------------------------------------------------------------------------- /scratch/scratch_kernel_RatQuad.R: -------------------------------------------------------------------------------- 1 | # Check numerically that gradient is correct for 1D 2 | # For RatQuad kernel 3 | set.seed(0) 4 | n <- 20 5 | x <- matrix(seq(0,1,length.out = n), ncol=1) 6 | f <- Vectorize(function(x) {sin(2*pi*x) + .5*sin(4*pi*x) +rnorm(1,0,.3)}) 7 | y <- f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 8 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=RatQuad$new(1, 1.5), parallel=FALSE, verbose=10, nug.est=T) 9 | gp$cool1Dplot() 10 | numDeriv::grad(func = function(x)gp$deviance(params=x[2:4], trend_params=x[1], nuglog=x[5]), x=c(-.8, 2,-1, .2, -4)) 11 | gp$deviance_grad(params = c(2,-1, .2), nug.update=T, nuglog=-4, trend_params=-.8) 12 | numDeriv::grad(func = function(x)gp$deviance(params=x[2:4], trend_params=x[1], nuglog=x[5]), x=c(gp$trend$m, gp$kernel$beta, gp$kernel$logalpha, gp$kernel$logs2, log(gp$nug,10))) 13 | gp$deviance_grad(params = c(gp$kernel$beta, gp$kernel$logalpha, gp$kernel$logs2), nug.update=T, nuglog=log(gp$nug,10), trend_params=gp$trend$b) 14 | 15 | # Check dC_dtheta 16 | m1 <- (gp$kernel$k(gp$X, beta=1,alpha=5) - gp$kernel$k(gp$X, beta=1-1e-6, alpha=5)) / 1e-6 17 | C_nonug <- gp$kernel$k(gp$X, beta=1, alpha=5) 18 | C <- C_nonug + gp$kernel$s2 * diag(gp$nug, nrow(C_nonug)) 19 | m2 <- gp$kernel$dC_dparams(params = c(1, 5, 1), X = gp$X, C = C, C_nonug = C_nonug)[1,,] 20 | summary(c(m1-m2))# %>% summary 21 | plot(m1, m2) 22 | 23 | gp$deviance_grad() 24 | dsign <- 1 25 | mm1 <- gp$kernel$dC_dparams(C = C, C_nonug = C_nonug, X=gp$X)[[1]] 26 | dsign <- -1 27 | mm2 <- gp$kernel$dC_dparams(C = C, C_nonug = C_nonug, X=gp$X)[[1]] 28 | plot(c(mm1[[1]]), c(mm2[[1]])) 29 | 30 | 31 | # Check dC_dlogs2 32 | beta <- gp$kernel$beta 33 | s2 <- gp$kernel$s2+.2 34 | nug <- gp$nug 35 | eps <- 1e-6 36 | m1 <- (gp$kernel$k(gp$X, beta=beta, s2=s2+eps) - gp$kernel$k(gp$X, beta=beta, s2=s2-eps)) / eps / 2 37 | C_nonug <- gp$kernel$k(gp$X, beta=beta, s2=s2) 38 | C <- C_nonug + s2 * diag(nug, nrow(C_nonug)) 39 | m2 <- gp$kernel$dC_dparams(params = log(c(beta, s2),10), X = gp$X, C = C, C_nonug = C)[[1]][[2]] 40 | c(m1 * s2 * log(10) -m2) %>% summary 41 | plot(c(m1 * s2 * log(10)), c(m2)) 42 | 43 | 44 | # Check C_dC_dparams 45 | params <- c(1.2,.8) 46 | nug <- .001 47 | gp$deviance(params=params, nug=nug) 48 | gp$deviance_grad(params=params, nug=nug, nug.update=T) 49 | gp$deviance_fngr(params=params, nug=nug, nug.update=T) 50 | microbenchmark::microbenchmark(sep={gp$deviance(params=params, nug=nug);gp$deviance_grad(params=params, nug=nug, nug.update=T)}, fngr=gp$deviance_fngr(params=params, nug=nug, nug.update=T)) 51 | 52 | 53 | 54 | 55 | # Check 2D 56 | set.seed(0) 57 | n <- 30 58 | x <- lhs::maximinLHS(n=n, k=2) 59 | f <- function(x) {sin(2*pi*x[1]) + .5*sin(4*pi*x[1]) +rnorm(1,0,.03) + x[2]^2} 60 | y <- apply(x, 1, f) #f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 61 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=RatQuad$new(c(1, 1)), parallel=FALSE, verbose=10, nug.est=T) 62 | ContourFunctions::cf(gp$predict, pts=x, batchmax=Inf) 63 | ContourFunctions::cf(f, pts=x) 64 | numDeriv::grad(func = function(x)gp$deviance(params = x[1:3], nuglog=x[4]), x=c(1,1, 1, -4)) 65 | gp$deviance_grad(params = c(1,1,1), nug.update=T, nuglog=-4) 66 | -------------------------------------------------------------------------------- /scratch/BestUnbiasedLinearPredictors.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Best Unbiased Linear Predictors" 3 | author: "Collin Erickson" 4 | date: "`r Sys.Date()`" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{Vignette Title} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | %\VignetteEncoding{UTF-8} 10 | --- 11 | 12 | Here I will derive the best unbiased linear predictors for Gaussian Process 13 | regression models. 14 | 15 | Let $X$ be the $n$ by $d$ matrix whose $n$ rows are $d$ dimensional vectors 16 | from the input space 17 | where the output has been measured. 18 | Let $Y$ be the measured values. 19 | 20 | Let $x$ be a new design point, with output $y(x)$. 21 | 22 | ## What is a BLUP? 23 | 24 | The best linear unbiased predictor (BLUP) is a predictor of $y(x)$ 25 | with three properties: 26 | * Linear: It is a linear combination of $Y$. 27 | * Unbiased: Its expectation is the true value. 28 | * Best: Of all linear and unbiased predictors, it has the 29 | minimum variance. 30 | 31 | 32 | 33 | ## Mean 0 34 | 35 | If 36 | 37 | 38 | 39 | ```{r setup, include = FALSE} 40 | knitr::opts_chunk$set( 41 | collapse = TRUE, 42 | comment = "#>" 43 | ) 44 | ``` 45 | 46 | Vignettes are long form documentation commonly included in packages. Because they are part of the distribution of the package, they need to be as compact as possible. The `html_vignette` output type provides a custom style sheet (and tweaks some options) to ensure that the resulting html is as small as possible. The `html_vignette` format: 47 | 48 | - Never uses retina figures 49 | - Has a smaller default figure size 50 | - Uses a custom CSS stylesheet instead of the default Twitter Bootstrap style 51 | 52 | ## Vignette Info 53 | 54 | Note the various macros within the `vignette` section of the metadata block above. These are required in order to instruct R how to build the vignette. Note that you should change the `title` field and the `\VignetteIndexEntry` to match the title of your vignette. 55 | 56 | ## Styles 57 | 58 | The `html_vignette` template includes a basic CSS theme. To override this theme you can specify your own CSS in the document metadata as follows: 59 | 60 | output: 61 | rmarkdown::html_vignette: 62 | css: mystyles.css 63 | 64 | ## Figures 65 | 66 | The figure sizes have been customised so that you can easily put two images side-by-side. 67 | 68 | ```{r, fig.show='hold'} 69 | plot(1:10) 70 | plot(10:1) 71 | ``` 72 | 73 | You can enable figure captions by `fig_caption: yes` in YAML: 74 | 75 | output: 76 | rmarkdown::html_vignette: 77 | fig_caption: yes 78 | 79 | Then you can use the chunk option `fig.cap = "Your figure caption."` in **knitr**. 80 | 81 | ## More Examples 82 | 83 | You can write math expressions, e.g. $Y = X\beta + \epsilon$, footnotes^[A footnote here.], and tables, e.g. using `knitr::kable()`. 84 | 85 | ```{r, echo=FALSE, results='asis'} 86 | knitr::kable(head(mtcars, 10)) 87 | ``` 88 | 89 | Also a quote using `>`: 90 | 91 | > "He who gives up [code] safety for [code] speed deserves neither." 92 | ([via](https://twitter.com/hadleywickham/status/504368538874703872)) 93 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # GauPro 0.2.17.9000 2 | 3 | # GauPro 0.2.17 4 | 5 | Fixed a test that caused error on CRAN. 6 | 7 | Changed the class name of GauPro_base() from "GauPro"" to "GauPro_base" to avoid 8 | documentation error. 9 | 10 | Accepted to CRAN on 11/21/25. 11 | 12 | # GauPro 0.2.16 13 | 14 | Fixed a test that caused error on CRAN. 15 | 16 | Accepted to CRAN on 8/26/25. 17 | 18 | # GauPro 0.2.15 19 | 20 | Fixed a test that caused error on CRAN tests. 21 | 22 | Accepted to CRAN on 4/8/25. 23 | 24 | # GauPro 0.2.14 25 | 26 | Bug fix from predictions when there are no categorical predictors and formula 27 | input is used. 28 | 29 | Added isotropic option for Gaussian, Exponential, Matern 3/2, Matern 5/2, 30 | and Triangle kernels. 31 | 32 | Combined README and main vignette for better documentation. 33 | 34 | Accepted to CRAN on 3/9/25. 35 | 36 | # GauPro 0.2.13 37 | 38 | Fixed Suggests issue to get back on CRAN. Packages in Suggests were moved 39 | to Depends, removed, or protected by requireNamespace. 40 | 41 | Accepted to CRAN on 9/26/24. 42 | 43 | # GauPro 0.2.12 44 | 45 | Fixed CRAN warning. 46 | 47 | Added `k_xyz(...)` alias for kernels (replaces `xyz$new(...)`) 48 | 49 | Accepted to CRAN on 6/10/24. 50 | 51 | # GauPro 0.2.11 52 | 53 | Fixed unreliable test to keep it on CRAN (again). 54 | 55 | # GauPro 0.2.8 56 | 57 | Fixed unreliable test to keep it on CRAN. 58 | 59 | Accepted to CRAN on 2/27/23. 60 | 61 | # GauPro 0.2.7 62 | 63 | Improved summary, importance, plots. 64 | 65 | Added gradpredvar, AugmentedEI, CorrectedEI, optimize_fn. 66 | 67 | GauPro was removed from CRAN on 1/25/23, this puts it back on CRAN. 68 | Accepted to CRAN on 2/12/23. 69 | 70 | # GauPro 0.2.6 71 | 72 | GP kernel model maxEI can now be run using mixopt to account for discrete 73 | inputs. 74 | 75 | Improved GP kernel model workability when input is formula and data frame. 76 | 77 | Added importance for kernel model, greatly improved summary. 78 | 79 | Fixed error in tests to prevent being removed from CRAN. 80 | 81 | Accepted to CRAN on 11/24/22. 82 | 83 | # GauPro 0.2.5 84 | 85 | Added kernels for factors. 86 | 87 | Changed default number of restarts to zero, and added checking more starting 88 | points. Should make it faster. 89 | 90 | Can give in data as data and formula instead of matrix and vector. 91 | 92 | Package was removed from CRAN on 10/3/22. This fixes the issue. 93 | 94 | Accepted to CRAN on 11/14/22. 95 | 96 | # GauPro 0.2.4 97 | 98 | Very minor change in Rcpp code to remove CRAN error. 99 | 100 | Accepted to CRAN on 4/11/21. 101 | 102 | # GauPro 0.2.3 103 | 104 | Minor changes. 105 | 106 | Accepted to CRAN on 3/28/21, but was notified of error on same day. 107 | 108 | # GauPro 0.2.2 109 | 110 | Fixing Valgrind error from 0.2.1. 111 | 112 | Accepted to CRAN on 9/11/2017. 113 | 114 | # GauPro 0.2.1 115 | 116 | Fixing minor errors from the 0.2.0 version. 117 | 118 | 119 | # GauPro 0.2.0 120 | 121 | Added kernel models that use kernels and trends. 122 | 123 | # GauPro 0.1.0 124 | 125 | Releasing for the first time. 126 | 127 | Accepted by CRAN on 10/11/16 128 | -------------------------------------------------------------------------------- /src/deviance_grad.cpp: -------------------------------------------------------------------------------- 1 | //#include 2 | #include 3 | //using namespace Rcpp; 4 | using namespace arma; 5 | 6 | 7 | // [[Rcpp::export]] 8 | arma::vec deviance_grad_theta(arma::mat X, arma::mat K, arma::mat Kinv, arma::vec y) { 9 | int N = X.n_rows; 10 | int D = X.n_cols; 11 | arma::mat Kinv_y = Kinv * y; 12 | arma::mat t2amat = (trans(y) * Kinv_y); 13 | double t2a = -N / t2amat(0,0); 14 | arma::vec dD = zeros(D); 15 | double t1; 16 | arma::mat t2 = zeros(1,1); 17 | arma::mat dK = zeros(N,N); 18 | for(int i = 0; i < D; i++) { 19 | dK = K; 20 | for(int j = 0; j < N; j++) { 21 | for(int k = 0; k < N; k++) { 22 | // Doesn't like pow for some reason, but it works 23 | dK(j, k) = - pow(X(j,i) - X(k,i), 2) * dK(j, k); 24 | } 25 | } 26 | t1 = 0; 27 | for (int ii = 0; ii < N; ii++) { 28 | t1 += sum(Kinv.row(ii) * dK.col(ii)); 29 | } 30 | t2 = t2a * trans(Kinv_y) * dK * Kinv_y; 31 | dD[i] = 2 * (t1 + t2(0,0)); 32 | } 33 | return dD; 34 | } 35 | 36 | // [[Rcpp::export]] 37 | double deviance_grad_nug(arma::mat X, arma::mat K, arma::mat Kinv, arma::vec y) { 38 | int N = X.n_rows; 39 | arma::mat Kinv_y = Kinv * y; 40 | arma::mat t2amat = (trans(y) * Kinv_y); 41 | double t2a = -N / t2amat(0,0); 42 | double dD = 0; 43 | double t1; 44 | arma::mat t2 = zeros(1,1); 45 | //arma::mat dK = diagmat(ones(N)); # dK is identity 46 | t1 = 0; // just the trace 47 | for (int ii = 0; ii < N; ii++) { 48 | t1 += Kinv(ii,ii); //sum(Kinv.row(ii) * dK.col(ii)); 49 | } 50 | t2 = t2a * trans(Kinv_y) * Kinv_y; 51 | dD = t1 + t2(0,0); 52 | return dD; 53 | } 54 | 55 | 56 | // [[Rcpp::export]] 57 | arma::vec deviance_grad_joint(arma::mat X, arma::mat K, arma::mat Kinv, arma::vec y) { 58 | int N = X.n_rows; 59 | int D = X.n_cols; 60 | arma::mat Kinv_y = Kinv * y; 61 | arma::mat t2amat = (trans(y) * Kinv_y); 62 | double t2a = -N / t2amat(0,0); 63 | arma::vec dD = zeros(D + 1); 64 | double t1; 65 | arma::mat t2 = zeros(1,1); 66 | arma::mat dK = zeros(N,N); 67 | // over thetas 68 | for(int i = 0; i < D; i++) { 69 | dK = K; 70 | for(int j = 0; j < N; j++) { 71 | for(int k = 0; k < N; k++) { 72 | // Doesn't like pow for some reason, but it works 73 | dK(j, k) = - pow(X(j,i) - X(k,i), 2) * dK(j, k); 74 | } 75 | } 76 | t1 = 0; 77 | for (int ii = 0; ii < N; ii++) { 78 | t1 += sum(Kinv.row(ii) * dK.col(ii)); 79 | } 80 | t2 = t2a * trans(Kinv_y) * dK * Kinv_y; 81 | dD[i] = 2 * (t1 + t2(0,0)); 82 | } 83 | // for nugget 84 | t1 = 0; // just the trace 85 | for (int ii = 0; ii < N; ii++) { 86 | t1 += Kinv(ii,ii); //sum(Kinv.row(ii) * dK.col(ii)); 87 | } 88 | t2 = t2a * trans(Kinv_y) * Kinv_y; 89 | dD[D] = t1 + t2(0,0); 90 | return dD; 91 | } 92 | 93 | 94 | 95 | 96 | // You can include R code blocks in C++ files processed with sourceCpp 97 | // (useful for testing and development). The R code will be automatically 98 | // run after the compilation. 99 | // 100 | 101 | /*** R 102 | #timesTwo(42) 103 | */ 104 | -------------------------------------------------------------------------------- /scratch/scratch_kernel_Gaussian_l.R: -------------------------------------------------------------------------------- 1 | # Check numerically that gradient is correct for 1D 2 | # For Gaussian_l kernel 3 | set.seed(0) 4 | n <- 20 5 | x <- matrix(seq(0,1,length.out = n), ncol=1) 6 | f <- Vectorize(function(x) {sin(2*pi*x) + .5*sin(4*pi*x) +rnorm(1,0,.3)}) 7 | y <- f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 8 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian_l$new(1), parallel=FALSE, verbose=10, nug.est=T) 9 | gp$cool1Dplot() 10 | numDeriv::grad(func = function(x) gp$deviance(params=x[1:2], nuglog=x[3]), x=c(2,1, -6)) 11 | gp$deviance_grad(params = c(2,1), nug.update=T, nuglog=-6) 12 | dgc <- function() { 13 | y <- c(rnorm(2,0,1), rnorm(1,-4,1)) 14 | v1 <- numDeriv::grad(func = function(x) gp$deviance(params=x[1:2], nuglog=x[3]), x=y) 15 | v2 <- gp$deviance_grad(params = y[1:2], nug.update=T, nuglog=y[3]) 16 | cbind(y, v1, v2, v1-v2, v1/v2) 17 | } 18 | numDeriv::grad(func = function(x) gp$deviance(params=x[1:2], nuglog=x[3]), 19 | x=c(log(gp$kernel$l,10),gp$kernel$logs2, log(gp$nug,10))) 20 | gp$deviance_grad(params = c(log(gp$kernel$l,10),gp$kernel$logs2), nug.update=T, nuglog=log(gp$nug,10)) 21 | 22 | N <- 1e2 23 | rs <- replicate(N, dgc()) 24 | to <- sapply(1:N, function(i) { 25 | maxerr <- max(abs(rs[,4,i])) 26 | c(rs[1,1,i], rs[2,1,i], rs[3,1,i], log(maxerr,10))}) 27 | plot(to[1,], to[4,]) 28 | plot(to[2,], to[4,]) 29 | plot(to[3,], to[4,]) 30 | 31 | 32 | # Check dC_dlogl 33 | l <- gp$kernel$l 34 | s2 <- gp$kernel$s2 35 | nug <- 1e-4; lognug=log(nug,10) 36 | eps <- 1e-8 37 | m1 <- (gp$kernel$k(gp$X, l=l+eps, s2=s2) - gp$kernel$k(gp$X, l=l-eps, s2=s2)) / eps / 2 38 | C_nonug <- gp$kernel$k(gp$X, l=l, s2=s2) 39 | C <- C_nonug + diag(nug, nrow(C_nonug)) 40 | m2 <- gp$kernel$dC_dparams(params = c(log(l,10), s2), X = gp$X, C = C, C_nonug = C)[[1]][[1]] 41 | c(m1 * l * log(10) -m2) %>% summary 42 | # Check dC_dlogs2 43 | m1 <- (gp$kernel$k(gp$X, l=l, s2=s2+eps) - gp$kernel$k(gp$X, l=l, s2=s2-eps)) / eps / 2 44 | C_nonug <- gp$kernel$k(gp$X, l=l, s2=s2) 45 | C <- C_nonug + s2 * diag(nug, nrow(C_nonug)) 46 | m2 <- gp$kernel$dC_dparams(params = log(c(l, s2),10), X = gp$X, C = C, C_nonug = C)[[1]][[2]] 47 | c(m1 * s2 * log(10) -m2) %>% summary 48 | 49 | numDeriv::grad(func = function(x) gp$deviance(params=x[1:2], nuglog=x[3]), 50 | x=c(log(c(l,s2),10),log(nug,10))) 51 | gp$deviance_grad(params = log(c(l, s2),10), nug.update=T, nuglog=lognug) 52 | 53 | 54 | 55 | optim(par = c(gp$kernel$logl, gp$kernel$logs2, log(gp$nug,10)), 56 | fn = function(x) gp$deviance(params = x[1:2], nuglog=x[3]), 57 | gr = function(x) gp$deviance_grad(params = x[1:2], nuglog=x[3]) 58 | ) 59 | 60 | 61 | # Check 2D 62 | set.seed(0) 63 | n <- 30 64 | x <- lhs::maximinLHS(n=n, k=2) 65 | f <- function(x) {sin(2*pi*x[1]) + .5*sin(4*pi*x[1]) +rnorm(1,0,.03) + x[2]^2} 66 | y <- apply(x, 1, f) #f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 67 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian_l$new(c(1, 1)), parallel=FALSE, verbose=10, nug.est=T) 68 | ContourFunctions::cf(gp$predict, pts=x) 69 | ContourFunctions::cf(f, pts=x) 70 | numDeriv::grad(func = function(x)gp$deviance(params = x[1:3], nuglog=x[4]), x=c(1,1, 1, -4)) 71 | gp$deviance_grad(params = c(1,1,1), nug.update=T, nuglog=-4) 72 | -------------------------------------------------------------------------------- /scratch/scratch_kernel_Sum.R: -------------------------------------------------------------------------------- 1 | # Check numerically that gradient is correct for 1D 2 | # For Sum kernel 3 | set.seed(0) 4 | n <- 20 5 | x <- matrix(seq(0,1,length.out = n), ncol=1) 6 | f <- Vectorize(function(x) {sin(2*pi*x) + .5*sin(4*pi*x) +rnorm(1,0,.03)}) 7 | y <- f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 8 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian_beta$new(3)+Matern32$new(-1), parallel=FALSE, verbose=10, nug.est=T) 9 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Exponential$new(3)+Matern52$new(-1), parallel=FALSE, verbose=10, nug.est=T) 10 | gp$cool1Dplot() 11 | params <- c(2,-0, -1,1, -5) 12 | numDeriv::grad(func = function(x)gp$deviance(params=x[1:4], nuglog=x[5]), x=params) 13 | gp$deviance_grad(params = params[1:4], nug.update=T, nuglog=params[5]) 14 | numDeriv::grad(func = function(x)gp$deviance(params=x[1:4], nuglog=x[5]), x=c(gp$kernel$k1$beta, gp$kernel$k1$logs2, gp$kernel$k2$beta, gp$kernel$k2$logs2, log(gp$nug,10))) 15 | gp$deviance_grad(params = c(gp$kernel$k1$beta, gp$kernel$k1$logs2, gp$kernel$k2$beta, gp$kernel$k2$logs2), nug.update=T, nuglog=log(gp$nug,10)) 16 | 17 | # Check dC_dtheta 18 | # m1 <- (gp$kernel$k(gp$X, beta=1) - gp$kernel$k(gp$X, beta=1-1e-6)) / 1e-6 19 | # C_nonug <- gp$kernel$k(gp$X, beta=1) 20 | # C <- C_nonug + gp$kernel$s2 * diag(gp$nug, nrow(C_nonug)) 21 | # m2 <- gp$kernel$dC_dparams(params = c(1, 1), X = gp$X, C = C, C_nonug = C_nonug)[[1]][[1]] 22 | # summary(c(m1-m2))# %>% summary 23 | # plot(m1, m2) 24 | 25 | gp$deviance_grad() 26 | dsign <- 1 27 | mm1 <- gp$kernel$dC_dparams(C = C, C_nonug = C_nonug, X=gp$X)[[1]] 28 | dsign <- -1 29 | mm2 <- gp$kernel$dC_dparams(C = C, C_nonug = C_nonug, X=gp$X)[[1]] 30 | plot(c(mm1[[1]]), c(mm2[[1]])) 31 | 32 | 33 | # Check dC_dlogs2 34 | beta <- gp$kernel$beta 35 | s2 <- gp$kernel$s2+.2 36 | nug <- gp$nug 37 | eps <- 1e-6 38 | m1 <- (gp$kernel$k(gp$X, beta=beta, s2=s2+eps) - gp$kernel$k(gp$X, beta=beta, s2=s2-eps)) / eps / 2 39 | C_nonug <- gp$kernel$k(gp$X, beta=beta, s2=s2) 40 | C <- C_nonug + s2 * diag(nug, nrow(C_nonug)) 41 | m2 <- gp$kernel$dC_dparams(params = log(c(beta, s2),10), X = gp$X, C = C, C_nonug = C)[[1]][[2]] 42 | c(m1 * s2 * log(10) -m2) %>% summary 43 | plot(c(m1 * s2 * log(10)), c(m2)) 44 | 45 | 46 | # Check C_dC_dparams 47 | params <- c(1.2,.8, .9, .4) 48 | nug <- .001 49 | gp$deviance(params=params, nug=nug) 50 | gp$deviance_grad(params=params, nug=nug, nug.update=T) 51 | gp$deviance_fngr(params=params, nug=nug, nug.update=T) 52 | numDeriv::grad(func = function(x)gp$deviance(params=x[1:4], nuglog=x[5]), x=c(params, log(nug,10))) 53 | microbenchmark::microbenchmark(sep={gp$deviance(params=params, nug=nug);gp$deviance_grad(params=params, nug=nug, nug.update=T)}, fngr=gp$deviance_fngr(params=params, nug=nug, nug.update=T)) 54 | 55 | 56 | 57 | 58 | # Check 2D 59 | set.seed(0) 60 | n <- 30 61 | x <- lhs::maximinLHS(n=n, k=2) 62 | f <- function(x) {sin(2*pi*x[1]) + .5*sin(4*pi*x[1]) +rnorm(1,0,.03) + x[2]^2} 63 | y <- apply(x, 1, f) #f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 64 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Sum$new(c(1, 1)), parallel=FALSE, verbose=10, nug.est=T) 65 | ContourFunctions::cf(gp$predict, pts=x, batchmax=Inf) 66 | ContourFunctions::cf(f, pts=x) 67 | numDeriv::grad(func = function(x)gp$deviance(params = x[1:3], nuglog=x[4]), x=c(1,1, 1, -4)) 68 | gp$deviance_grad(params = c(1,1,1), nug.update=T, nuglog=-4) 69 | -------------------------------------------------------------------------------- /.github/workflows/rhub.yaml: -------------------------------------------------------------------------------- 1 | # R-hub's generic GitHub Actions workflow file. It's canonical location is at 2 | # https://github.com/r-hub/actions/blob/v1/workflows/rhub.yaml 3 | # You can update this file to a newer version using the rhub2 package: 4 | # 5 | # rhub::rhub_setup() 6 | # 7 | # It is unlikely that you need to modify this file manually. 8 | 9 | name: R-hub 10 | run-name: "${{ github.event.inputs.id }}: ${{ github.event.inputs.name || format('Manually run by {0}', github.triggering_actor) }}" 11 | 12 | on: 13 | workflow_dispatch: 14 | inputs: 15 | config: 16 | description: 'A comma separated list of R-hub platforms to use.' 17 | type: string 18 | default: 'linux,windows,macos' 19 | name: 20 | description: 'Run name. You can leave this empty now.' 21 | type: string 22 | id: 23 | description: 'Unique ID. You can leave this empty now.' 24 | type: string 25 | 26 | jobs: 27 | 28 | setup: 29 | runs-on: ubuntu-latest 30 | outputs: 31 | containers: ${{ steps.rhub-setup.outputs.containers }} 32 | platforms: ${{ steps.rhub-setup.outputs.platforms }} 33 | 34 | steps: 35 | # NO NEED TO CHECKOUT HERE 36 | - uses: r-hub/actions/setup@v1 37 | with: 38 | config: ${{ github.event.inputs.config }} 39 | id: rhub-setup 40 | 41 | linux-containers: 42 | needs: setup 43 | if: ${{ needs.setup.outputs.containers != '[]' }} 44 | runs-on: ubuntu-latest 45 | name: ${{ matrix.config.label }} 46 | strategy: 47 | fail-fast: false 48 | matrix: 49 | config: ${{ fromJson(needs.setup.outputs.containers) }} 50 | container: 51 | image: ${{ matrix.config.container }} 52 | 53 | steps: 54 | - uses: r-hub/actions/checkout@v1 55 | - uses: r-hub/actions/platform-info@v1 56 | with: 57 | token: ${{ secrets.RHUB_TOKEN }} 58 | job-config: ${{ matrix.config.job-config }} 59 | - uses: r-hub/actions/setup-deps@v1 60 | with: 61 | token: ${{ secrets.RHUB_TOKEN }} 62 | job-config: ${{ matrix.config.job-config }} 63 | - uses: r-hub/actions/run-check@v1 64 | with: 65 | token: ${{ secrets.RHUB_TOKEN }} 66 | job-config: ${{ matrix.config.job-config }} 67 | 68 | other-platforms: 69 | needs: setup 70 | if: ${{ needs.setup.outputs.platforms != '[]' }} 71 | runs-on: ${{ matrix.config.os }} 72 | name: ${{ matrix.config.label }} 73 | strategy: 74 | fail-fast: false 75 | matrix: 76 | config: ${{ fromJson(needs.setup.outputs.platforms) }} 77 | 78 | steps: 79 | - uses: r-hub/actions/checkout@v1 80 | - uses: r-hub/actions/setup-r@v1 81 | with: 82 | job-config: ${{ matrix.config.job-config }} 83 | token: ${{ secrets.RHUB_TOKEN }} 84 | - uses: r-hub/actions/platform-info@v1 85 | with: 86 | token: ${{ secrets.RHUB_TOKEN }} 87 | job-config: ${{ matrix.config.job-config }} 88 | - uses: r-hub/actions/setup-deps@v1 89 | with: 90 | job-config: ${{ matrix.config.job-config }} 91 | token: ${{ secrets.RHUB_TOKEN }} 92 | - uses: r-hub/actions/run-check@v1 93 | with: 94 | job-config: ${{ matrix.config.job-config }} 95 | token: ${{ secrets.RHUB_TOKEN }} 96 | -------------------------------------------------------------------------------- /scratch/scratch_kernel_product.R: -------------------------------------------------------------------------------- 1 | # Check numerically that gradient is correct for 1D 2 | # For Sum kernel 3 | set.seed(0) 4 | n <- 20 5 | x <- matrix(seq(0,1,length.out = n), ncol=1) 6 | f <- Vectorize(function(x) {sin(2*pi*x) + .5*sin(4*pi*x) +rnorm(1,0,.3)}) 7 | y <- f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 8 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian_beta$new(3, .2)*Matern32$new(-1, .1), parallel=FALSE, verbose=10, nug.est=T) 9 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Exponential$new(3, .9)*Matern52$new(-1, .8), parallel=FALSE, verbose=10, nug.est=T) 10 | gp$cool1Dplot() 11 | params <- c(.2,-0.3, -1,1, -5) 12 | numDeriv::grad(func = function(x)gp$deviance(params=x[1:4], nuglog=x[5]), x=params) 13 | gp$deviance_grad(params = params[1:4], nug.update=T, nuglog=params[5]) 14 | numDeriv::grad(func = function(x)gp$deviance(params=x[1:4], nuglog=x[5]), x=c(gp$kernel$k1$beta, gp$kernel$k1$logs2, gp$kernel$k2$beta, gp$kernel$k2$logs2, log(gp$nug,10))) 15 | gp$deviance_grad(params = c(gp$kernel$k1$beta, gp$kernel$k1$logs2, gp$kernel$k2$beta, gp$kernel$k2$logs2), nug.update=T, nuglog=log(gp$nug,10)) 16 | 17 | # Check dC_dtheta 18 | # m1 <- (gp$kernel$k(gp$X, beta=1) - gp$kernel$k(gp$X, beta=1-1e-6)) / 1e-6 19 | # C_nonug <- gp$kernel$k(gp$X, beta=1) 20 | # C <- C_nonug + gp$kernel$s2 * diag(gp$nug, nrow(C_nonug)) 21 | # m2 <- gp$kernel$dC_dparams(params = c(1, 1), X = gp$X, C = C, C_nonug = C_nonug)[[1]][[1]] 22 | # summary(c(m1-m2))# %>% summary 23 | # plot(m1, m2) 24 | 25 | gp$deviance_grad() 26 | dsign <- 1 27 | mm1 <- gp$kernel$dC_dparams(C = C, C_nonug = C_nonug, X=gp$X)[[1]] 28 | dsign <- -1 29 | mm2 <- gp$kernel$dC_dparams(C = C, C_nonug = C_nonug, X=gp$X)[[1]] 30 | plot(c(mm1[[1]]), c(mm2[[1]])) 31 | 32 | 33 | # Check dC_dlogs2 34 | beta <- gp$kernel$beta 35 | s2 <- gp$kernel$s2+.2 36 | nug <- gp$nug 37 | eps <- 1e-6 38 | m1 <- (gp$kernel$k(gp$X, beta=beta, s2=s2+eps) - gp$kernel$k(gp$X, beta=beta, s2=s2-eps)) / eps / 2 39 | C_nonug <- gp$kernel$k(gp$X, beta=beta, s2=s2) 40 | C <- C_nonug + s2 * diag(nug, nrow(C_nonug)) 41 | m2 <- gp$kernel$dC_dparams(params = log(c(beta, s2),10), X = gp$X, C = C, C_nonug = C)[[1]][[2]] 42 | c(m1 * s2 * log(10) -m2) %>% summary 43 | plot(c(m1 * s2 * log(10)), c(m2)) 44 | 45 | 46 | # Check C_dC_dparams 47 | params <- c(1.2,.8, .9, .4) 48 | nug <- .001 49 | gp$deviance(params=params, nug=nug) 50 | gp$deviance_grad(params=params, nug=nug, nug.update=T) 51 | gp$deviance_fngr(params=params, nug=nug, nug.update=T) 52 | numDeriv::grad(func = function(x)gp$deviance(params=x[1:4], nuglog=x[5]), x=c(params, log(nug,10))) 53 | microbenchmark::microbenchmark(sep={gp$deviance(params=params, nug=nug);gp$deviance_grad(params=params, nug=nug, nug.update=T)}, fngr=gp$deviance_fngr(params=params, nug=nug, nug.update=T)) 54 | 55 | 56 | 57 | 58 | # Check 2D 59 | set.seed(0) 60 | n <- 30 61 | x <- lhs::maximinLHS(n=n, k=2) 62 | f <- function(x) {sin(2*pi*x[1]) + .5*sin(4*pi*x[1]) +rnorm(1,0,.03) + x[2]^2} 63 | y <- apply(x, 1, f) #f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 64 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=Sum$new(c(1, 1)), parallel=FALSE, verbose=10, nug.est=T) 65 | ContourFunctions::cf(gp$predict, pts=x, batchmax=Inf) 66 | ContourFunctions::cf(f, pts=x) 67 | numDeriv::grad(func = function(x)gp$deviance(params = x[1:3], nuglog=x[4]), x=c(1,1, 1, -4)) 68 | gp$deviance_grad(params = c(1,1,1), nug.update=T, nuglog=-4) 69 | -------------------------------------------------------------------------------- /scratch/gradfuncarray.cpp: -------------------------------------------------------------------------------- 1 | //This ended up being 5x slower than using apply and R matrix operations, 2 | // so not going to use it 3 | // Below were in GauPro_init.c 4 | 5 | //extern SEXP _GauPro_gradfuncarray(SEXP, SEXP, SEXP); 6 | //extern SEXP _GauPro_gradfuncarray2(SEXP, SEXP, SEXP); 7 | 8 | //{"_GauPro_gradfuncarray", (DL_FUNC) &_GauPro_gradfuncarray, 3}, 9 | //{"_GauPro_gradfuncarray2", (DL_FUNC) &_GauPro_gradfuncarray2, 3}, 10 | 11 | 12 | #include 13 | using namespace Rcpp; 14 | 15 | //' Calculate gradfunc in optimization to speed up. 16 | //' 17 | //' Doesn't need to be exported, should only be useful in functions. 18 | //' @param dC_dparams Derivative matrix for covariance function wrt kernel parameters 19 | //' @param C Covariance matrix 20 | //' @param Cinv_yminusmu Vector that is the inverse of C times y minus the mean. 21 | //' @return Vector, one value for each parameter 22 | //' @examples 23 | //' # corr_gauss_dCdX(matrix(c(1,0,0,1),2,2),c(1,1)) 24 | //' @export 25 | // [[Rcpp::export]] 26 | arma::vec gradfuncarray(arma::cube dC_dparams, arma::mat C, arma::vec Cinv_yminusmu) { 27 | int d1 = dC_dparams.n_rows; 28 | int d2 = dC_dparams.n_cols; 29 | int d3 = dC_dparams.n_slices; 30 | arma::vec out(d1); 31 | double t1; 32 | double t2; 33 | arma::mat tmat; 34 | arma::mat tmat2; 35 | arma::vec tvec1; 36 | for (int i = 0; i < d1; i++) { 37 | tmat = dC_dparams.subcube(i,0,0,i,d2-1,d3-1); 38 | // t1 = arma::sum((arma::solve(C, dC_dparams.subcube(0,0,i,d1-1,d2-2,i))).diag()); 39 | // t2 = arma::sum(Cinv_yminusmu, (dC_dparams.subcube(0,0,i,d1-1,d2-2,i) * Cinv_yminusmu)); 40 | tmat2 = arma::solve(C, tmat); 41 | t1 = arma::sum(tmat2.diag()); 42 | tvec1 = tmat * Cinv_yminusmu; 43 | t2 = arma::dot(Cinv_yminusmu, tvec1); // * (tmat * Cinv_yminusmu)); 44 | out(i) = t1 - t2; 45 | } 46 | 47 | return out; 48 | } 49 | 50 | 51 | //' Calculate gradfunc in optimization to speed up. 52 | //' NEEDS TO APERM dC_dparams 53 | //' Doesn't need to be exported, should only be useful in functions. 54 | //' @param dC_dparams Derivative matrix for covariance function wrt kernel parameters 55 | //' @param C Covariance matrix 56 | //' @param Cinv_yminusmu Vector that is the inverse of C times y minus the mean. 57 | //' @return Vector, one value for each parameter 58 | //' @examples 59 | //' # corr_gauss_dCdX(matrix(c(1,0,0,1),2,2),c(1,1)) 60 | //' @export 61 | // [[Rcpp::export]] 62 | arma::vec gradfuncarray2(arma::cube dC_dparams, arma::mat C, arma::vec Cinv_yminusmu) { 63 | // int d1 = dC_dparams.n_rows; 64 | // int d2 = dC_dparams.n_cols; 65 | int d3 = dC_dparams.n_slices; 66 | arma::vec out(d3); 67 | double t1; 68 | double t2; 69 | // arma::mat tmat; 70 | arma::mat tmat2; 71 | arma::vec tvec1; 72 | for (int i = 0; i < d3; i++) { 73 | // tmat = dC_dparams.subcube(i,0,0,i,d2-1,d3-1); 74 | // t1 = arma::sum((arma::solve(C, dC_dparams.subcube(0,0,i,d1-1,d2-2,i))).diag()); 75 | // t2 = arma::sum(Cinv_yminusmu, (dC_dparams.subcube(0,0,i,d1-1,d2-2,i) * Cinv_yminusmu)); 76 | tmat2 = arma::solve(C, dC_dparams.slice(i)); 77 | t1 = arma::sum(tmat2.diag()); 78 | tvec1 = dC_dparams.slice(i) * Cinv_yminusmu; 79 | t2 = arma::dot(Cinv_yminusmu, tvec1); // * (tmat * Cinv_yminusmu)); 80 | out(i) = t1 - t2; 81 | } 82 | 83 | return out; 84 | } 85 | 86 | -------------------------------------------------------------------------------- /scratch/RanApley_se_adjust_test.R: -------------------------------------------------------------------------------- 1 | set.seed(2) 2 | n <- 60 3 | d <- 2 4 | f <- function(x) sin(2*pi*x)^.8 5 | f <- function(x) abs(sin(2*pi*x))^.8 * sign(sin(2*pi*x)) * x^4 + rnorm(n, 0, .001) 6 | f <- function(x) as.numeric(x>.5)*sin(2*pi*x) + as.numeric(x>.5)*rnorm(length(x), 0, .09) 7 | f <- TestFunctions::banana 8 | X <- lhs::maximinLHS(n, d) #matrix(runif(n*d), ncol=2) 9 | Z <- f(X) 10 | gp <- GauPro(X, Z)#, nug=1e-8, nug.est=F) 11 | if (d==1) {gp$cool1Dplot()} 12 | if (d==2) {ContourFunctions::cf(gp$predict, pts=X)} 13 | 14 | E <- gp$Kinv[1:(n-1), 1:(n-1)] 15 | B <- gp$K[n, 1:(n-1)] 16 | G <- gp$Kinv[n, 1:(n-1)] 17 | Ainv1 <- E + E %*% outer(B, G) / (1 - sum(B*G)) 18 | 19 | Ainv2 <- solve(gp$K[-n, -n]) 20 | 21 | microbenchmark::microbenchmark(solve(gp$K[-n, -n]), 22 | { 23 | E <- gp$Kinv[1:(n-1), 1:(n-1)] 24 | B <- gp$K[n, 1:(n-1)] 25 | G <- gp$Kinv[n, 1:(n-1)] 26 | E + E %*% outer(B, G) / (1 - sum(B*G)) 27 | }, 28 | { 29 | gp$Kinv[-n, -n] %*% (diag(n-1) + outer(gp$K[n, 1:(n-1)], gp$Kinv[n, 1:(n-1)]) / (1 - sum(gp$K[n, 1:(n-1)]*gp$Kinv[n, 1:(n-1)]))) 30 | }, 31 | { 32 | gp$Kinv[-n, -n]+ gp$Kinv[-n, -n] %*% gp$K[n, 1:(n-1)] %*% gp$Kinv[n, 1:(n-1)] / (1 - sum(gp$K[n, 1:(n-1)]*gp$Kinv[n, 1:(n-1)])) 33 | }, 34 | { 35 | gp$Kinv[-n, -n]+ gp$Kinv[-n, -n] %*% gp$K[n, -n] %*% gp$Kinv[n, -n] / (1 - sum(gp$K[n, -n]*gp$Kinv[n, -n])) 36 | }, 37 | times = 100) 38 | 39 | 40 | yhati <- function(i, gp) { 41 | #n <- nrow(gp$X) 42 | Kinvi <- gp$Kinv[-i, -i]+ gp$Kinv[-i, -i] %*% gp$K[i, -i] %*% gp$Kinv[i, -i] / (1 - sum(gp$K[i, -i]*gp$Kinv[i, -i])) 43 | mn <- gp$mu_hat + sum(gp$K[i, -i] %*% Kinvi * (gp$Z[-i] - gp$mu_hat)) 44 | vr <- pmax(1e-16, gp$K[i, i] - gp$K[i, -i] %*% Kinvi %*% gp$K[-i, i]) 45 | c(mn, vr) 46 | } 47 | yhats <- sapply(1:n, function(i){yhati(i, gp)}) 48 | #plot(yhats, Z) 49 | ContourFunctions::cf(X, Z-yhats[1,]) 50 | zhats <- (yhats[1,] - Z) / sqrt(yhats[2,]) 51 | abszhats <- abs(zhats) 52 | gpz <- GauPro(X, abszhats, nug.est = F, nug = 1e-8)#, theta = gp$theta, param.est=F) 53 | if (d==1) {gpz$cool1Dplot()} 54 | if (d==2) {ContourFunctions::cf(gpz$predict, batchmax=Inf)} 55 | 56 | predse <- function(XX) { 57 | pr <- gp$pred(XX, se.fit = T) 58 | pr_z <- pmax(1e-4, gpz$pred(XX)) 59 | pr_se <- pr$se * pr_z 60 | #pr$s2 <- pr$s2 * pr_z^2 61 | pr_se 62 | } 63 | if (d==2) { 64 | ContourFunctions::cf(gp$pred) 65 | ContourFunctions::cf(function(x)gp$predict(x, se=T)$se, batchmax=Inf, pts=X) 66 | ContourFunctions::cf(function(x)predse(x), batchmax=Inf, pts=X) 67 | } 68 | XX <- lhs::randomLHS(1e4, d) 69 | ZZ <- f(XX) 70 | ZZpred <- gp$pred(XX) 71 | ZZse1 <- gp$pred(XX, se=T)$se 72 | ZZse2 <- predse(XX) 73 | plot(abs(ZZpred - ZZ), ZZse1);abline(a=0,b=1,col=2) 74 | plot(abs(ZZpred - ZZ), ZZse2);abline(a=0,b=1,col=2) 75 | hist((ZZpred - ZZ) / ZZse1) 76 | hist((ZZpred - ZZ) / ZZse2) 77 | 78 | if (d == 1) { 79 | curve(gp$pred(x)) 80 | points(X, Z) 81 | curve(gp$pred(x) + gp$pred(x,se=T)$se, add=T, col=2) 82 | curve(gp$pred(x) - gp$pred(x,se=T)$se, add=T, col=2) 83 | curve(gp$pred(x) + predse(x), add=T, col=3) 84 | curve(gp$pred(x) - predse(x), add=T, col=3) 85 | } 86 | -------------------------------------------------------------------------------- /scratch/scratch_kernel_White.R: -------------------------------------------------------------------------------- 1 | # Check numerically that gradient is correct for 1D 2 | # For White kernel 3 | set.seed(0) 4 | n <- 20 5 | x <- matrix(seq(0,1,length.out = n), ncol=1) 6 | f <- Vectorize(function(x) {sin(2*pi*x) + .5*sin(4*pi*x) +rnorm(1,0,.3)}) 7 | y <- f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 8 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=White$new(1), parallel=FALSE, verbose=10, nug.est=T) 9 | gp$cool1Dplot() 10 | numDeriv::grad(func = function(x)gp$deviance(params=x[2], trend_params=x[1], nuglog=x[3]), x=c(-.8, 2,-1)) 11 | gp$deviance_grad(params = c(2), nug.update=T, nuglog=-1, trend_params=-.8) 12 | numDeriv::grad(func = function(x)gp$deviance(params=x[2], trend_params=x[1], nuglog=x[3]), x=c(gp$trend$m, gp$kernel$logs2, log(gp$nug,10))) 13 | gp$deviance_grad(params = c(gp$kernel$logs2), nug.update=T, nuglog=log(gp$nug,10), trend_params=gp$trend$b) 14 | 15 | 16 | # Check if get same results as nugget 17 | 18 | gp1 <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian$new(1), parallel=FALSE, verbose=10, nug.est=T) 19 | gp2 <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian$new(1) + White$new(1), parallel=FALSE, verbose=10, nug.est=F) 20 | 21 | c(gp1$kernel$beta, gp2$kernel$k1$beta) 22 | c(gp1$nug * gp1$kernel$s2, gp2$nug * gp2$kernel$s2 + gp2$kernel$k2$s2) 23 | # Looks like it works 24 | 25 | gp3 <- GauPro_kernel_model$new(X=x, Z=y, kernel=Gaussian$new(1), parallel=FALSE, verbose=10, nug.est=F, nug=1e-8) 26 | gp3$cool1Dplot() 27 | gp2$cool1Dplot() 28 | 29 | 30 | 31 | 32 | 33 | # Check dC_dtheta 34 | m1 <- (gp$kernel$k(gp$X, beta=1,alpha=5) - gp$kernel$k(gp$X, beta=1-1e-6, alpha=5)) / 1e-6 35 | C_nonug <- gp$kernel$k(gp$X, beta=1, alpha=5) 36 | C <- C_nonug + gp$kernel$s2 * diag(gp$nug, nrow(C_nonug)) 37 | m2 <- gp$kernel$dC_dparams(params = c(1, 5, 1), X = gp$X, C = C, C_nonug = C_nonug)[1,,] 38 | summary(c(m1-m2))# %>% summary 39 | plot(m1, m2) 40 | 41 | gp$deviance_grad() 42 | dsign <- 1 43 | mm1 <- gp$kernel$dC_dparams(C = C, C_nonug = C_nonug, X=gp$X)[[1]] 44 | dsign <- -1 45 | mm2 <- gp$kernel$dC_dparams(C = C, C_nonug = C_nonug, X=gp$X)[[1]] 46 | plot(c(mm1[[1]]), c(mm2[[1]])) 47 | 48 | 49 | # Check dC_dlogs2 50 | beta <- gp$kernel$beta 51 | s2 <- gp$kernel$s2+.2 52 | nug <- gp$nug 53 | eps <- 1e-6 54 | m1 <- (gp$kernel$k(gp$X, beta=beta, s2=s2+eps) - gp$kernel$k(gp$X, beta=beta, s2=s2-eps)) / eps / 2 55 | C_nonug <- gp$kernel$k(gp$X, beta=beta, s2=s2) 56 | C <- C_nonug + s2 * diag(nug, nrow(C_nonug)) 57 | m2 <- gp$kernel$dC_dparams(params = log(c(beta, s2),10), X = gp$X, C = C, C_nonug = C)[[1]][[2]] 58 | c(m1 * s2 * log(10) -m2) %>% summary 59 | plot(c(m1 * s2 * log(10)), c(m2)) 60 | 61 | 62 | # Check C_dC_dparams 63 | params <- c(1.2,.8) 64 | nug <- .001 65 | gp$deviance(params=params, nug=nug) 66 | gp$deviance_grad(params=params, nug=nug, nug.update=T) 67 | gp$deviance_fngr(params=params, nug=nug, nug.update=T) 68 | microbenchmark::microbenchmark(sep={gp$deviance(params=params, nug=nug);gp$deviance_grad(params=params, nug=nug, nug.update=T)}, fngr=gp$deviance_fngr(params=params, nug=nug, nug.update=T)) 69 | 70 | 71 | 72 | 73 | # Check 2D 74 | set.seed(0) 75 | n <- 30 76 | x <- lhs::maximinLHS(n=n, k=2) 77 | f <- function(x) {sin(2*pi*x[1]) + .5*sin(4*pi*x[1]) +rnorm(1,0,.03) + x[2]^2} 78 | y <- apply(x, 1, f) #f(x) #sin(2*pi*x) #+ rnorm(n,0,1e-1) 79 | gp <- GauPro_kernel_model$new(X=x, Z=y, kernel=RatQuad$new(c(1, 1)), parallel=FALSE, verbose=10, nug.est=T) 80 | ContourFunctions::cf(gp$predict, pts=x, batchmax=Inf) 81 | ContourFunctions::cf(f, pts=x) 82 | numDeriv::grad(func = function(x)gp$deviance(params = x[1:3], nuglog=x[4]), x=c(1,1, 1, -4)) 83 | gp$deviance_grad(params = c(1,1,1), nug.update=T, nuglog=-4) 84 | -------------------------------------------------------------------------------- /scratch/corr_gauss_matrix_par_test.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | 4 | // [[Rcpp::depends(RcppParallel)]] 5 | #include 6 | using namespace RcppParallel; 7 | 8 | struct corr_gauss_matrix_par_struct : public Worker { 9 | 10 | // input matrix to read from 11 | const RMatrix mat1; 12 | const RMatrix mat2; 13 | const RVector theta; 14 | 15 | // output matrix to write to 16 | RMatrix rmat; 17 | 18 | // initialize from Rcpp input and output matrixes (the RMatrix class 19 | // can be automatically converted to from the Rcpp matrix type) 20 | corr_gauss_matrix_par_struct(const NumericMatrix mat1, 21 | const NumericMatrix mat2, 22 | const NumericVector theta, 23 | NumericMatrix rmat) 24 | : mat1(mat1), mat2(mat2), theta(theta), rmat(rmat) {} 25 | 26 | // function call operator that work for the specified range (begin/end) 27 | void operator()(std::size_t begin, std::size_t end) { 28 | int ncol = mat2.ncol(); 29 | double tsum; 30 | for (std::size_t i = begin; i < end; i++) { 31 | for (std::size_t j = 0; j < mat2.nrow(); j++) { 32 | 33 | // rows we will operate on 34 | // RMatrix::Row row1 = mat.row(i); 35 | // RMatrix::Row row2 = mat.row(j); 36 | 37 | // compute the average using std::tranform from the STL 38 | // std::vector avg(row1.length()); 39 | // std::transform(row1.begin(), row1.end(), // input range 1 40 | // row2.begin(), // input range 2 41 | // avg.begin(), // output range 42 | // average); // function to apply 43 | 44 | // calculate divergences 45 | // double d1 = kl_divergence(row1.begin(), row1.end(), avg.begin()); 46 | // double d2 = kl_divergence(row2.begin(), row2.end(), avg.begin()); 47 | 48 | // write to output matrix 49 | // rmat(i,j) = sqrt(.5 * (d1 + d2)); 50 | // rmat(i,j) = exp(-sum(theta * pow(mat1.row(i) - mat2.row(j), 2))); 51 | // rmat(i,j) = exp(-sum(theta * pow(mat1.row(i) - mat2.row(j), 2))); 52 | tsum=0; 53 | for (int k=0; k < ncol; k++) { 54 | tsum += theta[k] * pow(mat1(i,k) - mat2(j,k), 2); 55 | } 56 | rmat(i,j) = exp(- tsum); 57 | } 58 | } 59 | } 60 | }; 61 | 62 | //' Correlation Gaussian matrix in C using RcppParallel 63 | //' 64 | //' Faster than nonparallel version for D < 12 and > 20 rows 65 | //' @param x Matrix x 66 | //' @param y Matrix y, must have same number of columns as x 67 | //' @param theta Theta vector 68 | //' @return Correlation matrix 69 | //' @examples 70 | //' corr_gauss_matrixC(matrix(c(1,0,0,1),2,2), matrix(c(1,0,1,1),2,2), c(1,1)) 71 | //' @export 72 | // [[Rcpp::export]] 73 | NumericMatrix corr_gauss_matrixCpar(NumericMatrix x, NumericMatrix y, 74 | NumericVector theta) { 75 | 76 | // allocate the matrix we will return 77 | NumericMatrix rmat(x.nrow(), y.nrow()); 78 | 79 | // create the worker 80 | corr_gauss_matrix_par_struct corr_gauss_matrix_par_instance(x, y, 81 | theta, rmat); 82 | 83 | // call it with parallelFor 84 | parallelFor(0, x.nrow(), corr_gauss_matrix_par_instance, 20); 85 | 86 | return rmat; 87 | } 88 | 89 | 90 | // You can include R code blocks in C++ files processed with sourceCpp 91 | // (useful for testing and development). The R code will be automatically 92 | // run after the compilation. 93 | // 94 | 95 | /*** R 96 | */ 97 | -------------------------------------------------------------------------------- /scratch/deprecated_kernelmodel_maxEIwithfactorsoriginal.R: -------------------------------------------------------------------------------- 1 | # This was removed from kernel_model.R. 2 | # This ran optim over all factor combinations. 3 | # This can be a lot of optims, so the new one does 4 | # alternating descents on the cts and factor variables. 5 | 6 | maxEIwithfactorsorig = function(lower=apply(self$X, 2, min), 7 | upper=apply(self$X, 2, max), 8 | n0=100, minimize=FALSE, eps=0) { 9 | stop("dont use this anymore") 10 | stopifnot(all(lower < upper)) 11 | stopifnot(length(n0)==1, is.numeric(n0), n0>=1) 12 | # Get factor info 13 | factorinfo <- find_kernel_factor_dims(self$kernel) 14 | # Run inner EI over all factor combinations 15 | stopifnot(length(factorinfo)>0) 16 | # factordf <- data.frame(index=factorinfo[1] 17 | factorlist <- list() 18 | for (i_f in 1:(length(factorinfo)/2)) { 19 | factorlist[[as.character(factorinfo[i_f*2-1])]] <- 1:factorinfo[i_f*2] 20 | } 21 | factordf <- do.call(expand.grid, factorlist) 22 | # Track best seen in optimizing EI 23 | bestval <- Inf 24 | bestpar <- c() 25 | factorxindex <- factorinfo[(1:(length(factorinfo)/2))*2-1] #factorinfo[[1]] 26 | for (i_indcomb in 1:prod(factorinfo[(1:(length(factorinfo)/2))*2])) { 27 | factorxlevel <- unname(unlist(factordf[i_indcomb,])) #i_indcomb #factorinfo[[2]] 28 | # cat(factorxindex, factorxlevel, "\n") 29 | 30 | # If no non-factor levels, just calculate and compare 31 | if (length(factorxindex) == self$D) { 32 | # stop() 33 | xxinds1 <- c() 34 | xxinds2 <- c() 35 | xx <- rep(NA, self$D) 36 | xx[factorxindex] <- factorxlevel 37 | optim_out_i_indcomb <- list(par=xx) 38 | optim_out_i_indcomb$value <- -self$EI(xx, minimize = minimize) 39 | } else { 40 | 41 | # Otherwise optimize over continuous values 42 | X0 <- lhs::randomLHS(n=n0, k=self$D) 43 | X0 <- sweep(X0, 2, upper-lower, "*") 44 | X0 <- sweep(X0, 2, lower, "+") 45 | for (j in 1:length(factorxindex)) { 46 | X0[, factorxindex[j]] <- factorxlevel[j] 47 | } 48 | 49 | # Calculate EI at these points, use best as starting point for optim 50 | EI0 <- self$EI(x=X0, minimize=minimize, eps=eps) 51 | ind <- which.max(EI0) 52 | 53 | # Continuous indexes 54 | ctsinds <- setdiff(1:self$D, factorxindex) 55 | 56 | # Optimize starting from that point to find input that maximizes EI 57 | optim_out_i_indcomb <- optim(par=X0[ind, -factorxindex], 58 | lower=lower[-factorxindex], upper=upper[-factorxindex], 59 | # fn=function(xx){ei <- -self$EI(xx); cat(xx, ei, "\n"); ei}, 60 | fn=function(xx){ 61 | xx2 <- numeric(self$D) 62 | xx2[ctsinds] <- xx 63 | xx2[factorxindex] <- factorxlevel 64 | # xx2 <- c(xx[xxinds1], factorxlevel, xx[xxinds2]) 65 | # cat(xx, xx2, "\n") 66 | -self$EI(xx2, minimize = minimize) 67 | }, 68 | method="L-BFGS-B") 69 | } 70 | if (optim_out_i_indcomb$value < bestval) { 71 | # cat("new best val", optim_out_i_indcomb$value, bestval, i_indcomb, "\n") 72 | bestval <- optim_out_i_indcomb$value 73 | 74 | bestpar <- numeric(self$D) 75 | bestpar[ctsinds] <- optim_out_i_indcomb$par #[xxinds1] 76 | bestpar[factorxindex] <- factorxlevel 77 | # bestpar <- c(optim_out_i_indcomb$par[xxinds1], factorxlevel, optim_out_i_indcomb$par[xxinds2]) 78 | } 79 | } 80 | stopifnot(length(bestpar) == self$D) 81 | return(bestpar) 82 | }, 83 | -------------------------------------------------------------------------------- /vignettes/GauPro.R: -------------------------------------------------------------------------------- 1 | ## ----echo=FALSE--------------------------------------------------------------- 2 | knitr::opts_chunk$set(fig.width=7, fig.height=4) 3 | 4 | set.seed(0) 5 | 6 | ## ----libraryGauPro------------------------------------------------------------ 7 | library(GauPro) 8 | 9 | ## ----fitsine------------------------------------------------------------------ 10 | n <- 12 11 | x <- seq(0, 1, length.out = n) 12 | y <- sin(6*x^.8) + rnorm(n,0,1e-1) 13 | gp <- gpkm(x, y) 14 | 15 | ## ----plotsine----------------------------------------------------------------- 16 | gp$plot1D() 17 | 18 | ## ----fit_dm------------------------------------------------------------------- 19 | library(ggplot2) 20 | diamonds_subset <- diamonds[sample(1:nrow(diamonds), 60), ] 21 | dm <- gpkm(price ~ carat + cut + color + clarity + depth, 22 | diamonds_subset) 23 | 24 | ## ----summary_dm--------------------------------------------------------------- 25 | summary(dm) 26 | 27 | ## ----plot_dm------------------------------------------------------------------ 28 | plot(dm) 29 | 30 | ## ----diamond_construct_kernel------------------------------------------------- 31 | cts_kernel <- k_IgnoreIndsKernel(k=k_PowerExp(D=2), ignoreinds = c(2,3,4)) 32 | factor_kernel2 <- k_OrderedFactorKernel(D=5, xindex=2, nlevels=nlevels(diamonds_subset[[2]])) 33 | factor_kernel3 <- k_OrderedFactorKernel(D=5, xindex=3, nlevels=nlevels(diamonds_subset[[3]])) 34 | factor_kernel4 <- k_GowerFactorKernel(D=5, xindex=4, nlevels=nlevels(diamonds_subset[[4]])) 35 | 36 | # Multiply them 37 | diamond_kernel <- cts_kernel * factor_kernel2 * factor_kernel3 * factor_kernel4 38 | 39 | ## ----diamond_construct_kernel_fit--------------------------------------------- 40 | dm <- gpkm(price ~ carat + cut + color + clarity + depth, 41 | diamonds_subset, kernel=diamond_kernel) 42 | dm$plotkernel() 43 | 44 | ## ----combine seed, include=F-------------------------------------------------- 45 | set.seed(99) 46 | 47 | ## ----combine_periodic--------------------------------------------------------- 48 | x <- 1:20 49 | y <- sin(x) + .1*x^1.3 50 | combo_kernel <- k_Periodic(D=1) * k_Matern52(D=1) 51 | gp <- gpkm(x, y, kernel=combo_kernel, nug.min=1e-6) 52 | gp$plot() 53 | 54 | ## ----oldvignettedata---------------------------------------------------------- 55 | x <- seq(0,1,l=10) 56 | y <- abs(sin(2*pi*x))^.8 57 | ggplot(aes(x,y), data=cbind(x,y)) + 58 | geom_point() 59 | 60 | ## ----oldvignettedata_plot----------------------------------------------------- 61 | ggplot(aes(x,y), data=cbind(x,y)) + 62 | geom_point() + 63 | stat_smooth(method='lm') 64 | 65 | ## ----oldvignettedata_gpkm----------------------------------------------------- 66 | library(GauPro) 67 | gp <- gpkm(x, y, kernel=k_Gaussian(D=1), parallel=FALSE) 68 | 69 | ## ----oldvignettedata_plot1D--------------------------------------------------- 70 | gp$plot1D() 71 | 72 | ## ----oldvignettedata_cool1Dplot----------------------------------------------- 73 | if (requireNamespace("MASS", quietly = TRUE)) { 74 | gp$cool1Dplot() 75 | } 76 | 77 | ## ----oldvignettedata_maternplot----------------------------------------------- 78 | kern <- k_Matern52(D=1) 79 | gpk <- gpkm(matrix(x, ncol=1), y, kernel=kern, parallel=FALSE) 80 | if (requireNamespace("MASS", quietly = TRUE)) { 81 | plot(gpk) 82 | } 83 | 84 | ## ----oldvignettedata_exponentialplot------------------------------------------ 85 | kern.exp <- k_Exponential(D=1) 86 | gpk.exp <- gpkm(matrix(x, ncol=1), y, kernel=kern.exp, parallel=FALSE) 87 | if (requireNamespace("MASS", quietly = TRUE)) { 88 | plot(gpk.exp) 89 | } 90 | 91 | ## ----oldvignettedata_trendplot------------------------------------------------ 92 | kern.exp <- k_Exponential(D=1) 93 | trend.0 <- trend_0$new() 94 | gpk.exp <- gpkm(matrix(x, ncol=1), y, kernel=kern.exp, trend=trend.0, parallel=FALSE) 95 | if (requireNamespace("MASS", quietly = TRUE)) { 96 | plot(gpk.exp) 97 | } 98 | 99 | --------------------------------------------------------------------------------