C++ GET_SLOT函数代码示例

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

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

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