SEXP R_blacs_init(SEXP NPROW_in, SEXP NPCOL_in, SEXP ICTXT_in)
{
R_INIT;
SEXP NPROW, NPCOL, ICTXT, MYROW, MYCOL, RET, RET_NAMES;
newRvec(NPROW, 1, "int");
newRvec(NPCOL, 1, "int");
newRvec(ICTXT, 1, "int");
newRvec(MYROW, 1, "int");
newRvec(MYCOL, 1, "int");
INT(NPROW) = INT(NPROW_in);
INT(NPCOL) = INT(NPCOL_in);
INT(ICTXT) = INT(ICTXT_in);
char order = 'R';
/* sl_init_(INTP(ICTXT), INTP(NPROW), INTP(NPCOL));*/
Cblacs_get(INT(ICTXT_in), 0, INTP(ICTXT));
Cblacs_gridinit(INTP(ICTXT), &order, INT(NPROW), INT(NPCOL));
Cblacs_gridinfo(INT(ICTXT), INTP(NPROW), INTP(NPCOL), INTP(MYROW), INTP(MYCOL));
RET_NAMES = make_list_names(5, "NPROW", "NPCOL", "ICTXT", "MYROW", "MYCOL");
RET = make_list(RET_NAMES, 5, NPROW, NPCOL, ICTXT, MYROW, MYCOL);
R_END;
return(RET);
}
SEXP R_p_matexp_pade(SEXP A, SEXP desca, SEXP p)
{
R_INIT;
int m, n;
SEXP N, D;
SEXP RET, RET_NAMES;
m = nrows(A);
n = ncols(A);
// Allocate N and D
newRmat(N, m, n, "dbl");
newRmat(D, m, n, "dbl");
// Compute N and D
p_matexp_pade(DBLP(A), INTP(desca), INT(p, 0), DBLP(N), DBLP(D));
// Wrangle the return
RET_NAMES = make_list_names(2, "N", "D");
RET = make_list(RET_NAMES, 2, N, D);
R_END;
return RET;
}
/* LU factorization */
SEXP R_PDGETRF(SEXP M, SEXP N, SEXP A, SEXP CLDIM, SEXP DESCA, SEXP LIPIV)
{
R_INIT;
int *ipiv;
int IJ = 1;
SEXP RET, RET_NAMES, INFO, C;
newRvec(INFO, 1, "int");
newRmat(C, INT(CLDIM, 0), INT(CLDIM, 1), "dbl");
// A = LU
memcpy(DBLP(C), DBLP(A), nrows(A)*ncols(A)*sizeof(double));
INT(INFO, 0) = 0;
INT(LIPIV) = nonzero(INT(LIPIV));
ipiv = (int*) R_alloc(INT(LIPIV), sizeof(int));
pdgetrf_(INTP(M), INTP(N), DBLP(C), &IJ, &IJ, INTP(DESCA), ipiv, INTP(INFO));
// Manage return
RET_NAMES = make_list_names(2, "info", "A");
RET = make_list(RET_NAMES, 2, INFO, C);
R_END;
return RET;
}
SEXP R_blacs_gridinit(SEXP NPROW_in, SEXP NPCOL_in, SEXP SHANDLE)
{
R_INIT;
SEXP NPROW, NPCOL, MYROW, MYCOL, RET, RET_NAMES, ICTXT;
newRvec(NPROW, 1, "int");
newRvec(NPCOL, 1, "int");
newRvec(MYROW, 1, "int");
newRvec(MYCOL, 1, "int");
newRvec(ICTXT, 1, "int");
INT(NPROW) = INT(NPROW_in);
INT(NPCOL) = INT(NPCOL_in);
INT(ICTXT) = INT(SHANDLE);
char order = 'R';
Cblacs_gridinit(INTP(ICTXT), &order, INT(NPROW), INT(NPCOL));
Cblacs_gridinfo(INT(ICTXT), INTP(NPROW), INTP(NPCOL), INTP(MYROW), INTP(MYCOL));
make_list_names(RET_NAMES, 5, "NPROW", "NPCOL", "ICTXT", "MYROW", "MYCOL");
make_list(RET, RET_NAMES, 5, NPROW, NPCOL, ICTXT, MYROW, MYCOL);
R_END;
return(RET);
}
SEXP makedf_xlpep(struct iobtd *iop){
SEXP df, df_names, idvec, protidvec, pepflagvec, pepmassvec, pepsitevec;
yamldom_node_t *xlseq, *tmp, *seq, *prottmp, *peptmp;
int i, count;
int id;
const int ncols=5;
if(!(xlseq=yamldom_find_map_val(iop->root,"xlink"))){
goto err;
}
count = 0;
for(seq=YAMLDOM_SEQ_NODES(xlseq);seq;seq=seq->next)
count += count_seq_elem(yamldom_find_map_val(seq,"peps"));
hidefromGC(idvec = allocVector(INTSXP,count));
hidefromGC(protidvec = allocVector(INTSXP,count));
hidefromGC(pepflagvec = allocVector(INTSXP,count));
hidefromGC(pepmassvec = allocVector(REALSXP,count));
hidefromGC(pepsitevec = allocVector(INTSXP,count));
i=0;
for(seq=YAMLDOM_SEQ_NODES(xlseq);seq;seq=seq->next){
if(!(peptmp=yamldom_find_map_val(seq,"peps")))
goto err;
peptmp = YAMLDOM_SEQ_NODES(peptmp);
push_elem(&id,0,seq,"id",strtoint);
while(peptmp){
INTEGER(idvec)[i] = id;
/* prot id/rank (via prot) */
if(!(prottmp=yamldom_find_map_val(peptmp,"prot")))
goto err;
tmp = YAMLDOM_DEREF(prottmp);
push_elem(INTEGER(protidvec),i,tmp,"id",strtoint);
push_elem(INTEGER(pepflagvec),i,peptmp,"flags",strtoint);
push_elem(REAL(pepmassvec),i,peptmp,"mass",strtodouble);
push_elem(INTEGER(pepsitevec),i,peptmp,"linksite",strtoint);
i++;
peptmp = peptmp->next;
}
}
make_list_names(df_names, ncols, "xlid", "protid", "pep.flag", "pep.mass", "pep.xlsite");
make_dataframe(df, RNULL, df_names, ncols, idvec, protidvec, pepflagvec, pepmassvec, pepsitevec);
unhideGC();
return df;
err:
unhideGC();
return RNULL;
}
SEXP R_convert_dense_to_csr(SEXP x)
{
R_INIT;
SEXP data, row_ptr, col_ind;
SEXP R_list, R_list_names;
const int m = nrows(x), n = ncols(x);
int i, j;
int row_ptr_len;
int sparsity, density;
int ct = 0, rct = 0, first;
sparsity = sparse_count_zeros_withrows(m, n, &row_ptr_len, REAL(x));
density = m*n - sparsity;
newRvec(data, density, "dbl");
newRvec(col_ind, density, "int");
newRvec(row_ptr, m+1, "int");
for (i=0; i<m; i++)
{
first = true;
for (j=0; j<n; j++)
{
if (MatDBL(x, i, j) > 0.0)
{
DBL(data, ct) = MatDBL(x, i, j);
INT(col_ind, ct) = j+1;
ct++;
if (first == true)
{
INT(row_ptr, rct) = ct;
first = false;
rct++;
}
}
}
if (first == true)
{
INT(row_ptr, rct) = ct+1;
rct++;
}
}
INT(row_ptr, m) = ct+1;
R_list_names = make_list_names(3, "Data", "row_ptr", "col_ind");
R_list = make_list(R_list_names, 3, data, row_ptr, col_ind);
R_END;
return R_list;
}
/* SVD */
SEXP R_PDGESVD(SEXP M, SEXP N, SEXP ASIZE, SEXP A, SEXP DESCA,
SEXP ULDIM, SEXP DESCU, SEXP VTLDIM, SEXP DESCVT, SEXP JOBU, SEXP JOBVT,
SEXP INPLACE)
{
R_INIT;
double *A_OUT;
int IJ = 1, temp_lwork = -1;
double temp_A = 0, temp_work = 0, *WORK;
SEXP RET, RET_NAMES, INFO, D, U, VT;
newRvec(INFO, 1, "int");
newRvec(D, INT(ASIZE, 0), "dbl");
newRmat(U, INT(ULDIM, 0), INT(ULDIM, 1), "dbl");
newRmat(VT, INT(VTLDIM, 0), INT(VTLDIM, 1), "dbl");
// Query size of workspace
INT(INFO, 0) = 0;
pdgesvd_(STR(JOBU, 0), STR(JOBVT, 0),
INTP(M), INTP(N),
&temp_A, &IJ, &IJ, INTP(DESCA),
&temp_A, &temp_A, &IJ, &IJ, INTP(DESCU),
&temp_A, &IJ, &IJ, INTP(DESCVT),
&temp_work, &temp_lwork, INTP(INFO));
// Allocate work vector and calculate svd
temp_lwork = (int) temp_work;
temp_lwork = nonzero(temp_lwork);
WORK = (double *) R_alloc(temp_lwork, sizeof(double));
A_OUT = (double *) R_alloc(nrows(A)*ncols(A), sizeof(double));
memcpy(A_OUT, REAL(A), nrows(A)*ncols(A)*sizeof(double));
pdgesvd_(STR(JOBU, 0), STR(JOBVT, 0),
INTP(M), INTP(N),
A_OUT, &IJ, &IJ, INTP(DESCA),
REAL(D), REAL(U), &IJ, &IJ, INTP(DESCU),
REAL(VT), &IJ, &IJ, INTP(DESCVT),
WORK, &temp_lwork, INTP(INFO));
// Manage return
RET_NAMES = make_list_names(4, "info", "d", "u", "vt");
RET = make_list(RET_NAMES, 4, INFO, D, U, VT);
R_END;
return RET;
}
SEXP R_optimal_grid(SEXP NPROCS)
{
R_INIT;
SEXP NPROW, NPCOL, RET, RET_NAMES;
newRvec(NPROW, 1, "int", TRUE);
newRvec(NPCOL, 1, "int", TRUE);
optimalgrid_(INTP(NPROCS), INTP(NPROW), INTP(NPCOL));
RET_NAMES = make_list_names(2, "nprow", "npcol");
RET = make_list(RET_NAMES, 2, NPROW, NPCOL);
R_END;
return RET;
}
/* Matrix inverse */
SEXP R_PDGETRI(SEXP A, SEXP DESCA)
{
R_INIT;
int IJ = 1;
SEXP RET, RET_NAMES, INFO, INV;
newRvec(INFO, 1, "int");
newRmat(INV, nrows(A), ncols(A), "dbl");
// Compute inverse
pdinv_(DBLP(A), &IJ, &IJ, INTP(DESCA), DBLP(INV), INTP(INFO));
// Manage return
RET_NAMES = make_list_names(2, "info", "A");
RET = make_list(RET_NAMES, 2, INFO, INV);
R_END;
return RET;
}
/* Solving systems of linear equations */
SEXP R_PDGESV(SEXP N, SEXP NRHS, SEXP MXLDIMS, SEXP A, SEXP DESCA, SEXP B, SEXP DESCB)
{
R_INIT;
int IJ = 1;
int * ipiv;
double *A_cp;
SEXP RET, RET_NAMES, INFO, B_OUT;
newRvec(INFO, 1, "int");
newRmat(B_OUT, nrows(B), ncols(B), "dbl");
// Copy A and B since pdgesv writes in place
A_cp = (double *) R_alloc(nrows(A)*ncols(A), sizeof(double));
//FIXME check returns...
memcpy(A_cp, DBLP(A), nrows(A)*ncols(A)*sizeof(double));
memcpy(DBLP(B_OUT), DBLP(B), nrows(B)*ncols(B)*sizeof(double));
// Call pdgesv
ipiv = (int *) R_alloc(INT(MXLDIMS, 0) + INT(DESCA, 5), sizeof(int));
/* ipiv = (int *) R_alloc(nrows(B) + INT(DESCA, 5), sizeof(int));*/
INT(INFO, 0) = 0;
pdgesv_(INTP(N), INTP(NRHS),
A_cp, &IJ, &IJ, INTP(DESCA), ipiv,
DBLP(B_OUT), &IJ, &IJ, INTP(DESCB), INTP(INFO));
// Manage return
RET_NAMES = make_list_names(2, "info", "B");
RET = make_list(RET_NAMES, 2, INFO, B_OUT);
R_END;
return RET;
}
/* Cholesky */
SEXP R_PDPOTRF(SEXP N, SEXP A, SEXP DESCA, SEXP UPLO)
{
R_INIT;
int IJ = 1;
SEXP RET, RET_NAMES, INFO, C;
newRvec(INFO, 1, "int");
newRmat(C, nrows(A), ncols(A), "dbl");
// Compute chol
memcpy(DBLP(C), DBLP(A), nrows(A)*ncols(A)*sizeof(double));
INT(INFO, 0) = 0;
pdpotrf_(STR(UPLO, 0), INTP(N), DBLP(C), &IJ, &IJ, INTP(DESCA), INTP(INFO));
// Manage return
RET_NAMES = make_list_names(2, "info", "A");
RET = make_list(RET_NAMES, 2, INFO, C);
R_END;
return(RET);
}
SEXP makedf_scan(struct iobtd *iop){
SEXP df, df_names, plidvec, paridvec, sidvec, mzvec, zvec, intvec, rtvec;
yamldom_node_t *peakseq, *scanseq, *tmp, *seq, *scan;
int i, count;
int parid, id;
const int ncols=7;
if(!(scanseq=yamldom_find_map_val(iop->root,"scan"))){
goto err;
}
if(!(peakseq=yamldom_find_map_val(iop->root,"peaks"))){
goto err;
}
count=0;
for(seq=YAMLDOM_SEQ_NODES(peakseq);seq;seq=seq->next){
if(!(tmp=yamldom_find_map_val(seq,"scans")))
goto err;
count += count_seq_elem(tmp);
}
hidefromGC(sidvec = allocVector(INTSXP,count));
hidefromGC(plidvec = allocVector(INTSXP,count));
hidefromGC(paridvec = allocVector(INTSXP,count));
hidefromGC(mzvec = allocVector(REALSXP,count));
hidefromGC(zvec = allocVector(INTSXP,count));
hidefromGC(rtvec = allocVector(REALSXP,count));
hidefromGC(intvec = allocVector(REALSXP,count));
i=0;
for(seq=YAMLDOM_SEQ_NODES(peakseq);seq;seq=seq->next){
if(!(tmp=yamldom_find_map_val(seq,"id")))
goto err;
id=strtol(((yamldom_scalar_t*)tmp->data)->val,NULL,10);
if(!(tmp=yamldom_find_map_val(seq,"param")))
goto err;
tmp = YAMLDOM_DEREF(tmp);
if(!(tmp=yamldom_find_map_val(tmp,"id")))
goto err;
parid = strtol(((yamldom_scalar_t*)tmp->data)->val,NULL,10);
if(!(scanseq=yamldom_find_map_val(seq,"scans")))
goto err;
for(tmp=YAMLDOM_SEQ_NODES(scanseq);tmp;tmp=tmp->next){
scan=YAMLDOM_DEREF(tmp);
INTEGER(plidvec)[i]=id;
INTEGER(paridvec)[i]=parid;
push_elem(INTEGER(sidvec),i,scan,"id",strtoint);
push_elem(INTEGER(zvec),i,scan,"z",strtoint);
push_elem(REAL(mzvec),i,scan,"mz",strtodouble);
push_elem(REAL(intvec),i,scan,"preint",strtodouble);
push_elem(REAL(rtvec),i,scan,"rt",strtodouble);
if(REAL(rtvec)[i]<0.)
REAL(rtvec)[i]=0.;
i++;
}
}
make_list_names(df_names, ncols, "plid", "parid", "scanid", "mz", "z", "rt", "pre.int");
make_dataframe(df, RNULL, df_names, ncols, plidvec, paridvec, sidvec, mzvec, zvec, rtvec, intvec);
unhideGC();
return df;
err:
unhideGC();
return RNULL;
}
SEXP makedf_xlink(struct iobtd *iop){
SEXP df, df_names, idvec, peakidvec, errvec, covvec, modsv;
yamldom_node_t *xlseq, *tmp, *seq, *prottmp, *peptmp;
int i, count, modstrlen;
const int ncols=5;
char *mods;
if(!(xlseq=yamldom_find_map_val(iop->root,"xlink"))){
goto err;
}
count = count_seq_elem(xlseq);
hidefromGC(idvec = allocVector(INTSXP,count));
hidefromGC(peakidvec = allocVector(INTSXP,count));
hidefromGC(errvec = allocVector(REALSXP,count));
hidefromGC(covvec = allocVector(REALSXP,count));
hidefromGC(modsv = allocVector(STRSXP,count));
i=0;
for(seq=YAMLDOM_SEQ_NODES(xlseq);seq;seq=seq->next){
if(!(peptmp=yamldom_find_map_val(seq,"peps")))
goto err;
peptmp = YAMLDOM_SEQ_NODES(peptmp);
push_elem(INTEGER(idvec),i,seq,"id",strtoint);
push_elem(REAL(errvec),i,seq,"error",strtodouble);
push_elem(REAL(covvec),i,seq,"fragcov",strtodouble);
/* peaklist id (via prot -> param) */
if(!(prottmp=yamldom_find_map_val(peptmp,"prot")))
goto err;
tmp = YAMLDOM_DEREF(prottmp);
if(!(tmp=yamldom_find_map_val(tmp,"peaks")))
goto err;
tmp = YAMLDOM_DEREF(tmp);
push_elem(INTEGER(peakidvec),i,tmp,"id",strtoint);
if(!(tmp=yamldom_find_map_val(tmp,"param")))
goto err;
tmp = YAMLDOM_DEREF(tmp);
modstrlen = getmodstrlen(yamldom_find_map_val(tmp,"vmod"));
if(!(mods=malloc(modstrlen)))
goto err;
modstr(yamldom_find_map_val(seq,"mods"),mods);
if(mods && *mods)
SET_STRING_ELT(modsv, i, mkChar(mods));
else
SET_STRING_ELT(modsv, i, mkChar(""));
free(mods);
i++;
}
make_list_names(df_names, ncols, "xlid", "peakid", "error", "frag.cov", "mods");
make_dataframe(df, RNULL, df_names, ncols, idvec, peakidvec, errvec, covvec, modsv);
unhideGC();
return df;
err:
unhideGC();
return RNULL;
}
// The beast
SEXP R_PDSYEVX(SEXP JOBZ, SEXP RANGE, SEXP N, SEXP A, SEXP DESCA, SEXP VL, SEXP VU, SEXP IL, SEXP IU, SEXP ABSTOL, SEXP ORFAC)
{
R_INIT;
char uplo = 'U';
int IJ = 1;
int i;
int m, nz;
int lwork, liwork, info;
int descz[9], ldm[2], blacs[5];
int tmp_liwork;
int *iwork, *ifail, *iclustr;
double tmp_lwork;
double *work;
double *w, *z, *gap;
double *a;
SEXP RET, RET_NAMES, W, Z, M;
// grid and local information
pdims_(INTEGER(DESCA), ldm, blacs);
ldm[0] = nrows(A);//nonzero(ldm[0]);
ldm[1] = ncols(A);//nonzero(ldm[1]);
// Setup for the setup
for (i=0; i<9; i++)
descz[i] = INT(DESCA, i);
w = (double*) R_alloc(INT(N), sizeof(double));
z = (double*) R_alloc(ldm[0]*ldm[1], sizeof(double));
gap = (double*) R_alloc(blacs[1]*blacs[2], sizeof(double));
a = (double*) R_alloc(ldm[0]*ldm[1], sizeof(double));
memcpy(a, DBLP(A), nrows(A)*ncols(A)*sizeof(double));
ifail = (int*) R_alloc(INT(N, 0), sizeof(int));
iclustr = (int*) R_alloc(2*blacs[1]*blacs[2], sizeof(int));
// Allocate local workspace
lwork = -1;
liwork = -1;
info = 0;
pdsyevx_(CHARPT(JOBZ, 0), CHARPT(RANGE, 0), &uplo,
INTP(N), a, &IJ, &IJ, INTP(DESCA),
DBLP(VL), DBLP(VU), INTP(IL), INTP(IU),
DBLP(ABSTOL), &m, &nz, w,
DBLP(ORFAC), z, &IJ, &IJ, descz,
&tmp_lwork, &lwork, &tmp_liwork, &liwork,
ifail, iclustr, gap, &info);
lwork = nonzero( ((int) tmp_lwork) );
work = (double*) R_alloc(lwork, sizeof(double));
liwork = nonzero(tmp_liwork);
iwork = (int*) R_alloc(liwork, sizeof(int));
// Compute eigenvalues
m = 0;
info = 0;
pdsyevx_(CHARPT(JOBZ, 0), CHARPT(RANGE, 0), &uplo,
INTP(N), a, &IJ, &IJ, INTP(DESCA),
DBLP(VL), DBLP(VU), INTP(IL), INTP(IU),
DBLP(ABSTOL), &m, &nz, w,
DBLP(ORFAC), z, &IJ, &IJ, descz,
work, &lwork, iwork, &liwork,
ifail, iclustr, gap, &info);
newRvec(W, m, "dbl");
for (i=0; i<m; i++)
DBL(W, i) = w[i];
/* SEXP IFAIL;*/
/* PROTECT(IFAIL = allocVector(INTSXP, m));*/
/* for (i=0; i<m; i++)*/
/* INTEGER(IFAIL)[0] = ifail[i];*/
// Manage the return
if (CHARPT(JOBZ, 0)[0] == 'N') // Only eigenvalues are computed
{
RET_NAMES = make_list_names(1, "values");
RET = make_list(RET_NAMES, 1, W);
}
else // eigenvalues + eigenvectors
{
newRmat(Z, ldm[0], ldm[1], "dbl");
for (i=0; i<ldm[0]*ldm[1]; i++)
DBL(Z, i) = z[i];
newRvec(M, 1, "int");
INT(M, 0) = m;
RET_NAMES = make_list_names(3, "values", "vectors", "m");
RET = make_list(RET_NAMES, 3, W, Z, M);
}
R_END;
return RET;
}
/* Symmetric Eigen */
SEXP R_PDSYEVR(SEXP JOBZ, SEXP UPLO, SEXP N, SEXP A, SEXP DESCA, SEXP DESCZ)
{
R_INIT;
SEXP RET, RET_NAMES, INFO, W, Z;
char range = 'A';
int IJ = 1;
int lwork = -1;
int *iwork;
int liwork = -1;
double temp_work = 0;
double *work;
double *A_cp;
double tmp = 0;
int itmp = 0;
int m, nz;
newRvec(INFO, 1, "int");
INT(INFO, 0) = 0;
newRvec(W, INT(N, 0), "dbl");
newRmat(Z, nrows(A), ncols(A), "dbl");
/* Query size of workspace */
// pdsyev_(CHARPT(JOBZ, 0), CHARPT(UPLO, 0), INTP(N),
// &tmp, &IJ, &IJ, INTP(DESCA),
// &tmp, &tmp, &IJ, &IJ, INTP(DESCZ),
// &temp_work, &lwork, INTP(INFO));
pdsyevr_(CHARPT(JOBZ, 0), &range, CHARPT(UPLO, 0), INTP(N),
&tmp, &IJ, &IJ, INTP(DESCA), &tmp, &tmp, &itmp, &itmp,
&m, &nz, DBLP(W), DBLP(Z), &IJ, &IJ, INTP(DESCZ),
&temp_work, &lwork, &liwork, &liwork, INTP(INFO));
/* Allocate workspace and calculate */
const size_t size = nrows(A)*ncols(A);
A_cp = (double *) R_alloc(size, sizeof(*A_cp));
memcpy(A_cp, DBLP(A), size*sizeof(*A_cp));
lwork = (int) temp_work;
lwork = nonzero(lwork);
work = (double *) R_alloc(lwork, sizeof(*work));
liwork = nonzero(liwork);
iwork = (int *) R_alloc(liwork, sizeof(*iwork));
pdsyevr_(CHARPT(JOBZ, 0), &range, CHARPT(UPLO, 0), INTP(N),
A_cp, &IJ, &IJ, INTP(DESCA), &tmp, &tmp, &itmp, &itmp,
&m, &nz, DBLP(W), DBLP(Z), &IJ, &IJ, INTP(DESCZ),
work, &lwork, iwork, &liwork, INTP(INFO));
// pdsyev_(CHARPT(JOBZ, 0), CHARPT(UPLO, 0), INTP(N),
// A_cp, &IJ, &IJ, INTP(DESCA),
// DBLP(W), DBLP(Z), &IJ, &IJ, INTP(DESCZ),
// work, &lwork, INTP(INFO));
// Manage return
RET_NAMES = make_list_names(3, "values", "vectors", "info");
RET = make_list(RET_NAMES, 3, W, Z, INFO);
R_END;
return RET;
}