Beispiel #1
0
SEXP port_nlminb(SEXP fn, SEXP gr, SEXP hs, SEXP rho,
		 SEXP lowerb, SEXP upperb, SEXP d, SEXP iv, SEXP v)
{
    int i, n = LENGTH(d);
    SEXP xpt;
    SEXP dot_par_symbol = install(".par");
    double *b = (double *) NULL, *g = (double *) NULL,
	*h = (double *) NULL, fx = R_PosInf;
    if (isNull(rho)) {
	error(_("use of NULL environment is defunct"));
	rho = R_BaseEnv;
    } else
    if (!isEnvironment(rho))
	error(_("'rho' must be an environment"));
    if (!isReal(d) || n < 1)
	error(_("'d' must be a nonempty numeric vector"));
    if (hs != R_NilValue && gr == R_NilValue)
	error(_("When Hessian defined must also have gradient defined"));
    if (R_NilValue == (xpt = findVarInFrame(rho, dot_par_symbol)) ||
	!isReal(xpt) || LENGTH(xpt) != n)
	error(_("environment 'rho' must contain a numeric vector '.par' of length %d"),
	      n);
    /* We are going to alter .par, so must duplicate it */
    defineVar(dot_par_symbol, duplicate(xpt), rho);
    PROTECT(xpt = findVarInFrame(rho, dot_par_symbol));

    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(_("'lower' and 'upper' must be numeric vectors"));
    }
    if (gr != R_NilValue) {
	g = (double *)R_alloc(n, sizeof(double));
	if (hs != R_NilValue)
	    h = (double *)R_alloc((n * (n + 1))/2, sizeof(double));
    }

    do {
	nlminb_iterate(b, REAL(d), fx, g, h, INTEGER(iv), LENGTH(iv),
		       LENGTH(v), n, REAL(v), REAL(xpt));
	if (INTEGER(iv)[0] == 2 && g) check_gv(gr, hs, rho, n, g, h);
	else {
	    fx = asReal(eval(fn, rho));
	    if (ISNAN(fx)) {
		warning("NA/NaN function evaluation");
		fx = R_PosInf;
	    }
	}

	/* duplicate .par value again in case a callback has stored
	   value (package varComp does this) */
	defineVar(dot_par_symbol, duplicate(xpt), rho);
	xpt = findVarInFrame(rho, dot_par_symbol);
	UNPROTECT(1);
	PROTECT(xpt);
    } while(INTEGER(iv)[0] < 3);

    UNPROTECT(1); /* xpt */
    return R_NilValue;
}
Beispiel #2
0
SEXP lapack_qr(SEXP Xin, SEXP tl)
{
    SEXP ans, Givens, Gcpy, nms, pivot, qraux, X;
    int i, n, nGivens = 0, p, trsz, *Xdims, rank;
    double rcond = 0., tol = asReal(tl), *work;

    if (!(isReal(Xin) & isMatrix(Xin)))
	error(_("X must be a real (numeric) matrix"));
    if (tol < 0.) error(_("tol, given as %g, must be non-negative"), tol);
    if (tol > 1.) error(_("tol, given as %g, must be <= 1"), tol);
    ans = PROTECT(allocVector(VECSXP,5));
    SET_VECTOR_ELT(ans, 0, X = duplicate(Xin));
    Xdims = INTEGER(coerceVector(getAttrib(X, R_DimSymbol), INTSXP));
    n = Xdims[0]; p = Xdims[1];
    SET_VECTOR_ELT(ans, 2, qraux = allocVector(REALSXP, (n < p) ? n : p));
    SET_VECTOR_ELT(ans, 3, pivot = allocVector(INTSXP, p));
    for (i = 0; i < p; i++) INTEGER(pivot)[i] = i + 1;
    trsz = (n < p) ? n : p;	/* size of triangular part of decomposition */
    rank = trsz;
    Givens = PROTECT(allocVector(VECSXP, rank - 1));
    setAttrib(ans, R_NamesSymbol, nms = allocVector(STRSXP, 5));
    SET_STRING_ELT(nms, 0, mkChar("qr"));
    SET_STRING_ELT(nms, 1, mkChar("rank"));
    SET_STRING_ELT(nms, 2, mkChar("qraux"));
    SET_STRING_ELT(nms, 3, mkChar("pivot"));
    SET_STRING_ELT(nms, 4, mkChar("Givens"));
    if (n > 0 && p > 0) {
	int  info, *iwork, lwork;
	double *xpt = REAL(X), tmp;

	lwork = -1;
	F77_CALL(dgeqrf)(&n, &p, xpt, &n, REAL(qraux), &tmp, &lwork, &info);
	if (info)
	    error(_("First call to dgeqrf returned error code %d"), info);
	lwork = (int) tmp;
	work = (double *) R_alloc((lwork < 3*trsz) ? 3*trsz : lwork,
				  sizeof(double));
	F77_CALL(dgeqrf)(&n, &p, xpt, &n, REAL(qraux), work, &lwork, &info);
	if (info)
	    error(_("Second call to dgeqrf returned error code %d"), info);
	iwork = (int *) R_alloc(trsz, sizeof(int));
	F77_CALL(dtrcon)("1", "U", "N", &rank, xpt, &n, &rcond,
			 work, iwork, &info);
	if (info)
	    error(_("Lapack routine dtrcon returned error code %d"), info);
	while (rcond < tol) {	/* check diagonal elements */
	    double minabs = (xpt[0] < 0.) ? -xpt[0]: xpt[0];
	    int jmin = 0;
	    for (i = 1; i < rank; i++) {
		double el = xpt[i*(n+1)];
		el = (el < 0.) ? -el: el;
		if (el < minabs) {
		    jmin = i;
		    minabs = el;
		}
	    }
	    if (jmin < (rank - 1)) {
		SET_VECTOR_ELT(Givens, nGivens, getGivens(xpt, n, jmin, rank));
		nGivens++;
	    }
	    rank--;
	    F77_CALL(dtrcon)("1", "U", "N", &rank, xpt, &n, &rcond,
			     work, iwork, &info);
	    if (info)
		error(_("Lapack routine dtrcon returned error code %d"), info);
	}
    }
    SET_VECTOR_ELT(ans, 4, Gcpy = allocVector(VECSXP, nGivens));
    for (i = 0; i < nGivens; i++)
	SET_VECTOR_ELT(Gcpy, i, VECTOR_ELT(Givens, i));
    SET_VECTOR_ELT(ans, 1, ScalarInteger(rank));
    setAttrib(ans, install("useLAPACK"), ScalarLogical(1));
    setAttrib(ans, install("rcond"), ScalarReal(rcond));
    UNPROTECT(2);
    return ans;
}
Beispiel #3
0
SEXP firstCross(SEXP x, SEXP th, SEXP rel, SEXP start)
{
    int i, int_rel, int_start, P=0;
    double *real_x=NULL, real_th;

    if(ncols(x) > 1)
        error("only univariate data allowed");

    /* this currently only works for real x and th arguments
     * support for other types may be added later */
    PROTECT(x = coerceVector(x, REALSXP)); P++;
    real_th = asReal(th);
    int_rel = asInteger(rel);
    int_start = asInteger(start)-1;

    /* return number of observations if relationship is never TRUE */
    SEXP result = ScalarInteger(nrows(x));

    switch(int_rel) {
        case 1:  /* >  */
            real_x = REAL(x);
            for(i=int_start; i<nrows(x); i++)
                if(real_x[i] >  real_th) {
                    result = ScalarInteger(i+1);
                    break;
                }
            break;
        case 2:  /* <  */
            real_x = REAL(x);
            for(i=int_start; i<nrows(x); i++)
                if(real_x[i] <  real_th) {
                    result = ScalarInteger(i+1);
                    break;
                }
            break;
        case 3:  /* == */
            real_x = REAL(x);
            for(i=int_start; i<nrows(x); i++)
                if(real_x[i] == real_th) {
                    result = ScalarInteger(i+1);
                    break;
                }
            break;
        case 4:  /* >= */
            real_x = REAL(x);
            for(i=int_start; i<nrows(x); i++)
                if(real_x[i] >= real_th) {
                    result = ScalarInteger(i+1);
                    break;
                }
            break;
        case 5:  /* <= */
            real_x = REAL(x);
            for(i=int_start; i<nrows(x); i++)
                if(real_x[i] <= real_th) {
                    result = ScalarInteger(i+1);
                    break;
                }
            break;
        default:
            error("unsupported relationship operator");
  }
  UNPROTECT(P);
  return(result);
}
Beispiel #4
0
SEXP na_locf_col (SEXP x, SEXP fromLast, SEXP _maxgap, SEXP _limit)
{
  /* version of na_locf that works on multivariate data
   * of type LGLSXP, INTSXP and REALSXP.   */
  SEXP result;

  int i, ii, j, nr, nc, _first=0, P=0;
  double gap, maxgap, limit;

  int *int_x=NULL, *int_result=NULL;
  double *real_x=NULL, *real_result=NULL;

  nr = nrows(x);
  nc = ncols(x);
  maxgap = asReal(_maxgap);
  limit  = asReal(_limit);
  gap = 0;

  if(firstNonNA(x) == nr)
    return(x);

  PROTECT(result = allocMatrix(TYPEOF(x), nr, nc)); P++;

  switch(TYPEOF(x)) {
    case LGLSXP:
      int_x = LOGICAL(x);
      int_result = LOGICAL(result);
      if(!LOGICAL(fromLast)[0]) {
        for(j=0; j < nc; j++) {
          /* copy leading NAs */
          _first = firstNonNACol(x, j);
          //if(_first+1 == nr) continue;
          for(i=0+j*nr; i < (_first+1); i++) {
            int_result[i] = int_x[i];
          }
          /* result[_first] now has first value fromLast=FALSE */
          for(i=_first+1; i<nr+j*nr; i++) {
            int_result[i] = int_x[i];
            if(int_result[i] == NA_LOGICAL && gap < maxgap) {
              int_result[i] = int_result[i-1];
              gap++;
            }
          }
          if((int)gap > (int)maxgap) {  /* check that we don't have excessive trailing gap */
            for(ii = i-1; ii > i-gap-1; ii--) {
              int_result[ii] = NA_LOGICAL; 
            }
          }
        }
      } else {
        /* nr-2 is first position to fill fromLast=TRUE */
        for(j=0; j < nc; j++) {
          int_result[nr-1+j*nr] = int_x[nr-1+j*nr];
          for(i=nr-2 + j*nr; i>=0+j*nr; i--) {
            int_result[i] = int_x[i];
            if(int_result[i] == NA_LOGICAL && gap < maxgap) {
              int_result[i] = int_result[i+1];
              gap++;
            }
          }
        }
      }
      break;
    case INTSXP:
      int_x = INTEGER(x);
      int_result = INTEGER(result);
      if(!LOGICAL(fromLast)[0]) {
        for(j=0; j < nc; j++) {
          /* copy leading NAs */
          _first = firstNonNACol(x, j);
          //if(_first+1 == nr) continue;
          for(i=0+j*nr; i < (_first+1); i++) {
            int_result[i] = int_x[i];
          }
          /* result[_first] now has first value fromLast=FALSE */
          for(i=_first+1; i<nr+j*nr; i++) {
            int_result[i] = int_x[i];
            if(int_result[i] == NA_INTEGER) {
              if(limit > gap)
                int_result[i] = int_result[i-1];
              gap++;
            } else {
              if((int)gap > (int)maxgap) {
                for(ii = i-1; ii > i-gap-1; ii--) {
                  int_result[ii] = NA_INTEGER; 
                }
              }
              gap=0;
            }
          }
          if((int)gap > (int)maxgap) {  /* check that we don't have excessive trailing gap */
            for(ii = i-1; ii > i-gap-1; ii--) {
              int_result[ii] = NA_INTEGER; 
            }
          }
        }
      } else {
        /* nr-2 is first position to fill fromLast=TRUE */
        for(j=0; j < nc; j++) {
          int_result[nr-1+j*nr] = int_x[nr-1+j*nr];
          for(i=nr-2 + j*nr; i>=0+j*nr; i--) {
            int_result[i] = int_x[i];
            if(int_result[i] == NA_INTEGER) {
              if(limit > gap)
                int_result[i] = int_result[i+1];
              gap++;
            } else {
              if((int)gap > (int)maxgap) {
                for(ii = i+1; ii < i+gap+1; ii++) {
                  int_result[ii] = NA_INTEGER; 
                }
              }
              gap=0;
            }
          }
          if((int)gap > (int)maxgap) {  /* check that we don't have leading trailing gap */
            for(ii = i+1; ii < i+gap+1; ii++) {
              int_result[ii] = NA_INTEGER; 
            }
          }
        }
      }
      break;
    case REALSXP:
      real_x = REAL(x);
      real_result = REAL(result);
      if(!LOGICAL(fromLast)[0]) {   /* fromLast=FALSE */
        for(j=0; j < nc; j++) {
          /* copy leading NAs */
          _first = firstNonNACol(x, j);
          //if(_first+1 == nr) continue;
          for(i=0+j*nr; i < (_first+1); i++) {
            real_result[i] = real_x[i];
          }
          /* result[_first] now has first value fromLast=FALSE */
          for(i=_first+1; i<nr+j*nr; i++) {
            real_result[i] = real_x[i];
            if( ISNA(real_result[i]) || ISNAN(real_result[i])) {
              if(limit > gap)
                real_result[i] = real_result[i-1];
              gap++;
            } else {
              if((int)gap > (int)maxgap) {
                for(ii = i-1; ii > i-gap-1; ii--) {
                  real_result[ii] = NA_REAL; 
                }
              }
              gap=0;
            }
          }
          if((int)gap > (int)maxgap) {  /* check that we don't have excessive trailing gap */
            for(ii = i-1; ii > i-gap-1; ii--) {
              real_result[ii] = NA_REAL; 
            }
          }
        }
      } else {                      /* fromLast=TRUE */
        for(j=0; j < nc; j++) {
          real_result[nr-1+j*nr] = real_x[nr-1+j*nr];
          for(i=nr-2 + j*nr; i>=0+j*nr; i--) {
            real_result[i] = real_x[i];
            if(ISNA(real_result[i]) || ISNAN(real_result[i])) {
              if(limit > gap)
                real_result[i] = real_result[i+1];
              gap++;
            } else {
              if((int)gap > (int)maxgap) {
                for(ii = i+1; ii < i+gap+1; ii++) {
                  real_result[ii] = NA_REAL; 
                }
              }
              gap=0;
            }
          }
          if((int)gap > (int)maxgap) {  /* check that we don't have leading trailing gap */
            for(ii = i+1; ii < i+gap+1; ii++) {
              real_result[ii] = NA_REAL; 
            }
          }
        }
      }
      break;
    default:
      error("unsupported type");
      break;
  }
  if(isXts(x)) {
    setAttrib(result, R_DimSymbol, getAttrib(x, R_DimSymbol));
    setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
    setAttrib(result, xts_IndexSymbol, getAttrib(x, xts_IndexSymbol));
    copy_xtsCoreAttributes(x, result);
    copy_xtsAttributes(x, result);
  }
  UNPROTECT(P);
  return(result);
}
Beispiel #5
0
SEXP
KalmanFore(SEXP nahead, SEXP sZ, SEXP sa0, SEXP sP0, SEXP sT, SEXP sV,
	   SEXP sh, SEXP fast)
{
    SEXP res, forecasts, se;
    int  n = asInteger(nahead);
    int i, j, k, l;
    double fc, tmp, *mm, *anew, *Pnew;

    if (TYPEOF(sZ) != REALSXP ||
	TYPEOF(sa0) != REALSXP || TYPEOF(sP0) != REALSXP ||
	TYPEOF(sT) != REALSXP || TYPEOF(sV) != REALSXP)
	error(_("invalid argument type"));

    int p = LENGTH(sa0);
    double *Z = REAL(sZ), *a = REAL(sa0), *P = REAL(sP0), *T = REAL(sT),
	*V = REAL(sV), h = asReal(sh);

    anew = (double *) R_alloc(p, sizeof(double));
    Pnew = (double *) R_alloc(p * p, sizeof(double));
    mm = (double *) R_alloc(p * p, sizeof(double));
    PROTECT(res = allocVector(VECSXP, 2));
    SET_VECTOR_ELT(res, 0, forecasts = allocVector(REALSXP, n));
    SET_VECTOR_ELT(res, 1, se = allocVector(REALSXP, n));
    if (!LOGICAL(fast)[0]){
	PROTECT(sa0=duplicate(sa0));
	a=REAL(sa0);
	PROTECT(sP0=duplicate(sP0));
	P=REAL(sP0);
    }
    for (l = 0; l < n; l++) {
	fc = 0.0;
	for (i = 0; i < p; i++) {
	    tmp = 0.0;
	    for (k = 0; k < p; k++)
		tmp += T[i + p * k] * a[k];
	    anew[i] = tmp;
	    fc += tmp * Z[i];
	}
	for (i = 0; i < p; i++)
	    a[i] = anew[i];
	REAL(forecasts)[l] = fc;

	for (i = 0; i < p; i++)
	    for (j = 0; j < p; j++) {
		tmp = 0.0;
		for (k = 0; k < p; k++)
		    tmp += T[i + p * k] * P[k + p * j];
		mm[i + p * j] = tmp;
	    }
	for (i = 0; i < p; i++)
	    for (j = 0; j < p; j++) {
		tmp = V[i + p * j];
		for (k = 0; k < p; k++)
		    tmp += mm[i + p * k] * T[j + p * k];
		Pnew[i + p * j] = tmp;
	    }
	tmp = h;
	for (i = 0; i < p; i++)
	    for (j = 0; j < p; j++) {
		P[i + j * p] = Pnew[i + j * p];
		tmp += Z[i] * Z[j] * P[i + j * p];
	    }
	REAL(se)[l] = tmp;
    }
    UNPROTECT(1);
    return res;
}
Beispiel #6
0
SEXP mc_select_children(SEXP sTimeout, SEXP sWhich) 
{
    int maxfd = 0, sr, zombies = 0;
    unsigned int wlen = 0, wcount = 0;
    SEXP res;
    int *res_i, *which = 0;
    child_info_t *ci = children;
    fd_set fs;
    struct timeval tv = { 0, 0 }, *tvp = &tv;
    if (isReal(sTimeout) && LENGTH(sTimeout) == 1) {
	double tov = asReal(sTimeout);
	if (tov < 0.0) tvp = 0; /* Note: I'm not sure we really should allow this .. */
	else {
	    tv.tv_sec = (int) tov;
	    tv.tv_usec = (int) ((tov - ((double) tv.tv_sec)) * 1000000.0);
	}
    }
    if (TYPEOF(sWhich) == INTSXP && LENGTH(sWhich)) {
	which = INTEGER(sWhich);
	wlen = LENGTH(sWhich);
    }
    clean_zombies();

    FD_ZERO(&fs);
    while (ci && ci->pid) {
	if (ci->pfd == -1) zombies++;
	if (ci->pfd > maxfd) maxfd = ci->pfd;
	if (ci->pfd > 0) {
	    if (which) { /* check for the FD only if it's on the list */
		unsigned int k = 0;
		while (k < wlen) 
		    if (which[k++] == ci->pid) { 
			FD_SET(ci->pfd, &fs);
			wcount++;
			break; 
		    }
	    } else FD_SET(ci->pfd, &fs);
	}
	ci = ci -> next;
    }
    /* if there are any closed children, remove them - don't bother otherwise */
    if (zombies) rm_closed();

#ifdef MC_DEBUG
    Dprintf("select_children: maxfd=%d, wlen=%d, wcount=%d, zombies=%d, timeout=%d:%d\n", maxfd, wlen, wcount, zombies, (int)tv.tv_sec, (int)tv.tv_usec);
#endif

    if (maxfd == 0 || (wlen && !wcount)) 
	return R_NilValue; /* NULL signifies no children to tend to */

    sr = select(maxfd + 1, &fs, 0, 0, tvp);
#ifdef MC_DEBUG
    Dprintf("  sr = %d\n", sr);
#endif
    if (sr < 0) {
	/* we can land here when a child terminated due to arriving SIGCHLD.
	   For simplicity we treat this as timeout. The alernative would be to
	   go back to select, but potentially this could lead to a much longer
	   total timeout */
	if (errno == EINTR)
	    return ScalarLogical(TRUE);

	warning(_("error '%s' in select"), strerror(errno));
	return ScalarLogical(FALSE); /* FALSE on select error */
    }
    if (sr < 1) return ScalarLogical(1); /* TRUE on timeout */
    ci = children;
    maxfd = 0;
    while (ci && ci->pid) { /* pass 1 - count the FDs (in theory not
			       necessary since that's what select
			       should have returned)  */
	if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) maxfd++;
	ci = ci -> next;
    }
    ci = children;
