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)); }