Exemplo n.º 1
0
LVal filter_sbcl_uri(LVal v) {
  char* str=subseq(firsts(v),-3,0);
  if(strcmp(str,"bz2")==0 ||
     strcmp(str,"msi")==0) {
    char* u=uname();
    char* m=uname_m();
    char *third,*fourth;
    char *m2;
    int i;
    char* tmp=file_namestring(q(firsts(v)));
    LVal ret= split_string(tmp,"-");
    s(tmp);
    third=firsts(nthcdr(2,ret));
    fourth=firsts(nthcdr(3,ret));
    if(strcmp(third,"x86")==0 &&
       strcmp(fourth,"64")==0) {
      m2=q("x86-64");
      i=4;
    }else {
      m2=q(third);
      i=3;
    }
    i=(strcmp(m2,m)==0 && strcmp(firsts(nthcdr(i,ret)),u)==0);

    s(m2),s(str),s(m),s(u),sL(ret);
    return i?toNumber(1):0;
  }
  s(str);
  return 0;
}
Exemplo n.º 2
0
/* This is used for [[ and [[<- with a vector of indices of length > 1 .
   x is a list or pairlist, and it is indexed recusively from
   level start to level stop-1.  ( 0...len-1 or 0..len-2 then len-1).
   For [[<- it needs to duplicate if substructure might be shared.
 */