#ifdef MC_DEBUG
    Dprintf(" - read select %d children: ", maxfd);
#endif
    res = allocVector(INTSXP, maxfd);
    res_i = INTEGER(res);
    while (ci && ci->pid) { /* pass 2 - fill the array */
	if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) (res_i++)[0] = ci->pid;
#ifdef MC_DEBUG
	if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) Dprintf("%d ", ci->pid);
#endif
	ci = ci -> next;
    }
#ifdef MC_DEBUG
    Dprintf("\n");
#endif
    return res;
}
Beispiel #7
0
SEXP do_rgb(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP c, r, g, b, a, nam;
    int OP, i, l_max, nr, ng, nb, na;
    Rboolean max_1 = FALSE;
    double mV = 0.0; /* -Wall */

    checkArity(op, args);
    OP = PRIMVAL(op);
    if(OP) {/* op == 1:  rgb256() :*/
	PROTECT(r = coerceVector(CAR(args), INTSXP)); args = CDR(args);
	PROTECT(g = coerceVector(CAR(args), INTSXP)); args = CDR(args);
	PROTECT(b = coerceVector(CAR(args), INTSXP)); args = CDR(args);
	PROTECT(a = coerceVector(CAR(args), INTSXP)); args = CDR(args);
    }
    else {
	PROTECT(r = coerceVector(CAR(args), REALSXP)); args = CDR(args);
	PROTECT(g = coerceVector(CAR(args), REALSXP)); args = CDR(args);
	PROTECT(b = coerceVector(CAR(args), REALSXP)); args = CDR(args);
	PROTECT(a = coerceVector(CAR(args), REALSXP)); args = CDR(args);
	mV = asReal(CAR(args));			       args = CDR(args);
	max_1 = (mV == 1.);
    }

    nr = LENGTH(r); ng = LENGTH(g); nb = LENGTH(b); na = LENGTH(a);
    if (nr <= 0 || ng <= 0 || nb <= 0 || na <= 0) {
	UNPROTECT(4);
	return(allocVector(STRSXP, 0));
    }
    l_max = nr;
    if (l_max < ng) l_max = ng;
    if (l_max < nb) l_max = nb;
    if (l_max < na) l_max = na;

    PROTECT(nam = coerceVector(CAR(args), STRSXP)); args = CDR(args);
    if (length(nam) != 0 && length(nam) != l_max)
	errorcall(call, _("invalid names vector"));
    PROTECT(c = allocVector(STRSXP, l_max));

#define _R_set_c_RGBA(_R,_G,_B,_A)				\
    for (i = 0; i < l_max; i++)				\
	SET_STRING_ELT(c, i, mkChar(RGBA2rgb(_R,_G,_B,_A)))

    if(OP) { /* OP == 1:  rgb256() :*/
	_R_set_c_RGBA(CheckColor(INTEGER(r)[i%nr]),
		      CheckColor(INTEGER(g)[i%ng]),
		      CheckColor(INTEGER(b)[i%nb]),
		      CheckAlpha(INTEGER(a)[i%na]));
    }
    else if(max_1) {
	_R_set_c_RGBA(ScaleColor(REAL(r)[i%nr]),
		      ScaleColor(REAL(g)[i%ng]),
		      ScaleColor(REAL(b)[i%nb]),
		      ScaleAlpha(REAL(a)[i%na]));
    }
    else { /* maxColorVal not in {1, 255} */
	_R_set_c_RGBA(ScaleColor(REAL(r)[i%nr] / mV),
		      ScaleColor(REAL(g)[i%ng] / mV),
		      ScaleColor(REAL(b)[i%nb] / mV),
		      ScaleAlpha(REAL(a)[i%na] / mV));
    }
    if (length(nam) != 0)
	setAttrib(c, R_NamesSymbol, nam);
    UNPROTECT(6);
    return c;
}
Beispiel #8
0
SEXP colCounts(SEXP x, SEXP dim, SEXP rows, SEXP cols, SEXP value, SEXP what, SEXP naRm, SEXP hasNA) {
  SEXP ans;
  int narm, hasna, what2;
  R_xlen_t nrow, ncol;

  /* Argument 'x' and 'dim': */
  assertArgMatrix(x, dim, (R_TYPE_LGL | R_TYPE_INT | R_TYPE_REAL), "x");
  nrow = asR_xlen_t(dim, 0);
  ncol = asR_xlen_t(dim, 1);

  /* Argument 'value': */
  if (length(value) != 1)
    error("Argument 'value' must be a single value.");

  if (!isNumeric(value))
    error("Argument 'value' must be a numeric value.");

  /* Argument 'what': */
  what2 = asInteger(what);
  if (what2 < 0 || what2 > 2)
    error("INTERNAL ERROR: Unknown value of 'what' for rowCounts: %d", what2);

  /* Argument 'naRm': */
  narm = asLogicalNoNA(naRm, "na.rm");

  /* Argument 'hasNA': */
  hasna = asLogicalNoNA(hasNA, "hasNA");

  /* Argument 'rows' and 'cols': */
  R_xlen_t nrows, ncols;
  int rowsType, colsType;
  void *crows = validateIndices(rows, nrow, 0, &nrows, &rowsType);
  void *ccols = validateIndices(cols, ncol, 0, &ncols, &colsType);

  /* R allocate an integer vector of length 'ncol' */
  PROTECT(ans = allocVector(INTSXP, ncols));

  if (isReal(x)) {
    colCounts_Real[rowsType][colsType](REAL(x), nrow, ncol, crows, nrows, ccols, ncols, asReal(value), what2, narm, hasna, INTEGER(ans));
  } else if (isInteger(x)) {
    colCounts_Integer[rowsType][colsType](INTEGER(x), nrow, ncol, crows, nrows, ccols, ncols, asInteger(value), what2, narm, hasna, INTEGER(ans));
  } else if (isLogical(x)) {
    colCounts_Logical[rowsType][colsType](LOGICAL(x), nrow, ncol, crows, nrows, ccols, ncols, asLogical(value), what2, narm, hasna, INTEGER(ans));
  }

  UNPROTECT(1);

  return(ans);
} // colCounts()
Beispiel #9
0
int KviKvsVariant::compare(const KviKvsVariant * pOther, bool bPreferNumeric) const
{
	if(!pOther)
		return isEqualToNothing() ? CMP_EQUAL : CMP_THISGREATER;
	if(!pOther->m_pData)
		return isEqualToNothing() ? CMP_EQUAL : CMP_THISGREATER;
	if(!m_pData)
		return pOther->isEqualToNothing() ? CMP_EQUAL : CMP_OTHERGREATER;

	switch(m_pData->m_eType)
	{
		case KviKvsVariantData::HObject:
			switch(pOther->m_pData->m_eType)
			{
				case KviKvsVariantData::HObject:
					if(m_pData->m_u.hObject == pOther->m_pData->m_u.hObject)
						return CMP_EQUAL;
					if(m_pData->m_u.hObject == ((kvs_hobject_t)0))
						return CMP_OTHERGREATER;
					return CMP_THISGREATER;
				break;
				case KviKvsVariantData::Integer:
					return -1 * KviKvsVariantComparison::compareIntHObject(pOther,this);
				break;
				case KviKvsVariantData::Real:
					return -1 * KviKvsVariantComparison::compareRealHObject(pOther,this);
				break;
				case KviKvsVariantData::String:
					return -1 * KviKvsVariantComparison::compareStringHObject(pOther,this);
				break;
				case KviKvsVariantData::Boolean:
					return -1 * KviKvsVariantComparison::compareBoolHObject(pOther,this);
				break;
				case KviKvsVariantData::Hash:
					return KviKvsVariantComparison::compareHObjectHash(this,pOther);
				break;
				case KviKvsVariantData::Array:
					return KviKvsVariantComparison::compareHObjectArray(this,pOther);
				break;
				default: // just make gcc happy
				break;
			}
		break;
		case KviKvsVariantData::Integer:
			switch(pOther->m_pData->m_eType)
			{
				case KviKvsVariantData::HObject:
					return KviKvsVariantComparison::compareIntHObject(this,pOther);
				break;
				case KviKvsVariantData::Integer:
					if(m_pData->m_u.iInt == pOther->m_pData->m_u.iInt)
						return CMP_EQUAL;
					if(m_pData->m_u.iInt > pOther->m_pData->m_u.iInt)
						return CMP_THISGREATER;
					return CMP_OTHERGREATER;
				break;
				case KviKvsVariantData::Real:
					return KviKvsVariantComparison::compareIntReal(this,pOther);
				break;
				case KviKvsVariantData::String:
					return KviKvsVariantComparison::compareIntString(this,pOther);
				break;
				case KviKvsVariantData::Boolean:
					return KviKvsVariantComparison::compareIntBool(this,pOther);
				break;
				case KviKvsVariantData::Hash:
					return KviKvsVariantComparison::compareIntHash(this,pOther);
				break;
				case KviKvsVariantData::Array:
					return KviKvsVariantComparison::compareIntArray(this,pOther);
				break;
				default: // just make gcc happy
				break;
			}
		break;
		case KviKvsVariantData::Real:
			switch(pOther->m_pData->m_eType)
			{
				case KviKvsVariantData::HObject:
					return KviKvsVariantComparison::compareRealHObject(this,pOther);
				break;
				case KviKvsVariantData::Integer:
					return -1 * KviKvsVariantComparison::compareIntReal(pOther,this);
				break;
				case KviKvsVariantData::Real:
					if(*(m_pData->m_u.pReal) == *(pOther->m_pData->m_u.pReal))
						return CMP_EQUAL;
					if(*(m_pData->m_u.pReal) > *(pOther->m_pData->m_u.pReal))
						return CMP_THISGREATER;
					return CMP_OTHERGREATER;
				break;
				case KviKvsVariantData::String:
					return KviKvsVariantComparison::compareRealString(this,pOther);
				break;
				case KviKvsVariantData::Boolean:
					return KviKvsVariantComparison::compareRealBool(this,pOther);
				break;
				case KviKvsVariantData::Hash:
					return KviKvsVariantComparison::compareRealHash(this,pOther);
				break;
				case KviKvsVariantData::Array:
					return KviKvsVariantComparison::compareRealArray(this,pOther);
				break;
				default: // just make gcc happy
				break;
			}
		break;
		case KviKvsVariantData::String:
			switch(pOther->m_pData->m_eType)
			{
				case KviKvsVariantData::String:
					if(bPreferNumeric)
					{
						// prefer numeric comparison
						double dReal1;
						double dReal2;
						if(asReal(dReal1))
						{
							if(pOther->asReal(dReal2))
							{
								if(dReal1 == dReal2)
									return CMP_EQUAL;
								if(dReal1 > dReal2)
									return CMP_THISGREATER;
								return CMP_OTHERGREATER;
							}
						}
					}
					return -1 * m_pData->m_u.pString->compare(*(pOther->m_pData->m_u.pString),Qt::CaseInsensitive);
				case KviKvsVariantData::Real:
					return -1 * KviKvsVariantComparison::compareRealString(pOther,this);
				case KviKvsVariantData::Integer:
					return -1 * KviKvsVariantComparison::compareIntString(pOther,this);
				case KviKvsVariantData::Boolean:
					return -1 * KviKvsVariantComparison::compareBoolString(pOther,this);
				break;
				case KviKvsVariantData::Hash:
					return KviKvsVariantComparison::compareStringHash(this,pOther);
				break;
				case KviKvsVariantData::Array:
					return KviKvsVariantComparison::compareStringArray(this,pOther);
				break;
				case KviKvsVariantData::HObject:
					return KviKvsVariantComparison::compareStringHObject(this,pOther);
				break;
				default:
				break;
			}
		break;
		case KviKvsVariantData::Hash:
			switch(pOther->m_pData->m_eType)
			{
				case KviKvsVariantData::String:
					return -1 * KviKvsVariantComparison::compareStringHash(pOther,this);
				case KviKvsVariantData::Real:
					return -1 * KviKvsVariantComparison::compareRealHash(pOther,this);
				break;
				case KviKvsVariantData::Integer:
					return -1 * KviKvsVariantComparison::compareIntHash(pOther,this);
				break;
				case KviKvsVariantData::Boolean:
					return -1 * KviKvsVariantComparison::compareBoolHash(pOther,this);
				break;
				case KviKvsVariantData::Hash:
					if(m_pData->m_u.pHash->size() > pOther->m_pData->m_u.pHash->size())
						return CMP_THISGREATER;
					if(m_pData->m_u.pHash->size() == pOther->m_pData->m_u.pHash->size())
						return CMP_EQUAL;
					return CMP_OTHERGREATER;
				break;
				case KviKvsVariantData::Array:
					return -1 * KviKvsVariantComparison::compareArrayHash(pOther,this);
				break;
				case KviKvsVariantData::HObject:
					return -1 * KviKvsVariantComparison::compareHObjectHash(pOther,this);
				break;
				default:
				break;
			}
		break;
		case KviKvsVariantData::Array:
			switch(pOther->m_pData->m_eType)
			{
				case KviKvsVariantData::String:
					return -1 * KviKvsVariantComparison::compareStringArray(pOther,this);
				case KviKvsVariantData::Real:
					return -1 * KviKvsVariantComparison::compareRealArray(pOther,this);
				case KviKvsVariantData::Integer:
					return -1 * KviKvsVariantComparison::compareIntArray(pOther,this);
				case KviKvsVariantData::Boolean:
					return -1 * KviKvsVariantComparison::compareBoolArray(pOther,this);
				break;
				case KviKvsVariantData::Hash:
					return KviKvsVariantComparison::compareArrayHash(this,pOther);
				break;
				case KviKvsVariantData::Array:
					if(m_pData->m_u.pArray->size() > pOther->m_pData->m_u.pArray->size())
						return CMP_THISGREATER;
					if(m_pData->m_u.pArray->size() == pOther->m_pData->m_u.pArray->size())
						return CMP_EQUAL;
					return CMP_OTHERGREATER;
				break;
				case KviKvsVariantData::HObject:
					return -1 * KviKvsVariantComparison::compareHObjectArray(pOther,this);
				break;
				default:
				break;
			}
		break;
		case KviKvsVariantData::Boolean:
			switch(pOther->m_pData->m_eType)
			{
				case KviKvsVariantData::String:
					return KviKvsVariantComparison::compareBoolString(this,pOther);
				break;
				case KviKvsVariantData::Real:
					return -1 * KviKvsVariantComparison::compareRealBool(pOther,this);
				break;
				case KviKvsVariantData::Integer:
					return -1 * KviKvsVariantComparison::compareIntBool(pOther,this);
				break;
				case KviKvsVariantData::Boolean:
					if(m_pData->m_u.bBoolean == pOther->m_pData->m_u.bBoolean)
						return CMP_EQUAL;
					if(m_pData->m_u.bBoolean)
						return CMP_THISGREATER;
					return CMP_OTHERGREATER;
				break;
				case KviKvsVariantData::Hash:
					return KviKvsVariantComparison::compareBoolHash(this,pOther);
				break;
				case KviKvsVariantData::Array:
					return KviKvsVariantComparison::compareBoolArray(this,pOther);
				break;
				case KviKvsVariantData::HObject:
					return KviKvsVariantComparison::compareBoolHObject(this,pOther);
				break;
				default:
				break;
			}
		break;
		default: // should never happen anyway
		break;
	}

	return CMP_THISGREATER; // should never happen
}
Beispiel #10
0
SEXP iterative_correction(SEXP avecount, SEXP anchor, SEXP target, SEXP local, 
		SEXP nfrags, SEXP iter, SEXP exlocal, SEXP lowdiscard, SEXP winsorhigh) try {

	// Checking vector type and length.
	if (!isNumeric(avecount)) { throw std::runtime_error("average counts must be supplied as a double-precision vector"); }
	if (!isInteger(anchor) || !isInteger(target)) { throw std::runtime_error("anchor/target indices must be supplied as an integer vector"); }
	if (!isLogical(local)) { throw std::runtime_error("local specifier should be a logical vector"); }
	const int npairs=LENGTH(avecount);
	if (npairs!=LENGTH(anchor) || npairs!=LENGTH(target) || npairs!=LENGTH(local)) { throw std::runtime_error("lengths of vectors are not equal"); }
	const double* acptr=REAL(avecount);
	const int* aptr=INTEGER(anchor),
		  * tptr=INTEGER(target),
		  * lptr=LOGICAL(local);

	// Checking scalar type.
	if (!isInteger(nfrags) || LENGTH(nfrags)!=1) { throw std::runtime_error("number of fragments should be an integer scalar"); }
	if (!isInteger(iter) || LENGTH(iter)!=1) { throw std::runtime_error("number of iterations should be an integer scalar"); }
	if (!isInteger(exlocal) || LENGTH(exlocal)!=1) { throw std::runtime_error("exclusion specifier should be an integer scalar"); }
	const int numfrags=asInteger(nfrags),
		  iterations=asInteger(iter),
		  excluded=asInteger(exlocal);
	if (!isNumeric(lowdiscard) || LENGTH(lowdiscard)!=1) { throw std::runtime_error("proportion to discard should be a double-precision scalar"); }
	const double discarded=asReal(lowdiscard);
	if (!isNumeric(winsorhigh) || LENGTH(winsorhigh)!=1) { throw std::runtime_error("proportion to winsorize should be a double-precision scalar"); }
	const double winsorized=asReal(winsorhigh);
	
	SEXP output=PROTECT(allocVector(VECSXP, 3));
try {
	// Setting up a SEXP to hold the working probabilities (ultimately the truth).
	SET_VECTOR_ELT(output, 0, allocVector(REALSXP, npairs));
	double* wptr=REAL(VECTOR_ELT(output, 0));
	std::copy(acptr, acptr+npairs, wptr);

	// Excluding highly local interactions.
	int num_values=npairs;
	bool drop_intras=(excluded==NA_INTEGER);
	if (drop_intras || excluded >= 0) {
		for (int j=0; j<npairs; ++j) {
			if (lptr[j] && (drop_intras || aptr[j]-tptr[j] <= excluded)) { 
				wptr[j]=R_NaReal; 
				--num_values;
			}
		}
	}

	/**************************************************
 	 * Getting rid of unstable or extreme elements.
 	 **************************************************/

	// Winsorizing for the most abundant interactions.
	const int todrop=int(double(num_values)*winsorized);
	if (todrop>0) {
		int* ordered=new int[npairs];
		try {
			for (int i=0; i<npairs; ++i) { ordered[i]=i; }
			orderer current(acptr);
			std::sort(ordered, ordered+npairs, current);
	
			// Identifying the winsorizing value.		
			int curcount=0;
 		   	double winsor_val=R_NaReal;
			for (int i=npairs-1; i>=0; --i) { 
				const int& curo=ordered[i];
				if (ISNA(wptr[curo])) { continue; }
				++curcount;
				if (curcount > todrop) { 
					winsor_val=wptr[curo];
					break; 
				}
			}

			// Applying said value to all high-abundance interactions.
			if (ISNA(winsor_val)) { throw std::runtime_error("specified winsorizing proportion censors all data"); }
			curcount=0;
			for (int i=npairs-1; i>=0; --i) { 
				const int& curo=ordered[i];
				if (ISNA(wptr[curo])) { continue; }
				wptr[curo]=winsor_val;
				++curcount;
				if (curcount > todrop) { break; }
			}		
		} catch (std::exception& e){
			delete [] ordered;
			throw;
		}
		delete[] ordered;
	}

	// Bias and coverage vectors.
	SET_VECTOR_ELT(output, 1, allocVector(REALSXP, numfrags));
	double* bias=REAL(VECTOR_ELT(output, 1)),
		* biaptr=bias-1;
	for (int i=0; i<numfrags; ++i) { bias[i]=R_NaReal; }
	for (int pr=0; pr<npairs; ++pr) { 
		if (!ISNA(wptr[pr])) { biaptr[aptr[pr]]=biaptr[tptr[pr]]=1; }
	}
	double* coverage=(double*)R_alloc(numfrags, sizeof(double));
	for (int i=0; i<numfrags; ++i) { coverage[i]=0; }
	double* covptr=coverage-1; // To deal with 1-based indices.

	// Removing low-abundance fragments.
	if (discarded > 0) {
		for (int pr=0; pr<npairs; ++pr) {  // Computing the coverage.
			if (ISNA(wptr[pr])) { continue; }
			covptr[aptr[pr]]+=wptr[pr]; 
			covptr[tptr[pr]]+=wptr[pr];
        }

		int* ordering=new int [numfrags];
		try {
			for (int i=0; i<numfrags; ++i) { ordering[i]=i; }
			orderer current(coverage);
			std::sort(ordering, ordering+numfrags, current);
		
			// Ignoring empty rows.
			int counter=0;
			while (counter < numfrags && ISNA(bias[ordering[counter]])){ ++counter; }
				
			// Filtering out low-abundance rows.
			const int leftover=int(discarded*double(numfrags-counter))+counter;
			while (counter < leftover) { 
				bias[ordering[counter]]=R_NaReal;
				++counter; 
			}

			// Setting everything else back to zero.
			while (counter < numfrags) { 
				coverage[ordering[counter]]=0;
				++counter;
			}
		} catch (std::exception& e) { 
			delete [] ordering;
			throw;
		}
		delete [] ordering;
	
		// Propogating the filters through the interactions to remove anything with an anchor in the removed fragments.
		for (int pr=0; pr<npairs; ++pr) {
			if (ISNA(wptr[pr])) { continue; }
			if (ISNA(biaptr[aptr[pr]]) || ISNA(biaptr[tptr[pr]])) { wptr[pr]=R_NaReal; }  
		}
		for (int i=0; i<numfrags; ++i) { bias[i]=R_NaReal; }
		for (int pr=0; pr<npairs; ++pr) { 
			if (!ISNA(wptr[pr])) { biaptr[aptr[pr]]=biaptr[tptr[pr]]=1; }
		}
	}
	
	// Something to hold a diagnostic (i.e., the maximum step).
	SET_VECTOR_ELT(output, 2, allocVector(REALSXP, iterations));
	double* optr=REAL(VECTOR_ELT(output, 2));

    /********************************************************
 	 * Now, actually performing the iterative correction. ***
 	 ********************************************************/

	for (int it=0; it<iterations; ++it) {
		for (int pr=0; pr<npairs; ++pr) {  // Computing the coverage (ignoring locals, if necessary).
			if (ISNA(wptr[pr])) { continue; }
			covptr[aptr[pr]]+=wptr[pr]; 
			covptr[tptr[pr]]+=wptr[pr];
        }
		
		/* Computing the 'aditional bias' vector, to take the mean across all fragments.
		 * The exact value of the mean doesn't really matter, it just serves to slow down 
		 * the algorithm to avoid overshooting the mark and lack of convergence. Everything
		 * ends up being the same so long as the column sums approach 1.
		 */
//		double mean_of_all=0;
//		for (int i=0; i<numfrags; ++i) { if (!ISNA(coverage[i])) { mean_of_all+=coverage[i]; } }
//		mean_of_all/=numfrags;
//		for (int i=0; i<numfrags; ++i) { if (!ISNA(coverage[i])) { coverage[i]/=mean_of_all; } }

		/* Okay, that didn't really work. The strategy that is described in the paper fails to
 		 * give me contact probabilities that sum to 1. So instead, I'm using the coverage
 		 * itself to divide the working probabilities. Square rooting is necessary to avoid
 		 * instability during iteration.
 		 */
		for (int i=0; i<numfrags; ++i) { if (!ISNA(bias[i])) { coverage[i]=std::sqrt(coverage[i]); } }

		// Dividing the working matrix with the (geometric mean of the) additional biases.	
		for (int pr=0; pr<npairs; ++pr){ 
			if (!ISNA(wptr[pr])) { wptr[pr]/=covptr[aptr[pr]]*covptr[tptr[pr]]; }
        }
		
		// Multiplying the biases by additional biases, and cleaning out coverage. We store
		// the maximum step to see how far off convergence it is.
		double& maxed=(optr[it]=0);
		for (int i=0; i<numfrags; ++i) {			
			if (!ISNA(bias[i])) {
				double& cur_cov=coverage[i];
				if (cur_cov > maxed) { maxed=cur_cov; }
				else if (1/cur_cov > maxed) { maxed=1/cur_cov; }
				bias[i]*=cur_cov;
				cur_cov=0;
			}
		}
    }

	/* Recalculating the contact probabilities, using the estimated biases, 
	 * to get normalized values for Winsorized or discarded bin pairs.
	 * Discarded bins can't be salvaged, though.
	 */
	for (int pr=0; pr<npairs; ++pr) {  
		if (ISNA(biaptr[aptr[pr]]) || ISNA(biaptr[tptr[pr]])) { continue; }
		wptr[pr] = acptr[pr]/biaptr[aptr[pr]]/biaptr[tptr[pr]];
	}
} catch (std::exception& e) {
	UNPROTECT(1);
	throw;
}
	UNPROTECT(1);
	return output;
} catch (std::exception& e) {
	return mkString(e.what());
}
Beispiel #11
0
SEXP mc_select_children(SEXP sTimeout, SEXP sWhich) 
{
    int maxfd = 0, sr, zombies = 0;
    unsigned int wlen = 0, wcount = 0;
    SEXP res;
    int *res_i, *which = 0;
    child_info_t *ci = children;
    fd_set fs;
    struct timeval tv = { 0, 0 }, *tvp = &tv;
    if (isReal(sTimeout) && LENGTH(sTimeout) == 1) {
	double tov = asReal(sTimeout);
	if (tov < 0.0) tvp = 0; /* Note: I'm not sure we really should allow this .. */
	else {
	    tv.tv_sec = (int) tov;
	    tv.tv_usec = (int) ((tov - ((double) tv.tv_sec)) * 1000000.0);
	}
    }
    if (TYPEOF(sWhich) == INTSXP && LENGTH(sWhich)) {
	which = INTEGER(sWhich);
	wlen = LENGTH(sWhich);
    }
    { 
	int wstat; 
	while (waitpid(-1, &wstat, WNOHANG) > 0) ; /* check for zombies */
    }
    FD_ZERO(&fs);
    while (ci && ci->pid) {
	if (ci->pfd == -1) zombies++;
	if (ci->pfd > maxfd) maxfd = ci->pfd;
	if (ci->pfd > 0) {
	    if (which) { /* check for the FD only if it's on the list */
		unsigned int k = 0;
		while (k < wlen) 
		    if (which[k++] == ci->pid) { 
			FD_SET(ci->pfd, &fs);
			wcount++;
			break; 
		    }
	    } else FD_SET(ci->pfd, &fs);
	}
	ci = ci -> next;
    }
#ifdef MC_DEBUG
    Dprintf("select_children: maxfd=%d, wlen=%d, wcount=%d, zombies=%d, timeout=%d:%d\n", maxfd, wlen, wcount, zombies, (int)tv.tv_sec, (int)tv.tv_usec);
#endif
    if (zombies) { /* oops, this should never really happen - it did
		    * while we had a bug in rm_child_ but hopefully
		    * not anymore */
	while (zombies) { /* this is rather more complicated than it
			   * should be if we used pointers to delete,
			   * but well ... */
	    ci = children;
	    while (ci) {
		if (ci->pfd == -1) {
#ifdef MC_DEBUG
		    Dprintf("detected zombie: pid=%d, pfd=%d, sifd=%d\n", 
			    ci->pid, ci->pfd, ci->sifd);
#endif
		    rm_child_(ci->pid);
		    zombies--;
		    break;
		}
		ci = ci->next;
	    }
	    if (!ci) break;
	}
    }
    if (maxfd == 0 || (wlen && !wcount)) 
	return R_NilValue; /* NULL signifies no children to tend to */
    sr = select(maxfd + 1, &fs, 0, 0, tvp);
#ifdef MC_DEBUG
    Dprintf("  sr = %d\n", sr);
#endif
    if (sr < 0) {
	warning(_("error '%s' in select"), strerror(errno));
	return ScalarLogical(0); /* FALSE on select error */
    }
    if (sr < 1) return ScalarLogical(1); /* TRUE on timeout */
    ci = children;
    maxfd = 0;
    while (ci && ci->pid) { /* pass 1 - count the FDs (in theory not
			       necessary since that's what select
			       should have returned)  */
	if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) maxfd++;
	ci = ci -> next;
    }
    ci = children;
