// [[Rcpp::export]] NumericVector cpp_rlst( const int& n, const NumericVector& nu, const NumericVector& mu, const NumericVector& sigma ) { if (std::min({nu.length(), mu.length(), sigma.length()}) < 1) { Rcpp::warning("NAs produced"); return NumericVector(n, NA_REAL); } NumericVector x(n); bool throw_warning = false; for (int i = 0; i < n; i++) x[i] = rng_lst(GETV(nu, i), GETV(mu, i), GETV(sigma, i), throw_warning); if (throw_warning) Rcpp::warning("NAs produced"); return x; }
// [[Rcpp::export]] NumericVector cpp_dhcauchy( const NumericVector& x, const NumericVector& sigma, const bool& log_prob = false ) { if (std::min({x.length(), sigma.length()}) < 1) { return NumericVector(0); } int Nmax = std::max({ x.length(), sigma.length() }); NumericVector p(Nmax); bool throw_warning = false; for (int i = 0; i < Nmax; i++) p[i] = logpdf_hcauchy(GETV(x, i), GETV(sigma, i), throw_warning); if (!log_prob) p = Rcpp::exp(p); if (throw_warning) Rcpp::warning("NaNs produced"); return p; }
// [[Rcpp::export]] NumericVector cpp_ddgamma( const NumericVector& x, const NumericVector& shape, const NumericVector& scale, const bool& log_prob = false ) { if (std::min({x.length(), shape.length(), scale.length()}) < 1) { return NumericVector(0); } int Nmax = std::max({ x.length(), shape.length(), scale.length() }); NumericVector p(Nmax); bool throw_warning = false; for (int i = 0; i < Nmax; i++) p[i] = pmf_dgamma(GETV(x, i), GETV(shape, i), GETV(scale, i), throw_warning); if (log_prob) p = Rcpp::log(p); if (throw_warning) Rcpp::warning("NaNs produced"); return p; }
// [[Rcpp::export]] NumericVector cpp_phcauchy( const NumericVector& x, const NumericVector& sigma, bool lower_tail = true, bool log_prob = false ) { if (std::min({x.length(), sigma.length()}) < 1) { return NumericVector(0); } int Nmax = std::max({ x.length(), sigma.length() }); NumericVector p(Nmax); bool throw_warning = false; for (int i = 0; i < Nmax; i++) p[i] = cdf_hcauchy(GETV(x, i), GETV(sigma, i), throw_warning); if (!lower_tail) p = 1.0 - p; if (log_prob) p = Rcpp::log(p); if (throw_warning) Rcpp::warning("NaNs produced"); return p; }
// [[Rcpp::export]] NumericVector cpp_rbbinom( const int& n, const NumericVector& size, const NumericVector& alpha, const NumericVector& beta ) { if (std::min({size.length(), alpha.length(), beta.length()}) < 1) { Rcpp::warning("NAs produced"); return NumericVector(n, NA_REAL); } NumericVector x(n); bool throw_warning = false; for (int i = 0; i < n; i++) x[i] = rng_bbinom(GETV(size, i), GETV(alpha, i), GETV(beta, i), throw_warning); if (throw_warning) Rcpp::warning("NAs produced"); return x; }
// [[Rcpp::export]] NumericVector cpp_ddlaplace( const NumericVector& x, const NumericVector& location, const NumericVector& scale, const bool& log_prob = false ) { if (std::min({x.length(), location.length(), scale.length()}) < 1) { return NumericVector(0); } int Nmax = std::max({ x.length(), scale.length(), location.length() }); NumericVector p(Nmax); bool throw_warning = false; for (int i = 0; i < Nmax; i++) p[i] = logpmf_dlaplace(GETV(x, i), GETV(scale, i), GETV(location, i), throw_warning); if (!log_prob) p = Rcpp::exp(p); if (throw_warning) Rcpp::warning("NaNs produced"); return p; }
// [[Rcpp::export]] NumericVector cpp_ddweibull( const NumericVector& x, const NumericVector& q, const NumericVector& beta, const bool& log_prob = false ) { if (std::min({x.length(), q.length(), beta.length()}) < 1) { return NumericVector(0); } int Nmax = std::max({ x.length(), q.length(), beta.length() }); NumericVector p(Nmax); bool throw_warning = false; for (int i = 0; i < Nmax; i++) p[i] = pdf_dweibull(GETV(x, i), GETV(q, i), GETV(beta, i), throw_warning); if (log_prob) p = Rcpp::log(p); if (throw_warning) Rcpp::warning("NaNs produced"); return p; }
// [[Rcpp::export]] NumericVector cpp_rprop( const int& n, const NumericVector& size, const NumericVector& mean, const NumericVector& prior ) { if (std::min({size.length(), mean.length(), prior.length()}) < 1) { Rcpp::warning("NAs produced"); return NumericVector(n, NA_REAL); } NumericVector x(n); bool throw_warning = false; for (int i = 0; i < n; i++) x[i] = rng_prop(GETV(size, i), GETV(mean, i), GETV(prior, i), throw_warning); if (throw_warning) Rcpp::warning("NAs produced"); return x; }
// [[Rcpp::export]] NumericVector cpp_qhcauchy( const NumericVector& p, const NumericVector& sigma, const bool& lower_tail = true, const bool& log_prob = false ) { if (std::min({p.length(), sigma.length()}) < 1) { return NumericVector(0); } int Nmax = std::max({ p.length(), sigma.length() }); NumericVector q(Nmax); NumericVector pp = Rcpp::clone(p); bool throw_warning = false; if (log_prob) pp = Rcpp::exp(pp); if (!lower_tail) pp = 1.0 - pp; for (int i = 0; i < Nmax; i++) q[i] = invcdf_hcauchy(GETV(pp, i), GETV(sigma, i), throw_warning); if (throw_warning) Rcpp::warning("NaNs produced"); return q; }
// [[Rcpp::export]] NumericVector cpp_dbern( const NumericVector& x, const NumericVector& prob, const bool& log_prob = false ) { if (std::min({x.length(), prob.length()}) < 1) { return NumericVector(0); } int Nmax = std::max({ x.length(), prob.length() }); NumericVector p(Nmax); bool throw_warning = false; for (int i = 0; i < Nmax; i++) p[i] = pdf_bernoulli(GETV(x, i), GETV(prob, i), throw_warning); if (log_prob) p = Rcpp::log(p); if (throw_warning) Rcpp::warning("NaNs produced"); return p; }
// [[Rcpp::export]] NumericVector cpp_dgompertz( const NumericVector& x, const NumericVector& a, const NumericVector& b, bool log_prob = false ) { if (std::min({x.length(), a.length(), b.length()}) < 1) { return NumericVector(0); } int Nmax = std::max({ x.length(), a.length(), b.length() }); NumericVector p(Nmax); bool throw_warning = false; for (int i = 0; i < Nmax; i++) p[i] = logpdf_gompertz(GETV(x, i), GETV(a, i), GETV(b, i), throw_warning); if (!log_prob) p = Rcpp::exp(p); if (throw_warning) Rcpp::warning("NaNs produced"); return p; }
// [[Rcpp::export]] NumericVector cpp_rnhyper( const int& nn, const NumericVector& n, const NumericVector& m, const NumericVector& r ) { if (std::min({n.length(), m.length(), r.length()}) < 1) { Rcpp::warning("NAs produced"); return NumericVector(nn, NA_REAL); } double u; NumericVector x(nn); bool throw_warning = false; std::map<std::tuple<int, int, int>, std::vector<double>> memo; for (int i = 0; i < nn; i++) { if (i % 100 == 0) Rcpp::checkUserInterrupt(); if (ISNAN(GETV(n, i)) || ISNAN(GETV(m, i)) || ISNAN(GETV(r, i)) || GETV(r, i) > GETV(m, i) || GETV(n, i) < 0.0 || GETV(m, i) < 0.0 || GETV(r, i) < 0.0 || !isInteger(GETV(n, i), false) || !isInteger(GETV(m, i), false) || !isInteger(GETV(r, i), false)) { throw_warning = true; x[i] = NA_REAL; } else { std::vector<double>& tmp = memo[std::make_tuple( static_cast<int>(i % n.length()), static_cast<int>(i % m.length()), static_cast<int>(i % r.length()) )]; if (!tmp.size()) { tmp = nhyper_table(GETV(n, i), GETV(m, i), GETV(r, i), true); } u = rng_unif(); for (int j = 0; j <= to_pos_int( GETV(n, i) ); j++) { if (tmp[j] >= u) { x[i] = to_dbl(j) + GETV(r, i); break; } } } } if (throw_warning) Rcpp::warning("NAs produced"); return x; }
// [[Rcpp::export]] NumericVector cpp_qprop( const NumericVector& p, const NumericVector& size, const NumericVector& mean, const NumericVector& prior, const bool& lower_tail = true, const bool& log_prob = false ) { if (std::min({p.length(), size.length(), mean.length(), prior.length()}) < 1) { return NumericVector(0); } int Nmax = std::max({ p.length(), size.length(), mean.length(), prior.length() }); NumericVector x(Nmax); NumericVector pp = Rcpp::clone(p); bool throw_warning = false; if (log_prob) pp = Rcpp::exp(pp); if (!lower_tail) pp = 1.0 - pp; for (int i = 0; i < Nmax; i++) x[i] = invcdf_prop(GETV(pp, i), GETV(size, i), GETV(mean, i), GETV(prior, i), throw_warning); if (throw_warning) Rcpp::warning("NaNs produced"); return x; }
// [[Rcpp::export]] NumericVector cpp_dbpois( const NumericVector& x, const NumericVector& y, const NumericVector& a, const NumericVector& b, const NumericVector& c, const bool& log_prob = false ) { if (std::min({x.length(), y.length(), a.length(), b.length(), c.length()}) < 1) { return NumericVector(0); } int Nmax = std::max({ x.length(), y.length(), a.length(), b.length(), c.length() }); NumericVector p(Nmax); bool throw_warning = false; if (x.length() != y.length()) Rcpp::stop("lengths of x and y differ"); for (int i = 0; i < Nmax; i++) p[i] = logpmf_bpois(GETV(x, i), GETV(y, i), GETV(a, i), GETV(b, i), GETV(c, i), throw_warning); if (!log_prob) p = Rcpp::exp(p); if (throw_warning) Rcpp::warning("NaNs produced"); return p; }
// [[Rcpp::export]] NumericVector cpp_pprop( const NumericVector& x, const NumericVector& size, const NumericVector& mean, const NumericVector& prior, const bool& lower_tail = true, const bool& log_prob = false ) { if (std::min({x.length(), size.length(), mean.length(), prior.length()}) < 1) { return NumericVector(0); } int Nmax = std::max({ x.length(), size.length(), mean.length(), prior.length() }); NumericVector p(Nmax); bool throw_warning = false; for (int i = 0; i < Nmax; i++) p[i] = cdf_prop(GETV(x, i), GETV(size, i), GETV(mean, i), GETV(prior, i), throw_warning); if (!lower_tail) p = 1.0 - p; if (log_prob) p = Rcpp::log(p); if (throw_warning) Rcpp::warning("NaNs produced"); return p; }
// [[Rcpp::export]] NumericVector cpp_rhcauchy( const int& n, const NumericVector& sigma ) { if (sigma.length() < 1) { Rcpp::warning("NAs produced"); return NumericVector(n, NA_REAL); } NumericVector x(n); bool throw_warning = false; for (int i = 0; i < n; i++) x[i] = rng_hcauchy(GETV(sigma, i), throw_warning); if (throw_warning) Rcpp::warning("NAs produced"); return x; }
// [[Rcpp::export]] NumericVector cpp_rbern( const int& n, const NumericVector& prob ) { if (prob.length() < 1) { Rcpp::warning("NAs produced"); return NumericVector(n, NA_REAL); } NumericVector x(n); bool throw_warning = false; for (int i = 0; i < n; i++) x[i] = rng_bernoulli(GETV(prob, i), throw_warning); if (throw_warning) Rcpp::warning("NAs produced"); return x; }
// [[Rcpp::export]] NumericVector cpp_qdweibull( const NumericVector& p, const NumericVector& q, const NumericVector& beta, const bool& lower_tail = true, const bool& log_prob = false ) { if (std::min({p.length(), q.length(), beta.length()}) < 1) { return NumericVector(0); } int Nmax = std::max({ p.length(), q.length(), beta.length() }); NumericVector x(Nmax); NumericVector pp = Rcpp::clone(p); bool throw_warning = false; if (log_prob) pp = Rcpp::exp(pp); if (!lower_tail) pp = 1.0 - pp; for (int i = 0; i < Nmax; i++) x[i] = invcdf_dweibull(GETV(pp, i), GETV(q, i), GETV(beta, i), throw_warning); if (throw_warning) Rcpp::warning("NaNs produced"); return x; }
// [[Rcpp::export]] NumericVector cpp_rdweibull( const int& n, const NumericVector& q, const NumericVector& beta ) { if (std::min({q.length(), beta.length()}) < 1) { Rcpp::warning("NAs produced"); return NumericVector(n, NA_REAL); } NumericVector x(n); bool throw_warning = false; for (int i = 0; i < n; i++) x[i] = rng_dweibull(GETV(q, i), GETV(beta, i), throw_warning); if (throw_warning) Rcpp::warning("NAs produced"); return x; }
// [[Rcpp::export]] NumericVector cpp_rpareto( const int& n, const NumericVector& a, const NumericVector& b ) { if (std::min({a.length(), b.length()}) < 1) { Rcpp::warning("NAs produced"); return NumericVector(n, NA_REAL); } NumericVector x(n); bool throw_warning = false; for (int i = 0; i < n; i++) x[i] = rng_pareto(GETV(a, i), GETV(b, i), throw_warning); if (throw_warning) Rcpp::warning("NAs produced"); return x; }
// [[Rcpp::export]] NumericVector cpp_pgompertz( const NumericVector& x, const NumericVector& a, const NumericVector& b, const bool& lower_tail = true, const bool& log_prob = false ) { if (std::min({x.length(), a.length(), b.length()}) < 1) { return NumericVector(0); } int Nmax = std::max({ x.length(), a.length(), b.length() }); NumericVector p(Nmax); bool throw_warning = false; for (int i = 0; i < Nmax; i++) p[i] = cdf_gompertz(GETV(x, i), GETV(a, i), GETV(b, i), throw_warning); if (!lower_tail) p = 1.0 - p; if (log_prob) p = Rcpp::log(p); if (throw_warning) Rcpp::warning("NaNs produced"); return p; }
// [[Rcpp::export]] NumericVector cpp_rdlaplace( const int& n, const NumericVector& location, const NumericVector& scale ) { if (std::min({location.length(), scale.length()}) < 1) { Rcpp::warning("NAs produced"); return NumericVector(n, NA_REAL); } NumericVector x(n); bool throw_warning = false; for (int i = 0; i < n; i++) x[i] = rng_dlaplace(GETV(scale, i), GETV(location, i), throw_warning); if (throw_warning) Rcpp::warning("NAs produced"); return x; }
// [[Rcpp::export]] NumericVector cpp_dbbinom( const NumericVector& x, const NumericVector& size, const NumericVector& alpha, const NumericVector& beta, const bool& log_prob = false ) { if (std::min({x.length(), size.length(), alpha.length(), beta.length()}) < 1) { return NumericVector(0); } int Nmax = std::max({ x.length(), size.length(), alpha.length(), beta.length() }); NumericVector p(Nmax); bool throw_warning = false; for (int i = 0; i < Nmax; i++) p[i] = logpmf_bbinom(GETV(x, i), GETV(size, i), GETV(alpha, i), GETV(beta, i), throw_warning); if (!log_prob) p = Rcpp::exp(p); if (throw_warning) Rcpp::warning("NaNs produced"); return p; }
// [[Rcpp::export]] NumericVector cpp_dlst( const NumericVector& x, const NumericVector& nu, const NumericVector& mu, const NumericVector& sigma, const bool& log_prob = false ) { if (std::min({x.length(), nu.length(), mu.length(), sigma.length()}) < 1) { return NumericVector(0); } int Nmax = std::max({ x.length(), nu.length(), mu.length(), sigma.length() }); NumericVector p(Nmax); bool throw_warning = false; for (int i = 0; i < Nmax; i++) p[i] = pdf_lst(GETV(x, i), GETV(nu, i), GETV(mu, i), GETV(sigma, i), throw_warning); if (log_prob) p = Rcpp::log(p); if (throw_warning) Rcpp::warning("NaNs produced"); return p; }
// [[Rcpp::export]] NumericVector cpp_qnhyper( const NumericVector& p, const NumericVector& n, const NumericVector& m, const NumericVector& r, const bool& lower_tail = true, const bool& log_prob = false ) { if (std::min({p.length(), n.length(), m.length(), r.length()}) < 1) { return NumericVector(0); } int Nmax = std::max({ p.length(), n.length(), m.length(), r.length() }); NumericVector x(Nmax); NumericVector pp = Rcpp::clone(p); bool throw_warning = false; if (log_prob) pp = Rcpp::exp(pp); if (!lower_tail) pp = 1.0 - pp; std::map<std::tuple<int, int, int>, std::vector<double>> memo; for (int i = 0; i < Nmax; i++) { if (i % 100 == 0) Rcpp::checkUserInterrupt(); #ifdef IEEE_754 if (ISNAN(GETV(pp, i)) || ISNAN(GETV(n, i)) || ISNAN(GETV(m, i)) || ISNAN(GETV(r, i))) { x[i] = GETV(pp, i) + GETV(n, i) + GETV(m, i) + GETV(r, i); continue; } #endif if (!VALID_PROB(GETV(pp, i)) || GETV(r, i) > GETV(m, i) || GETV(n, i) < 0.0 || GETV(m, i) < 0.0 || GETV(r, i) < 0.0 || !isInteger(GETV(n, i), false) || !isInteger(GETV(m, i), false) || !isInteger(GETV(r, i), false)) { throw_warning = true; x[i] = NAN; } else { std::vector<double>& tmp = memo[std::make_tuple( static_cast<int>(i % n.length()), static_cast<int>(i % m.length()), static_cast<int>(i % r.length()) )]; if (!tmp.size()) { tmp = nhyper_table(GETV(n, i), GETV(m, i), GETV(r, i), true); } for (int j = 0; j <= to_pos_int( GETV(n, i) ); j++) { if (tmp[j] >= GETV(pp, i)) { x[i] = to_dbl(j) + GETV(r, i); break; } } } } if (throw_warning) Rcpp::warning("NaNs produced"); return x; }
// [[Rcpp::export]] NumericVector cpp_pbbinom( const NumericVector& x, const NumericVector& size, const NumericVector& alpha, const NumericVector& beta, const bool& lower_tail = true, const bool& log_prob = false ) { if (std::min({x.length(), size.length(), alpha.length(), beta.length()}) < 1) { return NumericVector(0); } int Nmax = std::max({ x.length(), size.length(), alpha.length(), beta.length() }); NumericVector p(Nmax); bool throw_warning = false; std::map<std::tuple<int, int, int>, std::vector<double>> memo; // maximum modulo size.length(), bounded in [0, size] int n = x.length(); int k = size.length(); NumericVector mx(k, 0.0); for (int i = 0; i < std::max(n, k); i++) { if (mx[i % k] < GETV(x, i)) { mx[i % k] = std::min(GETV(x, i), GETV(size, i)); } } for (int i = 0; i < Nmax; i++) { if (i % 100 == 0) Rcpp::checkUserInterrupt(); #ifdef IEEE_754 if (ISNAN(GETV(x, i)) || ISNAN(GETV(size, i)) || ISNAN(GETV(alpha, i)) || ISNAN(GETV(beta, i))) { p[i] = GETV(x, i) + GETV(size, i) + GETV(alpha, i) + GETV(beta, i); continue; } #endif if (GETV(alpha, i) <= 0.0 || GETV(beta, i) <= 0.0 || GETV(size, i) < 0.0 || !isInteger(GETV(size, i), false)) { throw_warning = true; p[i] = NAN; } else if (GETV(x, i) < 0.0) { p[i] = 0.0; } else if (GETV(x, i) >= GETV(size, i)) { p[i] = 1.0; } else if (is_large_int(GETV(x, i))) { p[i] = NA_REAL; Rcpp::warning("NAs introduced by coercion to integer range"); } else { std::vector<double>& tmp = memo[std::make_tuple( static_cast<int>(i % size.length()), static_cast<int>(i % alpha.length()), static_cast<int>(i % beta.length()) )]; if (!tmp.size()) { double mxi = std::min(mx[i % size.length()], GETV(size, i)); tmp = cdf_bbinom_table(mx[i % size.length()], GETV(size, i), GETV(alpha, i), GETV(beta, i)); } p[i] = tmp[to_pos_int(GETV(x, i))]; } } if (!lower_tail) p = 1.0 - p; if (log_prob) p = Rcpp::log(p); if (throw_warning) Rcpp::warning("NaNs produced"); return p; }
// [[Rcpp::export]] NumericVector cpp_ddirmnom( const NumericMatrix& x, const NumericVector& size, const NumericMatrix& alpha, const bool& log_prob = false ) { if (std::min({static_cast<int>(x.nrow()), static_cast<int>(x.ncol()), static_cast<int>(size.length()), static_cast<int>(alpha.nrow()), static_cast<int>(alpha.ncol())}) < 1) { return NumericVector(0); } int Nmax = std::max({ static_cast<int>(x.nrow()), static_cast<int>(size.length()), static_cast<int>(alpha.nrow()) }); int m = x.ncol(); int k = alpha.ncol(); k = std::min(m, k); NumericVector p(Nmax); bool throw_warning = false; if (k < 2) Rcpp::stop("number of columns in alpha should be >= 2"); if (m != k) Rcpp::stop("number of columns in x does not equal number of columns in alpha"); double prod_tmp, sum_alpha, sum_x; bool wrong_x, wrong_param; for (int i = 0; i < Nmax; i++) { prod_tmp = 0.0; sum_alpha = 0.0; sum_x = 0.0; wrong_x = false; wrong_param = false; for (int j = 0; j < k; j++) { if (GETM(alpha, i, j) <= 0.0) wrong_param = true; if (GETM(x, i, j) < 0.0 || !isInteger(GETM(x, i, j))) wrong_x = true; sum_x += GETM(x, i, j); sum_alpha += GETM(alpha, i, j); } #ifdef IEEE_754 if (ISNAN(sum_x + sum_alpha + GETV(size, i))) { p[i] = sum_x + sum_alpha + GETV(size, i); continue; } #endif if (wrong_param || GETV(size, i) < 0.0 || !isInteger(GETV(size, i), false)) { throw_warning = true; p[i] = NAN; continue; } if (sum_x < 0.0 || sum_x != GETV(size, i) || wrong_x) { p[i] = R_NegInf; } else { for (int j = 0; j < k; j++) { prod_tmp += R::lgammafn(GETM(x, i, j) + GETM(alpha, i, j)) - (lfactorial(GETM(x, i, j)) + R::lgammafn(GETM(alpha, i, j))); } p[i] = (lfactorial(GETV(size, i)) + R::lgammafn(sum_alpha)) - R::lgammafn(GETV(size, i) + sum_alpha) + prod_tmp; } } if (!log_prob) p = Rcpp::exp(p); if (throw_warning) Rcpp::warning("NaNs produced"); return p; }
// [[Rcpp::export]] NumericVector cpp_ddirichlet( const NumericMatrix& x, const NumericMatrix& alpha, const bool& log_prob = false ) { if (std::min({x.nrow(), x.ncol(), alpha.nrow(), alpha.ncol()}) < 1) { return NumericVector(0); } int Nmax = std::max({ x.nrow(), alpha.nrow() }); int m = x.ncol(); int k = alpha.ncol(); k = std::min(m, k); NumericVector p(Nmax); bool throw_warning = false; if (k < 2) Rcpp::stop("number of columns in alpha should be >= 2"); if (m != k) Rcpp::stop("number of columns in x does not equal number of columns in alpha"); double prod_gamma, sum_alpha, p_tmp, beta_const, sum_x; bool wrong_alpha, wrong_x; for (int i = 0; i < Nmax; i++) { wrong_alpha = false; wrong_x = false; sum_alpha = 0.0; sum_x = 0.0; for (int j = 0; j < m; j++) { sum_alpha += GETM(alpha, i, j); sum_x += GETM(x, i, j); if (GETM(alpha, i, j) <= 0.0) wrong_alpha = true; if (GETM(x, i, j) < 0.0 || GETM(x, i, j) > 1.0) wrong_x = true; } #ifdef IEEE_754 if (ISNAN(sum_x + sum_alpha)) { p[i] = sum_x + sum_alpha; continue; } #endif if (wrong_alpha) { throw_warning = true; p[i] = NAN; } else if (wrong_x) { p[i] = R_NegInf; } else { prod_gamma = 0.0; p_tmp = 0.0; for (int j = 0; j < m; j++) { prod_gamma += R::lgammafn(GETM(alpha, i, j)); p_tmp += log(GETM(x, i, j)) * (GETM(alpha, i, j) - 1.0); if (GETM(alpha, i, j) == 1.0 && GETM(x, i, j) == 0.0) p_tmp = R_NegInf; } beta_const = prod_gamma - R::lgammafn(sum_alpha); p[i] = p_tmp - beta_const; } } if (!log_prob) p = Rcpp::exp(p); if (throw_warning) Rcpp::warning("NaNs produced"); return p; }
// [[Rcpp::export]] NumericVector cpp_dnhyper( const NumericVector& x, const NumericVector& n, const NumericVector& m, const NumericVector& r, const bool& log_prob = false ) { if (std::min({x.length(), n.length(), m.length(), r.length()}) < 1) { return NumericVector(0); } int Nmax = std::max({ x.length(), n.length(), m.length(), r.length() }); NumericVector p(Nmax); bool throw_warning = false; std::map<std::tuple<int, int, int>, std::vector<double>> memo; for (int i = 0; i < Nmax; i++) { if (i % 100 == 0) Rcpp::checkUserInterrupt(); #ifdef IEEE_754 if (ISNAN(GETV(x, i)) || ISNAN(GETV(n, i)) || ISNAN(GETV(m, i)) || ISNAN(GETV(r, i))) { p[i] = GETV(x, i) + GETV(n, i) + GETV(m, i) + GETV(r, i); continue; } #endif if (GETV(r, i) > GETV(m, i) || GETV(n, i) < 0.0 || GETV(m, i) < 0.0 || GETV(r, i) < 0.0 || !isInteger(GETV(n, i), false) || !isInteger(GETV(m, i), false) || !isInteger(GETV(r, i), false)) { throw_warning = true; p[i] = NAN; } else if (!isInteger(GETV(x, i)) || GETV(x, i) < GETV(r, i) || GETV(x, i) > (GETV(n, i) + GETV(r, i))) { p[i] = 0.0; } else if (is_large_int(GETV(x, i))) { p[i] = NA_REAL; Rcpp::warning("NAs introduced by coercion to integer range"); } else { std::vector<double>& tmp = memo[std::make_tuple( static_cast<int>(i % n.length()), static_cast<int>(i % m.length()), static_cast<int>(i % r.length()) )]; if (!tmp.size()) { tmp = nhyper_table(GETV(n, i), GETV(m, i), GETV(r, i), false); } p[i] = tmp[to_pos_int( GETV(x, i) - GETV(r, i) )]; } } if (log_prob) p = Rcpp::log(p); if (throw_warning) Rcpp::warning("NaNs produced"); return p; }