// [[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;
}