#ifdef MC_DEBUG
    Dprintf(" - read select %d children: ", maxfd);
#endif
    res = allocVector(INTSXP, maxfd);
    res_i = INTEGER(res);
    while (ci && ci->pid) { /* pass 2 - fill the array */
	if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) (res_i++)[0] = ci->pid;
#ifdef MC_DEBUG
	if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) Dprintf("%d ", ci->pid);
#endif
	ci = ci -> next;
    }
#ifdef MC_DEBUG
    Dprintf("\n");
#endif
    return res;
}
Beispiel #12
0
SEXP R_handle_setopt(SEXP ptr, SEXP keys, SEXP values){
  CURL *handle = get_handle(ptr);
  SEXP optnames = getAttrib(values, R_NamesSymbol);

  if(!isInteger(keys))
    error("keys` must be an integer");

  if(!isVector(values))
    error("`values` must be a list");

  for(int i = 0; i < length(keys); i++){
    int key = INTEGER(keys)[i];
    const char* optname = CHAR(STRING_ELT(optnames, i));
    SEXP val = VECTOR_ELT(values, i);
    if(val == R_NilValue){
      assert(curl_easy_setopt(handle, key, NULL));
    } else if (key == CURLOPT_PROGRESSFUNCTION) {
      if (TYPEOF(val) != CLOSXP)
        error("Value for option %s (%d) must be a function.", optname, key);

      assert(curl_easy_setopt(handle, CURLOPT_PROGRESSFUNCTION,
        (curl_progress_callback) R_curl_callback_progress));
      assert(curl_easy_setopt(handle, CURLOPT_PROGRESSDATA, val));
    } else if (key == CURLOPT_READFUNCTION) {
      if (TYPEOF(val) != CLOSXP)
        error("Value for option %s (%d) must be a function.", optname, key);

      assert(curl_easy_setopt(handle, CURLOPT_READFUNCTION,
        (curl_read_callback) R_curl_callback_read));
      assert(curl_easy_setopt(handle, CURLOPT_READDATA, val));
    } else if (key == CURLOPT_DEBUGFUNCTION) {
      if (TYPEOF(val) != CLOSXP)
        error("Value for option %s (%d) must be a function.", optname, key);

      assert(curl_easy_setopt(handle, CURLOPT_DEBUGFUNCTION,
        (curl_debug_callback) R_curl_callback_debug));
      assert(curl_easy_setopt(handle, CURLOPT_DEBUGDATA, val));
    } else if (opt_is_linked_list(key)) {
      error("Option %s (%d) not supported.", optname, key);
    } else if(key < 10000){
      if(!isNumeric(val) || length(val) != 1) {
        error("Value for option %s (%d) must be a number.", optname, key);
      }
      assert(curl_easy_setopt(handle, key, (long) asInteger(val)));
    } else if(key < 20000){
      switch (TYPEOF(val)) {
      case RAWSXP:
        assert(curl_easy_setopt(handle, key, RAW(val)));
        break;
      case STRSXP:
        if (length(val) != 1)
          error("Value for option %s (%d) must be length-1 string", optname, key);
        assert(curl_easy_setopt(handle, key, CHAR(STRING_ELT(val, 0))));
        break;
      default:
        error("Value for option %s (%d) must be a string or raw vector.", optname, key);
      }
    } else if(key >= 30000 && key < 40000){
      if(!isNumeric(val) || length(val) != 1) {
        error("Value for option %s (%d) must be a number.", optname, key);
      }
      assert(curl_easy_setopt(handle, key, (curl_off_t) asReal(val)));
    } else {
      error("Option %s (%d) not supported.", optname, key);
    }
  }
  return ScalarLogical(1);
}
Beispiel #13
0
SEXP objFun_optimalf ( SEXP f, SEXP lsp, SEXP margin, SEXP equity,
  SEXP constrFun, SEXP constrVal, SEXP env )
{
  int P=0;
  
  double *d_fval    = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 2)))); P++;
  double *d_maxloss = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 3)))); P++;

  double *d_f       = REAL(PROTECT(AS_NUMERIC(f))); P++;
  double *d_margin, d_equity, maxU;  /* -Wall */

  int len = length(f);

  /* is changing 'lsp' stupid / dangerous? */
  for(int i=0; i < len; i++) {
    d_fval[i] = d_f[i];
  }

  SEXP s_ghpr, s_cval, fcall;
  /* Calculate GHPR */
  PROTECT(s_ghpr = ghpr(lsp)); P++;
  double d_ghpr = -asReal(s_ghpr);

  if(d_ghpr < -1) {
    /* Margin constraint */
    if( !isNull(margin) && !isNull(equity) ) {

      d_margin = REAL(PROTECT(AS_NUMERIC(margin))); P++;
      d_equity = asReal(equity);

      maxU = 0;
      for(int i=0; i < len; i++) {
        maxU += d_f[i] * d_margin[i] / -d_maxloss[i];
      }
      maxU *= d_equity;

      if(maxU > d_equity) {
        d_ghpr = R_PosInf;
      }
    } /* Margin constraint */

    /* Constraint function */
    if( !isNull(constrFun) ) {

      if( !isFunction(constrFun) )
        error("constrFun is not a function");

      PROTECT(fcall = lang3(constrFun, lsp, R_DotsSymbol)); P++;
      PROTECT(s_cval = eval(fcall, env)); P++;

      if( asReal(s_cval) >= asReal(constrVal) ) {
        d_ghpr = R_PosInf;
      }
    }
  } else {
    d_ghpr = R_PosInf;
  }

  UNPROTECT(P);
  return(ScalarReal(d_ghpr));
}
Beispiel #14
0
/*
   cairo(filename, type, width, height, pointsize, bg, res, antialias, 
         quality, family)
*/
SEXP in_Cairo(SEXP args)
{
    pGEDevDesc gdd;
    SEXP sc;
    const char *filename, *family;
    int type, quality, width, height, pointsize, bgcolor, res, antialias;
    double dpi;
    const void *vmax = vmaxget();

    args = CDR(args); /* skip entry point name */
    if (!isString(CAR(args)) || LENGTH(CAR(args)) < 1)
	error(_("invalid '%s' argument"), "filename");
    filename = translateChar(STRING_ELT(CAR(args), 0));
    args = CDR(args);
    type = asInteger(CAR(args));
    if(type == NA_INTEGER || type <= 0)
	error(_("invalid '%s' argument"), "type");
    args = CDR(args);
    width = asInteger(CAR(args));
    if(width == NA_INTEGER || width <= 0)
	error(_("invalid '%s' argument"), "width");
    args = CDR(args);
    height = asInteger(CAR(args));
    if(height == NA_INTEGER || height <= 0)
	error(_("invalid '%s' argument"), "height");
    args = CDR(args);
    pointsize = asInteger(CAR(args));
    if(pointsize == NA_INTEGER || pointsize <= 0)
	error(_("invalid '%s' argument"), "pointsize");
    args = CDR(args);
    sc = CAR(args);
    if (!isString(sc) && !isInteger(sc) && !isLogical(sc) && !isReal(sc))
	error(_("invalid '%s' value"), "bg");
    bgcolor = RGBpar(sc, 0);
    args = CDR(args);
    res = asInteger(CAR(args));
    args = CDR(args);
    antialias = asInteger(CAR(args));
    if(antialias == NA_INTEGER)
	error(_("invalid '%s' argument"), "antialias");
    args = CDR(args);
    quality = asInteger(CAR(args));
    if(quality == NA_INTEGER || quality < 0 || quality > 100)
	error(_("invalid '%s' argument"), "quality");
    args = CDR(args);
    if (!isString(CAR(args)) || LENGTH(CAR(args)) < 1)
	error(_("invalid '%s' argument"), "family");
    family = translateChar(STRING_ELT(CAR(args), 0));
    args = CDR(args);
    dpi = asReal(CAR(args));
    if(ISNAN(dpi) || dpi <= 0)
	error(_("invalid '%s' argument"), "dpi");

    R_GE_checkVersionOrDie(R_GE_version);
    R_CheckDeviceAvailable();
    BEGIN_SUSPEND_INTERRUPTS {
	pDevDesc dev;
	/* Allocate and initialize the device driver data */
	if (!(dev = (pDevDesc) calloc(1, sizeof(DevDesc)))) return 0;
	if (!BMDeviceDriver(dev, devtable[type].gtype, filename, quality,
			    width, height, pointsize,
			    bgcolor, res, antialias, family, dpi)) {
	    free(dev);
	    error(_("unable to start device '%s'"), devtable[type].name);
	}
	gdd = GEcreateDevDesc(dev);
	GEaddDevice2f(gdd, devtable[type].name, filename);
    } END_SUSPEND_INTERRUPTS;

    vmaxset(vmax);
    return R_NilValue;
}
Beispiel #15
0
SEXP qt_qsetZValue(SEXP item, SEXP z)
{
    unwrapQGraphicsItem(item, QGraphicsItem)->setZValue(asReal(z));
    return item;
}
Beispiel #16
0
void VirtualValue::real2int()
{
   ASSERT(isReal());
   setNumber(static_cast<int>(asReal()));
}
Beispiel #17
0
SEXP qt_qsetVerticalSpacing_QGraphicsGridLayout(SEXP rself, SEXP rspacing) {
  QGraphicsGridLayout *layout = unwrapPointer(rself, QGraphicsGridLayout);
  layout->setVerticalSpacing(asReal(rspacing));
  return rself;
}
Beispiel #18
0
/* This is a primitive SPECIALSXP with internal argument matching */
SEXP attribute_hidden do_rep(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP ans, x, times = R_NilValue /* -Wall */;
    int each = 1, nprotect = 3;
    R_xlen_t i, lx, len = NA_INTEGER, nt;
    static SEXP do_rep_formals = NULL;

    /* includes factors, POSIX[cl]t, Date */
    if (DispatchOrEval(call, op, R_RepCharSXP, args, rho, &ans, 0, 0))
	return(ans);

    /* This has evaluated all the non-missing arguments into ans */
    PROTECT(args = ans);

    /* This is a primitive, and we have not dispatched to a method
       so we manage the argument matching ourselves.  We pretend this is
       rep(x, times, length.out, each, ...)
    */
    if (do_rep_formals == NULL) {
        do_rep_formals = CONS(R_NilValue, list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
        R_PreserveObject(do_rep_formals);
        SET_TAG(do_rep_formals, R_XSymbol);
        SET_TAG(CDR(do_rep_formals), install("times"));
        SET_TAG(CDDR(do_rep_formals), R_LengthOutSymbol);
        SET_TAG(CDR(CDDR(do_rep_formals)), install("each"));
        SET_TAG(CDDR(CDDR(do_rep_formals)), R_DotsSymbol);
    }
    PROTECT(args = matchArgs(do_rep_formals, args, call));

    x = CAR(args);
    /* supported in R 2.15.x */
    if (TYPEOF(x) == LISTSXP)
	errorcall(call, "replication of pairlists is defunct");

    lx = xlength(x);

    double slen = asReal(CADDR(args));
    if (R_FINITE(slen)) {
	if(slen < 0)
	    errorcall(call, _("invalid '%s' argument"), "length.out");
	len = (R_xlen_t) slen;
    } else {
	len = asInteger(CADDR(args));
	if(len != NA_INTEGER && len < 0)
	    errorcall(call, _("invalid '%s' argument"), "length.out");
    }
    if(length(CADDR(args)) != 1)
	warningcall(call, _("first element used of '%s' argument"), 
		    "length.out");

    each = asInteger(CADDDR(args));
    if(each != NA_INTEGER && each < 0)
	errorcall(call, _("invalid '%s' argument"), "each");
    if(length(CADDDR(args)) != 1)
	warningcall(call, _("first element used of '%s' argument"), "each");
    if(each == NA_INTEGER) each = 1;

    if(lx == 0) {
	if(len > 0 && x == R_NilValue) 
	    warningcall(call, "'x' is NULL so the result will be NULL");
	SEXP a;
	PROTECT(a = duplicate(x));
	if(len != NA_INTEGER && len > 0) a = xlengthgets(a, len);
	UNPROTECT(3);
	return a;
    }
    if (!isVector(x))
	errorcall(call, "attempt to replicate an object of type '%s'",
		  type2char(TYPEOF(x)));

    /* So now we know x is a vector of positive length.  We need to
       replicate it, and its names if it has them. */

    /* First find the final length using 'times' and 'each' */
    if(len != NA_INTEGER) { /* takes precedence over times */
	nt = 1;
    } else {
	R_xlen_t sum = 0;
	if(CADR(args) == R_MissingArg) PROTECT(times = ScalarInteger(1));
	else PROTECT(times = coerceVector(CADR(args), INTSXP));
	nprotect++;
	nt = XLENGTH(times);
	if(nt != 1 && nt != lx * each)
	    errorcall(call, _("invalid '%s' argument"), "times");
	if(nt == 1) {
	    int it = INTEGER(times)[0];
	    if (it == NA_INTEGER || it < 0)
		errorcall(call, _("invalid '%s' argument"), "times");
	    len = lx * it * each;
	} else {
	    for(i = 0; i < nt; i++) {
		int it = INTEGER(times)[i];
		if (it == NA_INTEGER || it < 0)
		    errorcall(call, _("invalid '%s' argument"), "times");
		sum += it;
	    }
            len = sum;
	}
    }

    if(len > 0 && each == 0)
	errorcall(call, _("invalid '%s' argument"), "each");

    SEXP xn = getNamesAttrib(x);

    PROTECT(ans = rep4(x, times, len, each, nt));
    if (length(xn) > 0)
	setAttrib(ans, R_NamesSymbol, rep4(xn, times, len, each, nt));

#ifdef _S4_rep_keepClass
    if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
	setAttrib(ans, R_ClassSymbol, getClassAttrib(x));
	SET_S4_OBJECT(ans);
    }
#endif
    UNPROTECT(nprotect);
    return ans;
}
Beispiel #19
0
SEXP nlm(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP value, names, v, R_gradientSymbol, R_hessianSymbol;

    double *x, *typsiz, fscale, gradtl, stepmx,
	steptol, *xpls, *gpls, fpls, *a, *wrk, dlt;

    int code, i, j, k, itnlim, method, iexp, omsg, msg,
	n, ndigit, iagflg, iahflg, want_hessian, itncnt;


/* .Internal(
 *	nlm(function(x) f(x, ...), p, hessian, typsize, fscale,
 *	    msg, ndigit, gradtol, stepmax, steptol, iterlim)
 */
    function_info *state;

    args = CDR(args);
    PrintDefaults();

    state = (function_info *) R_alloc(1, sizeof(function_info));

    /* the function to be minimized */

    v = CAR(args);
    if (!isFunction(v))
	error(_("attempt to minimize non-function"));
    PROTECT(state->R_fcall = lang2(v, R_NilValue));
    args = CDR(args);

    /* `p' : inital parameter value */

    n = 0;
    x = fixparam(CAR(args), &n);
    args = CDR(args);

    /* `hessian' : H. required? */

    want_hessian = asLogical(CAR(args));
    if (want_hessian == NA_LOGICAL) want_hessian = 0;
    args = CDR(args);

    /* `typsize' : typical size of parameter elements */

    typsiz = fixparam(CAR(args), &n);
    args = CDR(args);

    /* `fscale' : expected function size */

    fscale = asReal(CAR(args));
    if (ISNA(fscale)) error(_("invalid NA value in parameter"));
    args = CDR(args);

    /* `msg' (bit pattern) */
    omsg = msg = asInteger(CAR(args));
    if (msg == NA_INTEGER) error(_("invalid NA value in parameter"));
    args = CDR(args);

    ndigit = asInteger(CAR(args));
    if (ndigit == NA_INTEGER) error(_("invalid NA value in parameter"));
    args = CDR(args);

    gradtl = asReal(CAR(args));
    if (ISNA(gradtl)) error(_("invalid NA value in parameter"));
    args = CDR(args);

    stepmx = asReal(CAR(args));
    if (ISNA(stepmx)) error(_("invalid NA value in parameter"));
    args = CDR(args);

    steptol = asReal(CAR(args));
    if (ISNA(steptol)) error(_("invalid NA value in parameter"));
    args = CDR(args);

    /* `iterlim' (def. 100) */
    itnlim = asInteger(CAR(args));
    if (itnlim == NA_INTEGER) error(_("invalid NA value in parameter"));

    state->R_env = rho;

    /* force one evaluation to check for the gradient and hessian */
    iagflg = 0;			/* No analytic gradient */
    iahflg = 0;			/* No analytic hessian */
    state->have_gradient = 0;
    state->have_hessian = 0;
    R_gradientSymbol = install("gradient");
    R_hessianSymbol = install("hessian");

    /* This vector is shared with all subsequent calls */
    v = allocVector(REALSXP, n);
    for (i = 0; i < n; i++) REAL(v)[i] = x[i];
    SETCADR(state->R_fcall, v);
    SET_NAMED(v, 2); // in case the functions try to alter it
    value = eval(state->R_fcall, state->R_env);

    v = getAttrib(value, R_gradientSymbol);
    if (v != R_NilValue) {
	if (LENGTH(v) == n && (isReal(v) || isInteger(v))) {
	    iagflg = 1;
	    state->have_gradient = 1;
	    v = getAttrib(value, R_hessianSymbol);

	    if (v != R_NilValue) {
		if (LENGTH(v) == (n * n) && (isReal(v) || isInteger(v))) {
		    iahflg = 1;
		    state->have_hessian = 1;
		} else {
		    warning(_("hessian supplied is of the wrong length or mode, so ignored"));
		}
	    }
	} else {
	    warning(_("gradient supplied is of the wrong length or mode, so ignored"));
	}
    }
    if (((msg/4) % 2) && !iahflg) { /* skip check of analytic Hessian */
      msg -= 4;
    }
    if (((msg/2) % 2) && !iagflg) { /* skip check of analytic gradient */
      msg -= 2;
    }
    FT_init(n, FT_SIZE, state);
    /* Plug in the call to the optimizer here */

    method = 1;	/* Line Search */
    iexp = iahflg ? 0 : 1; /* Function calls are expensive */
    dlt = 1.0;

    xpls = (double*)R_alloc(n, sizeof(double));
    gpls = (double*)R_alloc(n, sizeof(double));
    a = (double*)R_alloc(n*n, sizeof(double));
    wrk = (double*)R_alloc(8*n, sizeof(double));

    /*
     *	 Dennis + Schnabel Minimizer
     *
     *	  SUBROUTINE OPTIF9(NR,N,X,FCN,D1FCN,D2FCN,TYPSIZ,FSCALE,
     *	 +	   METHOD,IEXP,MSG,NDIGIT,ITNLIM,IAGFLG,IAHFLG,IPR,
     *	 +	   DLT,GRADTL,STEPMX,STEPTOL,
     *	 +	   XPLS,FPLS,GPLS,ITRMCD,A,WRK)
     *
     *
     *	 Note: I have figured out what msg does.
     *	 It is actually a sum of bit flags as follows
     *	   1 = don't check/warn for 1-d problems
     *	   2 = don't check analytic gradients
     *	   4 = don't check analytic hessians
     *	   8 = don't print start and end info
     *	  16 = print at every iteration
     *	 Using msg=9 is absolutely minimal
     *	 I think we always check gradients and hessians
     */

    optif9(n, n, x, (fcn_p) fcn, (fcn_p) Cd1fcn, (d2fcn_p) Cd2fcn,
	   state, typsiz, fscale, method, iexp, &msg, ndigit, itnlim,
	   iagflg, iahflg, dlt, gradtl, stepmx, steptol, xpls, &fpls,
	   gpls, &code, a, wrk, &itncnt);

    if (msg < 0)
	opterror(msg);
    if (code != 0 && (omsg&8) == 0)
	optcode(code);

    if (want_hessian) {
	PROTECT(value = allocVector(VECSXP, 6));
	PROTECT(names = allocVector(STRSXP, 6));
	fdhess(n, xpls, fpls, (fcn_p) fcn, state, a, n, &wrk[0], &wrk[n],
	       ndigit, typsiz);
	for (i = 0; i < n; i++)
	    for (j = 0; j < i; j++)
		a[i + j * n] = a[j + i * n];
    }
    else {
	PROTECT(value = allocVector(VECSXP, 5));
	PROTECT(names = allocVector(STRSXP, 5));
    }
    k = 0;

    SET_STRING_ELT(names, k, mkChar("minimum"));
    SET_VECTOR_ELT(value, k, ScalarReal(fpls));
    k++;

    SET_STRING_ELT(names, k, mkChar("estimate"));
    SET_VECTOR_ELT(value, k, allocVector(REALSXP, n));
    for (i = 0; i < n; i++)
	REAL(VECTOR_ELT(value, k))[i] = xpls[i];
    k++;

    SET_STRING_ELT(names, k, mkChar("gradient"));
    SET_VECTOR_ELT(value, k, allocVector(REALSXP, n));
    for (i = 0; i < n; i++)
	REAL(VECTOR_ELT(value, k))[i] = gpls[i];
    k++;

    if (want_hessian) {
	SET_STRING_ELT(names, k, mkChar("hessian"));
	SET_VECTOR_ELT(value, k, allocMatrix(REALSXP, n, n));
	for (i = 0; i < n * n; i++)
	    REAL(VECTOR_ELT(value, k))[i] = a[i];
	k++;
    }

    SET_STRING_ELT(names, k, mkChar("code"));
    SET_VECTOR_ELT(value, k, allocVector(INTSXP, 1));
    INTEGER(VECTOR_ELT(value, k))[0] = code;
    k++;

    /* added by Jim K Lindsey */
    SET_STRING_ELT(names, k, mkChar("iterations"));
    SET_VECTOR_ELT(value, k, allocVector(INTSXP, 1));
    INTEGER(VECTOR_ELT(value, k))[0] = itncnt;
    k++;

    setAttrib(value, R_NamesSymbol, names);
    UNPROTECT(3);
    return value;
}
Beispiel #20
0
/* to match seq.default */
SEXP attribute_hidden do_seq(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP ans = R_NilValue /* -Wall */, tmp, from, to, by, len, along;
    int nargs = length(args), lf;
    Rboolean One = nargs == 1;
    R_xlen_t i, lout = NA_INTEGER;
    static SEXP do_seq_formals = NULL;    

    if (DispatchOrEval(call, op, R_SeqCharSXP, args, rho, &ans, 0, 1))
	return(ans);

    /* This is a primitive and we manage argument matching ourselves.
       We pretend this is
       seq(from, to, by, length.out, along.with, ...)
    */
    if (do_seq_formals == NULL) {
        do_seq_formals = CONS(R_NilValue, CONS(R_NilValue, list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue)));
        R_PreserveObject(do_seq_formals);
        tmp = do_seq_formals;
        SET_TAG(tmp, install("from")); tmp = CDR(tmp);
        SET_TAG(tmp, install("to")); tmp = CDR(tmp);
        SET_TAG(tmp, install("by")); tmp = CDR(tmp);
        SET_TAG(tmp, R_LengthOutSymbol); tmp = CDR(tmp);
        SET_TAG(tmp, R_AlongWithSymbol); tmp = CDR(tmp);
        SET_TAG(tmp, R_DotsSymbol);
    }
    
    PROTECT(args = matchArgs(do_seq_formals, args, call));

    from = CAR(args); args = CDR(args);
    to = CAR(args); args = CDR(args);
    by = CAR(args); args = CDR(args);
    len = CAR(args); args = CDR(args);
    along = CAR(args);

    if(One && from != R_MissingArg) {
	lf = length(from);
	if(lf == 1 && (TYPEOF(from) == INTSXP || TYPEOF(from) == REALSXP)) {
	    double rfrom = asReal(from);
	    if (!R_FINITE(rfrom))
		errorcall(call, "'from' cannot be NA, NaN or infinite");
	    ans = seq_colon(1.0, rfrom, call);
	}
	else if (lf)
	    ans = seq_colon(1.0, (double)lf, call);
	else
	    ans = allocVector(INTSXP, 0);
	goto done;
    }
    if(along != R_MissingArg) {
	lout = XLENGTH(along);
	if(One) {
	    ans = lout ? seq_colon(1.0, (double)lout, call) : allocVector(INTSXP, 0);
	    goto done;
	}
    } else if(len != R_MissingArg && len != R_NilValue) {
	double rout = asReal(len);
	if(ISNAN(rout) || rout <= -0.5)
	    errorcall(call, _("'length.out' must be a non-negative number"));
	if(length(len) != 1)
	    warningcall(call, _("first element used of '%s' argument"), 
			"length.out");
	lout = (R_xlen_t) ceil(rout);
    }

    if(lout == NA_INTEGER) {
	double rfrom = asReal(from), rto = asReal(to), rby = asReal(by), *ra;
	if(from == R_MissingArg) rfrom = 1.0;
	else if(length(from) != 1) error("'from' must be of length 1");
	if(to == R_MissingArg) rto = 1.0;
	else if(length(to) != 1) error("'to' must be of length 1");
	if (!R_FINITE(rfrom))
	    errorcall(call, "'from' cannot be NA, NaN or infinite");
	if (!R_FINITE(rto))
	    errorcall(call, "'to' cannot be NA, NaN or infinite");
	if(by == R_MissingArg)
	    ans = seq_colon(rfrom, rto, call);
	else {
	    if(length(by) != 1) error("'by' must be of length 1");
	    double del = rto - rfrom, n, dd;
	    R_xlen_t nn;
	    if(!R_FINITE(rfrom))
		errorcall(call, _("'from' must be finite"));
	    if(!R_FINITE(rto))
		errorcall(call, _("'to' must be finite"));
	    if(del == 0.0 && rto == 0.0) {
		ans = to;
		goto done;
	    }
	    /* printf("from = %f, to = %f, by = %f\n", rfrom, rto, rby); */
	    n = del/rby;
	    if(!R_FINITE(n)) {
		if(del == 0.0 && rby == 0.0) {
		    ans = from;
		    goto done;
		} else
		    errorcall(call, _("invalid '(to - from)/by' in 'seq'"));
	    }
	    dd = fabs(del)/fmax2(fabs(rto), fabs(rfrom));
	    if(dd < 100 * DBL_EPSILON) {
		ans = from;
		goto done;
	    }
#ifdef LONG_VECTOR_SUPPORT
	    if(n > 100 * (double) INT_MAX)
#else
	    if(n > (double) INT_MAX)
#endif
		errorcall(call, _("'by' argument is much too small"));
	    if(n < - FEPS)
		errorcall(call, _("wrong sign in 'by' argument"));
	    if(TYPEOF(from) == INTSXP &&
	       TYPEOF(to) == INTSXP &&
	       TYPEOF(by) == INTSXP) {
		int *ia, ifrom = asInteger(from), iby = asInteger(by);
		/* With the current limits on integers and FEPS
		   reduced below 1/INT_MAX this is the same as the
		   next, so this is future-proofing against longer integers.
		*/
		/* seq.default gives integer result from
		   from + (0:n)*by
		*/
		nn = (R_xlen_t) n;
		ans = allocVector(INTSXP, nn+1);
		ia = INTEGER(ans);
		for(i = 0; i <= nn; i++)
		    ia[i] = (int)(ifrom + i * iby);
	    } else {
		nn = (int)(n + FEPS);
		ans = allocVector(REALSXP, nn+1);
		ra = REAL(ans);
		for(i = 0; i <= nn; i++)
		    ra[i] = rfrom + (double)i * rby;
		/* Added in 2.9.0 */
		if (nn > 0)
		    if((rby > 0 && ra[nn] > rto) || (rby < 0 && ra[nn] < rto))
			ra[nn] = rto;
	    }
	}
    } else if (lout == 0) {
	ans = allocVector(INTSXP, 0);
    } else if (One) {
	ans = seq_colon(1.0, (double)lout, call);
    } else if (by == R_MissingArg) {
	double rfrom = asReal(from), rto = asReal(to), rby;
	if(to == R_MissingArg) rto = rfrom + (double)lout - 1;
	if(from == R_MissingArg) rfrom = rto - (double)lout + 1;
	if(!R_FINITE(rfrom))
	    errorcall(call, _("'from' must be finite"));
	if(!R_FINITE(rto))
	    errorcall(call, _("'to' must be finite"));
	ans = allocVector(REALSXP, lout);
	if(lout > 0) REAL(ans)[0] = rfrom;
	if(lout > 1) REAL(ans)[lout - 1] = rto;
	if(lout > 2) {
	    rby = (rto - rfrom)/(double)(lout - 1);
	    for(i = 1; i < lout-1; i++) {
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
		REAL(ans)[i] = rfrom + (double)i*rby;
	    }
	}
    } else if (to == R_MissingArg) {
	double rfrom = asReal(from), rby = asReal(by), rto;
	if(from == R_MissingArg) rfrom = 1.0;
	if(!R_FINITE(rfrom))
	    errorcall(call, _("'from' must be finite"));
	if(!R_FINITE(rby))
	    errorcall(call, _("'by' must be finite"));
	rto = rfrom + (double)(lout-1)*rby;
	if(rby == (int)rby && rfrom <= INT_MAX && rfrom >= INT_MIN
	   && rto <= INT_MAX && rto >= INT_MIN) {
	    ans = allocVector(INTSXP, lout);
	    for(i = 0; i < lout; i++) {
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
		INTEGER(ans)[i] = (int)(rfrom + (double)i*rby);
	    }
	} else {
	    ans = allocVector(REALSXP, lout);
	    for(i = 0; i < lout; i++) {
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
		REAL(ans)[i] = rfrom + (double)i*rby;
	    }
	}
    } else if (from == R_MissingArg) {
	double rto = asReal(to), rby = asReal(by),
	    rfrom = rto - (double)(lout-1)*rby;
	if(!R_FINITE(rto))
	    errorcall(call, _("'to' must be finite"));
	if(!R_FINITE(rby))
	    errorcall(call, _("'by' must be finite"));
	if(rby == (int)rby && rfrom <= INT_MAX && rfrom >= INT_MIN
	   && rto <= INT_MAX && rto >= INT_MIN) {
	    ans = allocVector(INTSXP, lout);
	    for(i = 0; i < lout; i++) {
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
		INTEGER(ans)[i] = (int)(rto - (double)(lout - 1 - i)*rby);
	    }
	} else {
	    ans = allocVector(REALSXP, lout);
	    for(i = 0; i < lout; i++) {
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
		REAL(ans)[i] = rto - (double)(lout - 1 - i)*rby;
	    }
	}
    } else
	errorcall(call, _("too many arguments"));

