List fastLm(Rcpp::NumericMatrix Xs, Rcpp::NumericVector ys, int type) {
const Map<MatrixXd> X(as<Map<MatrixXd> >(Xs));
const Map<VectorXd> y(as<Map<VectorXd> >(ys));
Index n = X.rows();
if ((Index)y.size() != n) throw invalid_argument("size mismatch");
// Select and apply the least squares method
lm ans(do_lm(X, y, type));
// Copy coefficients and install names, if any
NumericVector coef(wrap(ans.coef()));
List dimnames(NumericMatrix(Xs).attr("dimnames"));
if (dimnames.size() > 1) {
RObject colnames = dimnames[1];
if (!(colnames).isNULL())
coef.attr("names") = clone(CharacterVector(colnames));
}
VectorXd resid = y - ans.fitted();
int rank = ans.rank();
int df = (rank == ::NA_INTEGER) ? n - X.cols() : n - rank;
double s = resid.norm() / std::sqrt(double(df));
// Create the standard errors
VectorXd se = s * ans.se();
return List::create(_["coefficients"] = coef,
_["se"] = se,
_["rank"] = rank,
_["df.residual"] = df,
_["residuals"] = resid,
_["s"] = s,
_["fitted.values"] = ans.fitted());
}
SEXP returnRealIfPossible(Eigen::MatrixBase<Derived> &matvec)
{
SEXP result;
if(matvec.imag().isZero())
result = wrap(matvec.real());
else
result = wrap(matvec);
return result;
}
// [[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_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_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_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_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_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_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_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_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_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;
}
extern "C" SEXP fastLm(SEXP Xs, SEXP ys, SEXP type) {
try {
const Map<MatrixXd> X(as<Map<MatrixXd> >(Xs));
const Map<VectorXd> y(as<Map<VectorXd> >(ys));
Index n = X.rows();
if ((Index)y.size() != n) throw invalid_argument("size mismatch");
// Select and apply the least squares method
lm ans(do_lm(X, y, ::Rf_asInteger(type)));
// Copy coefficients and install names, if any
NumericVector coef(wrap(ans.coef()));
List dimnames(NumericMatrix(Xs).attr("dimnames"));
if (dimnames.size() > 1) {
RObject colnames = dimnames[1];
if (!(colnames).isNULL())
coef.attr("names") = clone(CharacterVector(colnames));
}
VectorXd resid = y - ans.fitted();
int rank = ans.rank();
int df = (rank == ::NA_INTEGER) ? n - X.cols() : n - rank;
double s = resid.norm() / std::sqrt(double(df));
// Create the standard errors
VectorXd se = s * ans.se();
return List::create(_["coefficients"] = coef,
_["se"] = se,
_["rank"] = rank,
_["df.residual"] = df,
_["residuals"] = resid,
_["s"] = s,
_["fitted.values"] = ans.fitted());
} catch( std::exception &ex ) {
forward_exception_to_r( ex );
} catch(...) {
::Rf_error( "c++ exception (unknown reason)" );
}
return R_NilValue; // -Wall
}
// [[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_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_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_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_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_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_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_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;
}
RcppExport SEXP admm_lasso_precond(SEXP x_,
SEXP y_,
SEXP family_,
SEXP lambda_,
SEXP nlambda_,
SEXP lmin_ratio_,
SEXP penalty_factor_,
SEXP standardize_,
SEXP intercept_,
SEXP opts_)
{
BEGIN_RCPP
//Rcpp::NumericMatrix xx(x_);
//Rcpp::NumericVector yy(y_);
Rcpp::NumericMatrix xx(x_);
Rcpp::NumericVector yy(y_);
const int n = xx.rows();
const int p = xx.cols();
MatrixXd datX(n, p);
VectorXd datY(n);
// Copy data
std::copy(xx.begin(), xx.end(), datX.data());
std::copy(yy.begin(), yy.end(), datY.data());
//MatrixXd datX(as<MatrixXd>(x_));
//VectorXd datY(as<VectorXd>(y_));
//const int n = datX.rows();
//const int p = datX.cols();
//MatrixXf datX(n, p);
//VectorXf datY(n);
// Copy data and convert type from double to float
//std::copy(xx.begin(), xx.end(), datX.data());
//std::copy(yy.begin(), yy.end(), datY.data());
// In glmnet, we minimize
// 1/(2n) * ||y - X * beta||^2 + lambda * ||beta||_1
// which is equivalent to minimizing
// 1/2 * ||y - X * beta||^2 + n * lambda * ||beta||_1
ArrayXd lambda(as<ArrayXd>(lambda_));
int nlambda = lambda.size();
List opts(opts_);
const int maxit = as<int>(opts["maxit"]);
const int irls_maxit = as<int>(opts["irls_maxit"]);
const double irls_tol = as<double>(opts["irls_tol"]);
const double eps_abs = as<double>(opts["eps_abs"]);
const double eps_rel = as<double>(opts["eps_rel"]);
const double rho = as<double>(opts["rho"]);
bool standardize = as<bool>(standardize_);
bool intercept = as<bool>(intercept_);
bool intercept_bin = intercept;
CharacterVector family(as<CharacterVector>(family_));
ArrayXd penalty_factor(as<ArrayXd>(penalty_factor_));
// don't standardize if not linear model.
// fit intercept the dumb way if it is wanted
bool fullbetamat = false;
int add = 0;
if (family(0) != "gaussian")
{
standardize = false;
intercept = false;
if (intercept_bin)
{
fullbetamat = true;
add = 1;
// dont penalize the intercept
ArrayXd penalty_factor_tmp(p+1);
penalty_factor_tmp << 0, penalty_factor;
penalty_factor.swap(penalty_factor_tmp);
VectorXd v(n);
v.fill(1);
MatrixXd datX_tmp(n, p+1);
datX_tmp << v, datX;
datX.swap(datX_tmp);
datX_tmp.resize(0,0);
}
}
DataStd<double> datstd(n, p + add, standardize, intercept);
datstd.standardize(datX, datY);
// initialize pointers
FADMMBasePrecond<Eigen::VectorXd, Eigen::SparseVector<double>, Eigen::VectorXd> *solver_tall = NULL; // obj doesn't point to anything yet
ADMMBase<Eigen::SparseVector<double>, Eigen::VectorXd, Eigen::VectorXd> *solver_wide = NULL; // obj doesn't point to anything yet
//ADMMLassoTall *solver_tall;
//ADMMLassoWide *solver_wide;
// initialize classes
if(n > 2 * p)
{
solver_tall = new ADMMLassoTallPrecond(datX, datY, penalty_factor, eps_abs, eps_rel);
} else
{
solver_wide = new ADMMLassoWide(datX, datY, penalty_factor, eps_abs, eps_rel);
}
if (nlambda < 1) {
double lmax = 0.0;
if(n > 2 * p)
{
lmax = solver_tall->get_lambda_zero() / n * datstd.get_scaleY();
} else
{
lmax = solver_wide->get_lambda_zero() / n * datstd.get_scaleY();
}
double lmin = as<double>(lmin_ratio_) * lmax;
lambda.setLinSpaced(as<int>(nlambda_), std::log(lmax), std::log(lmin));
lambda = lambda.exp();
nlambda = lambda.size();
}
SpMat beta(p + 1, nlambda);
beta.reserve(Eigen::VectorXi::Constant(nlambda, std::min(n, p)));
IntegerVector niter(nlambda);
double ilambda = 0.0;
for(int i = 0; i < nlambda; i++)
{
ilambda = lambda[i] * n / datstd.get_scaleY();
if(n > 2 * p)
{
if(i == 0)
solver_tall->init(ilambda, rho);
else
solver_tall->init_warm(ilambda);
niter[i] = solver_tall->solve(maxit);
SpVec res = solver_tall->get_gamma();
double beta0 = 0.0;
if (!fullbetamat)
{
datstd.recover(beta0, res);
}
write_beta_matrix(beta, i, beta0, res, fullbetamat);
} else {
if(i == 0)
solver_wide->init(ilambda, rho);
else
solver_wide->init_warm(ilambda, i);
niter[i] = solver_wide->solve(maxit);
SpVec res = solver_wide->get_beta();
double beta0 = 0.0;
if (!fullbetamat)
{
datstd.recover(beta0, res);
}
write_beta_matrix(beta, i, beta0, res, fullbetamat);
}
}
if(n > 2 * p)
{
delete solver_tall;
}
else
{
delete solver_wide;
}
beta.makeCompressed();
return List::create(Named("lambda") = lambda,
Named("beta") = beta,
Named("niter") = niter);
END_RCPP
}
Rcpp::List EigsGen::extract()
{
int nconv = iparam[5 - 1];
int niter = iparam[9 - 1];
// Sometimes there are nconv = nev + 1 converged eigenvalues,
// mainly due to pairs of complex eigenvalues.
// We will truncate at nev.
int truenconv = nconv > nev ? nev : nconv;
// Converged eigenvalues from aupd()
VectorXcd evalsConverged(nconv);
evalsConverged.real() = MapVec(workl + ncv * ncv, nconv);
evalsConverged.imag() = MapVec(workl + ncv * ncv + ncv, nconv);
// If only eigenvalues are requested
if(!retvec)
{
if(nconv < nev)
::Rf_warning("only %d eigenvalues converged, less than k", nconv);
sortDesc(evalsConverged);
if(evalsConverged.size() > truenconv)
evalsConverged.conservativeResize(truenconv);
return returnResult(returnRealIfPossible(evalsConverged),
R_NilValue, wrap(truenconv), wrap(niter));
}
// Recompute the Hessenburg matrix, since occasionally
// aupd() will give us the incorrect one
recomputeH();
MapMat Hm(workl, ncv, ncv);
MapMat Vm(V, n, ncv);
RealSchur<MatrixXd> schur(Hm);
MatrixXd Qm = schur.matrixU();
MatrixXd Rm = schur.matrixT();
VectorXcd evalsRm(ncv);
VectorXi selectInd(nconv);
eigenvalueSchur(Rm, evalsRm);
findMatchedIndex(evalsConverged.head(nconv), evalsRm, selectInd);
//Rcpp::Rcout << evalsRm << "\n\n";
//Rcpp::Rcout << evalsConverged << "\n\n";
truenconv = selectInd.size();
if(truenconv < 1)
{
::Rf_warning("no converged eigenvalues found");
return returnResult(R_NilValue, R_NilValue, wrap(0L),
wrap(niter));
}
// Shrink Qm and Rm to the dimension given by the largest value
// in selectInd. Since selectInd is strictly increasing,
// we can just use its last value.
int lastInd = selectInd[selectInd.size() - 1];
Qm.conservativeResize(Eigen::NoChange, lastInd + 1);
Rm.conservativeResize(lastInd + 1, lastInd + 1);
// Eigen decomposition of Rm
EigenSolver<MatrixXd> es(Rm);
evalsRm = es.eigenvalues();
MatrixXcd evecsA = Vm * (Qm * es.eigenvectors());
// Order and select eigenvalues/eigenvectors
for(int i = 0; i < truenconv; i++)
{
// Since selectInd[i] >= i for all i, it is safe to
// overwrite the elements and columns.
evalsRm[i] = evalsRm[selectInd[i]];
}
if(evalsRm.size() > truenconv)
evalsRm.conservativeResize(truenconv);
transformEigenvalues(evalsRm);
// Now (evalsRm, selectInd) gives the pair of (value, location)
sortDescPair(evalsRm, selectInd);
if(truenconv > nev)
{
truenconv = nev;
evalsRm.conservativeResize(truenconv);
}
MatrixXcd evecsConverged(n, truenconv);
for(int i = 0; i < truenconv; i++)
{
evecsConverged.col(i) = evecsA.col(selectInd[i]);
}
if(truenconv < nev)
::Rf_warning("only %d eigenvalues converged, less than k", truenconv);
return returnResult(returnRealIfPossible(evalsRm),
returnRealIfPossible(evecsConverged),
wrap(truenconv),
wrap(niter));
}
