/**
* Get head of repository
*
* @param repo S4 class git_repository
* @return R_NilValue if unborn branch or not found. S4 class
* git_branch if not a detached head. S4 class git_commit if detached
* head
*/
SEXP git2r_repository_head(SEXP repo)
{
int err;
SEXP result = R_NilValue;
git_commit *commit = NULL;
git_reference *reference = NULL;
git_repository *repository = NULL;
repository= git2r_repository_open(repo);
if (!repository)
git2r_error(git2r_err_invalid_repository, __func__, NULL);
err = git_repository_head(&reference, repository);
if (GIT_OK != err) {
if (GIT_EUNBORNBRANCH == err || GIT_ENOTFOUND == err)
err = GIT_OK;
goto cleanup;
}
if (git_reference_is_branch(reference)) {
git_branch_t type = GIT_BRANCH_LOCAL;
if (git_reference_is_remote(reference))
type = GIT_BRANCH_REMOTE;
PROTECT(result = NEW_OBJECT(MAKE_CLASS("git_branch")));
err = git2r_branch_init(reference, type, repo, result);
} else {
err = git_commit_lookup(
&commit,
repository,
git_reference_target(reference));
if (GIT_OK != err)
goto cleanup;
PROTECT(result = NEW_OBJECT(MAKE_CLASS("git_commit")));
git2r_commit_init(commit, repo, result);
}
cleanup:
if (commit)
git_commit_free(commit);
if (reference)
git_reference_free(reference);
if (repository)
git_repository_free(repository);
if (R_NilValue != result)
UNPROTECT(1);
if (GIT_OK != err)
git2r_error(git2r_err_from_libgit2, __func__, giterr_last()->message);
return result;
}
SEXP Parent_inverse(SEXP par, SEXP unitdiag)
{
SEXP ans = PROTECT(NEW_OBJECT(MAKE_CLASS("dtCMatrix")));
int *ap, *ai, *dims, *pr = INTEGER(par),
countDiag = 1 - asLogical(unitdiag),
j, n = length(par), nnz;
double *ax;
if (!isInteger(par)) error(_("par argument must be an integer vector"));
SET_SLOT(ans, Matrix_pSym, allocVector(INTSXP, n + 1));
ap = INTEGER(GET_SLOT(ans, Matrix_pSym));
nnz = parent_inv_ap(n, countDiag, pr, ap);
SET_SLOT(ans, Matrix_iSym, allocVector(INTSXP, nnz));
ai = INTEGER(GET_SLOT(ans, Matrix_iSym));
SET_SLOT(ans, Matrix_xSym, allocVector(REALSXP, nnz));
ax = REAL(GET_SLOT(ans, Matrix_xSym));
for (j = 0; j < nnz; j++) ax[j] = 1.;
SET_SLOT(ans, Matrix_DimSym, allocVector(INTSXP, 2));
dims = INTEGER(GET_SLOT(ans, Matrix_DimSym));
dims[0] = dims[1] = n;
SET_SLOT(ans, Matrix_uploSym, mkString("L"));
SET_SLOT(ans, Matrix_diagSym, (countDiag ? mkString("N") : mkString("U")));
parent_inv_ai(n, countDiag, pr, ai);
UNPROTECT(1);
return ans;
}
SEXP R_ExpectCovarInfluence(SEXP y, SEXP weights) {
SEXP ans;
int q, n;
if (!isReal(y) || !isReal(weights))
error("R_ExpectCovarInfluence: arguments are not of type REALSXP");
n = nrow(y);
q = ncol(y);
if (LENGTH(weights) != n)
error("R_ExpectCovarInfluence: vector of case weights does not have %d elements", n);
/* allocate storage for return values */
PROTECT(ans = NEW_OBJECT(MAKE_CLASS("ExpectCovarInfluence")));
SET_SLOT(ans, coin_expectationSym,
PROTECT(allocVector(REALSXP, q)));
SET_SLOT(ans, coin_covarianceSym,
PROTECT(allocMatrix(REALSXP, q, q)));
SET_SLOT(ans, coin_sumweightsSym,
PROTECT(allocVector(REALSXP, 1)));
C_ExpectCovarInfluence(REAL(y), q, REAL(weights), n, ans);
UNPROTECT(4);
return(ans);
}
SEXP dgeMatrix_LU_(SEXP x, Rboolean warn_sing)
{
SEXP val = get_factors(x, "LU");
int *dims, npiv, info;
if (val != R_NilValue) /* nothing to do if it's there in 'factors' slot */
return val;
dims = INTEGER(GET_SLOT(x, Matrix_DimSym));
if (dims[0] < 1 || dims[1] < 1)
error(_("Cannot factor a matrix with zero extents"));
npiv = (dims[0] <dims[1]) ? dims[0] : dims[1];
val = PROTECT(NEW_OBJECT(MAKE_CLASS("denseLU")));
slot_dup(val, x, Matrix_xSym);
slot_dup(val, x, Matrix_DimSym);
F77_CALL(dgetrf)(dims, dims + 1, REAL(GET_SLOT(val, Matrix_xSym)),
dims,
INTEGER(ALLOC_SLOT(val, Matrix_permSym, INTSXP, npiv)),
&info);
if (info < 0)
error(_("Lapack routine %s returned error code %d"), "dgetrf", info);
else if (info > 0 && warn_sing)
warning(_("Exact singularity detected during LU decomposition."));
UNPROTECT(1);
return set_factors(x, val, "LU");
}
SEXP dgeMatrix_dgeMatrix_crossprod(SEXP x, SEXP y, SEXP trans)
{
int tr = asLogical(trans);/* trans=TRUE: tcrossprod(x,y) */
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix")));
int *xDims = INTEGER(GET_SLOT(x, Matrix_DimSym)),
*yDims = INTEGER(GET_SLOT(y, Matrix_DimSym)),
*vDims;
int m = xDims[!tr], n = yDims[!tr];/* -> result dim */
int xd = xDims[ tr], yd = yDims[ tr];/* the conformable dims */
double one = 1.0, zero = 0.0;
SET_SLOT(val, Matrix_factorSym, allocVector(VECSXP, 0));
SET_SLOT(val, Matrix_DimSym, allocVector(INTSXP, 2));
vDims = INTEGER(GET_SLOT(val, Matrix_DimSym));
if (xd > 0 && yd > 0 && n > 0 && m > 0) {
if (xd != yd)
error(_("Dimensions of x and y are not compatible for %s"),
tr ? "tcrossprod" : "crossprod");
vDims[0] = m; vDims[1] = n;
SET_SLOT(val, Matrix_xSym, allocVector(REALSXP, m * n));
F77_CALL(dgemm)(tr ? "N" : "T", tr ? "T" : "N", &m, &n, &xd, &one,
REAL(GET_SLOT(x, Matrix_xSym)), xDims,
REAL(GET_SLOT(y, Matrix_xSym)), yDims,
&zero, REAL(GET_SLOT(val, Matrix_xSym)), &m);
}
UNPROTECT(1);
return val;
}
SEXP double_to_csc(double *a, int *dim_a)
{
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgCMatrix")));
int j, maxnz, nrow, ncol, nnz, *vp, *vi;
double *vx;
nrow = dim_a[0]; ncol = dim_a[1];
SET_SLOT(val, Matrix_factorSym, allocVector(VECSXP, 0));
SET_SLOT(val, Matrix_DimSym, allocVector(INTSXP, 2));
SET_SLOT(val, Matrix_pSym, allocVector(INTSXP, ncol + 1));
vp = INTEGER(GET_SLOT(val, Matrix_pSym));
maxnz = nrow * ncol;
vi = Calloc(maxnz, int); vx = Calloc(maxnz, double);
nnz = 0;
for (j = 0; j < ncol; j++) {
int i;
vp[j] = nnz;
for (i = 0; i < nrow; i++) {
double val = a[i + j * nrow];
if (val != 0.) {
vi[nnz] = i;
vx[nnz] = val;
nnz++;
}
}
}
vp[ncol] = nnz;
SET_SLOT(val, Matrix_iSym, allocVector(INTSXP, nnz));
Memcpy(INTEGER(GET_SLOT(val, Matrix_iSym)), vi, nnz);
SET_SLOT(val, Matrix_xSym, allocVector(REALSXP, nnz));
Memcpy(REAL(GET_SLOT(val, Matrix_xSym)), vx, nnz);
Free(vi); Free(vx);
UNPROTECT(1);
return dgCMatrix_set_Dim(val, nrow);
}
SEXP csc_matrix_crossprod(SEXP x, SEXP y, SEXP classed)
{
int cl = asLogical(classed);
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix")));
int *xdims = INTEGER(GET_SLOT(x, Matrix_DimSym)),
*ydims = INTEGER(cl ? GET_SLOT(y, Matrix_DimSym) :
getAttrib(y, R_DimSymbol)),
*vdims = INTEGER(ALLOC_SLOT(val, Matrix_DimSym, INTSXP, 2));
int *xi = INTEGER(GET_SLOT(x, Matrix_iSym)),
*xp = INTEGER(GET_SLOT(x, Matrix_pSym));
int j, k = xdims[0], m = xdims[1], n = ydims[1];
double *vx, *xx = REAL(GET_SLOT(x, Matrix_xSym)),
*yx = REAL(cl ? GET_SLOT(y, Matrix_xSym) : y);
if (!cl && !(isMatrix(y) && isReal(y)))
error(_("y must be a numeric matrix"));
if (ydims[0] != k)
error(_("x and y must have the same number of rows"));
if (m < 1 || n < 1 || k < 1)
error(_("Matrices with zero extents cannot be multiplied"));
vdims[0] = m; vdims[1] = n;
vx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n));
for (j = 0; j < n; j++) {
int i; double *ypt = yx + j * k;
for(i = 0; i < m; i++) {
int ii; double accum = 0.;
for (ii = xp[i]; ii < xp[i+1]; ii++) {
accum += xx[ii] * ypt[xi[ii]];
}
vx[i + j * m] = accum;
}
}
UNPROTECT(1);
return val;
}
SEXP R_copyStruct_unz_file_info ( unz_file_info *value)
{
SEXP r_ans = R_NilValue, klass;
klass = MAKE_CLASS("unz_file_info");
if(klass == R_NilValue) {
PROBLEM "Cannot find R class unz_file_info "
ERROR;
}
PROTECT(klass);
PROTECT(r_ans = NEW(klass));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("version"), ScalarReal ( value -> version ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("version_needed"), ScalarReal ( value -> version_needed ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("flag"), ScalarReal ( value -> flag ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("compression_method"), ScalarReal ( value -> compression_method ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("dosDate"), ScalarReal ( value -> dosDate ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("crc"), ScalarReal ( value -> crc ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("compressed_size"), ScalarReal ( value -> compressed_size ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("uncompressed_size"), ScalarReal ( value -> uncompressed_size ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("size_filename"), ScalarReal ( value -> size_filename ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("size_file_extra"), ScalarReal ( value -> size_file_extra ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("size_file_comment"), ScalarReal ( value -> size_file_comment ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("disk_num_start"), ScalarReal ( value -> disk_num_start ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("internal_fa"), ScalarReal ( value -> internal_fa ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("external_fa"), ScalarReal ( value -> external_fa ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("tmu_date"), R_copyStruct_tm_unz( &value -> tmu_date ) ));
UNPROTECT( 17 );
return(r_ans);
}
/**
* Callback when iterating over notes
*
* @param blob_id Oid of the blob containing the message
* @param annotated_object_id Oid of the git object being annotated
* @param payload Payload data passed to `git_note_foreach`
* @return int 0 or error code
*/
static int git2r_note_foreach_cb(
const git_oid *blob_id,
const git_oid *annotated_object_id,
void *payload)
{
git2r_note_foreach_cb_data *cb_data = (git2r_note_foreach_cb_data*)payload;
/* Check if we have a list to populate */
if (R_NilValue != cb_data->list) {
int err;
SEXP note;
SET_VECTOR_ELT(
cb_data->list,
cb_data->n,
note = NEW_OBJECT(MAKE_CLASS("git_note")));
err = git2r_note_init(
blob_id,
annotated_object_id,
cb_data->repository,
cb_data->notes_ref,
cb_data->repo,
note);
if (GIT_OK != err)
return err;
}
cb_data->n += 1;
return 0;
}
SEXP rgeos_geospoint2SpatialPoints(SEXP env, GEOSGeom geom, SEXP p4s, SEXP id, int n) {
GEOSContextHandle_t GEOShandle = getContextHandle(env);
int type = GEOSGeomTypeId_r(GEOShandle, geom);
if ( type != GEOS_POINT && type != GEOS_MULTIPOINT && type != GEOS_GEOMETRYCOLLECTION )
error("rgeos_geospoint2SpatialPoints: invalid geometry type");
int pc=0;
SEXP bbox, crdmat;
if (GEOSisEmpty_r(GEOShandle, geom))
error("rgeos_geospoint2SpatialPoints: empty point found");
//if (GEOSisEmpty_r(GEOShandle, geom)==0) {
PROTECT(bbox = rgeos_geom2bbox(env, geom)); pc++;
PROTECT(crdmat = rgeos_geospoint2crdMat(env, geom, id, n, type)); pc++;
//} else {
// bbox = R_NilValue;
// crdmat = R_NilValue;
//}
SEXP ans;
PROTECT(ans = NEW_OBJECT(MAKE_CLASS("SpatialPoints"))); pc++;
SET_SLOT(ans, install("coords"), crdmat);
SET_SLOT(ans, install("bbox"), bbox);
SET_SLOT(ans, install("proj4string"), p4s);
UNPROTECT(pc);
return(ans);
}
/**
* Copy the contents of a to an appropriate CsparseMatrix object and,
* optionally, free a or free both a and the pointers to its contents.
*
* @param a matrix to be converted
* @param cl the name of the S4 class of the object to be generated
* @param dofree 0 - don't free a; > 0 cs_free a; < 0 Free a
*
* @return SEXP containing a copy of a
*/
SEXP Matrix_cs_to_SEXP(cs *a, char *cl, int dofree)
{
SEXP ans;
char *valid[] = {"dgCMatrix", "dsCMatrix", "dtCMatrix", ""};
int *dims, ctype = Matrix_check_class(cl, valid), nz;
if (ctype < 0)
error("invalid class of object to Matrix_cs_to_SEXP");
ans = PROTECT(NEW_OBJECT(MAKE_CLASS(cl)));
/* allocate and copy common slots */
dims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2));
dims[0] = a->m; dims[1] = a->n;
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_pSym, INTSXP, a->n + 1)),
a->p, a->n + 1);
nz = a->p[a->n];
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_iSym, INTSXP, nz)), a->i, nz);
Memcpy(REAL(ALLOC_SLOT(ans, Matrix_xSym, REALSXP, nz)), a->x, nz);
if (ctype > 0) {
int uplo = is_sym(a);
if (!uplo) error("cs matrix not compatible with class");
SET_SLOT(ans, Matrix_diagSym, mkString("N"));
SET_SLOT(ans, Matrix_uploSym, mkString(uplo < 0 ? "L" : "U"));
}
if (dofree > 0) cs_spfree(a);
if (dofree < 0) Free(a);
UNPROTECT(1);
return ans;
}
/**
* Copy the contents of N to a csn_LU or csn_QR object and,
* optionally, free N or free both N and the pointers to its contents.
*
* @param a csn object to be converted
* @param cl the name of the S4 class of the object to be generated
* @param dofree 0 - don't free a; > 0 cs_free a; < 0 Free a
*
* @return SEXP containing a copy of S
*/
SEXP Matrix_csn_to_SEXP(csn *N, char *cl, int dofree)
{
SEXP ans;
char *valid[] = {"csn_LU", "csn_QR", ""};
int ctype = Matrix_check_class(cl, valid), n = (N->U)->n;
if (ctype < 0)
error("Inappropriate class '%s' for Matrix_csn_to_SEXP", cl);
ans = PROTECT(NEW_OBJECT(MAKE_CLASS(cl)));
/* allocate and copy common slots */
/* FIXME: Use the triangular matrix classes for csn_LU */
SET_SLOT(ans, install("L"), /* these are free'd later if requested */
Matrix_cs_to_SEXP(N->L, "dgCMatrix", 0));
SET_SLOT(ans, install("U"),
Matrix_cs_to_SEXP(N->U, "dgCMatrix", 0));
switch(ctype) {
case 0:
Memcpy(INTEGER(ALLOC_SLOT(ans, install("Pinv"), INTSXP, n)),
N->pinv, n);
break;
case 1:
Memcpy(REAL(ALLOC_SLOT(ans, install("beta"), REALSXP, n)),
N->B, n);
break;
default:
error("Inappropriate class '%s' for Matrix_csn_to_SEXP", cl);
}
if (dofree > 0) cs_nfree(N);
if (dofree < 0) {
Free(N->L); Free(N->U); Free(N);
}
UNPROTECT(1);
return ans;
}
/**
* Copy the contents of S to a css_LU or css_QR object and,
* optionally, free S or free both S and the pointers to its contents.
*
* @param a css object to be converted
* @param cl the name of the S4 class of the object to be generated
* @param dofree 0 - don't free a; > 0 cs_free a; < 0 Free a
* @param m number of rows in original matrix
* @param n number of columns in original matrix
*
* @return SEXP containing a copy of S
*/
SEXP Matrix_css_to_SEXP(css *S, char *cl, int dofree, int m, int n)
{
SEXP ans;
char *valid[] = {"css_LU", "css_QR", ""};
int *nz, ctype = Matrix_check_class(cl, valid);
if (ctype < 0)
error("Inappropriate class '%s' for Matrix_css_to_SEXP", cl);
ans = PROTECT(NEW_OBJECT(MAKE_CLASS(cl)));
/* allocate and copy common slots */
Memcpy(INTEGER(ALLOC_SLOT(ans, install("Q"), INTSXP, n)), S->q, n);
nz = INTEGER(ALLOC_SLOT(ans, install("nz"), INTSXP, 3));
nz[0] = S->m2; nz[1] = S->lnz; nz[2] = S->unz;
switch(ctype) {
case 0:
break;
case 1:
Memcpy(INTEGER(ALLOC_SLOT(ans, install("Pinv"), INTSXP, m)),
S->pinv, m);
Memcpy(INTEGER(ALLOC_SLOT(ans, install("parent"), INTSXP, n)),
S->parent, n);
Memcpy(INTEGER(ALLOC_SLOT(ans, install("cp"), INTSXP, n)),
S->cp, n);
break;
default:
error("Inappropriate class '%s' for Matrix_css_to_SEXP", cl);
}
if (dofree > 0) cs_sfree(S);
if (dofree < 0) Free(S);
UNPROTECT(1);
return ans;
}
/**
* Fetch new data and update tips
*
* @param repo S4 class git_repository
* @param name The name of the remote to fetch from
* @param credentials The credentials for remote repository access.
* @param msg The one line long message to be appended to the reflog
* @return R_NilValue
*/
SEXP git2r_remote_fetch(
SEXP repo,
SEXP name,
SEXP credentials,
SEXP msg)
{
int err;
SEXP result = R_NilValue;
const git_transfer_progress *stats;
git_remote *remote = NULL;
git_repository *repository = NULL;
git_remote_callbacks callbacks = GIT_REMOTE_CALLBACKS_INIT;
if (git2r_arg_check_string(name))
git2r_error(git2r_err_string_arg, __func__, "name");
if (git2r_arg_check_credentials(credentials))
git2r_error(git2r_err_credentials_arg, __func__, "credentials");
if (git2r_arg_check_string(msg))
git2r_error(git2r_err_string_arg, __func__, "msg");
repository = git2r_repository_open(repo);
if (!repository)
git2r_error(git2r_err_invalid_repository, __func__, NULL);
err = git_remote_lookup(&remote, repository, CHAR(STRING_ELT(name, 0)));
if (GIT_OK != err)
goto cleanup;
callbacks.credentials = &git2r_cred_acquire_cb;
callbacks.payload = credentials;
err = git_remote_set_callbacks(remote, &callbacks);
if (GIT_OK != err)
goto cleanup;
err = git_remote_fetch(remote, NULL, CHAR(STRING_ELT(msg, 0)));
if (GIT_OK != err)
goto cleanup;
stats = git_remote_stats(remote);
PROTECT(result = NEW_OBJECT(MAKE_CLASS("git_transfer_progress")));
git2r_transfer_progress_init(stats, result);
cleanup:
if (remote) {
if (git_remote_connected(remote))
git_remote_disconnect(remote);
git_remote_free(remote);
}
if (repository)
git_repository_free(repository);
if (R_NilValue != result)
UNPROTECT(1);
if (GIT_OK != err)
git2r_error(git2r_err_from_libgit2, __func__, giterr_last()->message);
return result;
}
SEXP tsc_to_dgTMatrix(SEXP x)
{
SEXP ans;
if (*diag_P(x) != 'U')
ans = compressed_to_dgTMatrix(x, ScalarLogical(1));
else { /* unit triangular matrix */
SEXP islot = GET_SLOT(x, Matrix_iSym),
pslot = GET_SLOT(x, Matrix_pSym);
int *ai, *aj, j,
n = length(pslot) - 1,
nod = length(islot),
nout = n + nod,
*p = INTEGER(pslot);
double *ax;
ans = PROTECT(NEW_OBJECT(MAKE_CLASS("dgTMatrix")));
SET_SLOT(ans, Matrix_DimSym, duplicate(GET_SLOT(x, Matrix_DimSym)));
SET_SLOT(ans, Matrix_iSym, allocVector(INTSXP, nout));
ai = INTEGER(GET_SLOT(ans, Matrix_iSym));
Memcpy(ai, INTEGER(islot), nod);
SET_SLOT(ans, Matrix_jSym, allocVector(INTSXP, nout));
aj = INTEGER(GET_SLOT(ans, Matrix_jSym));
SET_SLOT(ans, Matrix_xSym, allocVector(REALSXP, nout));
ax = REAL(GET_SLOT(ans, Matrix_xSym));
Memcpy(ax, REAL(GET_SLOT(x, Matrix_xSym)), nod);
for (j = 0; j < n; j++) {
int jj, npj = nod + j, p2 = p[j+1];
aj[npj] = ai[npj] = j;
ax[npj] = 1.;
for (jj = p[j]; jj < p2; jj++) aj[jj] = j;
}
UNPROTECT(1);
}
return ans;
}
SEXP new_LinStatExpectCovarMPinv(int p, int q) {
SEXP ans, expect, covar, linearstatistic, MPinv;
PROTECT(ans = NEW_OBJECT(MAKE_CLASS("LinStatExpectCovarMPinv")));
SET_SLOT(ans, PL2_expectationSym, expect = PROTECT(allocVector(REALSXP, p * q)));
for (int i = 0; i < p * q; i++)
REAL(expect)[i] = 0.0;
SET_SLOT(ans, PL2_covarianceSym, covar = PROTECT(allocMatrix(REALSXP, p * q, p * q)));
for (int i = 0; i < p * q * p * q; i++)
REAL(covar)[i] = 0.0;
SET_SLOT(ans, PL2_dimensionSym, PROTECT(ScalarInteger(p * q)));
SET_SLOT(ans, PL2_linearstatisticSym, linearstatistic = PROTECT(allocVector(REALSXP, p * q)));
for (int i = 0; i < p * q; i++)
REAL(linearstatistic)[i] = 0.0;
SET_SLOT(ans, PL2_MPinvSym, MPinv = PROTECT(allocMatrix(REALSXP, p * q, p * q)));
for (int i = 0; i < p * q * p * q; i++)
REAL(MPinv)[i] = 0.0;
SET_SLOT(ans, PL2_rankSym, PROTECT(ScalarReal(0.0)));
SET_SLOT(ans, PL2_svdmemSym, PROTECT(new_svd_mem(p * q)));
SET_SLOT(ans, PL2_expcovinfSym, PROTECT(new_ExpectCovarInfluence(q)));
UNPROTECT(9);
return(ans);
}
SEXP dsyMatrix_trf(SEXP x)
{
SEXP val = get_factors(x, "BunchKaufman"),
dimP = GET_SLOT(x, Matrix_DimSym),
uploP = GET_SLOT(x, Matrix_uploSym);
int *dims = INTEGER(dimP), *perm, info;
int lwork = -1, n = dims[0];
const char *uplo = CHAR(STRING_ELT(uploP, 0));
double tmp, *vx, *work;
if (val != R_NilValue) return val;
dims = INTEGER(dimP);
val = PROTECT(NEW_OBJECT(MAKE_CLASS("BunchKaufman")));
SET_SLOT(val, Matrix_uploSym, duplicate(uploP));
SET_SLOT(val, Matrix_diagSym, mkString("N"));
SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
vx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, n * n));
AZERO(vx, n * n);
F77_CALL(dlacpy)(uplo, &n, &n, REAL(GET_SLOT(x, Matrix_xSym)), &n, vx, &n);
perm = INTEGER(ALLOC_SLOT(val, Matrix_permSym, INTSXP, n));
F77_CALL(dsytrf)(uplo, &n, vx, &n, perm, &tmp, &lwork, &info);
lwork = (int) tmp;
work = Alloca(lwork, double);
R_CheckStack();
F77_CALL(dsytrf)(uplo, &n, vx, &n, perm, work, &lwork, &info);
if (info) error(_("Lapack routine dsytrf returned error code %d"), info);
UNPROTECT(1);
return set_factors(x, val, "BunchKaufman");
}
SEXP dppMatrix_chol(SEXP x)
{
SEXP val = get_factors(x, "pCholesky"),
dimP = GET_SLOT(x, Matrix_DimSym),
uploP = GET_SLOT(x, Matrix_uploSym);
const char *uplo = CHAR(STRING_ELT(uploP, 0));
int *dims = INTEGER(dimP), info;
if (val != R_NilValue) return val;
dims = INTEGER(dimP);
val = PROTECT(NEW_OBJECT(MAKE_CLASS("pCholesky")));
SET_SLOT(val, Matrix_uploSym, duplicate(uploP));
SET_SLOT(val, Matrix_diagSym, mkString("N"));
SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
slot_dup(val, x, Matrix_xSym);
F77_CALL(dpptrf)(uplo, dims, REAL(GET_SLOT(val, Matrix_xSym)), &info);
if (info) {
if(info > 0) /* e.g. x singular */
error(_("the leading minor of order %d is not positive definite"),
info);
else /* should never happen! */
error(_("Lapack routine %s returned error code %d"), "dpptrf", info);
}
UNPROTECT(1);
return set_factors(x, val, "pCholesky");
}
/**
Turn a variant into an S object with a special class
such as COMDate or COMCurrency which is simply an extension
of numeric.
*/
SEXP
numberFromVariant(VARIANT *var, VARTYPE type)
{
SEXP ans;
SEXP klass;
const char *tmpName = NULL;
switch(type) {
case VT_CY:
tmpName = "COMCurrency";
break;
case VT_DATE:
tmpName = (char *) "COMDate";
break;
case VT_HRESULT:
tmpName = (char *) "HResult";
break;
case VT_DECIMAL:
tmpName = (char *) "COMDecimal";
break;
default:
PROBLEM "numberFromVariant called with unsupported variant type."
ERROR;
}
PROTECT(klass = MAKE_CLASS(tmpName));
PROTECT(ans = NEW(klass));
ans = R_do_slot_assign(ans, mkString(".Data"), R_scalarReal(V_R8(var)));
// SET_SLOT(ans, Rf_install(".Data"), R_scalarReal(V_R8(var)));
UNPROTECT(2);
return(ans);
}
SEXP ddense_band(SEXP x, SEXP k1P, SEXP k2P)
/* Always returns a full matrix with entries outside the band zeroed
* Class of the value can be dtrMatrix or dgeMatrix
*/
{
SEXP aa, ans = PROTECT(dup_mMatrix_as_dgeMatrix(x));
int *adims = INTEGER(GET_SLOT(ans, Matrix_DimSym)),
i, j, k1 = asInteger(k1P), k2 = asInteger(k2P);
int m = adims[0], n = adims[1], sqr = (adims[0] == adims[1]),
tru = (k1 >= 0), trl = (k2 <= 0);
double *ax = REAL(GET_SLOT(ans, Matrix_xSym));
if (k1 > k2)
error(_("Lower band %d > upper band %d"), k1, k2);
for (j = 0; j < n; j++) {
int i1 = j - k2, i2 = j + 1 - k1;
for (i = 0; i < i1; i++) ax[i + j * m] = 0.;
for (i = i2; i < m; i++) ax[i + j * m] = 0.;
}
if (!sqr || (!tru && !trl)) { /* return the dgeMatrix */
UNPROTECT(1);
return ans;
}
/* Copy ans to a dtrMatrix object (must be square) */
/* Because slots of ans are freshly allocated and ans will not be
* used, we use the slots themselves and don't duplicate */
aa = PROTECT(NEW_OBJECT(MAKE_CLASS("dtrMatrix")));
SET_SLOT(aa, Matrix_xSym, GET_SLOT(ans, Matrix_xSym));
SET_SLOT(aa, Matrix_DimSym, GET_SLOT(ans, Matrix_DimSym));
SET_SLOT(aa, Matrix_DimNamesSym, GET_SLOT(ans, Matrix_DimNamesSym));
SET_SLOT(aa, Matrix_diagSym, mkString("N"));
SET_SLOT(aa, Matrix_uploSym, mkString(tru ? "U" : "L"));
UNPROTECT(2);
return aa;
}
SEXP csc_to_dgeMatrix(SEXP x)
{
SEXP ans = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix"))),
Dimslot = GET_SLOT(x, Matrix_DimSym);
int *dims = INTEGER(Dimslot),
*xp = INTEGER(GET_SLOT(x, Matrix_pSym)),
*xi = INTEGER(GET_SLOT(x, Matrix_iSym));
double *xx = REAL(GET_SLOT(x, Matrix_xSym)), *ax;
int j, nrow = dims[0], ncol = dims[1];
SET_SLOT(ans, Matrix_DimSym, duplicate(Dimslot));
SET_SLOT(ans, Matrix_xSym, allocVector(REALSXP, nrow*ncol));
SET_SLOT(ans, Matrix_rcondSym, allocVector(REALSXP, 0));
SET_SLOT(ans, Matrix_factorSym, allocVector(VECSXP, 0));
ax = REAL(GET_SLOT(ans, Matrix_xSym));
for (j = 0; j < (nrow * ncol); j++) ax[j] = 0.;
for (j = 0; j < ncol; j++) {
int ind;
for (ind = xp[j]; ind < xp[j+1]; ind++) {
ax[j * nrow + xi[ind]] = xx[ind];
}
}
UNPROTECT(1);
return ans;
}
/**
* Invoked 'callback' for each entry in the given FETCH_HEAD file.
*
* @param ref_name The name of the ref.
* @param remote_url The url of the remote.
* @param oid The id of the remote head that were updated during the
* last fetch.
* @param is_merge Is head for merge.
* @return 0
*/
static int git2r_repository_fetchhead_foreach_cb(
const char *ref_name,
const char *remote_url,
const git_oid *oid,
unsigned int is_merge,
void *payload)
{
git2r_fetch_head_cb_data *cb_data = (git2r_fetch_head_cb_data*)payload;
/* Check if we have a list to populate */
if (R_NilValue != cb_data->list) {
char sha[GIT_OID_HEXSZ + 1];
SEXP fetch_head;
SET_VECTOR_ELT(
cb_data->list,
cb_data->n,
fetch_head = NEW_OBJECT(MAKE_CLASS("git_fetch_head")));
SET_SLOT(fetch_head, Rf_install("ref_name"), mkString(ref_name));
SET_SLOT(fetch_head, Rf_install("remote_url"), mkString(remote_url));
git_oid_tostr(sha, sizeof(sha), oid);
SET_SLOT(fetch_head, Rf_install("sha"), mkString(sha));
SET_SLOT(fetch_head, Rf_install("is_merge"), ScalarLogical(is_merge));
SET_SLOT(fetch_head, Rf_install("repo"), cb_data->repo);
}
cb_data->n += 1;
return 0;
}
SEXP dpoMatrix_chol(SEXP x)
{
SEXP val = get_factors(x, "Cholesky"),
dimP = GET_SLOT(x, Matrix_DimSym),
uploP = GET_SLOT(x, Matrix_uploSym);
char *uplo = CHAR(STRING_ELT(uploP, 0));
int *dims = INTEGER(dimP), info;
int n = dims[0];
double *vx;
if (val != R_NilValue) return val;
dims = INTEGER(dimP);
val = PROTECT(NEW_OBJECT(MAKE_CLASS("Cholesky")));
SET_SLOT(val, Matrix_uploSym, duplicate(uploP));
SET_SLOT(val, Matrix_diagSym, mkString("N"));
SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
vx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, n * n));
AZERO(vx, n * n);
F77_CALL(dlacpy)(uplo, &n, &n, REAL(GET_SLOT(x, Matrix_xSym)), &n, vx, &n);
if (n > 0) {
F77_CALL(dpotrf)(uplo, &n, vx, &n, &info);
if (info) {
if(info > 0)
error(_("the leading minor of order %d is not positive definite"),
info);
else /* should never happen! */
error(_("Lapack routine %s returned error code %d"), "dpotrf", info);
}
}
UNPROTECT(1);
return set_factors(x, val, "Cholesky");
}
SEXP dsyMatrix_dgeMatrix_mm_R(SEXP a, SEXP b)
{
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(GET_SLOT(b, Matrix_DimSym)),
*cdims,
m = adims[0], n = bdims[1], k = adims[1];
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix")));
double one = 1., zero = 0.;
if (bdims[0] != k)
error(_("Matrices are not conformable for multiplication"));
if (m < 1 || n < 1 || k < 1)
error(_("Matrices with zero extents cannot be multiplied"));
SET_SLOT(val, Matrix_rcondSym, allocVector(REALSXP, 0));
SET_SLOT(val, Matrix_factorSym, allocVector(VECSXP, 0));
SET_SLOT(val, Matrix_xSym, allocVector(REALSXP, m * n));
SET_SLOT(val, Matrix_DimSym, allocVector(INTSXP, 2));
cdims = INTEGER(GET_SLOT(val, Matrix_DimSym));
cdims[0] = m; cdims[1] = n;
F77_CALL(dsymm)("R", uplo_P(a), adims, bdims+1, &one,
REAL(GET_SLOT(a, Matrix_xSym)), adims,
REAL(GET_SLOT(b, Matrix_xSym)), bdims,
&zero, REAL(GET_SLOT(val, Matrix_xSym)), adims);
UNPROTECT(1);
return val;
}
SEXP dgeMatrix_matrix_crossprod(SEXP x, SEXP y, SEXP trans)
{
int tr = asLogical(trans);/* trans=TRUE: tcrossprod(x,y) */
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix")));
int *xDims = INTEGER(GET_SLOT(x, Matrix_DimSym)),
*yDims = INTEGER(getAttrib(y, R_DimSymbol)),
*vDims, nprot = 1;
int m = xDims[!tr], n = yDims[!tr];/* -> result dim */
int xd = xDims[ tr], yd = yDims[ tr];/* the conformable dims */
double one = 1.0, zero = 0.0;
if (isInteger(y)) {
y = PROTECT(coerceVector(y, REALSXP));
nprot++;
}
if (!(isMatrix(y) && isReal(y)))
error(_("Argument y must be a numeric matrix"));
SET_SLOT(val, Matrix_factorSym, allocVector(VECSXP, 0));
SET_SLOT(val, Matrix_DimSym, allocVector(INTSXP, 2));
vDims = INTEGER(GET_SLOT(val, Matrix_DimSym));
if (xd > 0 && yd > 0 && n > 0 && m > 0) {
if (xd != yd)
error(_("Dimensions of x and y are not compatible for %s"),
tr ? "tcrossprod" : "crossprod");
vDims[0] = m; vDims[1] = n;
SET_SLOT(val, Matrix_xSym, allocVector(REALSXP, m * n));
F77_CALL(dgemm)(tr ? "N" : "T", tr ? "T" : "N", &m, &n, &xd, &one,
REAL(GET_SLOT(x, Matrix_xSym)), xDims,
REAL(y), yDims,
&zero, REAL(GET_SLOT(val, Matrix_xSym)), &m);
}
UNPROTECT(nprot);
return val;
}
SEXP
createRRoutineReference(void *fun, const char * const routineName, const char * const returnTypeName, unsigned int numParams, ...)
{
SEXP ans, klass, tmp;
va_list args;
PROTECT(klass = MAKE_CLASS("CRoutineRef"));
PROTECT(ans = NEW(klass));
SET_SLOT(ans, Rf_install("ref"), R_MakeExternalPtr(fun, Rf_install("CRoutine"), R_NilValue));
if(routineName)
SET_SLOT(ans, Rf_install("name"), ScalarString(mkChar(routineName)));
SET_SLOT(ans, Rf_install("returnType"), ScalarString(mkChar(returnTypeName)));
SET_SLOT(ans, Rf_install("numParameters"), ScalarInteger(numParams));
if(numParams > 0) {
PROTECT( tmp = NEW_CHARACTER(numParams));
va_start(args, numParams);
for(int i = 0; i < numParams; i++)
SET_STRING_ELT(tmp, i, mkChar(va_arg(args, const char * const)));
SET_SLOT(ans, Rf_install("parameterTypes"), tmp);
va_end(args);
UNPROTECT(1);
}
UNPROTECT(2);
return(ans);
}
SEXP dgeMatrix_crossprod(SEXP x, SEXP trans)
{
int tr = asLogical(trans);/* trans=TRUE: tcrossprod(x) */
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dpoMatrix"))),
nms = VECTOR_ELT(GET_SLOT(x, Matrix_DimNamesSym), tr ? 0 : 1),
vDnms = ALLOC_SLOT(val, Matrix_DimNamesSym, VECSXP, 2);
int *Dims = INTEGER(GET_SLOT(x, Matrix_DimSym)),
*vDims = INTEGER(ALLOC_SLOT(val, Matrix_DimSym, INTSXP, 2));
int k = tr ? Dims[1] : Dims[0], n = tr ? Dims[0] : Dims[1];
double *vx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, n * n)),
one = 1.0, zero = 0.0;
AZERO(vx, n * n);
SET_SLOT(val, Matrix_uploSym, mkString("U"));
ALLOC_SLOT(val, Matrix_factorSym, VECSXP, 0);
vDims[0] = vDims[1] = n;
SET_VECTOR_ELT(vDnms, 0, duplicate(nms));
SET_VECTOR_ELT(vDnms, 1, duplicate(nms));
F77_CALL(dsyrk)("U", tr ? "N" : "T", &n, &k,
&one, REAL(GET_SLOT(x, Matrix_xSym)), Dims,
&zero, vx, &n);
SET_SLOT(val, Matrix_factorSym, allocVector(VECSXP, 0));
UNPROTECT(1);
return val;
}
SEXP
R_makeEnumValue(int val, const char *elName, const char *className)
{
SEXP ans, klass;
#if defined(USE_S4_ENUMS)
SEXP tmp;
PROTECT(klass = MAKE_CLASS(className));
PROTECT(ans = NEW(klass));
PROTECT(tmp = ScalarInteger(val));
SET_NAMES(tmp, mkString(elName));
ans = SET_SLOT(ans, Rf_install(".Data"), tmp);
UNPROTECT(3);
#else
PROTECT(ans = ScalarInteger(val));
SET_NAMES(ans, mkString(elName));
PROTECT(klass = NEW_CHARACTER(2));
SET_STRING_ELT(klass, 0, mkChar(className));
SET_STRING_ELT(klass, 1, mkChar("EnumValue"));
SET_CLASS(ans, klass);
UNPROTECT(2);
#endif
return(ans);
}
SEXP R_ExpectCovarLinearStatistic(SEXP x, SEXP y, SEXP weights,
SEXP expcovinf) {
SEXP ans;
int n, p, q, pq;
/* determine the dimensions and some checks */
n = nrow(x);
p = ncol(x);
q = ncol(y);
pq = p * q;
if (nrow(y) != n)
error("y does not have %d rows", n);
if (LENGTH(weights) != n)
error("vector of case weights does not have %d elements", n);
PROTECT(ans = NEW_OBJECT(MAKE_CLASS("ExpectCovar")));
SET_SLOT(ans, coin_expectationSym,
PROTECT(allocVector(REALSXP, pq)));
SET_SLOT(ans, coin_covarianceSym,
PROTECT(allocMatrix(REALSXP, pq, pq)));
C_ExpectCovarLinearStatistic(REAL(x), p, q,
REAL(weights), n, expcovinf, ans);
UNPROTECT(3);
return(ans);
}
SEXP dtTMatrix_as_dtCMatrix(SEXP x)
{
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dtCMatrix"))),
dimP = GET_SLOT(x, Matrix_DimSym),
xiP = GET_SLOT(x, Matrix_iSym);
int n = INTEGER(dimP)[0],
nnz = length(xiP);
int *ti = Calloc(nnz, int),
*vp = INTEGER(ALLOC_SLOT(val, Matrix_pSym, INTSXP, n + 1));
double *tx = Calloc(nnz, double);
SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
SET_SLOT(val, Matrix_uploSym, duplicate(GET_SLOT(x, Matrix_uploSym)));
SET_SLOT(val, Matrix_diagSym, duplicate(GET_SLOT(x, Matrix_diagSym)));
triplet_to_col(n, n, nnz, INTEGER(xiP),
INTEGER(GET_SLOT(x, Matrix_jSym)),
REAL(GET_SLOT(x, Matrix_xSym)),
vp, ti, tx);
nnz = vp[n];
Memcpy(INTEGER(ALLOC_SLOT(val, Matrix_iSym, INTSXP, nnz)), ti, nnz);
Memcpy( REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, nnz)), tx, nnz);
Free(ti); Free(tx);
UNPROTECT(1);
return val;
}
