void tr_d_packed_getDiag(double *dest, SEXP x)
{
int n = INTEGER(GET_SLOT(x, Matrix_DimSym))[0];
SEXP val = PROTECT(allocVector(REALSXP, n));
double *v = REAL(val);
if (*diag_P(x) == 'U') {
int j;
for (j = 0; j < n; j++) v[j] = 1.;
} else {
d_packed_getDiag(v, x, n);
}
UNPROTECT(1);
return;
}
SEXP get_factors(SEXP obj, char *nm)
{
SEXP fac = GET_SLOT(obj, Matrix_factorSym),
nms = getAttrib(fac, R_NamesSymbol);
int i, len = length(fac);
if ((!isNewList(fac)) || (length(fac) > 0 && nms == R_NilValue))
error("factors slot must be a named list");
for (i = 0; i < len; i++) {
if (!strcmp(nm, CHAR(STRING_ELT(nms, i)))) {
return VECTOR_ELT(fac, i);
}
}
return R_NilValue;
}
SEXP Csparse_Csparse_crossprod(SEXP a, SEXP b, SEXP trans)
{
int tr = asLogical(trans);
CHM_SP
cha = AS_CHM_SP(a),
chb = AS_CHM_SP(b),
chTr, chc;
const char *cl_a = class_P(a), *cl_b = class_P(b);
char diag[] = {'\0', '\0'};
int uploT = 0;
SEXP dn = PROTECT(allocVector(VECSXP, 2));
R_CheckStack();
chTr = cholmod_transpose((tr) ? chb : cha, chb->xtype, &c);
chc = cholmod_ssmult((tr) ? cha : chTr, (tr) ? chTr : chb,
/*out_stype:*/ 0, cha->xtype, /*out sorted:*/ 1, &c);
cholmod_free_sparse(&chTr, &c);
/* Preserve triangularity and unit-triangularity if appropriate;
* see Csparse_Csparse_prod() for comments */
if (cl_a[1] == 't' && cl_b[1] == 't')
if(*uplo_P(a) != *uplo_P(b)) { /* one 'U', the other 'L' */
uploT = (*uplo_P(b) == 'U') ? 1 : -1;
if(*diag_P(a) == 'U' && *diag_P(b) == 'U') { /* return UNIT-triag. */
chm_diagN2U(chc, uploT, /* do_realloc */ FALSE);
diag[0]= 'U';
}
else diag[0]= 'N';
}
SET_VECTOR_ELT(dn, 0, /* establish dimnames */
duplicate(VECTOR_ELT(GET_SLOT(a, Matrix_DimNamesSym), (tr) ? 0 : 1)));
SET_VECTOR_ELT(dn, 1,
duplicate(VECTOR_ELT(GET_SLOT(b, Matrix_DimNamesSym), (tr) ? 0 : 1)));
UNPROTECT(1);
return chm_sparse_to_SEXP(chc, 1, uploT, /*Rkind*/0, diag, dn);
}
/**
* Create credential object from S4 class 'cred_user_pass'.
*
* @param cred The newly created credential object.
* @param allowed_types A bitmask stating which cred types are OK to return.
* @param credentials The S4 class object with credentials.
* @return 0 on success, else -1.
*/
static int git2r_cred_user_pass(
git_cred **cred,
unsigned int allowed_types,
SEXP credentials)
{
if (GIT_CREDTYPE_USERPASS_PLAINTEXT & allowed_types) {
const char *username;
const char *password;
username = CHAR(STRING_ELT(
GET_SLOT(credentials,
Rf_install("username")), 0));
password = CHAR(STRING_ELT(
GET_SLOT(credentials,
Rf_install("password")), 0));
if (git_cred_userpass_plaintext_new(cred, username, password))
return -1;
return 0;
}
return -1;
}
SEXP tsc_transpose(SEXP x)
{
SEXP ans = PROTECT(NEW_OBJECT(MAKE_CLASS("dtCMatrix"))),
islot = GET_SLOT(x, Matrix_iSym);
int nnz = length(islot),
*adims, *xdims = INTEGER(GET_SLOT(x, Matrix_DimSym));
int up = uplo_P(x)[0] == 'U';
adims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2));
adims[0] = xdims[1]; adims[1] = xdims[0];
if(*diag_P(x) == 'U')
SET_SLOT(ans, Matrix_diagSym, duplicate(GET_SLOT(x, Matrix_diagSym)));
SET_SLOT(ans, Matrix_uploSym, mkString(up ? "L" : "U"));
csc_compTr(xdims[0], xdims[1], nnz,
INTEGER(GET_SLOT(x, Matrix_pSym)), INTEGER(islot),
REAL(GET_SLOT(x, Matrix_xSym)),
INTEGER(ALLOC_SLOT(ans, Matrix_pSym, INTSXP, xdims[0] + 1)),
INTEGER(ALLOC_SLOT(ans, Matrix_iSym, INTSXP, nnz)),
REAL(ALLOC_SLOT(ans, Matrix_xSym, REALSXP, nnz)));
UNPROTECT(1);
return ans;
}
void tr_l_packed_getDiag( int *dest, SEXP x)
{
int n = INTEGER(GET_SLOT(x, Matrix_DimSym))[0];
SEXP val = PROTECT(allocVector(LGLSXP, n));
int *v = LOGICAL(val);
if (*diag_P(x) == 'U') {
int j;
for (j = 0; j < n; j++) v[j] = 1;
} else {
l_packed_getDiag(v, x, n);
}
UNPROTECT(1);
return;
}
SEXP magChol(SEXP a)
{
SEXP gpu = GET_SLOT(a, install("gpu")),
b = PROTECT(NEW_OBJECT(MAKE_CLASS("magma")));
int *DIMA = INTEGER(GET_DIM(a)), N = DIMA[0], N2 = N * N, LDB = N, info;
double *B;
if(DIMA[1] != N) error("non-square matrix");
b = SET_SLOT(b, install(".Data"), AS_NUMERIC(a));
SET_SLOT(b, install("gpu"), duplicate(gpu));
B = REAL(b);
if(LOGICAL_VALUE(gpu)) {
double *dB;
magma_malloc((void**)&dB, N2*sizeof(double));
magma_dsetmatrix(N, N, B, LDB, dB, LDB);
magma_dpotrf_gpu(magma_uplo_const('U'), N, dB, LDB, &info);
magma_dgetmatrix(N, N, dB, LDB, B, LDB);
magma_free(dB);
} else {
double *hB;
magma_malloc_pinned((void**)&hB, N2*sizeof(double));
lapackf77_dlacpy(MagmaUpperStr, &N, &N, B, &LDB, hB, &LDB);
magma_dpotrf(magma_uplo_const('U'), N, hB, N, &info);
lapackf77_dlacpy(MagmaUpperStr, &N, &N, hB, &LDB, B, &LDB);
magma_free_pinned(hB);
}
if(info < 0) error("illegal argument %d in 'magChol", -1 * info);
else if(info > 0) error("leading minor of order %d is not positive definite", info);
int i, j;
for(j = 0; j < N; j++) {
for(i = j + 1; i < N; i++) {
B[i + j * N] = 0.0;
}
}
UNPROTECT(1);
return b;
}
/**
* Copy the diagonal elements of the packed denseMatrix x to dest
*
* @param dest vector of length ncol(x)
* @param x pointer to an object representing a packed array
* @param n number of columns in the matrix represented by x
*
* @return dest
*/
void d_packed_getDiag(double *dest, SEXP x, int n)
{
double *xx = REAL(GET_SLOT(x, Matrix_xSym));
#define END_packed_getDiag \
int j, pos = 0; \
\
if (*uplo_P(x) == 'U') { \
for(pos= 0, j=0; j < n; pos += 1+(++j)) dest[j] = xx[pos]; \
} else { \
for(pos= 0, j=0; j < n; pos += (n - j), j++) dest[j] = xx[pos]; \
} \
return
END_packed_getDiag;
}
static
SEXP get_factor_pattern(SEXP obj, char *pat, int offset)
{
SEXP facs = GET_SLOT(obj, Matrix_factorSym), nms;
int i;
/* Why should this be nessary? Shouldn't nms have length 0 if facs does? */
if (!LENGTH(facs)) return R_NilValue;
nms = getAttrib(facs, R_NamesSymbol);
for (i = 0; i < LENGTH(nms); i++) {
char *nm = CHAR(STRING_ELT(nms, i));
if (strlen(nm) > offset && !strcmp(pat + offset, nm + offset))
return VECTOR_ELT(facs, i);
}
return R_NilValue;
}
/**
* Check commit argument
*
* @param arg the arg to check
* @return 0 if OK, else 1
*/
int git2r_arg_check_commit(SEXP arg)
{
SEXP class_name;
if (R_NilValue == arg || S4SXP != TYPEOF(arg))
return 1;
class_name = getAttrib(arg, R_ClassSymbol);
if (0 != strcmp(CHAR(STRING_ELT(class_name, 0)), "git_commit"))
return 1;
if (git2r_arg_check_string(GET_SLOT(arg, Rf_install("hex"))))
return 1;
return 0;
}
SEXP dgCMatrix_matrix_solve(SEXP Ap, SEXP b, SEXP give_sparse)
// FIXME: add 'keep_dimnames' as argument
{
Rboolean sparse = asLogical(give_sparse);
if(sparse) {
// FIXME: implement this
error(_("dgCMatrix_matrix_solve(.., sparse=TRUE) not yet implemented"));
/* Idea: in the for(j = 0; j < nrhs ..) loop below, build the *sparse* result matrix
* ----- *column* wise -- which is perfect for dgCMatrix
* --> build (i,p,x) slots "increasingly" [well, allocate in batches ..]
*
* --> maybe first a protoype in R
*/
}
SEXP ans = PROTECT(dup_mMatrix_as_dgeMatrix(b)),
lu, qslot;
CSP L, U;
int *bdims = INTEGER(GET_SLOT(ans, Matrix_DimSym)), *p, *q;
int j, n = bdims[0], nrhs = bdims[1];
double *x, *ax = REAL(GET_SLOT(ans, Matrix_xSym));
C_or_Alloca_TO(x, n, double);
if (isNull(lu = get_factors(Ap, "LU"))) {
install_lu(Ap, /* order = */ 1, /* tol = */ 1.0, /* err_sing = */ TRUE,
/* keep_dimnames = */ TRUE);
lu = get_factors(Ap, "LU");
}
qslot = GET_SLOT(lu, install("q"));
L = AS_CSP__(GET_SLOT(lu, install("L")));
U = AS_CSP__(GET_SLOT(lu, install("U")));
R_CheckStack();
if (U->n != n)
error(_("Dimensions of system to be solved are inconsistent"));
if(nrhs >= 1 && n >= 1) {
p = INTEGER(GET_SLOT(lu, Matrix_pSym));
q = LENGTH(qslot) ? INTEGER(qslot) : (int *) NULL;
for (j = 0; j < nrhs; j++) {
cs_pvec(p, ax + j * n, x, n); /* x = b(p) */
cs_lsolve(L, x); /* x = L\x */
cs_usolve(U, x); /* x = U\x */
if (q) /* r(q) = x , hence
r = Q' U{^-1} L{^-1} P b = A^{-1} b */
cs_ipvec(q, x, ax + j * n, n);
else
Memcpy(ax + j * n, x, n);
}
}
if(n >= SMALL_4_Alloca) Free(x);
UNPROTECT(1);
return ans;
}
SEXP CombineSubMapsTransSimple(BigMatrix *oneVox_allSubs, SEXP allVoxs_allSubs, index_type seed, double *pVoxs, index_type nvoxs, index_type nsubs) {
//using namespace Rcpp;
BMAccessorType outMat( *oneVox_allSubs );
if (nvoxs != oneVox_allSubs->ncol())
::Rf_error("nvoxs must equal oneVox_allSubs->ncol");
if (nsubs != oneVox_allSubs->nrow())
::Rf_error("nsubs must equal oneVox_allSubs->nrow");
// loop through each subject's map
index_type s = 0;
index_type v = 0;
index_type vv = 0;
LDOUBLE x = 0;
LDOUBLE delta = 0;
LDOUBLE mean = 0;
LDOUBLE M2 = 0;
LDOUBLE stdev = 0;
// CType *inCol;
CType *outCol;
LDOUBLE scaled_x;
BigMatrix *allVoxs_oneSub;
SEXP Rp;
SEXP tmp;
//RObject RallVoxs_oneSub;
for (s=0; s < nsubs; ++s) {
PROTECT(tmp = VECTOR_ELT(allVoxs_allSubs, s));
//RallVoxs_oneSub(tmp);
//Rp = RallVoxs_oneSub.slot("address");
PROTECT(Rp = GET_SLOT(tmp, install("address")));
//tmp = allVoxs_allSubs[s];
//RObject RallVoxs_oneSub(tmp);
//Rp = RallVoxs_oneSub.slot("address");
allVoxs_oneSub = reinterpret_cast<BigMatrix*>(R_ExternalPtrAddr(Rp));
UNPROTECT(2);
BMAccessorType inMat( *allVoxs_oneSub );
for (v=0; v < nvoxs; ++v) {
vv = static_cast<index_type>(pVoxs[v]-1);
outMat[v][s] = static_cast<CType>(inMat[vv][seed]);
}
}
return R_NilValue;
}
// n.CMatrix --> [dli].CMatrix (not going through CHM!)
SEXP nz2Csparse(SEXP x, enum x_slot_kind r_kind)
{
const char *cl_x = class_P(x);
if(cl_x[0] != 'n') error(_("not a 'n.CMatrix'"));
if(cl_x[2] != 'C') error(_("not a CsparseMatrix"));
int nnz = LENGTH(GET_SLOT(x, Matrix_iSym));
SEXP ans;
char *ncl = strdup(cl_x);
double *dx_x; int *ix_x;
ncl[0] = (r_kind == x_double ? 'd' :
(r_kind == x_logical ? 'l' :
/* else (for now): r_kind == x_integer : */ 'i'));
PROTECT(ans = NEW_OBJECT(MAKE_CLASS(ncl)));
// create a correct 'x' slot:
switch(r_kind) {
int i;
case x_double: // 'd'
dx_x = REAL(ALLOC_SLOT(ans, Matrix_xSym, REALSXP, nnz));
for (i=0; i < nnz; i++) dx_x[i] = 1.;
break;
case x_logical: // 'l'
ix_x = LOGICAL(ALLOC_SLOT(ans, Matrix_xSym, LGLSXP, nnz));
for (i=0; i < nnz; i++) ix_x[i] = TRUE;
break;
case x_integer: // 'i'
ix_x = INTEGER(ALLOC_SLOT(ans, Matrix_xSym, INTSXP, nnz));
for (i=0; i < nnz; i++) ix_x[i] = 1;
break;
default:
error(_("nz2Csparse(): invalid/non-implemented r_kind = %d"),
r_kind);
}
// now copy all other slots :
slot_dup(ans, x, Matrix_iSym);
slot_dup(ans, x, Matrix_pSym);
slot_dup(ans, x, Matrix_DimSym);
slot_dup(ans, x, Matrix_DimNamesSym);
if(ncl[1] != 'g') { // symmetric or triangular ...
slot_dup_if_has(ans, x, Matrix_uploSym);
slot_dup_if_has(ans, x, Matrix_diagSym);
}
UNPROTECT(1);
return ans;
}
/**
* Get the tree pointed to by a commit
*
* @param commit S4 class git_commit or git_stash
* @return S4 class git_tree
*/
SEXP git2r_commit_tree(SEXP commit)
{
int err;
SEXP result = R_NilValue;
SEXP repo;
git_commit *commit_obj = NULL;
git_repository *repository = NULL;
git_tree *tree = NULL;
if (git2r_arg_check_commit(commit))
git2r_error(git2r_err_commit_arg, __func__, "commit");
repo = GET_SLOT(commit, Rf_install("repo"));
repository = git2r_repository_open(repo);
if (!repository)
git2r_error(git2r_err_invalid_repository, __func__, NULL);
err = git2r_commit_lookup(&commit_obj, repository, commit);
if (GIT_OK != err)
goto cleanup;
err = git_commit_tree(&tree, commit_obj);
if (GIT_OK != err)
goto cleanup;
PROTECT(result = NEW_OBJECT(MAKE_CLASS("git_tree")));
git2r_tree_init((git_tree*)tree, repo, result);
cleanup:
if (commit_obj)
git_commit_free(commit_obj);
if (tree)
git_tree_free(tree);
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 CHMfactor_solve(SEXP a, SEXP b, SEXP system)
{
CHM_FR L = AS_CHM_FR(a);
SEXP bb = PROTECT(dup_mMatrix_as_dgeMatrix(b));
CHM_DN B = AS_CHM_DN(bb), X;
int sys = asInteger(system);
R_CheckStack();
if (!(sys--)) /* align with CHOLMOD defs: R's {1:9} --> {0:8},
see ./CHOLMOD/Cholesky/cholmod_solve.c */
error(_("system argument is not valid"));
X = cholmod_solve(sys, L, B, &c);
UNPROTECT(1);
return chm_dense_to_SEXP(X, 1/*do_free*/, 0/*Rkind*/,
GET_SLOT(bb, Matrix_DimNamesSym), FALSE);
}
SEXP Rgraphviz_doLayout(SEXP graph, SEXP layoutType, SEXP size) {
/* Will perform a Graphviz layout on a graph */
Agraph_t *g;
SEXP slotTmp, nLayout, cPoints, bb;
/* Extract the Agraph_t pointer from the S4 object */
PROTECT(slotTmp = GET_SLOT(graph, install("agraph")));
CHECK_Rgraphviz_graph(slotTmp);
g = R_ExternalPtrAddr(slotTmp);
if (size != R_NilValue) {
agsafeset(g, "size", CHAR(STRING_ELT(size, 0)), NULL);
}
/* Call the appropriate Graphviz layout routine */
gvLayout(gvc, g, CHAR(STRING_ELT(layoutType, 0)));
/*
if (!isInteger(layoutType))
error("layoutType must be an integer value");
else {
gvLayout(gvc, g, layouts[INTEGER(layoutType)[0]]);
}
*/
/* Here we want to extract information for the resultant S4
object */
PROTECT(nLayout = getNodeLayouts(g));
PROTECT(bb = getBoundBox(g));
PROTECT(cPoints = getEdgeLocs(g));
SET_SLOT(graph, Rf_install("agraph"), slotTmp);
SET_SLOT(graph,Rf_install("AgNode"), nLayout);
SET_SLOT(graph,Rf_install("laidout"), Rgraphviz_ScalarLogicalFromRbool(TRUE));
SET_SLOT(graph,Rf_install("AgEdge"), cPoints);
SET_SLOT(graph,Rf_install("boundBox"), bb);
SET_SLOT(graph,Rf_install("fg"), Rgraphviz_ScalarStringOrNull(agget(g, "fgcolor")));
SET_SLOT(graph,Rf_install("bg"), Rgraphviz_ScalarStringOrNull(agget(g, "bgcolor")));
UNPROTECT(4);
/* free gvc after rendering */
gvFreeLayout(gvc, g);
return(graph);
}
SEXP
R_duplicateArray(SEXP r_ref, SEXP r_size, SEXP r_elementDup)
{
void *array, *copy;
size_t numBytes = (size_t) REAL(r_size)[0];
SEXP r_ans, tmp;
array = R_getNativeReference(r_ref, NULL, NULL);
copy = malloc( numBytes );
if(!copy) {
PROBLEM "Cannot allocate %lf bytes to copy native array", REAL(r_size)[0]
ERROR;
}
memcpy(copy, array, numBytes);
tmp = GET_SLOT(r_ref, Rf_install("ref"));
r_ans = R_MakeExternalPtr(copy, R_ExternalPtrTag(tmp), R_ExternalPtrProtected(tmp));
return(r_ans);
}
/* Csparse_drop(x, tol): drop entries with absolute value < tol, i.e,
* at least all "explicit" zeros */
SEXP Csparse_drop(SEXP x, SEXP tol)
{
const char *cl = class_P(x);
/* dtCMatrix, etc; [1] = the second character =?= 't' for triangular */
int tr = (cl[1] == 't');
CHM_SP chx = AS_CHM_SP__(x);
CHM_SP ans = cholmod_l_copy(chx, chx->stype, chx->xtype, &c);
double dtol = asReal(tol);
int Rkind = (chx->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
R_CheckStack();
if(!cholmod_l_drop(dtol, ans, &c))
error(_("cholmod_l_drop() failed"));
return chm_sparse_to_SEXP(ans, 1,
tr ? ((*uplo_P(x) == 'U') ? 1 : -1) : 0,
Rkind, tr ? diag_P(x) : "",
GET_SLOT(x, Matrix_DimNamesSym));
}
/*
* --- .Call ENTRY POINT ---
*/
SEXP SimpleIRangesList_isNormal(SEXP x)
{
SEXP list_ir, ans, ans_names;
IRanges_holder ir_holder;
int x_len, i;
list_ir = GET_SLOT(x, install("listData"));
x_len = LENGTH(list_ir);
PROTECT(ans = NEW_LOGICAL(x_len));
for (i = 0; i < x_len; i++) {
ir_holder = _hold_IRanges(VECTOR_ELT(list_ir, i));
LOGICAL(ans)[i] = _is_normal_IRanges_holder(&ir_holder);
}
PROTECT(ans_names = duplicate(GET_NAMES(list_ir)));
SET_NAMES(ans, ans_names);
UNPROTECT(2);
return ans;
}
SEXP
R_setVariant(SEXP svar, SEXP value, SEXP type)
{
VARIANT *var;
var = (VARIANT *)R_ExternalPtrAddr(GET_SLOT(svar, Rf_install("ref")));
if(!var) {
PROBLEM "Null VARIANT value passed to R_setVariant. Was this saved in another session\n"
ERROR;
}
HRESULT hr;
hr = R_convertRObjectToDCOM(value, var);
SEXP ans;
ans = NEW_LOGICAL(1);
LOGICAL_DATA(ans)[0] = hr == S_OK ? TRUE : FALSE;
return(ans);
}
static ReactionGlyph_t *
rsbml_build_doc_reaction_glyph(SEXP r_reaction_glyph)
{
ReactionGlyph_t * reaction_glyph;
SEXP r_curve = GET_SLOT(r_reaction_glyph, install("curve"));
reaction_glyph = ReactionGlyph_create();
rsbml_build_doc_base_graphical_object((GraphicalObject_t *)reaction_glyph, r_reaction_glyph);
SET_ATTR(ReactionGlyph, reaction_glyph, ReactionId, reaction, STRING);
if (GET_LENGTH(r_curve))
ReactionGlyph_setCurve(reaction_glyph, rsbml_build_doc_curve(r_curve));
ADD_LIST(ReactionGlyph, reaction_glyph, SpeciesReferenceGlyph,
speciesReferenceGlyphs, species_reference_glyph);
return reaction_glyph;
}
SEXP csc_col_permute(SEXP x, SEXP perm)
{
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgCMatrix"))), tmp;
int *iperm, *prm, *vi, *vp, *xi, *xp, j, k, ncol, pos;
double *vx, *xx;
SET_SLOT(val, Matrix_factorSym, allocVector(VECSXP, 0));
tmp = GET_SLOT(x, Matrix_DimSym);
SET_SLOT(val, Matrix_DimSym, duplicate(tmp));
ncol = INTEGER(tmp)[1];
if (!(isInteger(perm) && length(perm) == ncol))
error(_("perm must be an integer vector of length %d"),
ncol);
prm = INTEGER(perm);
if (!R_ldl_valid_perm(ncol, prm))
error(_("perm is not a valid 0-based permutation"));
iperm = Calloc(ncol, int);
for (j = 0; j < ncol; j++) iperm[prm[j]] = j;
tmp = GET_SLOT(x, Matrix_pSym);
xp = INTEGER(tmp);
SET_SLOT(val, Matrix_pSym, duplicate(tmp));
vp = INTEGER(GET_SLOT(val, Matrix_pSym));
tmp = GET_SLOT(x, Matrix_iSym);
xi = INTEGER(tmp);
SET_SLOT(val, Matrix_iSym, duplicate(tmp));
vi = INTEGER(GET_SLOT(val, Matrix_iSym));
tmp = GET_SLOT(x, Matrix_xSym);
xx = REAL(tmp);
SET_SLOT(val, Matrix_xSym, duplicate(tmp));
vx = REAL(GET_SLOT(val, Matrix_xSym));
pos = vp[0] = 0;
for (j = 0; j < ncol; j++) {
int jj = iperm[j];
int j1 = xp[jj], j2 = xp[jj+1];
vp[j + 1] = vp[j] + (j2 - j1);
for (k = j1; k < j2; k++) {
vi[pos] = xi[k];
vx[pos] = xx[k];
pos++;
}
}
Free(iperm);
UNPROTECT(1);
return val;
}
SEXP Csparse_transpose(SEXP x, SEXP tri)
{
/* TODO: lgCMatrix & igC* currently go via double prec. cholmod -
* since cholmod (& cs) lacks sparse 'int' matrices */
CHM_SP chx = AS_CHM_SP__(x);
int Rkind = (chx->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
CHM_SP chxt = cholmod_l_transpose(chx, chx->xtype, &c);
SEXP dn = PROTECT(duplicate(GET_SLOT(x, Matrix_DimNamesSym))), tmp;
int tr = asLogical(tri);
R_CheckStack();
tmp = VECTOR_ELT(dn, 0); /* swap the dimnames */
SET_VECTOR_ELT(dn, 0, VECTOR_ELT(dn, 1));
SET_VECTOR_ELT(dn, 1, tmp);
UNPROTECT(1);
return chm_sparse_to_SEXP(chxt, 1, /* SWAP 'uplo' for triangular */
tr ? ((*uplo_P(x) == 'U') ? -1 : 1) : 0,
Rkind, tr ? diag_P(x) : "", dn);
}
void onSet_SW_SKY(SEXP sxp_SW_SKY) {
int i, k = 6;
SW_SKY *v = &SW_Sky;
RealD *p_Cloud;
PROTECT(sxp_SW_SKY);
p_Cloud = REAL(GET_SLOT(sxp_SW_SKY, install("Cloud")));
MyFileName = SW_F_name(eSky);
for (i = 0; i < 12; i++) { //i=columns
v->cloudcov[i] = p_Cloud[0 + k * i];
v->windspeed[i] = p_Cloud[1 + k * i];
v->r_humidity[i] = p_Cloud[2 + k * i];
v->transmission[i] = p_Cloud[3 + k * i];
v->snow_density[i] = p_Cloud[4 + k * i];
v->n_rain_per_day[i] = p_Cloud[5 + k * i];
}
UNPROTECT(1);
}
SEXP dsyMatrix_solve(SEXP a)
{
SEXP trf = dsyMatrix_trf(a);
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dsyMatrix")));
int *dims = INTEGER(GET_SLOT(trf, Matrix_DimSym)), info;
SET_SLOT(val, Matrix_uploSym, duplicate(GET_SLOT(trf, Matrix_uploSym)));
SET_SLOT(val, Matrix_xSym, duplicate(GET_SLOT(trf, Matrix_xSym)));
SET_SLOT(val, Matrix_DimSym, duplicate(GET_SLOT(trf, Matrix_DimSym)));
SET_SLOT(val, Matrix_rcondSym, duplicate(GET_SLOT(a, Matrix_rcondSym)));
F77_CALL(dsytri)(uplo_P(val), dims,
REAL(GET_SLOT(val, Matrix_xSym)), dims,
INTEGER(GET_SLOT(trf, Matrix_permSym)),
(double *) R_alloc((long) dims[0], sizeof(double)),
&info);
UNPROTECT(1);
return val;
}
SEXP rgeos_delaunaytriangulation(SEXP env, SEXP obj, SEXP tol,
SEXP onlyEdges) {
GEOSContextHandle_t GEOShandle = getContextHandle(env);
double tolerance = NUMERIC_POINTER(tol)[0];
int oE = INTEGER_POINTER(onlyEdges)[0];
int pc=0;
SEXP ans, id;
SEXP p4s = GET_SLOT(obj, install("proj4string"));
GEOSGeom geom = rgeos_convert_R2geos(env, obj);
GEOSGeom resgeom = GEOSDelaunayTriangulation_r(GEOShandle, geom,
tolerance, oE);
if (resgeom == NULL)
error("rgeos_delaunaytriangulation: unable to compute");
GEOSGeom_destroy_r(GEOShandle, geom);
// int type = GEOSGeomTypeId_r(GEOShandle, resgeom);
int ng = GEOSGetNumGeometries_r(GEOShandle, resgeom);
//Rprintf("ng: %d, type: %d, %s\n", ng, type, GEOSGeomType_r(GEOShandle, resgeom));
// FIXME convert type 5 to type 7
char buf[BUFSIZ];
PROTECT(id = NEW_CHARACTER(ng)); pc++;
for (int i=0; i<ng; i++) {
sprintf(buf, "%d", i);
SET_STRING_ELT(id, i, COPY_TO_USER_STRING(buf));
}
ans = rgeos_convert_geos2R(env, resgeom, p4s, id);
UNPROTECT(pc);
return(ans);
}
SEXP
R_wxSize_new(SEXP r_width, SEXP r_height, SEXP r_addFinalizer)
{
int width = asInteger(r_width);
int height = asInteger(r_height);
R_CFinalizer_t finalizer = NULL;
wxSize *ans = new wxSize(width, height);
SEXP r_ans = R_make_wx_Ref(ans, "wxSize");
if(TYPEOF(r_addFinalizer) == LGLSXP && LOGICAL(r_addFinalizer)[0])
finalizer = R_finalize_wxSize;
if(finalizer) {
SEXP tmp = GET_SLOT(r_ans, Rf_install("ref"));
R_RegisterCFinalizer(tmp, finalizer);
}
return(r_ans);
}
static SpeciesReferenceGlyph_t *
rsbml_build_doc_species_reference_glyph(SEXP r_species_reference_glyph)
{
SpeciesReferenceGlyph_t * species_reference_glyph;
SEXP r_curve = GET_SLOT(r_species_reference_glyph, install("curve"));
species_reference_glyph = SpeciesReferenceGlyph_create();
rsbml_build_doc_base_graphical_object((GraphicalObject_t *)species_reference_glyph,
r_species_reference_glyph);
SET_ATTR(SpeciesReferenceGlyph, species_reference_glyph, SpeciesGlyphId, speciesGlyph, STRING);
SET_ATTR(SpeciesReferenceGlyph, species_reference_glyph, SpeciesReferenceId, speciesReference, STRING);
// FIXME: SpeciesReferenceGlyph_setRole is not exported
/*SET_ATTR(SpeciesReferenceGlyph, species_reference_glyph, Role, role, STRING);*/
if (GET_LENGTH(r_curve))
SpeciesReferenceGlyph_setCurve(species_reference_glyph, rsbml_build_doc_curve(r_curve));
return species_reference_glyph;
}
SEXP CHMfactor_spsolve(SEXP a, SEXP b, SEXP system)
{
CHM_FR L = AS_CHM_FR(a);
CHM_SP B = AS_CHM_SP__(b);
int sys = asInteger(system);
R_CheckStack();
if (!(sys--)) /* align with CHOLMOD defs: R's {1:9} --> {0:8},
see ./CHOLMOD/Cholesky/cholmod_solve.c */
error(_("system argument is not valid"));
// dimnames:
SEXP dn = PROTECT(allocVector(VECSXP, 2));
// none from a: our CHMfactor objects have no dimnames
SET_VECTOR_ELT(dn, 1, duplicate(VECTOR_ELT(GET_SLOT(b, Matrix_DimNamesSym), 1)));
UNPROTECT(1);
return chm_sparse_to_SEXP(cholmod_spsolve(sys, L, B, &c),
1/*do_free*/, 0/*uploT*/, 0/*Rkind*/, "", dn);
}
SEXP csc_matrix_mm(SEXP a, SEXP b, SEXP classed, SEXP right)
{
int cl = asLogical(classed), rt = asLogical(right);
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix")));
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*ai = INTEGER(GET_SLOT(a, Matrix_iSym)),
*ap = INTEGER(GET_SLOT(a, Matrix_pSym)),
*bdims = INTEGER(cl ? GET_SLOT(b, Matrix_DimSym) :
getAttrib(b, R_DimSymbol)),
*cdims = INTEGER(ALLOC_SLOT(val, Matrix_DimSym, INTSXP, 2)),
chk, ione = 1, j, jj, k, m, n;
double *ax = REAL(GET_SLOT(a, Matrix_xSym)),
*bx = REAL(cl ? GET_SLOT(b, Matrix_xSym) : b), *cx;
if (rt) {
m = bdims[0]; n = adims[1]; k = bdims[1]; chk = adims[0];
} else {
m = adims[0]; n = bdims[1]; k = adims[1]; chk = bdims[0];
}
if (chk != k)
error(_("Matrices are not conformable for multiplication"));
if (m < 1 || n < 1 || k < 1)
error(_("Matrices with zero extents cannot be multiplied"));
cx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n));
AZERO(cx, m * n); /* zero the accumulators */
for (j = 0; j < n; j++) { /* across columns of c */
if (rt) {
int kk, k2 = ap[j + 1];
for (kk = ap[j]; kk < k2; kk++) {
F77_CALL(daxpy)(&m, &ax[kk], &bx[ai[kk]*m],
&ione, &cx[j*m], &ione);
}
} else {
double *ccol = cx + j * m,
*bcol = bx + j * k;
for (jj = 0; jj < k; jj++) { /* across columns of a */
int kk, k2 = ap[jj + 1];
for (kk = ap[jj]; kk < k2; kk++) {
ccol[ai[kk]] += ax[kk] * bcol[jj];
}
}
}
}
cdims[0] = m; cdims[1] = n;
UNPROTECT(1);
return val;
}
