SEXP do_abuswap(SEXP x, SEXP nsim, SEXP thin, SEXP direct) { int nr = nrows(x), nc = ncols(x), ny = asInteger(nsim), ithin = asInteger(thin), idirect = asInteger(direct); size_t i, N = nr*nc; SEXP out = PROTECT(alloc3DArray(REALSXP, nr, nc, ny)); double *rout = REAL(out); if(TYPEOF(x) != REALSXP) x = coerceVector(x, REALSXP); PROTECT(x); double *rx = (double *) R_alloc(N, sizeof(double)); /* sequential swap as in do_swap */ memcpy(rx, REAL(x), N * sizeof(double)); GetRNGstate(); for(i = 0; i < ny; i++) { abuswap(rx, &nr, &nc, &ithin, &idirect); memcpy(rout + i * N, rx, N * sizeof(double)); } PutRNGstate(); UNPROTECT(2); return out; }
SEXP do_curveball(SEXP x, SEXP nsim, SEXP thin) { int nr = nrows(x), nc = ncols(x), ny = asInteger(nsim), ithin = asInteger(thin); size_t i, N = nr*nc; SEXP out = PROTECT(alloc3DArray(INTSXP, nr, nc, ny)); int *iout = INTEGER(out); if(TYPEOF(x) != INTSXP) x = coerceVector(x, INTSXP); PROTECT(x); /* difference to do_swap: need a work vector */ int *iwork = (int *) R_alloc(2*nc, sizeof(int)); int *ix = (int *) R_alloc(N, sizeof(int)); /* sequential trialswap of ix and save result to the iout array */ memcpy(ix, INTEGER(x), N * sizeof(int)); GetRNGstate(); for(i = 0; i < ny; i++) { /* different call than in do_swap */ curveball(ix, &nr, &nc, &ithin, iwork); memcpy(iout + i * N, ix, N * sizeof(int)); } PutRNGstate(); UNPROTECT(2); return out; }
SEXP do_rcfill(SEXP n, SEXP rs, SEXP cs) { int nrow = length(rs), ncol = length(cs), nmat = asInteger(n); int *rfill, *cfill, *rind, *cind; int rlen, clen, i, j, k, offset; if(TYPEOF(rs) != INTSXP) rs = coerceVector(rs, INTSXP); PROTECT(rs); if(TYPEOF(cs) != INTSXP) cs = coerceVector(cs, INTSXP); PROTECT(cs); int *rowsum = INTEGER(rs); int *colsum = INTEGER(cs); rfill = (int *) R_alloc(nrow, sizeof(int)); cfill = (int *) R_alloc(ncol, sizeof(int)); rind = (int *) R_alloc(nrow, sizeof(int)); cind = (int *) R_alloc(ncol, sizeof(int)); SEXP out = PROTECT(alloc3DArray(INTSXP, nrow, ncol, nmat)); int *x = INTEGER(out); memset(x, 0, nmat * nrow * ncol * sizeof(int)); /* collect matrices */ GetRNGstate(); for (k = 0; k < nmat; k++) { offset = k * nrow * ncol; /* initialize fills (0) and indices (0..n) */ for (i = 0, rlen = -1; i < nrow; i++) { if (rowsum[i] > 0) /* skip empty rows */ rind[++rlen] = i; rfill[i] = 0; } for (j = 0, clen = -1; j < ncol; j++) { if (colsum[j] > 0) cind[++clen] = j; cfill[j] = 0; } /* items 0..rlen/clen of rind/cind have the indices of * rows/columns which still can be filled. When the row/column * gets full, replace its index with the last index and reduce * rlen/clen by one */ while (rlen >= 0) { i = IRAND(rlen); j = IRAND(clen); x[offset + rind[i] + nrow * cind[j]]++; if (++rfill[rind[i]] >= rowsum[rind[i]]) rind[i] = rind[rlen--]; if (++cfill[cind[j]] >= colsum[cind[j]]) cind[j] = cind[clen--]; } } PutRNGstate(); UNPROTECT(3); return out; }
/** * Simulate a sample of random matrices from a Wishart distribution * * @param ns Number of samples to generate * @param nuP Degrees of freedom * @param scal Positive-definite scale matrix * * @return */ SEXP rWishart(SEXP ns, SEXP nuP, SEXP scal) { SEXP ans; int *dims = INTEGER(getAttrib(scal, R_DimSymbol)), info, n = asInteger(ns), psqr; double *scCp, *ansp, *tmp, nu = asReal(nuP), one = 1, zero = 0; if (!isMatrix(scal) || !isReal(scal) || dims[0] != dims[1]) error(_("'scal' must be a square, real matrix")); if (n <= 0) n = 1; // allocate early to avoid memory leaks in Callocs below. PROTECT(ans = alloc3DArray(REALSXP, dims[0], dims[0], n)); psqr = dims[0] * dims[0]; tmp = Calloc(psqr, double); scCp = Calloc(psqr, double); Memcpy(scCp, REAL(scal), psqr); memset(tmp, 0, psqr * sizeof(double)); F77_CALL(dpotrf)("U", &(dims[0]), scCp, &(dims[0]), &info); if (info) error(_("'scal' matrix is not positive-definite")); ansp = REAL(ans); GetRNGstate(); for (int j = 0; j < n; j++) { double *ansj = ansp + j * psqr; std_rWishart_factor(nu, dims[0], 1, tmp); F77_CALL(dtrmm)("R", "U", "N", "N", dims, dims, &one, scCp, dims, tmp, dims); F77_CALL(dsyrk)("U", "T", &(dims[1]), &(dims[1]), &one, tmp, &(dims[1]), &zero, ansj, &(dims[1])); for (int i = 1; i < dims[0]; i++) for (int k = 0; k < i; k++) ansj[i + k * dims[0]] = ansj[k + i * dims[0]]; } PutRNGstate(); Free(scCp); Free(tmp); UNPROTECT(1); return ans; }
SEXP do_swap(SEXP x, SEXP nsim, SEXP thin, SEXP method) { int nr = nrows(x), nc = ncols(x), ny = asInteger(nsim), ithin = asInteger(thin); size_t i, N = nr*nc; /* trialswap, swap and swapcount have identical function signature */ const char *cmethod = CHAR(STRING_ELT(method, 0)); if (strcmp("trialswap", cmethod) == 0) swap_fun = trialswap; else if (strcmp("swap", cmethod) == 0) swap_fun = swap; else if (strcmp("swapcount", cmethod) == 0) swap_fun = swapcount; else error("unknown sequential null model \"%s\"", cmethod); SEXP out = PROTECT(alloc3DArray(INTSXP, nr, nc, ny)); int *iout = INTEGER(out); if(TYPEOF(x) != INTSXP) x = coerceVector(x, INTSXP); PROTECT(x); int *ix = (int *) R_alloc(N, sizeof(int)); /* sequential trialswap of ix and save result to the iout array */ memcpy(ix, INTEGER(x), N * sizeof(int)); GetRNGstate(); for(i = 0; i < ny; i++) { swap_fun(ix, &nr, &nc, &ithin); memcpy(iout + i * N, ix, N * sizeof(int)); } PutRNGstate(); UNPROTECT(2); return out; }
SEXP do_backtrack(SEXP n, SEXP rs, SEXP cs) { int i, fill, nr = length(rs), nc = length(cs), nmat = asInteger(n); int N = nr * nc; /* check & cast */ if(TYPEOF(rs) != INTSXP) rs = coerceVector(rs, INTSXP); PROTECT(rs); if(TYPEOF(cs) != INTSXP) cs = coerceVector(cs, INTSXP); PROTECT(cs); int *rowsum = INTEGER(rs); int *colsum = INTEGER(cs); /* initialize work arrays for backtrack()*/ int *ind = (int *) R_alloc(nr * nc, sizeof(int)); int *rfill = (int *) R_alloc(nr, sizeof(int)); int * cfill = (int *) R_alloc(nc, sizeof(int)); for (i = 0, fill = 0; i < nr; i++) fill += rowsum[i]; int *x = (int *) R_alloc(nr * nc, sizeof(int)); SEXP out = PROTECT(alloc3DArray(INTSXP, nr, nc, nmat)); int *iout = INTEGER(out); GetRNGstate(); /* Call static C function */ for(i = 0; i < nmat; i++) { backtrack(x, rowsum, colsum, fill, nr, nc, rfill, cfill, ind); memcpy(iout + i * N, x, N * sizeof(int)); } PutRNGstate(); UNPROTECT(3); return out; }
SEXP TransPROBAJ( SEXP object, SEXP UT, SEXP nboot) { SEXP data, T1, E1, S, E; data = VECTOR_ELT(object, 0); T1 = VECTOR_ELT(data, 0); E1 = VECTOR_ELT(data, 1); S = VECTOR_ELT(data, 2); E = VECTOR_ELT(data, 3); int len = GET_LENGTH(T1), nt = GET_LENGTH(UT), t, nth = 1; SEXP P, list; PROTECT( P = alloc3DArray(REALSXP, *INTEGER(nboot), nt, 4) ); PROTECT( list = NEW_LIST(2) ); if (*INTEGER(nboot) > 1) nth = global_num_threads; int **index0 = (int**)malloc( nth*sizeof(int*) ); // allocate memory block if (index0 == NULL) error("TransPROBAJ: No more memory\n"); int **index1 = (int**)malloc( nth*sizeof(int*) ); // allocate memory block if (index1 == NULL) error("TransPROBAJ: No more memory\n"); double **WORK0 = (double**)malloc( nth*sizeof(double*) ); // allocate memory block if (WORK0 == NULL) error("TransPROBAJ: No more memory\n"); int **WORK1 = (int**)malloc( nth*sizeof(int*) ); // allocate memory block if (WORK1 == NULL) error("TransPROBAJ: No more memory\n"); for (t = 0; t < nth; t++) { // allocate per thread memory if ( ( index0[t] = (int*)malloc( len*sizeof(int) ) ) == NULL ) error("TransPROBAJ: No more memory\n"); if ( ( index1[t] = (int*)malloc( len*sizeof(int) ) ) == NULL ) error("TransPROBAJ: No more memory\n"); if ( ( WORK0[t] = (double*)malloc( len*2*sizeof(double) ) ) == NULL ) error("TransPROBAJ: No more memory\n"); if ( ( WORK1[t] = (int*)malloc( len*sizeof(int) ) ) == NULL ) error("TransPROBAJ: No more memory\n"); } #ifdef _OPENMP #pragma omp parallel num_threads(nth) private(t) #endif { int b; #ifdef _OPENMP t = omp_get_thread_num(); #else t = 0; #endif #ifdef _OPENMP #pragma omp single #endif { b = 0; indx_ii(&len, index0[t], index1[t]); // initialize indexes order_di(REAL(T1), INTEGER(E1), index0[t], len, FALSE, FALSE, TRUE, WORK0[t], WORK1[t]); // get permuation order_di(REAL(S), INTEGER(E), index1[t], len, FALSE, FALSE, TRUE, WORK0[t], WORK1[t]); // get permuation transAJI(&len, REAL(T1), INTEGER(E1), REAL(S), INTEGER(E), index0[t], index1[t], &nt, REAL(UT), INTEGER(nboot), REAL(P), &b, WORK0[t]); // compute transition probabilities } #ifdef _OPENMP #pragma omp for #endif for (b = 1; b < *INTEGER(nboot); b++) { boot_ii(RngArray[t], &len, index0[t], index1[t]); // bootstrap indexes order_di(REAL(T1), INTEGER(E1), index0[t], len, FALSE, FALSE, TRUE, WORK0[t], WORK1[t]); // get permuation order_di(REAL(S), INTEGER(E), index1[t], len, FALSE, FALSE, TRUE, WORK0[t], WORK1[t]); // get permuation transAJI(&len, REAL(T1), INTEGER(E1), REAL(S), INTEGER(E), index0[t], index1[t], &nt, REAL(UT), INTEGER(nboot), REAL(P), &b, WORK0[t]); // compute transition probabilities } } for (t = nth-1; t >= 0; t--) { free(index0[t]); // free memory block free(index1[t]); // free memory block free(WORK0[t]); // free memory block free(WORK1[t]); // free memory block } free(index0); // free memory block free(index1); // free memory block free(WORK0); // free memory block free(WORK1); // free memory block SET_ELEMENT(list, 0, P); SET_ELEMENT(list, 1, R_NilValue); UNPROTECT(2); return list; } // TransPROBAJ