fastGHQuad/0000755000176200001440000000000014235056774012256 5ustar liggesusersfastGHQuad/NAMESPACE0000644000176200001440000000032714234042346013464 0ustar liggesusers# Generated by roxygen2 (4.0.1): do not edit by hand export(aghQuad) export(evalHermitePoly) export(findPolyRoots) export(gaussHermiteData) export(ghQuad) export(hermitePolyCoef) import(Rcpp) useDynLib(fastGHQuad) fastGHQuad/LICENSE0000644000176200001440000000006014234042346013244 0ustar liggesusersYEAR: 2014 COPYRIGHT HOLDER: Alexander W BlockerfastGHQuad/ChangeLog0000644000176200001440000000016614234042346014020 0ustar liggesusers2011-12-05 Alexander W Blocker * src/lib.cpp: Add explicit casts to log calls where needed fastGHQuad/man/0000755000176200001440000000000014234042346013016 5ustar liggesusersfastGHQuad/man/gaussHermiteData.Rd0000644000176200001440000000261514234042346016543 0ustar liggesusers% Generated by roxygen2 (4.0.1): do not edit by hand \name{gaussHermiteData} \alias{gaussHermiteData} \title{Compute Gauss-Hermite quadrature rule} \usage{ gaussHermiteData(n) } \arguments{ \item{n}{Order of Gauss-Hermite rule to compute (number of nodes)} } \value{ A list containing: \item{x}{the n node positions for the requested rule} \item{w}{the w quadrature weights for the requested rule} } \description{ Computes Gauss-Hermite quadrature rule of requested order using Golub-Welsch algorithm. Returns result in list consisting of two entries: x, for nodes, and w, for quadrature weights. This is very fast and numerically stable, using the Golub-Welsch algorithm with specialized eigendecomposition (symmetric tridiagonal) LAPACK routines. It can handle quadrature of order 1000+. } \details{ This function computes the Gauss-Hermite rule of order n using the Golub-Welsch algorithm. All of the actual computation is performed in C/C++ and FORTRAN (via LAPACK). It is numerically-stable and extremely memory-efficient for rules of order 1000+. } \author{ Alexander W Blocker \email{ablocker@gmail.com} } \references{ Golub, G. H. and Welsch, J. H. (1969). Calculation of Gauss Quadrature Rules. Mathematics of Computation 23 (106): 221-230 Liu, Q. and Pierce, D. A. (1994). A Note on Gauss-Hermite Quadrature. Biometrika, 81(3) 624-629. } \seealso{ \code{\link{aghQuad}}, \code{\link{ghQuad}} } \keyword{math} fastGHQuad/man/fastGHQuad-package.Rd0000644000176200001440000000261414234042346016670 0ustar liggesusers% Generated by roxygen2 (4.0.1): do not edit by hand \docType{package} \name{fastGHQuad-package} \alias{fastGHQuad} \alias{fastGHQuad-package} \title{A package for fast, numerically-stable computation of Gauss-Hermite quadrature rules} \description{ This package provides functions to compute Gauss-Hermite quadrature rules very quickly with a higher degree of numerical stability (tested up to 2000 nodes). } \details{ It also provides function for adaptive Gauss-Hermite quadrature, extending Laplace approximations (as in Liu & Pierce 1994). \tabular{ll}{ Package: \tab fastGHQuad\cr Type: \tab Package\cr License: \tab MIT \cr LazyLoad: \tab yes\cr } } \examples{ # Get quadrature rule rule <- gaussHermiteData(1000) # Find a normalizing constant g <- function(x) 1/(1+x^2/10)^(11/2) # t distribution with 10 df aghQuad(g, 0, 1.1, rule) # actual is 1/dt(0,10) # Find an expectation g <- function(x) x^2*dt(x,10) # t distribution with 10 df aghQuad(g, 0, 1.1, rule) # actual is 1.25 } \author{ Alexander W Blocker Maintainer: Alexander W Blocker } \references{ Golub, G. H. and Welsch, J. H. (1969). Calculation of Gauss Quadrature Rules. Mathematics of Computation 23 (106): 221-230. Liu, Q. and Pierce, D. A. (1994). A Note on Gauss-Hermite Quadrature. Biometrika, 81(3) 624-629. } \seealso{ \code{\link{gaussHermiteData}}, \code{\link{aghQuad}}, \code{\link{ghQuad}} } \keyword{package} fastGHQuad/man/findPolyRoots.Rd0000644000176200001440000000135414234042346016123 0ustar liggesusers% Generated by roxygen2 (4.0.1): do not edit by hand \name{findPolyRoots} \alias{findPolyRoots} \title{Find real parts of roots of polynomial} \usage{ findPolyRoots(c) } \arguments{ \item{c}{Coefficients of polynomial} } \value{ Numeric vector containing the real parts of the roots of the polynomial defined by c } \description{ Finds real parts of polynomial's roots via eigendecomposition of companion matrix. This method is not used by gaussHermiteData. Only the real parts of each root are retained; this can be useful if the polynomial is known a priori to have all roots real. } \author{ Alexander W Blocker \email{ablocker@gmail.com} } \seealso{ \code{\link{gaussHermiteData}}, \code{\link{aghQuad}}, \code{\link{ghQuad}} } \keyword{math} fastGHQuad/man/hermitePolyCoef.Rd0000644000176200001440000000131514234042346016403 0ustar liggesusers% Generated by roxygen2 (4.0.1): do not edit by hand \name{hermitePolyCoef} \alias{hermitePolyCoef} \title{Get coefficient of Hermite polynomial} \usage{ hermitePolyCoef(n) } \arguments{ \item{n}{Degree of Hermite polynomial to compute} } \value{ Vector of (n+1) coefficients from requested polynomial } \description{ Calculate coefficients of Hermite polynomial using recursion relation. This function is provided for demonstration/teaching purposes; this method is not used by gaussHermiteData. It is numerically unstable for high-degree polynomials. } \author{ Alexander W Blocker \email{ablocker@gmail.com} } \seealso{ \code{\link{gaussHermiteData}}, \code{\link{aghQuad}}, \code{\link{ghQuad}} } \keyword{math} fastGHQuad/man/aghQuad.Rd0000644000176200001440000000567014234042346014667 0ustar liggesusers% Generated by roxygen2 (4.0.1): do not edit by hand \name{aghQuad} \alias{aghQuad} \title{Adaptive Gauss-Hermite quadrature using Laplace approximation} \usage{ aghQuad(g, muHat, sigmaHat, rule, ...) } \arguments{ \item{g}{Function to integrate with respect to first (scalar) argument} \item{muHat}{Mode for Laplace approximation} \item{sigmaHat}{Scale for Laplace approximation (\code{sqrt(-1/H)}, where H is the second derivative of g at muHat)} \item{rule}{Gauss-Hermite quadrature rule to use, as produced by \code{\link{gaussHermiteData}}} \item{...}{Additional arguments for g} } \value{ Numeric (scalar) with approximation integral of g from -Inf to Inf. } \description{ Convenience function for integration of a scalar function g based upon its Laplace approximation. } \details{ This function approximates \deqn{\int_{-\infty}^{\infty} g(x) \, dx}{ integral( g(x), -Inf, Inf)} using the method of Liu & Pierce (1994). This technique uses a Gaussian approximation of g (or the distribution component of g, if an expectation is desired) to "focus" quadrature around the high-density region of the distribution. Formally, it evaluates: \deqn{ \sqrt{2} \hat{\sigma} \sum_i w_i \exp(x_i^2) g(\hat{\mu} + \sqrt{2} }{ sqrt(2) * sigmaHat * sum( w * exp(x^2) * g(muHat + sqrt(2) * sigmaHat * x)) }\deqn{\hat{\sigma} x_i) }{ sqrt(2) * sigmaHat * sum( w * exp(x^2) * g(muHat + sqrt(2) * sigmaHat * x)) } where x and w come from the given rule. This method can, in many cases (where the Gaussian approximation is reasonably good), achieve better results with 10-100 quadrature points than with 1e6 or more draws for Monte Carlo integration. It is particularly useful for obtaining marginal likelihoods (or posteriors) in hierarchical and multilevel models --- where conditional independence allows for unidimensional integration, adaptive Gauss-Hermite quadrature is often extremely effective. } \examples{ # Get quadrature rules rule10 <- gaussHermiteData(10) rule100 <- gaussHermiteData(100) # Estimating normalizing constants g <- function(x) 1/(1+x^2/10)^(11/2) # t distribution with 10 df aghQuad(g, 0, 1.1, rule10) aghQuad(g, 0, 1.1, rule100) # actual is 1/dt(0,10) # Can work well even when the approximation is not exact g <- function(x) exp(-abs(x)) # Laplace distribution aghQuad(g, 0, 2, rule10) aghQuad(g, 0, 2, rule100) # actual is 2 # Estimating expectations # Variances for the previous two distributions g <- function(x) x^2*dt(x,10) # t distribution with 10 df aghQuad(g, 0, 1.1, rule10) aghQuad(g, 0, 1.1, rule100) # actual is 1.25 # Can work well even when the approximation is not exact g <- function(x) x^2*exp(-abs(x))/2 # Laplace distribution aghQuad(g, 0, 2, rule10) aghQuad(g, 0, 2, rule100) # actual is 2 } \author{ Alexander W Blocker \email{ablocker@gmail.com} } \references{ Liu, Q. and Pierce, D. A. (1994). A Note on Gauss-Hermite Quadrature. Biometrika, 81(3) 624-629. } \seealso{ \code{\link{gaussHermiteData}}, \code{\link{ghQuad}} } \keyword{math} fastGHQuad/man/ghQuad.Rd0000644000176200001440000000342714234042346014524 0ustar liggesusers% Generated by roxygen2 (4.0.1): do not edit by hand \name{ghQuad} \alias{ghQuad} \title{Convenience function for Gauss-Hermite quadrature} \usage{ ghQuad(f, rule, ...) } \arguments{ \item{f}{Function to integrate with respect to first (scalar) argument; this does not include the weight function \code{exp(-x^2)}} \item{rule}{Gauss-Hermite quadrature rule to use, as produced by \code{\link{gaussHermiteData}}} \item{...}{Additional arguments for f} } \value{ Numeric (scalar) with approximation integral of f(x)*exp(-x^2) from -Inf to Inf. } \description{ Convenience function for evaluation of Gauss-Hermite quadrature } \details{ This function performs classical unidimensional Gauss-Hermite quadrature with the function f using the rule provided; that is, it approximates \deqn{\int_{-\infty}^{\infty} f(x) \exp(-x^2) \, dx}{ integral( f(x) exp(-x^2), -Inf, Inf)} by evaluating \deqn{ \sum_i w_i f(x_i) }{sum( w * f(x) )} } \examples{ # Get quadrature rules rule10 <- gaussHermiteData(10) rule100 <- gaussHermiteData(100) # Check that rule is implemented correctly f <- function(x) rep(1,length(x)) if (!isTRUE(all.equal(sqrt(pi), ghQuad(f, rule10), ghQuad(f, rule100)))) { print(ghQuad(f, rule10)) print(ghQuad(f, rule100)) } # These should be 1.772454 f <- function(x) x if (!isTRUE(all.equal(0.0, ghQuad(f, rule10), ghQuad(f, rule100)))) { print(ghQuad(f, rule10)) print(ghQuad(f, rule100)) } # These should be zero } \author{ Alexander W Blocker \email{ablocker@gmail.com} } \references{ Golub, G. H. and Welsch, J. H. (1969). Calculation of Gauss Quadrature Rules. Mathematics of Computation 23 (106): 221-230. Liu, Q. and Pierce, D. A. (1994). A Note on Gauss-Hermite Quadrature. Biometrika, 81(3) 624-629. } \seealso{ \code{\link{gaussHermiteData}}, \code{\link{ghQuad}} } \keyword{math} fastGHQuad/man/evalHermitePoly.Rd0000644000176200001440000000142114234042346016414 0ustar liggesusers% Generated by roxygen2 (4.0.1): do not edit by hand \name{evalHermitePoly} \alias{evalHermitePoly} \title{Evaluate Hermite polynomial at given location} \usage{ evalHermitePoly(x, n) } \arguments{ \item{x}{Vector of location(s) at which polynomial will be evaluated} \item{n}{Degree of Hermite polynomial to compute} } \value{ Vector of length(x) values of Hermite polynomial } \description{ Evaluate Hermite polynomial of given degree at given location. This function is provided for demonstration/teaching purposes; this method is not used by gaussHermiteData. It is numerically unstable for high-degree polynomials. } \author{ Alexander W Blocker \email{ablocker@gmail.com} } \seealso{ \code{\link{gaussHermiteData}}, \code{\link{aghQuad}}, \code{\link{ghQuad}} } \keyword{math} fastGHQuad/DESCRIPTION0000644000176200001440000000125214235056774013764 0ustar liggesusersPackage: fastGHQuad Type: Package Title: Fast 'Rcpp' Implementation of Gauss-Hermite Quadrature Version: 1.0.1 Date: 2022-05-03 Author: Alexander W Blocker Maintainer: Alexander W Blocker Description: Fast, numerically-stable Gauss-Hermite quadrature rules and utility functions for adaptive GH quadrature. See Liu, Q. and Pierce, D. A. (1994) for a reference on these methods. License: MIT + file LICENSE LazyLoad: yes URL: https://github.com/awblocker/fastGHQuad Depends: Rcpp (>= 0.11.0) LinkingTo: Rcpp NeedsCompilation: yes Packaged: 2022-05-05 17:20:14 UTC; rstudio Repository: CRAN Date/Publication: 2022-05-05 23:30:04 UTC fastGHQuad/src/0000755000176200001440000000000014234263150013030 5ustar liggesusersfastGHQuad/src/lib.cpp0000644000176200001440000002355314234263150014312 0ustar liggesusers#include "lib.h" using std::vector; using std::abs; void buildHermiteJacobi(int n, vector *D, vector *E) { // // Construct symmetric tridiagonal matrix similar to Jacobi matrix // for Hermite polynomials // // On exit, D contains diagonal elements of said matrix; // E contains subdiagonal elements. // // Need D of size n, E of size n-1 // // Building matrix based on recursion relation for monic versions of Hermite // polynomials: // p_n(x) = H_n(x) / 2^n // p_n+1(x) + (B_n-x)*p_n(x) + A_n*p_n-1(x) = 0 // B_n = 0 // A_n = n/2 // // Matrix similar to Jacobi (J) defined by: // J_i,i = B_i-1, i = 1, ..., n // J_i,i-1 = J_i-1,i = sqrt(A_i-1), i = 2, ..., n // // Build diagonal int i; for (i = 0; i < n; i++) { (*D)[i] = 0.; } // Build sub/super-diagonal for (i = 0; i < n - 1; i++) { (*E)[i] = sqrt((i + 1.) / 2.); } } void quadInfoGolubWelsch(int n, vector &D, vector &E, double mu0, vector *x, vector *w) { // // Compute weights & nodes for Gaussian quadrature using Golub-Welsch // algorithm. // // First need to build symmetric tridiagonal matrix J similar to Jacobi for // desired orthogonal polynomial (based on recurrence relation). // // D contains the diagonal of this matrix J, and E contains the // sub/super-diagonal. // // This routine finds the eigenvectors & values of the given J matrix. // // The eigenvalues correspond to the nodes for the desired quadrature rule // (roots of the orthogonal polynomial). // // The eigenvectors can be used to compute the weights for the quadrature rule // via: // // w_j = mu0 * (v_j,1)^2 // // where mu0 = \int_a^b w(x) dx // (integral over range of integration of weight function) // // and // // v_j,1 is the first entry of the jth normalized (to unit length) // eigenvector. // // On exit, x (length n) contains nodes for quadrature rule, and w (length n) // contains weights for quadrature rule. // // Note that contents of D & E are destroyed on exit // // Setup for eigenvalue computations char JOBZ = 'V'; // Flag to compute both eigenvalues & vectors. int INFO; vector WORK(2 * n - 2); vector Z(n * n); // This holds the resulting eigenvectors. // Run eigen decomposition F77_NAME(dstev)(&JOBZ, &n, &D[0], &E[0], // Job flag & input matrix &Z[0], &n, // Output array for eigenvectors & dim &WORK[0], &INFO FCONE // Workspace & info flag ); // Setup x & w int i; for (i = 0; i < n; i++) { (*x)[i] = D[i]; (*w)[i] = mu0 * Z[i * n] * Z[i * n]; } } void findPolyRoots(const vector &c, int n, vector *r) { // // Compute roots of polynomial with coefficients c using eigenvalue // decomposition of companion matrix // // Using R LAPACK interface // // Places result into r, which needs to be of dimension n-1 // Need c of dimension n // using namespace std; int i; // Build companion matrix; column-major order for compatibility with LAPACK vector C(n * n); for (i = 0; i < n * n; i++) { C[i] = 0.; } // Add diagonal components for (i = 1; i < n; i++) { C[i + n * (i - 1)] = 1.; } // Add coefficients for (i = 0; i < n; i++) { C[i + n * (n - 1)] = -c[i] / c[n]; } // Setup for eigenvalue computation // Allocate vectors for real & imaginary parts of eigenvalues vector valI(n); // Integers for status codes and LWORK int INFO, LWORK; // Workspace; starting as a single double double tmpwork; // Run eigenvalue computation char no = 'N'; int one = 1; // First, get optimal workspace size LWORK = -1; F77_CALL(dgeev)( &no, &no, // Don't compute eigenvectors &n, &C[0], &n, // Companion matrix & dimensions; overwritten on exit &(*r)[0], &valI[0], // Arrays for real & imaginary parts of eigenvalues NULL, &one, // VL & LDVL; not used NULL, &one, // VR & LDVR; not used &tmpwork, // Workspace; will contain optimal size upon exit &LWORK, // Workspace size; -1 -> get optimal size &INFO // Status code FCONE FCONE ); // Next, actually run eigendecomposition LWORK = (int)tmpwork; vector work(LWORK); F77_CALL(dgeev)( &no, &no, // Don't compute eigenvectors &n, &C[0], &n, // Companion matrix & dimensions; overwritten on exit &(*r)[0], &valI[0], // Arrays for real & imaginary parts of eigenvalues NULL, &one, // VL & LDVL; not used NULL, &one, // VR & LDVR; not used &work[0], // Workspace; will contain optimal size upon exit &LWORK, // Workspace size; -1 -> get optimal size &INFO // Status code FCONE FCONE ); } SEXP findPolyRoots(SEXP cR) { using namespace Rcpp; // Convert coef to Rcpp object NumericVector c(cR); int n = c.size(); // Allocate vector for results NumericVector roots(n - 1); // Compute roots vector r = as >(roots); findPolyRoots(as >(c), n - 1, &r); return roots; } void hermitePolyCoef(int n, vector *c) { // // Compute coefficients of Hermite polynomial of order n // Need c of dimension n+1 // // Uses recursion relation for efficiency // Allocate workspace for coefficient evaluations; // will use column-major ordering vector work((n + 1) * (n + 1)); int i, j; for (i = 0; i < (n + 1) * (n + 1); i++) { work[i] = 0.; } // Handle special cases (n<2) if (n == 0) { (*c)[0] = 1.; return; } else if (n == 1) { (*c)[0] = 0.; (*c)[1] = 2.; return; } // Initialize recursion work[0] = 1.; // H_0(x) = 1 work[1] = 0.; work[1 + 1 * (n + 1)] = 2.; // H_1(x) = 2*x // Run recursion relation for (i = 2; i < n + 1; i++) { // Order 0 term updates work[i] = -2 * (i - 1) * work[i - 2]; for (j = 1; j < i + 1; j++) { // Remainder of recursion relation work[i + j * (n + 1)] = 2. * work[(i - 1) + (j - 1) * (n + 1)] - 2. * (i - 1.) * work[(i - 2) + j * (n + 1)]; } } // Extract double-formatted coefficients from last row for (j = 0; j < n + 1; j++) { (*c)[j] = (double)work[n + j * (n + 1)]; } } SEXP hermitePolyCoef(SEXP nR) { using namespace Rcpp; // Convert coef to Rcpp object int n = IntegerVector(nR)[0]; // Allocate vector for coefficients NumericVector coef(n + 1); // Compute roots vector c = as >(coef); hermitePolyCoef(n, &c); return coef; } double hermitePoly(double x, int n) { // // Compute Hermite polynomial of order n evaluated at x efficiently via // recursion relation: // H_n+1(x) = 2*x*H_n(x) - 2*n*H_n-1(x) // H_0(x) = 1 // H_1(x) = 2x // int i = 0; // Special cases if (n == 0) { return 1.; } else if (n == 1) { return 2. * x; } // Standard recursion double hnm2 = 1.; double hnm1 = 2. * x; double hn = 0.; for (i = 2; i <= n; i++) { hn = 2. * x * hnm1 - 2. * (i - 1.) * hnm2; hnm2 = hnm1; hnm1 = hn; } return hn; } SEXP evalHermitePoly(SEXP xR, SEXP nR) { using namespace Rcpp; int i; // Convert to Rcpp objects NumericVector x(xR); IntegerVector n(nR); if (n.size() == x.size()) { // Iterate through x & n NumericVector h(x.size()); for (i = 0; i < x.size(); i++) { h[i] = hermitePoly(x[i], n[i]); } return h; } else if (x.size() > n.size()) { // Iterate through x only NumericVector h(x.size()); for (i = 0; i < x.size(); i++) { h[i] = hermitePoly(x[i], n[0]); } return h; } else { // Iterate through n only NumericVector h(n.size()); for (i = 0; i < n.size(); i++) { h[i] = hermitePoly(x[0], n[i]); } return h; } } int gaussHermiteDataDirect(int n, vector *x, vector *w) { // // Calculates roots & weights of Hermite polynomials of order n for // Gauss-Hermite integration. // // Need x & w of size n // // Using standard formulation (no generalizations or polynomial adjustment) // // Direct evaluation and root-finding; clear, but numerically unstable // for n>20 or so // // Calculate coefficients of Hermite polynomial of given order vector coef(n + 1); hermitePolyCoef(n, &coef); // Find roots of given Hermite polynomial; these are the points at // which the integrand will be evaluated (x) findPolyRoots(coef, n, x); // Calculate weights w int i; double log2 = log(2.0), logsqrtpi = 0.5 * log(M_PI); for (i = 0; i < n; i++) { // First, compute the log-weight (*w)[i] = (n - 1.) * log2 + lgamma(n + 1) + logsqrtpi - 2. * log((double)n) - 2. * log(abs(hermitePoly((*x)[i], n - 1))); (*w)[i] = exp((*w)[i]); } return 0; } int gaussHermiteDataGolubWelsch(int n, vector *x, vector *w) { // // Calculates nodes & weights for Gauss-Hermite integration of order n // // Need x & w of size n // // Using standard formulation (no generalizations or polynomial adjustment) // // Evaluations use Golub-Welsch algorithm; numerically stable for n>=100 // // Build Jacobi-similar symmetric tridiagonal matrix via diagonal & // sub-diagonal vector D(n), E(n); buildHermiteJacobi(n, &D, &E); // Get nodes & weights double mu0 = sqrt(M_PI); quadInfoGolubWelsch(n, D, E, mu0, x, w); return 0; } SEXP gaussHermiteData(SEXP nR) { using namespace Rcpp; // Convert nR to int int n = IntegerVector(nR)[0]; // Allocate vectors for x & w vector x(n), w(n); // Build Gauss-Hermite integration rules gaussHermiteDataGolubWelsch(n, &x, &w); // Build list for values return List::create(Named("x") = x, Named("w") = w); } fastGHQuad/src/lib.h0000644000176200001440000000271114234263150013750 0ustar liggesusers#ifndef _fastGHQuad_LIB_H #define _fastGHQuad_LIB_H #define USE_FC_LEN_T #include #include #ifndef FCONE # define FCONE #endif /* * note : RcppExport is an alias to `extern "C"` defined by Rcpp. * * It gives C calling convention to the rcpp_hello_world function so that * it can be called from .Call in R. Otherwise, the C++ compiler mangles the * name of the function and .Call can't find it. * * It is only useful to use RcppExport when the function is intended to be * called by .Call. See the thread * http://thread.gmane.org/gmane.comp.lang.r.rcpp/649/focus=672 * on Rcpp-devel for a misuse of RcppExport */ double hermitePoly(double x, int n); RcppExport SEXP evalHermitePoly(SEXP xR, SEXP nR); void findPolyRoots(const std::vector& c, int n, std::vector* r); RcppExport SEXP findPolyRoots(SEXP cR); void hermitePolyCoef(int n, std::vector* c); RcppExport SEXP hermitePolyCoef(SEXP nR); void buildHermiteJacobi(int n, std::vector* D, std::vector E); void quadInfoGolubWelsch(int n, std::vector& D, std::vector& E, double mu0, std::vector& x, std::vector& w); int gaussHermiteDataDirect(int n, std::vector* x, std::vector* w); int gaussHermiteDataGolubWelsch(int n, std::vector* x, std::vector* w); RcppExport SEXP gaussHermiteData(SEXP nR); #endif fastGHQuad/src/init.cpp0000644000176200001440000000066014234042346014503 0ustar liggesusers#include "lib.h" extern "C" { void R_init_fastGHQuad(DllInfo *info) { R_registerRoutines(info, NULL, NULL, NULL, NULL); R_useDynamicSymbols(info, TRUE); R_RegisterCCallable("fastGHQuad", "gaussHermiteDataDirect", (DL_FUNC) &gaussHermiteDataDirect); R_RegisterCCallable("fastGHQuad", "gaussHermiteDataGolubWelsch", (DL_FUNC) &gaussHermiteDataGolubWelsch); } } fastGHQuad/src/Makevars0000644000176200001440000000024214234042346014524 0ustar liggesusers## With Rcpp 0.11.0 and later, we no longer need to set PKG_LIBS for ## Rcpp as there is no user-facing library. PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) fastGHQuad/src/Makevars.win0000644000176200001440000000024114234042346015317 0ustar liggesusers## With Rcpp 0.11.0 and later, we no longer need to set PKG_LIBS for ## Rcpp as there is no user-facing library. PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) fastGHQuad/R/0000755000176200001440000000000014234042346012444 5ustar liggesusersfastGHQuad/R/zzz.R0000644000176200001440000000273414234042346013432 0ustar liggesusers #' @import Rcpp #' @useDynLib fastGHQuad NULL #' A package for fast, numerically-stable computation of Gauss-Hermite #' quadrature rules #' #' This package provides functions to compute Gauss-Hermite quadrature rules #' very quickly with a higher degree of numerical stability (tested up to 2000 #' nodes). #' #' It also provides function for adaptive Gauss-Hermite quadrature, extending #' Laplace approximations (as in Liu & Pierce 1994). #' #' \tabular{ll}{ Package: \tab fastGHQuad\cr Type: \tab Package\cr License: #' \tab MIT \cr LazyLoad: \tab yes\cr } #' #' @name fastGHQuad-package #' @aliases fastGHQuad-package fastGHQuad #' @docType package #' @author Alexander W Blocker #' #' Maintainer: Alexander W Blocker #' @seealso \code{\link{gaussHermiteData}}, \code{\link{aghQuad}}, #' \code{\link{ghQuad}} #' @references Golub, G. H. and Welsch, J. H. (1969). Calculation of Gauss #' Quadrature Rules. Mathematics of Computation 23 (106): 221-230. #' #' Liu, Q. and Pierce, D. A. (1994). A Note on Gauss-Hermite Quadrature. #' Biometrika, 81(3) 624-629. #' @keywords package #' @examples #' #' # Get quadrature rule #' rule <- gaussHermiteData(1000) #' #' # Find a normalizing constant #' g <- function(x) 1/(1+x^2/10)^(11/2) # t distribution with 10 df #' aghQuad(g, 0, 1.1, rule) #' # actual is #' 1/dt(0,10) #' #' # Find an expectation #' g <- function(x) x^2*dt(x,10) # t distribution with 10 df #' aghQuad(g, 0, 1.1, rule) #' # actual is 1.25 #' NULL fastGHQuad/R/integrate.R0000644000176200001440000001242414234042346014554 0ustar liggesusers#' Convenience function for Gauss-Hermite quadrature #' #' Convenience function for evaluation of Gauss-Hermite quadrature #' #' This function performs classical unidimensional Gauss-Hermite quadrature #' with the function f using the rule provided; that is, it approximates #' \deqn{\int_{-\infty}^{\infty} f(x) \exp(-x^2) \, dx}{ integral( f(x) #' exp(-x^2), -Inf, Inf)} by evaluating \deqn{ \sum_i w_i f(x_i) }{sum( w * #' f(x) )} #' #' @param f Function to integrate with respect to first (scalar) argument; this #' does not include the weight function \code{exp(-x^2)} #' @param rule Gauss-Hermite quadrature rule to use, as produced by #' \code{\link{gaussHermiteData}} #' @param ... Additional arguments for f #' @return Numeric (scalar) with approximation integral of f(x)*exp(-x^2) from #' -Inf to Inf. #' @author Alexander W Blocker \email{ablocker@@gmail.com} #' @export #' @seealso \code{\link{gaussHermiteData}}, \code{\link{ghQuad}} #' @references Golub, G. H. and Welsch, J. H. (1969). Calculation of Gauss #' Quadrature Rules. Mathematics of Computation 23 (106): 221-230. #' #' Liu, Q. and Pierce, D. A. (1994). A Note on Gauss-Hermite Quadrature. #' Biometrika, 81(3) 624-629. #' @keywords math #' @examples #' #' # Get quadrature rules #' rule10 <- gaussHermiteData(10) #' rule100 <- gaussHermiteData(100) #' #' # Check that rule is implemented correctly #' f <- function(x) rep(1,length(x)) #' if (!isTRUE(all.equal(sqrt(pi), ghQuad(f, rule10), ghQuad(f, rule100)))) { #' print(ghQuad(f, rule10)) #' print(ghQuad(f, rule100)) #' } #' # These should be 1.772454 #' #' f <- function(x) x #' if (!isTRUE(all.equal(0.0, ghQuad(f, rule10), ghQuad(f, rule100)))) { #' print(ghQuad(f, rule10)) #' print(ghQuad(f, rule100)) #' } #' # These should be zero #' #' ghQuad <- function(f, rule, ...) { # Integrate function according to given quadrature rule # Simple wrapper sum(rule$w * f(rule$x, ...)) } #' Adaptive Gauss-Hermite quadrature using Laplace approximation #' #' Convenience function for integration of a scalar function g based upon its #' Laplace approximation. #' #' This function approximates \deqn{\int_{-\infty}^{\infty} g(x) \, dx}{ #' integral( g(x), -Inf, Inf)} using the method of Liu & Pierce (1994). This #' technique uses a Gaussian approximation of g (or the distribution component #' of g, if an expectation is desired) to "focus" quadrature around the #' high-density region of the distribution. Formally, it evaluates: \deqn{ #' \sqrt{2} \hat{\sigma} \sum_i w_i \exp(x_i^2) g(\hat{\mu} + \sqrt{2} }{ #' sqrt(2) * sigmaHat * sum( w * exp(x^2) * g(muHat + sqrt(2) * sigmaHat * x)) #' }\deqn{\hat{\sigma} x_i) }{ sqrt(2) * sigmaHat * sum( w * exp(x^2) * g(muHat #' + sqrt(2) * sigmaHat * x)) } where x and w come from the given rule. #' #' This method can, in many cases (where the Gaussian approximation is #' reasonably good), achieve better results with 10-100 quadrature points than #' with 1e6 or more draws for Monte Carlo integration. It is particularly #' useful for obtaining marginal likelihoods (or posteriors) in hierarchical #' and multilevel models --- where conditional independence allows for #' unidimensional integration, adaptive Gauss-Hermite quadrature is often #' extremely effective. #' #' @param g Function to integrate with respect to first (scalar) argument #' @param muHat Mode for Laplace approximation #' @param sigmaHat Scale for Laplace approximation (\code{sqrt(-1/H)}, where H #' is the second derivative of log(g) at muHat) #' @param rule Gauss-Hermite quadrature rule to use, as produced by #' \code{\link{gaussHermiteData}} #' @param ... Additional arguments for g #' @return Numeric (scalar) with approximation integral of g from -Inf to Inf. #' @author Alexander W Blocker \email{ablocker@@gmail.com} #' @export #' @seealso \code{\link{gaussHermiteData}}, \code{\link{ghQuad}} #' @references Liu, Q. and Pierce, D. A. (1994). A Note on Gauss-Hermite #' Quadrature. Biometrika, 81(3) 624-629. #' @keywords math #' @examples #' #' # Get quadrature rules #' rule10 <- gaussHermiteData(10) #' rule100 <- gaussHermiteData(100) #' #' # Estimating normalizing constants #' g <- function(x) 1/(1+x^2/10)^(11/2) # t distribution with 10 df #' aghQuad(g, 0, 1.1, rule10) #' aghQuad(g, 0, 1.1, rule100) #' # actual is #' 1/dt(0,10) #' #' # Can work well even when the approximation is not exact #' g <- function(x) exp(-abs(x)) # Laplace distribution #' aghQuad(g, 0, 2, rule10) #' aghQuad(g, 0, 2, rule100) #' # actual is 2 #' #' # Estimating expectations #' # Variances for the previous two distributions #' g <- function(x) x^2*dt(x,10) # t distribution with 10 df #' aghQuad(g, 0, 1.1, rule10) #' aghQuad(g, 0, 1.1, rule100) #' # actual is 1.25 #' #' # Can work well even when the approximation is not exact #' g <- function(x) x^2*exp(-abs(x))/2 # Laplace distribution #' aghQuad(g, 0, 2, rule10) #' aghQuad(g, 0, 2, rule100) #' # actual is 2 #' #' aghQuad <- function(g, muHat, sigmaHat, rule, ...) { # Adaptive Gauss-Hermite quadrature as in Liu & Pierce (1994) # Get transformed nodes z <- muHat + sqrt(2)*sigmaHat*rule$x # Transform weights to account for use of importance-sampling type ratio wStar <- exp(rule$x*rule$x + log(rule$w)) wStar # Approximate integrate val <- sqrt(2)*sigmaHat*sum(wStar*g(z, ...)) return(val) } fastGHQuad/R/lib.R0000644000176200001440000000707714234042346013350 0ustar liggesusers#' Evaluate Hermite polynomial at given location #' #' Evaluate Hermite polynomial of given degree at given location. This function #' is provided for demonstration/teaching purposes; this method is not used by #' gaussHermiteData. It is numerically unstable for high-degree polynomials. #' #' #' @param x Vector of location(s) at which polynomial will be evaluated #' @param n Degree of Hermite polynomial to compute #' @return Vector of length(x) values of Hermite polynomial #' @author Alexander W Blocker \email{ablocker@@gmail.com} #' @export #' @seealso \code{\link{gaussHermiteData}}, \code{\link{aghQuad}}, #' \code{\link{ghQuad}} #' @keywords math evalHermitePoly <- function(x, n) { .Call("evalHermitePoly", x, n, PACKAGE="fastGHQuad") } #' Find real parts of roots of polynomial #' #' Finds real parts of polynomial's roots via eigendecomposition of companion #' matrix. This method is not used by gaussHermiteData. Only the real parts of #' each root are retained; this can be useful if the polynomial is known a #' priori to have all roots real. #' #' #' @param c Coefficients of polynomial #' @return Numeric vector containing the real parts of the roots of the #' polynomial defined by c #' @author Alexander W Blocker \email{ablocker@@gmail.com} #' @export #' @seealso \code{\link{gaussHermiteData}}, \code{\link{aghQuad}}, #' \code{\link{ghQuad}} #' @keywords math findPolyRoots <- function(c) { .Call("findPolyRoots", c, PACKAGE="fastGHQuad") } #' Get coefficient of Hermite polynomial #' #' Calculate coefficients of Hermite polynomial using recursion relation. This #' function is provided for demonstration/teaching purposes; this method is not #' used by gaussHermiteData. It is numerically unstable for high-degree #' polynomials. #' #' #' @param n Degree of Hermite polynomial to compute #' @return Vector of (n+1) coefficients from requested polynomial #' @author Alexander W Blocker \email{ablocker@@gmail.com} #' @export #' @seealso \code{\link{gaussHermiteData}}, \code{\link{aghQuad}}, #' \code{\link{ghQuad}} #' @keywords math hermitePolyCoef <- function(n) { .Call("hermitePolyCoef", n, PACKAGE="fastGHQuad") } #' Compute Gauss-Hermite quadrature rule #' #' Computes Gauss-Hermite quadrature rule of requested order using Golub-Welsch #' algorithm. Returns result in list consisting of two entries: x, for nodes, #' and w, for quadrature weights. This is very fast and numerically stable, #' using the Golub-Welsch algorithm with specialized eigendecomposition #' (symmetric tridiagonal) LAPACK routines. It can handle quadrature of order #' 1000+. #' #' This function computes the Gauss-Hermite rule of order n using the #' Golub-Welsch algorithm. All of the actual computation is performed in C/C++ #' and FORTRAN (via LAPACK). It is numerically-stable and extremely #' memory-efficient for rules of order 1000+. #' #' @param n Order of Gauss-Hermite rule to compute (number of nodes) #' @return A list containing: \item{x}{the n node positions for the requested #' rule} \item{w}{the w quadrature weights for the requested rule} #' @author Alexander W Blocker \email{ablocker@@gmail.com} #' @export #' @seealso \code{\link{aghQuad}}, \code{\link{ghQuad}} #' @references Golub, G. H. and Welsch, J. H. (1969). Calculation of Gauss #' Quadrature Rules. Mathematics of Computation 23 (106): 221-230 #' #' Liu, Q. and Pierce, D. A. (1994). A Note on Gauss-Hermite Quadrature. #' Biometrika, 81(3) 624-629. #' @keywords math gaussHermiteData <- function(n) { if (n < 1) { stop("n must be a positive integer") } .Call("gaussHermiteData", n, PACKAGE="fastGHQuad") } fastGHQuad/MD50000644000176200001440000000173314235056774012572 0ustar liggesusers3f94dfe715dd8960bfad61a9596004d3 *ChangeLog afb9dd33b29f96ded5ea606f54803a43 *DESCRIPTION 37da4c2588d5c58d8594203cb8af5d35 *LICENSE cf3c07d26931e06ffe3466ac68a901cd *NAMESPACE 839aee87bccb77c3f3b8b0ba3970a0b2 *R/integrate.R 1ba7c1f97da03e39f3db4b2144d7af6d *R/lib.R 738a1a42bbaf28e03034880cea74b60e *R/zzz.R a9da0e95cbd8d3025e902488d2046393 *inst/include/fastGHQuad.h 6753bca9eb0f7c2d9a8c6e466c2f5f9d *man/aghQuad.Rd 5cc2c738e02cc2763bbe39748cac81e4 *man/evalHermitePoly.Rd be7b22cc32ee8063b77687db113da570 *man/fastGHQuad-package.Rd c2aa875e31d1815063d143f23af4cc4b *man/findPolyRoots.Rd 791bff7a3252af10eaf45b927b5bc4ce *man/gaussHermiteData.Rd f104bbaca9eee752598b2beb7db754d9 *man/ghQuad.Rd 64142c21d84c09fddefa854e0159bd0c *man/hermitePolyCoef.Rd d8cd66cf6671c273eaf174c37e2bcdb4 *src/Makevars 006c88eb3d4425d448d7bf2805f1fa2c *src/Makevars.win d4276a889eba44925eb17f397d8d8a6f *src/init.cpp afc6d4ad79c360aa8349ade4ba45e67f *src/lib.cpp 6119e04e43ff842366490417782cece9 *src/lib.h fastGHQuad/inst/0000755000176200001440000000000014234042346013220 5ustar liggesusersfastGHQuad/inst/include/0000755000176200001440000000000014234042346014643 5ustar liggesusersfastGHQuad/inst/include/fastGHQuad.h0000644000176200001440000000240314234042346017002 0ustar liggesusers#ifndef RCPP_fastGHQuad_H_ #define RCPP_fastGHQuad_H_ #include #include #ifdef __cplusplus extern "C" { #endif namespace fastGHQuad { using namespace Rcpp; int gaussHermiteDataDirect(int n, std::vector* x, std::vector* w) { static int(*fun)(int, std::vector*, std::vector*) = NULL; if (fun == NULL) { Rf_eval(Rf_lang2(Rf_install("loadNamespace"), Rf_ScalarString(Rf_mkChar("fastGHQuad"))), R_GlobalEnv); fun = (int(*)(int, std::vector*, std::vector*)) R_GetCCallable("fastGHQuad","gaussHermiteDataDirect"); } return fun(n, x, w); } int gaussHermiteDataGolubWelsch(int n, std::vector* x, std::vector* w) { static int(*fun)(int, std::vector*, std::vector*) = NULL; if (fun == NULL) { Rf_eval(Rf_lang2(Rf_install("loadNamespace"), Rf_ScalarString(Rf_mkChar("fastGHQuad"))), R_GlobalEnv); fun = (int(*)(int, std::vector*, std::vector*)) R_GetCCallable("fastGHQuad","gaussHermiteDataGolubWelsch"); } return fun(n, x, w); } } #ifdef __cplusplus } #endif #endif // RCPP_fastGHQuad_H_