done:
    UNPROTECT(1);
    return ans;
}
Beispiel #21
0
SEXP na_locf (SEXP x, SEXP fromLast, SEXP _maxgap, SEXP _limit)
{
  /* only works on univariate data         *
   * of type LGLSXP, INTSXP and REALSXP.   */
  SEXP result;

  int i, ii, nr, _first, P=0;
  double gap, maxgap, limit;
  _first = firstNonNA(x);

  if(_first == nrows(x))
    return(x);

  int *int_x=NULL, *int_result=NULL;
  double *real_x=NULL, *real_result=NULL;

  if(ncols(x) > 1)
    error("na.locf.xts only handles univariate, dimensioned data");

  nr = nrows(x);
  maxgap = asReal(coerceVector(_maxgap,REALSXP));
  limit  = asReal(coerceVector(_limit ,REALSXP));
  gap = 0;

  PROTECT(result = allocVector(TYPEOF(x), nrows(x))); P++;

  switch(TYPEOF(x)) {
    case LGLSXP:
      int_x = LOGICAL(x);
      int_result = LOGICAL(result);
      if(!LOGICAL(fromLast)[0]) {
        /* copy leading NAs */
        for(i=0; i < (_first+1); i++) {
          int_result[i] = int_x[i];
        }
        /* result[_first] now has first value fromLast=FALSE */
        for(i=_first+1; i<nr; i++) {
          int_result[i] = int_x[i];
          if(int_result[i] == NA_LOGICAL && gap < maxgap) {
            int_result[i] = int_result[i-1];
            gap++;
          }
        }
        if((int)gap > (int)maxgap) {  /* check that we don't have excessive trailing gap */
          for(ii = i-1; ii > i-gap-1; ii--) {
            int_result[ii] = NA_LOGICAL; 
          }
        }
      } else {
        /* nr-2 is first position to fill fromLast=TRUE */
        int_result[nr-1] = int_x[nr-1];
        for(i=nr-2; i>=0; i--) {
          int_result[i] = int_x[i];
          if(int_result[i] == NA_LOGICAL && gap < maxgap) {
            int_result[i] = int_result[i+1];
            gap++;
          }
        }
      }
      break;
    case INTSXP:
      int_x = INTEGER(x);
      int_result = INTEGER(result);
      if(!LOGICAL(fromLast)[0]) {
        /* copy leading NAs */
        for(i=0; i < (_first+1); i++) {
          int_result[i] = int_x[i];
        }
        /* result[_first] now has first value fromLast=FALSE */
        for(i=_first+1; i<nr; i++) {
          int_result[i] = int_x[i];
          if(int_result[i] == NA_INTEGER) {
            if(limit > gap)
              int_result[i] = int_result[i-1];
            gap++;
          } else {
            if((int)gap > (int)maxgap) {
              for(ii = i-1; ii > i-gap-1; ii--) {
                int_result[ii] = NA_INTEGER; 
              }
            }
            gap=0;
          }
        }
        if((int)gap > (int)maxgap) {  /* check that we don't have excessive trailing gap */
          for(ii = i-1; ii > i-gap-1; ii--) {
            int_result[ii] = NA_INTEGER; 
          }
        }
      } else {
        /* nr-2 is first position to fill fromLast=TRUE */
        int_result[nr-1] = int_x[nr-1];
        for(i=nr-2; i>=0; i--) {
          int_result[i] = int_x[i];
          if(int_result[i] == NA_INTEGER) {
            if(limit > gap)
              int_result[i] = int_result[i+1];
            gap++;
          } else {
            if((int)gap > (int)maxgap) {
              for(ii = i+1; ii < i+gap+1; ii++) {
                int_result[ii] = NA_INTEGER; 
              }
            }
            gap=0;
          }
        }
        if((int)gap > (int)maxgap) {  /* check that we don't have leading trailing gap */
          for(ii = i+1; ii < i+gap+1; ii++) {
            int_result[ii] = NA_INTEGER; 
          }
        }
      }
      break;
    case REALSXP:
      real_x = REAL(x);
      real_result = REAL(result);
      if(!LOGICAL(fromLast)[0]) {   /* fromLast=FALSE */
        for(i=0; i < (_first+1); i++) {
          real_result[i] = real_x[i];
        }
        for(i=_first+1; i<nr; i++) {
          real_result[i] = real_x[i];
          if( ISNA(real_result[i]) || ISNAN(real_result[i])) {
            if(limit > gap)
              real_result[i] = real_result[i-1];
            gap++;
          } else {
            if((int)gap > (int)maxgap) {
              for(ii = i-1; ii > i-gap-1; ii--) {
                real_result[ii] = NA_REAL; 
              }
            }
            gap=0;
          }
        }
        if((int)gap > (int)maxgap) {  /* check that we don't have excessive trailing gap */
          for(ii = i-1; ii > i-gap-1; ii--) {
            real_result[ii] = NA_REAL; 
          }
        }
      } else {                      /* fromLast=TRUE */
        real_result[nr-1] = real_x[nr-1];
        for(i=nr-2; i>=0; i--) {
          real_result[i] = real_x[i];
          if(ISNA(real_result[i]) || ISNAN(real_result[i])) {
            if(limit > gap)
              real_result[i] = real_result[i+1];
            gap++;
          } else {
            if((int)gap > (int)maxgap) {
              for(ii = i+1; ii < i+gap+1; ii++) {
                real_result[ii] = NA_REAL; 
              }
            }
            gap=0;
          }
        }
        if((int)gap > (int)maxgap) {  /* check that we don't have leading trailing gap */
          for(ii = i+1; ii < i+gap+1; ii++) {
            real_result[ii] = NA_REAL; 
          }
        }
      }
      break;
    default:
      error("unsupported type");
      break;
  }
  if(isXts(x)) {
    setAttrib(result, R_DimSymbol, getAttrib(x, R_DimSymbol));
    setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
    setAttrib(result, xts_IndexSymbol, getAttrib(x, xts_IndexSymbol));
    copy_xtsCoreAttributes(x, result);
    copy_xtsAttributes(x, result);
  }
  UNPROTECT(P);
  return(result);
}
Beispiel #22
0
SEXP Cdqrls(SEXP x, SEXP y, SEXP tol)
{
    SEXP ans, ansnames;
    SEXP qr, coefficients, residuals, effects, pivot, qraux;
    int n, ny = 0, p, rank, nprotect = 4, pivoted = 0;
    double rtol = asReal(tol), *work;


    int *dims = INTEGER(getAttrib(x, R_DimSymbol));
    n = dims[0]; p = dims[1];
    if(n) ny = LENGTH(y)/n;  /* n x ny, or a vector */

    /* These lose attributes, so do after we have extracted dims */
    if (TYPEOF(x) != REALSXP) {
	PROTECT(x = coerceVector(x, REALSXP)); 
	nprotect++;
    }
    if (TYPEOF(y) != REALSXP) {
	PROTECT(y = coerceVector(y, REALSXP));
	nprotect++;
    }

    double *rptr = REAL(x);
    for (R_xlen_t i = 0 ; i < XLENGTH(x) ; i++)
	if(!R_FINITE(rptr[i])) error("NA/NaN/Inf in 'x'");
    
    rptr = REAL(y);
    for (R_xlen_t i = 0 ; i < XLENGTH(y) ; i++)
	if(!R_FINITE(rptr[i])) error("NA/NaN/Inf in 'y'");

    PROTECT(ans = allocVector(VECSXP, 9));
    ansnames = allocVector(STRSXP, 9);
    setAttrib(ans, R_NamesSymbol, ansnames);
    SET_STRING_ELT(ansnames, 0, mkChar("qr"));
    SET_STRING_ELT(ansnames, 1, mkChar("coefficients"));
    SET_STRING_ELT(ansnames, 2, mkChar("residuals"));
    SET_STRING_ELT(ansnames, 3, mkChar("effects"));
    SET_STRING_ELT(ansnames, 4, mkChar("rank"));
    SET_STRING_ELT(ansnames, 5, mkChar("pivot"));
    SET_STRING_ELT(ansnames, 6, mkChar("qraux"));
    SET_STRING_ELT(ansnames, 7, mkChar("tol"));
    SET_STRING_ELT(ansnames, 8, mkChar("pivoted"));
    SET_VECTOR_ELT(ans, 0, qr = duplicate(x));
    if (ny > 1) coefficients = allocMatrix(REALSXP, p, ny);
    else coefficients = allocVector(REALSXP, p);
    PROTECT(coefficients);
    SET_VECTOR_ELT(ans, 1, coefficients);
    SET_VECTOR_ELT(ans, 2, residuals = duplicate(y));
    SET_VECTOR_ELT(ans, 3, effects = duplicate(y));
    PROTECT(pivot = allocVector(INTSXP, p));
    int *ip = INTEGER(pivot);
    for(int i = 0; i < p; i++) ip[i] = i+1;
    SET_VECTOR_ELT(ans, 5, pivot);
    PROTECT(qraux = allocVector(REALSXP, p));
    SET_VECTOR_ELT(ans, 6, qraux);
    SET_VECTOR_ELT(ans, 7, tol);
   
    work = (double *) R_alloc(2 * p, sizeof(double));
    F77_CALL(dqrls)(REAL(qr), &n, &p, REAL(y), &ny, &rtol,
		    REAL(coefficients), REAL(residuals), REAL(effects),
		    &rank, INTEGER(pivot), REAL(qraux), work);
    SET_VECTOR_ELT(ans, 4, ScalarInteger(rank));
    for(int i = 0; i < p; i++)
	if(ip[i] != i+1) { pivoted = 1; break; }
    SET_VECTOR_ELT(ans, 8, ScalarLogical(pivoted));
    UNPROTECT(nprotect);
    
    return ans;
}
Beispiel #23
0
SEXP
KalmanSmooth(SEXP sy, SEXP sZ, SEXP sa, SEXP sP, SEXP sT,
	     SEXP sV, SEXP sh, SEXP sPn, SEXP sUP)
{
    SEXP ssa, ssP, ssPn, res, states = R_NilValue, sN;
    double resid0, gain, tmp, *anew, *mm, *M;
    double *at, *rt, *Pt, *gains, *resids, *Mt, *L, gn, *Nt;
    int i, j, k, l;
    Rboolean var = TRUE;

    if (TYPEOF(sy) != REALSXP || TYPEOF(sZ) != REALSXP ||
	TYPEOF(sa) != REALSXP || TYPEOF(sP) != REALSXP ||
	TYPEOF(sT) != REALSXP || TYPEOF(sV) != REALSXP)
	error(_("invalid argument type"));

    int n = LENGTH(sy), p = LENGTH(sa);
    double *y = REAL(sy), *Z = REAL(sZ), *a, *P,
	*T = REAL(sT), *V = REAL(sV), h = asReal(sh), *Pnew;

    PROTECT(ssa = duplicate(sa)); a = REAL(ssa);
    PROTECT(ssP = duplicate(sP)); P = REAL(ssP);
    PROTECT(ssPn = duplicate(sPn)); Pnew = REAL(ssPn);

    PROTECT(res = allocVector(VECSXP, 2));
    SET_VECTOR_ELT(res, 0, states = allocMatrix(REALSXP, n, p));
    at = REAL(states);
    SET_VECTOR_ELT(res, 1, sN = allocVector(REALSXP, n*p*p));
    Nt = REAL(sN);

    anew = (double *) R_alloc(p, sizeof(double));
    M = (double *) R_alloc(p, sizeof(double));
    mm = (double *) R_alloc(p * p, sizeof(double));

    Pt = (double *) R_alloc(n * p * p, sizeof(double));
    gains = (double *) R_alloc(n, sizeof(double));
    resids = (double *) R_alloc(n, sizeof(double));
    Mt = (double *) R_alloc(n * p, sizeof(double));
    L = (double *) R_alloc(p * p, sizeof(double));

    for (l = 0; l < n; l++) {
	for (i = 0; i < p; i++) {
	    tmp = 0.0;
	    for (k = 0; k < p; k++)
		tmp += T[i + p * k] * a[k];
	    anew[i] = tmp;
	}
	if (l > asInteger(sUP)) {
	    for (i = 0; i < p; i++)
		for (j = 0; j < p; j++) {
		    tmp = 0.0;
		    for (k = 0; k < p; k++)
			tmp += T[i + p * k] * P[k + p * j];
		    mm[i + p * j] = tmp;
		}
	    for (i = 0; i < p; i++)
		for (j = 0; j < p; j++) {
		    tmp = V[i + p * j];
		    for (k = 0; k < p; k++)
			tmp += mm[i + p * k] * T[j + p * k];
		    Pnew[i + p * j] = tmp;
		}
	}
	for (i = 0; i < p; i++) at[l + n*i] = anew[i];
	for (i = 0; i < p*p; i++) Pt[l + n*i] = Pnew[i];
	if (!ISNAN(y[l])) {
	    resid0 = y[l];
	    for (i = 0; i < p; i++)
		resid0 -= Z[i] * anew[i];
	    gain = h;
	    for (i = 0; i < p; i++) {
		tmp = 0.0;
		for (j = 0; j < p; j++)
		    tmp += Pnew[i + j * p] * Z[j];
		Mt[l + n*i] = M[i] = tmp;
		gain += Z[i] * M[i];
	    }
	    gains[l] = gain;
	    resids[l] = resid0;
	    for (i = 0; i < p; i++)
		a[i] = anew[i] + M[i] * resid0 / gain;
	    for (i = 0; i < p; i++)
		for (j = 0; j < p; j++)
		    P[i + j * p] = Pnew[i + j * p] - M[i] * M[j] / gain;
	} else {
	    for (i = 0; i < p; i++) {
		a[i] = anew[i];
		Mt[l + n * i] = 0.0;
	    }
	    for (i = 0; i < p * p; i++)
		P[i] = Pnew[i];
	    gains[l] = NA_REAL;
	    resids[l] = NA_REAL;
	}
    }

    /* rt stores r_{t-1} */
    rt = (double *) R_alloc(n * p, sizeof(double));
    for (l = n - 1; l >= 0; l--) {
	if (!ISNAN(gains[l])) {
	    gn = 1/gains[l];
	    for (i = 0; i < p; i++)
		rt[l + n * i] = Z[i] * resids[l] * gn;
	} else {
	    for (i = 0; i < p; i++) rt[l + n * i] = 0.0;
	    gn = 0.0;
	}

	if (var) {
	    for (i = 0; i < p; i++)
		for (j = 0; j < p; j++)
		    Nt[l + n*i + n*p*j] = Z[i] * Z[j] * gn;
	}

	if (l < n - 1) {
	    /* compute r_{t-1} */
	    for (i = 0; i < p; i++)
		for (j = 0; j < p; j++)
		    mm[i + p * j] = ((i==j)?1:0) - Mt[l + n * i] * Z[j] * gn;
	    for (i = 0; i < p; i++)
		for (j = 0; j < p; j++) {
		    tmp = 0.0;
		    for (k = 0; k < p; k++)
			tmp += T[i + p * k] * mm[k + p * j];
		    L[i + p * j] = tmp;
		}
	    for (i = 0; i < p; i++) {
		tmp = 0.0;
		for (j = 0; j < p; j++)
		    tmp += L[j + p * i] * rt[l + 1 + n * j];
		rt[l + n * i] += tmp;
	    }
	    if(var) { /* compute N_{t-1} */
		for (i = 0; i < p; i++)
		    for (j = 0; j < p; j++) {
			tmp = 0.0;
			for (k = 0; k < p; k++)
			    tmp += L[k + p * i] * Nt[l + 1 + n*k + n*p*j];
			mm[i + p * j] = tmp;
		    }
		for (i = 0; i < p; i++)
		    for (j = 0; j < p; j++) {
			tmp = 0.0;
			for (k = 0; k < p; k++)
			    tmp += mm[i + p * k] * L[k + p * j];
			Nt[l + n*i + n*p*j] += tmp;
		    }
	    }
	}

	for (i = 0; i < p; i++) {
	    tmp = 0.0;
	    for (j = 0; j < p; j++)
		tmp += Pt[l + n*i + n*p*j] * rt[l + n * j];
	    at[l + n*i] += tmp;
	}
    }
    if (var)
	for (l = 0; l < n; l++) {
	    for (i = 0; i < p; i++)
		for (j = 0; j < p; j++) {
		    tmp = 0.0;
		    for (k = 0; k < p; k++)
			tmp += Pt[l + n*i + n*p*k] * Nt[l + n*k + n*p*j];
		    mm[i + p * j] = tmp;
		}
	    for (i = 0; i < p; i++)
		for (j = 0; j < p; j++) {
		    tmp = Pt[l + n*i + n*p*j];
		    for (k = 0; k < p; k++)
			tmp -= mm[i + p * k] * Pt[l + n*k + n*p*j];
		    Nt[l + n*i + n*p*j] = tmp;
		}
	}
    UNPROTECT(4);
    return res;
}
Beispiel #24
0
SEXP prob_profit ( SEXP beg, SEXP end, SEXP lsp,
        SEXP horizon, SEXP sample )
{
  /* Arguments:
   *   beg      First permutation index value
   *   end      Last permutation index value
   *   val      Profit target (percent)
   *   horizon  Horizon over which to determine probability
   *   hpr      Holding period returns
   *   prob     Probability of each HPR
   *   sample   If sample=0, run all permutations
   *            else run 'end - beg' random permutations
   *   replace  boolean (not implemented, always replace)
   */

  int P=0;  /* PROTECT counter */
  int i, j;  /* loop counters */

  /* extract lsp components */
  //double *d_event   = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 0)))); P++;
  double *d_prob    = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 1)))); P++;
  //double *d_fval    = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 2)))); P++;
  //double *d_maxloss = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 3)))); P++;
  double *d_zval    = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 4)))); P++;

  /* Get values from pointers */
  double i_beg = asReal(beg)-1;  /* zero-based */
  double i_end = asReal(end)-1;  /* zero-based */
  double i_sample = asReal(sample);
  int i_horizon = asInteger(horizon);

  /* initialize result object and pointer */
  SEXP result;
  PROTECT(result = allocVector(REALSXP, 2)); P++;
  double *d_result = REAL(result);

  /* initialize portfolio HPR object */
  SEXP phpr;

  double I; int J;
  double nr = nrows(VECTOR_ELT(lsp, 1));
  double passProb = 0;
  double sumProb = 0;
  double *d_phpr = NULL;

  /* does the lsp object have non-zero z values? */
  int using_z = (d_zval[0]==0 && d_zval[1]==0) ? 0 : 1;

  /* initialize object to hold permutation locations */
  SEXP perm;
  PROTECT(perm = allocVector(INTSXP, i_horizon)); P++;
  int *i_perm = INTEGER(perm);

  /* if lsp object contains z-values of zero, calculate HPR before
   * running permutations */
  if( !using_z ) {
    PROTECT(phpr = hpr(lsp, ScalarLogical(TRUE), R_NilValue)); P++;
    d_phpr = REAL(phpr);
  }

  /* Initialize R's random number generator (read in .Random.seed) */
  if(i_sample > 0) GetRNGstate();

  double probPerm;  /* proability of this permutation */
  double t0hpr;     /* this period's (t = 0) HPR */
  double t1hpr;     /* last period's (t = 1) HPR */
  double target = 1+d_zval[2];
    
  /* Loop over each permutation index */
  for(i=i_beg; i<=i_end; i++) {

    /* check for user-requested interrupt */
    if( i % 10000 == 999 ) R_CheckUserInterrupt();

    probPerm = 1;  /* proability of this permutation */
    t0hpr = 1;     /* this period's (t = 0) HPR */
    t1hpr = 1;     /* last period's (t = 1) HPR */
    
    /* if sampling, get a random permutation between 0 and nPr-1,
     * else use the current index value. */
    I = (i_sample > 0) ? ( unif_rand() * (i_sample-1) ) : i;

    /* set the permutation locations for index 'I' */
    for(j=i_horizon; j--;) {
      i_perm[j] = (long)fmod(I/pow(nr,j),nr);
    }
    /* Keep track of this permutation's probability */
    for(j=i_horizon; j--;) {
      probPerm *= d_prob[i_perm[j]];
    }
    /* if lsp object contains non-zero z values, calculate HPR for
     * each permutation */
    if( using_z ) {
      /* call lspm::hpr and assign pointer */
      PROTECT(phpr = hpr(lsp, ScalarLogical(TRUE), perm));
      d_phpr = REAL(phpr);
    }

    /* loop over permutation locations */
    for(j=0; j<i_horizon; j++) {
      /* if using_z, phpr has 'i_horizon' elements, else it has
       * 'nr' elements */
      J = using_z ? j : i_perm[j];
      t1hpr *= d_phpr[J];  /* New portfolio balance */
    }
    if( using_z ) UNPROTECT(1);  /* UNPROTECT phpr */
    /* If this permutation hit its target return,
     * add its probability to the total. */
    if( t1hpr >= target ) {
      passProb += probPerm;
    }
    /* Total probability of all permutations */
    sumProb += probPerm;
  }
  if(i_sample > 0) PutRNGstate();  /* Write out .Random.seed */

  /* Store results */
  d_result[0] = passProb;
  d_result[1] = sumProb;

  UNPROTECT(P);
  return result;
}
Beispiel #25
0
/* y vector length n of observations
   Z vector length p for observation equation y_t = Za_t +  eps_t
   a vector length p of initial state
   P p x p matrix for initial state uncertainty (contemparaneous)
   T  p x p transition matrix
   V  p x p = RQR'
   h = var(eps_t)
   anew used for a[t|t-1]
   Pnew used for P[t|t -1]
   M used for M = P[t|t -1]Z

   No checking here!
 */