SEXP attribute_hidden
vectorIndex(SEXP x, SEXP thesub, int start, int stop, int pok, SEXP call,
	    Rboolean dup)
{
    int i;
    R_xlen_t offset;
    SEXP cx;

    /* sanity check */
    if (dup && MAYBE_SHARED(x))
	error("should only be called in an assignment context.");

    for(i = start; i < stop; i++) {
	if(!isVectorList(x) && !isPairList(x)) {
	    if (i)
		errorcall(call, _("recursive indexing failed at level %d\n"), i+1);
	    else
		errorcall(call, _("attempt to select more than one element"));
	}
	PROTECT(x);
	SEXP names = PROTECT(getAttrib(x, R_NamesSymbol));
	offset = get1index(thesub, names,
		           xlength(x), pok, i, call);
	UNPROTECT(2); /* x, names */
	if(offset < 0 || offset >= xlength(x))
	    errorcall(call, _("no such index at level %d\n"), i+1);
	if(isPairList(x)) {
#ifdef LONG_VECTOR_SUPPORT
	    if (offset > R_SHORT_LEN_MAX)
		error("invalid subscript for pairlist");
#endif
	    cx = nthcdr(x, (int) offset);
	    if (NAMED(x) > NAMED(CAR(cx)))
		SET_NAMED(CAR(x), NAMED(x));
	    x = CAR(cx);
	    if (dup && MAYBE_SHARED(x)) {
		x = shallow_duplicate(x);
		SETCAR(cx, x);
	    }
	} else {
	    cx = x;
	    x = VECTOR_ELT(x, offset);
	    if (NAMED(cx) > NAMED(x))
		SET_NAMED(x, NAMED(cx));
	    if (dup && MAYBE_SHARED(x)) {
		x = shallow_duplicate(x);
		SET_VECTOR_ELT(cx, offset, x);
	    }
	}
    }
    return x;
}
Exemplo n.º 3
0
char* sbcl_bin(char* file) {
  char* str;
  LVal ret3,ret2,ret;
  cond_printf(1,"uname=%s uname-m=%s\n",uname(),uname_m());
  ret=atag_list(file);
  ret2=remove_if_not1(filter_sbcl_uri,ret);
  if(ret2==(LVal)NULL) {
    fprintf(stderr,"this architecture is not supported.stop\n");
    exit(1);
  }
  if(verbose&2)
    print_list(ret2);
  ret3= split_string(firsts(ret2),"-");
  str=q(firsts(nthcdr(1,ret3)));
  sL(ret),sL(ret2),sL(ret3);
  return str;
}
Exemplo n.º 4
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;
}
Exemplo n.º 5
0
static SEXP ExtractSubset(SEXP x, SEXP result, SEXP indx, SEXP call)
{
    R_xlen_t i, ii, n, nx;
    int mode, mi;
    SEXP tmp, tmp2;
    mode = TYPEOF(x);
    mi = TYPEOF(indx);
    n = XLENGTH(indx);
    nx = xlength(x);
    tmp = result;

    if (x == R_NilValue)
	return x;

    for (i = 0; i < n; i++) {
	switch(mi) {
	case REALSXP:
	    if(!R_FINITE(REAL(indx)[i])) ii = NA_INTEGER;
	    else ii = (R_xlen_t) (REAL(indx)[i] - 1);
	    break;
	default:
	    ii = INTEGER(indx)[i];
	    if (ii != NA_INTEGER) ii--;
	}
	switch (mode) {
	    /* NA_INTEGER < 0, so some of this is redundant */
	case LGLSXP:
	    if (0 <= ii && ii < nx && ii != NA_INTEGER)
		LOGICAL(result)[i] = LOGICAL(x)[ii];
	    else
		LOGICAL(result)[i] = NA_INTEGER;
	    break;
	case INTSXP:
	    if (0 <= ii && ii < nx && ii != NA_INTEGER)
		INTEGER(result)[i] = INTEGER(x)[ii];
	    else
		INTEGER(result)[i] = NA_INTEGER;
	    break;
	case REALSXP:
	    if (0 <= ii && ii < nx && ii != NA_INTEGER)
		REAL(result)[i] = REAL(x)[ii];
	    else
		REAL(result)[i] = NA_REAL;
	    break;
	case CPLXSXP:
	    if (0 <= ii && ii < nx && ii != NA_INTEGER) {
		COMPLEX(result)[i] = COMPLEX(x)[ii];
	    } else {
		COMPLEX(result)[i].r = NA_REAL;
		COMPLEX(result)[i].i = NA_REAL;
	    }
	    break;
	case STRSXP:
	    if (0 <= ii && ii < nx && ii != NA_INTEGER)
		SET_STRING_ELT(result, i, STRING_ELT(x, ii));
	    else
		SET_STRING_ELT(result, i, NA_STRING);
	    break;
	case VECSXP:
	case EXPRSXP:
	    if (0 <= ii && ii < nx && ii != NA_INTEGER)
		SET_VECTOR_ELT(result, i, VECTOR_ELT_FIX_NAMED(x, ii));
	    else
		SET_VECTOR_ELT(result, i, R_NilValue);
	    break;
	case LISTSXP:
	    /* cannot happen: pairlists are coerced to lists */
	case LANGSXP:
#ifdef LONG_VECTOR_SUPPORT
	    if (ii > R_SHORT_LEN_MAX)
		error("invalid subscript for pairlist");
#endif
	    if (0 <= ii && ii < nx && ii != NA_INTEGER) {
		tmp2 = nthcdr(x, (int) ii);
		SETCAR(tmp, CAR(tmp2));
		SET_TAG(tmp, TAG(tmp2));
	    }
	    else
		SETCAR(tmp, R_NilValue);
	    tmp = CDR(tmp);
	    break;
	case RAWSXP:
	    if (0 <= ii && ii < nx && ii != NA_INTEGER)
		RAW(result)[i] = RAW(x)[ii];
	    else
		RAW(result)[i] = (Rbyte) 0;
	    break;
	default:
	    errorcall(call, R_MSG_ob_nonsub, type2char(mode));
	}
    }
    return result;
}
Exemplo n.º 6
0
Arquivo: seq.c Projeto: Vladimir84/rcc
static SEXP rep(SEXP s, SEXP ncopy)
{
    int i, ns, na, nc;
    SEXP a, t;

    if (!isVector(ncopy))
	error(_("rep() incorrect type for second argument"));

    if (!isVector(s) && (!isList(s)))
	error(_("attempt to replicate non-vector"));

    if ((length(ncopy) == length(s)))
	return rep2(s, ncopy);

    if ((length(ncopy) != 1))
	error(_("invalid number of copies in rep()"));

    if ((nc = asInteger(ncopy)) == NA_INTEGER || nc < 0)/* nc = 0 ok */
	error(_("invalid number of copies in rep()"));

    ns = length(s);
    na = nc * ns;
    if (isVector(s))
	a = allocVector(TYPEOF(s), na);
    else
	a = allocList(na);
    PROTECT(a);

    switch (TYPEOF(s)) {
    case LGLSXP:
	for (i = 0; i < na; i++)
	    LOGICAL(a)[i] = LOGICAL(s)[i % ns];
	break;
    case INTSXP:
	for (i = 0; i < na; i++)
	    INTEGER(a)[i] = INTEGER(s)[i % ns];
	break;
    case REALSXP:
	for (i = 0; i < na; i++)
	    REAL(a)[i] = REAL(s)[i % ns];
	break;
    case CPLXSXP:
	for (i = 0; i < na; i++)
	    COMPLEX(a)[i] = COMPLEX(s)[i % ns];
	break;
    case STRSXP:
	for (i = 0; i < na; i++)
	    SET_STRING_ELT(a, i, STRING_ELT(s, i% ns));
	break;
    case LISTSXP:
	i = 0;
	for (t = a; t != R_NilValue; t = CDR(t), i++)
	    SETCAR(t, duplicate(CAR(nthcdr(s, (i % ns)))));
	break;
    case VECSXP:
	i = 0;
	for (i = 0; i < na; i++)
	    SET_VECTOR_ELT(a, i, duplicate(VECTOR_ELT(s, i% ns)));
	break;
    case RAWSXP:
	for (i = 0; i < na; i++)
	    RAW(a)[i] = RAW(s)[i % ns];
	break;
    default:
	UNIMPLEMENTED_TYPE("rep", s);
    }
    if (inherits(s, "factor")) {
	SEXP tmp;
	if(inherits(s, "ordered")) {
	    PROTECT(tmp = allocVector(STRSXP, 2));
	    SET_STRING_ELT(tmp, 0, mkChar("ordered"));
	    SET_STRING_ELT(tmp, 1, mkChar("factor"));
	}
	else {
	    PROTECT(tmp = allocVector(STRSXP, 1));
	    SET_STRING_ELT(tmp, 0, mkChar("factor"));
	}
	setAttrib(a, R_ClassSymbol, tmp);
	UNPROTECT(1);
	setAttrib(a, R_LevelsSymbol, getAttrib(s, R_LevelsSymbol));
    }
    UNPROTECT(1);
    return a;
}
Exemplo n.º 7
0
Arquivo: seq.c Projeto: Vladimir84/rcc
/* It is assumed that type-checking has been done in rep */
static SEXP rep2(SEXP s, SEXP ncopy)
{
    int i, na, nc, n, j;
    SEXP a, t, u;

    t = coerceVector(ncopy, INTSXP);
    PROTECT(t);

    nc = length(ncopy);
    na = 0;
    for (i = 0; i < nc; i++) {
	if (INTEGER(t)[i] == NA_INTEGER || INTEGER(t)[i]<0)
	    error(_("invalid number of copies in rep()"));
	na += INTEGER(t)[i];
    }

    if (isVector(s))
	a = allocVector(TYPEOF(s), na);
    else
	a = allocList(na);
    PROTECT(a);
    n = 0;
    switch (TYPEOF(s)) {
    case LGLSXP:
	for (i = 0; i < nc; i++)
	    for (j = 0; j < (INTEGER(t)[i]); j++)
		LOGICAL(a)[n++] = LOGICAL(s)[i];
	break;
    case INTSXP:
	for (i = 0; i < nc; i++)
	    for (j = 0; j < (INTEGER(t)[i]); j++)
		INTEGER(a)[n++] = INTEGER(s)[i];
	break;
    case REALSXP:
	for (i = 0; i < nc; i++)
	    for (j = 0; j < (INTEGER(t)[i]); j++)
		REAL(a)[n++] = REAL(s)[i];
	break;
    case CPLXSXP:
	for (i = 0; i < nc; i++)
	    for (j = 0; j < (INTEGER(t)[i]); j++)
		COMPLEX(a)[n++] = COMPLEX(s)[i];
	break;
    case STRSXP:
	for (i = 0; i < nc; i++)
	    for (j = 0; j < (INTEGER(t)[i]); j++)
		SET_STRING_ELT(a, n++, STRING_ELT(s, i));
	break;
    case VECSXP:
    case EXPRSXP:
	for (i = 0; i < nc; i++)
	    for (j = 0; j < (INTEGER(t)[i]); j++)
		SET_VECTOR_ELT(a, n++, VECTOR_ELT(s, i));
	break;
    case LISTSXP:
	u = a;
	for (i = 0; i < nc; i++)
	    for (j = 0; j < (INTEGER(t)[i]); j++) {
		SETCAR(u, duplicate(CAR(nthcdr(s, i))));
		u = CDR(u);
	    }
	break;
    case RAWSXP:
	for (i = 0; i < nc; i++)
	    for (j = 0; j < (INTEGER(t)[i]); j++)
		RAW(a)[n++] = RAW(s)[i];
	break;
    default:
	UNIMPLEMENTED_TYPE("rep2", s);
    }
    if (inherits(s, "factor")) {
	SEXP tmp;
	if(inherits(s, "ordered")) {
	    PROTECT(tmp = allocVector(STRSXP, 2));
	    SET_STRING_ELT(tmp, 0, mkChar("ordered"));
	    SET_STRING_ELT(tmp, 1, mkChar("factor"));
	}
	else {
	    PROTECT(tmp = allocVector(STRSXP, 1));
	    SET_STRING_ELT(tmp, 0, mkChar("factor"));
	}
	setAttrib(a, R_ClassSymbol, tmp);
	UNPROTECT(1);
	setAttrib(a, R_LevelsSymbol, getAttrib(s, R_LevelsSymbol));
    }
    UNPROTECT(2);
    return a;
}
Exemplo n.º 8
0
// xtsExtractSubset {{{
static SEXP xtsExtractSubset(SEXP x, SEXP result, SEXP indx) //, SEXP call)
{
    int i, ii, n, nx, mode;
    SEXP tmp, tmp2;
    mode = TYPEOF(x);
    n = LENGTH(indx);
    nx = length(x);
    tmp = result;

    if (x == R_NilValue)
    return x;

    for (i = 0; i < n; i++) {
    ii = INTEGER(indx)[i];
    if (ii != NA_INTEGER)
        ii--;
    switch (mode) {
    case LGLSXP:
        if (0 <= ii && ii < nx && ii != NA_LOGICAL)
        LOGICAL(result)[i] = LOGICAL(x)[ii];
        else
        LOGICAL(result)[i] = NA_LOGICAL;
        break;
    case INTSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        INTEGER(result)[i] = INTEGER(x)[ii];
        else
        INTEGER(result)[i] = NA_INTEGER;
        break;
    case REALSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        REAL(result)[i] = REAL(x)[ii];
        else
        REAL(result)[i] = NA_REAL;
        break;
    case CPLXSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER) {
        COMPLEX(result)[i] = COMPLEX(x)[ii];
        }
        else {
        COMPLEX(result)[i].r = NA_REAL;
        COMPLEX(result)[i].i = NA_REAL;
        }
        break;
    case STRSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        SET_STRING_ELT(result, i, STRING_ELT(x, ii));
        else
        SET_STRING_ELT(result, i, NA_STRING);
        break;
    case VECSXP:
    case EXPRSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        SET_VECTOR_ELT(result, i, VECTOR_ELT(x, ii));
        else
        SET_VECTOR_ELT(result, i, R_NilValue);
        break;
    case LISTSXP:
        /* cannot happen: pairlists are coerced to lists */
    case LANGSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER) {
        tmp2 = nthcdr(x, ii);
        SETCAR(tmp, CAR(tmp2));
        SET_TAG(tmp, TAG(tmp2));
        }
        else
        SETCAR(tmp, R_NilValue);
        tmp = CDR(tmp);
        break;
    case RAWSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        RAW(result)[i] = RAW(x)[ii];
        else
        RAW(result)[i] = (Rbyte) 0;
        break;
    default:
        error("error in subset\n");
//      errorcall(call, R_MSG_ob_nonsub, type2char(mode));
        break;
    }
    }
    return result;
} //}}}
Exemplo n.º 9
0
static SEXP ExtractSubset(SEXP x, SEXP result, SEXP indx) //, SEXP call)
{
    /* ExtractSubset is currently copied/inspired by subset.c from GNU-R
       This is slated to be reimplemented using the previous method
       in xts to get the correct dimnames
    */
    int i, ii, n, nx, mode;
    SEXP tmp, tmp2;
    mode = TYPEOF(x);
    n = LENGTH(indx); 
    nx = length(x);
    tmp = result;
    
    /*if (x == R_NilValue)*/
    if (isNull(x))
    return x;
    
    for (i = 0; i < n; i++) {
    ii = INTEGER(indx)[i];
    if (ii != NA_INTEGER)
        ii--;
    switch (mode) {
    case LGLSXP:
        if (0 <= ii && ii < nx && ii != NA_LOGICAL)
        LOGICAL(result)[i] = LOGICAL(x)[ii];
        else
        LOGICAL(result)[i] = NA_LOGICAL;
        break;
    case INTSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        INTEGER(result)[i] = INTEGER(x)[ii];
        else
        INTEGER(result)[i] = NA_INTEGER;
        break;
    case REALSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        REAL(result)[i] = REAL(x)[ii];
        else
        REAL(result)[i] = NA_REAL;
        break;
    case CPLXSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER) {
        COMPLEX(result)[i] = COMPLEX(x)[ii];
        }
        else {
        COMPLEX(result)[i].r = NA_REAL;
        COMPLEX(result)[i].i = NA_REAL;
        }
        break;
    case STRSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        SET_STRING_ELT(result, i, STRING_ELT(x, ii));
        else
        SET_STRING_ELT(result, i, NA_STRING);
        break;
    case VECSXP:
    case EXPRSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        SET_VECTOR_ELT(result, i, VECTOR_ELT(x, ii));
        else
        SET_VECTOR_ELT(result, i, R_NilValue);
        break;
    case LISTSXP:
        /* cannot happen: pairlists are coerced to lists */
    case LANGSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER) {
        tmp2 = nthcdr(x, ii);
        SETCAR(tmp, CAR(tmp2));
        SET_TAG(tmp, TAG(tmp2));
        }
        else
        SETCAR(tmp, R_NilValue);
        tmp = CDR(tmp);
        break;
    case RAWSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        RAW(result)[i] = RAW(x)[ii];
        else
        RAW(result)[i] = (Rbyte) 0;
        break;
    default:
        error("error in subset\n");
        break;
    }
    }
    return result;
}
Exemplo n.º 10
0
SEXP call_slra( SEXP _p, SEXP _s, SEXP _r, SEXP _opt, 
                SEXP _compute_ph, SEXP _compute_Rh ) {
  char str_buf[STR_MAX_LEN];
  
  /* Required parameters */
  gsl_vector vec_ml = SEXP2vec(getListElement(_s, ML_STR)), 
      p_in = SEXP2vec(_p), vec_nk = SEXP2vec(getListElement(_s, NK_STR)),
      vec_wk = SEXP2vec(getListElement(_s, WK_STR));
  gsl_matrix phi = SEXP2mat(getListElement(_s, PERM_STR));
  int np = compute_np(&vec_ml, &vec_nk);
  int r = *INTEGER(_r), compute_ph = !!(*INTEGER(_compute_ph)),
      compute_Rh = !!(*INTEGER(_compute_Rh)), compute_vh = 1;
  /* Optional parameters */
  OptimizationOptions opt;
  getRSLRADispOption(_opt);
  getRSLRAMethodOption(&opt, _opt);
  getRSLRAOption(opt, _opt, maxiter, asInteger);
  getRSLRAOption(opt, _opt, epsabs, asReal);
  getRSLRAOption(opt, _opt, epsrel, asReal);
  getRSLRAOption(opt, _opt, epsgrad, asReal);
  getRSLRAOption(opt, _opt, epsx, asReal);
  getRSLRAOption(opt, _opt, step, asReal);
  getRSLRAOption(opt, _opt, tol, asReal);
  getRSLRAOption(opt, _opt, reggamma, asReal);
  getRSLRAOption(opt, _opt, ls_correction, asReal);
  getRSLRAOption(opt, _opt, maxx, asReal);
  SEXP _r_ini = getListElement(_opt, RINI_STR);

  /* Create output values */  
  SEXP _p_out = R_NilValue, _r_out = R_NilValue, _v_out = R_NilValue;
  
  Structure *myStruct = NULL;
  VarproFunction *myF = NULL;
  int was_error = 0;
  try {
    /* Create output info */
    myStruct = createMosaicStructure(&vec_ml, &vec_nk, vecChkNIL(vec_wk));  
    int m = phi.size2;
    if (compute_ph) {
      PROTECT(_p_out = allocVector(REALSXP, np));
    }
    if (compute_Rh) {
      PROTECT(_r_out = allocMatrix(REALSXP, (m-r), m));
    }
    if (compute_vh) {
      PROTECT(_v_out = allocMatrix(REALSXP, (m-r)*r, (m-r)*r));
    }    
    gsl_matrix rini = SEXP2mat(_r_ini), r_out = SEXP2mat(_r_out),
               v_out = SEXP2mat(_v_out);
    gsl_vector p_out = SEXP2vec(_p_out);
    
    if (rini.data != NULL && (rini.size2 != (m - r) || rini.size1 != m)) {
      throw new Exception("Incorrect Rini\n");   
    }
 
    myF = new VarproFunction(vecChkNIL(p_in), myStruct, m-r, &phi);
    
    slra(myF, &opt, matChkNIL(rini), NULL, 
         vecChkNIL(p_out), matChkNIL(r_out), matChkNIL(v_out));
  } catch (Exception *e) {
    strncpy(str_buf, e->getMessage(), STR_MAX_LEN - 1);
    str_buf[STR_MAX_LEN - 1] = 0;
    was_error = 1;
    delete e;
  }   
  
  if (myStruct != NULL) {
    delete myStruct;
  }
  
  if (myF != NULL) {
    delete myF;
  }
  
  if (was_error) {
    error(str_buf);
  }

  SEXP _res, _info;
  PROTECT(_info = list5(ScalarInteger(opt.iter), ScalarReal(opt.time), 
                        ScalarReal(opt.fmin), _r_out, _v_out));
  {
    const char *names[] = { FMIN_STR, ITER_STR, TIME_STR, RH_STR, VH_STR };
    for (int i = 0; i < sizeof(names) / sizeof(names[0]); i++) {
      SET_TAG(nthcdr(_info, i), install(names[i]));
    }  
  }                        
                          
  PROTECT(_res = list2(_p_out, _info));
  SET_TAG(_res, install(PH_STR));
  SET_TAG(CDR(_res), install(INFO_STR));
  UNPROTECT(2 + compute_ph + compute_Rh + compute_vh);
  
  Log::deleteLog();
  
  return _res;
}
Exemplo n.º 11
0
SEXP attribute_hidden do_switch(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    int argval, nargs = length(args);
    SEXP x, y, z, w, ans, dflt = NULL;

    if (nargs < 1) errorcall(call, _("'EXPR' is missing"));
    check1arg(args, call, "EXPR");
    PROTECT(x = eval(CAR(args), rho));
    if (!isVector(x) || length(x) != 1)
	errorcall(call, _("EXPR must be a length 1 vector"));
    if (isFactor(x))
	warningcall(call,
		    _("EXPR is a \"factor\", treated as integer.\n"
		      " Consider using '%s' instead."),
		    "switch(as.character( * ), ...)");
    if (nargs > 1) {
	/* There is a complication: if called from lapply
	   there may be a ... argument */
	PROTECT(w = expandDots(CDR(args), rho));
	if (isString(x)) {
	    for (y = w; y != R_NilValue; y = CDR(y)) {
		if (TAG(y) != R_NilValue) {
		    if (pmatch(STRING_ELT(x, 0), TAG(y), 1 /* exact */)) {
			/* Find the next non-missing argument.
			   (If there is none, return NULL.) */
			while (CAR(y) == R_MissingArg) {
			    y = CDR(y);
			    if (y == R_NilValue) break;
			    if (TAG(y) == R_NilValue) dflt = setDflt(y, dflt);
			}
			if (y == R_NilValue) {
			    R_Visible = FALSE;
			    UNPROTECT(2);
			    return R_NilValue;
			}
			/* Check for multiple defaults following y.  This loop
			   is not necessary to determine the value of the
			   switch(), but it should be fast and will detect
			   typos. */
			for (z = CDR(y); z != R_NilValue; z = CDR(z))
			    if (TAG(z) == R_NilValue) dflt = setDflt(z, dflt);

			ans =  eval(CAR(y), rho);
			UNPROTECT(2);
			return ans;
		    }
		} else
		    dflt = setDflt(y, dflt);
	    }
 	    if (dflt) {
		ans =  eval(dflt, rho);
		UNPROTECT(2);
		return ans;
	    }
	    /* fall through to error */
	} else { /* Treat as numeric */
	    argval = asInteger(x);
	    if (argval != NA_INTEGER && argval >= 1 && argval <= length(w)) {
		SEXP alt = CAR(nthcdr(w, argval - 1));
		if (alt == R_MissingArg)
		    error("empty alternative in numeric switch");
		ans =  eval(alt, rho);
		UNPROTECT(2);
		return ans;
	    }
	    /* fall through to error */
	}
	UNPROTECT(1); /* w */
    }
    /* an error */
    UNPROTECT(1); /* x */
    R_Visible = FALSE;
    return R_NilValue;
}