https://github.com/cran/RcppDist
Raw File
Tip revision: 284f8657fb9540fadcc77f069db6a626bebf89b0 authored by JB Duck-Mayr on 28 October 2018, 21:50:09 UTC
version 0.1.1
Tip revision: 284f865
RcppExports.R
# Generated by using Rcpp::compileAttributes() -> do not edit by hand
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393

#' bayeslm
#'
#' Demonstrates the use of RcppDist in C++ with Bayesian linear regression
#'
#' To see an example of using RcppDist C++ functions in C++ code,
#' we can code up a Bayesian linear regression with completely uninformative
#' priors (such that estimates should be equivalent to classical estimates).
#' The code to do so is as follows:
#' \preformatted{
#' #include <RcppDist.h>
#' // or, alternatively,
#' // #include <RcppArmadillo.h>
#' // #include <mvnorm.h>
#'
#' // [[Rcpp::depends(RcppArmadillo, RcppDist)]]
#'
#' // [[Rcpp::export]]
#' Rcpp::List bayeslm(const arma::vec& y, const arma::mat x,
#'                    const int iters = 1000) {
#'     int n = x.n_rows;
#'     int p = x.n_cols;
#'     double a = (n - p) / 2.0;
#'     arma::mat xtx = x.t() * x;
#'     arma::mat xtxinv = xtx.i();
#'     arma::vec mu = xtxinv * x.t() * y;
#'     arma::mat px = x * xtxinv * x.t();
#'     double ssq = arma::as_scalar(y.t() * (arma::eye(n, n) - px) * y);
#'     ssq *= (1.0 / (n - p));
#'     double b = 1.0 / (a * ssq);
#'     arma::mat beta_draws(iters, p);
#'     Rcpp::NumericVector sigma_draws(iters);
#'     for ( int iter = 0; iter < iters; ++iter ) {
#'         double sigmasq = 1.0 / R::rgamma(a, b);
#'         sigma_draws[iter] = sigmasq;
#'         // Here we can use our multivariate normal generator
#'         beta_draws.row(iter) = rmvnorm(1, mu, xtxinv * sigmasq);
#'     }
#'     return Rcpp::List::create(Rcpp::_["beta_draws"] = beta_draws,
#'                               Rcpp::_["sigma_draws"] = sigma_draws);
#' }
#' }
#'
#' @param y A numeric vector -- the response
#' @param x A numeric matrix -- the explanatory variables; note this assumes
#'   you have included a column of ones if you intend there to be an intercept.
#' @param iters An integer vector of length one, the number of posterior draws
#'   desired; the default is 1000.
#'
#' @return A list of length two; the first element is a numeric matrix of the
#'   beta draws and the second element is a numeric vector of the sigma draws
#' @examples
#' set.seed(123)
#' n <- 30
#' x <- cbind(1, matrix(rnorm(n*3), ncol = 3))
#' beta <- matrix(c(10, 2, -1, 3), nrow = 4)
#' y <- x %*% beta + rnorm(n)
#' freqmod <- lm(y ~ x[ , -1])
#' bayesmod <- bayeslm(y, x)
#' round(unname(coef(freqmod)), 2)
#' round(apply(bayesmod$beta_draws, 2, mean), 2)
#' c(beta)
#' @export
bayeslm <- function(y, x, iters = 1000L) {
    .Call('_RcppDist_bayeslm', PACKAGE = 'RcppDist', y, x, iters)
}

test_d4beta <- function(x, shape1, shape2, a, b) {
    .Call('_RcppDist_test_d4beta', PACKAGE = 'RcppDist', x, shape1, shape2, a, b)
}

test_p4beta <- function(x, shape1, shape2, a, b) {
    .Call('_RcppDist_test_p4beta', PACKAGE = 'RcppDist', x, shape1, shape2, a, b)
}

test_q4beta_nolog <- function(x, shape1, shape2, a, b) {
    .Call('_RcppDist_test_q4beta_nolog', PACKAGE = 'RcppDist', x, shape1, shape2, a, b)
}

test_q4beta_log <- function(x, shape1, shape2, a, b) {
    .Call('_RcppDist_test_q4beta_log', PACKAGE = 'RcppDist', x, shape1, shape2, a, b)
}

test_dlst <- function(x, df, mu, sigma) {
    .Call('_RcppDist_test_dlst', PACKAGE = 'RcppDist', x, df, mu, sigma)
}