SEXP
KalmanLike(SEXP sy, SEXP sZ, SEXP sa, SEXP sP, SEXP sT,
	   SEXP sV, SEXP sh, SEXP sPn, SEXP sUP, SEXP op, SEXP fast)
{
    SEXP res, ans = R_NilValue, resid = R_NilValue, states = R_NilValue;
    int n, p, lop = asLogical(op);
    double *y, *Z, *a, *P, *T, *V, h = asReal(sh), *Pnew;
    double sumlog = 0.0, ssq = 0, resid0, gain, tmp, *anew, *mm, *M;
    int i, j, k, l;

    if (TYPEOF(sy) != REALSXP || TYPEOF(sZ) != REALSXP ||
	TYPEOF(sa) != REALSXP || TYPEOF(sP) != REALSXP ||
	TYPEOF(sPn) != REALSXP ||
	TYPEOF(sT) != REALSXP || TYPEOF(sV) != REALSXP)
	error(_("invalid argument type"));
    n = LENGTH(sy); p = LENGTH(sa);
    y = REAL(sy); Z = REAL(sZ); T = REAL(sT); V = REAL(sV);

    /* Avoid modifying arguments unless fast=TRUE */
    if (!LOGICAL(fast)[0]){
	    PROTECT(sP = duplicate(sP));
	    PROTECT(sa = duplicate(sa));
	    PROTECT(sPn = duplicate(sPn));
    }
    P = REAL(sP); a = REAL(sa); Pnew = REAL(sPn);

    anew = (double *) R_alloc(p, sizeof(double));
    M = (double *) R_alloc(p, sizeof(double));
    mm = (double *) R_alloc(p * p, sizeof(double));
    if(lop) {
	PROTECT(ans = allocVector(VECSXP, 3));
	SET_VECTOR_ELT(ans, 1, resid = allocVector(REALSXP, n));
	SET_VECTOR_ELT(ans, 2, states = allocMatrix(REALSXP, n, p));
    }
    for (l = 0; l < n; l++) {
	for (i = 0; i < p; i++) {
	    tmp = 0.0;
	    for (k = 0; k < p; k++)
		tmp += T[i + p * k] * a[k];
	    anew[i] = tmp;
	}
	if (l > asInteger(sUP)) {
	    for (i = 0; i < p; i++)
		for (j = 0; j < p; j++) {
		    tmp = 0.0;
		    for (k = 0; k < p; k++)
			tmp += T[i + p * k] * P[k + p * j];
		    mm[i + p * j] = tmp;
		}
	    for (i = 0; i < p; i++)
		for (j = 0; j < p; j++) {
		    tmp = V[i + p * j];
		    for (k = 0; k < p; k++)
			tmp += mm[i + p * k] * T[j + p * k];
		    Pnew[i + p * j] = tmp;
		}
	}
	if (!ISNAN(y[l])) {
	    double *rr = NULL /* -Wall */;
	    if(lop) rr = REAL(resid);
	    resid0 = y[l];
	    for (i = 0; i < p; i++)
		resid0 -= Z[i] * anew[i];
	    gain = h;
	    for (i = 0; i < p; i++) {
		tmp = 0.0;
		for (j = 0; j < p; j++)
		    tmp += Pnew[i + j * p] * Z[j];
		M[i] = tmp;
		gain += Z[i] * M[i];
	    }
	    ssq += resid0 * resid0 / gain;
	    if(lop) rr[l] = resid0 / sqrt(gain);
	    sumlog += log(gain);
	    for (i = 0; i < p; i++)
		a[i] = anew[i] + M[i] * resid0 / gain;
	    for (i = 0; i < p; i++)
		for (j = 0; j < p; j++)
		    P[i + j * p] = Pnew[i + j * p] - M[i] * M[j] / gain;
	} else {
	    double *rr = NULL /* -Wall */;
	    if(lop) rr = REAL(resid);
	    for (i = 0; i < p; i++)
		a[i] = anew[i];
	    for (i = 0; i < p * p; i++)
		P[i] = Pnew[i];
	    if(lop) rr[l] = NA_REAL;
	}
	if(lop) {
	    double *rs = REAL(states);
	    for(j = 0; j < p; j++) rs[l + n*j] = a[j];
	}
    }

    if(lop) {
	SET_VECTOR_ELT(ans, 0, res=allocVector(REALSXP, 2));
	REAL(res)[0] = ssq; REAL(res)[1] = sumlog;
	UNPROTECT(1);
	if (!LOGICAL(fast)[0])
	    UNPROTECT(3);
	return ans;
    } else {
	res = allocVector(REALSXP, 2);
	REAL(res)[0] = ssq; REAL(res)[1] = sumlog;
	if (!LOGICAL(fast)[0])
	    UNPROTECT(3);
	return res;
    }
}
Beispiel #26
0
/*
 *  call to nls_iter from R --- .Call("nls_iter", m, control, doTrace)
 *  where m and control are nlsModel and nlsControl objects
 *             doTrace is a logical value.
 *  m is modified; the return value is a "convergence-information" list.
 */
