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
