// Coordinate descent for gaussian models
SEXP cdfit_gaussian(SEXP X_, SEXP y_, SEXP penalty_, SEXP lambda, SEXP eps_, SEXP max_iter_, SEXP gamma_, SEXP multiplier, SEXP alpha_, SEXP dfmax_, SEXP user_) {
// Declarations
int n = length(y_);
int p = length(X_)/n;
int L = length(lambda);
SEXP res, beta, loss, iter;
PROTECT(beta = allocVector(REALSXP, L*p));
double *b = REAL(beta);
for (int j=0; j<(L*p); j++) b[j] = 0;
PROTECT(loss = allocVector(REALSXP, L));
PROTECT(iter = allocVector(INTSXP, L));
for (int i=0; i<L; i++) INTEGER(iter)[i] = 0;
double *a = Calloc(p, double); // Beta from previous iteration
for (int j=0; j<p; j++) a[j]=0;
double *X = REAL(X_);
double *y = REAL(y_);
const char *penalty = CHAR(STRING_ELT(penalty_, 0));
double *lam = REAL(lambda);
double eps = REAL(eps_)[0];
int max_iter = INTEGER(max_iter_)[0];
double gamma = REAL(gamma_)[0];
double *m = REAL(multiplier);
double alpha = REAL(alpha_)[0];
int dfmax = INTEGER(dfmax_)[0];
int user = INTEGER(user_)[0];
double *r = Calloc(n, double);
for (int i=0; i<n; i++) r[i] = y[i];
double *z = Calloc(p, double);
for (int j=0; j<p; j++) z[j] = crossprod(X, r, n, j)/n;
int *e1 = Calloc(p, int);
for (int j=0; j<p; j++) e1[j] = 0;
int *e2 = Calloc(p, int);
for (int j=0; j<p; j++) e2[j] = 0;
double cutoff, l1, l2;
int lstart;
// If lam[0]=lam_max, skip lam[0] -- closed form sol'n available
double rss = gLoss(r,n);
if (user) {
lstart = 0;
} else {
REAL(loss)[0] = rss;
lstart = 1;
}
double sdy = sqrt(rss/n);
// Path
for (int l=lstart;l<L;l++) {
R_CheckUserInterrupt();
if (l != 0) {
// Assign a
for (int j=0;j<p;j++) a[j] = b[(l-1)*p+j];
// Check dfmax
int nv = 0;
for (int j=0; j<p; j++) {
if (a[j] != 0) nv++;
}
if (nv > dfmax) {
for (int ll=l; ll<L; ll++) INTEGER(iter)[ll] = NA_INTEGER;
res = cleanupG(a, r, e1, e2, z, beta, loss, iter);
return(res);
}
// Determine eligible set
if (strcmp(penalty, "lasso")==0) cutoff = 2*lam[l] - lam[l-1];
if (strcmp(penalty, "MCP")==0) cutoff = lam[l] + gamma/(gamma-1)*(lam[l] - lam[l-1]);
if (strcmp(penalty, "SCAD")==0) cutoff = lam[l] + gamma/(gamma-2)*(lam[l] - lam[l-1]);
for (int j=0; j<p; j++) if (fabs(z[j]) > (cutoff * alpha * m[j])) e2[j] = 1;
} else {
// Determine eligible set
double lmax = 0;
for (int j=0; j<p; j++) if (fabs(z[j]) > lmax) lmax = fabs(z[j]);
if (strcmp(penalty, "lasso")==0) cutoff = 2*lam[l] - lmax;
if (strcmp(penalty, "MCP")==0) cutoff = lam[l] + gamma/(gamma-1)*(lam[l] - lmax);
if (strcmp(penalty, "SCAD")==0) cutoff = lam[l] + gamma/(gamma-2)*(lam[l] - lmax);
for (int j=0; j<p; j++) if (fabs(z[j]) > (cutoff * alpha * m[j])) e2[j] = 1;
}
while (INTEGER(iter)[l] < max_iter) {
while (INTEGER(iter)[l] < max_iter) {
while (INTEGER(iter)[l] < max_iter) {
// Solve over the active set
INTEGER(iter)[l]++;
double maxChange = 0;
for (int j=0; j<p; j++) {
if (e1[j]) {
z[j] = crossprod(X, r, n, j)/n + a[j];
// Update beta_j
l1 = lam[l] * m[j] * alpha;
l2 = lam[l] * m[j] * (1-alpha);
if (strcmp(penalty,"MCP")==0) b[l*p+j] = MCP(z[j], l1, l2, gamma, 1);
if (strcmp(penalty,"SCAD")==0) b[l*p+j] = SCAD(z[j], l1, l2, gamma, 1);
if (strcmp(penalty,"lasso")==0) b[l*p+j] = lasso(z[j], l1, l2, 1);
// Update r
double shift = b[l*p+j] - a[j];
if (shift !=0) {
for (int i=0;i<n;i++) r[i] -= shift*X[j*n+i];
if (fabs(shift) > maxChange) maxChange = fabs(shift);
}
}
}
// Check for convergence
for (int j=0; j<p; j++) a[j] = b[l*p+j];
if (maxChange < eps*sdy) break;
}
// Scan for violations in strong set
int violations = 0;
for (int j=0; j<p; j++) {
if (e1[j]==0 & e2[j]==1) {
z[j] = crossprod(X, r, n, j)/n;
// Update beta_j
l1 = lam[l] * m[j] * alpha;
l2 = lam[l] * m[j] * (1-alpha);
if (strcmp(penalty,"MCP")==0) b[l*p+j] = MCP(z[j], l1, l2, gamma, 1);
if (strcmp(penalty,"SCAD")==0) b[l*p+j] = SCAD(z[j], l1, l2, gamma, 1);
if (strcmp(penalty,"lasso")==0) b[l*p+j] = lasso(z[j], l1, l2, 1);
// If something enters the eligible set, update eligible set & residuals
if (b[l*p+j] !=0) {
e1[j] = e2[j] = 1;
for (int i=0; i<n; i++) r[i] -= b[l*p+j]*X[j*n+i];
a[j] = b[l*p+j];
violations++;
}
}
}
if (violations==0) break;
}
// Scan for violations in rest
int violations = 0;
for (int j=0; j<p; j++) {
if (e2[j]==0) {
z[j] = crossprod(X, r, n, j)/n;
// Update beta_j
l1 = lam[l] * m[j] * alpha;
l2 = lam[l] * m[j] * (1-alpha);
if (strcmp(penalty,"MCP")==0) b[l*p+j] = MCP(z[j], l1, l2, gamma, 1);
if (strcmp(penalty,"SCAD")==0) b[l*p+j] = SCAD(z[j], l1, l2, gamma, 1);
if (strcmp(penalty,"lasso")==0) b[l*p+j] = lasso(z[j], l1, l2, 1);
// If something enters the eligible set, update eligible set & residuals
if (b[l*p+j] !=0) {
e1[j] = e2[j] = 1;
for (int i=0; i<n; i++) r[i] -= b[l*p+j]*X[j*n+i];
a[j] = b[l*p+j];
violations++;
}
}
}
if (violations==0) {
break;
}
}
REAL(loss)[l] = gLoss(r, n);
}
res = cleanupG(a, r, e1, e2, z, beta, loss, iter);
return(res);
}
// Coordinate descent for gaussian models (no active cycling)
RcppExport SEXP cdfit_gaussian_nac(SEXP X_, SEXP y_, SEXP row_idx_,
SEXP lambda_, SEXP nlambda_,
SEXP lam_scale_, SEXP lambda_min_,
SEXP alpha_, SEXP user_, SEXP eps_,
SEXP max_iter_, SEXP multiplier_, SEXP dfmax_,
SEXP ncore_, SEXP verbose_) {
XPtr<BigMatrix> xMat(X_);
double *y = REAL(y_);
int *row_idx = INTEGER(row_idx_);
double lambda_min = REAL(lambda_min_)[0];
double alpha = REAL(alpha_)[0];
int n = Rf_length(row_idx_); // number of observations used for fitting model
int p = xMat->ncol();
int L = INTEGER(nlambda_)[0];
int lam_scale = INTEGER(lam_scale_)[0];
int user = INTEGER(user_)[0];
int verbose = INTEGER(verbose_)[0];
double eps = REAL(eps_)[0];
int max_iter = INTEGER(max_iter_)[0];
double *m = REAL(multiplier_);
int dfmax = INTEGER(dfmax_)[0];
NumericVector lambda(L);
NumericVector center(p);
NumericVector scale(p);
int p_keep = 0;
int *p_keep_ptr = &p_keep;
vector<int> col_idx;
vector<double> z;
double lambda_max = 0.0;
double *lambda_max_ptr = &lambda_max;
int xmax_idx = 0;
int *xmax_ptr = &xmax_idx;
// set up omp
int useCores = INTEGER(ncore_)[0];
#ifdef BIGLASSO_OMP_H_
int haveCores = omp_get_num_procs();
if(useCores < 1) {
useCores = haveCores;
}
omp_set_dynamic(0);
omp_set_num_threads(useCores);
#endif
if (verbose) {
char buff1[100];
time_t now1 = time (0);
strftime (buff1, 100, "%Y-%m-%d %H:%M:%S.000", localtime (&now1));
Rprintf("\nPreprocessing start: %s\n", buff1);
}
// standardize: get center, scale; get p_keep_ptr, col_idx; get z, lambda_max, xmax_idx;
standardize_and_get_residual(center, scale, p_keep_ptr, col_idx, z, lambda_max_ptr, xmax_ptr, xMat,
y, row_idx, lambda_min, alpha, n, p);
p = p_keep; // set p = p_keep, only loop over columns whose scale > 1e-6
if (verbose) {
char buff1[100];
time_t now1 = time (0);
strftime (buff1, 100, "%Y-%m-%d %H:%M:%S.000", localtime (&now1));
Rprintf("Preprocessing end: %s\n", buff1);
Rprintf("\n-----------------------------------------------\n");
}
// Objects to be returned to R
arma::sp_mat beta = arma::sp_mat(p, L); // beta
double *a = Calloc(p, double); //Beta from previous iteration
NumericVector loss(L);
IntegerVector iter(L);
IntegerVector n_reject(L);
double l1, l2, shift;
double max_update, update, thresh; // for convergence check
int i, j, jj, l, lstart;
double *r = Calloc(n, double);
for (i = 0; i < n; i++) r[i] = y[i];
double sumResid = sum(r, n);
loss[0] = gLoss(r,n);
thresh = eps * loss[0] / n;
// set up lambda
if (user == 0) {
if (lam_scale) { // set up lambda, equally spaced on log scale
double log_lambda_max = log(lambda_max);
double log_lambda_min = log(lambda_min*lambda_max);
double delta = (log_lambda_max - log_lambda_min) / (L-1);
for (l = 0; l < L; l++) {
lambda[l] = exp(log_lambda_max - l * delta);
}
} else { // equally spaced on linear scale
double delta = (lambda_max - lambda_min*lambda_max) / (L-1);
for (l = 0; l < L; l++) {
lambda[l] = lambda_max - l * delta;
}
}
lstart = 1;
} else {
lstart = 0;
lambda = Rcpp::as<NumericVector>(lambda_);
}
// Path
for (l = lstart; l < L; l++) {
if(verbose) {
// output time
char buff[100];
time_t now = time (0);
strftime (buff, 100, "%Y-%m-%d %H:%M:%S.000", localtime (&now));
Rprintf("Lambda %d. Now time: %s\n", l, buff);
}
if (l != 0) {
// Check dfmax
int nv = 0;
for (j = 0; j < p; j++) {
if (a[j] != 0) nv++;
}
if (nv > dfmax) {
for (int ll=l; ll<L; ll++) iter[ll] = NA_INTEGER;
Free_memo_nac(a, r);
return List::create(beta, center, scale, lambda, loss, iter, n_reject, Rcpp::wrap(col_idx));
}
}
while(iter[l] < max_iter) {
iter[l]++;
max_update = 0.0;
for (j = 0; j < p; j++) {
jj = col_idx[j];
z[j] = crossprod_resid(xMat, r, sumResid, row_idx, center[jj], scale[jj], n, jj) / n + a[j];
l1 = lambda[l] * m[jj] * alpha;
l2 = lambda[l] * m[jj] * (1-alpha);
beta(j, l) = lasso(z[j], l1, l2, 1);
shift = beta(j, l) - a[j];
if (shift !=0) {
// compute objective update for checking convergence
//update = z[j] * shift - 0.5 * (1 + l2) * (pow(beta(j, l), 2) - pow(a[j], 2)) - l1 * (fabs(beta(j, l)) - fabs(a[j]));
update = pow(beta(j, l) - a[j], 2);
if (update > max_update) {
max_update = update;
}
update_resid(xMat, r, shift, row_idx, center[jj], scale[jj], n, jj); // update r
sumResid = sum(r, n); //update sum of residual
a[j] = beta(j, l); //update a
}
}
// Check for convergence
if (max_update < thresh) {
loss[l] = gLoss(r, n);
break;
}
}
}
Free_memo_nac(a, r);
return List::create(beta, center, scale, lambda, loss, iter, n_reject, Rcpp::wrap(col_idx));
}
SEXP gdfit_gaussian(SEXP X_, SEXP y_, SEXP penalty_, SEXP K1_, SEXP K0_, SEXP lambda, SEXP alpha_, SEXP eps_, SEXP max_iter_, SEXP gamma_, SEXP group_multiplier, SEXP dfmax_, SEXP gmax_, SEXP user_) {
// Lengths/dimensions
int n = length(y_);
int L = length(lambda);
int J = length(K1_) - 1;
int p = length(X_)/n;
// Pointers
double *X = REAL(X_);
double *y = REAL(y_);
const char *penalty = CHAR(STRING_ELT(penalty_, 0));
int *K1 = INTEGER(K1_);
int K0 = INTEGER(K0_)[0];
double *lam = REAL(lambda);
double alpha = REAL(alpha_)[0];
double eps = REAL(eps_)[0];
int max_iter = INTEGER(max_iter_)[0];
double gamma = REAL(gamma_)[0];
double *m = REAL(group_multiplier);
int dfmax = INTEGER(dfmax_)[0];
int gmax = INTEGER(gmax_)[0];
int user = INTEGER(user_)[0];
// Outcome
SEXP res, beta, iter, df, loss;
PROTECT(beta = allocVector(REALSXP, L*p));
for (int j=0; j<(L*p); j++) REAL(beta)[j] = 0;
PROTECT(iter = allocVector(INTSXP, L));
for (int i=0; i<L; i++) INTEGER(iter)[i] = 0;
PROTECT(df = allocVector(REALSXP, L));
for (int i=0; i<L; i++) REAL(df)[i] = 0;
PROTECT(loss = allocVector(REALSXP, L));
for (int i=0; i<L; i++) REAL(loss)[i] = 0;
double *b = REAL(beta);
// Intermediate quantities
double *r = Calloc(n, double);
for (int i=0; i<n; i++) r[i] = y[i];
double *a = Calloc(p, double);
for (int j=0; j<p; j++) a[j] = 0;
int *e = Calloc(J, int);
for (int g=0; g<J; g++) e[g] = 0;
int converged, lstart, ng, nv, violations;
double shift, l1, l2;
// If lam[0]=lam_max, skip lam[0] -- closed form sol'n available
if (user) {
lstart = 0;
} else {
REAL(loss)[0] = gLoss(r,n);
lstart = 1;
}
// Path
for (int l=lstart; l<L; l++) {
R_CheckUserInterrupt();
if (l != 0) {
for (int j=0; j<p; j++) a[j] = b[(l-1)*p+j];
// Check dfmax, gmax
ng = 0;
nv = 0;
for (int g=0; g<J; g++) {
if (a[K1[g]] != 0) {
ng++;
nv = nv + (K1[g+1]-K1[g]);
}
}
if (ng > gmax | nv > dfmax) {
for (int ll=l; ll<L; ll++) INTEGER(iter)[ll] = NA_INTEGER;
res = cleanupG(a, r, e, beta, iter, df, loss);
return(res);
}
}
while (INTEGER(iter)[l] < max_iter) {
while (INTEGER(iter)[l] < max_iter) {
converged = 0;
INTEGER(iter)[l]++;
REAL(df)[l] = 0;
// Update unpenalized covariates
for (int j=0; j<K0; j++) {
shift = crossprod(X, r, n, j)/n;
b[l*p+j] = shift + a[j];
for (int i=0; i<n; i++) r[i] -= shift * X[n*j+i];
REAL(df)[l] += 1;
}
// Update penalized groups
for (int g=0; g<J; g++) {
l1 = lam[l] * m[g] * alpha;
l2 = lam[l] * m[g] * (1-alpha);
if (e[g]) gd_gaussian(b, X, r, g, K1, n, l, p, penalty, l1, l2, gamma, df, a);
}
// Check convergence
if (checkConvergence(b, a, eps, l, p)) {
converged = 1;
REAL(loss)[l] = gLoss(r,n);
break;
}
for (int j=0; j<p; j++) a[j] = b[l*p+j];
}
// Scan for violations
violations = 0;
for (int g=0; g<J; g++) {
if (e[g]==0) {
l1 = lam[l] * m[g] * alpha;
l2 = lam[l] * m[g] * (1-alpha);
gd_gaussian(b, X, r, g, K1, n, l, p, penalty, l1, l2, gamma, df, a);
if (b[l*p+K1[g]] != 0) {
e[g] = 1;
violations++;
}
}
}
if (violations==0) {
REAL(loss)[l] = gLoss(r, n);
break;
}
for (int j=0; j<p; j++) a[j] = b[l*p+j];
}
}
res = cleanupG(a, r, e, beta, iter, df, loss);
return(res);
}