SEXP
nls_iter(SEXP m, SEXP control, SEXP doTraceArg)
{
    double dev, fac, minFac, tolerance, newDev, convNew = -1./*-Wall*/;
    int i, j, maxIter, hasConverged, nPars, doTrace, evaltotCnt = -1, warnOnly, printEval;
    SEXP tmp, conv, incr, deviance, setPars, getPars, pars, newPars, trace;

    doTrace = asLogical(doTraceArg);

    if(!isNewList(control))
	error(_("'control' must be a list"));
    if(!isNewList(m))
	error(_("'m' must be a list"));

    PROTECT(tmp = getAttrib(control, R_NamesSymbol));

    conv = getListElement(control, tmp, "maxiter");
    if(conv == NULL || !isNumeric(conv))
	error(_("'%s' absent"), "control$maxiter");
    maxIter = asInteger(conv);

    conv = getListElement(control, tmp, "tol");
    if(conv == NULL || !isNumeric(conv))
	error(_("'%s' absent"), "control$tol");
    tolerance = asReal(conv);

    conv = getListElement(control, tmp, "minFactor");
    if(conv == NULL || !isNumeric(conv))
	error(_("'%s' absent"), "control$minFactor");
    minFac = asReal(conv);

    conv = getListElement(control, tmp, "warnOnly");
    if(conv == NULL || !isLogical(conv))
	error(_("'%s' absent"), "control$warnOnly");
    warnOnly = asLogical(conv);

    conv = getListElement(control, tmp, "printEval");
    if(conv == NULL || !isLogical(conv))
	error(_("'%s' absent"), "control$printEval");
    printEval = asLogical(conv);

#define CONV_INFO_MSG(_STR_, _I_)					\
	ConvInfoMsg(_STR_, i, _I_, fac, minFac, maxIter, convNew)

#define NON_CONV_FINIS(_ID_, _MSG_)		\
    if(warnOnly) {				\
	warning(_MSG_);				\
	return CONV_INFO_MSG(_MSG_, _ID_);      \
    }						\
    else					\
	error(_MSG_);

#define NON_CONV_FINIS_1(_ID_, _MSG_, _A1_)	\
    if(warnOnly) {				\
	char msgbuf[1000];			\
	warning(_MSG_, _A1_);			\
	snprintf(msgbuf, 1000, _MSG_, _A1_);	\
	return CONV_INFO_MSG(msgbuf, _ID_);	\
    }						\
    else					\
	error(_MSG_, _A1_);

#define NON_CONV_FINIS_2(_ID_, _MSG_, _A1_, _A2_)	\
    if(warnOnly) {					\
	char msgbuf[1000];				\
	warning(_MSG_, _A1_, _A2_);			\
	snprintf(msgbuf, 1000, _MSG_, _A1_, _A2_);	\
	return CONV_INFO_MSG(msgbuf, _ID_);		\
    }							\
    else						\
	error(_MSG_, _A1_, _A2_);



    /* now get parts from 'm' */
    tmp = getAttrib(m, R_NamesSymbol);

    conv = getListElement(m, tmp, "conv");
    if(conv == NULL || !isFunction(conv))
	error(_("'%s' absent"), "m$conv()");
    PROTECT(conv = lang1(conv));

    incr = getListElement(m, tmp, "incr");
    if(incr == NULL || !isFunction(incr))
	error(_("'%s' absent"), "m$incr()");
    PROTECT(incr = lang1(incr));

    deviance = getListElement(m, tmp, "deviance");
    if(deviance == NULL || !isFunction(deviance))
	error(_("'%s' absent"), "m$deviance()");
    PROTECT(deviance = lang1(deviance));

    trace = getListElement(m, tmp, "trace");
    if(trace == NULL || !isFunction(trace))
	error(_("'%s' absent"), "m$trace()");
    PROTECT(trace = lang1(trace));

    setPars = getListElement(m, tmp, "setPars");
    if(setPars == NULL || !isFunction(setPars))
	error(_("'%s' absent"), "m$setPars()");
    PROTECT(setPars);

    getPars = getListElement(m, tmp, "getPars");
    if(getPars == NULL || !isFunction(getPars))
	error(_("'%s' absent"), "m$getPars()");
    PROTECT(getPars = lang1(getPars));

    PROTECT(pars = eval(getPars, R_GlobalEnv));
    nPars = LENGTH(pars);

    dev = asReal(eval(deviance, R_GlobalEnv));
    if(doTrace) eval(trace,R_GlobalEnv);

    fac = 1.0;
    hasConverged = FALSE;

    PROTECT(newPars = allocVector(REALSXP, nPars));
    if(printEval)
	evaltotCnt = 1;
    for (i = 0; i < maxIter; i++) {
	SEXP newIncr;
	int evalCnt = -1;
	if((convNew = asReal(eval(conv, R_GlobalEnv))) < tolerance) {
	    hasConverged = TRUE;
	    break;
	}
	PROTECT(newIncr = eval(incr, R_GlobalEnv));

	if(printEval)
	    evalCnt = 1;

	while(fac >= minFac) {
	    if(printEval) {
		Rprintf("  It. %3d, fac= %11.6g, eval (no.,total): (%2d,%3d):",
			i+1, fac, evalCnt, evaltotCnt);
		evalCnt++;
		evaltotCnt++;
	    }
	    for(j = 0; j < nPars; j++)
		REAL(newPars)[j] = REAL(pars)[j] + fac * REAL(newIncr)[j];

	    PROTECT(tmp = lang2(setPars, newPars));
	    if (asLogical(eval(tmp, R_GlobalEnv))) { /* singular gradient */
		UNPROTECT(11);

		NON_CONV_FINIS(1, _("singular gradient"));
	    }
	    UNPROTECT(1);

	    newDev = asReal(eval(deviance, R_GlobalEnv));
	    if(printEval)
		Rprintf(" new dev = %g\n", newDev);
	    if(newDev <= dev) {
		dev = newDev;
		fac = MIN(2*fac, 1);
		tmp = newPars;
		newPars = pars;
		pars = tmp;
		break;
	    }
	    fac /= 2.;
	}
	UNPROTECT(1);
	if( fac < minFac ) {
	    UNPROTECT(9);
	    NON_CONV_FINIS_2(2,
			     _("step factor %g reduced below 'minFactor' of %g"),
			     fac, minFac);
	}
	if(doTrace) eval(trace, R_GlobalEnv);
    }

    UNPROTECT(9);
    if(!hasConverged) {
	NON_CONV_FINIS_1(3,
			 _("number of iterations exceeded maximum of %d"),
			 maxIter);
    }
    /* else */

    return CONV_INFO_MSG(_("converged"), 0);
}
Beispiel #27
0
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, a copy is available at
 *  http://www.r-project.org/Licenses/
 */

