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