// this actually undoes the permutation
Matrix* permuteRowsAndColumns(Matrix *M, idxtype* rowPerm, idxtype* colPerm)
{
Matrix *ret = allocMatrix(M->nvtxs, M->nnz, 0, 0, 0);
int i;
idxtype* revRowPerm = idxmalloc(M->nvtxs,
"permuteRowsAndColumns:revRowPerm");
// idxtype* revColPerm = idxmalloc(M->nvtxs,
// "permuteRowsAndColumns:revColPerm");
for ( i=0; i<M->nvtxs; i++ )
{
revRowPerm[rowPerm[i]] = i;
// revColPerm[colPerm[i]] = i;
}
ret->xadj[0]=0;
for ( i=0; i<M->nvtxs; i++ )
{
int orgI = revRowPerm[i];
int j;
ret->xadj[i+1] = ret->xadj[i] + ( M->xadj[orgI+1] -
M->xadj[orgI] );
for ( j=ret->xadj[i]; j<ret->xadj[i+1]; j++ )
{
int orgJ = M->xadj[orgI] + j - ret->xadj[i];
ret->adjncy[j] = colPerm[M->adjncy[orgJ]];
ret->adjwgt[j] = M->adjwgt[orgJ];
}
ParallelQSort( ret->adjncy, ret->adjwgt, ret->xadj[i],
ret->xadj[i+1]-1 );
}
ret->nnz = M->nnz;
// GKfree ( (void**)&revRowPerm, (void**)&revColPerm, LTERM );
GKfree ( (void**)&revRowPerm, LTERM );
return ret;
}
SEXP r_propagate_x(SEXP extPtr, SEXP vars, SEXP drift, SEXP diffusion,
SEXP dt, SEXP padding) {
SEXP ret;
quasse_fft *obj = (quasse_fft*)R_ExternalPtrAddr(extPtr);
int nkl = INTEGER(padding)[0], nkr = INTEGER(padding)[1];
int idx=-1, nd=LENGTH(vars) / obj->nx;
idx = lookup(nd, obj->nd, obj->n_fft);
if ( idx < 0 )
error("Failed to find nd = %d\n", nd);
qf_copy_x(obj, REAL(vars), nd, 1);
qf_setup_kern(obj, REAL(drift)[0], REAL(diffusion)[0], REAL(dt)[0],
nkl, nkr);
propagate_x(obj, idx);
PROTECT(ret = allocMatrix(REALSXP, obj->nx, nd));
qf_copy_x(obj, REAL(ret), nd, 0);
UNPROTECT(1);
return ret;
}
static SEXP
GDALColorTable2Matrix(GDALColorTableH ctab) {
int ncol = GDALGetColorEntryCount(ctab);
SEXP cmat = allocMatrix(INTSXP, ncol, 4);
for (int i = 0; i < ncol; ++i) {
const GDALColorEntry* ce = GDALGetColorEntry(ctab, i);
INTEGER(cmat)[i] = static_cast<int>(ce->c1);
INTEGER(cmat)[i + ncol] = static_cast<int>(ce->c2);
INTEGER(cmat)[i + 2 * ncol] = static_cast<int>(ce->c3);
INTEGER(cmat)[i + 3 * ncol] = static_cast<int>(ce->c4);
}
return(cmat);
}
// 特徴点取得
SEXP GoodFeaturesToTrack(SEXP img, SEXP maxpos, SEXP quality, SEXP mindist, SEXP useHarris, SEXP subPix){
SEXP dim = getAttrib(img, R_DimSymbol);
int n;
std::vector<double> pos(2*INTEGER(maxpos)[0]);
if(isInteger(img)){
n = GoodFeaturesToTrackI32(INTEGER(img),INTEGER(dim)[0],
INTEGER(dim)[1], INTEGER(maxpos)[0],
&pos[0], REAL(quality)[0], REAL(mindist)[0],
INTEGER(useHarris)[0],INTEGER(subPix)[0]);
} else {
n = GoodFeaturesToTrackF64( REAL(img),INTEGER(dim)[0],
INTEGER(dim)[1], INTEGER(maxpos)[0],
&pos[0], REAL(quality)[0], REAL(mindist)[0],
INTEGER(useHarris)[0],INTEGER(subPix)[0]);
}
SEXP r;
PROTECT(r = allocMatrix(REALSXP,2,n));
std::copy(&pos[0],&pos[0]+2*n,REAL(r));
UNPROTECT(1);
return r;
}
SEXP magMultmv(SEXP a, SEXP transa, SEXP x, SEXP right)
{
SEXP gpu = magGetGPU(a, x),
y = PROTECT(NEW_OBJECT(MAKE_CLASS("magma")));
int RHS = LOGICAL_VALUE(right), TA = (LOGICAL_VALUE(transa) ^ !RHS),
*DIMA = INTEGER(GET_DIM(a)),
M = DIMA[0], N = DIMA[1], LENX = LENGTH(x), LENY = DIMA[TA], LDA=M;
char TRANSA = (TA ? 'T' : 'N');
double *A = REAL(PROTECT(AS_NUMERIC(a))), *X = REAL(PROTECT(AS_NUMERIC(x))),
*dA, *dX, *dY;
if(DIMA[!TA] != LENX) error("non-conformable matrices");
y = SET_SLOT(y, install(".Data"),
allocMatrix(REALSXP, (RHS ? LENY : 1), (RHS ? 1 : LENY)));
SET_SLOT(y, install("gpu"), duplicate(gpu));
magma_malloc((void**)&dA, (M*N)*sizeof(double));
magma_malloc((void**)&dX, LENX*sizeof(double));
magma_malloc((void**)&dY, LENY*sizeof(double));
magma_dsetmatrix(M, N, A, LDA, dA, LDA);
magma_dsetvector(LENX, X, 1, dX, 1);
if(LOGICAL_VALUE(gpu)) {
magmablas_dgemv(TRANSA, M, N, 1.0, dA, LDA, dX, 1, 0.0, dY, 1);
} else {
cublasDgemv(TRANSA, M, N, 1.0, dA, LDA, dX, 1, 0.0, dY, 1);
}
magma_dgetvector(LENY, dY, 1, REAL(y), 1);
magma_free(dA);
magma_free(dX);
magma_free(dY);
UNPROTECT(3);
return y;
}
/* --- .Call ENTRY POINT --- */
SEXP CompressedIRangesList_summary(SEXP object)
{
int ans_len;
SEXP part_end;
SEXP ans, ans_names, col_names;
part_end = _get_PartitioningByEnd_end(
_get_CompressedList_partitioning(object));
ans_len = LENGTH(part_end);
PROTECT(ans = allocMatrix(INTSXP, ans_len, 2));
memset(INTEGER(ans), 0, 2 * ans_len * sizeof(int));
if (ans_len > 0) {
int i, j, prev_end = 0;
int *ans1_elt, *ans2_elt;
const int *part_end_elt, *ranges_width;
SEXP unlistData = _get_CompressedList_unlistData(object);
ranges_width = INTEGER(_get_IRanges_width(unlistData));
for (i = 0, ans1_elt = INTEGER(ans), ans2_elt = (INTEGER(ans) + ans_len),
part_end_elt = INTEGER(part_end);
i < ans_len; i++, ans1_elt++, ans2_elt++, part_end_elt++)
{
*ans1_elt = *part_end_elt - prev_end;
for (j = 0; j < *ans1_elt; j++) {
*ans2_elt += *ranges_width;
ranges_width++;
}
prev_end = *part_end_elt;
}
}
PROTECT(ans_names = NEW_LIST(2));
PROTECT(col_names = NEW_CHARACTER(2));
SET_STRING_ELT(col_names, 0, mkChar("Length"));
SET_STRING_ELT(col_names, 1, mkChar("WidthSum"));
SET_VECTOR_ELT(ans_names, 0,
duplicate(_get_CompressedList_names(object)));
SET_VECTOR_ELT(ans_names, 1, col_names);
SET_DIMNAMES(ans, ans_names);
UNPROTECT(3);
return ans;
}
Matrix* mis_projectFlow(Matrix* Mc, idxtype* rmap, int nvtxs)
{
Matrix* Mr = allocMatrix(nvtxs, Mc->nnz, 0, 0, 0);
idxtype* hashtable = idxmalloc(nvtxs,
"mis_projectFlow:hashtable");
int i,Mr_counter;
for ( i=0; i<nvtxs; i++ )
{
hashtable[i]=-1;
}
for ( i=0; i<Mc->nvtxs; i++ )
{
hashtable[rmap[i]]=i;
}
Mr->xadj[0]=0;
Mr_counter=0;
for ( i=0; i<nvtxs; i++ )
{
int j=hashtable[i];
if ( j > -1 )
{
int k;
for ( k=Mc->xadj[j]; k<Mc->xadj[j+1]; k++ )
{
Mr->adjncy[Mr_counter]=rmap[Mc->adjncy[k]];
Mr->adjwgt[Mr_counter++]=Mc->adjwgt[k];
}
}
Mr->xadj[i+1]=Mr_counter;
}
free(hashtable);
printf("Projected %d flow values\n",Mr->nnz);
printf("avg nnz per column:%d\n",(Mr_counter/Mr->nvtxs));
return Mr;
}
SEXP icav_Matrix_sort(SEXP _M,SEXP Param)
{
// sorts a cloned version
//copies values in (Col_index and Row_index) of _M to a new matrix mimat. size of mimat < size of _M
// param[0] rows of _M
// param[1] cols of _M
// param[2] chunk size
SEXP mimat;
int i,j,_COL;
int MAX_T,Tnum;
int one = 1;
double *M,*mm;
int *param;
PROTECT(_M = coerceVector(_M, REALSXP));
PROTECT(Param = coerceVector(Param, INTSXP));
M = REAL(_M);
param = INTEGER(Param);
PROTECT(mimat = allocMatrix(REALSXP,param[0],param[1]));
mm=REAL(mimat);
MAX_T = omp_get_max_threads();
//we order the cols
for(i=0; i<param[1]; i++) {
_COL = i*param[0];
for(j=0; j<param[0]; j++) {
mm[j+_COL]=M[j+_COL];
}
}
for(i=0; i<param[1]; i++) {
_COL = i*param[0];
qsort (&mm[_COL], param[0], sizeof(double), icav_compare_doubles);
}
UNPROTECT(3);
return(mimat);
}
void get_mean(gsl_matrix* m, gsl_vector* mean) {
// initialise R matrix
SEXP mr;
PROTECT(mr = allocMatrix(REALSXP, m->size1, m->size2));
for (unsigned int i = 0; i < m->size1; i++) {
for (unsigned int j = 0; j < m->size2; j++) {
REAL(mr)[i+(m->size1)*j] = gsl_matrix_get(m, i, j);
}
}
// calculate mean
SEXP meanr;
//printf("Centroid: \n");
PROTECT(meanr = R_exec("colMeans",mr));
for (unsigned int i = 0; i < mean->size; i++) {
gsl_vector_set(mean, i, REAL(meanr)[i]); //printf("%f ", REAL(meanr)[i]);
} ;
//printf("\n");
fflush(stdout);
UNPROTECT(2);
}
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 compressed_non_0_ij(SEXP x, SEXP colP)
{
int col = asLogical(colP); /* 1 if "C"olumn compressed; 0 if "R"ow */
SEXP ans, indSym = col ? Matrix_iSym : Matrix_jSym;
SEXP indP = GET_SLOT(x, indSym),
pP = GET_SLOT(x, Matrix_pSym);
int n_el = length(indP), i, *ij;
ij = INTEGER(ans = PROTECT(allocMatrix(INTSXP, n_el, 2)));
/* expand the compressed margin to 'i' or 'j' : */
expand_cmprPt(length(pP) - 1, INTEGER(pP), &ij[col ? n_el : 0]);
/* and copy the other one: */
if (col)
for(i = 0; i < n_el; i++)
ij[i] = INTEGER(indP)[i];
else /* row compressed */
for(i = 0; i < n_el; i++)
ij[i + n_el] = INTEGER(indP)[i];
UNPROTECT(1);
return ans;
}
/* method used below is linear least squares */
void get_weights(matrix *X, matrix *Y, matrix *B)
{
matrix * A;
char uplo;
int info;
A = initMatrix();
allocMatrix(A,X->cols,X->cols);
/* X'*X -> A */
multATA(X,A);
/* X'*Y -> B */
multATB(X,Y,B);
/* Solve Ax = B */
uplo = 'u';
dposv_(&uplo,&A->cols,&B->cols,A->data,&A->rows,B->data,&A->rows,&info);
if (info != 0)
printError(1,__FILE__,__LINE__,"dposv returned non-zero info");
freeMatrix(A);
}
USER_OBJECT_
RS_axesValueMatrix(displayd *display)
{
/* currently only works for Tour2D */
int n = display->t2d.nsubset, k, j;
vartabled *vt;
USER_OBJECT_ matrix;
PROTECT(matrix = allocMatrix(REALSXP, n, 4));
for (k = 0; k < n; k++) {
j = display->t2d.subset_vars.els[k];
vt = vartable_element_get (j, display->d);
REAL(matrix)[k] = display->t2d.F.vals[0][j]; /* x coeff */
REAL(matrix)[k+n] = display->t2d.F.vals[1][j]; /* y coeff */
REAL(matrix)[k+2*n] = vt->lim.max - vt->lim.min; /* range */
REAL(matrix)[k+3*n] = j+1; /* variable index */
}
UNPROTECT(1);
return(matrix);
}
SEXP r_do_integrate(SEXP extPtr, SEXP vars, SEXP lambda, SEXP mu,
SEXP drift, SEXP diffusion, SEXP nt, SEXP dt,
SEXP padding) {
quasse_fft *obj = (quasse_fft*)R_ExternalPtrAddr(extPtr);
SEXP ret;
int nkl = INTEGER(padding)[0], nkr = INTEGER(padding)[1];
int ndat = LENGTH(lambda);
double c_dt = REAL(dt)[0], c_nt = INTEGER(nt)[0];
double *c_lambda=REAL(lambda), *c_mu=REAL(mu);
double c_drift=REAL(drift)[0], c_diffusion=REAL(diffusion)[0];
int i, idx, nd;
if ( obj == NULL )
error("Corrupt QuaSSE integrator: ptr is NULL (are you using multicore?)");
nd = LENGTH(vars) / obj->nx;
idx = lookup(nd, obj->nd, obj->n_fft);
if ( idx < 0 )
error("Failed to find nd = %d\n", nd);
qf_copy_x(obj, REAL(vars), nd, 1);
obj->lambda = REAL(lambda);
obj->mu = REAL(mu);
for ( i = 0; i < ndat; i++ )
obj->z[i] = exp(c_dt * (c_lambda[i] - c_mu[i]));
qf_setup_kern(obj, c_drift, c_diffusion, c_dt, nkl, nkr);
do_integrate(obj, c_nt, idx);
obj->lambda = NULL;
obj->mu = NULL;
PROTECT(ret = allocMatrix(REALSXP, obj->nx, nd));
qf_copy_x(obj, REAL(ret), nd, 0);
UNPROTECT(1);
return ret;
}
SEXP lsq_dense_QR(SEXP X, SEXP y)
{
SEXP ans;
int info, n, p, k, *Xdims, *ydims, lwork;
double *work, tmp, *xvals;
if (!(isReal(X) & isMatrix(X)))
error(_("X must be a numeric (double precision) matrix"));
Xdims = INTEGER(coerceVector(getAttrib(X, R_DimSymbol), INTSXP));
n = Xdims[0];
p = Xdims[1];
if (!(isReal(y) & isMatrix(y)))
error(_("y must be a numeric (double precision) matrix"));
ydims = INTEGER(coerceVector(getAttrib(y, R_DimSymbol), INTSXP));
if (ydims[0] != n)
error(_(
"number of rows in y (%d) does not match number of rows in X (%d)"),
ydims[0], n);
k = ydims[1];
if (k < 1 || p < 1) return allocMatrix(REALSXP, p, k);
xvals = (double *) R_alloc(n * p, sizeof(double));
Memcpy(xvals, REAL(X), n * p);
ans = PROTECT(duplicate(y));
lwork = -1;
F77_CALL(dgels)("N", &n, &p, &k, xvals, &n, REAL(ans), &n,
&tmp, &lwork, &info);
if (info)
error(_("First call to Lapack routine dgels returned error code %d"),
info);
lwork = (int) tmp;
work = (double *) R_alloc(lwork, sizeof(double));
F77_CALL(dgels)("N", &n, &p, &k, xvals, &n, REAL(ans), &n,
work, &lwork, &info);
if (info)
error(_("Second call to Lapack routine dgels returned error code %d"),
info);
UNPROTECT(1);
return ans;
}
SEXP do_RGB2hsv(SEXP call, SEXP op, SEXP args, SEXP env)
{
/* (r,g,b) -> (h,s,v) conversion */
SEXP rgb, dd, ans, names, dmns;
int n, i, i3;
checkArity(op, args);
PROTECT(rgb = coerceVector(CAR(args),REALSXP)); args = CDR(args);
if(!isMatrix(rgb))
errorcall(call, _("rgb is not a matrix (internally)"));
dd = getAttrib(rgb, R_DimSymbol);
if(INTEGER(dd)[0] != 3)
errorcall(call, _("rgb must have 3 rows (internally)"));
n = INTEGER(dd)[1];
PROTECT(ans = allocMatrix(REALSXP, 3, n));
PROTECT(dmns = allocVector(VECSXP, 2));
/* row names: */
PROTECT(names = allocVector(STRSXP, 3));
SET_STRING_ELT(names, 0, mkChar("h"));
SET_STRING_ELT(names, 1, mkChar("s"));
SET_STRING_ELT(names, 2, mkChar("v"));
SET_VECTOR_ELT(dmns, 0, names);
/* column names if input has: */
if ((dd = getAttrib(rgb, R_DimNamesSymbol)) != R_NilValue &&
(names = VECTOR_ELT(dd, 1)) != R_NilValue)
SET_VECTOR_ELT(dmns, 1, names);
setAttrib(ans, R_DimNamesSymbol, dmns);
UNPROTECT(2);/* names, dmns */
for(i = i3 = 0; i < n; i++, i3 += 3) {
rgb2hsv(REAL(rgb)[i3+ 0], REAL(rgb)[i3+ 1], REAL(rgb)[i3+ 2],
&REAL(ans)[i3+ 0], &REAL(ans)[i3+ 1], &REAL(ans)[i3 +2]);
}
UNPROTECT(2);
return ans;
}
static SEXP _scan_bin_offsets_seq(Rbyte **b) {
int32_t nbin = *(int32_t *)(*b); *b += 4;
Rbyte *tmp_bytes = *b;
int nchunks = 0;
for (int i = 0; i < nbin; i++) {
nchunks += _scan_bin_chunk_count(&tmp_bytes);
}
// need real values, because 32 bits is generally not enough
SEXP ans;
PROTECT(ans = allocMatrix(REALSXP, 5, nchunks));
double *m = REAL(ans);
for (int i = 0; i < nbin; i++) {
_scan_bin_offsets(b, &m);
}
// skip past the interval index
*b += 4 + *(int32_t *)(*b) * 8;
UNPROTECT(1);
return ans;
}
SEXP distances_sampling(SEXP dist_id_var, SEXP n_var, SEXP m_var, SEXP theta_var){
GetRNGstate();
int m = INTEGER_VALUE(m_var);
int n = INTEGER_VALUE(n_var);
int dist_id = INTEGER_VALUE(dist_id_var);
double theta = NUMERIC_VALUE(theta_var);
int **sample= new int*[m];
SEXP Rval;
Generic gen;
Exponential_model * exp_mod = gen.new_instance(dist_id, n);
exp_mod->distances_sampling(m,theta,sample);
PROTECT(Rval = allocMatrix(REALSXP, m, n));
for (int i = 0; i < m; i++)
for (int j = 0; j < n; j++)
REAL(Rval)[i + m * j] = sample[i][j];
UNPROTECT(1);
for (int i = 0 ; i < m ; i ++ ) delete [] sample[ i ];
delete [] sample;
delete exp_mod;
PutRNGstate();
return Rval;
}
SEXP Rmultinom(SEXP args)
{
SEXP prob, ans, nms;
int n, size, k, i, ik;
args = CDR(args);
n = asInteger(CAR(args)); args = CDR(args);/* n= #{samples} */
size = asInteger(CAR(args)); args = CDR(args);/* X ~ Multi(size, prob) */
if (n == NA_INTEGER || n < 0)
error(_("invalid first argument 'n'"));
if (size == NA_INTEGER || size < 0)
error(_("invalid second argument 'size'"));
prob = CAR(args);
prob = coerceVector(prob, REALSXP);
k = length(prob);/* k = #{components or classes} = X-vector length */
if (MAYBE_REFERENCED(prob)) prob = duplicate(prob);/*as `do_sample' -- need this line? */
PROTECT(prob);
/* check and make sum = 1: */
FixupProb(REAL(prob), k, /*require_k = */ 0, TRUE);
GetRNGstate();
PROTECT(ans = allocMatrix(INTSXP, k, n));/* k x n : natural for columnwise store */
for(i=ik = 0; i < n; i++, ik += k) {
// if ((i+1) % NINTERRUPT) R_CheckUserInterrupt();
rmultinom(size, REAL(prob), k, &INTEGER(ans)[ik]);
}
PutRNGstate();
if(!isNull(nms = getAttrib(prob, R_NamesSymbol))) {
SEXP dimnms;
PROTECT(nms);
PROTECT(dimnms = allocVector(VECSXP, 2));
SET_VECTOR_ELT(dimnms, 0, nms);
setAttrib(ans, R_DimNamesSymbol, dimnms);
UNPROTECT(2);
}
UNPROTECT(2);
return ans;
}
SEXP ancestors(SEXP nod, SEXP anc, SEXP des) {
int numEdges = length(anc);
int numNodes = length(nod);
int* nodes = INTEGER(nod);
int* ancestor = INTEGER(anc);
int* descendant = INTEGER(des);
int parent = 0;
SEXP isAncestor;
PROTECT(isAncestor = allocMatrix(INTSXP, numEdges, numNodes));
for (int n=0; n<numNodes; n++) {
for (int i=0; i<numEdges; i++) {
if (nodes[n]==descendant[i]) {
INTEGER(isAncestor)[i + n*numEdges] = 1;
} else {
INTEGER(isAncestor)[i + n*numEdges] = 0;
}
}
}
for (int n=0; n<numNodes; n++) {
for (int i=0; i<numEdges; i++) {
if (INTEGER(isAncestor)[i + n*numEdges]==1) {
parent = ancestor[i];
for (int j=i+1; j<numEdges; j++) {
if (descendant[j]==parent) {
INTEGER(isAncestor)[j + n*numEdges]=1;
}
}
}
}
}
UNPROTECT(1);
return isAncestor;
}
/* faster rbind() implementation for arc sets. */
SEXP arcs_rbind (SEXP matrix1, SEXP matrix2, SEXP reverse2) {
int i = 0, j = 0, m1 = length(matrix1)/2, m2 = length(matrix2)/2;
SEXP res;
/* allocate the return value. */
PROTECT(res = allocMatrix(STRSXP, m1 + m2, 2));
/* allocate and initialize the column names. */
finalize_arcs(res);
/* copy the elements of the first matrix. */
for (i = 0; i < m1; i++)
for (j = 0; j < 2; j++)
SET_STRING_ELT(res, CMC(i, j, m1 + m2), STRING_ELT(matrix1, CMC(i, j, m1)));
/* copy the elements of the second matrix, reversing the order of the
* columns as needed. */
if (isTRUE(reverse2)) {
for (i = 0; i < m2; i++)
for(j = 0; j < 2; j++)
SET_STRING_ELT(res, CMC(i + m1, j, m1 + m2), STRING_ELT(matrix2, CMC(i, 1 - j, m2)));
}/*THEN*/
else {
for (i = 0; i < m2; i++)
for(j = 0; j < 2; j++)
SET_STRING_ELT(res, CMC(i + m1, j, m1 + m2), STRING_ELT(matrix2, CMC(i, j, m2)));
}/*ELSE*/
UNPROTECT(1);
return res;
}/*ARCS_RBIND*/
SEXP R_colwiseProd(SEXP V, SEXP X)
{
int *xdims, nrx, ncx, ii, jj, kk, len_V;
double *xptr, *vptr;
xdims = getDims(X);
nrx = xdims[0];
ncx = xdims[1];
len_V = length(V);
PROTECT(X = coerceVector(X, REALSXP));
xptr = REAL(X);
PROTECT(V = coerceVector(V, REALSXP));
vptr = REAL(V);
double *ansptr;
SEXP ans;
PROTECT(ans = allocMatrix(REALSXP, nrx, ncx));
ansptr = REAL(ans);
kk = 0;
for (jj = 0; jj < ncx; jj++){
//Rprintf("kk=%i len_V=%i\n", kk, len_V);
for (ii=0; ii<nrx; ii++){
ansptr[ii + nrx * jj] = vptr[kk] * xptr[ii + nrx * jj];
}
kk++;
if (kk == len_V){
//Rprintf("HERE: kk=%i len_V=%i\n", kk, len_V);
kk=0;
}
}
UNPROTECT(3);
return(ans);
}
int main(int argc, char *argv[]) {
int i, j;
if (argc != 3) {
fprintf(stderr, "Usage: %s N_matrix_size M_iters\n", argv[0]);
exit(1);
}
int N = atoi(argv[1]);
int M = atoi(argv[2]);
float *matA, *matArev;
genRandMatrix(&matA, N);
// printf("Matrix A: \n");
// printMatrix(matA, N);
allocMatrix(&matArev, N, true);
matrixReverse(matA, matArev, N, M);
// printf("Reverse A: \n");
// printMatrix(matArev, N);
freeMatrix(matA, N);
freeMatrix(matArev, N);
return 0;
}
//sam <- .Call("sampling_multi_gibbs_cayley",dist_id, permu.length, num.permus, theta, 0, algorithm_id)
SEXP sampling_multi_gibbs_cayley(SEXP dist_id_var,SEXP n_var, SEXP m_var,
SEXP theta_var, SEXP model_var,SEXP method_var){
GetRNGstate();
//method_var == 1 multistage
//method_var == 2 gibbs
int m = INTEGER_VALUE(m_var);
int n = INTEGER_VALUE(n_var);
int model = INTEGER_VALUE(model_var);//GMM MM
int method ;
method = INTEGER_VALUE(method_var);//gibbs...
int dist_id = INTEGER_VALUE(dist_id_var);
PROTECT(theta_var = AS_NUMERIC(theta_var));
double*theta=NUMERIC_POINTER(theta_var);
UNPROTECT(1);
//return(R_NilValue);
int**sample=new int*[m];
SEXP Rval;
Generic gen;
Exponential_model * exp_mod = gen.new_instance(dist_id, n);
if(method == 1)
exp_mod->multistage_sampling(m,theta, sample);
else
exp_mod->gibbs_sampling(m, theta, model,sample);
PROTECT(Rval = allocMatrix(REALSXP, m, n));
for (int i = 0; i < m; i++)
for (int j = 0; j < n; j++)
REAL(Rval)[i + m * j] = sample[i][j];
UNPROTECT(1);
for (int i = 0 ; i < m ; i ++ ) delete [] sample[ i ];
delete [] sample;
delete exp_mod;
PutRNGstate();
return Rval;
}
static SEXP alloc_imat(const struct recv_fit *fit)
{
const struct recv_loglik *ll = recv_fit_loglik(fit);
const struct recv_model *m = recv_loglik_model(ll);
size_t dim = recv_model_dim(m);
const double *imatp;
SEXP imat = allocMatrix(REALSXP, dim, dim);
double *ximat = NUMERIC_POINTER(imat);
enum blas_uplo uplo, f77uplo;
size_t i, j;
recv_fit_get_imat(fit, &imatp, &uplo);
f77uplo = (uplo == BLAS_UPPER) ? BLAS_LOWER : BLAS_UPPER;
memset(ximat, 0, dim * dim * sizeof(double));
if (dim > 0) {
packed_dsctr(f77uplo, dim, imatp, ximat, dim);
}
if (uplo == BLAS_UPPER) {
for (j = 0; j < dim; j++) {
for (i = 0; i < j; i++) {
ximat[i + j * dim] = ximat[j + i * dim];
}
}
} else {
for (j = 0; j < dim; j++) {
for (i = j + 1; i < dim; i++) {
ximat[i + j * dim] = ximat[j + i * dim];
}
}
}
return imat;
}
/* second version */
SEXP out(SEXP x, SEXP y)
{
R_len_t i, j, nx = length(x), ny = length(y);
double tmp, *rx = REAL(x), *ry = REAL(y), *rans;
SEXP ans, dim, dimnames;
PROTECT(ans = allocMatrix(REALSXP, nx, ny));
rans = REAL(ans);
for(i = 0; i < nx; i++) {
tmp = rx[i];
for(j = 0; j < ny; j++)
rans[i + nx*j] = tmp * ry[j];
}
PROTECT(dim = allocVector(INTSXP, 2));
INTEGER(dim)[0] = nx; INTEGER(dim)[1] = ny;
setAttrib(ans, R_DimSymbol, dim);
PROTECT(dimnames = allocVector(VECSXP, 2));
SET_VECTOR_ELT(dimnames, 0, getAttrib(x, R_NamesSymbol));
SET_VECTOR_ELT(dimnames, 1, getAttrib(y, R_NamesSymbol));
setAttrib(ans, R_DimNamesSymbol, dimnames);
UNPROTECT(3);
return(ans);
}
/* convert an edge list to an arc set. */
SEXP elist2arcs(SEXP elist) {
int i = 0, j = 0, k = 0, n = length(elist), narcs = 0;
SEXP from, adjacent, nodes, arcs;
/* count how many arcs are present in the graph. */
for (i = 0; i < n; i++)
narcs += length(VECTOR_ELT(elist, i));
/* allocate and initialize the return value. */
PROTECT(arcs = allocMatrix(STRSXP, narcs, 2));
nodes = getAttrib(elist, R_NamesSymbol);
for (i = 0; i < n; i++) {
/* cache the parent node and the vector of its adjacent. */
from = STRING_ELT(nodes, i);
adjacent = VECTOR_ELT(elist, i);
/* fill the return value. */
for (j = 0; j < length(adjacent); j++) {
SET_STRING_ELT(arcs, k, from);
SET_STRING_ELT(arcs, k + narcs, STRING_ELT(adjacent, j));
k++;
}/*FOR*/
}/*FOR*/
UNPROTECT(1);
return arcs;
}/*ELIST2ARCS*/
// this actually undoes the permutation
Matrix* permuteRowsAndColumns(Matrix* M, idxtype* perm)
{
Matrix *ret = allocMatrix(M->nvtxs, M->nnz, 0, 0, 0);
int i;
idxtype* revPerm = idxmalloc(M->nvtxs,
"permuteRowsAndColumns:revPerm");
for ( i=0; i<M->nvtxs; i++ )
{
revPerm[perm[i]] = i;
}
ret->xadj[0]=0;
for ( i=0; i<M->nvtxs; i++ )
{
int orgI = revPerm[i];
int j;
ret->xadj[i+1] = ret->xadj[i] + ( M->xadj[orgI+1] -
M->xadj[orgI] );
for ( j=ret->xadj[i]; j<ret->xadj[i+1]; j++ )
{
int orgJ = M->xadj[orgI] + j - ret->xadj[i];
ret->adjncy[j] = perm[M->adjncy[orgJ]];
ret->adjwgt[j] = M->adjwgt[orgJ];
}
ParallelQSort( ret->adjncy, ret->adjwgt, ret->xadj[i],
ret->xadj[i+1]-1 );
}
ret->nnz = M->nnz;
free ( revPerm );
return ret;
}
SEXP numeric_deriv(SEXP args)
{
SEXP theta, expr, rho, ans, ans1, gradient, par, dimnames;
double tt, xx, delta, eps = sqrt(DOUBLE_EPS);
int start, i, j;
expr = CADR(args);
if(!isString(theta = CADDR(args)))
error("theta should be of type character");
if(!isEnvironment(rho = CADDDR(args)))
error("rho should be an environment");
PROTECT(ans = coerceVector(eval(expr, rho), REALSXP));
PROTECT(gradient = allocMatrix(REALSXP, LENGTH(ans), LENGTH(theta)));
for(i = 0, start = 0; i < LENGTH(theta); i++, start += LENGTH(ans)) {
PROTECT(par = findVar(install(CHAR(STRING_ELT(theta, i))), rho));
tt = REAL(par)[0];
xx = fabs(tt);
delta = (xx < 1) ? eps : xx*eps;
REAL(par)[0] += delta;
PROTECT(ans1 = coerceVector(eval(expr, rho), REALSXP));
for(j = 0; j < LENGTH(ans); j++)
REAL(gradient)[j + start] =
(REAL(ans1)[j] - REAL(ans)[j])/delta;
REAL(par)[0] = tt;
UNPROTECT(2); /* par, ans1 */
}
PROTECT(dimnames = allocVector(VECSXP, 2));
SET_VECTOR_ELT(dimnames, 1, theta);
dimnamesgets(gradient, dimnames);
setAttrib(ans, install("gradient"), gradient);
UNPROTECT(3); /* ans gradient dimnames */
return ans;
}
SEXP Dgemm(
SEXP ENV, SEXP A, SEXP B, SEXP C, SEXP ALPHA, SEXP BETA, SEXP TRANSA, SEXP TRANSB)
{
cl_env *env = get_env(ENV);
int allocated = 0;
MATRIXCHECK(A, REALSXP);
MATRIXCHECK(B, REALSXP);
SCALARCHECK(ALPHA, REALSXP);
SCALARCHECK(BETA, REALSXP);
clblasTranspose transA = getTrans(TRANSA);
clblasTranspose transB = getTrans(TRANSB);
double alpha = SCALARREAL(ALPHA), beta = SCALARREAL(BETA);
int ar = nrows(A), ac = ncols(A), br = nrows(B), bc = ncols(B), cr, cc;
if (isNull(C) || LENGTH(C) == 0)
{
cr = transA == clblasNoTrans ? ar : ac;
cc = transB == clblasNoTrans ? bc : br;
C = PROTECT(allocMatrix(REALSXP, cr, cc));
beta = 0;
allocated = 1;
} else {
MATRIXCHECK(C, REALSXP);
cr = nrows(C), cc = ncols(C);
}
int size_a = LENGTH(A) * sizeof(double);
int size_b = LENGTH(B) * sizeof(double);
int size_c = LENGTH(C) * sizeof(double);
double *ap = REAL(A), *bp = REAL(B), *cp = REAL(C);
cl_int err = Dgemm_internal(
env, ap, bp, cp, alpha, beta, transA, transB, ar, ac, br, bc, cr, cc, size_a, size_b, size_c);
CHECK(err);
UNPROTECT(allocated);
return C;
}
