Example #1
0
SEXP dt_na(SEXP x, SEXP cols) {
    int i, j, n=0, this;
    double *dv;
    SEXP v, ans, class;
    
    if (!isNewList(x)) error("Internal error. Argument 'x' to Cdt_na is type '%s' not 'list'", type2char(TYPEOF(x)));
    if (!isInteger(cols)) error("Internal error. Argument 'cols' to Cdt_na is type '%s' not 'integer'", type2char(TYPEOF(cols)));
    for (i=0; i<LENGTH(cols); i++) {
        this = INTEGER(cols)[i];
        if (this<1 || this>LENGTH(x)) 
            error("Item %d of 'cols' is %d which is outside 1-based range [1,ncol(x)=%d]", i+1, this, LENGTH(x));
        if (!n) n = length(VECTOR_ELT(x, this-1));
    }
    ans = PROTECT(allocVector(LGLSXP, n));
    for (i=0; i<n; i++) LOGICAL(ans)[i]=0;
    for (i=0; i<LENGTH(cols); i++) {
        v = VECTOR_ELT(x, INTEGER(cols)[i]-1);
        if (!length(v) || isNewList(v) || isList(v)) continue; // like stats:::na.omit.data.frame, skip list/pairlist columns
        if (n != length(v))
            error("Column %d of input list x is length %d, inconsistent with first column of that item which is length %d.", i+1,length(v),n);
        switch (TYPEOF(v)) {
        case LGLSXP:
            for (j=0; j<n; j++) LOGICAL(ans)[j] |= (LOGICAL(v)[j] == NA_LOGICAL);
            break;
        case INTSXP:
            for (j=0; j<n; j++) LOGICAL(ans)[j] |= (INTEGER(v)[j] == NA_INTEGER);
            break;
        case STRSXP:
            for (j=0; j<n; j++) LOGICAL(ans)[j] |= (STRING_ELT(v, j) == NA_STRING);
            break;
        case REALSXP:
            class = getAttrib(v, R_ClassSymbol);        
            if (isString(class) && STRING_ELT(class, 0) == char_integer64) {
                dv = (double *)REAL(v);
                for (j=0; j<n; j++) {
                    u.d = dv[j];
                    LOGICAL(ans)[j] |= (u.ull == NAINT64);
                }
            } else {
                for (j=0; j<n; j++) LOGICAL(ans)[j] |= ISNAN(REAL(v)[j]);
            }
            break;
        case RAWSXP: 
            // no such thing as a raw NA
            // vector already initialised to all 0's
            break;
        case CPLXSXP:
            // taken from https://github.com/wch/r-source/blob/d75f39d532819ccc8251f93b8ab10d5b83aac89a/src/main/coerce.c
            for (j=0; j<n; j++) LOGICAL(ans)[j] |= (ISNAN(COMPLEX(v)[j].r) || ISNAN(COMPLEX(v)[j].i));
            break;
        default:
            error("Unknown column type '%s'", type2char(TYPEOF(v)));
        }
    }
Example #2
0
SEXP sankoff3(SEXP dlist, SEXP scost, SEXP nr, SEXP nc, SEXP node, SEXP edge, SEXP mNodes, SEXP tips) {
    R_len_t i, n = length(node), nt = length(tips);
    int nrx=INTEGER(nr)[0], ncx=INTEGER(nc)[0], mn=INTEGER(mNodes)[0];
    int  ni, ei, j, *edges=INTEGER(edge), *nodes=INTEGER(node);
    SEXP result, dlist2; //tmp,
    double *res, *cost; // *rtmp,
    cost = REAL(scost);
    if(!isNewList(dlist)) error("'dlist' must be a list");
    ni = nodes[0];
    PROTECT(dlist2 = allocVector(VECSXP, mn));
    PROTECT(result = allocMatrix(REALSXP, nrx, ncx));
    res = REAL(result);
    for(i = 0; i < nt; i++) SET_VECTOR_ELT(dlist2, INTEGER(tips)[i], VECTOR_ELT(dlist, INTEGER(tips)[i]));
    for(j=0; j<(nrx * ncx); j++) res[j] = 0.0;

    for(i = 0; i < n; i++) {
        ei = edges[i];
        if(ni == nodes[i]) {
            sankoff4(REAL(VECTOR_ELT(dlist2,ei)), nrx, cost, ncx, res);
        }
        else {
            SET_VECTOR_ELT(dlist2, ni, result);
            UNPROTECT(1);
            PROTECT(result = allocMatrix(REALSXP, nrx, ncx));
            res = REAL(result);
            for(j=0; j<(nrx * ncx); j++) res[j] = 0.0;
            ni = nodes[i];
            sankoff4(REAL(VECTOR_ELT(dlist2,ei)), nrx, cost, ncx, res);
        }
    }
    SET_VECTOR_ELT(dlist2, ni, result);
    UNPROTECT(2);
    return(dlist2);
}
Example #3
0
fragment_finder::fragment_finder(SEXP starts, SEXP ends) {
	if (!isNewList(starts) || !isNewList(ends)) { throw std::runtime_error("start/end positions should each be a list of integer vectors"); }
	const int nnames=LENGTH(starts);
	if (nnames!=LENGTH(ends)) { throw std::runtime_error("number of names does not correspond to number of start/end position vectors"); }
	
	for (int i=0; i<nnames; ++i) {
		SEXP current1=VECTOR_ELT(starts, i);
		if (!isInteger(current1)) { throw std::runtime_error("start vector should be integer"); }
		SEXP current2=VECTOR_ELT(ends, i);
		if (!isInteger(current2)) { throw std::runtime_error("end vector should be integer"); }
		const int ncuts=LENGTH(current1);
		if (LENGTH(current2)!=ncuts) { throw std::runtime_error("start/end vectors should have the same length"); }
		pos.push_back(chr_stats(INTEGER(current1), INTEGER(current2), ncuts));	
	}
	return;
}
Example #4
0
SEXP set_factors(SEXP obj, SEXP val, char *nm)
{
    SEXP fac = GET_SLOT(obj, Matrix_factorSym),
	nms = getAttrib(fac, R_NamesSymbol), nfac, nnms;
    int i, len = length(fac);

    if ((!isNewList(fac)) || (length(fac) > 0 && nms == R_NilValue))
	error("factors slot must be a named list");
    for (i = 0; i < len; i++) {
	if (!strcmp(nm, CHAR(STRING_ELT(nms, i)))) {
	    SET_VECTOR_ELT(fac, i, duplicate(val));
	    return val;
	}
    }
    nfac = PROTECT(allocVector(VECSXP, len + 1));
    nnms = PROTECT(allocVector(STRSXP, len + 1));
    setAttrib(nfac, R_NamesSymbol, nnms);
    for (i = 0; i < len; i++) {
	SET_VECTOR_ELT(nfac, i, VECTOR_ELT(fac, i));
	SET_STRING_ELT(nnms, i, duplicate(STRING_ELT(nms, i)));
    }
    SET_VECTOR_ELT(nfac, len, duplicate(val));
    SET_STRING_ELT(nnms, len, mkChar(nm));
    SET_SLOT(obj, Matrix_factorSym, nfac);
    UNPROTECT(2);
    return val;
}
Example #5
0
SEXP getd2PM2(SEXP eig, SEXP nc, SEXP el, SEXP w){
    R_len_t i, j, nel, nw;
    int m=INTEGER(nc)[0], l=0;
    double *ws=REAL(w);
    double *edgelen=REAL(el);
    double *eva, *eve, *evei;
    SEXP P, RESULT;
    nel = length(el);
    nw = length(w);
    eva = REAL(VECTOR_ELT(eig, 0));
    eve = REAL(VECTOR_ELT(eig, 1));
    evei = REAL(VECTOR_ELT(eig, 2));
    PROTECT(RESULT = allocVector(VECSXP, nel*nw));    
    double *p;
    if(!isNewList(eig)) error("'dlist' must be a list");    
    for(j=0; j<nel; j++){
        for(i=0; i<nw; i++){
            PROTECT(P = allocMatrix(REALSXP, m, m));
            p = REAL(P);
            getd2P2(eva, eve, evei, m, edgelen[j], ws[i], p);
            SET_VECTOR_ELT(RESULT, l, P);
            UNPROTECT(1); //P
            l++;
        }
    }
    UNPROTECT(1); //RESULT
    return(RESULT);
} 
Example #6
0
SEXP setlistelt(SEXP l, SEXP i, SEXP value)
{
    R_len_t i2;
    // Internal use only. So that := can update elements of a list of data.table, #2204. Just needed to overallocate/grow the VECSXP.
    if (!isNewList(l)) error("First argument to setlistelt must be a list()");
    if (!isInteger(i) || LENGTH(i)!=1) error("Second argument to setlistelt must a length 1 integer vector");
    i2 = INTEGER(i)[0];
    if (LENGTH(l) < i2 || i2<1) error("i (%d) is outside the range of items [1,%d]",i2,LENGTH(l));
    SET_VECTOR_ELT(l, i2-1, value);
    return(R_NilValue);
}
Example #7
0
/**
 * Return the element of a given name from a named list
 *
 * @param list
 * @param nm name of desired element
 *
 * @return element of list with name nm
 */
static R_INLINE SEXP getListElement(SEXP list, char *nm)
{
    int i; SEXP names = getAttrib(list, R_NamesSymbol);

    if (!isNewList(list) || LENGTH(names) != LENGTH(list))
	error(("'getElement' applies only to named lists"));
    for (i = 0; i < LENGTH(list); i++)
	if (!strcmp(CHAR(STRING_ELT(names, i)), nm)) /* ASCII only */
	    return(VECTOR_ELT(list, i));
    return R_NilValue;
}
Example #8
0
File: list.c Project: wch/rspeed
// Set the value of an item in a list, in-place
SEXP C_set_list_item(SEXP x, SEXP idx, SEXP value) {
  if (!isNewList(x))
    error("x must be a list");
  if (!isNumeric(idx))
    error("idx must be a numeric");

  int i = asInteger(idx);
  if (i < 1 || i > length(x))
    error("i must a number between 1 and the length of the list");

  SET_VECTOR_ELT(x, i-1, value);
  return x;
}
Example #9
0
static SEXP do_one(SEXP X, SEXP FUN, SEXP classes, SEXP deflt,
		   Rboolean replace, SEXP rho)
{
    SEXP ans, names, klass;
    int i, j, n;
    Rboolean matched = FALSE;

    /* if X is a list, recurse.  Otherwise if it matches classes call f */
    if(isNewList(X)) {
	n = length(X);
  if (replace) {
    PROTECT(ans = shallow_duplicate(X));
  } else {
    PROTECT(ans = allocVector(VECSXP, n));
    names = getAttrib(X, R_NamesSymbol);
    if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
  }
	for(i = 0; i < n; i++)
	    SET_VECTOR_ELT(ans, i, do_one(VECTOR_ELT(X, i), FUN, classes,
					  deflt, replace, rho));
	UNPROTECT(1);
	return ans;
    }
    if(strcmp(CHAR(STRING_ELT(classes, 0)), "ANY") == 0) /* ASCII */
	matched = TRUE;
    else {
	PROTECT(klass = R_data_class(X, FALSE));
	for(i = 0; i < LENGTH(klass); i++)
	    for(j = 0; j < length(classes); j++)
		if(Seql(STRING_ELT(klass, i), STRING_ELT(classes, j)))
		    matched = TRUE;
	UNPROTECT(1);
    }
    if(matched) {
	/* This stores value to which the function is to be applied in
	   a variable X in the environment of the rapply closure call
	   that calls into the rapply .Internal. */
	SEXP R_fcall; /* could allocate once and preserve for re-use */
	SEXP Xsym = install("X");
	defineVar(Xsym, X, rho);
	INCREMENT_NAMED(X);
	/* PROTECT(R_fcall = lang2(FUN, Xsym)); */
	PROTECT(R_fcall = lang3(FUN, Xsym, R_DotsSymbol));
	ans = R_forceAndCall(R_fcall, 1, rho);
	if (MAYBE_REFERENCED(ans))
	    ans = lazy_duplicate(ans);
	UNPROTECT(1);
	return(ans);
    } else if(replace) return lazy_duplicate(X);
    else return lazy_duplicate(deflt);
}
Example #10
0
SEXP get_factors(SEXP obj, char *nm)
{
    SEXP fac = GET_SLOT(obj, Matrix_factorSym),
	nms = getAttrib(fac, R_NamesSymbol);
    int i, len = length(fac);

    if ((!isNewList(fac)) || (length(fac) > 0 && nms == R_NilValue))
	error("factors slot must be a named list");
    for (i = 0; i < len; i++) {
	if (!strcmp(nm, CHAR(STRING_ELT(nms, i)))) {
	    return VECTOR_ELT(fac, i);
	}
    }
    return R_NilValue;
}
Example #11
0
SEXP lapply(SEXP list, SEXP expr, SEXP rho)
{
    int i, n = length(list);
    SEXP ans;

    if(!isNewList(list)) error("`list' must be a list");
    if(!isEnvironment(rho)) error("`rho' should be an environment");
    PROTECT(ans = allocVector(VECSXP, n));
    for(i = 0; i < n; i++) {
	defineVar(install("x"), VECTOR_ELT(list, i), rho);
	SET_VECTOR_ELT(ans, i, eval(expr, rho));
    }
    setAttrib(ans, R_NamesSymbol, getAttrib(list, R_NamesSymbol));
    UNPROTECT(1);
    return(ans);
}
Example #12
0
dpoMatrix::dpoMatrix(SEXP x) {
    if (!(IS_S4_OBJECT(x)))
	error(_("S4 object expected but not provided"));
// FIXME: This check should be changed to an S4 inherits check, which
// should be available in Rinternals.h but isn't.
    if (strcmp(CHAR(asChar(getAttrib(x, R_ClassSymbol))),
	       "dpoMatrix") != 0)
	error(_("Object must be of class \"dpoMatrix\""));
    uplo = CHAR(asChar(GET_SLOT(x, install("uplo"))));
    int *dims = INTEGER(GET_SLOT(x, lme4_DimSym));
    n = dims[0];
    if (dims[1] != n)
	error(_("Cholesky object must be a square matrix"));
    X = REAL(GET_SLOT(x, lme4_xSym));
    factors = GET_SLOT(x, install("factors"));
    if (LENGTH(factors) && !isNewList(factors))
	error(_("\"factors\" slot should be a list"));
}
Example #13
0
SEXP lapply2(SEXP list, SEXP fn, SEXP rho)
{
    int i, n = length(list);
    SEXP R_fcall, ans;

    if(!isNewList(list)) error("`list' must be a list");
    if(!isFunction(fn)) error("`fn' must be a function");
    if(!isEnvironment(rho)) error("`rho' should be an environment");
    PROTECT(R_fcall = lang2(fn, R_NilValue));
    PROTECT(ans = allocVector(VECSXP, n));
    for(i = 0; i < n; i++) {
	SETCADR(R_fcall, VECTOR_ELT(list, i));
	SET_VECTOR_ELT(ans, i, eval(R_fcall, rho));
    }
    setAttrib(ans, R_NamesSymbol, getAttrib(list, R_NamesSymbol));
    UNPROTECT(2);
    return(ans);
}
Example #14
0
INLINE_FUN Rboolean isVectorizable(SEXP s)
{
    if (s == R_NilValue) return TRUE;
    else if (isNewList(s)) {
	R_xlen_t i, n;

	n = XLENGTH(s);
	for (i = 0 ; i < n; i++)
	    if (!isVector(VECTOR_ELT(s, i)) || XLENGTH(VECTOR_ELT(s, i)) > 1)
		return FALSE;
	return TRUE;
    }
    else if (isList(s)) {
	for ( ; s != R_NilValue; s = CDR(s))
	    if (!isVector(CAR(s)) || LENGTH(CAR(s)) > 1) return FALSE;
	return TRUE;
    }
    else return FALSE;
}
Example #15
0
static SEXP do_one(SEXP X, SEXP FUN, SEXP classes, SEXP deflt,
		   Rboolean replace, SEXP rho)
{
    SEXP ans, names, klass, R_fcall;
    int i, j, n;
    Rboolean matched = FALSE;

    /* if X is a list, recurse.  Otherwise if it matches classes call f */
    if(isNewList(X)) {
	n = length(X);
	PROTECT(ans = allocVector(VECSXP, n));
	names = getAttrib(X, R_NamesSymbol);
	/* or copy attributes if replace = TRUE? */
	if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
	for(i = 0; i < n; i++)
	    SET_VECTOR_ELT(ans, i, do_one(VECTOR_ELT(X, i), FUN, classes,
					  deflt, replace, rho));
	UNPROTECT(1);
	return ans;
    }
    if(strcmp(CHAR(STRING_ELT(classes, 0)), "ANY") == 0) /* ASCII */
	matched = TRUE;
    else {
	PROTECT(klass = R_data_class(X, FALSE));
	for(i = 0; i < LENGTH(klass); i++)
	    for(j = 0; j < length(classes); j++)
		if(Seql(STRING_ELT(klass, i), STRING_ELT(classes, j)))
		    matched = TRUE;
	UNPROTECT(1);
    }
    if(matched) {
	/* PROTECT(R_fcall = lang2(FUN, X)); */
	PROTECT(R_fcall = lang3(FUN, X, R_DotsSymbol));
	ans = eval(R_fcall, rho);
	if (NAMED(ans))
	    ans = duplicate(ans);
	UNPROTECT(1);
	return(ans);
    } else if(replace) return duplicate(X);
    else return duplicate(deflt);
}
Example #16
0
// sankoffNew
SEXP sankoff3B(SEXP dlist, SEXP scost, SEXP nr, SEXP nc, SEXP node, SEXP edge, SEXP mNodes, SEXP tips, SEXP contrast, SEXP nrs) {
    R_len_t i, n = length(node); //, nt = length(tips);
    int nrx=INTEGER(nr)[0], ncx=INTEGER(nc)[0], mn=INTEGER(mNodes)[0], nrc = INTEGER(nrs)[0];
    int  ni, ei, j, *edges=INTEGER(edge), *nodes=INTEGER(node), ntips=INTEGER(tips)[0];
    SEXP result, dlist2; //tmp,
    double *res, *cost, *tmp; // *rtmp,
    tmp = (double *) R_alloc(ncx * nrc, sizeof(double));
    for(j=0; j<(ncx * nrc); j++) tmp[j] = 0.0;
    cost = REAL(scost);
    sankoff4(REAL(contrast), nrc, cost, ncx, tmp);

    if(!isNewList(dlist)) error("'dlist' must be a list");
    ni = nodes[0];
    PROTECT(dlist2 = allocVector(VECSXP, mn));
    PROTECT(result = allocMatrix(REALSXP, nrx, ncx));
    res = REAL(result);
// die naechte Zeile vielleicht raus
//    for(i = 0; i < nt; i++) SET_VECTOR_ELT(dlist2, INTEGER(tips)[i], VECTOR_ELT(dlist, INTEGER(tips)[i]));
    for(j=0; j<(nrx * ncx); j++) res[j] = 0.0;

    for(i = 0; i < n; i++) {
        ei = edges[i];
        if(ni == nodes[i]) {
            if(ei < ntips) sankoffTips(INTEGER(VECTOR_ELT(dlist,ei)), tmp, nrx, ncx, nrc, res);
            else sankoff4(REAL(VECTOR_ELT(dlist2,ei)), nrx, cost, ncx, res);
        }
        else {
            SET_VECTOR_ELT(dlist2, ni, result);
            UNPROTECT(1);
            PROTECT(result = allocMatrix(REALSXP, nrx, ncx));
            res = REAL(result);
            for(j=0; j<(nrx * ncx); j++) res[j] = 0.0;
            ni = nodes[i];
            if(ei < ntips) sankoffTips(INTEGER(VECTOR_ELT(dlist,ei)), tmp, nrx, ncx, nrc, res);
            else sankoff4(REAL(VECTOR_ELT(dlist2,ei)), nrx, cost, ncx, res);
        }
    }
    SET_VECTOR_ELT(dlist2, ni, result);
    UNPROTECT(2);
    return(dlist2);
}
Example #17
0
SEXP setattrib(SEXP x, SEXP name, SEXP value)
{
    if (TYPEOF(name) != STRSXP) error("Attribute name must be of type character");
    if ( !isNewList(x) && 
         strcmp(CHAR(STRING_ELT(name, 0)), "class") == 0 && 
         isString(value) && (strcmp(CHAR(STRING_ELT(value, 0)), "data.table") == 0 || 
         strcmp(CHAR(STRING_ELT(value, 0)), "data.frame") == 0) )
        error("Internal structure doesn't seem to be a list. Can't set class to be 'data.table' or 'data.frame'. Use 'as.data.table()' or 'as.data.frame()' methods instead.");
    if (isLogical(x) && x == ScalarLogical(TRUE)) {
        x = PROTECT(duplicate(x));
        setAttrib(x, name, NAMED(value) ? duplicate(value) : value);
        UNPROTECT(1);
        return(x);
    }
    setAttrib(x, name,
        NAMED(value) ? duplicate(value) : value);
        // duplicate is temp fix to restore R behaviour prior to R-devel change on 10 Jan 2014 (r64724).
        // TO DO: revisit. Enough to reproduce is: DT=data.table(a=1:3); DT[2]; DT[,b:=2]
        // ... Error: selfrefnames is ok but tl names [1] != tl [100]
    return(R_NilValue);
}               
Example #18
0
SEXP attribute_hidden do_subset2_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP ans, dims, dimnames, indx, subs, x;
    int i, ndims, nsubs;
    int drop = 1, pok, exact = -1;
    int named_x;
    R_xlen_t offset = 0;

    PROTECT(args);
    ExtractDropArg(args, &drop);
    /* Is partial matching ok?  When the exact arg is NA, a warning is
       issued if partial matching occurs.
     */
    exact = ExtractExactArg(args);
    if (exact == -1)
	pok = exact;
    else
	pok = !exact;

    x = CAR(args);

    /* This code was intended for compatibility with S, */
    /* but in fact S does not do this.	Will anyone notice? */

    if (x == R_NilValue) {
	UNPROTECT(1); /* args */
	return x;
    }

    /* Get the subscripting and dimensioning information */
    /* and check that any array subscripting is compatible. */

    subs = CDR(args);
    if(0 == (nsubs = length(subs)))
	errorcall(call, _("no index specified"));
    dims = getAttrib(x, R_DimSymbol);
    ndims = length(dims);
    if(nsubs > 1 && nsubs != ndims)
	errorcall(call, _("incorrect number of subscripts"));

    /* code to allow classes to extend environment */
    if(TYPEOF(x) == S4SXP) {
        x = R_getS4DataSlot(x, ANYSXP);
	if(x == R_NilValue)
	  errorcall(call, _("this S4 class is not subsettable"));
    }
    PROTECT(x);

    /* split out ENVSXP for now */
    if( TYPEOF(x) == ENVSXP ) {
	if( nsubs != 1 || !isString(CAR(subs)) || length(CAR(subs)) != 1 )
	    errorcall(call, _("wrong arguments for subsetting an environment"));
	ans = findVarInFrame(x, installTrChar(STRING_ELT(CAR(subs), 0)));
	if( TYPEOF(ans) == PROMSXP ) {
	    PROTECT(ans);
	    ans = eval(ans, R_GlobalEnv);
	    UNPROTECT(1); /* ans */
	} else SET_NAMED(ans, 2);

	UNPROTECT(2); /* args, x */
	if(ans == R_UnboundValue)
	    return(R_NilValue);
	if (NAMED(ans))
	    SET_NAMED(ans, 2);
	return ans;
    }

    /* back to the regular program */
    if (!(isVector(x) || isList(x) || isLanguage(x)))
	errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));

    named_x = NAMED(x);  /* x may change below; save this now.  See PR#13411 */

    if(nsubs == 1) { /* vector indexing */
	SEXP thesub = CAR(subs);
	int len = length(thesub);

	if (len > 1) {
#ifdef SWITCH_TO_REFCNT
	    if (IS_GETTER_CALL(call)) {
		/* this is (most likely) a getter call in a complex
		   assighment so we duplicate as needed. The original
		   x should have been duplicated if it might be
		   shared */
		if (MAYBE_SHARED(x))
		    error("getter call used outside of a complex assignment.");
		x = vectorIndex(x, thesub, 0, len-1, pok, call, TRUE);
	    }
	    else
		x = vectorIndex(x, thesub, 0, len-1, pok, call, FALSE);
#else
	    x = vectorIndex(x, thesub, 0, len-1, pok, call, FALSE);
#endif
	    named_x = NAMED(x);
	    UNPROTECT(1); /* x */
	    PROTECT(x);
	}

	SEXP xnames = PROTECT(getAttrib(x, R_NamesSymbol));
	offset = get1index(thesub, xnames,
			   xlength(x), pok, len > 1 ? len-1 : -1, call);
	UNPROTECT(1); /* xnames */
	if (offset < 0 || offset >= xlength(x)) {
	    /* a bold attempt to get the same behaviour for $ and [[ */
	    if (offset < 0 && (isNewList(x) ||
			       isExpression(x) ||
			       isList(x) ||
			       isLanguage(x))) {
		UNPROTECT(2); /* args, x */
		return R_NilValue;
	    }
	    else errorcall(call, R_MSG_subs_o_b);
	}
    } else { /* matrix indexing */
	/* Here we use the fact that: */
	/* CAR(R_NilValue) = R_NilValue */
	/* CDR(R_NilValue) = R_NilValue */

	int ndn; /* Number of dimnames. Unlikely to be anything but
		    0 or nsubs, but just in case... */

	PROTECT(indx = allocVector(INTSXP, nsubs));
	dimnames = getAttrib(x, R_DimNamesSymbol);
	ndn = length(dimnames);
	for (i = 0; i < nsubs; i++) {
	    INTEGER(indx)[i] = (int)
		get1index(CAR(subs),
			  (i < ndn) ? VECTOR_ELT(dimnames, i) : R_NilValue,
			  INTEGER(indx)[i], pok, -1, call);
	    subs = CDR(subs);
	    if (INTEGER(indx)[i] < 0 ||
		INTEGER(indx)[i] >= INTEGER(dims)[i])
		errorcall(call, R_MSG_subs_o_b);
	}
	offset = 0;
	for (i = (nsubs - 1); i > 0; i--)
	    offset = (offset + INTEGER(indx)[i]) * INTEGER(dims)[i - 1];
	offset += INTEGER(indx)[0];
	UNPROTECT(1); /* indx */
    }

    if(isPairList(x)) {
#ifdef LONG_VECTOR_SUPPORT
	if (offset > R_SHORT_LEN_MAX)
	    error("invalid subscript for pairlist");
#endif
	ans = CAR(nthcdr(x, (int) offset));
	if (named_x > NAMED(ans))
	    SET_NAMED(ans, named_x);
    } else if(isVectorList(x)) {
	/* did unconditional duplication before 2.4.0 */
	ans = VECTOR_ELT(x, offset);
	if (named_x > NAMED(ans))
	    SET_NAMED(ans, named_x);
    } else {
	ans = allocVector(TYPEOF(x), 1);
	switch (TYPEOF(x)) {
	case LGLSXP:
	case INTSXP:
	    INTEGER(ans)[0] = INTEGER(x)[offset];
	    break;
	case REALSXP:
	    REAL(ans)[0] = REAL(x)[offset];
	    break;
	case CPLXSXP:
	    COMPLEX(ans)[0] = COMPLEX(x)[offset];
	    break;
	case STRSXP:
	    SET_STRING_ELT(ans, 0, STRING_ELT(x, offset));
	    break;
	case RAWSXP:
	    RAW(ans)[0] = RAW(x)[offset];
	    break;
	default:
	    UNIMPLEMENTED_TYPE("do_subset2", x);
	}
    }
    UNPROTECT(2); /* args, x */
    return ans;
}
Example #19
0
/**
* @brief Main entry point for R
*
* @param bamfilenameR Filename of read container
* @param aRgvals Vector containing the user arguments
* @param filterList passed from R in the form list("chr1"=c(100,200,3000,3010...start,end...))
* @return R list in the form list("chr1"=c(1,2,1,2,1,1,...),"chr1_gind"=c(1100,1200...),"chr1_lind"=c(0,112,...),"chrX"=NA,...) and a Statistics vector
* @details All chromosome of the filter or all chromosomes in the file header will be scanned and passed to an R list
* @note
* @todo high_cov not yet implemented.
*/
SEXP construct_dc(SEXP bamfilenameR, SEXP aRgvals, SEXP filterList) {

	double *statsp;//resulting statistics in the order "total reads" "coverage" "local coverage" "max score"
	uint32_t upcounter=0,i=0;
	time_t tstart,tstop;
	global_densities_t gd={0};
    user_arguments_t user_args;
    filter_t ft;
    SEXP histogram,stats;
    int *argvalsp;

    signal(SIGINT,SIG_DFL);//make this thing stop on CTRL+C
    time(&tstart);

    /* Set user defined values */

    PROTECT(aRgvals=AS_INTEGER(aRgvals));upcounter++;
    if(LENGTH(aRgvals)!=10)error("Invalid amount of arguments - arguments[%d] / should be %d!\n",LENGTH(aRgvals),9);
    argvalsp=INTEGER_POINTER(aRgvals);
    user_args.bamfilename = STRING_VALUE(bamfilenameR);
    user_args.READTHROUGH = argvalsp[0];//bool. read from start to end and 0 take whole read whithout CIGAR splice info
    user_args.PAIRED = argvalsp[1];
    user_args.STRANDED = argvalsp[2];//Set to 1 / -1 it will use only forward / reverse reads respectively. 0 means all reads are processed
    user_args.TMAPQ = argvalsp[3];//Minimum MPAQ score. Lower scored reads will be skipped
    user_args.COLLAPSE = argvalsp[4];
    user_args.EXTEND = argvalsp[5];//extend each read in its direction by this amount of BPs
    user_args.HWINDOW = argvalsp[6];
    user_args.COMPRESSION = argvalsp[7];//minimum BPs needed between data blocks to collapse the gap and index it
    user_args.VERBOSE = argvalsp[8];
    user_args.UNIQUE = argvalsp[9];


    /* Try to open the file */
    samfile_t *bam_file;
    bam_file=open_samtools(user_args.bamfilename);
	if(!bam_file){
		warning("sam/bam file not found!\n");
		UNPROTECT(upcounter);
	    return(R_NilValue);
	}

    if(user_args.HWINDOW>user_args.COMPRESSION){
    	warning("HWINDOW has to be smaller than COMPRESSION! HWINDOW updated to %d\n",user_args.COMPRESSION);
    	user_args.HWINDOW=user_args.COMPRESSION;
    }

	PROTECT(histogram = NEW_INTEGER(UINT16_MAX));upcounter++;//initialize compressed scores
	gd.histogramp = (uint32_t*) INTEGER_POINTER(histogram);
	for(i = 0; i < UINT16_MAX; i++) gd.histogramp[i] = 0;

	gd.total_elements=bam_file->header->n_targets;//one vector per chromosome needed
	/* ####  CHECK IF THERE IS AN ACTIVE FILTER IN PLACE */
    user_args.FILTER=isNewList(filterList) ? 1 : 0;
    if(user_args.FILTER){
    	upcounter+=set_filter(filterList,&ft);
    	gd.total_elements=ft.seqn;//overwrite total elements if filter is passed, since one density is returned per slice
    }

	// Creating a list with vector elements as many as sequences plus a character string vector:
    PROTECT(gd.list = allocVector(VECSXP, (gd.total_elements*3)+2));upcounter++;//3x for the two indexes and scores per chromosome
    PROTECT(gd.list_names = allocVector(STRSXP,(gd.total_elements*3)+2));upcounter++;//+1 for statistics vector +1 for the histogram

	/* PASS EVERYTHING */
	write_density(&gd,&user_args,bam_file,&ft);
	if(!gd.total_reads)goto NO_READS_FOUND;
	// 1 total_reads  2 gcoverage  3 lcoverage  4 maxscore  5 lmaxscore  6 lowqual  7 filtered  8 collapsed  9 paired  10 proper_pairs 11 pos  12 neg 13 fmapmass 14 lsize 15 gsize
	SET_STRING_ELT(gd.list_names,gd.total_elements*3,mkChar("Statistics"));
	PROTECT(stats = NEW_NUMERIC(15));upcounter++;
	statsp = NUMERIC_POINTER(stats);
	*statsp++=(double)gd.total_reads;
	*statsp++=(double)gd.mapmass/(double)gd.gsize;
	*statsp++=(double)gd.lmapmass/(double)gd.lsize;
	*statsp++=(double)gd.maxscore;
	*statsp++=(double)gd.lmaxScore;
	*statsp++=(double)gd.lowqual;
	*statsp++=(double)gd.filtered_reads;
	*statsp++=(double)gd.collapsed;
	*statsp++=(double)gd.paired;
	*statsp++=(double)gd.ppairs/2;
	*statsp++=(double)gd.pos_strand;
	*statsp++=(double)gd.neg_strand;
	*statsp=(double)gd.mapmass;
	*statsp++=(double)gd.lsize;
	*statsp++=(double)gd.gsize;


	if(gd.lmaxScore>=umaxof(usersize)-1){
		warning("\nThe maximum pile up is exceeding the maximal value of UINT16_MAX=%d. Reads have been capped to that value.\nConsider to rerun using the maxDups option!\n",UINT16_MAX);
	}

	SET_VECTOR_ELT(gd.list,gd.total_elements*3, stats);

	SET_STRING_ELT(gd.list_names,(gd.total_elements*3)+1,mkChar("Histogram"));
	SET_VECTOR_ELT(gd.list,(gd.total_elements*3)+1,histogram);

    setAttrib(gd.list, R_NamesSymbol, gd.list_names);

    NO_READS_FOUND:
    time(&tstop);
	if(user_args.VERBOSE>0)printf("About %.0f seconds passed. %llu reads processed \n", difftime(tstop, tstart),gd.total_reads);
	close_bamfile(bam_file);
	if(user_args.FILTER)destroy_filter(&ft);
    UNPROTECT(upcounter+gd.upcounter);
    if(!gd.total_reads)return(R_NilValue);
    else return(gd.list);
}
Example #20
0
File: Train.cpp Project: rforge/crf
void CRF::Update_Pot(SEXP _nodeFea, SEXP _edgeFea, SEXP _nodeExt, SEXP _edgeExt)
{
	int nPar = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.par")))[0];

	SEXP _par;
	PROTECT(_par = AS_NUMERIC(GetVar(_crf, "par")));
	double *par = NUMERIC_POINTER(_par);

	for (int i = 0; i < nNodes * maxState; i++)
		nodePot[i] = 0;
	for (int i = 0; i < nEdges; i++)
		for (int j = 0; j < nEdgeStates[i]; j++)
			edgePot[i][j] = 0;

  if (!isNull(_nodeFea))
  {
    PROTECT(_nodeFea = AS_NUMERIC(_nodeFea));
  	double *nodeFea = NUMERIC_POINTER(_nodeFea);
  	if (!ISNAN(nodeFea[0]))
  	{
  		int nNodeFea = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.nf")))[0];
  		SEXP _nodePar;
  		PROTECT(_nodePar = AS_INTEGER(GetVar(_crf, "node.par")));
  		int *nodePar = INTEGER_POINTER(_nodePar);
  		for (int i = 0; i < nNodes; i++)
  		{
  			for (int j = 0; j < nNodeFea; j++)
  			{
  				double f = nodeFea[j + nNodeFea * i];
  				if (f != 0)
  					for (int k = 0; k < nStates[i]; k++)
  					{
  						int p = nodePar[i + nNodes * (k + maxState * j)] - 1;
  						if (p >= 0 && p < nPar)
  							nodePot[i + nNodes * k] += f * par[p];
  					}
  			}
  		}
  		UNPROTECT(1);
  	}
    UNPROTECT(1);
  }

  if (!isNull(_edgeFea))
  {
  	PROTECT(_edgeFea = AS_NUMERIC(_edgeFea));
  	double *edgeFea = NUMERIC_POINTER(_edgeFea);
  	if (!ISNAN(edgeFea[0]))
  	{
  		int nEdgeFea = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.ef")))[0];
  		SEXP _edgePar = GetVar(_crf, "edge.par");
  		for (int i = 0; i < nEdges; i++)
  		{
  			SEXP _edgeParI;
  			PROTECT(_edgeParI = AS_INTEGER(GetListElement(_edgePar, i)));
  			int *edgePar = INTEGER_POINTER(_edgeParI);
  			for (int j = 0; j < nEdgeFea; j++)
  			{
  				double f = edgeFea[j + nEdgeFea * i];
  				if (f != 0)
  					for (int k = 0; k < nEdgeStates[i]; k++)
  					{
  						int p = edgePar[k + nEdgeStates[i] * j] - 1;
  						if (p >= 0 && p < nPar)
  							edgePot[i][k] += f * par[p];
  					}
  			}
  			UNPROTECT(1);
  		}
  	}
    UNPROTECT(1);
  }

	if (!isNull(_nodeExt) && isNewList(_nodeExt))
	{
		for (int i = 0; i < nPar; i++)
		{
			SEXP _nodeExtI = GetListElement(_nodeExt, i);
      if (!isNull(_nodeExtI))
      {
  			PROTECT(_nodeExtI = AS_NUMERIC(_nodeExtI));
  			double *nodeExt = NUMERIC_POINTER(_nodeExtI);
  			if (!ISNAN(nodeExt[0]))
  			{
  				for (int j = 0; j < nNodes; j++)
  				{
  					for (int k = 0; k < nStates[j]; k++)
  					{
  						nodePot[j + nNodes * k] += nodeExt[j + nNodes * k] * par[i];
  					}
  				}
  			}
        UNPROTECT(1);
      }
		}
	}

	if (!isNull(_edgeExt) && isNewList(_edgeExt))
	{
		for (int i = 0; i < nPar; i++)
		{
			SEXP _edgeExtI = GetListElement(_edgeExt, i);
			if (!isNull(_edgeExtI) && isNewList(_edgeExtI))
			{
				for (int j = 0; j < nEdges; j++)
				{
					SEXP _edgeExtII = GetListElement(_edgeExtI, j);
          if (!isNull(_edgeExtII))
          {
  					PROTECT(_edgeExtII = AS_NUMERIC(_edgeExtII));
  					double *edgeExt = NUMERIC_POINTER(_edgeExtII);
  					if (!ISNAN(edgeExt[0]))
  					{
  						for (int k = 0; k < nEdgeStates[j]; k++)
  						{
  							edgePot[j][k] += edgeExt[k] * par[i];
  						}
  					}
            UNPROTECT(1);
          }
				}
			}
		}
	}

	for (int i = 0; i < nNodes * maxState; i++)
		nodePot[i] = exp(nodePot[i]);
	for (int i = 0; i < nEdges; i++)
		for (int j = 0; j < nEdgeStates[i]; j++)
			edgePot[i][j] = exp(edgePot[i][j]);

	UNPROTECT(1);
}
Example #21
0
File: Train.cpp Project: rforge/crf
SEXP CRF_NLL(SEXP _crf, SEXP _par, SEXP _instances, SEXP _nodeFea, SEXP _edgeFea, SEXP _nodeExt, SEXP _edgeExt, SEXP _infer, SEXP _env)
{
	CRF crf(_crf);

	int nInstances = INTEGER_POINTER(GET_DIM(_instances))[0];
	int nPar = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.par")))[0];
	int nNodeFea = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.nf")))[0];
	int nEdgeFea = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.ef")))[0];

	PROTECT(_par = AS_NUMERIC(_par));
	double *par = NUMERIC_POINTER(_par);
	double *crfPar = NUMERIC_POINTER(GetVar(_crf, "par"));
	for (int i = 0; i < nPar; i++)
		crfPar[i] = par[i];

	PROTECT(_instances = AS_NUMERIC(_instances));
	double *instances = NUMERIC_POINTER(_instances);

	SEXP _nodePar;
	PROTECT(_nodePar = AS_INTEGER(GetVar(_crf, "node.par")));
	int *nodePar = INTEGER_POINTER(_nodePar);

	SEXP _edgePar = GetVar(_crf, "edge.par");
	int **edgePar = (int **) R_alloc(crf.nEdges, sizeof(int *));
	SEXP _edgeParI, _temp;
	PROTECT(_edgeParI = NEW_LIST(crf.nEdges));
	for (int i = 0; i < crf.nEdges; i++)
	{
		SET_VECTOR_ELT(_edgeParI, i, _temp = AS_INTEGER(GetListElement(_edgePar, i)));
		edgePar[i] = INTEGER_POINTER(_temp);
	}

	SEXP _nll = GetVar(_crf, "nll");
	double *nll = NUMERIC_POINTER(_nll);
	*nll = 0.0;

	double *gradient = NUMERIC_POINTER(GetVar(_crf, "gradient"));
	for (int i = 0; i < nPar; i++)
		gradient[i] = 0.0;

	int *y = (int *) R_allocVector<int>(crf.nNodes);

	SEXP _nodeFeaN = _nodeFea;
	SEXP _edgeFeaN = _edgeFea;
	SEXP _nodeExtN = _nodeExt;
	SEXP _edgeExtN = _edgeExt;
	for (int n = 0; n < nInstances; n++)
	{
		if (!isNull(_nodeFea) && isNewList(_nodeFea)) _nodeFeaN = GetListElement(_nodeFea, n);
		if (!isNull(_edgeFea) && isNewList(_edgeFea)) _edgeFeaN = GetListElement(_edgeFea, n);
		if (!isNull(_nodeExt) && isNewList(_nodeExt)) _nodeExtN = GetListElement(_nodeExt, n);
		if (!isNull(_edgeExt) && isNewList(_edgeExt)) _edgeExtN = GetListElement(_edgeExt, n);

		crf.Update_Pot(_nodeFeaN, _edgeFeaN, _nodeExtN, _edgeExtN);

		for (int i = 0; i < crf.nNodes; i++)
			y[i] = instances[n + nInstances * i] - 1;

		SEXP _belief;
		PROTECT(_belief = eval(_infer, _env));

		SEXP _nodeBel;
		PROTECT(_nodeBel = AS_NUMERIC(GetListElement(_belief, "node.bel")));
		double *nodeBel = NUMERIC_POINTER(_nodeBel);

		SEXP _edgeBel = GetListElement(_belief, "edge.bel");
		double **edgeBel = (double **) R_alloc(crf.nEdges, sizeof(double *));
		SEXP _edgeBelI, _temp;
		PROTECT(_edgeBelI = NEW_LIST(crf.nEdges));
		for (int i = 0; i < crf.nEdges; i++)
		{
			SET_VECTOR_ELT(_edgeBelI, i, _temp = AS_NUMERIC(GetListElement(_edgeBel, i)));
			edgeBel[i] = NUMERIC_POINTER(_temp);
		}

		*nll += NUMERIC_POINTER(AS_NUMERIC(GetListElement(_belief, "logZ")))[0] - crf.Get_LogPotential(y);

    if (!isNull(_nodeFeaN))
    {
  		PROTECT(_nodeFeaN = AS_NUMERIC(_nodeFeaN));
  		double *nodeFea = NUMERIC_POINTER(_nodeFeaN);
  		if (!ISNAN(nodeFea[0]))
  		{
  			for (int i = 0; i < crf.nNodes; i++)
  			{
  				int s = y[i];
  				for (int j = 0; j < nNodeFea; j++)
  				{
  					double f = nodeFea[j + nNodeFea * i];
  					if (f != 0)
  					{
  						for (int k = 0; k < crf.nStates[i]; k++)
  						{
  							int p = nodePar[i + crf.nNodes * (k + crf.maxState * j)] - 1;
  							if (p >= 0 && p < nPar)
  							{
  								if (k == s)
  								{
  									gradient[p] -= f;
  								}
  								gradient[p] += f * nodeBel[i + crf.nNodes * k];
  							}
  						}
  					}
  				}
  			}
  		}
      UNPROTECT(1);
    }

    if (!isNull(_edgeFeaN))
    {
  		PROTECT(_edgeFeaN = AS_NUMERIC(_edgeFeaN));
  		double *edgeFea = NUMERIC_POINTER(_edgeFeaN);
  		if (!ISNAN(edgeFea[0]))
  		{
  			for (int i = 0; i < crf.nEdges; i++)
  			{
  				int s = y[crf.EdgesBegin(i)] + crf.nStates[crf.EdgesBegin(i)] * y[crf.EdgesEnd(i)];
  				for (int j = 0; j < nEdgeFea; j++)
  				{
  					double f = edgeFea[j + nEdgeFea * i];
  					if (f != 0)
  					{
  						for (int k = 0; k < crf.nEdgeStates[i]; k++)
  						{
  							int p = edgePar[i][k + crf.nEdgeStates[i] * j] - 1;
  							if (p >= 0 && p < nPar)
  							{
  								if (k == s)
  								{
  									gradient[p] -= f;
  								}
  								gradient[p] += f * edgeBel[i][k];
  							}
  						}
  					}
  				}
  			}
  		}
      UNPROTECT(1);
    }

		if (!isNull(_nodeExtN) && isNewList(_nodeExtN))
		{
			for (int i = 0; i < nPar; i++)
			{
				SEXP _nodeExtI = GetListElement(_nodeExtN, i);
        if (!isNull(_nodeExtI))
        {
  				PROTECT(_nodeExtI = AS_NUMERIC(_nodeExtI));
  				double *nodeExt = NUMERIC_POINTER(_nodeExtI);
  				if (!ISNAN(nodeExt[0]))
  				{
  					for (int j = 0; j < crf.nNodes; j++)
  					{
  						int s = y[j];
  						for (int k = 0; k < crf.nStates[j]; k++)
  						{
  							double f = nodeExt[j + crf.nNodes * k];
  							if (k == s)
  							{
  								gradient[i] -= f;
  							}
  							gradient[i] += f * nodeBel[j + crf.nNodes * k];
  						}
  					}
  				}
          UNPROTECT(1);
        }
			}
		}

		if (!isNull(_edgeExtN) && isNewList(_edgeExtN))
		{
			for (int i = 0; i < nPar; i++)
			{
				SEXP _edgeExtI = GetListElement(_edgeExtN, i);
				if (!isNull(_edgeExtI) && isNewList(_edgeExtI))
				{
					for (int j = 0; j < crf.nEdges; j++)
					{
						SEXP _edgeExtII = GetListElement(_edgeExtI, j);
            if (!isNull(_edgeExtII))
            {
  						PROTECT(_edgeExtII = AS_NUMERIC(_edgeExtII));
  						double *edgeExt = NUMERIC_POINTER(_edgeExtII);
  						if (!ISNAN(edgeExt[0]))
  						{
  							int s = y[crf.EdgesBegin(j)] + crf.nStates[crf.EdgesBegin(j)] * y[crf.EdgesEnd(j)];
  							for (int k = 0; k < crf.nEdgeStates[j]; k++)
  							{
  								double f = edgeExt[k];
  								if (k == s)
  								{
  									gradient[i] -= f;
  								}
  								gradient[i] += f * edgeBel[j][k];
  							}
  						}
              UNPROTECT(1);
            }
					}
				}
			}
		}

		UNPROTECT(3);
	}

	UNPROTECT(4);

	return(_nll);
}
Example #22
0
File: clogit.c Project: cran/Epi
SEXP clogit(SEXP X, SEXP y, SEXP offset, SEXP init, 
	    SEXP maxiter, SEXP eps, SEXP tol_chol)
{
    int i;
    int n = length(X);
    int m = length(init);
    int M = m*m;
    int flag = 0;
    int niter = INTEGER(maxiter)[0];
    double loglik[2], *score, *info, *beta;
    SEXP ans, a, names, dims;

    if (!isNewList(X)) error("'X' must be a list");
    if (!isNewList(y)) error("'y' must be a list");
    if (!isNewList(offset)) error("'offset' must be a list");
    if (length(X) != length(y)) error("length mismatch between X and y");
    if (length(X) != length(offset)) 
	error("length mismatch between X and offset");

    for (i = 0; i < n; ++i) {

	int T = nrows(VECTOR_ELT(X,i));
        int xcols = ncols(VECTOR_ELT(X,i));
        int ylen  = length(VECTOR_ELT(y,i));
	int olen = length(VECTOR_ELT(offset, i));

	if (xcols != m) {
	    error("Element %d of X has %d columns; expected %d", i, xcols, m);
	}
	if (ylen != T) {
	    error("Element %d of y has length %d; expected %d", i, ylen, T);
	}
	if (olen != T) {
	    error("Element %d of offset has length %d; expected %d", 
		  i, ylen, T);
	}

    }

    beta = (double *) R_alloc(m, sizeof(double));
    for (i = 0; i < m; ++i) {
	beta[i] = REAL(init)[i];
    }
    score = (double *) R_alloc(m, sizeof(double));
    info = (double *) R_alloc(M, sizeof(double));

    /* Calculate initial loglikelihood */
    cloglik(X, y, offset, m, beta, &loglik[0], score, info);
    
    /* Maximize the likelihood */
    clogit_fit(X, y, offset, m, beta, &loglik[1], score, info,
	       &flag, &niter, REAL(eps), REAL(tol_chol));

    /* Construct return list */

    PROTECT(ans = allocVector(VECSXP, 5));
    PROTECT(names = allocVector(STRSXP, 5));

    /* Estimates */
    PROTECT(a = allocVector(REALSXP, m));
    for (i = 0; i < m; ++i) {
	REAL(a)[i] = beta[i];
    }
    SET_VECTOR_ELT(ans, 0, a);
    SET_STRING_ELT(names, 0, mkChar("coefficients"));
    UNPROTECT(1);

    /* Log likelihood */
    PROTECT(a = allocVector(REALSXP, 2));
    REAL(a)[0] = loglik[0];
    REAL(a)[1] = loglik[1];
    SET_VECTOR_ELT(ans, 1, a);
    SET_STRING_ELT(names, 1, mkChar("loglik"));
    UNPROTECT(1);

    /* Information matrix */
    PROTECT(a = allocVector(REALSXP, M));
    PROTECT(dims = allocVector(INTSXP, 2));
    for (i = 0; i < M; ++i) {
	REAL(a)[i] = info[i];
    }
    INTEGER(dims)[0] = m;
    INTEGER(dims)[1] = m;
    setAttrib(a, R_DimSymbol, dims);    
    SET_VECTOR_ELT(ans, 2, a);
    SET_STRING_ELT(names, 2, mkChar("var"));
    UNPROTECT(2);

    /* Flag */
    PROTECT(a = ScalarInteger(flag));
    SET_VECTOR_ELT(ans, 3, a);
    SET_STRING_ELT(names, 3, mkChar("flag"));
    UNPROTECT(1);

    /* Number of iterations */
    PROTECT(a = ScalarInteger(niter));
    SET_VECTOR_ELT(ans, 4, a);
    SET_STRING_ELT(names, 4, mkChar("iter"));
    UNPROTECT(1);

    setAttrib(ans, R_NamesSymbol, names);
    UNPROTECT(2);
    return(ans);
}
Example #23
0
File: mrb4R.c Project: rcqls/mrb4R
//convert R Vector in  rbObj
mrb_value RVector2mrbArray(SEXP vect)
{
  mrb_value res;
  //char *name;
  int i,n=0;
  //Rcomplex cpl;
  //mrb_value res2; 

  //vect have to be R Vector!!!
  if(!isVector(vect) | isNewList(vect)) return mrb_nil_value(); 
  n=length(vect);
  if(n>1) {
    res = mrb_ary_new_capa(mrb,n);
    switch(TYPEOF(vect)) {
    case REALSXP:
      for(i=0;i<n;i++) {
	      mrb_ary_push(mrb,res,mrb_float_value(mrb,REAL(vect)[i]));
      }
      break;
    case INTSXP:
      for(i=0;i<n;i++) {
	      mrb_ary_push(mrb,res,mrb_fixnum_value(INTEGER(vect)[i]));
      }
      break;
    case LGLSXP:
      for(i=0;i<n;i++) {
        mrb_ary_push(mrb,res,(INTEGER(vect)[i] ? mrb_true_value() : mrb_false_value()));      }
      break;
    case STRSXP:
      for(i=0;i<n;i++) {
        mrb_ary_push(mrb,res,mrb_str_new_cstr(mrb,CHAR(STRING_ELT(vect,i))));
      }
      break;
    // case CPLXSXP:
    //   rb_require("complex");
    //   for(i=0;i<n;i++) {
	   //    cpl=COMPLEX(vect)[i];
	   //    res2 = rb_eval_string("Complex.new(0,0)");
	   //    rb_iv_set(res2,"@real",rb_float_new(cpl.r));
	   //    rb_iv_set(res2,"@image",rb_float_new(cpl.i));
	   //    rb_ary_store(res,i,res2);
    //   }
    //   break;
    }
  } else {
    switch(TYPEOF(vect)) {
    case REALSXP:
      res=mrb_float_value(mrb,REAL(vect)[0]);
      break;
    case INTSXP:
      res=mrb_fixnum_value(INTEGER(vect)[0]);
      break;
    case LGLSXP:
      res=(INTEGER(vect)[0] ? mrb_true_value() : mrb_false_value());
      break;
    case STRSXP:
      res=mrb_str_new_cstr(mrb,CHAR(STRING_ELT(vect,0)));
      break;
    // case CPLXSXP:
    //   rb_require("complex");
    //   cpl=COMPLEX(vect)[0];
    //   res= rb_eval_string("Complex.new(0,0)");
    //   rb_iv_set(res,"@real",rb_float_new(cpl.r));
    //   rb_iv_set(res,"@image",rb_float_new(cpl.i));
    //   break;
    }
  }
  return res;
}
Example #24
0
/* complete.cases(.) */
SEXP compcases(SEXP args)
{
    SEXP s, t, u, rval;
    int i, len;

    args = CDR(args);

    len = -1;

    for (s = args; s != R_NilValue; s = CDR(s)) {
	if (isList(CAR(s))) {
	    for (t = CAR(s); t != R_NilValue; t = CDR(t))
		if (isMatrix(CAR(t))) {
		    u = getAttrib(CAR(t), R_DimSymbol);
		    if (len < 0)
			len = INTEGER(u)[0];
		    else if (len != INTEGER(u)[0])
			goto bad;
		}
		else if (isVector(CAR(t))) {
		    if (len < 0)
			len = LENGTH(CAR(t));
		    else if (len != LENGTH(CAR(t)))
			goto bad;
		}
		else
		    error(R_MSG_type, type2char(TYPEOF(CAR(t))));
	}
	/* FIXME : Need to be careful with the use of isVector() */
	/* since this includes lists and expressions. */
	else if (isNewList(CAR(s))) {
	    int it, nt;
	    t = CAR(s);
	    nt = length(t);
	    /* 0-column data frames are a special case */
	    if(nt) {
		for (it = 0 ; it < nt ; it++) {
		    if (isMatrix(VECTOR_ELT(t, it))) {
			u = getAttrib(VECTOR_ELT(t, it), R_DimSymbol);
			if (len < 0)
			    len = INTEGER(u)[0];
			else if (len != INTEGER(u)[0])
			    goto bad;
		    }
		    else if (isVector(VECTOR_ELT(t, it))) {
			if (len < 0)
			    len = LENGTH(VECTOR_ELT(t, it));
			else if (len != LENGTH(VECTOR_ELT(t, it)))
			    goto bad;
		    }
		    else
			error(R_MSG_type, "unknown");
		}
	    } else {
		u = getAttrib(t, R_RowNamesSymbol);
		if (!isNull(u)) {
		    if (len < 0)
			len = LENGTH(u);
		    else if (len != INTEGER(u)[0])
			goto bad;
		}
	    }
	}
	else if (isMatrix(CAR(s))) {
	    u = getAttrib(CAR(s), R_DimSymbol);
	    if (len < 0)
		len = INTEGER(u)[0];
	    else if (len != INTEGER(u)[0])
		goto bad;
	}
	else if (isVector(CAR(s))) {
	    if (len < 0)
		len = LENGTH(CAR(s));
	    else if (len != LENGTH(CAR(s)))
		goto bad;
	}
	else
	    error(R_MSG_type, type2char(TYPEOF(CAR(s))));
    }

    if (len < 0)
	error(_("no input has determined the number of cases"));
    PROTECT(rval = allocVector(LGLSXP, len));
    for (i = 0; i < len; i++) INTEGER(rval)[i] = 1;
    /* FIXME : there is a lot of shared code here for vectors. */
    /* It should be abstracted out and optimized. */
    for (s = args; s != R_NilValue; s = CDR(s)) {
	if (isList(CAR(s))) {
	    /* Now we only need to worry about vectors */
	    /* since we use mod to handle arrays. */
	    /* FIXME : using mod like this causes */
	    /* a potential performance hit. */
	    for (t = CAR(s); t != R_NilValue; t = CDR(t)) {
		u = CAR(t);
		for (i = 0; i < LENGTH(u); i++) {
		    switch (TYPEOF(u)) {
		    case INTSXP:
		    case LGLSXP:
			if (INTEGER(u)[i] == NA_INTEGER)
			    INTEGER(rval)[i % len] = 0;
			break;
		    case REALSXP:
			if (ISNAN(REAL(u)[i]))
			    INTEGER(rval)[i % len] = 0;
			break;
		    case CPLXSXP:
			if (ISNAN(COMPLEX(u)[i].r) || ISNAN(COMPLEX(u)[i].i))
			    INTEGER(rval)[i % len] = 0;
			break;
		    case STRSXP:
			if (STRING_ELT(u, i) == NA_STRING)
			    INTEGER(rval)[i % len] = 0;
			break;
		    default:
			UNPROTECT(1);
			error(R_MSG_type, type2char(TYPEOF(u)));
		    }
		}
	    }
	}
	if (isNewList(CAR(s))) {
	    int it, nt;
	    t = CAR(s);
	    nt = length(t);
	    for (it = 0 ; it < nt ; it++) {
		u = VECTOR_ELT(t, it);
		for (i = 0; i < LENGTH(u); i++) {
		    switch (TYPEOF(u)) {
		    case INTSXP:
		    case LGLSXP:
			if (INTEGER(u)[i] == NA_INTEGER)
			    INTEGER(rval)[i % len] = 0;
			break;
		    case REALSXP:
			if (ISNAN(REAL(u)[i]))
			    INTEGER(rval)[i % len] = 0;
			break;
		    case CPLXSXP:
			if (ISNAN(COMPLEX(u)[i].r) || ISNAN(COMPLEX(u)[i].i))
			    INTEGER(rval)[i % len] = 0;
			break;
		    case STRSXP:
			if (STRING_ELT(u, i) == NA_STRING)
			    INTEGER(rval)[i % len] = 0;
			break;
		    default:
			UNPROTECT(1);
			error(R_MSG_type, type2char(TYPEOF(u)));
		    }
		}
	    }
	}
	else {
	    for (i = 0; i < LENGTH(CAR(s)); i++) {
		u = CAR(s);
		switch (TYPEOF(u)) {
		case INTSXP:
		case LGLSXP:
		    if (INTEGER(u)[i] == NA_INTEGER)
			INTEGER(rval)[i % len] = 0;
		    break;
		case REALSXP:
		    if (ISNAN(REAL(u)[i]))
			INTEGER(rval)[i % len] = 0;
		    break;
		case CPLXSXP:
		    if (ISNAN(COMPLEX(u)[i].r) || ISNAN(COMPLEX(u)[i].i))
			INTEGER(rval)[i % len] = 0;
		    break;
		case STRSXP:
		    if (STRING_ELT(u, i) == NA_STRING)
			INTEGER(rval)[i % len] = 0;
		    break;
		default:
		    UNPROTECT(1);
		    error(R_MSG_type, type2char(TYPEOF(u)));
		}
	    }
	}
    }
    UNPROTECT(1);
    return rval;

 bad:
    error(_("not all arguments have the same length"));
    return R_NilValue; /* -Wall */
}
Example #25
0
SEXP transpose(SEXP l, SEXP fill, SEXP ignoreArg) {

  R_len_t i, j, k=0, maxlen=0, zerolen=0, anslen;
  SEXP li, thisi, ans;
  SEXPTYPE type, maxtype=0;
  Rboolean coerce = FALSE;

  if (!isNewList(l))
    error("l must be a list.");
  if (!length(l))
    return(duplicate(l));
  if (!isLogical(ignoreArg) || LOGICAL(ignoreArg)[0] == NA_LOGICAL)
    error("ignore.empty should be logical TRUE/FALSE.");
  if (length(fill) != 1)
    error("fill must be NULL or length=1 vector.");
  R_len_t ln = LENGTH(l);
  Rboolean ignore = LOGICAL(ignoreArg)[0];

  // preprocessing
  R_len_t *len  = (R_len_t *)R_alloc(ln, sizeof(R_len_t));
  for (i=0; i<ln; i++) {
    li = VECTOR_ELT(l, i);
    if (!isVectorAtomic(li) && !isNull(li))
      error("Item %d of list input is not an atomic vector", i+1);
    len[i] = length(li);
    if (len[i] > maxlen)
      maxlen = len[i];
    zerolen += (len[i] == 0);
    if (isFactor(li)) {
      maxtype = STRSXP;
    } else {
      type = TYPEOF(li);
      if (type > maxtype)
        maxtype = type;
    }
  }
  // coerce fill to maxtype
  fill = PROTECT(coerceVector(fill, maxtype));

  // allocate 'ans'
  ans = PROTECT(allocVector(VECSXP, maxlen));
  anslen = (!ignore) ? ln : (ln - zerolen);
  for (i=0; i<maxlen; i++) {
    SET_VECTOR_ELT(ans, i, thisi=allocVector(maxtype, anslen) );
  }

  // transpose
  for (i=0; i<ln; i++) {
    if (ignore && !len[i]) continue;
    li = VECTOR_ELT(l, i);
    if (TYPEOF(li) != maxtype) {
      coerce = TRUE;
      if (!isFactor(li)) li = PROTECT(coerceVector(li, maxtype));
      else li = PROTECT(asCharacterFactor(li));
    }
    switch (maxtype) {
    case INTSXP :
      for (j=0; j<maxlen; j++) {
        thisi = VECTOR_ELT(ans, j);
        INTEGER(thisi)[k] = (j < len[i]) ? INTEGER(li)[j] : INTEGER(fill)[0];
      }
      break;
    case LGLSXP :
      for (j=0; j<maxlen; j++) {
        thisi = VECTOR_ELT(ans, j);
        LOGICAL(thisi)[k] = (j < len[i]) ? LOGICAL(li)[j] : LOGICAL(fill)[0];
      }
      break;
    case REALSXP :
      for (j=0; j<maxlen; j++) {
        thisi = VECTOR_ELT(ans, j);
        REAL(thisi)[k] = (j < len[i]) ? REAL(li)[j] : REAL(fill)[0];
      }
      break;
    case STRSXP :
      for (j=0; j<maxlen; j++) {
        thisi = VECTOR_ELT(ans, j);
        SET_STRING_ELT(thisi, k, (j < len[i]) ? STRING_ELT(li, j) : STRING_ELT(fill, 0));
      }
      break;
    default :
        error("Unsupported column type '%s'", type2char(maxtype));
    }
    if (coerce) {
      coerce = FALSE;
      UNPROTECT(1);
    }
    k++;
  }
  UNPROTECT(2);
  return(ans);
}
Example #26
0
SEXP port_nlsb(SEXP m, SEXP d, SEXP gg, SEXP iv, SEXP v,
	       SEXP lowerb, SEXP upperb)
{
    int *dims = INTEGER(getAttrib(gg, R_DimSymbol));
    int i, n = LENGTH(d), p = LENGTH(d), nd = dims[0];
    SEXP getPars, setPars, resid, gradient,
	rr = PROTECT(allocVector(REALSXP, nd)),
	x = PROTECT(allocVector(REALSXP, n));
    // This used to use Calloc, but that will leak if 
    // there is a premature return (and did in package drfit)
    double *b = (double *) NULL,
	*rd = (double *)R_alloc(nd, sizeof(double));

    if (!isReal(d) || n < 1)
	error(_("'d' must be a nonempty numeric vector"));
    if(!isNewList(m)) error(_("m must be a list"));
				/* Initialize parameter vector */
    getPars = PROTECT(lang1(getFunc(m, "getPars", "m")));
    eval_check_store(getPars, R_GlobalEnv, x);
				/* Create the setPars call */
    setPars = PROTECT(lang2(getFunc(m, "setPars", "m"), x));
				/* Evaluate residual and gradient */
    resid = PROTECT(lang1(getFunc(m, "resid", "m")));
    eval_check_store(resid, R_GlobalEnv, rr);
    gradient = PROTECT(lang1(getFunc(m, "gradient", "m")));
    neggrad(gradient, R_GlobalEnv, gg);

    if ((LENGTH(lowerb) == n) && (LENGTH(upperb) == n)) {
	if (isReal(lowerb) && isReal(upperb)) {
	    double *rl = REAL(lowerb), *ru = REAL(upperb);
	    b = (double *)R_alloc(2*n, sizeof(double));
	    for (i = 0; i < n; i++) {
		b[2*i] = rl[i];
		b[2*i + 1] = ru[i];
	    }
	} else error(_("'lowerb' and 'upperb' must be numeric vectors"));
    }

    do {
	nlsb_iterate(b, REAL(d), REAL(gg), INTEGER(iv), LENGTH(iv),
		     LENGTH(v), n, nd, p, REAL(rr), rd,
		     REAL(v), REAL(x));
	switch(INTEGER(iv)[0]) {
	case -3:
	    eval(setPars, R_GlobalEnv);
	    eval_check_store(resid, R_GlobalEnv, rr);
	    neggrad(gradient, R_GlobalEnv, gg);
	    break;
	case -2:
	    eval_check_store(resid, R_GlobalEnv, rr);
	    neggrad(gradient, R_GlobalEnv, gg);
	    break;
	case -1:
	    eval(setPars, R_GlobalEnv);
	    eval_check_store(resid, R_GlobalEnv, rr);
	    neggrad(gradient, R_GlobalEnv, gg);
	    break;
	case 0:
	    Rprintf("nlsb_iterate returned %d", INTEGER(iv)[0]);
	    break;
	case 1:
	    eval(setPars, R_GlobalEnv);
	    eval_check_store(resid, R_GlobalEnv, rr);
	    break;
	case 2:
	    eval(setPars, R_GlobalEnv);
	    neggrad(gradient, R_GlobalEnv, gg);
	    break;
	}
    } while(INTEGER(iv)[0] < 3);

    UNPROTECT(6);
    return R_NilValue;
}
Example #27
0
File: nls.c Project: Bgods/r-source
/*
 *  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);
}
Example #28
0
_Bool userOverride(int8_t *type, lenOff *colNames, const char *anchor, int ncol)
{
  // use typeSize superfluously to avoid not-used warning; otherwise could move typeSize from fread.h into fread.c
  if (typeSize[CT_BOOL8_N]!=1) STOP("Internal error: typeSize[CT_BOOL8_N] != 1"); // # nocov
  if (typeSize[CT_STRING]!=8) STOP("Internal error: typeSize[CT_STRING] != 1"); // # nocov
  colNamesSxp = R_NilValue;
  if (colNames!=NULL) {
    SET_VECTOR_ELT(RCHK, 1, colNamesSxp=allocVector(STRSXP, ncol));
    for (int i=0; i<ncol; i++) {
      SEXP elem;
      if (colNames[i].len<=0) {
        char buff[12];
        sprintf(buff,"V%d",i+1);
        elem = mkChar(buff);  // no PROTECT as passed immediately to SET_STRING_ELT
      } else {
        elem = mkCharLenCE(anchor+colNames[i].off, colNames[i].len, ienc);  // no PROTECT as passed immediately to SET_STRING_ELT
      }
      SET_STRING_ELT(colNamesSxp, i, elem);
    }
  }
  if (length(colClassesSxp)) {
    SEXP typeRName_sxp = PROTECT(allocVector(STRSXP, NUT));
    for (int i=0; i<NUT; i++) SET_STRING_ELT(typeRName_sxp, i, mkChar(typeRName[i]));
    if (isString(colClassesSxp)) {
      SEXP typeEnum_idx = PROTECT(chmatch(colClassesSxp, typeRName_sxp, NUT, FALSE));
      if (LENGTH(colClassesSxp)==1) {
        signed char newType = typeEnum[INTEGER(typeEnum_idx)[0]-1];
        if (newType == CT_DROP) STOP("colClasses='NULL' is not permitted; i.e. to drop all columns and load nothing");
        for (int i=0; i<ncol; i++) type[i]=newType;   // freadMain checks bump up only not down
      } else if (LENGTH(colClassesSxp)==ncol) {
        for (int i=0; i<ncol; i++) {
          if (STRING_ELT(colClassesSxp,i)==NA_STRING) continue; // user is ok with inherent type for this column
          type[i] = typeEnum[INTEGER(typeEnum_idx)[i]-1];
        }
      } else {
        STOP("colClasses is an unnamed character vector but its length is %d. Must be length 1 or ncol (%d in this case) when unnamed. To specify types for a subset of columns you can either name the items with the column names or pass list() format to colClasses using column names or column numbers. See examples in ?fread.",
              LENGTH(colClassesSxp), ncol);
      }
      UNPROTECT(1); // typeEnum_idx
    } else {
      if (!isNewList(colClassesSxp)) STOP("CfreadR: colClasses is not type list");
      if (!length(getAttrib(colClassesSxp, R_NamesSymbol))) STOP("CfreadR: colClasses is type list but has no names");
      SEXP typeEnum_idx = PROTECT(chmatch(PROTECT(getAttrib(colClassesSxp, R_NamesSymbol)), typeRName_sxp, NUT, FALSE));
      for (int i=0; i<LENGTH(colClassesSxp); i++) {
        SEXP items;
        signed char thisType = typeEnum[INTEGER(typeEnum_idx)[i]-1];
        items = VECTOR_ELT(colClassesSxp,i);
        if (thisType == CT_DROP) {
          if (!isNull(dropSxp) || !isNull(selectSxp)) {
            if (dropSxp!=items) DTWARN("Ignoring the NULL item in colClasses= because select= or drop= has been used.");
            // package damr has a nice workaround for when NULL didn't work before v1.12.0: it sets drop=col_class$`NULL`. So allow that unambiguous case with no warning.
          } else {
            dropSxp = items;
          }
          continue;
        }
        SEXP itemsInt;
        if (isString(items)) itemsInt = PROTECT(chmatch(items, colNamesSxp, NA_INTEGER, FALSE));
        else                 itemsInt = PROTECT(coerceVector(items, INTSXP));
        // UNPROTECTed directly just after this for loop. No protecti++ here is correct.
        for (int j=0; j<LENGTH(items); j++) {
          int k = INTEGER(itemsInt)[j];
          if (k==NA_INTEGER) {
            if (isString(items)) STOP("Column name '%s' in colClasses[[%d]] not found", CHAR(STRING_ELT(items, j)),i+1);
            else STOP("colClasses[[%d]][%d] is NA", i+1, j+1);
          } else {
            if (k<1 || k>ncol) STOP("Column number %d (colClasses[[%d]][%d]) is out of range [1,ncol=%d]",k,i+1,j+1,ncol);
            k--;
            if (type[k]<0) STOP("Column '%s' appears more than once in colClasses", CHAR(STRING_ELT(colNamesSxp,k)));
            type[k] = -thisType;
            // freadMain checks bump up only not down.  Deliberately don't catch here to test freadMain; e.g. test 959
          }
        }
        UNPROTECT(1); // UNPROTECTing itemsInt inside loop to save protection stack
      }
      for (int i=0; i<ncol; i++) if (type[i]<0) type[i] *= -1;  // undo sign; was used to detect duplicates
      UNPROTECT(2);  // typeEnum_idx (+1 for its protect of getAttrib)
    }
    UNPROTECT(1);  // typeRName_sxp
  }
  if (readInt64As != CT_INT64) {
    for (int i=0; i<ncol; i++) if (type[i]==CT_INT64) type[i] = readInt64As;
  }
  if (length(dropSxp)) {
    SEXP itemsInt;
    if (isString(dropSxp)) itemsInt = PROTECT(chmatch(dropSxp, colNamesSxp, NA_INTEGER, FALSE));
    else                   itemsInt = PROTECT(coerceVector(dropSxp, INTSXP));
    for (int j=0; j<LENGTH(itemsInt); j++) {
      int k = INTEGER(itemsInt)[j];
      if (k==NA_INTEGER) {
        if (isString(dropSxp)) {
          DTWARN("Column name '%s' in 'drop' not found", CHAR(STRING_ELT(dropSxp, j)));
        } else {
          DTWARN("drop[%d] is NA", j+1);
        }
      } else {
        if (k<1 || k>ncol) {
          DTWARN("Column number %d (drop[%d]) is out of range [1,ncol=%d]",k,j+1,ncol);
        } else {
          // if (type[k-1] == CT_DROP) DTWARN("drop= contains duplicates");
          // NULL in colClasses didn't work between 1.11.0 and 1.11.8 so people have been using drop= to re-specify the NULL columns in colClasses. Now that NULL in colClasses works
          // from v1.12.0 there is no easy way to distinguish dups in drop= from drop overlapping with NULLs in colClasses. But it's unambiguous that it was intended to remove these
          // columns, so no need for warning.
          type[k-1] = CT_DROP;
        }
      }
    }
    UNPROTECT(1); // itemsInt
  } else if (length(selectSxp)) {
    SEXP tt;
    if (isString(selectSxp)) {
      // invalid cols check part of #1445 moved here (makes sense before reading the file)
      tt = PROTECT(chmatch(selectSxp, colNamesSxp, NA_INTEGER, FALSE));
      for (int i=0; i<length(selectSxp); i++) if (INTEGER(tt)[i]==NA_INTEGER)
        DTWARN("Column name '%s' not found in column name header (case sensitive), skipping.", CHAR(STRING_ELT(selectSxp, i)));
    } else {
      tt = PROTECT(selectSxp); // harmless superfluous PROTECT, for ease of balancing
    }
    for (int i=0; i<LENGTH(tt); i++) {
      int k = isInteger(tt) ? INTEGER(tt)[i] : (int)REAL(tt)[i];
      if (k == NA_INTEGER) continue;
      if (k<0) STOP("Column number %d (select[%d]) negative but should be in the range [1,ncol=%d]. Consider drop= for column exclusion.",k,i+1,ncol);
      if (k==0) STOP("select = 0 (select[%d]) has no meaning. All values of select should be in the range [1,ncol=%d].",i+1,ncol);
      if (k>ncol) STOP("Column number %d (select[%d]) is too large for this table, which only has %d columns.",k,i+1,ncol);
      if (type[k-1]<0) STOP("Column number %d ('%s') has been selected twice by select=", k, CHAR(STRING_ELT(colNamesSxp,k-1)));
      type[k-1] *= -1; // detect and error on duplicates on all types without calling duplicated() at all
    }
    for (int i=0; i<ncol; i++) {
      if (type[i]<0) type[i] *= -1;
      else type[i]=CT_DROP;
    }
    UNPROTECT(1); // tt
  }
  return true;
}
Example #29
0
_Bool userOverride(int8_t *type, lenOff *colNames, const char *anchor, int ncol)
{
  // use typeSize superfluously to avoid not-used warning; otherwise could move typeSize from fread.h into fread.c
  if (typeSize[CT_BOOL8]!=1) STOP("Internal error: typeSize[CT_BOOL8] != 1");
  if (typeSize[CT_STRING]!=8) STOP("Internal error: typeSize[CT_STRING] != 1");
  colNamesSxp = NULL;
  if (colNames!=NULL) {
    colNamesSxp = PROTECT(allocVector(STRSXP, ncol));
    protecti++;
    for (int i=0; i<ncol; i++) {
      SEXP this;
      if (colNames[i].len<=0) {
        char buff[10];
        sprintf(buff,"V%d",i+1);
        this = mkChar(buff);
      } else {
        this = mkCharLenCE(anchor+colNames[i].off, colNames[i].len, ienc);
      }
      SET_STRING_ELT(colNamesSxp, i, this);
    }
  }
  if (length(colClassesSxp)) {
    SEXP typeRName_sxp = PROTECT(allocVector(STRSXP, NUT));
    protecti++;
    for (int i=0; i<NUT; i++) SET_STRING_ELT(typeRName_sxp, i, mkChar(typeRName[i]));
    if (isString(colClassesSxp)) {
      SEXP typeEnum_idx = PROTECT(chmatch(colClassesSxp, typeRName_sxp, NUT, FALSE));
      protecti++;
      if (LENGTH(colClassesSxp)==1) {
        signed char newType = typeEnum[INTEGER(typeEnum_idx)[0]-1];
        if (newType == CT_DROP) STOP("colClasses='drop' is not permitted; i.e. to drop all columns and load nothing");
        for (int i=0; i<ncol; i++) type[i]=newType;   // freadMain checks bump up only not down
      } else if (LENGTH(colClassesSxp)==ncol) {
        for (int i=0; i<ncol; i++) {
          if (STRING_ELT(colClassesSxp,i)==NA_STRING) continue; // user is ok with inherent type for this column
          type[i] = typeEnum[INTEGER(typeEnum_idx)[i]-1];
        }
      } else {
        STOP("colClasses is an unnamed character vector but its length is %d. Must be length 1 or ncol (%d in this case) when unnamed. To specify types for a subset of columns you can either name the items with the column names or pass list() format to colClasses using column names or column numbers. See examples in ?fread.",
              LENGTH(colClassesSxp), ncol);
      }
    } else {
      if (!isNewList(colClassesSxp)) STOP("CfreadR: colClasses is not type list");
      if (!length(getAttrib(colClassesSxp, R_NamesSymbol))) STOP("CfreadR: colClasses is type list but has no names");
      SEXP typeEnum_idx = PROTECT(chmatch(getAttrib(colClassesSxp, R_NamesSymbol), typeRName_sxp, NUT, FALSE));
      protecti++;
      for (int i=0; i<LENGTH(colClassesSxp); i++) {
        SEXP items;
        signed char thisType = typeEnum[INTEGER(typeEnum_idx)[i]-1];
        items = VECTOR_ELT(colClassesSxp,i);
        if (thisType == CT_DROP) {
          if (!isNull(dropSxp) || !isNull(selectSxp)) STOP("Can't use NULL in colClasses when select or drop is used as well.");
          dropSxp = items;
          continue;
        }
        SEXP itemsInt;
        if (isString(items)) itemsInt = PROTECT(chmatch(items, colNamesSxp, NA_INTEGER, FALSE));
        else itemsInt = PROTECT(coerceVector(items, INTSXP));
        protecti++;
        for (int j=0; j<LENGTH(items); j++) {
          int k = INTEGER(itemsInt)[j];
          if (k==NA_INTEGER) {
            if (isString(items)) STOP("Column name '%s' in colClasses[[%d]] not found", CHAR(STRING_ELT(items, j)),i+1);
            else STOP("colClasses[[%d]][%d] is NA", i+1, j+1);
          } else {
            if (k<1 || k>ncol) STOP("Column number %d (colClasses[[%d]][%d]) is out of range [1,ncol=%d]",k,i+1,j+1,ncol);
            k--;
            if (type[k]<0) STOP("Column '%s' appears more than once in colClasses", CHAR(STRING_ELT(colNamesSxp,k)));
            type[k] = -thisType;
            // freadMain checks bump up only not down.  Deliberately don't catch here to test freadMain; e.g. test 959
          }
        }
      }
      for (int i=0; i<ncol; i++) if (type[i]<0) type[i] *= -1;  // undo sign; was used to detect duplicates
    }
  }
  if (readInt64As != CT_INT64) {
    for (int i=0; i<ncol; i++) if (type[i]==CT_INT64) type[i] = readInt64As;
  }
  if (length(dropSxp)) {
    SEXP itemsInt;
    if (isString(dropSxp)) itemsInt = PROTECT(chmatch(dropSxp, colNamesSxp, NA_INTEGER, FALSE));
    else itemsInt = PROTECT(coerceVector(dropSxp, INTSXP));
    protecti++;
    for (int j=0; j<LENGTH(itemsInt); j++) {
      int k = INTEGER(itemsInt)[j];
      if (k==NA_INTEGER) {
        if (isString(dropSxp)) {
          DTWARN("Column name '%s' in 'drop' not found", CHAR(STRING_ELT(dropSxp, j)));
        } else {
          DTWARN("drop[%d] is NA", j+1);
        }
      } else {
        if (k<1 || k>ncol) {
          DTWARN("Column number %d (drop[%d]) is out of range [1,ncol=%d]",k,j+1,ncol);
        } else {
          if (type[k-1] == CT_DROP) STOP("Duplicates detected in drop");
          type[k-1] = CT_DROP;
        }
      }
    }
  } else if (length(selectSxp)) {
    SEXP tt;
    if (isString(selectSxp)) {
      // invalid cols check part of #1445 moved here (makes sense before reading the file)
      tt = PROTECT(chmatch(selectSxp, colNamesSxp, NA_INTEGER, FALSE));
      protecti++;
      for (int i=0; i<length(selectSxp); i++) if (INTEGER(tt)[i]==NA_INTEGER)
        DTWARN("Column name '%s' not found in column name header (case sensitive), skipping.", CHAR(STRING_ELT(selectSxp, i)));
    } else tt = selectSxp;
    for (int i=0; i<LENGTH(tt); i++) {
      int k = isInteger(tt) ? INTEGER(tt)[i] : (int)REAL(tt)[i];
      if (k == NA_INTEGER) continue;
      if (k<1 || k>ncol) STOP("Column number %d (select[%d]) is out of range [1,ncol=%d]",k,i+1,ncol);
      if (type[k-1]<0) STOP("Column number %d ('%s') has been selected twice by select=", k, STRING_ELT(colNames,k-1));
      type[k-1] *= -1; // detect and error on duplicates on all types without calling duplicated() at all
    }
    for (int i=0; i<ncol; i++) {
      if (type[i]<0) type[i] *= -1;
      else type[i]=CT_DROP;
    }
  }
  return TRUE;  // continue
}
Example #30
0
SEXP sampler_glue_R_dist(SEXP sampler, SEXP sampler_context, SEXP log_dens,
                         SEXP x0, SEXP sample_size, SEXP tuning, SEXP envir) {

  // Check parameters for validity and unpack some of them into C types.

  if (!isEnvironment(envir))
    error("envir is not an environment.");

  int sample_size_int = asInteger(sample_size);
  if (sample_size_int<1)
    error("sample size must be a positive integer.");
  int ndim = length(x0);

  double tuning_dbl = asReal(tuning);
  double *x0_dbl = REAL(x0);

  // Locate the sampler as a function pointer.

  if (!isString(sampler))
    error("sampler is not a character string.");
  sampler_t *sampler_fp =
    (sampler_t*)R_FindSymbol(CHAR(STRING_ELT(sampler,0)), "", NULL);
  if (sampler_fp==NULL)
    error("Cannot locate symbol \"%s\".", CHAR(STRING_ELT(sampler,0)));

  // Create a stub for log_dens so that it looks like a C density
  // to the sampler.

  R_stub_context_t stub_context =
    { .log_dens=log_dens, .envir=envir, .evals=0, .grads=0 };
  SEXP raw_context;
  PROTECT(raw_context = void_as_raw(&stub_context));
  dist_t stub_ds = { .log_dens=R_log_density_stub_func,
                     .context=raw_context, .ndim=ndim };

  // Allocate a result matrix, set up the RNG, and call the sampler
  // to draw a sample.

  SEXP X_out;
  PROTECT(X_out = allocMatrix(REALSXP, sample_size_int, ndim));
  GetRNGstate();
  sampler_fp(sampler_context, &stub_ds, x0_dbl, sample_size_int,
             tuning_dbl, REAL(X_out));
  PutRNGstate();

  // Set up return value as an R object.

  SEXP ans, ans_names;
  PROTECT(ans = allocVector(VECSXP, 3));
  SET_VECTOR_ELT(ans, 0, X_out);
  SET_VECTOR_ELT(ans, 1, ScalarInteger(stub_context.evals));
  SET_VECTOR_ELT(ans, 2, ScalarInteger(stub_context.grads));
  PROTECT(ans_names = allocVector(VECSXP, 3));
  SET_VECTOR_ELT(ans_names, 0, mkString("X"));
  SET_VECTOR_ELT(ans_names, 1, mkString("evals"));
  SET_VECTOR_ELT(ans_names, 2, mkString("grads"));
  setAttrib(ans, R_NamesSymbol, ans_names);
  UNPROTECT(4);

  return(ans);
}

// This function wraps an R log density function so that it exposes
// the interface expected by a sampler_t and keeps track of the number
// of times it is called.

static double R_log_density_stub_func(dist_t *ds, double *x,
                                      int compute_grad, double *grad) {
  SEXP xsexp, fcall, result_sexp, compute_grad_sexp, result_names;

  R_stub_context_t *stub_context = (R_stub_context_t*)raw_as_void(ds->context);

  // Allocate R variables for the arguments to the R log.density.and.grad
  // and call it.

  PROTECT(xsexp = allocVector(REALSXP, ds->ndim));
  memmove(REAL(xsexp), x, sizeof(double)*ds->ndim);
  PROTECT(compute_grad_sexp = allocVector(LGLSXP, 1));
  LOGICAL(compute_grad_sexp)[0] = (compute_grad!=0);
  PROTECT(fcall = lang3(stub_context->log_dens, xsexp, compute_grad_sexp));
  PROTECT(result_sexp = eval(fcall, stub_context->envir));

  double log_dens = NAN;
  int found_log_dens=0, found_grad=0;

  // Unpack the results from the log.density.and.grad into the
  // variable log_dens and (if appropriate) the memory pointed to by
  // grad.

  if (!isNewList(result_sexp)) {
    error("log density function must return a list.");
  }
  PROTECT(result_names = getAttrib(result_sexp, R_NamesSymbol));
  for (int i = 0; i < length(result_sexp); i++) {
    if (!strcmp(CHAR(STRING_ELT(result_names,i)), "log.density")) {
      log_dens = asReal(VECTOR_ELT(result_sexp, i));
      found_log_dens = 1;
    }
    if (compute_grad &&
        !strcmp(CHAR(STRING_ELT(result_names,i)), "grad.log.density")) {
      memmove(grad, REAL(VECTOR_ELT(result_sexp, i)), sizeof(double)*ds->ndim);
      found_grad = 1;
    }
  }

  UNPROTECT(5);

  // Throw an error if the log density did not return the appropriate
  // list elements.

  if (!found_log_dens)
    error("log density did not return log.density element.");
  if (!found_grad && compute_grad)
    error("log density did not return grad.log.density element.");

  // Increment the evaluation counters.

  stub_context->evals++;
  if (compute_grad)
    stub_context->grads++;

  return log_dens;
}