SEXP do_nw_align(SEXP gt1, SEXP gt2, SEXP sparam, SEXP sends)
{
int n1, n2, i, j, n, k;
const char *s1, *s2;
char *a1, *a2, *eq;
double gap, pm, mm, **score;
int ends[4], **link;
SEXP ans, ssc, sal, end;
enum gap { GAP_NO = 0, GAP_S1, GAP_S2 };
if (!isString(gt1) || (length(gt1) != 1))
error(_("'gt1' argument should be a character string"));
if (!isString(gt2) || (length(gt2) != 1))
error(_("'gt2' argument should be a character string"));
if (!isReal(sparam) || LENGTH(sparam) != 3)
error(_("'param' should a numeric vector of length 3"));
if (!isLogical(sends) || (length(sends) != 4))
error(_("'ends' argument should be a logical vector of length 4"));
s1 = CHAR(STRING_ELT(gt1,0));
s2 = CHAR(STRING_ELT(gt2,0));
n1 = strlen(s1)+1;
n2 = strlen(s2)+1;
gap = REAL(sparam)[0];
pm = REAL(sparam)[1];
mm = REAL(sparam)[2];
memcpy(ends, LOGICAL(sends), 4*sizeof(int));
score = (double **)R_alloc(n1, sizeof(double *));
score[0] = (double *)R_alloc(n2*n1, sizeof(double));
link = (int **)R_alloc(n1, sizeof(int *));
link[0] = (int *)R_alloc(n2*n1, sizeof(int));
for (i = 1; i < n1; i++) {
score[i] = score[0] + i*n2;
link[i] = link[0] + i*n2;
}
/* initialize first rows of score, link matrices */
if (ends[2]) {
memset(score[0], 0, n2*sizeof(double));
} else {
score[0][0] = 0;
for (j = 1; j < n2; j++)
score[0][j] = j * gap;
}
link[0][0] = GAP_NO;
for (j = 1; j < n2; j++)
link[0][j] = GAP_S1;
/* dynamic programming loops */
for (i = 1; i < n1; i++) {
score[i][0] = ends[0] ? 0 : (i * gap);
link[i][0] = GAP_S2;
for (j = 1; j < n2; j++) {
double sc1, sc2, scm;
sc1 = score[i][j-1] + gap;
sc2 = score[i-1][j] + gap;
scm = score[i-1][j-1] + (s1[i-1] == s2[j-1] ? pm : mm);
if (scm >= sc1) {
if (scm > sc2) {
link[i][j] = GAP_NO;
score[i][j] = scm;
} else {
link[i][j] = GAP_S2;
score[i][j] = sc2;
}
} else {
if (sc1 >= sc2) {
link[i][j] = GAP_S1;
score[i][j] = sc1;
} else {
link[i][j] = GAP_S2;
score[i][j] = sc2;
}
}
}
}
/* identify ends of best alignment */
i = n1-1 ; j = n2-1;
if (ends[3]) {
for (n = n2-1; n > 0; n--) {
if (score[i][n] >= score[i][j])
j = n;
}
}
if (ends[1]) {
for (n = n1-1; n > 0; n--) {
if (score[n][n2-1] >= score[i][j]) {
i = n;
j = n2-1;
}
}
}
PROTECT(end = allocVector(INTSXP,4));
INTEGER(end)[1] = i;
INTEGER(end)[3] = j;
PROTECT(ssc = ScalarReal(score[i][j]));
/* these will receive the final alignment */
k = n1+n2;
a1 = (char *)R_alloc(k+1, sizeof(char));
a2 = (char *)R_alloc(k+1, sizeof(char));
eq = (char *)R_alloc(k+1, sizeof(char));
a1[k] = a2[k] = eq[k] = '\0';
/* backtrack to extract best alignment */
while ((i && j) || (i && !ends[0]) || (j && !ends[2])) {
n = link[i][j];
a1[--k] = (n == GAP_S1) ? '-' : toupper(s1[--i]);
a2[k] = (n == GAP_S2) ? '-' : toupper(s2[--j]);
eq[k] = (a1[k] == a2[k]) ? '|' : ' ';
}
INTEGER(end)[0] = i+1;
INTEGER(end)[2] = j+1;
PROTECT(sal = allocVector(STRSXP,3));
SET_STRING_ELT(sal,0,mkChar(a1+k));
SET_STRING_ELT(sal,1,mkChar(eq+k));
SET_STRING_ELT(sal,2,mkChar(a2+k));
PROTECT(ans = allocVector(VECSXP,3));
SET_VECTOR_ELT(ans,0,ssc);
SET_VECTOR_ELT(ans,1,end);
SET_VECTOR_ELT(ans,2,sal);
UNPROTECT(4);
return ans;
}
SEXP attribute_hidden do_cum(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP s, t, ans;
R_xlen_t i, n;
checkArity(op, args);
if (DispatchGroup("Math", call, op, args, env, &ans))
return ans;
if (isComplex(CAR(args))) {
t = CAR(args);
n = XLENGTH(t);
PROTECT(s = allocVector(CPLXSXP, n));
setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
UNPROTECT(1);
if(n == 0) return s;
for (i = 0 ; i < n ; i++) {
COMPLEX(s)[i].r = NA_REAL;
COMPLEX(s)[i].i = NA_REAL;
}
switch (PRIMVAL(op) ) {
case 1: /* cumsum */
return ccumsum(t, s);
break;
case 2: /* cumprod */
return ccumprod(t, s);
break;
case 3: /* cummax */
errorcall(call, _("'cummax' not defined for complex numbers"));
break;
case 4: /* cummin */
errorcall(call, _("'cummin' not defined for complex numbers"));
break;
default:
errorcall(call, "unknown cumxxx function");
}
} else if( ( isInteger(CAR(args)) || isLogical(CAR(args)) ) &&
PRIMVAL(op) != 2) {
PROTECT(t = coerceVector(CAR(args), INTSXP));
n = XLENGTH(t);
PROTECT(s = allocVector(INTSXP, n));
setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
if(n == 0) {
UNPROTECT(2); /* t, s */
return s;
}
for(i = 0 ; i < n ; i++) INTEGER(s)[i] = NA_INTEGER;
switch (PRIMVAL(op) ) {
case 1: /* cumsum */
ans = icumsum(t,s);
break;
case 3: /* cummax */
ans = icummax(t,s);
break;
case 4: /* cummin */
ans = icummin(t,s);
break;
default:
errorcall(call, _("unknown cumxxx function"));
ans = R_NilValue;
}
UNPROTECT(2); /* t, s */
return ans;
} else {
PROTECT(t = coerceVector(CAR(args), REALSXP));
n = XLENGTH(t);
PROTECT(s = allocVector(REALSXP, n));
setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
UNPROTECT(2);
if(n == 0) return s;
for(i = 0 ; i < n ; i++) REAL(s)[i] = NA_REAL;
switch (PRIMVAL(op) ) {
case 1: /* cumsum */
return cumsum(t,s);
break;
case 2: /* cumprod */
return cumprod(t,s);
break;
case 3: /* cummax */
return cummax(t,s);
break;
case 4: /* cummin */
return cummin(t,s);
break;
default:
errorcall(call, _("unknown cumxxx function"));
}
}
return R_NilValue; /* for -Wall */
}
SEXP do_nw_score(SEXP gt1, SEXP gt2, SEXP sparam, SEXP sends)
{
int n1, n2, i, j, n;
const char *s1, *s2;
double gap, pm, mm, m, *score;
int ends[4];
if (!isString(gt1) || (length(gt1) != 1))
error(_("'gt1' argument should be a character string"));
if (!isString(gt2) || (length(gt2) != 1))
error(_("'gt2' argument should be a character string"));
if (!isReal(sparam) || LENGTH(sparam) != 3)
error(_("'param' should a numeric vector of length 3"));
if (!isLogical(sends) || (length(sends) != 4))
error(_("'ends' argument should be a logical vector of length 4"));
s1 = CHAR(STRING_ELT(gt1,0));
s2 = CHAR(STRING_ELT(gt2,0));
n1 = strlen(s1)+1;
n2 = strlen(s2)+1;
gap = REAL(sparam)[0];
pm = REAL(sparam)[1];
mm = REAL(sparam)[2];
memcpy(ends, LOGICAL(sends), 4*sizeof(int));
/* initialize first rows of score, link vectors */
score = (double *)R_alloc(n2, sizeof(double));
if (ends[2]) {
memset(score, 0, n2*sizeof(double));
} else {
score[0] = 0;
for (j = 1; j < n2; j++)
score[j] = j * gap;
}
/* dynamic programming loops */
m = 0.0;
for (i = 1; i < n1; i++) {
double sc0, sc1, sc2, scm;
sc0 = score[0];
sc1 = score[0] = ends[0] ? 0 : (i * gap);
for (j = 1; j < n2; j++) {
scm = sc0 + (s1[i-1] == s2[j-1] ? pm : mm);
sc0 = score[j];
sc2 = sc0 + gap;
if (scm > sc1) {
score[j] = (scm > sc2) ? scm : sc2;
} else {
score[j] = (sc1 > sc2) ? sc1 : sc2;
}
sc1 = score[j] + gap;
}
if (ends[1]) {
if (score[n2-1] > m) m = score[n2-1];
}
}
/* identify end of best alignment */
if (ends[3]) {
for (n = n2-1; n > 0; n--)
if (score[n] > m)
m = score[n];
} else {
if (score[n2-1] > m) m = score[n2-1];
}
return ScalarReal(m);
}
/*
* call to nls_iter from R --- .Call("nls_iter", m, control, doTrace)
* where m and control are nlsModel and nlsControl objects
* doTrace is a logical value.
* m is modified; the return value is a "convergence-information" list.
*/
SEXP
nls_iter(SEXP m, SEXP control, SEXP doTraceArg)
{
double dev, fac, minFac, tolerance, newDev, convNew = -1./*-Wall*/;
int i, j, maxIter, hasConverged, nPars, doTrace, evaltotCnt = -1, warnOnly, printEval;
SEXP tmp, conv, incr, deviance, setPars, getPars, pars, newPars, trace;
doTrace = asLogical(doTraceArg);
if(!isNewList(control))
error(_("'control' must be a list"));
if(!isNewList(m))
error(_("'m' must be a list"));
PROTECT(tmp = getAttrib(control, R_NamesSymbol));
conv = getListElement(control, tmp, "maxiter");
if(conv == NULL || !isNumeric(conv))
error(_("'%s' absent"), "control$maxiter");
maxIter = asInteger(conv);
conv = getListElement(control, tmp, "tol");
if(conv == NULL || !isNumeric(conv))
error(_("'%s' absent"), "control$tol");
tolerance = asReal(conv);
conv = getListElement(control, tmp, "minFactor");
if(conv == NULL || !isNumeric(conv))
error(_("'%s' absent"), "control$minFactor");
minFac = asReal(conv);
conv = getListElement(control, tmp, "warnOnly");
if(conv == NULL || !isLogical(conv))
error(_("'%s' absent"), "control$warnOnly");
warnOnly = asLogical(conv);
conv = getListElement(control, tmp, "printEval");
if(conv == NULL || !isLogical(conv))
error(_("'%s' absent"), "control$printEval");
printEval = asLogical(conv);
#define CONV_INFO_MSG(_STR_, _I_) \
ConvInfoMsg(_STR_, i, _I_, fac, minFac, maxIter, convNew)
#define NON_CONV_FINIS(_ID_, _MSG_) \
if(warnOnly) { \
warning(_MSG_); \
return CONV_INFO_MSG(_MSG_, _ID_); \
} \
else \
error(_MSG_);
#define NON_CONV_FINIS_1(_ID_, _MSG_, _A1_) \
if(warnOnly) { \
char msgbuf[1000]; \
warning(_MSG_, _A1_); \
snprintf(msgbuf, 1000, _MSG_, _A1_); \
return CONV_INFO_MSG(msgbuf, _ID_); \
} \
else \
error(_MSG_, _A1_);
#define NON_CONV_FINIS_2(_ID_, _MSG_, _A1_, _A2_) \
if(warnOnly) { \
char msgbuf[1000]; \
warning(_MSG_, _A1_, _A2_); \
snprintf(msgbuf, 1000, _MSG_, _A1_, _A2_); \
return CONV_INFO_MSG(msgbuf, _ID_); \
} \
else \
error(_MSG_, _A1_, _A2_);
/* now get parts from 'm' */
tmp = getAttrib(m, R_NamesSymbol);
conv = getListElement(m, tmp, "conv");
if(conv == NULL || !isFunction(conv))
error(_("'%s' absent"), "m$conv()");
PROTECT(conv = lang1(conv));
incr = getListElement(m, tmp, "incr");
if(incr == NULL || !isFunction(incr))
error(_("'%s' absent"), "m$incr()");
PROTECT(incr = lang1(incr));
deviance = getListElement(m, tmp, "deviance");
if(deviance == NULL || !isFunction(deviance))
error(_("'%s' absent"), "m$deviance()");
PROTECT(deviance = lang1(deviance));
trace = getListElement(m, tmp, "trace");
if(trace == NULL || !isFunction(trace))
error(_("'%s' absent"), "m$trace()");
PROTECT(trace = lang1(trace));
setPars = getListElement(m, tmp, "setPars");
if(setPars == NULL || !isFunction(setPars))
error(_("'%s' absent"), "m$setPars()");
PROTECT(setPars);
getPars = getListElement(m, tmp, "getPars");
if(getPars == NULL || !isFunction(getPars))
error(_("'%s' absent"), "m$getPars()");
PROTECT(getPars = lang1(getPars));
PROTECT(pars = eval(getPars, R_GlobalEnv));
nPars = LENGTH(pars);
dev = asReal(eval(deviance, R_GlobalEnv));
if(doTrace) eval(trace,R_GlobalEnv);
fac = 1.0;
hasConverged = FALSE;
PROTECT(newPars = allocVector(REALSXP, nPars));
if(printEval)
evaltotCnt = 1;
for (i = 0; i < maxIter; i++) {
SEXP newIncr;
int evalCnt = -1;
if((convNew = asReal(eval(conv, R_GlobalEnv))) < tolerance) {
hasConverged = TRUE;
break;
}
PROTECT(newIncr = eval(incr, R_GlobalEnv));
if(printEval)
evalCnt = 1;
while(fac >= minFac) {
if(printEval) {
Rprintf(" It. %3d, fac= %11.6g, eval (no.,total): (%2d,%3d):",
i+1, fac, evalCnt, evaltotCnt);
evalCnt++;
evaltotCnt++;
}
for(j = 0; j < nPars; j++)
REAL(newPars)[j] = REAL(pars)[j] + fac * REAL(newIncr)[j];
PROTECT(tmp = lang2(setPars, newPars));
if (asLogical(eval(tmp, R_GlobalEnv))) { /* singular gradient */
UNPROTECT(11);
NON_CONV_FINIS(1, _("singular gradient"));
}
UNPROTECT(1);
newDev = asReal(eval(deviance, R_GlobalEnv));
if(printEval)
Rprintf(" new dev = %g\n", newDev);
if(newDev <= dev) {
dev = newDev;
fac = MIN(2*fac, 1);
tmp = newPars;
newPars = pars;
pars = tmp;
break;
}
fac /= 2.;
}
UNPROTECT(1);
if( fac < minFac ) {
UNPROTECT(9);
NON_CONV_FINIS_2(2,
_("step factor %g reduced below 'minFactor' of %g"),
fac, minFac);
}
if(doTrace) eval(trace, R_GlobalEnv);
}
UNPROTECT(9);
if(!hasConverged) {
NON_CONV_FINIS_1(3,
_("number of iterations exceeded maximum of %d"),
maxIter);
}
/* else */
return CONV_INFO_MSG(_("converged"), 0);
}
SEXP expand_pair_links(SEXP anchor1, SEXP anchor2, SEXP querystarts1, SEXP queryends1, SEXP subject1, SEXP nsubjects1,
SEXP querystarts2, SEXP queryends2, SEXP subject2, SEXP nsubjects2, SEXP sameness, SEXP use_both) try {
if (!isInteger(anchor1) || !isInteger(anchor2)) { throw std::runtime_error("anchors must be integer vectors"); }
const int Npairs = LENGTH(anchor1);
if (Npairs != LENGTH(anchor2)) { throw std::runtime_error("anchor vectors must be of equal length"); }
const int* a1ptr=INTEGER(anchor1), *a2ptr=INTEGER(anchor2);
if (!isInteger(querystarts1) || !isInteger(queryends1)) { throw std::runtime_error("query indices (1) must be integer vectors"); }
const int Nq = LENGTH(querystarts1);
if (Nq != LENGTH(queryends1)) { throw std::runtime_error("query indices (1) must be of equal length"); }
const int* qsptr1=INTEGER(querystarts1), *qeptr1=INTEGER(queryends1);
if (!isInteger(subject1)) { throw std::runtime_error("subject indices (1) must be integer"); }
const int Ns1 = LENGTH(subject1);
const int *sjptr1=INTEGER(subject1);
if (!isInteger(querystarts2) || !isInteger(queryends2)) { throw std::runtime_error("query indices (2) must be integer vectors"); }
if (Nq != LENGTH(querystarts2) || Nq != LENGTH(queryends2)) { throw std::runtime_error("query indices (2) must be of equal length"); }
const int* qsptr2=INTEGER(querystarts2), *qeptr2=INTEGER(queryends2);
if (!isInteger(subject2)) { throw std::runtime_error("subject indices (2) must be integer"); }
const int Ns2 = LENGTH(subject2);
const int *sjptr2=INTEGER(subject2);
if (!isInteger(nsubjects1) || LENGTH(nsubjects1)!=1) { throw std::runtime_error("total number of subjects (1) must be an integer scalar"); }
const int Ns_all1 = asInteger(nsubjects1);
if (!isInteger(nsubjects2) || LENGTH(nsubjects2)!=1) { throw std::runtime_error("total number of subjects (2) must be an integer scalar"); }
const int Ns_all2 = asInteger(nsubjects2);
int true_mode_start, true_mode_end;
set_mode_values(use_both, true_mode_start, true_mode_end);
if (!isLogical(sameness) || LENGTH(sameness)!=1) { throw std::runtime_error("same region indicator should be a logical scalar"); }
const bool is_same=asLogical(sameness);
if (is_same) { true_mode_end=true_mode_start+1; } // No point examining the flipped ones.
// Check indices.
check_indices(qsptr1, qeptr1, Nq, sjptr1, Ns1, Ns_all1);
check_indices(qsptr2, qeptr2, Nq, sjptr2, Ns2, Ns_all2);
// Setting up the set.
typedef std::pair<int, int> link;
std::set<link> currently_active;
std::set<link>::const_iterator itca;
std::deque<link> stored_inactive;
std::deque<int> interactions;
int curpair=0, mode=0, maxmode, curq1=0, curq2=0, curindex1=0, curindex2=0;
for (curpair=0; curpair<Npairs; ++curpair) {
maxmode = (a1ptr[curpair] == a2ptr[curpair] ? true_mode_start+1 : true_mode_end);
// Repeating with switched anchors, if the query sets are not the same.
for (mode=true_mode_start; mode<maxmode; ++mode) {
if (mode==0) {
curq1 = a1ptr[curpair];
curq2 = a2ptr[curpair];
if (curq1 >= Nq || curq1 < 0 || curq1==NA_INTEGER) { throw std::runtime_error("region index (1) out of bounds"); }
if (curq2 >= Nq || curq2 < 0 || curq2==NA_INTEGER) { throw std::runtime_error("region index (2) out of bounds"); }
} else {
curq2 = a1ptr[curpair];
curq1 = a2ptr[curpair];
}
/* Storing all combinations associated with this pair. Avoiding redundant combinations
* for self-linking (we can't use a simple rule like curindex2 < curindex1 to restrict
* the loop, as the second anchor can overlap regions above the first anchor if the
* latter is nested within the former).
*/
for (curindex1=qsptr1[curq1]; curindex1<qeptr1[curq1]; ++curindex1) {
for (curindex2=qsptr2[curq2]; curindex2<qeptr2[curq2]; ++curindex2) {
if (is_same && sjptr1[curindex1] < sjptr2[curindex2]) {
currently_active.insert(link(sjptr2[curindex2], sjptr1[curindex1]));
} else {
currently_active.insert(link(sjptr1[curindex1], sjptr2[curindex2]));
}
}
}
}
// Relieving the set by storing all inactive entries (automatically sorted as well).
for (itca=currently_active.begin(); itca!=currently_active.end(); ++itca) {
stored_inactive.push_back(*itca);
}
interactions.resize(interactions.size() + currently_active.size(), curpair);
currently_active.clear();
}
// Popping back a list of information.
SEXP output=PROTECT(allocVector(VECSXP, 3));
try {
const int total_entries=interactions.size();
SET_VECTOR_ELT(output, 0, allocVector(INTSXP, total_entries));
int * oiptr=INTEGER(VECTOR_ELT(output, 0));
SET_VECTOR_ELT(output, 1, allocVector(INTSXP, total_entries));
int * os1ptr=INTEGER(VECTOR_ELT(output, 1));
SET_VECTOR_ELT(output, 2, allocVector(INTSXP, total_entries));
int * os2ptr=INTEGER(VECTOR_ELT(output, 2));
std::copy(interactions.begin(), interactions.end(), oiptr);
for (int curdex=0; curdex < total_entries; ++curdex) {
os1ptr[curdex]=stored_inactive[curdex].first;
os2ptr[curdex]=stored_inactive[curdex].second;
}
} catch (std::exception& e) {
UNPROTECT(1);
throw;
}
UNPROTECT(1);
return output;
} catch (std::exception& e) {
return mkString(e.what());
}
SEXP iterative_correction(SEXP avecount, SEXP anchor, SEXP target, SEXP local,
SEXP nfrags, SEXP iter, SEXP exlocal, SEXP lowdiscard, SEXP winsorhigh) try {
// Checking vector type and length.
if (!isNumeric(avecount)) { throw std::runtime_error("average counts must be supplied as a double-precision vector"); }
if (!isInteger(anchor) || !isInteger(target)) { throw std::runtime_error("anchor/target indices must be supplied as an integer vector"); }
if (!isLogical(local)) { throw std::runtime_error("local specifier should be a logical vector"); }
const int npairs=LENGTH(avecount);
if (npairs!=LENGTH(anchor) || npairs!=LENGTH(target) || npairs!=LENGTH(local)) { throw std::runtime_error("lengths of vectors are not equal"); }
const double* acptr=REAL(avecount);
const int* aptr=INTEGER(anchor),
* tptr=INTEGER(target),
* lptr=LOGICAL(local);
// Checking scalar type.
if (!isInteger(nfrags) || LENGTH(nfrags)!=1) { throw std::runtime_error("number of fragments should be an integer scalar"); }
if (!isInteger(iter) || LENGTH(iter)!=1) { throw std::runtime_error("number of iterations should be an integer scalar"); }
if (!isInteger(exlocal) || LENGTH(exlocal)!=1) { throw std::runtime_error("exclusion specifier should be an integer scalar"); }
const int numfrags=asInteger(nfrags),
iterations=asInteger(iter),
excluded=asInteger(exlocal);
if (!isNumeric(lowdiscard) || LENGTH(lowdiscard)!=1) { throw std::runtime_error("proportion to discard should be a double-precision scalar"); }
const double discarded=asReal(lowdiscard);
if (!isNumeric(winsorhigh) || LENGTH(winsorhigh)!=1) { throw std::runtime_error("proportion to winsorize should be a double-precision scalar"); }
const double winsorized=asReal(winsorhigh);
SEXP output=PROTECT(allocVector(VECSXP, 3));
try {
// Setting up a SEXP to hold the working probabilities (ultimately the truth).
SET_VECTOR_ELT(output, 0, allocVector(REALSXP, npairs));
double* wptr=REAL(VECTOR_ELT(output, 0));
std::copy(acptr, acptr+npairs, wptr);
// Excluding highly local interactions.
int num_values=npairs;
bool drop_intras=(excluded==NA_INTEGER);
if (drop_intras || excluded >= 0) {
for (int j=0; j<npairs; ++j) {
if (lptr[j] && (drop_intras || aptr[j]-tptr[j] <= excluded)) {
wptr[j]=R_NaReal;
--num_values;
}
}
}
/**************************************************
* Getting rid of unstable or extreme elements.
**************************************************/
// Winsorizing for the most abundant interactions.
const int todrop=int(double(num_values)*winsorized);
if (todrop>0) {
int* ordered=new int[npairs];
try {
for (int i=0; i<npairs; ++i) { ordered[i]=i; }
orderer current(acptr);
std::sort(ordered, ordered+npairs, current);
// Identifying the winsorizing value.
int curcount=0;
double winsor_val=R_NaReal;
for (int i=npairs-1; i>=0; --i) {
const int& curo=ordered[i];
if (ISNA(wptr[curo])) { continue; }
++curcount;
if (curcount > todrop) {
winsor_val=wptr[curo];
break;
}
}
// Applying said value to all high-abundance interactions.
if (ISNA(winsor_val)) { throw std::runtime_error("specified winsorizing proportion censors all data"); }
curcount=0;
for (int i=npairs-1; i>=0; --i) {
const int& curo=ordered[i];
if (ISNA(wptr[curo])) { continue; }
wptr[curo]=winsor_val;
++curcount;
if (curcount > todrop) { break; }
}
} catch (std::exception& e){
delete [] ordered;
throw;
}
delete[] ordered;
}
// Bias and coverage vectors.
SET_VECTOR_ELT(output, 1, allocVector(REALSXP, numfrags));
double* bias=REAL(VECTOR_ELT(output, 1)),
* biaptr=bias-1;
for (int i=0; i<numfrags; ++i) { bias[i]=R_NaReal; }
for (int pr=0; pr<npairs; ++pr) {
if (!ISNA(wptr[pr])) { biaptr[aptr[pr]]=biaptr[tptr[pr]]=1; }
}
double* coverage=(double*)R_alloc(numfrags, sizeof(double));
for (int i=0; i<numfrags; ++i) { coverage[i]=0; }
double* covptr=coverage-1; // To deal with 1-based indices.
// Removing low-abundance fragments.
if (discarded > 0) {
for (int pr=0; pr<npairs; ++pr) { // Computing the coverage.
if (ISNA(wptr[pr])) { continue; }
covptr[aptr[pr]]+=wptr[pr];
covptr[tptr[pr]]+=wptr[pr];
}
int* ordering=new int [numfrags];
try {
for (int i=0; i<numfrags; ++i) { ordering[i]=i; }
orderer current(coverage);
std::sort(ordering, ordering+numfrags, current);
// Ignoring empty rows.
int counter=0;
while (counter < numfrags && ISNA(bias[ordering[counter]])){ ++counter; }
// Filtering out low-abundance rows.
const int leftover=int(discarded*double(numfrags-counter))+counter;
while (counter < leftover) {
bias[ordering[counter]]=R_NaReal;
++counter;
}
// Setting everything else back to zero.
while (counter < numfrags) {
coverage[ordering[counter]]=0;
++counter;
}
} catch (std::exception& e) {
delete [] ordering;
throw;
}
delete [] ordering;
// Propogating the filters through the interactions to remove anything with an anchor in the removed fragments.
for (int pr=0; pr<npairs; ++pr) {
if (ISNA(wptr[pr])) { continue; }
if (ISNA(biaptr[aptr[pr]]) || ISNA(biaptr[tptr[pr]])) { wptr[pr]=R_NaReal; }
}
for (int i=0; i<numfrags; ++i) { bias[i]=R_NaReal; }
for (int pr=0; pr<npairs; ++pr) {
if (!ISNA(wptr[pr])) { biaptr[aptr[pr]]=biaptr[tptr[pr]]=1; }
}
}
// Something to hold a diagnostic (i.e., the maximum step).
SET_VECTOR_ELT(output, 2, allocVector(REALSXP, iterations));
double* optr=REAL(VECTOR_ELT(output, 2));
/********************************************************
* Now, actually performing the iterative correction. ***
********************************************************/
for (int it=0; it<iterations; ++it) {
for (int pr=0; pr<npairs; ++pr) { // Computing the coverage (ignoring locals, if necessary).
if (ISNA(wptr[pr])) { continue; }
covptr[aptr[pr]]+=wptr[pr];
covptr[tptr[pr]]+=wptr[pr];
}
/* Computing the 'aditional bias' vector, to take the mean across all fragments.
* The exact value of the mean doesn't really matter, it just serves to slow down
* the algorithm to avoid overshooting the mark and lack of convergence. Everything
* ends up being the same so long as the column sums approach 1.
*/
// double mean_of_all=0;
// for (int i=0; i<numfrags; ++i) { if (!ISNA(coverage[i])) { mean_of_all+=coverage[i]; } }
// mean_of_all/=numfrags;
// for (int i=0; i<numfrags; ++i) { if (!ISNA(coverage[i])) { coverage[i]/=mean_of_all; } }
/* Okay, that didn't really work. The strategy that is described in the paper fails to
* give me contact probabilities that sum to 1. So instead, I'm using the coverage
* itself to divide the working probabilities. Square rooting is necessary to avoid
* instability during iteration.
*/
for (int i=0; i<numfrags; ++i) { if (!ISNA(bias[i])) { coverage[i]=std::sqrt(coverage[i]); } }
// Dividing the working matrix with the (geometric mean of the) additional biases.
for (int pr=0; pr<npairs; ++pr){
if (!ISNA(wptr[pr])) { wptr[pr]/=covptr[aptr[pr]]*covptr[tptr[pr]]; }
}
// Multiplying the biases by additional biases, and cleaning out coverage. We store
// the maximum step to see how far off convergence it is.
double& maxed=(optr[it]=0);
for (int i=0; i<numfrags; ++i) {
if (!ISNA(bias[i])) {
double& cur_cov=coverage[i];
if (cur_cov > maxed) { maxed=cur_cov; }
else if (1/cur_cov > maxed) { maxed=1/cur_cov; }
bias[i]*=cur_cov;
cur_cov=0;
}
}
}
/* Recalculating the contact probabilities, using the estimated biases,
* to get normalized values for Winsorized or discarded bin pairs.
* Discarded bins can't be salvaged, though.
*/
for (int pr=0; pr<npairs; ++pr) {
if (ISNA(biaptr[aptr[pr]]) || ISNA(biaptr[tptr[pr]])) { continue; }
wptr[pr] = acptr[pr]/biaptr[aptr[pr]]/biaptr[tptr[pr]];
}
} catch (std::exception& e) {
UNPROTECT(1);
throw;
}
UNPROTECT(1);
return output;
} catch (std::exception& e) {
return mkString(e.what());
}
/*
cairo(filename, type, width, height, pointsize, bg, res, antialias,
quality, family)
*/
SEXP in_Cairo(SEXP args)
{
pGEDevDesc gdd;
SEXP sc;
const char *filename, *family;
int type, quality, width, height, pointsize, bgcolor, res, antialias;
const void *vmax = vmaxget();
args = CDR(args); /* skip entry point name */
if (!isString(CAR(args)) || LENGTH(CAR(args)) < 1)
error(_("invalid '%s' argument"), "filename");
filename = translateChar(STRING_ELT(CAR(args), 0));
args = CDR(args);
type = asInteger(CAR(args));
if(type == NA_INTEGER || type <= 0)
error(_("invalid '%s' argument"), "type");
args = CDR(args);
width = asInteger(CAR(args));
if(width == NA_INTEGER || width <= 0)
error(_("invalid '%s' argument"), "width");
args = CDR(args);
height = asInteger(CAR(args));
if(height == NA_INTEGER || height <= 0)
error(_("invalid '%s' argument"), "height");
args = CDR(args);
pointsize = asInteger(CAR(args));
if(pointsize == NA_INTEGER || pointsize <= 0)
error(_("invalid '%s' argument"), "pointsize");
args = CDR(args);
sc = CAR(args);
if (!isString(sc) && !isInteger(sc) && !isLogical(sc) && !isReal(sc))
error(_("invalid '%s' value"), "bg");
bgcolor = RGBpar(sc, 0);
args = CDR(args);
res = asInteger(CAR(args));
args = CDR(args);
antialias = asInteger(CAR(args));
if(antialias == NA_INTEGER)
error(_("invalid '%s' argument"), "antialias");
args = CDR(args);
quality = asInteger(CAR(args));
if(quality == NA_INTEGER || quality < 0 || quality > 100)
error(_("invalid '%s' argument"), "quality");
args = CDR(args);
if (!isString(CAR(args)) || LENGTH(CAR(args)) < 1)
error(_("invalid '%s' argument"), "family");
family = translateChar(STRING_ELT(CAR(args), 0));
R_GE_checkVersionOrDie(R_GE_version);
R_CheckDeviceAvailable();
BEGIN_SUSPEND_INTERRUPTS {
pDevDesc dev;
/* Allocate and initialize the device driver data */
if (!(dev = (pDevDesc) calloc(1, sizeof(DevDesc)))) return 0;
if (!BMDeviceDriver(dev, devtable[type].gtype, filename, quality,
width, height, pointsize,
bgcolor, res, antialias, family)) {
free(dev);
error(_("unable to start device '%s'"), devtable[type].name);
}
gdd = GEcreateDevDesc(dev);
GEaddDevice2f(gdd, devtable[type].name, filename);
} END_SUSPEND_INTERRUPTS;
vmaxset(vmax);
return R_NilValue;
}
SEXP attribute_hidden do_relop_dflt(SEXP call, SEXP op, SEXP x, SEXP y)
{
SEXP klass = R_NilValue, dims, tsp=R_NilValue, xnames, ynames;
int nx, ny, xarray, yarray, xts, yts;
Rboolean mismatch = FALSE, iS;
PROTECT_INDEX xpi, ypi;
PROTECT_WITH_INDEX(x, &xpi);
PROTECT_WITH_INDEX(y, &ypi);
nx = length(x);
ny = length(y);
/* pre-test to handle the most common case quickly.
Used to skip warning too ....
*/
if (ATTRIB(x) == R_NilValue && ATTRIB(y) == R_NilValue &&
TYPEOF(x) == REALSXP && TYPEOF(y) == REALSXP &&
LENGTH(x) > 0 && LENGTH(y) > 0) {
SEXP ans = real_relop((RELOP_TYPE) PRIMVAL(op), x, y);
if (nx > 0 && ny > 0)
mismatch = ((nx > ny) ? nx % ny : ny % nx) != 0;
if (mismatch) {
PROTECT(ans);
warningcall(call, _("longer object length is not a multiple of shorter object length"));
UNPROTECT(1);
}
UNPROTECT(2);
return ans;
}
/* That symbols and calls were allowed was undocumented prior to
R 2.5.0. We deparse them as deparse() would, minus attributes */
if ((iS = isSymbol(x)) || TYPEOF(x) == LANGSXP) {
SEXP tmp = allocVector(STRSXP, 1);
PROTECT(tmp);
SET_STRING_ELT(tmp, 0, (iS) ? PRINTNAME(x) :
STRING_ELT(deparse1(x, 0, DEFAULTDEPARSE), 0));
REPROTECT(x = tmp, xpi);
UNPROTECT(1);
}
if ((iS = isSymbol(y)) || TYPEOF(y) == LANGSXP) {
SEXP tmp = allocVector(STRSXP, 1);
PROTECT(tmp);
SET_STRING_ELT(tmp, 0, (iS) ? PRINTNAME(y) :
STRING_ELT(deparse1(y, 0, DEFAULTDEPARSE), 0));
REPROTECT(y = tmp, ypi);
UNPROTECT(1);
}
if (!isVector(x) || !isVector(y)) {
if (isNull(x) || isNull(y)) {
UNPROTECT(2);
return allocVector(LGLSXP,0);
}
errorcall(call,
_("comparison (%d) is possible only for atomic and list types"),
PRIMVAL(op));
}
if (TYPEOF(x) == EXPRSXP || TYPEOF(y) == EXPRSXP)
errorcall(call, _("comparison is not allowed for expressions"));
/* ELSE : x and y are both atomic or list */
if (LENGTH(x) <= 0 || LENGTH(y) <= 0) {
UNPROTECT(2);
return allocVector(LGLSXP,0);
}
mismatch = FALSE;
xarray = isArray(x);
yarray = isArray(y);
xts = isTs(x);
yts = isTs(y);
if (nx > 0 && ny > 0)
mismatch = ((nx > ny) ? nx % ny : ny % nx) != 0;
if (xarray || yarray) {
if (xarray && yarray) {
if (!conformable(x, y))
errorcall(call, _("non-conformable arrays"));
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else if (xarray) {
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else /*(yarray)*/ {
PROTECT(dims = getAttrib(y, R_DimSymbol));
}
PROTECT(xnames = getAttrib(x, R_DimNamesSymbol));
PROTECT(ynames = getAttrib(y, R_DimNamesSymbol));
}
else {
PROTECT(dims = R_NilValue);
PROTECT(xnames = getAttrib(x, R_NamesSymbol));
PROTECT(ynames = getAttrib(y, R_NamesSymbol));
}
if (xts || yts) {
if (xts && yts) {
if (!tsConform(x, y))
errorcall(call, _("non-conformable time series"));
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else if (xts) {
if (length(x) < length(y))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else /*(yts)*/ {
if (length(y) < length(x))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(y, R_TspSymbol));
PROTECT(klass = getAttrib(y, R_ClassSymbol));
}
}
if (mismatch)
warningcall(call, _("longer object length is not a multiple of shorter object length"));
if (isString(x) || isString(y)) {
REPROTECT(x = coerceVector(x, STRSXP), xpi);
REPROTECT(y = coerceVector(y, STRSXP), ypi);
x = string_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isComplex(x) || isComplex(y)) {
REPROTECT(x = coerceVector(x, CPLXSXP), xpi);
REPROTECT(y = coerceVector(y, CPLXSXP), ypi);
x = complex_relop((RELOP_TYPE) PRIMVAL(op), x, y, call);
}
else if (isReal(x) || isReal(y)) {
REPROTECT(x = coerceVector(x, REALSXP), xpi);
REPROTECT(y = coerceVector(y, REALSXP), ypi);
x = real_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isInteger(x) || isInteger(y)) {
REPROTECT(x = coerceVector(x, INTSXP), xpi);
REPROTECT(y = coerceVector(y, INTSXP), ypi);
x = integer_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isLogical(x) || isLogical(y)) {
REPROTECT(x = coerceVector(x, LGLSXP), xpi);
REPROTECT(y = coerceVector(y, LGLSXP), ypi);
x = integer_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (TYPEOF(x) == RAWSXP || TYPEOF(y) == RAWSXP) {
REPROTECT(x = coerceVector(x, RAWSXP), xpi);
REPROTECT(y = coerceVector(y, RAWSXP), ypi);
x = raw_relop((RELOP_TYPE) PRIMVAL(op), x, y);
} else errorcall(call, _("comparison of these types is not implemented"));
PROTECT(x);
if (dims != R_NilValue) {
setAttrib(x, R_DimSymbol, dims);
if (xnames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, xnames);
else if (ynames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, ynames);
}
else {
if (length(x) == length(xnames))
setAttrib(x, R_NamesSymbol, xnames);
else if (length(x) == length(ynames))
setAttrib(x, R_NamesSymbol, ynames);
}
if (xts || yts) {
setAttrib(x, R_TspSymbol, tsp);
setAttrib(x, R_ClassSymbol, klass);
UNPROTECT(2);
}
UNPROTECT(6);
return x;
}
SEXP bmerge(SEXP iArg, SEXP xArg, SEXP icolsArg, SEXP xcolsArg, SEXP isorted, SEXP rollarg, SEXP rollendsArg, SEXP nomatch, SEXP retFirstArg, SEXP retLengthArg, SEXP allLen1Arg)
{
int xN, iN, protecti=0;
roll = 0.0;
nearest = FALSE;
enc_warn = TRUE;
if (isString(rollarg)) {
if (strcmp(CHAR(STRING_ELT(rollarg,0)),"nearest") != 0) error("roll is character but not 'nearest'");
roll=1.0;
nearest=TRUE; // the 1.0 here is just any non-0.0, so roll!=0.0 can be used later
} else {
if (!isReal(rollarg)) error("Internal error: roll is not character or double");
roll = REAL(rollarg)[0]; // more common case (rolling forwards or backwards) or no roll when 0.0
}
rollabs = fabs(roll);
i = iArg;
x = xArg; // set globals so bmerge_r can see them.
if (!isInteger(icolsArg)) error("Internal error: icols is not integer vector");
if (!isInteger(xcolsArg)) error("Internal error: xcols is not integer vector");
if (LENGTH(icolsArg) > LENGTH(xcolsArg)) error("Internal error: length(icols) [%d] > length(xcols) [%d]", LENGTH(icolsArg), LENGTH(xcolsArg));
icols = INTEGER(icolsArg);
xcols = INTEGER(xcolsArg);
xN = LENGTH(VECTOR_ELT(x,0));
iN = LENGTH(VECTOR_ELT(i,0));
ncol = LENGTH(icolsArg); // there may be more sorted columns in x than involved in the join
for(int col=0; col<ncol; col++) {
if (icols[col]==NA_INTEGER) error("Internal error. icols[%d] is NA", col);
if (xcols[col]==NA_INTEGER) error("Internal error. xcols[%d] is NA", col);
if (icols[col]>LENGTH(i) || icols[col]<1) error("icols[%d]=%d outside range [1,length(i)=%d]", col, icols[col], LENGTH(i));
if (xcols[col]>LENGTH(x) || xcols[col]<1) error("xcols[%d]=%d outside range [1,length(x)=%d]", col, xcols[col], LENGTH(x));
int it = TYPEOF(VECTOR_ELT(i, icols[col]-1));
int xt = TYPEOF(VECTOR_ELT(x, xcols[col]-1));
if (it != xt) error("typeof x.%s (%s) != typeof i.%s (%s)", CHAR(STRING_ELT(getAttrib(x,R_NamesSymbol),xcols[col]-1)), type2char(xt), CHAR(STRING_ELT(getAttrib(i,R_NamesSymbol),icols[col]-1)), type2char(it));
}
if (!isInteger(retFirstArg) || LENGTH(retFirstArg)!=iN) error("retFirst must be integer vector the same length as nrow(i)");
retFirst = INTEGER(retFirstArg);
if (!isInteger(retLengthArg) || LENGTH(retLengthArg)!=iN) error("retLength must be integer vector the same length as nrow(i)");
retLength = INTEGER(retLengthArg);
if (!isLogical(allLen1Arg) || LENGTH(allLen1Arg) != 1) error("allLen1 must be a length 1 logical vector");
allLen1 = LOGICAL(allLen1Arg);
if (!isLogical(rollendsArg) || LENGTH(rollendsArg) != 2) error("rollends must be a length 2 logical vector");
rollends = LOGICAL(rollendsArg);
if (nearest && TYPEOF(VECTOR_ELT(i, icols[ncol-1]-1))==STRSXP) error("roll='nearest' can't be applied to a character column, yet.");
for (int j=0; j<iN; j++) {
// defaults need to populated here as bmerge_r may well not touch many locations, say if the last row of i is before the first row of x.
retFirst[j] = INTEGER(nomatch)[0]; // default to no match for NA goto below
// retLength[j] = 0; // TO DO: do this to save the branch below and later branches at R level to set .N to 0
retLength[j] = INTEGER(nomatch)[0]==0 ? 0 : 1;
}
allLen1[0] = TRUE; // All-0 and All-NA are considered all length 1 according to R code currently. Really, it means any(length>1).
o = NULL;
if (!LOGICAL(isorted)[0]) {
SEXP order = PROTECT(vec_init(length(icolsArg), ScalarInteger(1))); // rep(1, length(icolsArg))
SEXP oSxp = PROTECT(forder(i, icolsArg, ScalarLogical(FALSE), ScalarLogical(TRUE), order, ScalarLogical(FALSE)));
protecti += 2;
if (!LENGTH(oSxp)) o = NULL;
else o = INTEGER(oSxp);
}
if (iN) bmerge_r(-1,xN,-1,iN,0,1,1);
UNPROTECT(protecti);
return(R_NilValue);
}
SEXP seqlib_generate_oligos(SEXP seqs, SEXP parameters)
{
const char *pname;
int i,j;
oligoDesignParms *parms;
parms = NewOligoDesignParmRec();
SEXP res,elm;
for (i=0; i< length(parameters); i++)
{
pname = CHAR(STRING_ELT(getAttrib(parameters,R_NamesSymbol), i));
elm = VECTOR_ELT(parameters,i);
if ((strcmp(pname,"t.melt")==0) && isReal(elm) && (length(elm) == 2))
{
parms->tm_min = REAL(elm)[0];
parms->tm_max = REAL(elm)[1];
}
else if ((strcmp(pname,"cg.content")==0) && isReal(elm) && (length(elm) == 2))
{
parms->cg_min = REAL(elm)[0];
parms->cg_max = REAL(elm)[1];
}
else if ((strcmp(pname,"oligo.len")==0) && isInteger(elm) && (length(elm) == 1))
{
parms->oligo_len = (INTEGER)(elm)[0];
}
else if ((strcmp(pname,"nimblegen.passes")==0) && isInteger(elm) && (length(elm) == 1))
{
parms->NimbleGenMaxPass = (INTEGER)(elm)[0];
}
else if ((strcmp(pname,"forbidden.sequences") == 0) && isString(elm) && (length(elm) >= 1))
{
parms->forbidden_seqs = (sequence_tp**)malloc(sizeof(sequence_tp*)*(length(elm)+1));
for (j=0; j<length(elm); j++)
parms->forbidden_seqs[j] = sequence_from_string(CHAR(STRING_ELT(elm,j)));
parms->forbidden_seqs[length(elm)] = NULL;
}
#ifdef DEBUG
else
{
fprintf(stderr,"Skipping unknown parameter %s : \n",pname);
if (isString(elm))
{
for (j=0; j<length(elm); j++)
fprintf(stderr,"String Value[%d] = %s\n",j,CHAR(STRING_ELT(elm, j)));
}
if (isReal(elm))
{
for (j=0; j<length(elm); j++)
fprintf(stderr," Real Value[%d] = %f\n",j,REAL(elm)[j]);
}
if (isInteger(elm))
{
for (j=0; j<length(elm); j++)
fprintf(stderr,"Int Value[%d] = %d\n",j,INTEGER(elm)[j]);
}
if (isLogical(elm))
{
for (j=0; j<length(elm); j++)
fprintf(stderr,"Logical Value[%d] = %d\n",j,LOGICAL(elm)[j]);
}
}
#endif
}
#ifdef DEBUG
fprintf(stderr," ----Generate oligos ----- \n");
fprintf(stderr,"cg : %f -%f \n",parms->cg_min,parms->cg_max);
fprintf(stderr,"tm : %f -%f \n",parms->tm_min,parms->tm_max);
fprintf(stderr,"oligo-len : %d \n",parms->oligo_len);
#endif
PROTECT(res = mkString("Done gen olis"));
UNPROTECT(1);
return res;
}
SEXP rgeos_geosring2Polygon(SEXP env, GEOSGeom lr, int hole) {
GEOSContextHandle_t GEOShandle = getContextHandle(env);
int pc=0;
GEOSCoordSeq s = (GEOSCoordSequence *) GEOSGeom_getCoordSeq_r(GEOShandle, lr);
if (s == NULL)
error("rgeos_geosring2Polygon: CoordSeq failure");
unsigned int n;
if (GEOSCoordSeq_getSize_r(GEOShandle, s, &n) == 0)
error("rgeos_geosring2Polygon: CoordSeq failure");
// Get coordinates
SEXP crd;
PROTECT(crd = rgeos_crdMatFixDir(PROTECT(rgeos_CoordSeq2crdMat(env, s, FALSE, hole)), hole)); pc += 2;
// Calculate area
GEOSGeom p = GEOSGeom_createPolygon_r(GEOShandle,GEOSGeom_clone_r(GEOShandle,lr),NULL,0);
if (p == NULL)
error("rgeos_geosring2Polygon: unable to create polygon");
SEXP area;
PROTECT(area = NEW_NUMERIC(1)); pc++;
NUMERIC_POINTER(area)[0] = 0.0;
if (!GEOSArea_r(GEOShandle, p, NUMERIC_POINTER(area)))
error("rgeos_geosring2Polygon: area calculation failure");
// Calculate label position
SEXP labpt;
PROTECT(labpt = NEW_NUMERIC(2)); pc++;
GEOSGeom centroid = GEOSGetCentroid_r(GEOShandle, p);
double xc, yc;
rgeos_Pt2xy(env, centroid, &xc, &yc);
if (!R_FINITE(xc) || !R_FINITE(yc)) {
xc = 0.0;
yc = 0.0;
for(int i=0; i != n; i++) {
xc += NUMERIC_POINTER(crd)[i];
yc += NUMERIC_POINTER(crd)[(int) (n) +i];
}
xc /= n;
yc /= n;
}
NUMERIC_POINTER(labpt)[0] = xc;
NUMERIC_POINTER(labpt)[1] = yc;
GEOSGeom_destroy_r(GEOShandle, centroid);
GEOSGeom_destroy_r(GEOShandle, p);
// Get ring direction
SEXP ringDir;
PROTECT(ringDir = NEW_INTEGER(1)); pc++;
INTEGER_POINTER(ringDir)[0] = hole ? -1 : 1;
// Get hole status
SEXP Hole;
PROTECT(Hole = NEW_LOGICAL(1)); pc++;
LOGICAL_POINTER(Hole)[0] = hole;
SEXP ans;
PROTECT(ans = NEW_OBJECT(MAKE_CLASS("Polygon"))); pc++;
SET_SLOT(ans, install("ringDir"), ringDir);
SET_SLOT(ans, install("labpt"), labpt);
SET_SLOT(ans, install("area"), area);
SET_SLOT(ans, install("hole"), Hole);
SET_SLOT(ans, install("coords"), crd);
SEXP valid;
PROTECT(valid = SP_PREFIX(Polygon_validate_c)(ans)); pc++;
if (!isLogical(valid)) {
UNPROTECT(pc);
if (isString(valid))
error(CHAR(STRING_ELT(valid, 0)));
else
error("invalid Polygon object");
}
UNPROTECT(pc);
return(ans);
}
SEXP attribute_hidden do_cat(SEXP call, SEXP op, SEXP args, SEXP rho)
{
cat_info ci;
RCNTXT cntxt;
SEXP objs, file, fill, sepr, labs, s;
int ifile;
Rconnection con;
int append;
int i, iobj, n, nobjs, pwidth, width, sepw, lablen, ntot, nlsep, nlines;
char buf[512];
const char *p = "";
checkArity(op, args);
/* Use standard printing defaults */
PrintDefaults();
objs = CAR(args);
args = CDR(args);
file = CAR(args);
ifile = asInteger(file);
con = getConnection(ifile);
if(!con->canwrite) /* if it is not open, we may not know yet */
error(_("cannot write to this connection"));
args = CDR(args);
sepr = CAR(args);
if (!isString(sepr))
error(_("invalid '%s' specification"), "sep");
nlsep = 0;
for (i = 0; i < LENGTH(sepr); i++)
if (strstr(CHAR(STRING_ELT(sepr, i)), "\n")) nlsep = 1; /* ASCII */
args = CDR(args);
fill = CAR(args);
if ((!isNumeric(fill) && !isLogical(fill)) || (length(fill) != 1))
error(_("invalid '%s' argument"), "fill");
if (isLogical(fill)) {
if (asLogical(fill) == 1)
pwidth = R_print.width;
else
pwidth = INT_MAX;
}
else pwidth = asInteger(fill);
if(pwidth <= 0) {
warning(_("non-positive 'fill' argument will be ignored"));
pwidth = INT_MAX;
}
args = CDR(args);
labs = CAR(args);
if (!isString(labs) && labs != R_NilValue)
error(_("invalid '%s' argument"), "labels");
lablen = length(labs);
args = CDR(args);
append = asLogical(CAR(args));
if (append == NA_LOGICAL)
error(_("invalid '%s' specification"), "append");
ci.wasopen = con->isopen;
ci.changedcon = switch_stdout(ifile, 0);
/* will open new connection if required, and check for writeable */
#ifdef Win32
/* do this after re-sinking output */
WinCheckUTF8();
#endif
ci.con = con;
/* set up a context which will close the connection if there is an error */
begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
R_NilValue, R_NilValue);
cntxt.cend = &cat_cleanup;
cntxt.cenddata = &ci;
nobjs = length(objs);
width = 0;
ntot = 0;
nlines = 0;
for (iobj = 0; iobj < nobjs; iobj++) {
s = VECTOR_ELT(objs, iobj);
if (iobj != 0 && !isNull(s))
cat_printsep(sepr, ntot++);
n = length(s);
/* 0-length objects are ignored */
if (n > 0) {
if (labs != R_NilValue && (iobj == 0)
&& (asInteger(fill) > 0)) {
Rprintf("%s ", trChar(STRING_ELT(labs, nlines % lablen)));
/* FIXME -- Rstrlen allows for double-width chars */
width += Rstrlen(STRING_ELT(labs, nlines % lablen), 0) + 1;
nlines++;
}
if (isString(s))
p = trChar(STRING_ELT(s, 0));
else if (isSymbol(s)) /* length 1 */
p = CHAR(PRINTNAME(s));
else if (isVectorAtomic(s)) {
/* Not a string, as that is covered above.
Thus the maximum size is about 60.
The copy is needed as cat_newline might reuse the buffer.
Use strncpy is in case these assumptions change.
*/
p = EncodeElement0(s, 0, 0, OutDec);
strncpy(buf, p, 512); buf[511] = '\0';
p = buf;
}
#ifdef fixed_cat
else if (isVectorList(s)) {
/* FIXME: call EncodeElement() for every element of s.
Real Problem: `s' can be large;
should do line breaking etc.. (buf is of limited size)
*/
}
#endif
else
errorcall(call,
_("argument %d (type '%s') cannot be handled by 'cat'"),
1+iobj, type2char(TYPEOF(s)));
/* FIXME : cat(...) should handle ANYTHING */
size_t w = strlen(p);
cat_sepwidth(sepr, &sepw, ntot);
if ((iobj > 0) && (width + w + sepw > pwidth)) {
cat_newline(labs, &width, lablen, nlines);
nlines++;
}
for (i = 0; i < n; i++, ntot++) {
Rprintf("%s", p);
width += (int)(w + sepw);
if (i < (n - 1)) {
cat_printsep(sepr, ntot);
if (isString(s))
p = trChar(STRING_ELT(s, i+1));
else {
p = EncodeElement0(s, i+1, 0, OutDec);
strncpy(buf, p, 512); buf[511] = '\0';
p = buf;
}
w = (int) strlen(p);
cat_sepwidth(sepr, &sepw, ntot);
/* This is inconsistent with the version above.
As from R 2.3.0, fill <= 0 is ignored. */
if ((width + w + sepw > pwidth) && pwidth) {
cat_newline(labs, &width, lablen, nlines);
nlines++;
}
} else ntot--; /* we don't print sep after last, so don't advance */
}
}
}
if ((pwidth != INT_MAX) || nlsep)
Rprintf("\n");
/* end the context after anything that could raise an error but before
doing the cleanup so the cleanup doesn't get done twice */
endcontext(&cntxt);
cat_cleanup(&ci);
return R_NilValue;
}
/* format.default(x, trim, digits, nsmall, width, justify, na.encode,
scientific) */
SEXP attribute_hidden do_format(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP l, x, y, swd;
int il, digits, trim = 0, nsmall = 0, wd = 0, adj = -1, na, sci = 0;
int w, d, e;
int wi, di, ei, scikeep;
const char *strp;
R_xlen_t i, n;
checkArity(op, args);
PrintDefaults();
scikeep = R_print.scipen;
if (isEnvironment(x = CAR(args))) {
return mkString(EncodeEnvironment(x));
}
else if (!isVector(x))
error(_("first argument must be atomic"));
args = CDR(args);
trim = asLogical(CAR(args));
if (trim == NA_INTEGER)
error(_("invalid '%s' argument"), "trim");
args = CDR(args);
if (!isNull(CAR(args))) {
digits = asInteger(CAR(args));
if (digits == NA_INTEGER || digits < R_MIN_DIGITS_OPT
|| digits > R_MAX_DIGITS_OPT)
error(_("invalid '%s' argument"), "digits");
R_print.digits = digits;
}
args = CDR(args);
nsmall = asInteger(CAR(args));
if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20)
error(_("invalid '%s' argument"), "nsmall");
args = CDR(args);
if (isNull(swd = CAR(args))) wd = 0; else wd = asInteger(swd);
if(wd == NA_INTEGER)
error(_("invalid '%s' argument"), "width");
args = CDR(args);
adj = asInteger(CAR(args));
if(adj == NA_INTEGER || adj < 0 || adj > 3)
error(_("invalid '%s' argument"), "justify");
args = CDR(args);
na = asLogical(CAR(args));
if(na == NA_LOGICAL)
error(_("invalid '%s' argument"), "na.encode");
args = CDR(args);
if(LENGTH(CAR(args)) != 1)
error(_("invalid '%s' argument"), "scientific");
if(isLogical(CAR(args))) {
int tmp = LOGICAL(CAR(args))[0];
if(tmp == NA_LOGICAL) sci = NA_INTEGER;
else sci = tmp > 0 ?-100 : 100;
} else if (isNumeric(CAR(args))) {
sci = asInteger(CAR(args));
} else
error(_("invalid '%s' argument"), "scientific");
if(sci != NA_INTEGER) R_print.scipen = sci;
if ((n = XLENGTH(x)) <= 0) {
PROTECT(y = allocVector(STRSXP, 0));
} else {
switch (TYPEOF(x)) {
case LGLSXP:
PROTECT(y = allocVector(STRSXP, n));
if (trim) w = 0; else formatLogical(LOGICAL(x), n, &w);
w = imax2(w, wd);
for (i = 0; i < n; i++) {
strp = EncodeLogical(LOGICAL(x)[i], w);
SET_STRING_ELT(y, i, mkChar(strp));
}
break;
case INTSXP:
PROTECT(y = allocVector(STRSXP, n));
if (trim) w = 0;
else formatInteger(INTEGER(x), n, &w);
w = imax2(w, wd);
for (i = 0; i < n; i++) {
strp = EncodeInteger(INTEGER(x)[i], w);
SET_STRING_ELT(y, i, mkChar(strp));
}
break;
case REALSXP:
formatReal(REAL(x), n, &w, &d, &e, nsmall);
if (trim) w = 0;
w = imax2(w, wd);
PROTECT(y = allocVector(STRSXP, n));
for (i = 0; i < n; i++) {
strp = EncodeReal0(REAL(x)[i], w, d, e, OutDec);
SET_STRING_ELT(y, i, mkChar(strp));
}
break;
case CPLXSXP:
formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall);
if (trim) wi = w = 0;
w = imax2(w, wd); wi = imax2(wi, wd);
PROTECT(y = allocVector(STRSXP, n));
for (i = 0; i < n; i++) {
strp = EncodeComplex(COMPLEX(x)[i], w, d, e, wi, di, ei, OutDec);
SET_STRING_ELT(y, i, mkChar(strp));
}
break;
case STRSXP:
{
/* this has to be different from formatString/EncodeString as
we don't actually want to encode here */
const char *s;
char *q;
int b, b0, cnt = 0, j;
SEXP s0, xx;
/* This is clumsy, but it saves rewriting and re-testing
this complex code */
PROTECT(xx = duplicate(x));
for (i = 0; i < n; i++) {
SEXP tmp = STRING_ELT(xx, i);
if(IS_BYTES(tmp)) {
const char *p = CHAR(tmp), *q;
char *pp = R_alloc(4*strlen(p)+1, 1), *qq = pp, buf[5];
for (q = p; *q; q++) {
unsigned char k = (unsigned char) *q;
if (k >= 0x20 && k < 0x80) {
*qq++ = *q;
} else {
snprintf(buf, 5, "\\x%02x", k);
for(int j = 0; j < 4; j++) *qq++ = buf[j];
}
}
*qq = '\0';
s = pp;
} else s = translateChar(tmp);
if(s != CHAR(tmp)) SET_STRING_ELT(xx, i, mkChar(s));
}
w = wd;
if (adj != Rprt_adj_none) {
for (i = 0; i < n; i++)
if (STRING_ELT(xx, i) != NA_STRING)
w = imax2(w, Rstrlen(STRING_ELT(xx, i), 0));
else if (na) w = imax2(w, R_print.na_width);
} else w = 0;
/* now calculate the buffer size needed, in bytes */
for (i = 0; i < n; i++)
if (STRING_ELT(xx, i) != NA_STRING) {
il = Rstrlen(STRING_ELT(xx, i), 0);
cnt = imax2(cnt, LENGTH(STRING_ELT(xx, i)) + imax2(0, w-il));
} else if (na) cnt = imax2(cnt, R_print.na_width + imax2(0, w-R_print.na_width));
R_CheckStack2(cnt+1);
char buff[cnt+1];
PROTECT(y = allocVector(STRSXP, n));
for (i = 0; i < n; i++) {
if(!na && STRING_ELT(xx, i) == NA_STRING) {
SET_STRING_ELT(y, i, NA_STRING);
} else {
q = buff;
if(STRING_ELT(xx, i) == NA_STRING) s0 = R_print.na_string;
else s0 = STRING_ELT(xx, i) ;
s = CHAR(s0);
il = Rstrlen(s0, 0);
b = w - il;
if(b > 0 && adj != Rprt_adj_left) {
b0 = (adj == Rprt_adj_centre) ? b/2 : b;
for(j = 0 ; j < b0 ; j++) *q++ = ' ';
b -= b0;
}
for(j = 0; j < LENGTH(s0); j++) *q++ = *s++;
if(b > 0 && adj != Rprt_adj_right)
for(j = 0 ; j < b ; j++) *q++ = ' ';
*q = '\0';
SET_STRING_ELT(y, i, mkChar(buff));
}
}
}
UNPROTECT(2); /* xx , y */
PROTECT(y);
break;
default:
error(_("Impossible mode ( x )")); y = R_NilValue;/* -Wall */
}
}
if((l = getAttrib(x, R_DimSymbol)) != R_NilValue) {
setAttrib(y, R_DimSymbol, l);
if((l = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
setAttrib(y, R_DimNamesSymbol, l);
} else if((l = getAttrib(x, R_NamesSymbol)) != R_NilValue)
setAttrib(y, R_NamesSymbol, l);
/* In case something else forgets to set PrintDefaults(), PR#14477 */
R_print.scipen = scikeep;
UNPROTECT(1); /* y */
return y;
}
SEXP hitrun(SEXP alpha, SEXP initial, SEXP nbatch, SEXP blen, SEXP nspac,
SEXP origin, SEXP basis, SEXP amat, SEXP bvec, SEXP outmat, SEXP debug)
{
if (! isReal(alpha))
error("argument \"alpha\" must be type double");
if (! isReal(initial))
error("argument \"initial\" must be type double");
if (! isInteger(nbatch))
error("argument \"nbatch\" must be type integer");
if (! isInteger(blen))
error("argument \"blen\" must be type integer");
if (! isInteger(nspac))
error("argument \"nspac\" must be type integer");
if (! isReal(origin))
error("argument \"origin\" must be type double");
if (! isReal(basis))
error("argument \"basis\" must be type double");
if (! isReal(amat))
error("argument \"amat\" must be type double");
if (! isReal(bvec))
error("argument \"bvec\" must be type double");
if (! (isNull(outmat) | isReal(outmat)))
error("argument \"outmat\" must be type double or NULL");
if (! isLogical(debug))
error("argument \"debug\" must be logical");
if (! isMatrix(basis))
error("argument \"basis\" must be matrix");
if (! isMatrix(amat))
error("argument \"amat\" must be matrix");
if (! (isNull(outmat) | isMatrix(outmat)))
error("argument \"outmat\" must be matrix or NULL");
int dim_oc = LENGTH(alpha);
int dim_nc = LENGTH(initial);
int ncons = nrows(amat);
if (LENGTH(nbatch) != 1)
error("argument \"nbatch\" must be scalar");
if (LENGTH(blen) != 1)
error("argument \"blen\" must be scalar");
if (LENGTH(nspac) != 1)
error("argument \"nspac\" must be scalar");
if (LENGTH(origin) != dim_oc)
error("length(origin) != length(alpha)");
if (nrows(basis) != dim_oc)
error("nrow(basis) != length(alpha)");
if (ncols(basis) != dim_nc)
error("ncol(basis) != length(initial)");
if (ncols(amat) != dim_nc)
error("ncol(amat) != length(initial)");
if (LENGTH(bvec) != ncons)
error("length(bvec) != nrow(amat)");
if (LENGTH(debug) != 1)
error("argument \"debug\" must be scalar");
int dim_out = dim_oc;
if (! isNull(outmat)) {
dim_out = nrows(outmat);
if (ncols(outmat) != dim_oc)
error("ncol(outmat) != length(alpha)");
}
int int_nbatch = INTEGER(nbatch)[0];
int int_blen = INTEGER(blen)[0];
int int_nspac = INTEGER(nspac)[0];
int int_debug = LOGICAL(debug)[0];
double *dbl_star_alpha = REAL(alpha);
double *dbl_star_initial = REAL(initial);
double *dbl_star_origin = REAL(origin);
double *dbl_star_basis = REAL(basis);
double *dbl_star_amat = REAL(amat);
double *dbl_star_bvec = REAL(bvec);
int has_outmat = isMatrix(outmat);
double *dbl_star_outmat = 0;
if (has_outmat)
dbl_star_outmat = REAL(outmat);
if (int_nbatch <= 0)
error("argument \"nbatch\" must be positive");
if (int_blen <= 0)
error("argument \"blen\" must be positive");
if (int_nspac <= 0)
error("argument \"nspac\" must be positive");
check_finite(dbl_star_alpha, dim_oc, "alpha");
check_positive(dbl_star_alpha, dim_oc, "alpha");
check_finite(dbl_star_initial, dim_nc, "initial");
check_finite(dbl_star_origin, dim_oc, "origin");
check_finite(dbl_star_basis, dim_oc * dim_nc, "basis");
check_finite(dbl_star_amat, ncons * dim_nc, "amat");
check_finite(dbl_star_bvec, ncons, "bvec");
if (has_outmat)
check_finite(dbl_star_outmat, dim_out * dim_oc, "outmat");
double *state = (double *) R_alloc(dim_nc, sizeof(double));
double *proposal = (double *) R_alloc(dim_nc, sizeof(double));
double *batch_buffer = (double *) R_alloc(dim_out, sizeof(double));
double *out_buffer = (double *) R_alloc(dim_out, sizeof(double));
memcpy(state, dbl_star_initial, dim_nc * sizeof(double));
logh_setup(dbl_star_alpha, dbl_star_origin, dbl_star_basis, dim_oc, dim_nc);
double current_log_dens = logh(state);
out_setup(dbl_star_origin, dbl_star_basis, dbl_star_outmat, dim_oc, dim_nc,
dim_out, has_outmat);
SEXP result, resultnames, path, save_initial, save_final;
if (! int_debug) {
PROTECT(result = allocVector(VECSXP, 3));
PROTECT(resultnames = allocVector(STRSXP, 3));
} else {
PROTECT(result = allocVector(VECSXP, 11));
PROTECT(resultnames = allocVector(STRSXP, 11));
}
PROTECT(path = allocMatrix(REALSXP, dim_out, int_nbatch));
SET_VECTOR_ELT(result, 0, path);
PROTECT(save_initial = duplicate(initial));
SET_VECTOR_ELT(result, 1, save_initial);
UNPROTECT(2);
SET_STRING_ELT(resultnames, 0, mkChar("batch"));
SET_STRING_ELT(resultnames, 1, mkChar("initial"));
SET_STRING_ELT(resultnames, 2, mkChar("final"));
if (int_debug) {
SEXP spath, ppath, zpath, u1path, u2path, s1path, s2path, gpath;
int nn = int_nbatch * int_blen * int_nspac;
PROTECT(spath = allocMatrix(REALSXP, dim_nc, nn));
SET_VECTOR_ELT(result, 3, spath);
PROTECT(ppath = allocMatrix(REALSXP, dim_nc, nn));
SET_VECTOR_ELT(result, 4, ppath);
PROTECT(zpath = allocMatrix(REALSXP, dim_nc, nn));
SET_VECTOR_ELT(result, 5, zpath);
PROTECT(u1path = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 6, u1path);
PROTECT(u2path = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 7, u2path);
PROTECT(s1path = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 8, s1path);
PROTECT(s2path = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 9, s2path);
PROTECT(gpath = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 10, gpath);
UNPROTECT(8);
SET_STRING_ELT(resultnames, 3, mkChar("current"));
SET_STRING_ELT(resultnames, 4, mkChar("proposal"));
SET_STRING_ELT(resultnames, 5, mkChar("z"));
SET_STRING_ELT(resultnames, 6, mkChar("u1"));
SET_STRING_ELT(resultnames, 7, mkChar("u2"));
SET_STRING_ELT(resultnames, 8, mkChar("s1"));
SET_STRING_ELT(resultnames, 9, mkChar("s2"));
SET_STRING_ELT(resultnames, 10, mkChar("log.green"));
}
namesgets(result, resultnames);
UNPROTECT(1);
GetRNGstate();
if (current_log_dens == R_NegInf)
error("log unnormalized density -Inf at initial state");
for (int ibatch = 0, k = 0; ibatch < int_nbatch; ibatch++) {
for (int i = 0; i < dim_out; i++)
batch_buffer[i] = 0.0;
for (int jbatch = 0; jbatch < int_blen; jbatch++) {
double proposal_log_dens;
for (int ispac = 0; ispac < int_nspac; ispac++) {
/* Note: should never happen! */
if (current_log_dens == R_NegInf)
error("log density -Inf at current state");
double u1 = R_NaReal;
double u2 = R_NaReal;
double smax = R_NaReal;
double smin = R_NaReal;
double z[dim_nc];
propose(state, proposal, dbl_star_amat, dbl_star_bvec,
dim_nc, ncons, z, &smax, &smin, &u1);
proposal_log_dens = logh(proposal);
int accept = FALSE;
if (proposal_log_dens != R_NegInf) {
if (proposal_log_dens >= current_log_dens) {
accept = TRUE;
} else {
double green = exp(proposal_log_dens
- current_log_dens);
u2 = unif_rand();
accept = u2 < green;
}
}
if (int_debug) {
int l = ispac + int_nspac * (jbatch + int_blen * ibatch);
int lbase = l * dim_nc;
SEXP spath = VECTOR_ELT(result, 3);
SEXP ppath = VECTOR_ELT(result, 4);
SEXP zpath = VECTOR_ELT(result, 5);
SEXP u1path = VECTOR_ELT(result, 6);
SEXP u2path = VECTOR_ELT(result, 7);
SEXP s1path = VECTOR_ELT(result, 8);
SEXP s2path = VECTOR_ELT(result, 9);
SEXP gpath = VECTOR_ELT(result, 10);
for (int lj = 0; lj < dim_nc; lj++) {
REAL(spath)[lbase + lj] = state[lj];
REAL(ppath)[lbase + lj] = proposal[lj];
REAL(zpath)[lbase + lj] = z[lj];
}
REAL(u1path)[l] = u1;
REAL(u2path)[l] = u2;
REAL(s1path)[l] = smin;
REAL(s2path)[l] = smax;
REAL(gpath)[l] = proposal_log_dens - current_log_dens;
}
if (accept) {
memcpy(state, proposal, dim_nc * sizeof(double));
current_log_dens = proposal_log_dens;
}
} /* end of inner loop (one iteration) */
outfun(state, out_buffer);
for (int j = 0; j < dim_out; j++)
batch_buffer[j] += out_buffer[j];
} /* end of middle loop (one batch) */
for (int j = 0; j < dim_out; j++, k++)
REAL(path)[k] = batch_buffer[j] / int_blen;
} /* end of outer loop */
PutRNGstate();
PROTECT(save_final = allocVector(REALSXP, dim_nc));
memcpy(REAL(save_final), state, dim_nc * sizeof(double));
SET_VECTOR_ELT(result, 2, save_final);
UNPROTECT(5);
return result;
}
SEXP impliedLinearity(SEXP m, SEXP h)
{
GetRNGstate();
if (! isMatrix(m))
error("'m' must be matrix");
if (! isLogical(h))
error("'h' must be logical");
if (LENGTH(h) != 1)
error("'h' must be scalar");
if (! isString(m))
error("'m' must be character");
SEXP m_dim;
PROTECT(m_dim = getAttrib(m, R_DimSymbol));
int nrow = INTEGER(m_dim)[0];
int ncol = INTEGER(m_dim)[1];
UNPROTECT(1);
if (nrow <= 1)
error("no use if only one row");
if (ncol <= 3)
error("no use if only one col");
for (int i = 0; i < nrow; i++) {
const char *foo = CHAR(STRING_ELT(m, i));
if (strlen(foo) != 1)
error("column one of 'm' not zero-or-one valued");
if (! (foo[0] == '0' || foo[0] == '1'))
error("column one of 'm' not zero-or-one valued");
}
if (! LOGICAL(h)[0])
for (int i = nrow; i < 2 * nrow; i++) {
const char *foo = CHAR(STRING_ELT(m, i));
if (strlen(foo) != 1)
error("column two of 'm' not zero-or-one valued");
if (! (foo[0] == '0' || foo[0] == '1'))
error("column two of 'm' not zero-or-one valued");
}
dd_set_global_constants();
/* note actual type of "value" is mpq_t (defined in cddmp.h) */
mytype value;
dd_init(value);
dd_MatrixPtr mf = dd_CreateMatrix(nrow, ncol - 1);
/* note our matrix has one more column than Fukuda's */
/* representation */
if(LOGICAL(h)[0])
mf->representation = dd_Inequality;
else
mf->representation = dd_Generator;
mf->numbtype = dd_Rational;
/* linearity */
for (int i = 0; i < nrow; i++) {
const char *foo = CHAR(STRING_ELT(m, i));
if (foo[0] == '1')
set_addelem(mf->linset, i + 1);
/* note conversion from zero-origin to one-origin indexing */
}
/* matrix */
for (int j = 1, k = nrow; j < ncol; j++)
for (int i = 0; i < nrow; i++, k++) {
const char *rat_str = CHAR(STRING_ELT(m, k));
if (mpq_set_str(value, rat_str, 10) == -1) {
dd_FreeMatrix(mf);
dd_clear(value);
dd_free_global_constants();
error("error converting string to GMP rational");
}
mpq_canonicalize(value);
dd_set(mf->matrix[i][j - 1], value);
/* note our matrix has one more column than Fukuda's */
}
dd_ErrorType err = dd_NoError;
dd_rowset out = dd_ImplicitLinearityRows(mf, &err);
if (err != dd_NoError) {
rr_WriteErrorMessages(err);
set_free(out);
dd_FreeMatrix(mf);
dd_clear(value);
dd_free_global_constants();
error("failed");
}
SEXP foo;
PROTECT(foo = rr_set_fwrite(out));
set_free(out);
dd_FreeMatrix(mf);
dd_clear(value);
dd_free_global_constants();
PutRNGstate();
UNPROTECT(1);
return foo;
}
SEXP bmerge(SEXP iArg, SEXP xArg, SEXP icolsArg, SEXP xcolsArg, SEXP isorted, SEXP xoArg, SEXP rollarg, SEXP rollendsArg, SEXP nomatchArg, SEXP multArg, SEXP opArg, SEXP nqgrpArg, SEXP nqmaxgrpArg) {
int xN, iN, protecti=0;
ctr=0; // needed for non-equi join case
SEXP retFirstArg, retLengthArg, retIndexArg, allLen1Arg, allGrp1Arg;
retFirstArg = retLengthArg = retIndexArg = R_NilValue; // suppress gcc msg
// iArg, xArg, icolsArg and xcolsArg
i = iArg; x = xArg; // set globals so bmerge_r can see them.
if (!isInteger(icolsArg)) error("Internal error: icols is not integer vector");
if (!isInteger(xcolsArg)) error("Internal error: xcols is not integer vector");
if (LENGTH(icolsArg) > LENGTH(xcolsArg)) error("Internal error: length(icols) [%d] > length(xcols) [%d]", LENGTH(icolsArg), LENGTH(xcolsArg));
icols = INTEGER(icolsArg);
xcols = INTEGER(xcolsArg);
xN = LENGTH(VECTOR_ELT(x,0));
iN = ilen = anslen = LENGTH(VECTOR_ELT(i,0));
ncol = LENGTH(icolsArg); // there may be more sorted columns in x than involved in the join
for(int col=0; col<ncol; col++) {
if (icols[col]==NA_INTEGER) error("Internal error. icols[%d] is NA", col);
if (xcols[col]==NA_INTEGER) error("Internal error. xcols[%d] is NA", col);
if (icols[col]>LENGTH(i) || icols[col]<1) error("icols[%d]=%d outside range [1,length(i)=%d]", col, icols[col], LENGTH(i));
if (xcols[col]>LENGTH(x) || xcols[col]<1) error("xcols[%d]=%d outside range [1,length(x)=%d]", col, xcols[col], LENGTH(x));
int it = TYPEOF(VECTOR_ELT(i, icols[col]-1));
int xt = TYPEOF(VECTOR_ELT(x, xcols[col]-1));
if (it != xt) error("typeof x.%s (%s) != typeof i.%s (%s)", CHAR(STRING_ELT(getAttrib(x,R_NamesSymbol),xcols[col]-1)), type2char(xt), CHAR(STRING_ELT(getAttrib(i,R_NamesSymbol),icols[col]-1)), type2char(it));
}
// raise(SIGINT);
// rollArg, rollendsArg
roll = 0.0; rollToNearest = FALSE;
if (isString(rollarg)) {
if (strcmp(CHAR(STRING_ELT(rollarg,0)),"nearest") != 0) error("roll is character but not 'nearest'");
roll=1.0; rollToNearest=TRUE; // the 1.0 here is just any non-0.0, so roll!=0.0 can be used later
} else {
if (!isReal(rollarg)) error("Internal error: roll is not character or double");
roll = REAL(rollarg)[0]; // more common case (rolling forwards or backwards) or no roll when 0.0
}
rollabs = fabs(roll);
if (!isLogical(rollendsArg) || LENGTH(rollendsArg) != 2)
error("rollends must be a length 2 logical vector");
rollends = LOGICAL(rollendsArg);
if (rollToNearest && TYPEOF(VECTOR_ELT(i, icols[ncol-1]-1))==STRSXP)
error("roll='nearest' can't be applied to a character column, yet.");
// nomatch arg
nomatch = INTEGER(nomatchArg)[0];
// mult arg
if (!strcmp(CHAR(STRING_ELT(multArg, 0)), "all")) mult = ALL;
else if (!strcmp(CHAR(STRING_ELT(multArg, 0)), "first")) mult = FIRST;
else if (!strcmp(CHAR(STRING_ELT(multArg, 0)), "last")) mult = LAST;
else error("Internal error: invalid value for 'mult'. Please report to datatable-help");
// opArg
if (!isInteger(opArg) || length(opArg) != ncol)
error("Internal error: opArg is not an integer vector of length equal to length(on)");
op = INTEGER(opArg);
if (!isInteger(nqgrpArg))
error("Internal error: nqgrpArg must be an integer vector");
nqgrp = nqgrpArg; // set global for bmerge_r
scols = (!length(nqgrpArg)) ? 0 : -1; // starting col index, -1 is external group column for non-equi join case
// nqmaxgrpArg
if (!isInteger(nqmaxgrpArg) || length(nqmaxgrpArg) != 1 || INTEGER(nqmaxgrpArg)[0] <= 0)
error("Intrnal error: nqmaxgrpArg is not a positive length-1 integer vector");
nqmaxgrp = INTEGER(nqmaxgrpArg)[0];
if (nqmaxgrp>1 && mult == ALL) {
// non-equi case with mult=ALL, may need reallocation
anslen = 1.1 * ((iN > 1000) ? iN : 1000);
retFirst = Calloc(anslen, int); // anslen is set above
retLength = Calloc(anslen, int);
retIndex = Calloc(anslen, int);
if (retFirst==NULL || retLength==NULL || retIndex==NULL)
error("Internal error in allocating memory for non-equi join");
// initialise retIndex here directly, as next loop is meant for both equi and non-equi joins
for (int j=0; j<anslen; j++) retIndex[j] = j+1;
} else { // equi joins (or) non-equi join but no multiple matches