/* Graphical parameters which are treated identically by
 * par( <nam> = <value> )  and	highlevel  plotfun (..., <nam> = <value> ).
 *
 * This is #included both from Specify() and Specify2() into ./par.c
*/
    if (streql(what, "adj")) {
	lengthCheck(what, value, 1);	x = asReal(value);
	BoundsCheck(x, 0.0, 1.0, what);
	R_DEV__(adj) = x;
    }
    else if (streql(what, "ann")) {
	lengthCheck(what, value, 1);	ix = asLogical(value);
	R_DEV__(ann) = (ix != 0);/* NA |-> TRUE */
    }
    else if (streql(what, "bg")) {
	/* in par() this means the plot region, inline it means filled points */
#ifdef FOR_PAR
	lengthCheck(what, value, 1);
#else
	if (!isVector(value) || LENGTH(value) < 1) par_error(what);
#endif
	R_DEV__(bg) = RGBpar3(value, 0, dpptr(dd)->bg);
Beispiel #28
0
SEXP coxfit6(SEXP maxiter2,  SEXP time2,   SEXP status2, 
	     SEXP covar2,    SEXP offset2, SEXP weights2,
	     SEXP strata2,   SEXP method2, SEXP eps2, 
	     SEXP toler2,    SEXP ibeta,    SEXP doscale2) {
    int i,j,k, person;
    
    double **covar, **cmat, **imat;  /*ragged arrays */
    double  wtave;
    double *a, *newbeta;
    double *a2, **cmat2;
    double *scale;
    double  denom=0, zbeta, risk;
    double  temp, temp2;
    int     ndead;  /* actually, the sum of their weights */
    double  newlk=0;
    double  dtime, d2;
    double  deadwt;  /*sum of case weights for the deaths*/
    double  efronwt; /* sum of weighted risk scores for the deaths*/
    int     halving;    /*are we doing step halving at the moment? */
    int     nrisk;   /* number of subjects in the current risk set */
 
    /* copies of scalar input arguments */
    int     nused, nvar, maxiter;
    int     method;
    double  eps, toler;
    int doscale;

    /* vector inputs */
    double *time, *weights, *offset;
    int *status, *strata;
    
    /* returned objects */
    SEXP imat2, means2, beta2, u2, loglik2;
    double *beta, *u, *loglik, *means;
    SEXP sctest2, flag2, iter2;
    double *sctest;
    int *flag, *iter;
    SEXP rlist, rlistnames;
    int nprotect;  /* number of protect calls I have issued */

    /* get local copies of some input args */
    nused = LENGTH(offset2);
    nvar  = ncols(covar2);
    method = asInteger(method2);
    maxiter = asInteger(maxiter2);
    eps  = asReal(eps2);     /* convergence criteria */
    toler = asReal(toler2);  /* tolerance for cholesky */
    doscale = asInteger(doscale2);

    time = REAL(time2);
    weights = REAL(weights2);
    offset= REAL(offset2);
    status = INTEGER(status2);
    strata = INTEGER(strata2);
    
    /*
    **  Set up the ragged arrays and scratch space
    **  Normally covar2 does not need to be duplicated, even though
    **  we are going to modify it, due to the way this routine was
    **  was called.  In this case NAMED(covar2) will =0
    */
    nprotect =0;
    if (NAMED(covar2)>0) {
	PROTECT(covar2 = duplicate(covar2)); 
	nprotect++;
	}
    covar= dmatrix(REAL(covar2), nused, nvar);

    PROTECT(imat2 = allocVector(REALSXP, nvar*nvar)); 
    nprotect++;
    imat = dmatrix(REAL(imat2),  nvar, nvar);
    a = (double *) R_alloc(2*nvar*nvar + 4*nvar, sizeof(double));
    newbeta = a + nvar;
    a2 = newbeta + nvar;
    scale = a2 + nvar;
    cmat = dmatrix(scale + nvar,   nvar, nvar);
    cmat2= dmatrix(scale + nvar +nvar*nvar, nvar, nvar);

    /* 
    ** create output variables
    */ 
    PROTECT(beta2 = duplicate(ibeta));
    beta = REAL(beta2);
    PROTECT(means2 = allocVector(REALSXP, nvar));
    means = REAL(means2);
    PROTECT(u2 = allocVector(REALSXP, nvar));
    u = REAL(u2);
    PROTECT(loglik2 = allocVector(REALSXP, 2)); 
    loglik = REAL(loglik2);
    PROTECT(sctest2 = allocVector(REALSXP, 1));
    sctest = REAL(sctest2);
    PROTECT(flag2 = allocVector(INTSXP, 1));
    flag = INTEGER(flag2);
    PROTECT(iter2 = allocVector(INTSXP, 1));
    iter = INTEGER(iter2);
    nprotect += 7;

    /*
    ** Subtract the mean from each covar, as this makes the regression
    **  much more stable.
    */
    for (i=0; i<nvar; i++) {
	temp=0;
	for (person=0; person<nused; person++) temp += covar[i][person];
	temp /= nused;
	means[i] = temp;
	for (person=0; person<nused; person++) covar[i][person] -=temp;
	if (doscale==1) {  /* and also scale it */
	    temp =0;
	    for (person=0; person<nused; person++) {
		temp += fabs(covar[i][person]);
	    }
	    if (temp > 0) temp = nused/temp;   /* scaling */
	    else temp=1.0; /* rare case of a constant covariate */
	    scale[i] = temp;
	    for (person=0; person<nused; person++)  covar[i][person] *= temp;
	    }
	}
    if (doscale==1) {
	for (i=0; i<nvar; i++) beta[i] /= scale[i]; /*rescale initial betas */
	}
    else {
	for (i=0; i<nvar; i++) scale[i] = 1.0;
	}

    /*
    ** do the initial iteration step
    */
    strata[nused-1] =1;
    loglik[1] =0;
    for (i=0; i<nvar; i++) {
	u[i] =0;
	a2[i] =0;
	for (j=0; j<nvar; j++) {
	    imat[i][j] =0 ;
	    cmat2[i][j] =0;
	    }
	}

    for (person=nused-1; person>=0; ) {
	if (strata[person] == 1) {
	    nrisk =0 ;  
	    denom = 0;
	    for (i=0; i<nvar; i++) {
		a[i] = 0;
		for (j=0; j<nvar; j++) cmat[i][j] = 0;
		}
	    }

	dtime = time[person];
	ndead =0; /*number of deaths at this time point */
	deadwt =0;  /* sum of weights for the deaths */
	efronwt=0;  /* sum of weighted risks for the deaths */
	while(person >=0 &&time[person]==dtime) {
	    /* walk through the this set of tied times */
	    nrisk++;
	    zbeta = offset[person];    /* form the term beta*z (vector mult) */
	    for (i=0; i<nvar; i++)
		zbeta += beta[i]*covar[i][person];
	    zbeta = coxsafe(zbeta);
	    risk = exp(zbeta) * weights[person];
	    denom += risk;

	    /* a is the vector of weighted sums of x, cmat sums of squares */
	    for (i=0; i<nvar; i++) {
		a[i] += risk*covar[i][person];
		for (j=0; j<=i; j++)
		    cmat[i][j] += risk*covar[i][person]*covar[j][person];
	        }

	    if (status[person]==1) {
		ndead++;
		deadwt += weights[person];
		efronwt += risk;
		loglik[1] += weights[person]*zbeta;

		for (i=0; i<nvar; i++) 
		    u[i] += weights[person]*covar[i][person];
		if (method==1) { /* Efron */
		    for (i=0; i<nvar; i++) {
			a2[i] +=  risk*covar[i][person];
			for (j=0; j<=i; j++)
			    cmat2[i][j] += risk*covar[i][person]*covar[j][person];
		        }
		    }
	        }
	    
	    person--;
	    if (strata[person]==1) break;  /*ties don't cross strata */
	    }


	if (ndead >0) {  /* we need to add to the main terms */
	    if (method==0) { /* Breslow */
		loglik[1] -= deadwt* log(denom);
	   
		for (i=0; i<nvar; i++) {
		    temp2= a[i]/ denom;  /* mean */
		    u[i] -=  deadwt* temp2;
		    for (j=0; j<=i; j++)
			imat[j][i] += deadwt*(cmat[i][j] - temp2*a[j])/denom;
		    }
		}
	    else { /* Efron */
		/*
		** If there are 3 deaths we have 3 terms: in the first the
		**  three deaths are all in, in the second they are 2/3
		**  in the sums, and in the last 1/3 in the sum.  Let k go
		**  from 0 to (ndead -1), then we will sequentially use
		**     denom - (k/ndead)*efronwt as the denominator
		**     a - (k/ndead)*a2 as the "a" term
		**     cmat - (k/ndead)*cmat2 as the "cmat" term
		**  and reprise the equations just above.
		*/
		for (k=0; k<ndead; k++) {
		    temp = (double)k/ ndead;
		    wtave = deadwt/ndead;
		    d2 = denom - temp*efronwt;
		    loglik[1] -= wtave* log(d2);
		    for (i=0; i<nvar; i++) {
			temp2 = (a[i] - temp*a2[i])/ d2;
			u[i] -= wtave *temp2;
			for (j=0; j<=i; j++)
			    imat[j][i] +=  (wtave/d2) *
				((cmat[i][j] - temp*cmat2[i][j]) -
					  temp2*(a[j]-temp*a2[j]));
		        }
		    }
		
		for (i=0; i<nvar; i++) {
		    a2[i]=0;
		    for (j=0; j<nvar; j++) cmat2[i][j]=0;
		    }
		}
	    }
	}   /* end  of accumulation loop */
    loglik[0] = loglik[1]; /* save the loglik for iter 0 */

    /* am I done?
    **   update the betas and test for convergence
    */
    for (i=0; i<nvar; i++) /*use 'a' as a temp to save u0, for the score test*/
	a[i] = u[i];

    *flag= cholesky2(imat, nvar, toler);
    chsolve2(imat,nvar,a);        /* a replaced by  a *inverse(i) */

    temp=0;
    for (i=0; i<nvar; i++)
	temp +=  u[i]*a[i];
    *sctest = temp;  /* score test */

    /*
    **  Never, never complain about convergence on the first step.  That way,
    **  if someone HAS to they can force one iter at a time.
    */
    for (i=0; i<nvar; i++) {
	newbeta[i] = beta[i] + a[i];
	}
    if (maxiter==0) {
	chinv2(imat,nvar);
	for (i=0; i<nvar; i++) {
	    beta[i] *= scale[i];  /*return to original scale */
	    u[i] /= scale[i];
	    imat[i][i] *= scale[i]*scale[i];
	    for (j=0; j<i; j++) {
		imat[j][i] *= scale[i]*scale[j];
		imat[i][j] = imat[j][i];
		}
	    }
	goto finish;
    }

    /*
    ** here is the main loop
    */
    halving =0 ;             /* =1 when in the midst of "step halving" */
    for (*iter=1; *iter<= maxiter; (*iter)++) {
	newlk =0;
	for (i=0; i<nvar; i++) {
	    u[i] =0;
	    for (j=0; j<nvar; j++)
		imat[i][j] =0;
	    }

	/*
	** The data is sorted from smallest time to largest
	** Start at the largest time, accumulating the risk set 1 by 1
	*/
	for (person=nused-1; person>=0; ) {
	    if (strata[person] == 1) { /* rezero temps for each strata */
		denom = 0;
		nrisk =0;
		for (i=0; i<nvar; i++) {
		    a[i] = 0;
		    for (j=0; j<nvar; j++) cmat[i][j] = 0;
		    }
		}

	    dtime = time[person];
	    deadwt =0;
	    ndead =0;
	    efronwt =0;
	    while(person>=0 && time[person]==dtime) {
		nrisk++;
		zbeta = offset[person];
		for (i=0; i<nvar; i++)
		    zbeta += newbeta[i]*covar[i][person];
		zbeta = coxsafe(zbeta);
		risk = exp(zbeta) * weights[person];
		denom += risk;

		for (i=0; i<nvar; i++) {
		    a[i] += risk*covar[i][person];
		    for (j=0; j<=i; j++)
		    cmat[i][j] += risk*covar[i][person]*covar[j][person];
		    }

		if (status[person]==1) {
		    ndead++;
		    deadwt += weights[person];
		    newlk += weights[person] *zbeta;
		    for (i=0; i<nvar; i++) 
			u[i] += weights[person] *covar[i][person];
		    if (method==1) { /* Efron */
			efronwt += risk;
			for (i=0; i<nvar; i++) {
			    a2[i] +=  risk*covar[i][person];
			    for (j=0; j<=i; j++)
				cmat2[i][j] += risk*covar[i][person]*covar[j][person];
			    }   
		        }
	  	    }
		
		person--;
		if (strata[person]==1) break; /*tied times don't cross strata*/
	        }

	    if (ndead >0) {  /* add up terms*/
		if (method==0) { /* Breslow */
		    newlk -= deadwt* log(denom);
		    for (i=0; i<nvar; i++) {
			temp2= a[i]/ denom;  /* mean */
			u[i] -= deadwt* temp2;
			for (j=0; j<=i; j++)
			    imat[j][i] +=  (deadwt/denom)*
				(cmat[i][j] - temp2*a[j]);
		        }
    		    }
		else  { /* Efron */
		    for (k=0; k<ndead; k++) {
			temp = (double)k / ndead;
			wtave= deadwt/ ndead;
			d2= denom - temp* efronwt;
			newlk -= wtave* log(d2);
			for (i=0; i<nvar; i++) {
			    temp2 = (a[i] - temp*a2[i])/ d2;
			    u[i] -= wtave*temp2;
			    for (j=0; j<=i; j++)
				imat[j][i] +=  (wtave/d2)*
				    ((cmat[i][j] - temp*cmat2[i][j]) -
				    temp2*(a[j]-temp*a2[j]));
    		            }
    		        }

		    for (i=0; i<nvar; i++) { /*in anticipation */
			a2[i] =0;
			for (j=0; j<nvar; j++) cmat2[i][j] =0;
		        }
	            }
		}
	    }   /* end  of accumulation loop  */

	/* am I done?
	**   update the betas and test for convergence
	*/
	*flag = cholesky2(imat, nvar, toler);

	if (fabs(1-(loglik[1]/newlk))<= eps && halving==0) { /* all done */
	    loglik[1] = newlk;
	    chinv2(imat, nvar);     /* invert the information matrix */
	    for (i=0; i<nvar; i++) {
		beta[i] = newbeta[i]*scale[i];
		u[i] /= scale[i];
		imat[i][i] *= scale[i]*scale[i];
		for (j=0; j<i; j++) {
		    imat[j][i] *= scale[i]*scale[j];
		    imat[i][j] = imat[j][i];
		    }
	    }
	    goto finish;
	}

	if (*iter== maxiter) break;  /*skip the step halving calc*/

	if (newlk < loglik[1])   {    /*it is not converging ! */
		halving =1;
		for (i=0; i<nvar; i++)
		    newbeta[i] = (newbeta[i] + beta[i]) /2; /*half of old increment */
		}
	else {
	    halving=0;
	    loglik[1] = newlk;
	    chsolve2(imat,nvar,u);
	    j=0;
	    for (i=0; i<nvar; i++) {
		beta[i] = newbeta[i];
		newbeta[i] = newbeta[i] +  u[i];
	        }
	    }
	}   /* return for another iteration */

    /*
    ** We end up here only if we ran out of iterations 
    */
    loglik[1] = newlk;
    chinv2(imat, nvar);
    for (i=0; i<nvar; i++) {
	beta[i] = newbeta[i]*scale[i];
	u[i] /= scale[i];
	imat[i][i] *= scale[i]*scale[i];
	for (j=0; j<i; j++) {
	    imat[j][i] *= scale[i]*scale[j];
	    imat[i][j] = imat[j][i];
	    }
	}
    *flag = 1000;


finish:
    /*
    ** create the output list
    */
    PROTECT(rlist= allocVector(VECSXP, 8));
    SET_VECTOR_ELT(rlist, 0, beta2);
    SET_VECTOR_ELT(rlist, 1, means2);
    SET_VECTOR_ELT(rlist, 2, u2);
    SET_VECTOR_ELT(rlist, 3, imat2);
    SET_VECTOR_ELT(rlist, 4, loglik2);
    SET_VECTOR_ELT(rlist, 5, sctest2);
    SET_VECTOR_ELT(rlist, 6, iter2);
    SET_VECTOR_ELT(rlist, 7, flag2);
    

    /* add names to the objects */
    PROTECT(rlistnames = allocVector(STRSXP, 8));
    SET_STRING_ELT(rlistnames, 0, mkChar("coef"));
    SET_STRING_ELT(rlistnames, 1, mkChar("means"));
    SET_STRING_ELT(rlistnames, 2, mkChar("u"));
    SET_STRING_ELT(rlistnames, 3, mkChar("imat"));
    SET_STRING_ELT(rlistnames, 4, mkChar("loglik"));
    SET_STRING_ELT(rlistnames, 5, mkChar("sctest"));
    SET_STRING_ELT(rlistnames, 6, mkChar("iter"));
    SET_STRING_ELT(rlistnames, 7, mkChar("flag"));
    setAttrib(rlist, R_NamesSymbol, rlistnames);

    unprotect(nprotect+2);
    return(rlist);
    }
Beispiel #29
0
SEXP swfDevice ( SEXP args ){

	/*
	 * Make sure the version number of the R running this
	 * routine is compatible with the version number of 
	 * the R that compiled this routine.
	*/
	R_GE_checkVersionOrDie(R_GE_version);

	/* Declare local variabls for holding the components of the args SEXP */
	const char *fileName;
	const char *bg, *fg;
	double width, height, frameRate;
	SEXP fontFileList;
	const char *logFileName;

	/* 
	 * pGEDevDesc is a variable provided by the R Graphics Engine
	 * that contains all device information required by the parent
	 * R system. It contains one important componant of type pDevDesc
	 * which containts information specific to the implementation of
	 * the swf device. The creation and initialization of this component
	 * is one of the main tasks of this routine.
  */
	pGEDevDesc swfDev;


	/* Retrieve function arguments from input SEXP. */

	/*
	 * Skip first argument. It holds the name of the R function
	 * that called this C routine.
  */ 
	args = CDR(args);

	/* Recover file name. */
	fileName = translateChar(asChar(CAR(args)));
	/* Advance to next argument stored in SEXPR. */
	args = CDR(args);

	/* Recover figure dimensions. */
	/* For now these are assumed to be in inches. */
	width = asReal(CAR(args)); args = CDR(args);
	height = asReal(CAR(args)); args = CDR(args);
    
	/* Recover initial background and foreground colors. */
	bg = CHAR(asChar(CAR(args))); args = CDR(args);
	fg = CHAR(asChar(CAR(args))); args = CDR(args);
	frameRate = asReal(asChar(CAR(args))); args = CDR(args);
	fontFileList = CAR(args); args = CDR(args);
	logFileName = CHAR(asChar(CAR(args))); args = CDR(args);
	

	/* Ensure there is an empty slot avaliable for a new device. */
	R_CheckDeviceAvailable();

	BEGIN_SUSPEND_INTERRUPTS{

		/* 
		 * The pDevDesc variable specifies which funtions and components 
		 * which describe the specifics of this graphics device. After
		 * setup, this information will be incorporated into the pGEDevDesc
		 * variable swfDev.
		*/ 
		pDevDesc deviceInfo;

		/* 
		 * Create the deviceInfo variable. If this operation fails, 
		 * a 0 is returned in order to cause R to shut down due to the
		 * possibility of corrupted memory.
		*/
		if( !( deviceInfo = (pDevDesc) calloc(1, sizeof(DevDesc))) )
			return 0;

		/*
		 * Call setup routine to initialize deviceInfo and associate
		 * R graphics function hooks with the appropriate C routines
		 * in this file.
		*/
		if( !SWF_Setup( deviceInfo, fileName, width, height, bg, fg, 
			frameRate, fontFileList, logFileName ) ){
			/* 
			 * If setup was unsuccessful, destroy the device and return
			 * an error message.
			*/
			free( deviceInfo );
			error("SWF device setup was unsuccessful!");
		}

		/* Create swfDev as a Graphics Engine device using deviceInfo. */
		swfDev = GEcreateDevDesc( deviceInfo );

		// Register the device as an avaiable graphics device in the R
		// Session.
		GEaddDevice2( swfDev, "swf output" );

	} END_SUSPEND_INTERRUPTS;


	return R_NilValue;

}
Beispiel #30
0
SEXP fitabn_marginals(SEXP R_obsdata, SEXP R_dag,SEXP R_numVars, SEXP R_vartype, SEXP R_maxparents,SEXP R_priors_mean, SEXP R_priors_sd,SEXP R_priors_gamshape,SEXP R_priors_gamscale,
		      SEXP R_maxiters, SEXP R_epsabs, SEXP R_verbose, SEXP R_errorverbose, SEXP R_groupedvars, SEXP R_groupids, SEXP R_epsabs_inner,SEXP R_maxiters_inner,
	              SEXP R_finitestepsize, SEXP R_hparams,
		      SEXP R_childid, SEXP R_paramid, SEXP R_denom_modes, SEXP R_betafixed, SEXP R_mlik, SEXP R_maxiters_hessian,
		      SEXP R_max_hessian_error,SEXP R_myfactor_brent, SEXP R_maxiters_hessian_brent, SEXP R_num_intervals_brent)
{
/** ****************/
/** declarations **/

int errverbose,verbose;
datamatrix data,designmatrix;
const double priormean=asReal(R_priors_mean);/*Rprintf("priormean=%f %f\n",priormean[0],priormean[5]);*/
const double priorsd=asReal(R_priors_sd);/*Rprintf("priorsd=%f %f\n",priorsd[0],priorsd[5]);*/
const double priorgamshape=asReal(R_priors_gamshape);  /*Rprintf("priorgamshape=%f %f\n",priorgamshape[0],priorgamshape[1]);*/
const double priorgamscale=asReal(R_priors_gamscale);  /*Rprintf("priorgamscale=%f %f\n",priorgamscale[0],priorgamscale[1]);*/
/*const int *vartype=INTEGER(R_vartype);*/
/*const int numvariates=asInteger(R_numvariates);*/
int numVars=asInteger(R_numVars);
double max_hessian_error=asReal(R_max_hessian_error);
double myfactor_brent=asReal(R_myfactor_brent);
int maxiters_hessian_brent=asInteger(R_maxiters_hessian_brent);
double num_intervals_brent=asReal(R_num_intervals_brent);
/*Rprintf("vartype: ");for(i=0;i<LENGTH(R_vartype);i++){Rprintf("%u ",vartype[i]);} Rprintf("\n");*/
network dag;
/*cycle cyclestore;*/
/*storage nodescore;*/
SEXP posterior;
double *denom_modes=REAL(R_denom_modes);
int childid=asInteger(R_childid);
int paramid=asInteger(R_paramid);

/** end of declarations*/
/** *******************/
/** ********************************************/
/** parse function arguments - R data structs **/
/** get the data we require from the passed arguments e.g. how many variables/nodes to we have **/
const int maxiters=asInteger(R_maxiters);
const double epsabs=asReal(R_epsabs);
int maxiters_inner=asInteger(R_maxiters_inner);
int maxiters_hessian=asInteger(R_maxiters_hessian);
double epsabs_inner=asReal(R_epsabs_inner);
const int maxparents=asInteger(R_maxparents);
double finitestepsize=asReal(R_finitestepsize);
/*double h_lowerend=REAL(R_hparams)[0];
double h_upperend=REAL(R_hparams)[1];*/
double h_guess=REAL(R_hparams)[0];
double h_epsabs=REAL(R_hparams)[1];
double betafixed=asReal(R_betafixed);
double mlik=asReal(R_mlik);
verbose=asInteger(R_verbose);
errverbose=asInteger(R_errorverbose);
/** end of argument parsing **/

/** *******************************************************************************
***********************************************************************************
STEP 0. - create R storage for sending results back                                */
/** generic code to create a list comprising of vectors of type double 
   - currently overkill but useful template **/
#ifdef JUNK
PROTECT(listresults = allocVector(VECSXP, 2));
for(i=0;i<2;i++){
				PROTECT(tmplistentry=NEW_NUMERIC(numvariates));
				SET_VECTOR_ELT(listresults, i, tmplistentry);
                                UNPROTECT(1);
				}
#endif	

							
/** *******************************************************************************
***********************************************************************************
 STEP 1. convert data.frame in R into C data structure for us with BGM functions */



make_dag(&dag, numVars,R_dag,0,R_vartype,&maxparents,R_groupedvars);/** user supplied DAG **/
  /*printDAG(&dag,2);*/
make_data(R_obsdata,&data,R_groupids);
#ifdef JUNK
/** An R MATRIX it is single dimension and just needs to be unrolled */
posterior=gsl_matrix_alloc(numvariates,2);
for(j=0;j<2;j++){for(i=0;i<numvariates;i++){gsl_matrix_set(posterior,i,j,REAL(R_posterior)[i+j*numvariates]);}} 
#endif
/*gsl_set_error_handler_off();*//*Rprintf("Warning: turning off GSL Error handler\n"); */

/*calc_network_Score(&dag,&data,&designmatrix,
		   priormean,priorsd,priorgamshape,priorgamscale,
		   maxiters,epsabs,verbose,errverbose,listresults,1,epsabs_inner,maxiters_inner,finitestepsize,
		   h_lowerend, h_upperend, h_guess, h_epsabs);*/
	  
PROTECT(posterior=NEW_NUMERIC(1));				
calc_parameter_marginal(&dag,&data,&designmatrix,
		   priormean,priorsd,priorgamshape,priorgamscale,
		   maxiters,epsabs,verbose,errverbose, 
		   denom_modes,childid,paramid,
			/*pdfminval, pdfstepsize,*/
			epsabs_inner,maxiters_inner,finitestepsize, h_guess, h_epsabs,maxiters_hessian,betafixed, mlik,REAL(posterior),
			max_hessian_error,myfactor_brent, maxiters_hessian_brent,num_intervals_brent);

/*gsl_set_error_handler (NULL);*//*Rprintf("Restoring: GSL Error handler\n");*/ /** restore the error handler*/

/** set up memory storage for any network which has each node with <=maxparents **/

/** Roll back into an R MATRIX */
/*for(j=0;j<2;j++){for(i=0;i<numvariates;i++){REAL(VECTOR_ELT(listresults,j))[i]=gsl_matrix_get(posterior,i,j);}} */

#ifdef JUNK
gsl_matrix_free(posterior);

UNPROTECT(1);

return(listresults);
#endif

 
UNPROTECT(1);
/*Rprintf("posterior=%f\n",REAL(posterior)[0]);*/
return(posterior);

}