示例#1
0
文件: align.c 项目: rforge/gtdb
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;
}
示例#2
0
文件: cum.c 项目: Bgods/r-source
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 */
}
示例#3
0
文件: align.c 项目: rforge/gtdb
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);
}
示例#4
0
/*
 *  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);
}
示例#5
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());
}
示例#6
0
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());
}
示例#7
0
/*
   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;
}
示例#8
0
文件: relop.c 项目: SensePlatform/R
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;
}
示例#9
0
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);
}
示例#10
0
文件: SeqLibR.c 项目: UvA-MAD/SeqLibR
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;
	
}
示例#11
0
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);
}
示例#12
0
文件: builtin.c 项目: o-/Rexperiments
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;
}
示例#13
0
文件: paste.c 项目: jagdeesh109/RRO
/* 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;
}
示例#14
0
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;
}
示例#15
0
文件: linearity.c 项目: cjgeyer/rcdd
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;
}
示例#16
0
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