/**
* Callback when iterating over stashes
*
* @param index The position within the stash list. 0 points to the
* most recent stashed state.
* @param message The stash message.
* @param stash_id The commit oid of the stashed state.
* @param payload Pointer to a git2r_stash_list_cb_data data structure.
* @return 0 if OK, else error code
*/
static int git2r_stash_list_cb(
size_t index,
const char* message,
const git_oid *stash_id,
void *payload)
{
int error = 0, nprotect = 0;
SEXP stash, class;
git2r_stash_list_cb_data *cb_data = (git2r_stash_list_cb_data*)payload;
/* Check if we have a list to populate */
if (!Rf_isNull(cb_data->list)) {
PROTECT(class = Rf_allocVector(STRSXP, 2));
nprotect++;
SET_STRING_ELT(class, 0, Rf_mkChar("git_stash"));
SET_STRING_ELT(class, 1, Rf_mkChar("git_commit"));
PROTECT(stash = Rf_mkNamed(VECSXP, git2r_S3_items__git_commit));
nprotect++;
Rf_setAttrib(stash, R_ClassSymbol, class);
error = git2r_stash_init(
stash_id,
cb_data->repository,
cb_data->repo,
stash);
if (error)
goto cleanup;
SET_VECTOR_ELT(cb_data->list, cb_data->n, stash);
}
// called from package MatrixModels's R code:
SEXP dgCMatrix_cholsol(SEXP x, SEXP y)
{
/* Solve Sparse Least Squares X %*% beta ~= y with dense RHS y,
* where X = t(x) i.e. we pass x = t(X) as argument,
* via "Cholesky(X'X)" .. well not really:
* cholmod_factorize("x", ..) finds L in X'X = L'L directly */
CHM_SP cx = AS_CHM_SP(x);
/* FIXME: extend this to work in multivariate case, i.e. y a matrix with > 1 column ! */
CHM_DN cy = AS_CHM_DN(coerceVector(y, REALSXP)), rhs, cAns, resid;
CHM_FR L;
int n = cx->ncol;/* #{obs.} {x = t(X) !} */
double one[] = {1,0}, zero[] = {0,0}, neg1[] = {-1,0};
const char *nms[] = {"L", "coef", "Xty", "resid", ""};
SEXP ans = PROTECT(Rf_mkNamed(VECSXP, nms));
R_CheckStack();
if (n < cx->nrow || n <= 0)
error(_("dgCMatrix_cholsol requires a 'short, wide' rectangular matrix"));
if (cy->nrow != n)
error(_("Dimensions of system to be solved are inconsistent"));
rhs = cholmod_allocate_dense(cx->nrow, 1, cx->nrow, CHOLMOD_REAL, &c);
/* cholmod_sdmult(A, transp, alpha, beta, X, Y, &c):
* Y := alpha*(A*X) + beta*Y or alpha*(A'*X) + beta*Y ;
* here: rhs := 1 * x %*% y + 0 = x %*% y = X'y */
if (!(cholmod_sdmult(cx, 0 /* trans */, one, zero, cy, rhs, &c)))
error(_("cholmod_sdmult error (rhs)"));
L = cholmod_analyze(cx, &c);
if (!cholmod_factorize(cx, L, &c))
error(_("cholmod_factorize failed: status %d, minor %d from ncol %d"),
c.status, L->minor, L->n);
/* FIXME: Do this in stages so an "effects" vector can be calculated */
if (!(cAns = cholmod_solve(CHOLMOD_A, L, rhs, &c)))
error(_("cholmod_solve (CHOLMOD_A) failed: status %d, minor %d from ncol %d"),
c.status, L->minor, L->n);
/* L : */
SET_VECTOR_ELT(ans, 0, chm_factor_to_SEXP(L, 0));
/* coef : */
SET_VECTOR_ELT(ans, 1, allocVector(REALSXP, cx->nrow));
Memcpy(REAL(VECTOR_ELT(ans, 1)), (double*)(cAns->x), cx->nrow);
/* X'y : */
/* FIXME: Change this when the "effects" vector is available */
SET_VECTOR_ELT(ans, 2, allocVector(REALSXP, cx->nrow));
Memcpy(REAL(VECTOR_ELT(ans, 2)), (double*)(rhs->x), cx->nrow);
/* resid := y */
resid = cholmod_copy_dense(cy, &c);
/* cholmod_sdmult(A, transp, alp, bet, X, Y, &c):
* Y := alp*(A*X) + bet*Y or alp*(A'*X) + beta*Y ;
* here: resid := -1 * x' %*% coef + 1 * y = y - X %*% coef */
if (!(cholmod_sdmult(cx, 1/* trans */, neg1, one, cAns, resid, &c)))
error(_("cholmod_sdmult error (resid)"));
/* FIXME: for multivariate case, i.e. resid *matrix* with > 1 column ! */
SET_VECTOR_ELT(ans, 3, allocVector(REALSXP, n));
Memcpy(REAL(VECTOR_ELT(ans, 3)), (double*)(resid->x), n);
cholmod_free_factor(&L, &c);
cholmod_free_dense(&rhs, &c);
cholmod_free_dense(&cAns, &c);
UNPROTECT(1);
return ans;
}
/**
* Return compile time options for libgit2.
*
* @return A VECSXP with threads, https and ssh set to TRUE/FALSE
*/
SEXP git2r_libgit2_features(void)
{
const char *names[] = {"threads", "https", "ssh", ""};
int value = git_libgit2_features();
SEXP features;
PROTECT(features = Rf_mkNamed(VECSXP, names));
SET_VECTOR_ELT(features, 0, Rf_ScalarLogical(value & GIT_FEATURE_THREADS));
SET_VECTOR_ELT(features, 1, Rf_ScalarLogical(value & GIT_FEATURE_HTTPS));
SET_VECTOR_ELT(features, 2, Rf_ScalarLogical(value & GIT_FEATURE_SSH));
UNPROTECT(1);
return features;
}
/**
* Return the version of the libgit2 library being currently used.
*
* @return A VECSXP with major, minor and rev.
*/
SEXP git2r_libgit2_version(void)
{
const char *names[] = {"major", "minor", "rev", ""};
SEXP version;
int major, minor, rev;
git_libgit2_version(&major, &minor, &rev);
PROTECT(version = Rf_mkNamed(VECSXP, names));
SET_VECTOR_ELT(version, 0, Rf_ScalarInteger(major));
SET_VECTOR_ELT(version, 1, Rf_ScalarInteger(minor));
SET_VECTOR_ELT(version, 2, Rf_ScalarInteger(rev));
UNPROTECT(1);
return version;
}
SEXP dgeMatrix_Schur(SEXP x, SEXP vectors, SEXP isDGE)
{
// 'x' is either a traditional matrix or a dgeMatrix, as indicated by isDGE.
int *dims, n, vecs = asLogical(vectors), is_dge = asLogical(isDGE),
info, izero = 0, lwork = -1, nprot = 1;
if(is_dge) {
dims = INTEGER(GET_SLOT(x, Matrix_DimSym));
} else { // traditional matrix
dims = INTEGER(getAttrib(x, R_DimSymbol));
if(!isReal(x)) { // may not be "numeric" ..
x = PROTECT(coerceVector(x, REALSXP)); // -> maybe error
nprot++;
}
}
double *work, tmp;
const char *nms[] = {"WR", "WI", "T", "Z", ""};
SEXP val = PROTECT(Rf_mkNamed(VECSXP, nms));
n = dims[0];
if (n != dims[1] || n < 1)
error(_("dgeMatrix_Schur: argument x must be a non-null square matrix"));
SET_VECTOR_ELT(val, 0, allocVector(REALSXP, n));
SET_VECTOR_ELT(val, 1, allocVector(REALSXP, n));
SET_VECTOR_ELT(val, 2, allocMatrix(REALSXP, n, n));
Memcpy(REAL(VECTOR_ELT(val, 2)),
REAL(is_dge ? GET_SLOT(x, Matrix_xSym) : x),
n * n);
SET_VECTOR_ELT(val, 3, allocMatrix(REALSXP, vecs ? n : 0, vecs ? n : 0));
F77_CALL(dgees)(vecs ? "V" : "N", "N", NULL, dims, (double *) NULL, dims, &izero,
(double *) NULL, (double *) NULL, (double *) NULL, dims,
&tmp, &lwork, (int *) NULL, &info);
if (info) error(_("dgeMatrix_Schur: first call to dgees failed"));
lwork = (int) tmp;
C_or_Alloca_TO(work, lwork, double);
F77_CALL(dgees)(vecs ? "V" : "N", "N", NULL, dims, REAL(VECTOR_ELT(val, 2)), dims,
&izero, REAL(VECTOR_ELT(val, 0)), REAL(VECTOR_ELT(val, 1)),
REAL(VECTOR_ELT(val, 3)), dims, work, &lwork,
(int *) NULL, &info);
if(lwork >= SMALL_4_Alloca) Free(work);
if (info) error(_("dgeMatrix_Schur: dgees returned code %d"), info);
UNPROTECT(nprot);
return val;
} // dgeMatrix_Schur
// called from package MatrixModels's R code
SEXP dgCMatrix_qrsol(SEXP x, SEXP y, SEXP ord)
{
/* FIXME: extend this to work in multivariate case, i.e. y a matrix with > 1 column ! */
SEXP ycp = PROTECT((TYPEOF(y) == REALSXP) ?
duplicate(y) : coerceVector(y, REALSXP));
CSP xc = AS_CSP(x); /* <--> x may be dgC* or dtC* */
int order = asInteger(ord);
#ifdef _not_yet_do_FIXME__
const char *nms[] = {"L", "coef", "Xty", "resid", ""};
SEXP ans = PROTECT(Rf_mkNamed(VECSXP, nms));
#endif
R_CheckStack();
if (order < 0 || order > 3)
error(_("dgCMatrix_qrsol(., order) needs order in {0,..,3}"));
/* --> cs_amd() --- order 0: natural, 1: Chol, 2: LU, 3: QR */
if (LENGTH(ycp) != xc->m)
error(_("Dimensions of system to be solved are inconsistent"));
/* FIXME? Note that qr_sol() would allow *under-determined systems;
* In general, we'd need LENGTH(ycp) = max(n,m)
* FIXME also: multivariate y (see above)
*/
if (xc->m < xc->n || xc->n <= 0)
error(_("dgCMatrix_qrsol(<%d x %d>-matrix) requires a 'tall' rectangular matrix"),
xc->m, xc->n);
/* cs_qrsol(): Tim Davis (2006) .. "8.2 Using a QR factorization", p.136f , calling
* ------- cs_sqr(order, ..), see p.76 */
/* MM: FIXME: write our *OWN* version of - the first case (m >= n) - of cs_qrsol()
* --------- which will (1) work with a *multivariate* y
* (2) compute coefficients properly, not overwriting RHS
*/
if (!cs_qrsol(order, xc, REAL(ycp)))
/* return value really is 0 or 1 - no more info there */
error(_("cs_qrsol() failed inside dgCMatrix_qrsol()"));
/* Solution is only in the first part of ycp -- cut its length back to n : */
ycp = lengthgets(ycp, (R_len_t) xc->n);
UNPROTECT(1);
return ycp;
}
/**
* Stash
*
* @param repo The repository
* @param message Optional description
* @param index All changes already added to the index are left
* intact in the working directory. Default is FALSE
* @param untracked All untracked files are also stashed and then
* cleaned up from the working directory. Default is FALSE
* @param ignored All ignored files are also stashed and then cleaned
* up from the working directory. Default is FALSE
* @param stasher Signature with stasher and time of stash
* @return S3 class git_stash
*/
SEXP git2r_stash_save(
SEXP repo,
SEXP message,
SEXP index,
SEXP untracked,
SEXP ignored,
SEXP stasher)
{
int error, nprotect = 0;
SEXP result = R_NilValue, class;
git_oid oid;
git_stash_flags flags = GIT_STASH_DEFAULT;
git_commit *commit = NULL;
git_repository *repository = NULL;
git_signature *c_stasher = NULL;
if (git2r_arg_check_logical(index))
git2r_error(__func__, NULL, "'index'", git2r_err_logical_arg);
if (git2r_arg_check_logical(untracked))
git2r_error(__func__, NULL, "'untracked'", git2r_err_logical_arg);
if (git2r_arg_check_logical(ignored))
git2r_error(__func__, NULL, "'ignored'", git2r_err_logical_arg);
if (git2r_arg_check_signature(stasher))
git2r_error(__func__, NULL, "'stasher'", git2r_err_signature_arg);
repository = git2r_repository_open(repo);
if (!repository)
git2r_error(__func__, NULL, git2r_err_invalid_repository, NULL);
if (LOGICAL(index)[0])
flags |= GIT_STASH_KEEP_INDEX;
if (LOGICAL(untracked)[0])
flags |= GIT_STASH_INCLUDE_UNTRACKED;
if (LOGICAL(ignored)[0])
flags |= GIT_STASH_INCLUDE_IGNORED;
error = git2r_signature_from_arg(&c_stasher, stasher);
if (error)
goto cleanup;
error = git_stash_save(
&oid,
repository,
c_stasher,
CHAR(STRING_ELT(message, 0)),
flags);
if (error) {
if (GIT_ENOTFOUND == error)
error = GIT_OK;
goto cleanup;
}
PROTECT(result = Rf_mkNamed(VECSXP, git2r_S3_items__git_commit));
nprotect++;
Rf_setAttrib(result, R_ClassSymbol, class = Rf_allocVector(STRSXP, 2));
SET_STRING_ELT(class, 0, Rf_mkChar("git_stash"));
SET_STRING_ELT(class, 1, Rf_mkChar("git_commit"));
error = git2r_stash_init(&oid, repository, repo, result);
cleanup:
git_commit_free(commit);
git_signature_free(c_stasher);
git_repository_free(repository);
if (nprotect)
UNPROTECT(nprotect);
if (error)
git2r_error(__func__, GIT2R_ERROR_LAST(), NULL, NULL);
return result;
}