test_plst <- function(x, df, mu, sigma) {
    .Call('_RcppDist_test_plst', PACKAGE = 'RcppDist', x, df, mu, sigma)
}

test_qlst_nolog <- function(x, df, mu, sigma) {
    .Call('_RcppDist_test_qlst_nolog', PACKAGE = 'RcppDist', x, df, mu, sigma)
}

test_qlst_log <- function(x, df, mu, sigma) {
    .Call('_RcppDist_test_qlst_log', PACKAGE = 'RcppDist', x, df, mu, sigma)
}

test_dtruncnorm <- function(x, mu, sigma, a, b) {
    .Call('_RcppDist_test_dtruncnorm', PACKAGE = 'RcppDist', x, mu, sigma, a, b)
}

test_ptruncnorm <- function(x, mu, sigma, a, b) {
    .Call('_RcppDist_test_ptruncnorm', PACKAGE = 'RcppDist', x, mu, sigma, a, b)
}

test_qtruncnorm_nolog <- function(x, mu, sigma, a, b) {
    .Call('_RcppDist_test_qtruncnorm_nolog', PACKAGE = 'RcppDist', x, mu, sigma, a, b)
}

test_qtruncnorm_log <- function(x, mu, sigma, a, b) {
    .Call('_RcppDist_test_qtruncnorm_log', PACKAGE = 'RcppDist', x, mu, sigma, a, b)
}

test_dtrunct <- function(x, df, a, b) {
    .Call('_RcppDist_test_dtrunct', PACKAGE = 'RcppDist', x, df, a, b)
}

test_ptrunct <- function(x, df, a, b) {
    .Call('_RcppDist_test_ptrunct', PACKAGE = 'RcppDist', x, df, a, b)
}

test_qtrunct_nolog <- function(x, df, a, b) {
    .Call('_RcppDist_test_qtrunct_nolog', PACKAGE = 'RcppDist', x, df, a, b)
}

test_qtrunct_log <- function(x, df, a, b) {
    .Call('_RcppDist_test_qtrunct_log', PACKAGE = 'RcppDist', x, df, a, b)
}

test_dtrunclst <- function(x, df, mu, sigma, a, b) {
    .Call('_RcppDist_test_dtrunclst', PACKAGE = 'RcppDist', x, df, mu, sigma, a, b)
}

test_ptrunclst <- function(x, df, mu, sigma, a, b) {
    .Call('_RcppDist_test_ptrunclst', PACKAGE = 'RcppDist', x, df, mu, sigma, a, b)
}

test_qtrunclst_nolog <- function(x, df, mu, sigma, a, b) {
    .Call('_RcppDist_test_qtrunclst_nolog', PACKAGE = 'RcppDist', x, df, mu, sigma, a, b)
}

test_qtrunclst_log <- function(x, df, mu, sigma, a, b) {
    .Call('_RcppDist_test_qtrunclst_log', PACKAGE = 'RcppDist', x, df, mu, sigma, a, b)
}

test_dtri <- function(x, a, b, c) {
    .Call('_RcppDist_test_dtri', PACKAGE = 'RcppDist', x, a, b, c)
}

test_ptri <- function(x, a, b, c) {
    .Call('_RcppDist_test_ptri', PACKAGE = 'RcppDist', x, a, b, c)
}

test_qtri_nolog <- function(x, a, b, c) {
    .Call('_RcppDist_test_qtri_nolog', PACKAGE = 'RcppDist', x, a, b, c)
}

test_qtri_log <- function(x, a, b, c) {
    .Call('_RcppDist_test_qtri_log', PACKAGE = 'RcppDist', x, a, b, c)
}

test_dmvnorm <- function(x, mu, S) {
    .Call('_RcppDist_test_dmvnorm', PACKAGE = 'RcppDist', x, mu, S)
}

test_dmvt <- function(x, mu, S, df) {
    .Call('_RcppDist_test_dmvt', PACKAGE = 'RcppDist', x, mu, S, df)
}

test_dwish <- function(x, df, S) {
    .Call('_RcppDist_test_dwish', PACKAGE = 'RcppDist', x, df, S)
}

test_diwish <- function(x, df, S) {
    .Call('_RcppDist_test_diwish', PACKAGE = 'RcppDist', x, df, S)
}

back to top