SEXP R_to_CMatrix(SEXP x)
{
SEXP ans, tri = PROTECT(allocVector(LGLSXP, 1));
char *ncl = strdup(class_P(x));
static const char *valid[] = { MATRIX_VALID_Rsparse, ""};
int ctype = Matrix_check_class_etc(x, valid);
int *x_dims = INTEGER(GET_SLOT(x, Matrix_DimSym)), *a_dims;
PROTECT_INDEX ipx;
if (ctype < 0)
error(_("invalid class(x) '%s' in R_to_CMatrix(x)"), ncl);
/* replace 'R' with 'C' : */
ncl[2] = 'C';
PROTECT_WITH_INDEX(ans = NEW_OBJECT(MAKE_CLASS(ncl)), &ipx);
a_dims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2));
/* reversed dim() since we will transpose: */
a_dims[0] = x_dims[1];
a_dims[1] = x_dims[0];
/* triangular: */ LOGICAL(tri)[0] = 0;
if((ctype / 3) != 2) /* not n..Matrix */
slot_dup(ans, x, Matrix_xSym);
if(ctype % 3) { /* s(ymmetric) or t(riangular) : */
SET_SLOT(ans, Matrix_uploSym,
mkString((*uplo_P(x) == 'U') ? "L" : "U"));
if(ctype % 3 == 2) { /* t(riangular) : */
LOGICAL(tri)[0] = 1;
slot_dup(ans, x, Matrix_diagSym);
}
}
SET_SLOT(ans, Matrix_iSym, duplicate(GET_SLOT(x, Matrix_jSym)));
slot_dup(ans, x, Matrix_pSym);
REPROTECT(ans = Csparse_transpose(ans, tri), ipx);
SET_DimNames(ans, x);
free(ncl);
UNPROTECT(2);
return ans;
}
SEXP LU_expand(SEXP x)
{
const char *nms[] = {"L", "U", "P", ""};
SEXP L, U, P, val = PROTECT(Matrix_make_named(VECSXP, nms)),
lux = GET_SLOT(x, Matrix_xSym),
dd = GET_SLOT(x, Matrix_DimSym);
int *iperm, *perm, *pivot = INTEGER(GET_SLOT(x, Matrix_permSym)),
i, n = INTEGER(dd)[0];
SET_VECTOR_ELT(val, 0, NEW_OBJECT(MAKE_CLASS("dtrMatrix")));
L = VECTOR_ELT(val, 0);
SET_VECTOR_ELT(val, 1, NEW_OBJECT(MAKE_CLASS("dtrMatrix")));
U = VECTOR_ELT(val, 1);
SET_VECTOR_ELT(val, 2, NEW_OBJECT(MAKE_CLASS("pMatrix")));
P = VECTOR_ELT(val, 2);
SET_SLOT(L, Matrix_xSym, duplicate(lux));
SET_SLOT(L, Matrix_DimSym, duplicate(dd));
SET_SLOT(L, Matrix_uploSym, mkString("L"));
SET_SLOT(L, Matrix_diagSym, mkString("U"));
make_d_matrix_triangular(REAL(GET_SLOT(L, Matrix_xSym)), L);
SET_SLOT(U, Matrix_xSym, duplicate(lux));
SET_SLOT(U, Matrix_DimSym, duplicate(dd));
SET_SLOT(U, Matrix_uploSym, mkString("U"));
SET_SLOT(U, Matrix_diagSym, mkString("N"));
make_d_matrix_triangular(REAL(GET_SLOT(U, Matrix_xSym)), U);
SET_SLOT(P, Matrix_DimSym, duplicate(dd));
iperm = Alloca(n, int);
R_CheckStack();
perm = INTEGER(ALLOC_SLOT(P, Matrix_permSym, INTSXP, n));
for (i = 0; i < n; i++) iperm[i] = i + 1; /* initialize permutation*/
for (i = 0; i < n; i++) { /* generate inverse permutation */
int newpos = pivot[i] - 1;
if (newpos != i) {
int tmp = iperm[i];
iperm[i] = iperm[newpos];
iperm[newpos] = tmp;
}
}
/* invert the inverse */
for (i = 0; i < n; i++) perm[iperm[i] - 1] = i + 1;
UNPROTECT(1);
return val;
}
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;
}
/**
* Return a SuiteSparse QR factorization of the sparse matrix A
*
* @param Ap (pointer to) a [m x n] dgCMatrix
* @param ordering integer SEXP specifying the ordering strategy to be used
* see SPQR/Include/SuiteSparseQR_definitions.h
* @param econ integer SEXP ("economy"): number of rows of R and columns of Q
* to return. The default is m. Using n gives the standard economy form.
* A value less than the estimated rank r is set to r, so econ=0 gives the
* "rank-sized" factorization, where nrow(R)==nnz(diag(R))==r.
* @param tol double SEXP: if tol <= -2 use SPQR's default,
* if -2 < tol < 0, then no tol is used; otherwise,
* tol > 0, use as tolerance: columns with 2-norm <= tol treated as 0
*
*
* @return SEXP "SPQR" object with slots (Q, R, p, rank, Dim):
* Q: dgCMatrix; R: dgCMatrix [subject to change to dtCMatrix FIXME ?]
* p: integer: 0-based permutation (or length 0 <=> identity);
* rank: integer, the "revealed" rank Dim: integer, original matrix dim.
*/
SEXP dgCMatrix_SPQR(SEXP Ap, SEXP ordering, SEXP econ, SEXP tol)
{
/* SEXP ans = PROTECT(allocVector(VECSXP, 4)); */
SEXP ans = PROTECT(NEW_OBJECT(MAKE_CLASS("SPQR")));
CHM_SP A = AS_CHM_SP(Ap), Q, R;
UF_long *E, rank;/* not always = int FIXME (Windows_64 ?) */
if ((rank = SuiteSparseQR_C_QR(asInteger(ordering),
asReal(tol),/* originally had SPQR_DEFAULT_TOL */
(UF_long)asInteger(econ),/* originally had 0 */
A, &Q, &R, &E, &cl)) == -1)
error(_("SuiteSparseQR_C_QR returned an error code"));
SET_SLOT(ans, Matrix_DimSym, duplicate(GET_SLOT(Ap, Matrix_DimSym)));
/* SET_VECTOR_ELT(ans, 0, */
/* chm_sparse_to_SEXP(Q, 0, 0, 0, "", R_NilValue)); */
SET_SLOT(ans, install("Q"),
chm_sparse_to_SEXP(Q, 0, 0, 0, "", R_NilValue));
/* Also gives a dgCMatrix (not a dtC* *triangular*) :
* may make sense if to be used in the "spqr_solve" routines .. ?? */
/* SET_VECTOR_ELT(ans, 1, */
/* chm_sparse_to_SEXP(R, 0, 0, 0, "", R_NilValue)); */
SET_SLOT(ans, install("R"),
chm_sparse_to_SEXP(R, 0, 0, 0, "", R_NilValue));
cholmod_free_sparse(&Al, &cl);
cholmod_free_sparse(&R, &cl);
cholmod_free_sparse(&Q, &cl);
if (E) {
int *Er;
SET_VECTOR_ELT(ans, 2, allocVector(INTSXP, A->ncol));
Er = INTEGER(VECTOR_ELT(ans, 2));
for (int i = 0; i < A->ncol; i++) Er[i] = (int) E[i];
Free(E);
} else SET_VECTOR_ELT(ans, 2, allocVector(INTSXP, 0));
SET_VECTOR_ELT(ans, 3, ScalarInteger((int)rank));
UNPROTECT(1);
return ans;
}
SEXP
R_make_var_reference(void *ref, const char * const type)
{
SEXP ans;
SEXP klass = MAKE_CLASS("VariableReference");
PROTECT(klass);
PROTECT(ans = NEW(klass));
SET_SLOT(ans, Rf_install("ref"), R_createNativeReference(ref, type, type));
UNPROTECT(2);
return(ans);
}
SEXP magMultmm(SEXP a, SEXP transa, SEXP b, SEXP transb)
{
SEXP gpu = magGetGPU(a, b),
c = PROTECT(NEW_OBJECT(MAKE_CLASS("magma")));
int TA = LOGICAL_VALUE(transa), TB = LOGICAL_VALUE(transb),
*DIMA = INTEGER(GET_DIM(a)), *DIMB = INTEGER(GET_DIM(b)),
M = DIMA[TA], N = DIMB[!TB], K = DIMA[!TA],
LDA = DIMA[0], LDB = DIMB[0], LDC = M;
char TRANSA = (TA ? 'T' : 'N'), TRANSB = (TB ? 'T' : 'N');
double *A = REAL(PROTECT(AS_NUMERIC(a))), *B = REAL(PROTECT(AS_NUMERIC(b))),
*dA, *dB, *dC;
if(DIMB[TB] != K) error("non-conformable matrices");
c = SET_SLOT(c, install(".Data"), allocMatrix(REALSXP, M, N));
SET_SLOT(c, install("gpu"), duplicate(gpu));
magma_malloc((void**)&dA, (M*K)*sizeof(double));
magma_malloc((void**)&dB, (K*N)*sizeof(double));
magma_malloc((void**)&dC, (M*N)*sizeof(double));
magma_dsetmatrix(DIMA[0], DIMA[1], A, LDA, dA, LDA);
magma_dsetmatrix(DIMB[0], DIMB[1], B, LDB, dB, LDB);
if(LOGICAL_VALUE(gpu))
magmablas_dgemm(TRANSA, TRANSB, M, N, K, 1.0, dA, LDA, dB, LDB, 0.0, dC, LDC);
else
cublasDgemm(TRANSA, TRANSB, M, N, K, 1.0, dA, LDA, dB, LDB, 0.0, dC, LDC);
magma_dgetmatrix(M, N, dC, LDC, REAL(c), LDC);
magma_free(dA);
magma_free(dB);
magma_free(dC);
UNPROTECT(3);
return c;
}
SEXP SP_PREFIX(SpatialPolygons_c)(SEXP pls, SEXP pO, SEXP p4s) {
SEXP ans, bbox;
int pc=0;
PROTECT(ans = NEW_OBJECT(MAKE_CLASS("SpatialPolygons"))); pc++;
SET_SLOT(ans, install("polygons"), pls);
SET_SLOT(ans, install("proj4string"), p4s);
if (pO == R_NilValue) {
SET_SLOT(ans, install("plotOrder"), SP_PREFIX(SpatialPolygons_plotOrder_c)(pls));
} else {
SET_SLOT(ans, install("plotOrder"), pO);
}
PROTECT(bbox = SP_PREFIX(bboxCalcR_c(pls))); pc++;
SET_SLOT(ans, install("bbox"), bbox);
UNPROTECT(pc);
return(ans);
}
SEXP ctree_memory (SEXP object, SEXP MP_INV) {
SEXP ans, weights, splitstatistics, dontuse, dontusetmp, varmemory;
int q, p, nobs, ninputs;
q = ncol(get_test_trafo(GET_SLOT(object, PL2_responsesSym)));
ninputs = get_ninputs(object);
nobs = get_nobs(object);
ans = PROTECT(NEW_OBJECT(MAKE_CLASS("TreeFitMemory")));
SET_SLOT(ans, PL2_expcovinfSym, PROTECT(new_ExpectCovarInfluence(q)));
SET_SLOT(ans, PL2_expcovinfssSym, PROTECT(new_ExpectCovarInfluence(1)));
SET_SLOT(ans, PL2_linexpcov2sampleSym, PROTECT(new_LinStatExpectCovar(1, q)));
SET_SLOT(ans, PL2_weightsSym, weights = PROTECT(allocVector(REALSXP, nobs)));
for (int i = 0; i < nobs; i++)
REAL(weights)[i] = 0.0;
SET_SLOT(ans, PL2_splitstatisticsSym, splitstatistics = PROTECT(allocVector(REALSXP, nobs)));
for (int i = 0; i < nobs; i++)
REAL(splitstatistics)[i] = 0.0;
SET_SLOT(ans, PL2_dontuseSym, dontuse = PROTECT(allocVector(LGLSXP, ninputs)));
for (int i = 0; i < ninputs; i++)
LOGICAL(dontuse)[i] = 0.0;
SET_SLOT(ans, PL2_dontusetmpSym, dontusetmp = PROTECT(allocVector(LGLSXP, ninputs)));
for (int i = 0; i < ninputs; i++)
LOGICAL(dontusetmp)[i] = 0.0;
varmemory = PROTECT(allocVector(VECSXP, ninputs));
for (int i = 0; i < ninputs; i++) {
p = ncol(get_transformation(GET_SLOT(object, PL2_inputsSym), i + 1));
if (LOGICAL(MP_INV)[0]) {
SET_VECTOR_ELT(varmemory, i, new_LinStatExpectCovarMPinv(p, q));
} else {
SET_VECTOR_ELT(varmemory, i, new_LinStatExpectCovar(p, q));
}
}
SET_SLOT(ans, PL2_varmemorySym, varmemory);
UNPROTECT(9);
return(ans);
}
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;
}
/**
* Init slots in S4 class git_tag
*
* @param source a tag
* @param repo S4 class git_repository that contains the tag
* @param dest S4 class git_tag to initialize
* @return void
*/
void git2r_tag_init(git_tag *source, SEXP repo, SEXP dest)
{
const git_signature *tagger;
const git_oid *oid;
char sha[GIT_OID_HEXSZ + 1];
char target[GIT_OID_HEXSZ + 1];
oid = git_tag_id(source);
git_oid_tostr(sha, sizeof(sha), oid);
SET_SLOT(dest, Rf_install("sha"), mkString(sha));
SET_SLOT(dest, Rf_install("message"), mkString(git_tag_message(source)));
SET_SLOT(dest, Rf_install("name"), mkString(git_tag_name(source)));
tagger = git_tag_tagger(source);
if (tagger)
git2r_signature_init(tagger, GET_SLOT(dest, Rf_install("tagger")));
oid = git_tag_target_id(source);
git_oid_tostr(target, sizeof(target), oid);;
SET_SLOT(dest, Rf_install("target"), mkString(target));
SET_SLOT(dest, Rf_install("repo"), repo);
}
SEXP
R_createRCOMUnknownObject(void *ref, const char *tag)
{
SEXP obj, ans; /*, classNames, klass, sym */;
if(!ref)
return(R_NilValue);
#ifdef ANNOUNCE_COM_CALLS
fprintf(stderr, "Creating %s %p\n", tag, ref);fflush(stderr);
#endif
#ifdef REGISTER_COM_OBJECTS_WITH_S
registerCOMObject(ref, 1);
#endif
//XXX do we need this? Probably to ensure that if we get back the same
// value that has already been used, that we don't use it before calling the
// finalizer. R_gc() doesn't seem to do it, so we may need more.
//
// This is not in fact necessary. Left here as a reminder.
// callGC();
PROTECT(ans = R_MakeExternalPtr(ref, Rf_install(tag), R_NilValue));
//XXX R_RegisterCFinalizer(ans, RDCOM_finalizer);
R_RegisterCFinalizerEx(ans, RDCOM_finalizer, TRUE);
#if 1
obj = createCOMReferenceObject(ans, tag);
UNPROTECT(1);
#else
klass = MAKE_CLASS("COMIDispatch");
if(klass == NULL || klass == R_NilValue) {
PROBLEM "Can't locate S4 class definition COMIDispatch"
ERROR;
}
/*XX the call to duplicate is needed until 1.6.2 is released
because of a bug in the NEW() mechanism in < 1.6.2! Removed now. */
PROTECT(obj = NEW(klass));
SET_SLOT(obj, Rf_install("ref"), ans);
UNPROTECT(2);
#endif
return(obj);
}
/*XXX Is this used or is it in SWinTypeLibs. */
SEXP
R_createRTypeLib(void *ref)
{
SEXP ans, obj, klass;
PROTECT(ans = R_MakeExternalPtr((void*) ref, R_ITypeLibSym, R_ITypeLibSym));
R_RegisterCFinalizer(ans, R_typelib_finalizer);
klass = MAKE_CLASS("ITypeLib");
PROTECT(obj = duplicate(NEW(klass)));
SET_SLOT(obj, Rf_install("ref"), ans);
UNPROTECT(2);
return(obj);
}
SEXP onGet_SW_SKY() {
int i;
SW_SKY *v = &SW_Sky;
SEXP swCloud,SW_SKY;
SEXP Cloud;
SEXP Cloud_names, Cloud_names_x, Cloud_names_y;
int k = 6;
char *x_names[] = { "SkyCoverPCT", "WindSpeed_m/s", "HumidityPCT",
"Transmissivity", "SnowDensity_kg/m^3", "RainEvents_per_day" };
char *y_names[] = { "January", "February", "March", "April", "May", "June",
"July", "August", "September", "October", "November", "December" };
RealD *p_Cloud;
PROTECT(swCloud = MAKE_CLASS("swCloud"));
PROTECT(SW_SKY = NEW_OBJECT(swCloud));
PROTECT(Cloud = allocMatrix(REALSXP, k, 12));
p_Cloud = REAL(Cloud);
for (i = 0; i < 12; i++) { //i=columns
p_Cloud[0 + k * i] = v->cloudcov[i];
p_Cloud[1 + k * i] = v->windspeed[i];
p_Cloud[2 + k * i] = v->r_humidity[i];
p_Cloud[3 + k * i] = v->transmission[i];
p_Cloud[4 + k * i] = v->snow_density[i];
p_Cloud[5 + k * i] = v->n_rain_per_day[i];
}
PROTECT(Cloud_names = allocVector(VECSXP, 2));
PROTECT(Cloud_names_x = allocVector(STRSXP, k));
for (i = 0; i < k; i++) {
SET_STRING_ELT(Cloud_names_x, i, mkChar(x_names[i]));
}
PROTECT(Cloud_names_y = allocVector(STRSXP, 12));
for (i = 0; i < 12; i++) {
SET_STRING_ELT(Cloud_names_y, i, mkChar(y_names[i]));
}
SET_VECTOR_ELT(Cloud_names, 0, Cloud_names_x);
SET_VECTOR_ELT(Cloud_names, 1, Cloud_names_y);
setAttrib(Cloud, R_DimNamesSymbol, Cloud_names);
SET_SLOT(SW_SKY,install("Cloud"), Cloud);
UNPROTECT(6);
return SW_SKY;
}
SEXP
R_createNativeReference(void *val, const char *className, const char *tagName)
{
SEXP ans;
SEXP klass = MAKE_CLASS((char *) className);
if(klass == R_NilValue) {
PROBLEM "Can't find class %s", className
ERROR;
}
PROTECT(klass);
PROTECT(ans = NEW(klass));
ans = SET_SLOT(ans, Rf_install("ref"), R_MakeExternalPtr(val, Rf_install(tagName), R_NilValue));
UNPROTECT(2);
return(ans);
}
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);
}
/* This and the following R_to_CMatrix() lead to memory-not-mapped seg.faults
* only with {32bit + R-devel + enable-R-shlib} -- no idea why */
SEXP compressed_to_TMatrix(SEXP x, SEXP colP)
{
int col = asLogical(colP); /* 1 if "C"olumn compressed; 0 if "R"ow */
/* however, for Csparse, we now effectively use the cholmod-based
* Csparse_to_Tsparse() in ./Csparse.c ; maybe should simply write
* an as_cholmod_Rsparse() function and then do "as there" ...*/
SEXP indSym = col ? Matrix_iSym : Matrix_jSym,
ans, indP = GET_SLOT(x, indSym),
pP = GET_SLOT(x, Matrix_pSym);
int npt = length(pP) - 1;
char *ncl = strdup(class_P(x));
static const char *valid[] = { MATRIX_VALID_Csparse, MATRIX_VALID_Rsparse, ""};
int ctype = R_check_class_etc(x, valid);
if (ctype < 0)
error(_("invalid class(x) '%s' in compressed_to_TMatrix(x)"), ncl);
/* replace 'C' or 'R' with 'T' :*/
ncl[2] = 'T';
ans = PROTECT(NEW_OBJECT(MAKE_CLASS(ncl)));
slot_dup(ans, x, Matrix_DimSym);
if((ctype / 3) % 4 != 2) /* not n..Matrix */
slot_dup(ans, x, Matrix_xSym);
if(ctype % 3) { /* s(ymmetric) or t(riangular) : */
slot_dup(ans, x, Matrix_uploSym);
if(ctype % 3 == 2) /* t(riangular) : */
slot_dup(ans, x, Matrix_diagSym);
}
SET_DimNames(ans, x);
// possibly asymmetric for symmetricMatrix is ok
SET_SLOT(ans, indSym, duplicate(indP));
expand_cmprPt(npt, INTEGER(pP),
INTEGER(ALLOC_SLOT(ans, col ? Matrix_jSym : Matrix_iSym,
INTSXP, length(indP))));
free(ncl);
UNPROTECT(1);
return ans;
}
SEXP
R_stringArrayFFIType(SEXP len)
{
int n = INTEGER(len)[0];
ffi_type *ptr = calloc(1, sizeof(ffi_type));
*ptr = ffi_type_pointer;
#if 0
#warning "Check the alignment"
#endif
ptr->alignment = 1; /* XXX */
ptr->size = n;
ptr->elements = &ffi_string_array_element_types;
SEXP ans, klass;
PROTECT(klass = MAKE_CLASS("FixedLengthStringFFIType"));
PROTECT(ans = NEW(klass));
SET_SLOT(ans, Rf_install("ref"), R_MakeExternalPtr(ptr, Rf_install("ffi_type"), R_NilValue));
UNPROTECT(2);
return(ans);
}
SEXP onGet_SW_SWC_hist(TimeInt year) {
sw_error(-1, "'onGet_SW_SWC_hist' is currently not functional.\n");
int i, j = 0;
SW_SOILWAT *v = &SW_Soilwat;
SEXP swSWC_hist;
SEXP hist;
char *cSWC_hist[] = { "doy", "lyr", "swc", "st_err" };
SEXP lyrs, lyrs_names, lyrs_names_y;
RealD *p_lyrs;
PROTECT(swSWC_hist = MAKE_CLASS("swSWC_hist"));
PROTECT(hist = NEW_OBJECT(swSWC_hist));
PROTECT(lyrs = allocMatrix(REALSXP, MAX_LAYERS*MAX_DAYS, 4));
p_lyrs = REAL(lyrs);
//TODO: variable j is used as index but not incremented
for (i = 0; i < MAX_DAYS * MAX_LAYERS; i++) {
p_lyrs[i + MAX_DAYS * MAX_LAYERS * 0] = (int) (i / MAX_LAYERS);
p_lyrs[i + MAX_DAYS * MAX_LAYERS * 1] = (int) (j % MAX_LAYERS);
p_lyrs[i + MAX_DAYS * MAX_LAYERS * 2] = v->hist.swc[(int) (i / MAX_LAYERS)][(int) (j % MAX_LAYERS)];
p_lyrs[i + MAX_DAYS * MAX_LAYERS * 3] = v->hist.std_err[(int) (i / MAX_LAYERS)][(int) (j % MAX_LAYERS)];
}
PROTECT(lyrs_names = allocVector(VECSXP,2));
PROTECT(lyrs_names_y = allocVector(STRSXP,4));
for (i = 0; i < 4; i++)
SET_STRING_ELT(lyrs_names_y, i, mkChar(cSWC_hist[i]));
SET_VECTOR_ELT(lyrs_names, 1, lyrs_names_y);
setAttrib(lyrs, R_DimNamesSymbol, lyrs_names);
SET_SLOT(hist,install("data"),lyrs);
UNPROTECT(5);
return lyrs;
}
SEXP
R_makeRefObject(void *ref, const char *className)
{
SEXP klass, obj, sref;
if(!ref) {
PROBLEM "NULL value for external reference"
WARN;
return(R_NilValue);
}
PROTECT(klass = MAKE_CLASS((char *) className)); /* XXX define MAKE_CLASS with const */
if(klass == R_NilValue) { /* Is this the right test? */
PROBLEM "Cannot find class %s for external reference", className
ERROR;
}
PROTECT(obj = NEW_OBJECT(klass));
PROTECT(sref = R_MakeExternalPtr(ref, Rf_install(className), R_NilValue));
obj = SET_SLOT(obj, Rf_install("ref"), sref);
UNPROTECT(3);
return(obj);
}
SEXP new_svd_mem(int p) {
SEXP ans, u, v, s;
PROTECT(ans = NEW_OBJECT(MAKE_CLASS("svd_mem")));
SET_SLOT(ans, PL2_pSym, PROTECT(ScalarInteger(p)));
SET_SLOT(ans, PL2_methodSym, PROTECT(mkString("dgesdd")));
SET_SLOT(ans, PL2_jobuSym, PROTECT(mkString("S")));
SET_SLOT(ans, PL2_jobvSym, PROTECT(mkString("")));
SET_SLOT(ans, PL2_uSym, u = PROTECT(allocMatrix(REALSXP, p, p)));
for (int i = 0; i < p * p; i++)
REAL(u)[i] = 0.0;
SET_SLOT(ans, PL2_vSym, v = PROTECT(allocMatrix(REALSXP, p, p)));
for (int i = 0; i < p * p; i++)
REAL(v)[i] = 0.0;
SET_SLOT(ans, PL2_sSym, s = PROTECT(allocVector(REALSXP, p)));
for (int i = 0; i < p; i++)
REAL(s)[i] = 0.0;
UNPROTECT(8);
return(ans);
}
SEXP getBoundBox(Agraph_t *g) {
/* Determine the graphviz determiend bounding box and */
/* assign it to the appropriate Ragraph structure */
SEXP bbClass, xyClass, curBB, LLXY, URXY;
xyClass = MAKE_CLASS("xyPoint");
bbClass = MAKE_CLASS("boundingBox");
PROTECT(curBB = NEW_OBJECT(bbClass));
PROTECT(LLXY = NEW_OBJECT(xyClass));
PROTECT(URXY = NEW_OBJECT(xyClass));
SET_SLOT(LLXY,Rf_install("x"),Rf_ScalarInteger(g->u.bb.LL.x));
SET_SLOT(LLXY,Rf_install("y"),Rf_ScalarInteger(g->u.bb.LL.y));
SET_SLOT(URXY,Rf_install("x"),Rf_ScalarInteger(g->u.bb.UR.x));
SET_SLOT(URXY,Rf_install("y"),Rf_ScalarInteger(g->u.bb.UR.y));
SET_SLOT(curBB,Rf_install("botLeft"), LLXY);
SET_SLOT(curBB,Rf_install("upRight"), URXY);
UNPROTECT(3);
return(curBB);
}
SEXP R_copyStruct_tm_unz (tm_unz *value)
{
SEXP r_ans = R_NilValue, klass;
klass = MAKE_CLASS("tm_unz");
if(klass == R_NilValue) {
PROBLEM "Cannot find R class tm_unz "
ERROR;
}
PROTECT(klass);
PROTECT(r_ans = NEW(klass));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("tm_sec"), ScalarInteger( value -> tm_sec ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("tm_min"), ScalarInteger( value -> tm_min ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("tm_hour"), ScalarInteger( value -> tm_hour ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("tm_mday"), ScalarInteger( value -> tm_mday ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("tm_mon"), ScalarInteger( value -> tm_mon ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("tm_year"), ScalarInteger( value -> tm_year ) ));
UNPROTECT( 8 );
return(r_ans);
}
SEXP onGet_SW_SWC() {
SW_SOILWAT *v = &SW_Soilwat;
SEXP swSWC;
SEXP SWC;
char *cSWC[] = { "UseSWCHistoricData", "DataFilePrefix", "FirstYear", "Method", "History" };
SEXP swcUseData;
SEXP swcFilePrefix;
SEXP swcFirstYear;
SEXP swcMethod;
PROTECT(swSWC = MAKE_CLASS("swSWC"));
PROTECT(SWC = NEW_OBJECT(swSWC));
PROTECT(swcUseData = NEW_LOGICAL(1));
LOGICAL(swcUseData)[0] = v->hist_use;
SET_SLOT(SWC, install(cSWC[0]), swcUseData);
PROTECT(swcFilePrefix = NEW_CHARACTER(1));
SET_STRING_ELT(swcFilePrefix, 0, mkChar("swcdata"));//v->hist.file_prefix)
SET_SLOT(SWC, install(cSWC[1]), swcFilePrefix);
PROTECT(swcFirstYear = NEW_INTEGER(1));
INTEGER(swcFirstYear)[0] = v->hist.yr.first;
SET_SLOT(SWC, install(cSWC[2]), swcFirstYear);
PROTECT(swcMethod = NEW_INTEGER(1));
INTEGER(swcMethod)[0] = v->hist.method;
SET_SLOT(SWC, install(cSWC[3]), swcMethod);
if(v->hist_use)
SET_SLOT(SWC,install(cSWC[4]),onGet_SW_SWC_hists());
else
SET_SLOT(SWC,install(cSWC[4]),NEW_LIST(0));
UNPROTECT(6);
return SWC;
}
/* Determines whether we can use the error information from the
source object and if so, throws that as an error.
If serr is non-NULL, then the error is not thrown in R
but a COMSErrorInfo object is returned with the information in it.
*/
HRESULT
checkErrorInfo(IUnknown *obj, HRESULT status, SEXP *serr)
{
HRESULT hr;
ISupportErrorInfo *info;
fprintf(stderr, "<checkErrorInfo> %X \n", (unsigned int) status);
if(serr)
*serr = NULL;
hr = obj->QueryInterface(IID_ISupportErrorInfo, (void **)&info);
if(hr != S_OK) {
fprintf(stderr, "No support for ISupportErrorInfo\n");fflush(stderr);
return(hr);
}
info->AddRef();
hr = info->InterfaceSupportsErrorInfo(IID_IDispatch);
info->Release();
if(hr != S_OK) {
fprintf(stderr, "No support for InterfaceSupportsErrorInfo\n");fflush(stderr);
return(hr);
}
IErrorInfo *errorInfo;
hr = GetErrorInfo(0L, &errorInfo);
if(hr != S_OK) {
/* fprintf(stderr, "GetErrorInfo failed\n");fflush(stderr); */
COMError(status);
return(hr);
}
/* So there is some information for us. Use it. */
SEXP klass, ans, tmp;
BSTR ostr;
char *str;
errorInfo->AddRef();
if(serr) {
PROTECT(klass = MAKE_CLASS("SCOMErrorInfo"));
PROTECT(ans = NEW(klass));
PROTECT(tmp = NEW_CHARACTER(1));
errorInfo->GetSource(&ostr);
SET_STRING_ELT(tmp, 0, COPY_TO_USER_STRING(FromBstr(ostr)));
SET_SLOT(ans, Rf_install("source"), tmp);
UNPROTECT(1);
PROTECT(tmp = NEW_CHARACTER(1));
errorInfo->GetDescription(&ostr);
SET_STRING_ELT(tmp, 0, COPY_TO_USER_STRING(str = FromBstr(ostr)));
SET_SLOT(ans, Rf_install("description"), tmp);
UNPROTECT(1);
PROTECT(tmp = NEW_NUMERIC(1));
NUMERIC_DATA(tmp)[0] = status;
SET_SLOT(ans, Rf_install("status"), tmp);
*serr = ans;
UNPROTECT(3);
errorInfo->Release();
PROBLEM "%s", str
WARN;
} else {
errorInfo->GetDescription(&ostr);
str = FromBstr(ostr);
errorInfo->GetSource(&ostr);
errorInfo->Release();
PROBLEM "%s (%s)", str, FromBstr(ostr)
ERROR;
}
return(hr);
}
SEXP RDagSearch::estimate(SEXP rSamples, SEXP rPerturbations, SEXP rClasses, SEXP rClsdist,
SEXP rMaxParents, SEXP rParentSizes, SEXP rMaxComplexity, SEXP rOrder, SEXP rNodeCats,
SEXP rParentsPool, SEXP rFixedParentsPool, SEXP rMatEdgeLiks, SEXP rUseCache, SEXP rEcho, int bIntSample = 0) {
int i, j, k, len, maxParentSet, maxCategories, maxComplexity, bEqualCategories, node, echo, klmode;
int *pRperturbations, *pPerturbations, **parentsPool, **fixedParentsPool, *pPool, *pParentSizes;
double *matEdgeLiks, *pMatEdgeLiks;
SEXP dim, rnodecat, rparpool;
int sampleline, *pNodeOffsets;
int *pRsamples, *pSamples;
double *pfRsamples, *pfSamples;
DAG_LIST<double, int> *pDagList;
int hasClasses, *pRclasses, *pClasses;
if(!isMatrix(rSamples))
error("Data is not a matrix");
PROTECT(rMaxParents = AS_INTEGER(rMaxParents));
maxParentSet = INTEGER_POINTER(rMaxParents)[0];
UNPROTECT(1);
PROTECT(rMaxComplexity = AS_INTEGER(rMaxComplexity));
maxComplexity = INTEGER_POINTER(rMaxComplexity)[0];
UNPROTECT(1);
PROTECT(rEcho = AS_LOGICAL(rEcho));
echo = LOGICAL(rEcho)[0];
UNPROTECT(1);
klmode = 0;
PROTECT(rClsdist = AS_INTEGER(rClsdist));
klmode = INTEGER_POINTER(rClsdist)[0];
UNPROTECT(1);
hasClasses = 0;
if(!isNull(rClasses) && isInteger(rClasses))
hasClasses = 1;
sampleline = 0;
if(bIntSample) {
dim = GET_DIM(rSamples);
m_numNodes = INTEGER(dim)[0];
m_numSamples = INTEGER(dim)[1];
}
else {
dim = GET_DIM(rSamples);
sampleline = INTEGER(dim)[0];
m_numSamples = INTEGER(dim)[1];
if(isNull(rNodeCats))
error("Node categories must be specified");
m_numNodes = length(rNodeCats);
}
if(m_pRorder)
CATNET_FREE(m_pRorder);
m_pRorder = (int*)CATNET_MALLOC(m_numNodes*sizeof(int));
if (!m_pRorder) {
CATNET_MEM_ERR();
}
PROTECT(rOrder = AS_INTEGER(rOrder));
if(length(rOrder) < m_numNodes) {
warning("Invalid nodeOrder parameter - reset to default node order.");
for(i = 0; i < m_numNodes; i++)
m_pRorder[i] = i + 1;
}
else {
memcpy(m_pRorder, INTEGER(rOrder), m_numNodes*sizeof(int));
}
UNPROTECT(1);
if(m_pSearchParams)
delete m_pSearchParams;
m_pSearchParams = new SEARCH_PARAMETERS(
m_numNodes, m_numSamples,
maxParentSet, maxComplexity, echo,
!isNull(rNodeCats),
!isNull(rParentSizes), !isNull(rPerturbations),
!isNull(rParentsPool), !isNull(rFixedParentsPool),
!isNull(rMatEdgeLiks), 0,
NULL, this, sampleline, 0, hasClasses, klmode);
if (!m_pSearchParams) {
CATNET_MEM_ERR();
}
pPerturbations = 0;
if(!isNull(rPerturbations)) {
PROTECT(rPerturbations = AS_INTEGER(rPerturbations));
pPerturbations = m_pSearchParams->m_pPerturbations;
pRperturbations = INTEGER_POINTER(rPerturbations);
for(j = 0; j < m_numSamples; j++) {
for(i = 0; i < m_numNodes; i++) {
pPerturbations[j*m_numNodes + i] = pRperturbations[j*m_numNodes + m_pRorder[i] - 1];
}
}
UNPROTECT(1);
}
if(hasClasses) {
pClasses = (int*)m_pSearchParams->m_pClasses;
PROTECT(rClasses = AS_INTEGER(rClasses));
pRclasses = INTEGER(rClasses);
memcpy(pClasses, pRclasses, m_numSamples*sizeof(int));
UNPROTECT(1); // rClasses
}
parentsPool = 0;
if(!isNull(rParentsPool)) {
PROTECT(rParentsPool = AS_LIST(rParentsPool));
parentsPool = m_pSearchParams->m_parentsPool;
for(i = 0; i < m_numNodes; i++) {
rparpool = AS_INTEGER(VECTOR_ELT(rParentsPool, (int)(m_pRorder[i] - 1)));
len = length(rparpool);
if(isVector(rparpool) && len > 0 && len <= m_numNodes) {
parentsPool[i] = (int*)CATNET_MALLOC((len+1)*sizeof(int));
pPool = INTEGER(rparpool);
if (parentsPool[i] && pPool) {
for(j = 0; j < len; j++) {
if(pPool[j] > 0 && pPool[j] <= m_numNodes) {
for(k = 0; k < m_numNodes; k++)
if(pPool[j] == m_pRorder[k])
break;
if(k < m_numNodes)
parentsPool[i][j] = k;
else
parentsPool[i][j] = -1;
}
}
parentsPool[i][len] = -1;
}
if(m_pSearchParams->m_maxParentsPool < len)
m_pSearchParams->m_maxParentsPool = len;
}
}
UNPROTECT(1);
}
fixedParentsPool = 0;
if(!isNull(rFixedParentsPool)) {
PROTECT(rFixedParentsPool = AS_LIST(rFixedParentsPool));
fixedParentsPool = m_pSearchParams->m_fixedParentsPool;
for(i = 0; i < m_numNodes; i++) {
rparpool = AS_INTEGER(VECTOR_ELT(rFixedParentsPool, (int)(m_pRorder[i] - 1)));
len = length(rparpool);
if(isVector(rparpool) && len > 0 && len <= m_numNodes) {
fixedParentsPool[i] = (int*)CATNET_MALLOC((len+1)*sizeof(int));
if(maxParentSet < len)
maxParentSet = len;
pPool = INTEGER(rparpool);
if (fixedParentsPool[i] && pPool) {
for(j = 0; j < len; j++) {
if(pPool[j] > 0 && pPool[j] <= m_numNodes) {
for(k = 0; k < m_numNodes; k++)
if(pPool[j] == m_pRorder[k])
break;
if(k < m_numNodes)
fixedParentsPool[i][j] = k;
else
fixedParentsPool[i][j] = -1;
}
}
fixedParentsPool[i][len] = -1;
}
if(m_pSearchParams->m_maxParentsPool < len)
m_pSearchParams->m_maxParentsPool = len;
}
}
UNPROTECT(1);
}
if(!isNull(rMatEdgeLiks) && m_pSearchParams->m_matEdgeLiks) {
PROTECT(rMatEdgeLiks = AS_NUMERIC(rMatEdgeLiks));
matEdgeLiks = m_pSearchParams->m_matEdgeLiks;
pMatEdgeLiks = REAL(rMatEdgeLiks);
for(j = 0; j < m_numNodes; j++) {
for(i = 0; i < m_numNodes; i++) {
matEdgeLiks[j*m_numNodes + i] = pMatEdgeLiks[(m_pRorder[j] - 1)*m_numNodes + m_pRorder[i] - 1];
}
}
UNPROTECT(1);
}
if(!isNull(rParentSizes)) {
pParentSizes = m_pSearchParams->m_pParentSizes;
PROTECT(rParentSizes = AS_INTEGER(rParentSizes));
if(length(rParentSizes) == m_numNodes) {
for(i = 0; i < m_numNodes; i++)
pParentSizes[i] = INTEGER(rParentSizes)[m_pRorder[i] - 1];
}
UNPROTECT(1);
}
pDagList = 0;
if(bIntSample) {
PROTECT(rSamples = AS_INTEGER(rSamples));
pSamples = (int*)m_pSearchParams->m_pSamples;
pRsamples = INTEGER(rSamples);
for(j = 0; j < m_numSamples; j++) {
for(i = 0; i < m_numNodes; i++) {
pSamples[j*m_numNodes + i] = pRsamples[j*m_numNodes + m_pRorder[i] - 1];
if(R_IsNA(pSamples[j*m_numNodes + i]) || pSamples[j*m_numNodes + i] < 1) {
pSamples[j*m_numNodes + i] = CATNET_NAN;
}
}
}
UNPROTECT(1); // rSamples
maxCategories = 0;
if(!isNull(rNodeCats)) {
PROTECT(rNodeCats = AS_LIST(rNodeCats));
for(i = 0; i < m_numNodes; i++) {
rnodecat = AS_INTEGER(VECTOR_ELT(rNodeCats, (int)(m_pRorder[i] - 1)));
len = length(rnodecat);
if(maxCategories < len)
maxCategories = len;
//if(maxCategories > 0 && maxCategories != len)
// CATNET_ERR("Nodes should have equal number of categories");
if(isVector(rnodecat) && len > 0) {
m_pSearchParams->m_pNodeNumCats[i] = len;
m_pSearchParams->m_pNodeCats[i] = (int*)CATNET_MALLOC(len*sizeof(int));
if (!m_pSearchParams->m_pNodeCats[i]) {
CATNET_MEM_ERR();
}
for(j = 0; j < len; j++)
m_pSearchParams->m_pNodeCats[i][j] = INTEGER(rnodecat)[j];
}
}
UNPROTECT(1);
}
bEqualCategories = 1;
for(i = 0; i < m_numNodes; i++)
if(i > 1 && m_pSearchParams->m_pNodeNumCats[i] != m_pSearchParams->m_pNodeNumCats[0])
bEqualCategories = 0;
if(bEqualCategories) {
switch(maxParentSet) {
case 1: switch(maxCategories) {
case 2: pDagList = new DAGD_SEARCH<double, int, int, 1, 2>; break;
case 3: pDagList = new DAGD_SEARCH<double, int, int, 1, 3>; break;
case 4: pDagList = new DAGD_SEARCH<double, int, int, 1, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
case 2: switch(maxCategories) {
case 2: pDagList = new DAGD_SEARCH<double, int, int, 2, 2>; break;
case 3: pDagList = new DAGD_SEARCH<double, int, int, 2, 3>; break;
case 4: pDagList = new DAGD_SEARCH<double, int, int, 2, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
case 3: switch(maxCategories) {
case 2: pDagList = new DAGD_SEARCH<double, int, int, 3, 2>; break;
case 3: pDagList = new DAGD_SEARCH<double, int, int, 3, 3>; break;
case 4: pDagList = new DAGD_SEARCH<double, int, int, 3, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
case 4: switch(maxCategories) {
case 2: pDagList = new DAGD_SEARCH<double, int, int, 4, 2>; break;
case 3: pDagList = new DAGD_SEARCH<double, int, int, 4, 3>; break;
case 4: pDagList = new DAGD_SEARCH<double, int, int, 4, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
default: CATNET_NOTSUPP_ERR();break;
}
} /* bEqualCategories */
else {
switch(maxParentSet) {
case 1:
pDagList = new DAGD_SEARCH_DC<double, int, int, 1>; break;
case 2:
pDagList = new DAGD_SEARCH_DC<double, int, int, 2>; break;
case 3:
pDagList = new DAGD_SEARCH_DC<double, int, int, 3>; break;
case 4:
pDagList = new DAGD_SEARCH_DC<double, int, int, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
} /* !bEqualCategories */
}
else /* !bIntSample */ {
pNodeOffsets = (int*)CATNET_MALLOC(m_numNodes*sizeof(int));
if (!pNodeOffsets) {
CATNET_MEM_ERR();
}
memset(pNodeOffsets, 0, m_numNodes*sizeof(int));
maxCategories = 0;
PROTECT(rNodeCats = AS_LIST(rNodeCats));
for(i = 0; i < m_numNodes; i++) {
//rnodecat = AS_INTEGER(VECTOR_ELT(rNodeCats, (int)(m_pRorder[i] - 1)));
rnodecat = AS_INTEGER(VECTOR_ELT(rNodeCats, i));
len = length(rnodecat);
if(maxCategories < len)
maxCategories = len;
//if(maxCategories > 0 && maxCategories != len)
// CATNET_ERR("Nodes should have equal number of categories");
pNodeOffsets[i] = len;
if(i > 0)
pNodeOffsets[i] = pNodeOffsets[i-1] + len;
if(isVector(rnodecat) && len > 0) {
m_pSearchParams->m_pNodeNumCats[i] = len;
m_pSearchParams->m_pNodeCats[i] = (int*)CATNET_MALLOC(len*sizeof(int));
if (m_pSearchParams->m_pNodeCats[i]) {
for(j = 0; j < len; j++)
m_pSearchParams->m_pNodeCats[i][j] = INTEGER(rnodecat)[j];
}
}
}
for(i = m_numNodes - 1; i > 0; i--)
pNodeOffsets[i] = pNodeOffsets[i-1];
pNodeOffsets[0] = 0;
UNPROTECT(1);
PROTECT(rSamples = AS_NUMERIC(rSamples));
pfSamples = (double*)m_pSearchParams->m_pSamples;
pfRsamples = REAL(rSamples);
int ii = 0;
if (pfSamples && pfRsamples) {
for(i = 0; i < m_numNodes; i++) {
for(j = 0; j < m_numSamples; j++) {
memcpy(pfSamples+j*sampleline + ii,
pfRsamples+j*sampleline + pNodeOffsets[m_pRorder[i] - 1],
m_pSearchParams->m_pNodeNumCats[i]*sizeof(double));
if(R_IsNA(pfSamples[j*sampleline + ii]) || pfSamples[j*sampleline + ii] < 0) {
pfSamples[j*sampleline + ii] = CATNET_NAN;
}
}
ii += m_pSearchParams->m_pNodeNumCats[i];
}
}
UNPROTECT(1); // rSamples
CATNET_FREE(pNodeOffsets);
pNodeOffsets = 0;
bEqualCategories = 1;
for(i = 0; i < m_numNodes; i++)
if(i > 1 && m_pSearchParams->m_pNodeNumCats[i] != m_pSearchParams->m_pNodeNumCats[0])
bEqualCategories = 0;
if(bEqualCategories) {
switch(maxParentSet) {
case 1: switch(maxCategories) {
case 2: pDagList = new DAGP_SEARCH<double, int, 1, 2>; break;
case 3: pDagList = new DAGP_SEARCH<double, int, 1, 3>; break;
case 4: pDagList = new DAGP_SEARCH<double, int, 1, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
case 2: switch(maxCategories) {
case 2: pDagList = new DAGP_SEARCH<double, int, 2, 2>; break;
case 3: pDagList = new DAGP_SEARCH<double, int, 2, 3>; break;
case 4: pDagList = new DAGP_SEARCH<double, int, 2, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
case 3: switch(maxCategories) {
case 2: pDagList = new DAGP_SEARCH<double, int, 3, 2>; break;
case 3: pDagList = new DAGP_SEARCH<double, int, 3, 3>; break;
case 4: pDagList = new DAGP_SEARCH<double, int, 3, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
case 4: switch(maxCategories) {
case 2: pDagList = new DAGP_SEARCH<double, int, 4, 2>; break;
case 3: pDagList = new DAGP_SEARCH<double, int, 4, 3>; break;
case 4: pDagList = new DAGP_SEARCH<double, int, 4, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
default: CATNET_NOTSUPP_ERR();break;
}
} /* bEqualCategories */
else {
switch(maxParentSet) {
case 1:
pDagList = new DAGP_SEARCH_DC<double, int, 1>; break;
case 2:
pDagList = new DAGP_SEARCH_DC<double, int, 2>; break;
case 3:
pDagList = new DAGP_SEARCH_DC<double, int, 3>; break;
case 4:
pDagList = new DAGP_SEARCH_DC<double, int, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
} /* !bEqualCategories */
}
if(!pDagList)
CATNET_MEM_ERR();
pDagList->search(m_pSearchParams);
if(m_pSearchParams)
delete m_pSearchParams;
m_pSearchParams = 0;
if(!pDagList->m_dagPars || pDagList->m_numDags < 1) {
warning("No networks are found");
return R_NilValue;
}
int *pn;
SEXP plist, pint, ppars, pLoglik, pComplx;
SEXP daglist = PROTECT(NEW_OBJECT(MAKE_CLASS("dagEvaluate")));
PROTECT(pint = NEW_INTEGER(1));
INTEGER_POINTER(pint)[0] = m_numNodes;
SET_SLOT(daglist, install("numnodes"), pint);
UNPROTECT(1);
PROTECT(pint = NEW_INTEGER(1));
INTEGER_POINTER(pint)[0] = m_numSamples;
SET_SLOT(daglist, install("numsamples"), pint);
UNPROTECT(1);
PROTECT(pint = NEW_INTEGER(1));
INTEGER_POINTER(pint)[0] = maxCategories;
SET_SLOT(daglist, install("maxcats"), pint);
UNPROTECT(1);
PROTECT(pint = NEW_INTEGER(1));
INTEGER_POINTER(pint)[0] = maxParentSet;
SET_SLOT(daglist, install("maxpars"), pint);
UNPROTECT(1);
PROTECT(plist = allocVector(VECSXP, m_numNodes));
for(k = 0; k < m_numNodes; k++) {
node = m_pRorder[k]-1;
if(!pDagList->m_parSlots[k] || pDagList->m_numParSlots[k] <= 0) {
SET_VECTOR_ELT(plist, node, R_NilValue);
continue;
}
PROTECT(ppars = NEW_INTEGER(pDagList->m_numParSlots[k]/*maxParentSet*/*maxParentSet));
pn = INTEGER_POINTER(ppars);
for(j = 0; j < pDagList->m_numParSlots[k]/*maxParentSet*/; j++) {
i = 0;
while(i < maxParentSet && pDagList->m_parSlots[k][j*maxParentSet+i] >= 0) {
pn[j*maxParentSet+i] =
m_pRorder[pDagList->m_parSlots[k][j*maxParentSet+i]];
i++;
}
for(; i < maxParentSet; i++)
pn[j*maxParentSet+i] = 0;
}
SET_VECTOR_ELT(plist, node, ppars);
UNPROTECT(1);
}
SET_SLOT(daglist, install("parSlots"), plist);
UNPROTECT(1);
PROTECT(plist = allocVector(VECSXP, m_numNodes));
for(k = 0; k < m_numNodes; k++) {
node = m_pRorder[k]-1;
if(!pDagList->m_parLogliks[k] || pDagList->m_numParSlots[k] <= 0) {
SET_VECTOR_ELT(plist, node, R_NilValue);
continue;
}
PROTECT(ppars = NEW_NUMERIC(pDagList->m_numParSlots[k]));
memcpy(NUMERIC_POINTER(ppars), pDagList->m_parLogliks[k], pDagList->m_numParSlots[k]*sizeof(double));
SET_VECTOR_ELT(plist, node, ppars);
UNPROTECT(1);
}
SET_SLOT(daglist, install("parLogliks"), plist);
UNPROTECT(1);
PROTECT(plist = allocVector(VECSXP, m_numNodes));
for(k = 0; k < m_numNodes; k++) {
node = m_pRorder[k]-1;
if(!pDagList->m_parComplx[k] || pDagList->m_numParSlots[k] <= 0) {
SET_VECTOR_ELT(plist, node, R_NilValue);
continue;
}
PROTECT(ppars = NEW_INTEGER(pDagList->m_numParSlots[k]));
memcpy(INTEGER_POINTER(ppars), pDagList->m_parComplx[k], pDagList->m_numParSlots[k]*sizeof(int));
SET_VECTOR_ELT(plist, node, ppars);
UNPROTECT(1);
}
SET_SLOT(daglist, install("parComplx"), plist);
UNPROTECT(1);
PROTECT(plist = allocVector(VECSXP, m_numNodes));
for(k = 0; k < m_numNodes; k++) {
node = m_pRorder[k]-1;
if(!pDagList->m_parSampleSize[k] || pDagList->m_numParSlots[k] <= 0) {
SET_VECTOR_ELT(plist, node, R_NilValue);
continue;
}
PROTECT(ppars = NEW_INTEGER(pDagList->m_numParSlots[k]));
memcpy(INTEGER_POINTER(ppars), pDagList->m_parSampleSize[k], pDagList->m_numParSlots[k]*sizeof(int));
SET_VECTOR_ELT(plist, node, ppars);
UNPROTECT(1);
}
SET_SLOT(daglist, install("parSampleSize"), plist);
UNPROTECT(1);
PROTECT(pint = NEW_INTEGER(1));
INTEGER_POINTER(pint)[0] = pDagList->m_numDags;
SET_SLOT(daglist, install("numDags"), pint);
UNPROTECT(1);
PROTECT(plist = allocVector(VECSXP, pDagList->m_numDags));
PROTECT(pLoglik = NEW_NUMERIC(pDagList->m_numDags));
PROTECT(pComplx = NEW_INTEGER(pDagList->m_numDags));
DAG_PARS<double> *pDags = pDagList->m_dagPars;
char *pParBuff = (char*)CATNET_MALLOC((m_numNodes+1)*sizeof(int));
int *pIntBuff = (int*)CATNET_MALLOC((m_numNodes+1)*sizeof(int));
int nParBuff;
if (!pParBuff || !pIntBuff) {
CATNET_MEM_ERR();
}
for(k = 0; k < pDagList->m_numDags && pDags; k++) {
NUMERIC_POINTER(pLoglik)[k] = pDags->loglik;
INTEGER_POINTER(pComplx)[k] = pDags->complx;
if(pDags->numPars == 0) {
SET_VECTOR_ELT(plist, k, R_NilValue);
continue;
}
nParBuff = m_numNodes;
if(pDags->compressNumPars(pIntBuff, pParBuff, nParBuff, m_pRorder) <= 0) {
SET_VECTOR_ELT(plist, k, R_NilValue);
continue;
}
nParBuff = 1 + (int)((nParBuff*sizeof(char))/sizeof(int));
PROTECT(ppars = NEW_INTEGER(nParBuff));
memcpy(INTEGER_POINTER(ppars), pParBuff, nParBuff*sizeof(int));
SET_VECTOR_ELT(plist, k, ppars);
UNPROTECT(1);
pDags = pDags->next;
}
CATNET_FREE(pParBuff);
CATNET_FREE(pIntBuff);
SET_SLOT(daglist, install("numPars"), plist);
SET_SLOT(daglist, install("loglik"), pLoglik);
SET_SLOT(daglist, install("complx"), pComplx);
UNPROTECT(3);
UNPROTECT(1); // cnet
delete pDagList;
pDagList = 0;
if(m_pRorder)
CATNET_FREE(m_pRorder);
m_pRorder = 0;
return daglist;
}
/**
* @param merge_result S4 class git_merge_result
* @repository The repository
* @param merge_head The merge head to merge
* @param n The number of merge heads
* @param preference The merge preference option (None [0], No
* Fast-Forward [1] or Only Fast-Forward [2])
* @param name The name of the merge in the reflog
* @param merger Who is performing the merge
* @param commit_on_success Commit merge commit, if one was created
* during a normal merge
* @return 0 on success, or error code
*/
static int git2r_merge(
SEXP merge_result,
git_repository *repository,
const git_annotated_commit **merge_heads,
size_t n,
git_merge_preference_t preference,
const char *name,
git_signature *merger,
int commit_on_success)
{
int err;
git_merge_analysis_t merge_analysis;
git_merge_preference_t merge_preference;
git_checkout_options checkout_opts = GIT_CHECKOUT_OPTIONS_INIT;
git_merge_options merge_opts = GIT_MERGE_OPTIONS_INIT;
merge_opts.rename_threshold = 50;
merge_opts.target_limit = 200;
checkout_opts.checkout_strategy = GIT_CHECKOUT_SAFE;
err = git_merge_analysis(
&merge_analysis,
&merge_preference,
repository,
merge_heads,
n);
if (err)
return err;
if (merge_analysis & GIT_MERGE_ANALYSIS_UP_TO_DATE) {
SET_SLOT(merge_result,
Rf_install("up_to_date"),
ScalarLogical(1));
return GIT_OK;
} else {
SET_SLOT(merge_result,
Rf_install("up_to_date"),
ScalarLogical(0));
}
if (GIT_MERGE_PREFERENCE_NONE == preference)
preference = merge_preference;
switch (preference) {
case GIT_MERGE_PREFERENCE_NONE:
if (merge_analysis & GIT_MERGE_ANALYSIS_FASTFORWARD) {
if (1 != n) {
giterr_set_str(
GITERR_NONE,
"Unable to perform Fast-Forward merge "
"with mith multiple merge heads.");
return GIT_ERROR;
}
err = git2r_fast_forward_merge(
merge_result,
merge_heads[0],
repository,
name);
} else if (merge_analysis & GIT_MERGE_ANALYSIS_NORMAL) {
err = git2r_normal_merge(
merge_result,
merge_heads,
n,
repository,
name,
merger,
commit_on_success,
&checkout_opts,
&merge_opts);
}
break;
case GIT_MERGE_PREFERENCE_NO_FASTFORWARD:
if (merge_analysis & GIT_MERGE_ANALYSIS_NORMAL) {
err = git2r_normal_merge(
merge_result,
merge_heads,
n,
repository,
name,
merger,
commit_on_success,
&checkout_opts,
&merge_opts);
}
break;
case GIT_MERGE_PREFERENCE_FASTFORWARD_ONLY:
if (merge_analysis & GIT_MERGE_ANALYSIS_FASTFORWARD) {
if (1 != n) {
giterr_set_str(
GITERR_NONE,
"Unable to perform Fast-Forward merge "
"with mith multiple merge heads.");
return GIT_ERROR;
}
err = git2r_fast_forward_merge(
merge_result,
merge_heads[0],
repository,
name);
} else {
giterr_set_str(GITERR_NONE, "Unable to perform Fast-Forward merge.");
return GIT_ERROR;
}
break;
default:
giterr_set_str(GITERR_NONE, "Unknown merge option");
return GIT_ERROR;
}
return GIT_OK;
}
/**
* Perform a normal merge
*
* @param merge_result S4 class git_merge_result
* @param merge_heads The merge heads to merge
* @param n The number of merge heads
* @param repository The repository
* @param message The commit message of the merge
* @param merger Who is performing the merge
* @param commit_on_success Commit merge commit, if one was created
* @param merge_opts Merge options
* @return 0 on success, or error code
*/
static int git2r_normal_merge(
SEXP merge_result,
const git_annotated_commit **merge_heads,
size_t n,
git_repository *repository,
const char *message,
git_signature *merger,
int commit_on_success,
const git_checkout_options *checkout_opts,
const git_merge_options *merge_opts)
{
int err;
git_commit *commit = NULL;
git_index *index = NULL;
SET_SLOT(merge_result, Rf_install("fast_forward"), ScalarLogical(0));
err = git_merge(
repository,
merge_heads,
n,
merge_opts,
checkout_opts);
if (err)
goto cleanup;
err = git_repository_index(&index, repository);
if (err)
goto cleanup;
if (git_index_has_conflicts(index)) {
SET_SLOT(merge_result, Rf_install("conflicts"), ScalarLogical(1));
} else {
SET_SLOT(merge_result, Rf_install("conflicts"), ScalarLogical(0));
if (commit_on_success) {
char sha[GIT_OID_HEXSZ + 1];
git_oid oid;
err = git2r_commit_create(
&oid,
repository,
index,
message,
merger,
merger);
if (err)
goto cleanup;
git_oid_fmt(sha, &oid);
sha[GIT_OID_HEXSZ] = '\0';
SET_SLOT(merge_result, Rf_install("sha"), mkString(sha));
}
}
cleanup:
if (commit)
git_commit_free(commit);
if (index)
git_index_free(index);
return err;
}
/**
* Perform a fast-forward merge
*
* @param merge_result S4 class git_merge_result
* @param merge_head The merge head to fast-forward merge
* @param repository The repository
* @param log_message First part of the one line long message in the reflog
* @return 0 on success, or error code
*/
static int git2r_fast_forward_merge(
SEXP merge_result,
const git_annotated_commit *merge_head,
git_repository *repository,
const char *log_message)
{
int err;
const git_oid *oid;
git_buf buf = GIT_BUF_INIT;
git_commit *commit = NULL;
git_tree *tree = NULL;
git_reference *reference = NULL;
git_checkout_options opts = GIT_CHECKOUT_OPTIONS_INIT;
oid = git_annotated_commit_id(merge_head);
err = git_commit_lookup(&commit, repository, oid);
if (err)
goto cleanup;
err = git_commit_tree(&tree, commit);
if (err)
goto cleanup;
opts.checkout_strategy = GIT_CHECKOUT_SAFE;
err = git_checkout_tree(repository, (git_object*)tree, &opts);
if (err)
goto cleanup;
err = git_repository_head(&reference, repository);
if (err) {
if (GIT_ENOTFOUND != err)
goto cleanup;
}
err = git_buf_printf(&buf, "%s: Fast-forward", log_message);
if (err)
goto cleanup;
if (GIT_ENOTFOUND == err) {
err = git_reference_create(
&reference,
repository,
"HEAD",
git_commit_id(commit),
0, /* force */
buf.ptr);
} else {
git_reference *target_ref = NULL;
err = git_reference_set_target(
&target_ref,
reference,
git_commit_id(commit),
buf.ptr);
if (target_ref)
git_reference_free(target_ref);
}
SET_SLOT(
merge_result,
Rf_install("fast_forward"),
ScalarLogical(1));
SET_SLOT(
merge_result,
Rf_install("conflicts"),
ScalarLogical(0));
cleanup:
git_buf_free(&buf);
if (commit)
git_commit_free(commit);
if (reference)
git_reference_free(reference);
if (tree)
git_tree_free(tree);
return err;
}
SEXP onGet_SW_VPD() {
int i;
SW_VEGPROD *v = &SW_VegProd;
SEXP swProd;
SEXP VegProd;
SEXP VegComp, VegComp_names, vegtype_names, col_names;
SEXP Albedo;
SEXP Canopy, Canopy_names, Canopy_names_x;
char *cCanopy_names_x[] = { "xinflec", "yinflec", "range", "slope", "height_cm" };
RealD *p_Canopy;
SEXP VegInterception, VegInterception_names, VegInterception_names_x;
char *cVegInterception_x[] = { "kSmax", "kdead" };
RealD *p_VegInterception;
SEXP LitterInterception, LitterInterception_names, LitterInterception_names_x;
char *cLitterInterception_x[] = { "kSmax" };
RealD *p_LitterInterception;
SEXP EsTpartitioning_param;
SEXP Es_param_limit;
SEXP Shade, Shade_names, Shade_names_x;
char *cShade_names_x[] = { "ShadeScale", "ShadeMaximalDeadBiomass", "tanfuncXinflec", "yinflec", "range", "slope" };
RealD *p_Shade;
SEXP Hydraulic_flag;//"Flag"
SEXP Hydraulic, Hydraulic_names, Hydraulic_names_x;
RealD *p_Hydraulic;
char *cHydraulic_names[] = { "MaxCondRoot", "SoilWaterPotential50", "ShapeCond" };
SEXP CSWP;
SEXP MonthlyVeg;
SEXP Grasslands, Grasslands_names;
SEXP Shrublands, Shrublands_names;
SEXP Forest, Forest_names;
SEXP Forb, Forb_names;
char *cvegtype_names[] = { "Grasses", "Shrubs", "Trees", "Forbs" };
PROTECT(vegtype_names = allocVector(STRSXP, NVEGTYPES));
for (i = 0; i < NVEGTYPES; i++)
SET_STRING_ELT(vegtype_names, i, mkChar(cvegtype_names[i]));
/* CO2 */
// Initialize variables
SEXP CO2Coefficients, CO2_names, CO2_col_names;
RealD *p_CO2Coefficients;
// Create row and column names
char *cCO2_col_names[] = { "Biomass Coeff1", "Biomass Coeff2", "WUE Coeff1", "WUE Coeff2" };
PROTECT(CO2_col_names = allocVector(STRSXP, 4));
for (i = 0; i < 4; i++)
SET_STRING_ELT(CO2_col_names, i, mkChar(cCO2_col_names[i]));
// Create matrix containing the multipliers
PROTECT(CO2Coefficients = allocMatrix(REALSXP, NVEGTYPES, 4));
p_CO2Coefficients = REAL(CO2Coefficients);
p_CO2Coefficients[0] = v->veg[SW_GRASS].co2_bio_coeff1;
p_CO2Coefficients[1] = v->veg[SW_SHRUB].co2_bio_coeff1;
p_CO2Coefficients[2] = v->veg[SW_TREES].co2_bio_coeff1;
p_CO2Coefficients[3] = v->veg[SW_FORBS].co2_bio_coeff1;
p_CO2Coefficients[4] = v->veg[SW_GRASS].co2_bio_coeff2;
p_CO2Coefficients[5] = v->veg[SW_SHRUB].co2_bio_coeff2;
p_CO2Coefficients[6] = v->veg[SW_TREES].co2_bio_coeff2;
p_CO2Coefficients[7] = v->veg[SW_FORBS].co2_bio_coeff2;
p_CO2Coefficients[8] = v->veg[SW_GRASS].co2_wue_coeff1;
p_CO2Coefficients[9] = v->veg[SW_SHRUB].co2_wue_coeff1;
p_CO2Coefficients[10] = v->veg[SW_TREES].co2_wue_coeff1;
p_CO2Coefficients[11] = v->veg[SW_FORBS].co2_wue_coeff1;
p_CO2Coefficients[12] = v->veg[SW_GRASS].co2_wue_coeff2;
p_CO2Coefficients[13] = v->veg[SW_SHRUB].co2_wue_coeff2;
p_CO2Coefficients[14] = v->veg[SW_TREES].co2_wue_coeff2;
p_CO2Coefficients[15] = v->veg[SW_FORBS].co2_wue_coeff2;
// Integrate values with names
PROTECT(CO2_names = allocVector(VECSXP, 2));
SET_VECTOR_ELT(CO2_names, 1, CO2_col_names);
SET_VECTOR_ELT(CO2_names, 0, vegtype_names);
setAttrib(CO2Coefficients, R_DimNamesSymbol, CO2_names);
RealD *p_Grasslands, *p_Shrublands, *p_Forest, *p_Forb;
SEXP MonthlyVeg_Column_names, MonthlyVeg_Row_names;
char *cMonthlyVeg_Column_names[] = { "Litter", "Biomass", "Live_pct", "LAI_conv" };
PROTECT(swProd = MAKE_CLASS("swProd"));
PROTECT(VegProd = NEW_OBJECT(swProd));
PROTECT(VegComp = allocVector(REALSXP, NVEGTYPES + 1));
REAL(VegComp)[0] = v->veg[SW_GRASS].cov.fCover; //Grass
REAL(VegComp)[1] = v->veg[SW_SHRUB].cov.fCover; //Shrub
REAL(VegComp)[2] = v->veg[SW_TREES].cov.fCover; //Tree
REAL(VegComp)[3] = v->veg[SW_FORBS].cov.fCover; //forb
REAL(VegComp)[4] = v->bare_cov.fCover; //Bare Ground
PROTECT(VegComp_names = allocVector(STRSXP, NVEGTYPES + 1));
SET_STRING_ELT(VegComp_names, 0, mkChar("Grasses"));
SET_STRING_ELT(VegComp_names, 1, mkChar("Shrubs"));
SET_STRING_ELT(VegComp_names, 2, mkChar("Trees"));
SET_STRING_ELT(VegComp_names, 3, mkChar("Forbs"));
SET_STRING_ELT(VegComp_names, 4, mkChar("Bare Ground"));
setAttrib(VegComp, R_NamesSymbol, VegComp_names);
PROTECT(Albedo = allocVector(REALSXP, NVEGTYPES + 1));
REAL(Albedo)[0] = v->veg[SW_GRASS].cov.albedo; //Grass
REAL(Albedo)[1] = v->veg[SW_SHRUB].cov.albedo; //Shrub
REAL(Albedo)[2] = v->veg[SW_TREES].cov.albedo; //Tree
REAL(Albedo)[3] = v->veg[SW_FORBS].cov.albedo; //forb
REAL(Albedo)[4] = v->bare_cov.albedo; //bare ground
setAttrib(Albedo, R_NamesSymbol, VegComp_names);
PROTECT(Canopy = allocMatrix(REALSXP, 5, NVEGTYPES));
p_Canopy = REAL(Canopy);
p_Canopy[0] = v->veg[SW_GRASS].cnpy.xinflec;
p_Canopy[1] = v->veg[SW_GRASS].cnpy.yinflec;
p_Canopy[2] = v->veg[SW_GRASS].cnpy.range;
p_Canopy[3] = v->veg[SW_GRASS].cnpy.slope;
p_Canopy[4] = v->veg[SW_GRASS].canopy_height_constant;
p_Canopy[5] = v->veg[SW_SHRUB].cnpy.xinflec;
p_Canopy[6] = v->veg[SW_SHRUB].cnpy.yinflec;
p_Canopy[7] = v->veg[SW_SHRUB].cnpy.range;
p_Canopy[8] = v->veg[SW_SHRUB].cnpy.slope;
p_Canopy[9] = v->veg[SW_SHRUB].canopy_height_constant;
p_Canopy[10] = v->veg[SW_TREES].cnpy.xinflec;
p_Canopy[11] = v->veg[SW_TREES].cnpy.yinflec;
p_Canopy[12] = v->veg[SW_TREES].cnpy.range;
p_Canopy[13] = v->veg[SW_TREES].cnpy.slope;
p_Canopy[14] = v->veg[SW_TREES].canopy_height_constant;
p_Canopy[15] = v->veg[SW_FORBS].cnpy.xinflec;
p_Canopy[16] = v->veg[SW_FORBS].cnpy.yinflec;
p_Canopy[17] = v->veg[SW_FORBS].cnpy.range;
p_Canopy[18] = v->veg[SW_FORBS].cnpy.slope;
p_Canopy[19] = v->veg[SW_FORBS].canopy_height_constant;
PROTECT(Canopy_names = allocVector(VECSXP, 2));
PROTECT(Canopy_names_x = allocVector(STRSXP, 5));
for (i = 0; i < 5; i++)
SET_STRING_ELT(Canopy_names_x, i, mkChar(cCanopy_names_x[i]));
SET_VECTOR_ELT(Canopy_names, 0, Canopy_names_x);
SET_VECTOR_ELT(Canopy_names, 1, vegtype_names);
setAttrib(Canopy, R_DimNamesSymbol, Canopy_names);
PROTECT(VegInterception = allocMatrix(REALSXP, 2, NVEGTYPES));
p_VegInterception = REAL(VegInterception);
p_VegInterception[0] = v->veg[SW_GRASS].veg_kSmax;
p_VegInterception[1] = v->veg[SW_GRASS].veg_kdead;
p_VegInterception[2] = v->veg[SW_SHRUB].veg_kSmax;
p_VegInterception[3] = v->veg[SW_SHRUB].veg_kdead;
p_VegInterception[4] = v->veg[SW_TREES].veg_kSmax;
p_VegInterception[5] = v->veg[SW_TREES].veg_kdead;
p_VegInterception[6] = v->veg[SW_FORBS].veg_kSmax;
p_VegInterception[7] = v->veg[SW_FORBS].veg_kdead;
PROTECT(VegInterception_names = allocVector(VECSXP, 2));
PROTECT(VegInterception_names_x = allocVector(STRSXP, 2));
for (i = 0; i < 2; i++)
SET_STRING_ELT(VegInterception_names_x, i, mkChar(cVegInterception_x[i]));
SET_VECTOR_ELT(VegInterception_names, 0, VegInterception_names_x);
SET_VECTOR_ELT(VegInterception_names, 1, vegtype_names);
setAttrib(VegInterception, R_DimNamesSymbol, VegInterception_names);
PROTECT(LitterInterception = allocMatrix(REALSXP, 1, NVEGTYPES));
p_LitterInterception = REAL(LitterInterception);
p_LitterInterception[0] = v->veg[SW_GRASS].lit_kSmax;
p_LitterInterception[1] = v->veg[SW_SHRUB].lit_kSmax;
p_LitterInterception[2] = v->veg[SW_TREES].lit_kSmax;
p_LitterInterception[3] = v->veg[SW_FORBS].lit_kSmax;
PROTECT(LitterInterception_names = allocVector(VECSXP, 2));
PROTECT(LitterInterception_names_x = allocVector(STRSXP, 1));
for (i = 0; i < 1; i++)
SET_STRING_ELT(LitterInterception_names_x, i, mkChar(cLitterInterception_x[i]));
SET_VECTOR_ELT(LitterInterception_names, 0, LitterInterception_names_x);
SET_VECTOR_ELT(LitterInterception_names, 1, vegtype_names);
setAttrib(LitterInterception, R_DimNamesSymbol, LitterInterception_names);
PROTECT(EsTpartitioning_param = allocVector(REALSXP, NVEGTYPES));
REAL(EsTpartitioning_param)[0] = v->veg[SW_GRASS].EsTpartitioning_param; //Grass
REAL(EsTpartitioning_param)[1] = v->veg[SW_SHRUB].EsTpartitioning_param; //Shrub
REAL(EsTpartitioning_param)[2] = v->veg[SW_TREES].EsTpartitioning_param; //Tree
REAL(EsTpartitioning_param)[3] = v->veg[SW_FORBS].EsTpartitioning_param; //forb
setAttrib(EsTpartitioning_param, R_NamesSymbol, vegtype_names);
PROTECT(Es_param_limit = allocVector(REALSXP, NVEGTYPES));
REAL(Es_param_limit)[0] = v->veg[SW_GRASS].Es_param_limit; //Grass
REAL(Es_param_limit)[1] = v->veg[SW_SHRUB].Es_param_limit; //Shrub
REAL(Es_param_limit)[2] = v->veg[SW_TREES].Es_param_limit; //Tree
REAL(Es_param_limit)[3] = v->veg[SW_FORBS].Es_param_limit; //forb
setAttrib(Es_param_limit, R_NamesSymbol, vegtype_names);
PROTECT(Shade = allocMatrix(REALSXP, 6, NVEGTYPES));
p_Shade = REAL(Shade);
p_Shade[0] = v->veg[SW_GRASS].shade_scale;
p_Shade[1] = v->veg[SW_GRASS].shade_deadmax;
p_Shade[2] = v->veg[SW_GRASS].tr_shade_effects.xinflec;
p_Shade[3] = v->veg[SW_GRASS].tr_shade_effects.yinflec;
p_Shade[4] = v->veg[SW_GRASS].tr_shade_effects.range;
p_Shade[5] = v->veg[SW_GRASS].tr_shade_effects.slope;
p_Shade[6] = v->veg[SW_SHRUB].shade_scale;
p_Shade[7] = v->veg[SW_SHRUB].shade_deadmax;
p_Shade[8] = v->veg[SW_SHRUB].tr_shade_effects.xinflec;
p_Shade[9] = v->veg[SW_SHRUB].tr_shade_effects.yinflec;
p_Shade[10] = v->veg[SW_SHRUB].tr_shade_effects.range;
p_Shade[11] = v->veg[SW_SHRUB].tr_shade_effects.slope;
p_Shade[12] = v->veg[SW_TREES].shade_scale;
p_Shade[13] = v->veg[SW_TREES].shade_deadmax;
p_Shade[14] = v->veg[SW_TREES].tr_shade_effects.xinflec;
p_Shade[15] = v->veg[SW_TREES].tr_shade_effects.yinflec;
p_Shade[16] = v->veg[SW_TREES].tr_shade_effects.range;
p_Shade[17] = v->veg[SW_TREES].tr_shade_effects.slope;
p_Shade[18] = v->veg[SW_FORBS].shade_scale;
p_Shade[19] = v->veg[SW_FORBS].shade_deadmax;
p_Shade[20] = v->veg[SW_FORBS].tr_shade_effects.xinflec;
p_Shade[21] = v->veg[SW_FORBS].tr_shade_effects.yinflec;
p_Shade[22] = v->veg[SW_FORBS].tr_shade_effects.range;
p_Shade[23] = v->veg[SW_FORBS].tr_shade_effects.slope;
PROTECT(Shade_names = allocVector(VECSXP, 2));
PROTECT(Shade_names_x = allocVector(STRSXP, 6));
for (i = 0; i < 6; i++)
SET_STRING_ELT(Shade_names_x, i, mkChar(cShade_names_x[i]));
SET_VECTOR_ELT(Shade_names, 0, Shade_names_x);
SET_VECTOR_ELT(Shade_names, 1, vegtype_names);
setAttrib(Shade, R_DimNamesSymbol, Shade_names);
PROTECT(Hydraulic_flag = allocVector(LGLSXP, NVEGTYPES));
LOGICAL_POINTER(Hydraulic_flag)[0] = v->veg[SW_GRASS].flagHydraulicRedistribution; //Grass
LOGICAL_POINTER(Hydraulic_flag)[1] = v->veg[SW_SHRUB].flagHydraulicRedistribution; //Shrub
LOGICAL_POINTER(Hydraulic_flag)[2] = v->veg[SW_TREES].flagHydraulicRedistribution; //Tree
LOGICAL_POINTER(Hydraulic_flag)[3] = v->veg[SW_FORBS].flagHydraulicRedistribution; //forb
setAttrib(Hydraulic_flag, R_NamesSymbol, vegtype_names);
PROTECT(Hydraulic = allocMatrix(REALSXP, 3, NVEGTYPES));
p_Hydraulic = REAL(Hydraulic);
p_Hydraulic[0] = v->veg[SW_GRASS].maxCondroot;
p_Hydraulic[1] = v->veg[SW_GRASS].swpMatric50;
p_Hydraulic[2] = v->veg[SW_GRASS].shapeCond;
p_Hydraulic[3] = v->veg[SW_SHRUB].maxCondroot;
p_Hydraulic[4] = v->veg[SW_SHRUB].swpMatric50;
p_Hydraulic[5] = v->veg[SW_SHRUB].shapeCond;
p_Hydraulic[6] = v->veg[SW_TREES].maxCondroot;
p_Hydraulic[7] = v->veg[SW_TREES].swpMatric50;
p_Hydraulic[8] = v->veg[SW_TREES].shapeCond;
p_Hydraulic[9] = v->veg[SW_FORBS].maxCondroot;
p_Hydraulic[10] = v->veg[SW_FORBS].swpMatric50;
p_Hydraulic[11] = v->veg[SW_FORBS].shapeCond;
PROTECT(Hydraulic_names = allocVector(VECSXP, 2));
PROTECT(Hydraulic_names_x = allocVector(STRSXP, 3));
for (i = 0; i < 3; i++) {
SET_STRING_ELT(Hydraulic_names_x, i, mkChar(cHydraulic_names[i]));
}
SET_VECTOR_ELT(Hydraulic_names, 0, Hydraulic_names_x);
SET_VECTOR_ELT(Hydraulic_names, 1, vegtype_names);
setAttrib(Hydraulic, R_DimNamesSymbol, Hydraulic_names);
PROTECT(CSWP = allocVector(REALSXP, NVEGTYPES));
REAL(CSWP)[0] = v->veg[SW_GRASS].SWPcrit / -10; //Grass
REAL(CSWP)[1] = v->veg[SW_SHRUB].SWPcrit / -10; //Shrub
REAL(CSWP)[2] = v->veg[SW_TREES].SWPcrit / -10; //Tree
REAL(CSWP)[3] = v->veg[SW_FORBS].SWPcrit / -10; //Forb
setAttrib(CSWP, R_NamesSymbol, vegtype_names);
PROTECT(MonthlyVeg_Column_names = allocVector(STRSXP, 4));
for (i = 0; i < 4; i++)
SET_STRING_ELT(MonthlyVeg_Column_names, i, mkChar(cMonthlyVeg_Column_names[i]));
PROTECT(MonthlyVeg_Row_names = allocVector(STRSXP, 12));
for (i = 0; i < 12; i++)
SET_STRING_ELT(MonthlyVeg_Row_names, i, mkChar(cMonths[i]));
PROTECT(Grasslands = allocMatrix(REALSXP, 12, 4));
p_Grasslands = REAL(Grasslands);
for (i = 0; i < 12; i++) {
p_Grasslands[i + 12 * 0] = v->veg[SW_GRASS].litter[i];
p_Grasslands[i + 12 * 1] = v->veg[SW_GRASS].biomass[i];
p_Grasslands[i + 12 * 2] = v->veg[SW_GRASS].pct_live[i];
p_Grasslands[i + 12 * 3] = v->veg[SW_GRASS].lai_conv[i];
}
PROTECT(Grasslands_names = allocVector(VECSXP, 2));
SET_VECTOR_ELT(Grasslands_names, 0, MonthlyVeg_Row_names);
SET_VECTOR_ELT(Grasslands_names, 1, MonthlyVeg_Column_names);
setAttrib(Grasslands, R_DimNamesSymbol, Grasslands_names);
PROTECT(Shrublands = allocMatrix(REALSXP, 12, 4));
p_Shrublands = REAL(Shrublands);
for (i = 0; i < 12; i++) {
p_Shrublands[i + 12 * 0] = v->veg[SW_SHRUB].litter[i];
p_Shrublands[i + 12 * 1] = v->veg[SW_SHRUB].biomass[i];
p_Shrublands[i + 12 * 2] = v->veg[SW_SHRUB].pct_live[i];
p_Shrublands[i + 12 * 3] = v->veg[SW_SHRUB].lai_conv[i];
}
PROTECT(Shrublands_names = allocVector(VECSXP, 2));
SET_VECTOR_ELT(Shrublands_names, 0, MonthlyVeg_Row_names);
SET_VECTOR_ELT(Shrublands_names, 1, MonthlyVeg_Column_names);
setAttrib(Shrublands, R_DimNamesSymbol, Shrublands_names);
PROTECT(Forest = allocMatrix(REALSXP, 12, 4));
p_Forest = REAL(Forest);
for (i = 0; i < 12; i++) {
p_Forest[i + 12 * 0] = v->veg[SW_TREES].litter[i];
p_Forest[i + 12 * 1] = v->veg[SW_TREES].biomass[i];
p_Forest[i + 12 * 2] = v->veg[SW_TREES].pct_live[i];
p_Forest[i + 12 * 3] = v->veg[SW_TREES].lai_conv[i];
}
PROTECT(Forest_names = allocVector(VECSXP, 2));
SET_VECTOR_ELT(Forest_names, 0, MonthlyVeg_Row_names);
SET_VECTOR_ELT(Forest_names, 1, MonthlyVeg_Column_names);
setAttrib(Forest, R_DimNamesSymbol, Forest_names);
PROTECT(Forb = allocMatrix(REALSXP, 12, 4));
p_Forb = REAL(Forb);
for (i = 0; i < 12; i++) {
p_Forb[i + 12 * 0] = v->veg[SW_FORBS].litter[i];
p_Forb[i + 12 * 1] = v->veg[SW_FORBS].biomass[i];
p_Forb[i + 12 * 2] = v->veg[SW_FORBS].pct_live[i];
p_Forb[i + 12 * 3] = v->veg[SW_FORBS].lai_conv[i];
}
PROTECT(Forb_names = allocVector(VECSXP, 2));
SET_VECTOR_ELT(Forb_names, 0, MonthlyVeg_Row_names);
SET_VECTOR_ELT(Forb_names, 1, MonthlyVeg_Column_names);
setAttrib(Forb, R_DimNamesSymbol, Forb_names);
PROTECT(MonthlyVeg = allocVector(VECSXP, NVEGTYPES));
SET_VECTOR_ELT(MonthlyVeg, SW_TREES, Forest);
SET_VECTOR_ELT(MonthlyVeg, SW_SHRUB, Shrublands);
SET_VECTOR_ELT(MonthlyVeg, SW_FORBS, Forb);
SET_VECTOR_ELT(MonthlyVeg, SW_GRASS, Grasslands);
PROTECT(col_names = allocVector(STRSXP, NVEGTYPES));
SET_STRING_ELT(col_names, 0, mkChar("Trees"));
SET_STRING_ELT(col_names, 1, mkChar("Shrubs"));
SET_STRING_ELT(col_names, 2, mkChar("Forbs"));
SET_STRING_ELT(col_names, 3, mkChar("Grasses"));
setAttrib(MonthlyVeg, R_NamesSymbol, col_names);
SET_SLOT(VegProd, install(cVegProd_names[0]), VegComp);
SET_SLOT(VegProd, install(cVegProd_names[1]), Albedo);
SET_SLOT(VegProd, install(cVegProd_names[2]), Canopy);
SET_SLOT(VegProd, install(cVegProd_names[3]), VegInterception);
SET_SLOT(VegProd, install(cVegProd_names[4]), LitterInterception);
SET_SLOT(VegProd, install(cVegProd_names[5]), EsTpartitioning_param);
SET_SLOT(VegProd, install(cVegProd_names[6]), Es_param_limit);
SET_SLOT(VegProd, install(cVegProd_names[7]), Shade);
SET_SLOT(VegProd, install(cVegProd_names[8]), Hydraulic_flag);
SET_SLOT(VegProd, install(cVegProd_names[9]), Hydraulic);
SET_SLOT(VegProd, install(cVegProd_names[10]), CSWP);
SET_SLOT(VegProd, install(cVegProd_names[11]), MonthlyVeg);
SET_SLOT(VegProd, install(cVegProd_names[12]), CO2Coefficients);
UNPROTECT(40);
return VegProd;
}
// returns a protected object
SEXP createTestRegression()
{
SEXP regression = PROTECT(regression = NEW_OBJECT(MAKE_CLASS("bmer")));
int protectCount = 0;
// create and setup the dims slot
int *dims = INTEGER(ALLOC_SLOT(regression, lme4_dimsSym, INTSXP, (int) (cvg_POS - nt_POS)));
dims[n_POS] = TEST_NUM_OBSERVATIONS;
dims[p_POS] = TEST_NUM_UNMODELED_COEFS;
dims[nt_POS] = TEST_NUM_FACTORS;
dims[isREML_POS] = FALSE;
dims[q_POS] = 0;
for (int i = 0; i < TEST_NUM_FACTORS; ++i) {
dims[q_POS] += testNumGroupsPerFactor[i] * testNumModeledCoefPerFactor[i];
}
dims[np_POS] = dims[q_POS];
int numObservations = dims[n_POS];
int numUnmodeledCoef = dims[p_POS];
int numModeledCoef = dims[q_POS];
int numFactors = dims[nt_POS];
// create the deviance slot
ALLOC_SLOT(regression, lme4_devianceSym, REALSXP, (int) (NULLdev_POS - ML_POS));
// create and setup the Gp slot
int *sparseRowsForFactor = INTEGER(ALLOC_SLOT(regression, lme4_GpSym, INTSXP, numFactors + 1));
sparseRowsForFactor[0] = 0;
for (int i = 0; i < numFactors; ++i) {
sparseRowsForFactor[i + 1] = testNumGroupsPerFactor[i] * testNumModeledCoefPerFactor[i] + sparseRowsForFactor[i];
}
// create and setup the X slot
SEXP denseDesignMatrixExp = ALLOC_SLOT(regression, lme4_XSym, REALSXP, numObservations * numUnmodeledCoef);
SET_DIMS(denseDesignMatrixExp, numObservations, numUnmodeledCoef);
double *denseDesignMatrix = REAL(denseDesignMatrixExp);
for (int i = 0; i < numObservations; ++i) {
denseDesignMatrix[i] = 1.0;
denseDesignMatrix[i + numObservations] = testDenseDesignMatrixColumn2[i];
denseDesignMatrix[i + 2 * numObservations] = testDenseDesignMatrixColumn3[i];
}
double *response = REAL(ALLOC_SLOT(regression, lme4_ySym, REALSXP, numObservations));
Memcpy(response, testResponse, numObservations);
// sXwt slot
double *sqrtObservationWeights = REAL(ALLOC_SLOT(regression, lme4_sqrtXWtSym, REALSXP, numObservations));
for (int i = 0; i < numObservations; ++i) sqrtObservationWeights[i] = sqrt(testObservationWeights[i]);
// create and setup the Zt slot
SEXP sparseDesignMatrixExp = PROTECT(sparseDesignMatrixExp = NEW_OBJECT(MAKE_CLASS("dgCMatrix")));
++protectCount;
SET_SLOT(regression, lme4_ZtSym, sparseDesignMatrixExp);
int *sdm_dims = INTEGER(ALLOC_SLOT(sparseDesignMatrixExp, install("Dim"), INTSXP, 2));
sdm_dims[0] = numModeledCoef;
sdm_dims[1] = numObservations;
int numSparseNonZeroes = 0;
for (int i = 0; i < numFactors; ++i) numSparseNonZeroes += testNumModeledCoefPerFactor[i];
numSparseNonZeroes *= numObservations;
int *sdm_nonZeroRowIndices = INTEGER(ALLOC_SLOT(sparseDesignMatrixExp, install("i"), INTSXP, numSparseNonZeroes));
Memcpy(sdm_nonZeroRowIndices, testSparseDesignMatrixNonZeroRowIndices, numSparseNonZeroes);
int *sdm_indicesForColumn = INTEGER(ALLOC_SLOT(sparseDesignMatrixExp, install("p"), INTSXP, numObservations + 1));
Memcpy(sdm_indicesForColumn, testSparseDesignMatrixIndicesForColumn, numObservations + 1);
double *sdm_values = REAL(ALLOC_SLOT(sparseDesignMatrixExp, install("x"), REALSXP, numSparseNonZeroes));
Memcpy(sdm_values, testSparseDesignMatrixValues, numSparseNonZeroes);
// create and setup the A slot
SEXP rotatedSparseDesignMatrixExp = PROTECT(rotatedSparseDesignMatrixExp = NEW_OBJECT(MAKE_CLASS("dgCMatrix")));
++protectCount;
SET_SLOT(regression, lme4_ASym, rotatedSparseDesignMatrixExp);
int *rsdm_dims = INTEGER(ALLOC_SLOT(rotatedSparseDesignMatrixExp, install("Dim"), INTSXP, 2));
rsdm_dims[0] = numModeledCoef;
rsdm_dims[1] = numObservations;
int *rsdm_nonZeroRowIndices = INTEGER(ALLOC_SLOT(rotatedSparseDesignMatrixExp, install("i"), INTSXP, numSparseNonZeroes));
Memcpy(rsdm_nonZeroRowIndices, testSparseDesignMatrixNonZeroRowIndices, numSparseNonZeroes);
int *rsdm_indicesForColumn = INTEGER(ALLOC_SLOT(rotatedSparseDesignMatrixExp, install("p"), INTSXP, numObservations + 1));
Memcpy(rsdm_indicesForColumn, testSparseDesignMatrixIndicesForColumn, numObservations + 1);
ALLOC_SLOT(rotatedSparseDesignMatrixExp, install("x"), REALSXP, numSparseNonZeroes);
// ST slot
SEXP stExp = ALLOC_SLOT(regression, lme4_STSym, VECSXP, numFactors);
for (int i = 0; i < TEST_NUM_FACTORS; ++i) {
SEXP stExp_i = PROTECT(allocVector(REALSXP, testNumModeledCoefPerFactor[i] * testNumModeledCoefPerFactor[i]));
++protectCount;
SET_VECTOR_ELT(stExp, i, stExp_i);
SET_DIMS(stExp_i, testNumModeledCoefPerFactor[i], testNumModeledCoefPerFactor[i]);
double *stValues = REAL(stExp_i);
Memcpy(stValues, testSTDecompositions[i], testNumModeledCoefPerFactor[i] * testNumModeledCoefPerFactor[i]);
}
// L slot
SEXP upperLeftBlockLeftFactorizationExp = PROTECT(NEW_OBJECT(MAKE_CLASS("dCHMsimpl")));
++protectCount;
SET_SLOT(regression, lme4_LSym, upperLeftBlockLeftFactorizationExp);
int *ulfblf_permutation = INTEGER(ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("perm"), INTSXP, numModeledCoef));
Memcpy(ulfblf_permutation, testFactorizationPermutation, numModeledCoef);
int *ulfblf_columnCounts = INTEGER(ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("colcount"), INTSXP, numModeledCoef));
Memcpy(ulfblf_columnCounts, testFactorizationColumnCounts, numModeledCoef);
int numFactorizationNonZeroes = 0;
for (int i = 0; i < numModeledCoef; ++i) numFactorizationNonZeroes += ulfblf_columnCounts[i];
ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("x"), REALSXP, numFactorizationNonZeroes);
int *ulfblf_indicesForColumn = INTEGER(ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("p"), INTSXP, numModeledCoef + 1));
Memcpy(ulfblf_indicesForColumn, testFactorizationIndicesForColumn, numModeledCoef + 1);
int *ulfblf_nonZeroRowIndices = INTEGER(ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("i"), INTSXP, numFactorizationNonZeroes));
Memcpy(ulfblf_nonZeroRowIndices, testFactorizationNonZeroRowIndices, numFactorizationNonZeroes);
int *ulfblf_numNonZeroes = INTEGER(ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("nz"), INTSXP, numModeledCoef));
Memcpy(ulfblf_numNonZeroes, testFactorizationNumNonZeroes, numModeledCoef);
int *ulfblf_nextColumns = INTEGER(ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("nxt"), INTSXP, numModeledCoef + 2));
Memcpy(ulfblf_nextColumns, testFactorizationNextColumns, numModeledCoef + 2);
int *ulfblf_prevColumns = INTEGER(ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("prv"), INTSXP, numModeledCoef + 2));
Memcpy(ulfblf_prevColumns, testFactorizationPrevColumns, numModeledCoef + 2);
int *ulfblf_type = INTEGER(ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("type"), INTSXP, 4));
Memcpy(ulfblf_type, testFactorizationType, 4);
int *ulfblf_dims = INTEGER(ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("Dim"), INTSXP, 2));
ulfblf_dims[0] = ulfblf_dims[1] = numModeledCoef;
// misc slots
ALLOC_SLOT(regression, lme4_offsetSym, REALSXP, 0);
ALLOC_SLOT(regression, lme4_varSym, REALSXP, 0);
ALLOC_SLOT(regression, lme4_fixefSym, REALSXP, numUnmodeledCoef);
ALLOC_SLOT(regression, lme4_uSym, REALSXP, numModeledCoef);
ALLOC_SLOT(regression, lme4_CxSym, REALSXP, numSparseNonZeroes);
SEXP offDiagonalBlockRightFactorizationExp =
ALLOC_SLOT(regression, lme4_RXSym, REALSXP, numUnmodeledCoef * numUnmodeledCoef);
AZERO(REAL(offDiagonalBlockRightFactorizationExp), numUnmodeledCoef * numUnmodeledCoef);
SET_DIMS(offDiagonalBlockRightFactorizationExp, numUnmodeledCoef, numUnmodeledCoef);
SEXP lowerRightBlockRightFactorizationExp =
ALLOC_SLOT(regression, lme4_RZXSym, REALSXP, numModeledCoef * numUnmodeledCoef);
SET_DIMS(lowerRightBlockRightFactorizationExp, numModeledCoef, numUnmodeledCoef);
guaranteeValidPrior(regression);
// at this point, everything should be jammed into the regression
// or its objects
UNPROTECT(protectCount);
return (regression);
}
