SEXP call_rkAuto(SEXP Xstart, SEXP Times, SEXP Func, SEXP Initfunc, SEXP Parms, SEXP eventfunc, SEXP elist, SEXP Nout, SEXP Rho, SEXP Rtol, SEXP Atol, SEXP Tcrit, SEXP Verbose, SEXP Hmin, SEXP Hmax, SEXP Hini, SEXP Rpar, SEXP Ipar, SEXP Method, SEXP Maxsteps, SEXP Flist) { /** Initialization **/ long int old_N_Protect = save_N_Protected(); double *tt = NULL, *xs = NULL; double *y, *f, *Fj, *tmp, *FF, *rr; SEXP R_yout; double *y0, *y1, *y2, *dy1, *dy2, *out, *yout; double errold = 0.0, t, dt, tmax; SEXP R_FSAL, Alpha, Beta; int fsal = FALSE; /* assume no FSAL */ /* Use polynomial interpolation if not disabled by the method or when events come in to play (stop-and-go mode). Methods with dense output interpolate by default, all others do not. */ int interpolate = TRUE; int i = 0, j = 0, it = 0, it_tot = 0, it_ext = 0, nt = 0, neq = 0, it_rej = 0; int isForcing, isEvent; /*------------------------------------------------------------------------*/ /* Processing of Arguments */ /*------------------------------------------------------------------------*/ int lAtol = LENGTH(Atol); double *atol = (double*) R_alloc((int) lAtol, sizeof(double)); int lRtol = LENGTH(Rtol); double *rtol = (double*) R_alloc((int) lRtol, sizeof(double)); for (j = 0; j < lRtol; j++) rtol[j] = REAL(Rtol)[j]; for (j = 0; j < lAtol; j++) atol[j] = REAL(Atol)[j]; double tcrit = REAL(Tcrit)[0]; double hmin = REAL(Hmin)[0]; double hmax = REAL(Hmax)[0]; double hini = REAL(Hini)[0]; int maxsteps = INTEGER(Maxsteps)[0]; int nout = INTEGER(Nout)[0]; /* number of global outputs is func is in a DLL */ int verbose = INTEGER(Verbose)[0]; int stage = (int)REAL(getListElement(Method, "stage"))[0]; SEXP R_A, R_B1, R_B2, R_C, R_D, R_densetype; double *A, *bb1, *bb2 = NULL, *cc = NULL, *dd = NULL; PROTECT(R_A = getListElement(Method, "A")); incr_N_Protect(); A = REAL(R_A); PROTECT(R_B1 = getListElement(Method, "b1")); incr_N_Protect(); bb1 = REAL(R_B1); PROTECT(R_B2 = getListElement(Method, "b2")); incr_N_Protect(); if (length(R_B2)) bb2 = REAL(R_B2); PROTECT(R_C = getListElement(Method, "c")); incr_N_Protect(); if (length(R_C)) cc = REAL(R_C); PROTECT(R_D = getListElement(Method, "d")); incr_N_Protect(); if (length(R_D)) dd = REAL(R_D); /* dense output Cash-Karp: densetype = 2 */ int densetype = 0; PROTECT(R_densetype = getListElement(Method, "densetype")); incr_N_Protect(); if (length(R_densetype)) densetype = INTEGER(R_densetype)[0]; double qerr = REAL(getListElement(Method, "Qerr"))[0]; double beta = 0; /* 0.4/qerr; */ PROTECT(Beta = getListElement(Method, "beta")); incr_N_Protect(); if (length(Beta)) beta = REAL(Beta)[0]; double alpha = 1/qerr - 0.75 * beta; PROTECT(Alpha = getListElement(Method, "alpha")); incr_N_Protect(); if (length(Alpha)) alpha = REAL(Alpha)[0]; PROTECT(R_FSAL = getListElement(Method, "FSAL")); incr_N_Protect(); if (length(R_FSAL)) fsal = INTEGER(R_FSAL)[0]; PROTECT(Times = AS_NUMERIC(Times)); incr_N_Protect(); tt = NUMERIC_POINTER(Times); nt = length(Times); PROTECT(Xstart = AS_NUMERIC(Xstart)); incr_N_Protect(); xs = NUMERIC_POINTER(Xstart); neq = length(Xstart); /*------------------------------------------------------------------------*/ /* timesteps (for advection computation in ReacTran) */ /*------------------------------------------------------------------------*/ for (i = 0; i < 2; i++) timesteps[i] = 0; /*------------------------------------------------------------------------*/ /* DLL, ipar, rpar (for compatibility with lsoda) */ /*------------------------------------------------------------------------*/ int isDll = FALSE; int lrpar= 0, lipar = 0; int *ipar = NULL; /* code adapted from lsoda to improve compatibility */ if (inherits(Func, "NativeSymbol")) { /* function is a dll */ isDll = TRUE; if (nout > 0) isOut = TRUE; //ntot = neq + nout; /* length of yout */ lrpar = nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else { /* function is not a dll */ isDll = FALSE; isOut = FALSE; //ntot = neq; lipar = 3; /* in lsoda = 1 */ lrpar = nout; /* in lsoda = 1 */ } out = (double*) R_alloc(lrpar, sizeof(double)); ipar = (int *) R_alloc(lipar, sizeof(int)); /* first 3 elements of ipar are special */ ipar[0] = nout; ipar[1] = lrpar; ipar[2] = lipar; if (isDll == 1) { /* other elements of ipar are set in R-function lsodx via argument "ipar" */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* out: first nout elements of out are reserved for output variables other elements are set via argument "rpar" */ for (j = 0; j < nout; j++) out[j] = 0.0; for (j = 0; j < LENGTH(Rpar); j++) out[nout+j] = REAL(Rpar)[j]; } /*------------------------------------------------------------------------*/ /* Allocation of Workspace */ /*------------------------------------------------------------------------*/ y0 = (double*) R_alloc(neq, sizeof(double)); y1 = (double*) R_alloc(neq, sizeof(double)); y2 = (double*) R_alloc(neq, sizeof(double)); dy1 = (double*) R_alloc(neq, sizeof(double)); dy2 = (double*) R_alloc(neq, sizeof(double)); f = (double*) R_alloc(neq, sizeof(double)); y = (double*) R_alloc(neq, sizeof(double)); Fj = (double*) R_alloc(neq, sizeof(double)); tmp = (double*) R_alloc(neq, sizeof(double)); FF = (double*) R_alloc(neq * stage, sizeof(double)); rr = (double*) R_alloc(neq * 5, sizeof(double)); /* matrix for polynomial interpolation */ SEXP R_nknots; int nknots = 6; /* 6 = 5th order polynomials by default*/ int iknots = 0; /* counter for knots buffer */ double *yknots; PROTECT(R_nknots = getListElement(Method, "nknots")); incr_N_Protect(); if (length(R_nknots)) nknots = INTEGER(R_nknots)[0] + 1; if (nknots < 2) {nknots = 1; interpolate = FALSE;} if (densetype > 0) interpolate = TRUE; yknots = (double*) R_alloc((neq + 1) * (nknots + 1), sizeof(double)); /* matrix for holding states and global outputs */ PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); incr_N_Protect(); yout = REAL(R_yout); /* initialize outputs with NA first */ for (i = 0; i < nt * (neq + nout + 1); i++) yout[i] = NA_REAL; /* attribute that stores state information, similar to lsoda */ SEXP R_istate; int *istate; PROTECT(R_istate = allocVector(INTSXP, 22)); incr_N_Protect(); istate = INTEGER(R_istate); istate[0] = 0; /* assume succesful return */ for (i = 0; i < 22; i++) istate[i] = 0; /*------------------------------------------------------------------------*/ /* Initialization of Parameters (for DLL functions) */ /*------------------------------------------------------------------------*/ PROTECT(Y = allocVector(REALSXP,(neq))); incr_N_Protect(); initParms(Initfunc, Parms); isForcing = initForcings(Flist); isEvent = initEvents(elist, eventfunc, 0); if (isEvent) interpolate = FALSE; /*------------------------------------------------------------------------*/ /* Initialization of Integration Loop */ /*------------------------------------------------------------------------*/ yout[0] = tt[0]; /* initial time */ yknots[0] = tt[0]; /* for polynomial interpolation */ for (i = 0; i < neq; i++) { y0[i] = xs[i]; /* initial values */ yout[(i + 1) * nt] = y0[i]; /* output array */ yknots[iknots + nknots * (i + 1)] = xs[i]; /* for polynomials */ } iknots++; t = tt[0]; tmax = fmax(tt[nt - 1], tcrit); dt = fmin(hmax, hini); hmax = fmin(hmax, tmax - t); /* Initialize work arrays (to be on the safe side, remove this later) */ for (i = 0; i < neq; i++) { y1[i] = 0; y2[i] = 0; Fj[i] = 0; for (j= 0; j < stage; j++) { FF[i + j * neq] = 0; } } /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ it = 1; /* step counter; zero element is initial state */ it_ext = 0; /* counter for external time step (dense output) */ it_tot = 0; /* total number of time steps */ it_rej = 0; if (interpolate) { /* integrate over the whole time step and interpolate internally */ rk_auto( fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, densetype, maxsteps, nt, &iknots, &it, &it_ext, &it_tot, &it_rej, istate, ipar, t, tmax, hmin, hmax, alpha, beta, &dt, &errold, tt, y0, y1, y2, dy1, dy2, f, y, Fj, tmp, FF, rr, A, out, bb1, bb2, cc, dd, atol, rtol, yknots, yout, Func, Parms, Rho ); } else { /* integrate separately between external time steps; do not interpolate */ for (int j = 0; j < nt - 1; j++) { t = tt[j]; tmax = fmin(tt[j + 1], tcrit); dt = tmax - t; if (isEvent) { updateevent(&t, y0, istate); } if (verbose) Rprintf("\n %d th time interval = %g ... %g", j, t, tmax); rk_auto( fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, densetype, maxsteps, nt, &iknots, &it, &it_ext, &it_tot, &it_rej, istate, ipar, t, tmax, hmin, hmax, alpha, beta, &dt, &errold, tt, y0, y1, y2, dy1, dy2, f, y, Fj, tmp, FF, rr, A, out, bb1, bb2, cc, dd, atol, rtol, yknots, yout, Func, Parms, Rho ); /* in this mode, internal interpolation is skipped, so we can simply store the results at the end of each call */ yout[j + 1] = tmax; for (i = 0; i < neq; i++) yout[j + 1 + nt * (1 + i)] = y2[i]; } } /*====================================================================*/ /* call derivs again to get global outputs */ /* j = -1 suppresses unnecessary internal copying */ /*====================================================================*/ if (nout > 0) { for (int j = 0; j < nt; j++) { t = yout[j]; for (i = 0; i < neq; i++) tmp[i] = yout[j + nt * (1 + i)]; derivs(Func, t, tmp, Parms, Rho, FF, out, -1, neq, ipar, isDll, isForcing); for (i = 0; i < nout; i++) { yout[j + nt * (1 + neq + i)] = out[i]; } } } /* attach diagnostic information (codes are compatible to lsoda) */ setIstate(R_yout, R_istate, istate, it_tot, stage, fsal, qerr, it_rej); if (densetype == 2) istate[12] = it_tot * stage + 2; /* number of function evaluations */ /* verbose printing in debugging mode*/ if (verbose) Rprintf("\nNumber of time steps it = %d, it_ext = %d, it_tot = %d it_rej %d\n", it, it_ext, it_tot, it_rej); /* release R resources */ timesteps[0] = 0; timesteps[1] = 0; restore_N_Protected(old_N_Protect); return(R_yout); }
/* Susceptible-Infectious-Removed MCMC analysis: . Exponentially distributed infectiousness periods */ SEXP expMH_SIR(SEXP N, SEXP removalTimes, SEXP otherParameters, SEXP priorValues, SEXP initialValues, SEXP bayesReps, SEXP bayesStart, SEXP bayesThin, SEXP bayesOut){ /* Declarations */ int ii, jj, kk, ll, nInfected, nRemoved, nProtected=0, initialInfected; SEXP infRateSIR, remRateSIR, logLikelihood;/*, timeInfected, timeDim, initialInf ; */ SEXP parameters, infectionTimes, candidateTimes, infectedBeforeDay; SEXP allTimes, indicator, SS, II; double infRate, remRate, oldLkhood, newLkhood, minimumLikelyInfectionTime; /* starting values */ double infRatePrior[2], remRatePrior[2], thetaprior; /* priors values */ double sumSI, sumDurationInfectious, likelihood,logR; int acceptRate=0, consistent=0, verbose, missingInfectionTimes; SEXP retParameters, parNames, acceptanceRate; SEXP infTimes; /* Code */ GetRNGstate(); /* should be before a call to a random number generator */ initialInfected = INTEGER(getListElement(otherParameters, "initialInfected"))[0]; verbose = INTEGER(getListElement(otherParameters, "verbose"))[0]; missingInfectionTimes = INTEGER(getListElement(otherParameters, "missingInfectionTimes"))[0]; PROTECT(N = AS_INTEGER(N)); ++nProtected; PROTECT(removalTimes = AS_NUMERIC(removalTimes)); ++nProtected; /* priors and starting values */ PROTECT(priorValues = AS_LIST(priorValues)); ++nProtected; PROTECT(initialValues = AS_LIST(initialValues)); ++nProtected; nRemoved = LENGTH(removalTimes); /* number of individuals removed */ /* bayes replications, thin, etc */ PROTECT(bayesReps = AS_INTEGER(bayesReps)); ++nProtected; PROTECT(bayesStart = AS_INTEGER(bayesStart)); ++nProtected; PROTECT(bayesThin = AS_INTEGER(bayesThin)); ++nProtected; PROTECT(bayesOut = AS_INTEGER(bayesOut)); ++nProtected; PROTECT(infRateSIR = allocVector(REALSXP, INTEGER(bayesOut)[0])); ++nProtected; PROTECT(remRateSIR = allocVector(REALSXP, INTEGER(bayesOut)[0])); ++nProtected; PROTECT(logLikelihood = allocVector(REALSXP, INTEGER(bayesOut)[0])); ++nProtected; /* PROTECT(timeInfected = allocVector(REALSXP, nRemoved * INTEGER(bayesOut)[0])); ++nProtected; PROTECT(timeDim = allocVector(INTSXP, 2)); ++nProtected; INTEGER(timeDim)[0] = nRemoved; INTEGER(timeDim)[1] = INTEGER(bayesOut)[0]; setAttrib(timeInfected, R_DimSymbol, timeDim); PROTECT(initialInf = allocVector(REALSXP, INTEGER(bayesOut)[0])); ++nProtected; */ PROTECT(parameters = allocVector(REALSXP,2)); ++nProtected; PROTECT(infectionTimes = allocVector(REALSXP,nRemoved)); ++nProtected; PROTECT(candidateTimes = allocVector(REALSXP,nRemoved)); ++nProtected; PROTECT(infectedBeforeDay = allocVector(REALSXP,nRemoved)); ++nProtected; PROTECT(infTimes = allocVector(REALSXP,nRemoved)); ++nProtected; for(jj = 0; jj < nRemoved; ++jj){ REAL(infectionTimes)[jj] = REAL(getListElement(initialValues, "infectionTimes"))[jj]; REAL(candidateTimes)[jj] = REAL(infectionTimes)[jj]; REAL(infectedBeforeDay)[jj] = REAL(getListElement(otherParameters, "infectedBeforeDay"))[jj]; REAL(infTimes)[jj] = 0; } nInfected = LENGTH(infectionTimes); PROTECT(allTimes = allocVector(REALSXP,nRemoved+nInfected)); ++nProtected; PROTECT(indicator = allocVector(INTSXP,nRemoved+nInfected)); ++nProtected; PROTECT(SS = allocVector(INTSXP,nRemoved+nInfected+1)); ++nProtected; PROTECT(II = allocVector(INTSXP,nRemoved+nInfected+1)); ++nProtected; /* working variables */ infRate = REAL(getListElement(initialValues, "infectionRate"))[0]; remRate = REAL(getListElement(initialValues, "removalRate"))[0]; minimumLikelyInfectionTime = REAL(getListElement(otherParameters, "minimumLikelyInfectionTime"))[0]; for(ii = 0; ii < 2; ++ii){ infRatePrior[ii] = REAL(getListElement(priorValues, "infectionRate"))[ii]; remRatePrior[ii] = REAL(getListElement(priorValues, "removalRate"))[ii]; } thetaprior = REAL(getListElement(priorValues, "theta"))[0]; REAL(parameters)[0] = infRate; REAL(parameters)[1] = remRate; expLikelihood_SIR(REAL(parameters),REAL(infectionTimes), REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved, &sumSI, &sumDurationInfectious, &likelihood, REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II)); oldLkhood = likelihood; for(ii = 1; ii <= INTEGER(bayesReps)[0]; ++ii){ infRate = rgamma(nInfected-1+infRatePrior[0],1/(sumSI+infRatePrior[1])); /* update infRate */ remRate = rgamma(nRemoved+remRatePrior[0],1/(sumDurationInfectious+remRatePrior[1]));/*remRate */ /*Rprintf("SI = %f : I = %f\n",sumSI,sumDurationInfectious);*/ REAL(parameters)[0] = infRate; REAL(parameters)[1] = remRate; if(missingInfectionTimes){ expLikelihood_SIR(REAL(parameters),REAL(infectionTimes), REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved, &sumSI, &sumDurationInfectious, &likelihood, REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II)); oldLkhood = likelihood; kk = ceil(unif_rand()*(nRemoved-1)); /* initial infection time excluded */ consistent=0; if(kk == nRemoved-1){ REAL(candidateTimes)[kk] = runif(REAL(infectionTimes)[kk-1], REAL(infectedBeforeDay)[kk]);} else if((REAL(infectionTimes)[kk+1] > REAL(infectedBeforeDay)[kk])){ REAL(candidateTimes)[kk] = runif(REAL(infectionTimes)[kk-1], REAL(infectedBeforeDay)[kk]);} else{REAL(candidateTimes)[kk] = runif(REAL(infectionTimes)[kk-1], REAL(infectionTimes)[kk+1]);} expLikelihood_SIR(REAL(parameters),REAL(candidateTimes), REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved, &sumSI, &sumDurationInfectious, &likelihood, REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II)); newLkhood = likelihood; logR = (newLkhood-oldLkhood); if(log(unif_rand()) <= logR){ REAL(infectionTimes)[kk] = REAL(candidateTimes)[kk]; ++acceptRate; } REAL(candidateTimes)[kk] = REAL(infectionTimes)[kk];/* update candidate times */ REAL(infectionTimes)[0] = REAL(infectionTimes)[1] -rexp(1/(infRate*INTEGER(N)[0]+remRate+thetaprior)); REAL(candidateTimes)[0] = REAL(infectionTimes)[0]; } expLikelihood_SIR(REAL(parameters),REAL(infectionTimes), REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved, &sumSI, &sumDurationInfectious, &likelihood, REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II)); oldLkhood = likelihood; kk = ceil(INTEGER(bayesReps)[0]/100); ll = ceil(INTEGER(bayesReps)[0]/ 10); if(verbose == 1){ if((ii % kk) == 0){Rprintf(".");} if((ii % ll) == 0){Rprintf(" %d\n",ii);} } if((ii >= (INTEGER(bayesStart)[0])) && ((ii-INTEGER(bayesStart)[0]) % INTEGER(bayesThin)[0] == 0)){ ll = (ii - (INTEGER(bayesStart)[0]))/INTEGER(bayesThin)[0]; /* REAL(initialInf)[ll] = REAL(infectionTimes)[0]; */ REAL(logLikelihood)[ll] = likelihood; REAL(infRateSIR)[ll] = infRate; REAL(remRateSIR)[ll] = remRate; for(jj = 0; jj < nRemoved; ++jj){ REAL(infTimes)[jj] += REAL(infectionTimes)[jj]; } /* for(jj = 0; jj < nRemoved; ++jj){ REAL(timeInfected)[(nRemoved*ll+jj)] = REAL(infectionTimes)[jj]; } */ } } PutRNGstate(); /* after using random number generators. */ /* Print infection times and removal times at last iteration */ for(jj = 0; jj < nRemoved; ++jj){ REAL(infTimes)[jj] = REAL(infTimes)[jj]/INTEGER(bayesOut)[0]; } if(verbose){ for(jj = 0; jj < nRemoved; ++jj){ Rprintf("%2d %8.4f %2.0f\n",jj, REAL(infTimes)[jj],REAL(removalTimes)[jj]); } } PROTECT(retParameters = NEW_LIST(5)); ++nProtected; PROTECT(acceptanceRate = allocVector(INTSXP,1)); ++nProtected; INTEGER(acceptanceRate)[0] = acceptRate; PROTECT(parNames = allocVector(STRSXP,5)); ++nProtected; SET_STRING_ELT(parNames, 0, mkChar("logLikelihood")); SET_STRING_ELT(parNames, 1, mkChar("infRateSIR")); SET_STRING_ELT(parNames, 2, mkChar("remRateSIR")); SET_STRING_ELT(parNames, 3, mkChar("infectionTimes")); SET_STRING_ELT(parNames, 4, mkChar("acceptanceRate")); setAttrib(retParameters, R_NamesSymbol,parNames); SET_ELEMENT(retParameters, 0, logLikelihood); SET_ELEMENT(retParameters, 1, infRateSIR); SET_ELEMENT(retParameters, 2, remRateSIR); SET_ELEMENT(retParameters, 3, infTimes); SET_ELEMENT(retParameters, 4, acceptanceRate); /* SET_ELEMENT(retParameters, 3, initialInf); SET_ELEMENT(retParameters, 4, timeInfected); */ UNPROTECT(nProtected); return(retParameters); }
SEXP trAWBWlist(SEXP Alist, SEXP W, SEXP Blist, SEXP mode) { R_len_t nA = length(Alist), nB=length(Blist); SEXP ans; SEXP Aitem, Aidims, Bitem, Bidims, Wdims; int nrA, ncA, nrB, ncB, nrW, ncW, ii, jj; int Aii, Bjj, Astart, Aend, idx; double *modep; double *rA, *rB, *rW, *ansp, rans; //if(!isNewList(Alist)) error("'list’ must be a list"); Wdims = getAttrib(W, R_DimSymbol); nrW = INTEGER(Wdims)[0]; ncW = INTEGER(Wdims)[1]; rW = REAL(W); PROTECT(ans = allocVector(REALSXP,nA*nB)); ansp = REAL(ans); PROTECT(mode = coerceVector(mode, REALSXP)) ; modep = REAL(mode); idx = 0; for (Bjj=0; Bjj<nB; Bjj++){ PROTECT(Bitem = AS_NUMERIC(VECTOR_ELT(Blist, Bjj))); PROTECT(Bidims = getAttrib(Bitem, R_DimSymbol)); if (length(Bidims) < 2) error("Bad Bidims"); nrB = INTEGER(Bidims)[0]; ncB = INTEGER(Bidims)[1]; //Rprintf("B: %i %i %i\n", Bjj, nrB, ncB); rB = REAL(Bitem); // printmatd(rB, &nrB, &ncB); if (*modep==0){ Astart=0; Aend =nA; } else { Astart=Bjj; Aend =nA; } for (Aii=Astart; Aii<Aend; Aii++){ PROTECT(Aitem = AS_NUMERIC(VECTOR_ELT(Alist, Aii))); PROTECT(Aidims = getAttrib(Aitem, R_DimSymbol)); nrA = INTEGER(Aidims)[0]; ncA = INTEGER(Aidims)[1]; // Rprintf("A: %i %i %i\n", Aii, nrA, ncA); rA = REAL(Aitem); trAWBWprim(rA, &nrA, &ncA, rW, &nrW, &ncW, rB, &nrB, &ncB, &rans); //Rprintf("%i %i %f\n", Aii, Bjj, rans); //ansp[Aii+nA*Bjj] = rans; //Rprintf("A: %i B: %i %f \n", Aii, Bjj, rans); ansp[idx++] = rans; UNPROTECT(2); } UNPROTECT(2); } //setAttrib(ans, R_NamesSymbol, getAttrib(Alist, R_NamesSymbol)); UNPROTECT(2); return(ans); }
SEXP call_rkImplicit(SEXP Xstart, SEXP Times, SEXP Func, SEXP Initfunc, SEXP Parms, SEXP eventfunc, SEXP elist, SEXP Nout, SEXP Rho, SEXP Tcrit, SEXP Verbose, SEXP Hini, SEXP Rpar, SEXP Ipar, SEXP Method, SEXP Maxsteps, SEXP Flist) { /** Initialization **/ long int old_N_Protect = save_N_Protected(); double *tt = NULL, *xs = NULL; double *y, *f, *Fj, *tmp, *tmp2, *tmp3, *FF, *rr; SEXP R_yout; double *y0, *y1, *dy1, *out, *yout; double t, dt, tmax; int fsal = FALSE; /* fixed step methods have no FSAL */ int interpolate = TRUE; /* polynomial interpolation is done by default */ int i = 0, j=0, it=0, it_tot=0, it_ext=0, nt = 0, neq=0; int isForcing, isEvent; double *alpha; int *index; /**************************************************************************/ /****** Processing of Arguments ******/ /**************************************************************************/ double tcrit = REAL(Tcrit)[0]; double hini = REAL(Hini)[0]; int maxsteps = INTEGER(Maxsteps)[0]; int nout = INTEGER(Nout)[0]; /* number of global outputs if func is in a DLL */ int verbose = INTEGER(Verbose)[0]; int stage = (int)REAL(getListElement(Method, "stage"))[0]; SEXP R_A, R_B1, R_C; double *A, *bb1, *cc=NULL; PROTECT(R_A = getListElement(Method, "A")); incr_N_Protect(); A = REAL(R_A); PROTECT(R_B1 = getListElement(Method, "b1")); incr_N_Protect(); bb1 = REAL(R_B1); PROTECT(R_C = getListElement(Method, "c")); incr_N_Protect(); if (length(R_C)) cc = REAL(R_C); double qerr = REAL(getListElement(Method, "Qerr"))[0]; PROTECT(Times = AS_NUMERIC(Times)); incr_N_Protect(); tt = NUMERIC_POINTER(Times); nt = length(Times); PROTECT(Xstart = AS_NUMERIC(Xstart)); incr_N_Protect(); xs = NUMERIC_POINTER(Xstart); neq = length(Xstart); /*------------------------------------------------------------------------*/ /* timesteps (for advection computation in ReacTran) */ /*------------------------------------------------------------------------*/ for (i = 0; i < 2; i++) timesteps[i] = 0; /**************************************************************************/ /****** DLL, ipar, rpar (to be compatible with lsoda) ******/ /**************************************************************************/ int isDll = FALSE; //int ntot = 0; int lrpar= 0, lipar = 0; int *ipar = NULL; if (inherits(Func, "NativeSymbol")) { /* function is a dll */ isDll = TRUE; if (nout > 0) isOut = TRUE; //ntot = neq + nout; /* length of yout */ lrpar = nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else { /* function is not a dll */ isDll = FALSE; isOut = FALSE; //ntot = neq; lipar = 3; /* in lsoda = 1 */ lrpar = nout; /* in lsoda = 1 */ } out = (double *) R_alloc(lrpar, sizeof(double)); ipar = (int *) R_alloc(lipar, sizeof(int)); ipar[0] = nout; /* first 3 elements of ipar are special */ ipar[1] = lrpar; ipar[2] = lipar; if (isDll == 1) { /* other elements of ipar are set in R-function lsodx via argument *ipar* */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* out: first nout elements of out are reserved for output variables other elements are set via argument *rpar* */ for (j = 0; j < nout; j++) out[j] = 0.0; for (j = 0; j < LENGTH(Rpar); j++) out[nout+j] = REAL(Rpar)[j]; } /*------------------------------------------------------------------------*/ /* Allocation of Workspace */ /*------------------------------------------------------------------------*/ y0 = (double *) R_alloc(neq, sizeof(double)); y1 = (double *) R_alloc(neq, sizeof(double)); dy1 = (double *) R_alloc(neq, sizeof(double)); f = (double *) R_alloc(neq, sizeof(double)); y = (double *) R_alloc(neq, sizeof(double)); Fj = (double *) R_alloc(neq, sizeof(double)); FF = (double *) R_alloc(neq * stage, sizeof(double)); rr = (double *) R_alloc(neq * 5, sizeof(double)); /* ks */ alpha = (double *) R_alloc(neq * stage * neq * stage, sizeof(double)); index = (int *) R_alloc(neq * stage, sizeof(int)); tmp = (double *) R_alloc(neq * stage, sizeof(double)); tmp2 = (double *) R_alloc(neq * stage, sizeof(double)); tmp3 = (double *) R_alloc(neq * stage, sizeof(double)); /* matrix for polynomial interpolation */ SEXP R_nknots; int nknots = 6; /* 6 = 5th order polynomials by default*/ int iknots = 0; /* counter for knots buffer */ double *yknots; PROTECT(R_nknots = getListElement(Method, "nknots")); incr_N_Protect(); if (length(R_nknots)) nknots = INTEGER(R_nknots)[0] + 1; if (nknots < 2) {nknots=1; interpolate = FALSE;} yknots = (double *) R_alloc((neq + 1) * (nknots + 1), sizeof(double)); /* matrix for holding states and global outputs */ PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); incr_N_Protect(); yout = REAL(R_yout); /* initialize outputs with NA first */ for (i = 0; i < nt * (neq + nout + 1); i++) yout[i] = NA_REAL; /* attribute that stores state information, similar to lsoda */ SEXP R_istate; int *istate; PROTECT(R_istate = allocVector(INTSXP, 22)); incr_N_Protect(); istate = INTEGER(R_istate); istate[0] = 0; /* assume succesful return */ for (i = 0; i < 22; i++) istate[i] = 0; /*------------------------------------------------------------------------*/ /* Initialization of Parameters (for DLL functions) */ /*------------------------------------------------------------------------*/ PROTECT(Y = allocVector(REALSXP,(neq))); incr_N_Protect(); initParms(Initfunc, Parms); isForcing = initForcings(Flist); isEvent = initEvents(elist, eventfunc,0); if (isEvent) interpolate = FALSE; /*------------------------------------------------------------------------*/ /* Initialization of Integration Loop */ /*------------------------------------------------------------------------*/ yout[0] = tt[0]; /* initial time */ yknots[0] = tt[0]; /* for polynomial interpolation */ for (i = 0; i < neq; i++) { y0[i] = xs[i]; /* initial values */ yout[(i + 1) * nt] = y0[i]; /* output array */ yknots[iknots + nknots * (i + 1)] = xs[i]; /* for polynomials */ } iknots++; t = tt[0]; tmax = fmax(tt[nt - 1], tcrit); /* Initialization of work arrays (to be on the safe side, remove this later) */ for (i = 0; i < neq; i++) { y1[i] = 0; Fj[i] = 0; for (j= 0; j < stage; j++) { FF[i + j * neq] = 0; } } /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ it = 1; /* step counter; zero element is initial state */ it_ext = 0; /* counter for external time step (dense output) */ it_tot = 0; /* total number of time steps */ if (interpolate) { /* integrate over the whole time step and interpolate internally */ rk_implicit( alpha, index, fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, maxsteps, nt, &iknots, &it, &it_ext, &it_tot, istate, ipar, t, tmax, hini, &dt, tt, y0, y1, dy1, f, y, Fj, tmp, tmp2, tmp3, FF, rr, A, out, bb1, cc, yknots, yout, Func, Parms, Rho ); } else { for (int j = 0; j < nt - 1; j++) { t = tt[j]; tmax = fmin(tt[j + 1], tcrit); dt = tmax - t; if (isEvent) { updateevent(&t, y0, istate); } rk_implicit(alpha, index, fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, maxsteps, nt, &iknots, &it, &it_ext, &it_tot, istate, ipar, t, tmax, hini, &dt, tt, y0, y1, dy1, f, y, Fj, tmp, tmp2, tmp3, FF, rr, A, out, bb1, cc, yknots, yout, Func, Parms, Rho ); /* in this mode, internal interpolation is skipped, so we can simply store the results at the end of each call */ yout[j + 1] = tmax; for (i = 0; i < neq; i++) yout[j + 1 + nt * (1 + i)] = y1[i]; } } /*====================================================================*/ /* call derivs again to get global outputs */ /* j = -1 suppresses unnecessary internal copying */ /*====================================================================*/ if(nout > 0) { for (int j = 0; j < nt; j++) { t = yout[j]; for (i = 0; i < neq; i++) tmp[i] = yout[j + nt * (1 + i)]; derivs(Func, t, tmp, Parms, Rho, FF, out, -1, neq, ipar, isDll, isForcing); for (i = 0; i < nout; i++) { yout[j + nt * (1 + neq + i)] = out[i]; } } } /* attach diagnostic information (codes are compatible to lsoda) */ setIstate(R_yout, R_istate, istate, it_tot, stage, fsal, qerr, 0); /* release R resources */ if (verbose) { Rprintf("Number of time steps it = %d, it_ext = %d, it_tot = %d\n", it, it_ext, it_tot); Rprintf("Maxsteps %d\n", maxsteps); } /* release R resources */ timesteps[0] = 0; timesteps[1] = 0; restore_N_Protected(old_N_Protect); return(R_yout); }
/* * Public */ SEXP do_mdwt(SEXP vntX, SEXP vntH, SEXP vntL) { SEXP vntOut; SEXP vntY; SEXP vntLr; double *x, *h, *y; int m, n, lh, L; #ifdef DEBUG_RWT REprintf("In do_mdwt(x, h, L)...\n"); #endif /* * Handle first parameter (numeric matrix) */ #ifdef DEBUG_RWT REprintf("\tfirst param 'x'\n"); #endif if (GetMatrixDimen(vntX, &m, &n) != 2) { error("'x' is not a two dimensional matrix"); /*NOTREACHED*/ } PROTECT(vntX = AS_NUMERIC(vntX)); x = NUMERIC_POINTER(vntX); #ifdef DEBUG_RWT REprintf("x[%d][%d] = 0x%p\n", m, n, x); #endif /* * Handle second parameter (numeric vector) */ #ifdef DEBUG_RWT REprintf("\tsecond param 'h'\n"); #endif PROTECT(vntH = AS_NUMERIC(vntH)); h = NUMERIC_POINTER(vntH); lh = GET_LENGTH(vntH); #ifdef DEBUG_RWT REprintf("h[%d] = 0x%p\n", GET_LENGTH(vntH), h); #endif /* * Handle third parameter (integer scalar) */ #ifdef DEBUG_RWT REprintf("\tthird param 'L'\n"); #endif { PROTECT(vntL = AS_INTEGER(vntL)); { int *piL = INTEGER_POINTER(vntL); L = piL[0]; } UNPROTECT(1); } #ifdef DEBUG_RWT REprintf("L = %d\n", L); #endif #ifdef DEBUG_RWT REprintf("\tcheck number of levels\n"); #endif if (L < 0) { error("The number of levels, L, must be a non-negative integer"); /*NOTREACHED*/ } #ifdef DEBUG_RWT REprintf("\tcheck dimen prereqs\n"); #endif /* Check the ROW dimension of input */ if (m > 1) { double mtest = (double) m / pow(2.0, (double) L); if (!isint(mtest)) { error("The matrix row dimension must be of size m*2^(L)"); /*NOTREACHED*/ } } /* Check the COLUMN dimension of input */ if (n > 1) { double ntest = (double) n / pow(2.0, (double) L); if (!isint(ntest)) { error("The matrix column dimension must be of size n*2^(L)"); /*NOTREACHED*/ } } #ifdef DEBUG_RWT REprintf("\tcreate value objects\n"); #endif /* Create y value object */ { #ifdef DEBUG_RWT REprintf("\tcreate 'y' value object\n"); #endif PROTECT(vntY = NEW_NUMERIC(n*m)); y = NUMERIC_POINTER(vntY); /* Add dimension attribute to value object */ #ifdef DEBUG_RWT REprintf("\tconvert 'y' value object to matrix\n"); #endif { SEXP vntDim; PROTECT(vntDim = NEW_INTEGER(2)); INTEGER(vntDim)[0] = m; INTEGER(vntDim)[1] = n; SET_DIM(vntY, vntDim); UNPROTECT(1); } } /* Create Lr value object */ { #ifdef DEBUG_RWT REprintf("\tcreating 'Lr' value object\n"); #endif PROTECT(vntLr = NEW_INTEGER(1)); INTEGER_POINTER(vntLr)[0] = L; } #ifdef DEBUG_RWT REprintf("\tcompute discrete wavelet transform\n"); #endif MDWT(x, m, n, h, lh, L, y); /* Unprotect params */ UNPROTECT(2); #ifdef DEBUG_RWT REprintf("\tcreate list output object\n"); #endif PROTECT(vntOut = NEW_LIST(2)); #ifdef DEBUG_RWT REprintf("\tassigning value objects to list\n"); #endif SET_VECTOR_ELT(vntOut, 0, vntY); SET_VECTOR_ELT(vntOut, 1, vntLr); /* Unprotect value objects */ UNPROTECT(2); { SEXP vntNames; #ifdef DEBUG_RWT REprintf("\tassigning names to value objects in list\n"); #endif PROTECT(vntNames = NEW_CHARACTER(2)); SET_STRING_ELT(vntNames, 0, CREATE_STRING_VECTOR("y")); SET_STRING_ELT(vntNames, 1, CREATE_STRING_VECTOR("L")); SET_NAMES(vntOut, vntNames); UNPROTECT(1); } /* Unprotect output object */ UNPROTECT(1); #ifdef DEBUG_RWT REprintf("\treturning output...\n"); #endif return vntOut; }
SEXP do_partrans (SEXP object, SEXP params, SEXP dir, SEXP gnsi) { int nprotect = 0; SEXP fn, fcall, rho, ans, nm; SEXP pdim, pvec; SEXP pompfun; SEXP tparams = R_NilValue; pompfunmode mode = undef; char direc; int qmat; int ndim[2], *dim, *idx; double *pp, *ps, *pt, *pa; int npar1, npar2, nreps; pomp_transform_fn *ff = NULL; int k; direc = *(INTEGER(dir)); // extract the user-defined function switch (direc) { case 1: // forward transformation PROTECT(pompfun = GET_SLOT(object,install("from.trans"))); nprotect++; PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++; break; case -1: // inverse transformation PROTECT(pompfun = GET_SLOT(object,install("to.trans"))); nprotect++; PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++; break; default: error("impossible error"); break; } // extract 'userdata' as pairlist PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++; PROTECT(pdim = GET_DIM(params)); nprotect++; if (isNull(pdim)) { // a single vector npar1 = LENGTH(params); nreps = 1; qmat = 0; } else { // a parameter matrix dim = INTEGER(pdim); npar1 = dim[0]; nreps = dim[1]; qmat = 1; } switch (mode) { case Rfun: // use user-supplied R function // set up the function call if (qmat) { // matrix case PROTECT(pvec = NEW_NUMERIC(npar1)); nprotect++; SET_NAMES(pvec,GET_ROWNAMES(GET_DIMNAMES(params))); PROTECT(fcall = LCONS(pvec,fcall)); nprotect++; } else { // vector case PROTECT(fcall = LCONS(params,fcall)); nprotect++; } SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; // the function's environment PROTECT(rho = (CLOENV(fn))); nprotect++; if (qmat) { // matrix case const char *dimnm[2] = {"variable","rep"}; ps = REAL(params); pp = REAL(pvec); memcpy(pp,ps,npar1*sizeof(double)); PROTECT(ans = eval(fcall,rho)); nprotect++; PROTECT(nm = GET_NAMES(ans)); nprotect++; if (isNull(nm)) error("user transformation functions must return a named numeric vector"); // set up matrix to hold the results npar2 = LENGTH(ans); ndim[0] = npar2; ndim[1] = nreps; PROTECT(tparams = makearray(2,ndim)); nprotect++; setrownames(tparams,nm,2); fixdimnames(tparams,dimnm,2); pt = REAL(tparams); pa = REAL(AS_NUMERIC(ans)); memcpy(pt,pa,npar2*sizeof(double)); ps += npar1; pt += npar2; for (k = 1; k < nreps; k++, ps += npar1, pt += npar2) { memcpy(pp,ps,npar1*sizeof(double)); pa = REAL(AS_NUMERIC(eval(fcall,rho))); memcpy(pt,pa,npar2*sizeof(double)); } } else { // vector case PROTECT(tparams = eval(fcall,rho)); nprotect++; if (isNull(GET_NAMES(tparams))) error("user transformation functions must return a named numeric vector"); } break; case native: // use native routine ff = (pomp_transform_fn *) R_ExternalPtrAddr(fn); if (qmat) { idx = INTEGER(PROTECT(name_index(GET_ROWNAMES(GET_DIMNAMES(params)),pompfun,"paramnames"))); nprotect++; } else { idx = INTEGER(PROTECT(name_index(GET_NAMES(params),pompfun,"paramnames"))); nprotect++; } set_pomp_userdata(fcall); PROTECT(tparams = duplicate(params)); nprotect++; for (k = 0, ps = REAL(params), pt = REAL(tparams); k < nreps; k++, ps += npar1, pt += npar1) { R_CheckUserInterrupt(); (*ff)(pt,ps,idx); } unset_pomp_userdata(); break; default: error("unrecognized 'mode' slot in 'partrans'"); } UNPROTECT(nprotect); return tparams; }
SEXP xmethas( SEXP ncif, SEXP cifname, SEXP beta, SEXP ipar, SEXP iparlen, SEXP period, SEXP xprop, SEXP yprop, SEXP mprop, SEXP ntypes, SEXP nrep, SEXP p, SEXP q, SEXP nverb, SEXP nrep0, SEXP x, SEXP y, SEXP marks, SEXP ncond, SEXP fixall, SEXP track, SEXP thin, SEXP snoopenv, SEXP temper, SEXP invertemp) { char *cifstring; double cvd, cvn, qnodds, anumer, adenom, betavalue; double *iparvector; int verb, marked, tempered, mustupdate, itype; int nfree, nsuspect; int irep, ix, j, maxchunk, iverb; int Ncif; int *plength; long Nmore; int permitted; double invtemp; double *xx, *yy, *xpropose, *ypropose; int *mm, *mpropose, *pp, *aa; SEXP out, xout, yout, mout, pout, aout; int tracking, thinstart; #ifdef HISTORY_INCLUDES_RATIO SEXP numout, denout; double *nn, *dd; #endif State state; Model model; Algor algo; Propo birthprop, deathprop, shiftprop; History history; Snoop snooper; /* The following variables are used only for a non-hybrid interaction */ Cifns thecif; /* cif structure */ Cdata *thecdata; /* pointer to initialised cif data block */ /* The following variables are used only for a hybrid interaction */ Cifns *cif; /* vector of cif structures */ Cdata **cdata; /* vector of pointers to initialised cif data blocks */ int *needupd; /* vector of logical values */ int k; /* loop index for cif's */ /* =================== Protect R objects from garbage collector ======= */ PROTECT(ncif = AS_INTEGER(ncif)); PROTECT(cifname = AS_CHARACTER(cifname)); PROTECT(beta = AS_NUMERIC(beta)); PROTECT(ipar = AS_NUMERIC(ipar)); PROTECT(iparlen = AS_INTEGER(iparlen)); PROTECT(period = AS_NUMERIC(period)); PROTECT(xprop = AS_NUMERIC(xprop)); PROTECT(yprop = AS_NUMERIC(yprop)); PROTECT(mprop = AS_INTEGER(mprop)); PROTECT(ntypes = AS_INTEGER(ntypes)); PROTECT(nrep = AS_INTEGER(nrep)); PROTECT( p = AS_NUMERIC(p)); PROTECT( q = AS_NUMERIC(q)); PROTECT(nverb = AS_INTEGER(nverb)); PROTECT(nrep0 = AS_INTEGER(nrep0)); PROTECT( x = AS_NUMERIC(x)); PROTECT( y = AS_NUMERIC(y)); PROTECT( marks = AS_INTEGER(marks)); PROTECT(fixall = AS_INTEGER(fixall)); PROTECT(ncond = AS_INTEGER(ncond)); PROTECT(track = AS_INTEGER(track)); PROTECT(thin = AS_INTEGER(thin)); PROTECT(temper = AS_INTEGER(temper)); PROTECT(invertemp = AS_NUMERIC(invertemp)); /* that's 24 protected objects */ /* =================== Translate arguments from R to C ================ */ /* Ncif is the number of cif's plength[i] is the number of interaction parameters in the i-th cif */ Ncif = *(INTEGER_POINTER(ncif)); plength = INTEGER_POINTER(iparlen); /* copy RMH algorithm parameters */ algo.nrep = *(INTEGER_POINTER(nrep)); algo.nverb = *(INTEGER_POINTER(nverb)); algo.nrep0 = *(INTEGER_POINTER(nrep0)); algo.p = *(NUMERIC_POINTER(p)); algo.q = *(NUMERIC_POINTER(q)); algo.fixall = ((*(INTEGER_POINTER(fixall))) == 1); algo.ncond = *(INTEGER_POINTER(ncond)); algo.tempered = tempered = (*(INTEGER_POINTER(temper)) != 0); algo.invtemp = invtemp = *(NUMERIC_POINTER(invertemp)); /* copy model parameters without interpreting them */ model.beta = NUMERIC_POINTER(beta); model.ipar = iparvector = NUMERIC_POINTER(ipar); model.period = NUMERIC_POINTER(period); model.ntypes = *(INTEGER_POINTER(ntypes)); state.ismarked = marked = (model.ntypes > 1); /* copy initial state */ state.npts = LENGTH(x); state.npmax = 4 * ((state.npts > 256) ? state.npts : 256); state.x = (double *) R_alloc(state.npmax, sizeof(double)); state.y = (double *) R_alloc(state.npmax, sizeof(double)); xx = NUMERIC_POINTER(x); yy = NUMERIC_POINTER(y); if(marked) { state.marks =(int *) R_alloc(state.npmax, sizeof(int)); mm = INTEGER_POINTER(marks); } if(!marked) { for(j = 0; j < state.npts; j++) { state.x[j] = xx[j]; state.y[j] = yy[j]; } } else { for(j = 0; j < state.npts; j++) { state.x[j] = xx[j]; state.y[j] = yy[j]; state.marks[j] = mm[j]; } } #if MH_DEBUG Rprintf("\tnpts=%d\n", state.npts); #endif /* access proposal data */ xpropose = NUMERIC_POINTER(xprop); ypropose = NUMERIC_POINTER(yprop); mpropose = INTEGER_POINTER(mprop); /* we need to initialise 'mpropose' to keep compilers happy. mpropose is only used for marked patterns. Note 'mprop' is always a valid pointer */ /* ================= Allocate space for cifs etc ========== */ if(Ncif > 1) { cif = (Cifns *) R_alloc(Ncif, sizeof(Cifns)); cdata = (Cdata **) R_alloc(Ncif, sizeof(Cdata *)); needupd = (int *) R_alloc(Ncif, sizeof(int)); } else { /* Keep the compiler happy */ cif = (Cifns *) R_alloc(1, sizeof(Cifns)); cdata = (Cdata **) R_alloc(1, sizeof(Cdata *)); needupd = (int *) R_alloc(1, sizeof(int)); } /* ================= Determine process to be simulated ========== */ /* Get the cif's */ if(Ncif == 1) { cifstring = (char *) STRING_VALUE(cifname); thecif = getcif(cifstring); mustupdate = NEED_UPDATE(thecif); if(thecif.marked && !marked) fexitc("cif is for a marked point process, but proposal data are not marked points; bailing out."); /* Keep compiler happy*/ cif[0] = thecif; needupd[0] = mustupdate; } else { mustupdate = NO; for(k = 0; k < Ncif; k++) { cifstring = (char *) CHAR(STRING_ELT(cifname, k)); cif[k] = getcif(cifstring); needupd[k] = NEED_UPDATE(cif[k]); if(needupd[k]) mustupdate = YES; if(cif[k].marked && !marked) fexitc("component cif is for a marked point process, but proposal data are not marked points; bailing out."); } } /* ============= Initialise transition history ========== */ tracking = (*(INTEGER_POINTER(track)) != 0); /* Initialise even if not needed, to placate the compiler */ if(tracking) { history.nmax = algo.nrep; } else { history.nmax = 1; } history.n = 0; history.proptype = (int *) R_alloc(history.nmax, sizeof(int)); history.accepted = (int *) R_alloc(history.nmax, sizeof(int)); #ifdef HISTORY_INCLUDES_RATIO history.numerator = (double *) R_alloc(history.nmax, sizeof(double)); history.denominator = (double *) R_alloc(history.nmax, sizeof(double)); #endif /* ============= Visual debugging ========== */ /* Active if 'snoopenv' is an environment */ #if MH_DEBUG Rprintf("Initialising mhsnoop\n"); #endif initmhsnoop(&snooper, snoopenv); #if MH_DEBUG Rprintf("Initialised\n"); if(snooper.active) Rprintf("Debugger is active.\n"); #endif /* ================= Thinning of initial state ==================== */ thinstart = (*(INTEGER_POINTER(thin)) != 0); /* ================= Initialise algorithm ==================== */ /* Interpret the model parameters and initialise auxiliary data */ if(Ncif == 1) { thecdata = (*(thecif.init))(state, model, algo); /* keep compiler happy */ cdata[0] = thecdata; } else { for(k = 0; k < Ncif; k++) { if(k > 0) model.ipar += plength[k-1]; cdata[k] = (*(cif[k].init))(state, model, algo); } /* keep compiler happy */ thecdata = cdata[0]; } /* Set the fixed elements of the proposal objects */ birthprop.itype = BIRTH; deathprop.itype = DEATH; shiftprop.itype = SHIFT; birthprop.ix = NONE; if(!marked) birthprop.mrk = deathprop.mrk = shiftprop.mrk = NONE; /* Set up some constants */ verb = (algo.nverb !=0); qnodds = (1.0 - algo.q)/algo.q; /* Set value of beta for unmarked process */ /* (Overwritten for marked process, but keeps compiler happy) */ betavalue = model.beta[0]; /* ============= Run Metropolis-Hastings ================== */ /* Initialise random number generator */ GetRNGstate(); /* Here comes the code for the M-H loop. The basic code (in mhloop.h) is #included many times using different options The C preprocessor descends through a chain of files mhv1.h, mhv2.h, ... to enumerate all possible combinations of flags. */ #include "mhv1.h" /* relinquish random number generator */ PutRNGstate(); /* ============= Done ================== */ /* Create space for output, and copy final state */ /* Point coordinates */ PROTECT(xout = NEW_NUMERIC(state.npts)); PROTECT(yout = NEW_NUMERIC(state.npts)); xx = NUMERIC_POINTER(xout); yy = NUMERIC_POINTER(yout); for(j = 0; j < state.npts; j++) { xx[j] = state.x[j]; yy[j] = state.y[j]; } /* Marks */ if(marked) { PROTECT(mout = NEW_INTEGER(state.npts)); mm = INTEGER_POINTER(mout); for(j = 0; j < state.npts; j++) mm[j] = state.marks[j]; } else { /* Keep the compiler happy */ PROTECT(mout = NEW_INTEGER(1)); mm = INTEGER_POINTER(mout); mm[0] = 0; } /* Transition history */ if(tracking) { PROTECT(pout = NEW_INTEGER(algo.nrep)); PROTECT(aout = NEW_INTEGER(algo.nrep)); pp = INTEGER_POINTER(pout); aa = INTEGER_POINTER(aout); for(j = 0; j < algo.nrep; j++) { pp[j] = history.proptype[j]; aa[j] = history.accepted[j]; } #ifdef HISTORY_INCLUDES_RATIO PROTECT(numout = NEW_NUMERIC(algo.nrep)); PROTECT(denout = NEW_NUMERIC(algo.nrep)); nn = NUMERIC_POINTER(numout); dd = NUMERIC_POINTER(denout); for(j = 0; j < algo.nrep; j++) { nn[j] = history.numerator[j]; dd[j] = history.denominator[j]; } #endif } else { /* Keep the compiler happy */ PROTECT(pout = NEW_INTEGER(1)); PROTECT(aout = NEW_INTEGER(1)); pp = INTEGER_POINTER(pout); aa = INTEGER_POINTER(aout); pp[0] = aa[0] = 0; #ifdef HISTORY_INCLUDES_RATIO PROTECT(numout = NEW_NUMERIC(1)); PROTECT(denout = NEW_NUMERIC(1)); nn = NUMERIC_POINTER(numout); dd = NUMERIC_POINTER(denout); nn[0] = dd[0] = 0; #endif } /* Pack up into list object for return */ if(!tracking) { /* no transition history */ if(!marked) { PROTECT(out = NEW_LIST(2)); SET_VECTOR_ELT(out, 0, xout); SET_VECTOR_ELT(out, 1, yout); } else { PROTECT(out = NEW_LIST(3)); SET_VECTOR_ELT(out, 0, xout); SET_VECTOR_ELT(out, 1, yout); SET_VECTOR_ELT(out, 2, mout); } } else { /* transition history */ if(!marked) { #ifdef HISTORY_INCLUDES_RATIO PROTECT(out = NEW_LIST(6)); #else PROTECT(out = NEW_LIST(4)); #endif SET_VECTOR_ELT(out, 0, xout); SET_VECTOR_ELT(out, 1, yout); SET_VECTOR_ELT(out, 2, pout); SET_VECTOR_ELT(out, 3, aout); #ifdef HISTORY_INCLUDES_RATIO SET_VECTOR_ELT(out, 4, numout); SET_VECTOR_ELT(out, 5, denout); #endif } else { #ifdef HISTORY_INCLUDES_RATIO PROTECT(out = NEW_LIST(7)); #else PROTECT(out = NEW_LIST(5)); #endif SET_VECTOR_ELT(out, 0, xout); SET_VECTOR_ELT(out, 1, yout); SET_VECTOR_ELT(out, 2, mout); SET_VECTOR_ELT(out, 3, pout); SET_VECTOR_ELT(out, 4, aout); #ifdef HISTORY_INCLUDES_RATIO SET_VECTOR_ELT(out, 5, numout); SET_VECTOR_ELT(out, 6, denout); #endif } } #ifdef HISTORY_INCLUDES_RATIO UNPROTECT(32); /* 24 arguments plus xout, yout, mout, pout, aout, out, numout, denout */ #else UNPROTECT(30); /* 24 arguments plus xout, yout, mout, pout, aout, out */ #endif return(out); }
// compute pdf of a sequence of Euler steps SEXP euler_model_density (SEXP func, SEXP x, SEXP times, SEXP params, SEXP tcovar, SEXP covar, SEXP log, SEXP args, SEXP gnsi) { int nprotect = 0; pompfunmode mode = undef; int give_log; int nvars, npars, nreps, ntimes, ncovars, covlen; pomp_onestep_pdf *ff = NULL; SEXP cvec, pvec = R_NilValue; SEXP t1vec = R_NilValue, t2vec = R_NilValue; SEXP x1vec = R_NilValue, x2vec = R_NilValue; SEXP Snames, Pnames, Cnames; SEXP fn, rho = R_NilValue, fcall = R_NilValue; SEXP F; int *pidx = 0, *sidx = 0, *cidx = 0; { int *dim; dim = INTEGER(GET_DIM(x)); nvars = dim[0]; nreps = dim[1]; dim = INTEGER(GET_DIM(params)); npars = dim[0]; dim = INTEGER(GET_DIM(covar)); covlen = dim[0]; ncovars = dim[1]; ntimes = LENGTH(times); } PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(covar))); nprotect++; // set up the covariate table struct lookup_table covariate_table = {covlen, ncovars, 0, REAL(tcovar), REAL(covar)}; // vector for interpolated covariates PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++; SET_NAMES(cvec,Cnames); PROTECT(fn = pomp_fun_handler(func,gnsi,&mode)); nprotect++; give_log = *(INTEGER(log)); switch (mode) { case Rfun: // R function PROTECT(t1vec = NEW_NUMERIC(1)); nprotect++; PROTECT(t2vec = NEW_NUMERIC(1)); nprotect++; PROTECT(x1vec = NEW_NUMERIC(nvars)); nprotect++; SET_NAMES(x1vec,Snames); PROTECT(x2vec = NEW_NUMERIC(nvars)); nprotect++; SET_NAMES(x2vec,Snames); PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++; SET_NAMES(pvec,Pnames); // set up the function call PROTECT(fcall = LCONS(cvec,args)); nprotect++; SET_TAG(fcall,install("covars")); PROTECT(fcall = LCONS(pvec,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(t2vec,fcall)); nprotect++; SET_TAG(fcall,install("t2")); PROTECT(fcall = LCONS(t1vec,fcall)); nprotect++; SET_TAG(fcall,install("t1")); PROTECT(fcall = LCONS(x2vec,fcall)); nprotect++; SET_TAG(fcall,install("x2")); PROTECT(fcall = LCONS(x1vec,fcall)); nprotect++; SET_TAG(fcall,install("x1")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; PROTECT(rho = (CLOENV(fn))); nprotect++; break; case native: // native code // construct state, parameter, covariate indices sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames")),"state variables"))); nprotect++; pidx = INTEGER(PROTECT(matchnames(Pnames,GET_SLOT(func,install("paramnames")),"parameters"))); nprotect++; cidx = INTEGER(PROTECT(matchnames(Cnames,GET_SLOT(func,install("covarnames")),"covariates"))); nprotect++; *((void **) (&ff)) = R_ExternalPtrAddr(fn); break; default: errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov break; } // create array to hold results { int dim[2] = {nreps, ntimes-1}; PROTECT(F = makearray(2,dim)); nprotect++; } switch (mode) { case Rfun: // R function { double *cp = REAL(cvec); double *t1p = REAL(t1vec); double *t2p = REAL(t2vec); double *x1p = REAL(x1vec); double *x2p = REAL(x2vec); double *pp = REAL(pvec); double *t1s = REAL(times); double *t2s = t1s+1; double *x1s = REAL(x); double *x2s = x1s + nvars*nreps; double *ps; double *fs = REAL(F); int j, k; for (k = 0; k < ntimes-1; k++, t1s++, t2s++) { // loop over times R_CheckUserInterrupt(); *t1p = *t1s; *t2p = *t2s; // interpolate the covariates at time t1, store the results in cvec table_lookup(&covariate_table,*t1p,cp); for (j = 0, ps = REAL(params); j < nreps; j++, fs++, x1s += nvars, x2s += nvars, ps += npars) { // loop over replicates memcpy(x1p,x1s,nvars*sizeof(double)); memcpy(x2p,x2s,nvars*sizeof(double)); memcpy(pp,ps,npars*sizeof(double)); *fs = *(REAL(AS_NUMERIC(eval(fcall,rho)))); if (!give_log) *fs = exp(*fs); } } } break; case native: // native code set_pomp_userdata(args); { double *t1s = REAL(times); double *t2s = t1s+1; double *x1s = REAL(x); double *x2s = x1s + nvars*nreps; double *fs = REAL(F); double *cp = REAL(cvec); double *ps; int j, k; for (k = 0; k < ntimes-1; k++, t1s++, t2s++) { // loop over times R_CheckUserInterrupt(); // interpolate the covariates at time t1, store the results in cvec table_lookup(&covariate_table,*t1s,cp); for (j = 0, ps = REAL(params); j < nreps; j++, fs++, x1s += nvars, x2s += nvars, ps += npars) { // loop over replicates (*ff)(fs,x1s,x2s,*t1s,*t2s,ps,sidx,pidx,cidx,ncovars,cp); if (!give_log) *fs = exp(*fs); } } } unset_pomp_userdata(); break; default: errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov break; } UNPROTECT(nprotect); return F; }
SEXP euler_model_simulator (SEXP func, SEXP xstart, SEXP times, SEXP params, SEXP deltat, SEXP method, SEXP zeronames, SEXP tcovar, SEXP covar, SEXP args, SEXP gnsi) { int nprotect = 0; pompfunmode mode = undef; int nvars, npars, nreps, ntimes, nzeros, ncovars, covlen; int nstep = 0; double dt, dtt; SEXP X; SEXP ans, nm, fn, fcall = R_NilValue, rho = R_NilValue; SEXP Snames, Pnames, Cnames; SEXP cvec, tvec = R_NilValue; SEXP xvec = R_NilValue, pvec = R_NilValue, dtvec = R_NilValue; int *pidx = 0, *sidx = 0, *cidx = 0, *zidx = 0; pomp_onestep_sim *ff = NULL; int meth = INTEGER_VALUE(method); // meth: 0 = Euler, 1 = one-step, 2 = fixed step dtt = NUMERIC_VALUE(deltat); if (dtt <= 0) errorcall(R_NilValue,"'delta.t' should be a positive number"); { int *dim; dim = INTEGER(GET_DIM(xstart)); nvars = dim[0]; nreps = dim[1]; dim = INTEGER(GET_DIM(params)); npars = dim[0]; dim = INTEGER(GET_DIM(covar)); covlen = dim[0]; ncovars = dim[1]; ntimes = LENGTH(times); } PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(xstart))); nprotect++; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(covar))); nprotect++; // set up the covariate table struct lookup_table covariate_table = {covlen, ncovars, 0, REAL(tcovar), REAL(covar)}; // vector for interpolated covariates PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++; SET_NAMES(cvec,Cnames); // indices of accumulator variables nzeros = LENGTH(zeronames); zidx = INTEGER(PROTECT(matchnames(Snames,zeronames,"state variables"))); nprotect++; // extract user function PROTECT(fn = pomp_fun_handler(func,gnsi,&mode)); nprotect++; // set up switch (mode) { case Rfun: // R function PROTECT(dtvec = NEW_NUMERIC(1)); nprotect++; PROTECT(tvec = NEW_NUMERIC(1)); nprotect++; PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++; PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++; SET_NAMES(xvec,Snames); SET_NAMES(pvec,Pnames); // set up the function call PROTECT(fcall = LCONS(cvec,args)); nprotect++; SET_TAG(fcall,install("covars")); PROTECT(fcall = LCONS(dtvec,fcall)); nprotect++; SET_TAG(fcall,install("delta.t")); PROTECT(fcall = LCONS(pvec,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(tvec,fcall)); nprotect++; SET_TAG(fcall,install("t")); PROTECT(fcall = LCONS(xvec,fcall)); nprotect++; SET_TAG(fcall,install("x")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; // get function's environment PROTECT(rho = (CLOENV(fn))); nprotect++; break; case native: // native code // construct state, parameter, covariate indices sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames")),"state variables"))); nprotect++; pidx = INTEGER(PROTECT(matchnames(Pnames,GET_SLOT(func,install("paramnames")),"parameters"))); nprotect++; cidx = INTEGER(PROTECT(matchnames(Cnames,GET_SLOT(func,install("covarnames")),"covariates"))); nprotect++; *((void **) (&ff)) = R_ExternalPtrAddr(fn); break; default: errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov break; } // create array to hold results { int dim[3] = {nvars, nreps, ntimes}; PROTECT(X = makearray(3,dim)); nprotect++; setrownames(X,Snames,3); } // copy the start values into the result array memcpy(REAL(X),REAL(xstart),nvars*nreps*sizeof(double)); if (mode==1) { set_pomp_userdata(args); GetRNGstate(); } // now do computations { int first = 1; int use_names = 0; int *posn = 0; double *time = REAL(times); double *xs = REAL(X); double *xt = REAL(X)+nvars*nreps; double *cp = REAL(cvec); double *ps = REAL(params); double t = time[0]; double *pm, *xm; int i, j, k, step; for (step = 1; step < ntimes; step++, xs = xt, xt += nvars*nreps) { R_CheckUserInterrupt(); if (t > time[step]) { errorcall(R_NilValue,"'times' is not an increasing sequence"); } memcpy(xt,xs,nreps*nvars*sizeof(double)); // set accumulator variables to zero for (j = 0; j < nreps; j++) for (i = 0; i < nzeros; i++) xt[zidx[i]+nvars*j] = 0.0; switch (meth) { case 0: // Euler method dt = dtt; nstep = num_euler_steps(t,time[step],&dt); break; case 1: // one step dt = time[step]-t; nstep = (dt > 0) ? 1 : 0; break; case 2: // fixed step dt = dtt; nstep = num_map_steps(t,time[step],dt); break; default: errorcall(R_NilValue,"unrecognized 'method'"); // # nocov break; } for (k = 0; k < nstep; k++) { // loop over Euler steps // interpolate the covar functions for the covariates table_lookup(&covariate_table,t,cp); for (j = 0, pm = ps, xm = xt; j < nreps; j++, pm += npars, xm += nvars) { // loop over replicates switch (mode) { case Rfun: // R function { double *xp = REAL(xvec); double *pp = REAL(pvec); double *tp = REAL(tvec); double *dtp = REAL(dtvec); double *ap; *tp = t; *dtp = dt; memcpy(xp,xm,nvars*sizeof(double)); memcpy(pp,pm,npars*sizeof(double)); if (first) { PROTECT(ans = eval(fcall,rho)); nprotect++; // evaluate the call if (LENGTH(ans) != nvars) { errorcall(R_NilValue,"user 'step.fun' returns a vector of %d state variables but %d are expected: compare initial conditions?", LENGTH(ans),nvars); } PROTECT(nm = GET_NAMES(ans)); nprotect++; use_names = !isNull(nm); if (use_names) { posn = INTEGER(PROTECT(matchnames(Snames,nm,"state variables"))); nprotect++; } ap = REAL(AS_NUMERIC(ans)); first = 0; } else { ap = REAL(AS_NUMERIC(eval(fcall,rho))); } if (use_names) { for (i = 0; i < nvars; i++) xm[posn[i]] = ap[i]; } else { for (i = 0; i < nvars; i++) xm[i] = ap[i]; } } break; case native: // native code (*ff)(xm,pm,sidx,pidx,cidx,ncovars,cp,t,dt); break; default: errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov break; } } t += dt; if ((meth == 0) && (k == nstep-2)) { // penultimate step dt = time[step]-t; t = time[step]-dt; } } } } if (mode==1) { PutRNGstate(); unset_pomp_userdata(); } UNPROTECT(nprotect); return X; }
//take the elements of a GFF in R and make a GFF object in C; return pointer //Assume length of vectors are all equal (except optional elements can be NULL) SEXP rph_gff_new(SEXP seqnameP, SEXP srcP, SEXP featureP, SEXP startP, SEXP endP, SEXP scoreP, SEXP strandP, SEXP frameP, SEXP attributeP) { GFF_Set *gff; GFF_Feature *feat; int gfflen, i; int haveScore=0, haveStrand=0, haveFrame=0, haveAttribute=0, numProtect=5; String *seqname, *source, *feature, *attribute; int *start, *end, frame=GFF_NULL_FRAME, *frameVec=NULL; double *scoreVec=NULL, score; char strand; PROTECT(seqnameP = AS_CHARACTER(seqnameP)); PROTECT(srcP = AS_CHARACTER(srcP)); PROTECT(featureP = AS_CHARACTER(featureP)); PROTECT(startP = AS_INTEGER(startP)); start = INTEGER_POINTER(startP); PROTECT(endP = AS_INTEGER(endP)); end = INTEGER_POINTER(endP); if (scoreP != R_NilValue) { PROTECT(scoreP = AS_NUMERIC(scoreP)); haveScore = 1; scoreVec = NUMERIC_POINTER(scoreP); } else score=0; if (strandP != R_NilValue) { PROTECT(strandP = AS_CHARACTER(strandP)); haveStrand=1; } else strand='.'; if (frameP != R_NilValue) { PROTECT(frameP = AS_INTEGER(frameP)); haveFrame=1; frameVec = INTEGER_POINTER(frameP); } if (attributeP != R_NilValue) { PROTECT(attributeP = AS_CHARACTER(attributeP)); haveAttribute=1; } numProtect += (haveScore + haveStrand + haveFrame + haveAttribute); gfflen = LENGTH(seqnameP); gff = gff_new_set_len(gfflen); for (i=0; i<gfflen; i++) { checkInterruptN(i, 1000); seqname = str_new_charstr(CHAR(STRING_ELT(seqnameP, i))); source = str_new_charstr(CHAR(STRING_ELT(srcP, i))); feature = str_new_charstr(CHAR(STRING_ELT(featureP, i))); if (haveScore) score = scoreVec[i]; if (haveStrand) strand = (CHAR(STRING_ELT(strandP, i)))[0]; if (haveFrame) { if (frameVec[i] == 0) frame = 0; else if (frameVec[i] == 1) frame = 2; else if (frameVec[i] == 2) frame = 1; } if (haveAttribute) attribute = str_new_charstr(CHAR(STRING_ELT(attributeP, i))); else attribute = str_new_charstr(""); if (seqname == NULL) die("seqname is NULL\n"); if (source == NULL) die ("source is NULL\n"); if (feature == NULL) die("feature is NULL\n"); if (attribute == NULL) die("attribute is NULL\n"); if (strand != '+' && strand != '-' && strand!='.') die("strand is %c\n", strand); if (frame != GFF_NULL_FRAME && (frame<0 || frame>2)) die("frame is %i\n", frame); feat = gff_new_feature(seqname, source, feature, start[i], end[i], score, strand, frame, attribute, haveScore==0); lst_push_ptr(gff->features, feat); } UNPROTECT(numProtect); return rph_gff_new_extptr(gff); }
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)); }
SEXP CRF_NLL(SEXP _crf, SEXP _par, SEXP _instances, SEXP _nodeFea, SEXP _edgeFea, SEXP _nodeExt, SEXP _edgeExt, SEXP _infer, SEXP _env) { CRF crf(_crf); int nInstances = INTEGER_POINTER(GET_DIM(_instances))[0]; int nPar = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.par")))[0]; int nNodeFea = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.nf")))[0]; int nEdgeFea = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.ef")))[0]; PROTECT(_par = AS_NUMERIC(_par)); double *par = NUMERIC_POINTER(_par); double *crfPar = NUMERIC_POINTER(GetVar(_crf, "par")); for (int i = 0; i < nPar; i++) crfPar[i] = par[i]; PROTECT(_instances = AS_NUMERIC(_instances)); double *instances = NUMERIC_POINTER(_instances); SEXP _nodePar; PROTECT(_nodePar = AS_INTEGER(GetVar(_crf, "node.par"))); int *nodePar = INTEGER_POINTER(_nodePar); SEXP _edgePar = GetVar(_crf, "edge.par"); int **edgePar = (int **) R_alloc(crf.nEdges, sizeof(int *)); SEXP _edgeParI, _temp; PROTECT(_edgeParI = NEW_LIST(crf.nEdges)); for (int i = 0; i < crf.nEdges; i++) { SET_VECTOR_ELT(_edgeParI, i, _temp = AS_INTEGER(GetListElement(_edgePar, i))); edgePar[i] = INTEGER_POINTER(_temp); } SEXP _nll = GetVar(_crf, "nll"); double *nll = NUMERIC_POINTER(_nll); *nll = 0.0; double *gradient = NUMERIC_POINTER(GetVar(_crf, "gradient")); for (int i = 0; i < nPar; i++) gradient[i] = 0.0; int *y = (int *) R_allocVector<int>(crf.nNodes); SEXP _nodeFeaN = _nodeFea; SEXP _edgeFeaN = _edgeFea; SEXP _nodeExtN = _nodeExt; SEXP _edgeExtN = _edgeExt; for (int n = 0; n < nInstances; n++) { if (!isNull(_nodeFea) && isNewList(_nodeFea)) _nodeFeaN = GetListElement(_nodeFea, n); if (!isNull(_edgeFea) && isNewList(_edgeFea)) _edgeFeaN = GetListElement(_edgeFea, n); if (!isNull(_nodeExt) && isNewList(_nodeExt)) _nodeExtN = GetListElement(_nodeExt, n); if (!isNull(_edgeExt) && isNewList(_edgeExt)) _edgeExtN = GetListElement(_edgeExt, n); crf.Update_Pot(_nodeFeaN, _edgeFeaN, _nodeExtN, _edgeExtN); for (int i = 0; i < crf.nNodes; i++) y[i] = instances[n + nInstances * i] - 1; SEXP _belief; PROTECT(_belief = eval(_infer, _env)); SEXP _nodeBel; PROTECT(_nodeBel = AS_NUMERIC(GetListElement(_belief, "node.bel"))); double *nodeBel = NUMERIC_POINTER(_nodeBel); SEXP _edgeBel = GetListElement(_belief, "edge.bel"); double **edgeBel = (double **) R_alloc(crf.nEdges, sizeof(double *)); SEXP _edgeBelI, _temp; PROTECT(_edgeBelI = NEW_LIST(crf.nEdges)); for (int i = 0; i < crf.nEdges; i++) { SET_VECTOR_ELT(_edgeBelI, i, _temp = AS_NUMERIC(GetListElement(_edgeBel, i))); edgeBel[i] = NUMERIC_POINTER(_temp); } *nll += NUMERIC_POINTER(AS_NUMERIC(GetListElement(_belief, "logZ")))[0] - crf.Get_LogPotential(y); if (!isNull(_nodeFeaN)) { PROTECT(_nodeFeaN = AS_NUMERIC(_nodeFeaN)); double *nodeFea = NUMERIC_POINTER(_nodeFeaN); if (!ISNAN(nodeFea[0])) { for (int i = 0; i < crf.nNodes; i++) { int s = y[i]; for (int j = 0; j < nNodeFea; j++) { double f = nodeFea[j + nNodeFea * i]; if (f != 0) { for (int k = 0; k < crf.nStates[i]; k++) { int p = nodePar[i + crf.nNodes * (k + crf.maxState * j)] - 1; if (p >= 0 && p < nPar) { if (k == s) { gradient[p] -= f; } gradient[p] += f * nodeBel[i + crf.nNodes * k]; } } } } } } UNPROTECT(1); } if (!isNull(_edgeFeaN)) { PROTECT(_edgeFeaN = AS_NUMERIC(_edgeFeaN)); double *edgeFea = NUMERIC_POINTER(_edgeFeaN); if (!ISNAN(edgeFea[0])) { for (int i = 0; i < crf.nEdges; i++) { int s = y[crf.EdgesBegin(i)] + crf.nStates[crf.EdgesBegin(i)] * y[crf.EdgesEnd(i)]; for (int j = 0; j < nEdgeFea; j++) { double f = edgeFea[j + nEdgeFea * i]; if (f != 0) { for (int k = 0; k < crf.nEdgeStates[i]; k++) { int p = edgePar[i][k + crf.nEdgeStates[i] * j] - 1; if (p >= 0 && p < nPar) { if (k == s) { gradient[p] -= f; } gradient[p] += f * edgeBel[i][k]; } } } } } } UNPROTECT(1); } if (!isNull(_nodeExtN) && isNewList(_nodeExtN)) { for (int i = 0; i < nPar; i++) { SEXP _nodeExtI = GetListElement(_nodeExtN, i); if (!isNull(_nodeExtI)) { PROTECT(_nodeExtI = AS_NUMERIC(_nodeExtI)); double *nodeExt = NUMERIC_POINTER(_nodeExtI); if (!ISNAN(nodeExt[0])) { for (int j = 0; j < crf.nNodes; j++) { int s = y[j]; for (int k = 0; k < crf.nStates[j]; k++) { double f = nodeExt[j + crf.nNodes * k]; if (k == s) { gradient[i] -= f; } gradient[i] += f * nodeBel[j + crf.nNodes * k]; } } } UNPROTECT(1); } } } if (!isNull(_edgeExtN) && isNewList(_edgeExtN)) { for (int i = 0; i < nPar; i++) { SEXP _edgeExtI = GetListElement(_edgeExtN, i); if (!isNull(_edgeExtI) && isNewList(_edgeExtI)) { for (int j = 0; j < crf.nEdges; j++) { SEXP _edgeExtII = GetListElement(_edgeExtI, j); if (!isNull(_edgeExtII)) { PROTECT(_edgeExtII = AS_NUMERIC(_edgeExtII)); double *edgeExt = NUMERIC_POINTER(_edgeExtII); if (!ISNAN(edgeExt[0])) { int s = y[crf.EdgesBegin(j)] + crf.nStates[crf.EdgesBegin(j)] * y[crf.EdgesEnd(j)]; for (int k = 0; k < crf.nEdgeStates[j]; k++) { double f = edgeExt[k]; if (k == s) { gradient[i] -= f; } gradient[i] += f * edgeBel[j][k]; } } UNPROTECT(1); } } } } } UNPROTECT(3); } UNPROTECT(4); return(_nll); }
SEXP MRF_NLL(SEXP _crf, SEXP _par, SEXP _instances, SEXP _infer, SEXP _env) { CRF crf(_crf); int nInstances = INTEGER_POINTER(GET_DIM(_instances))[0]; int nPar = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.par")))[0]; PROTECT(_par = AS_NUMERIC(_par)); double *par = NUMERIC_POINTER(_par); double *crfPar = NUMERIC_POINTER(GetVar(_crf, "par")); for (int i = 0; i < nPar; i++) crfPar[i] = par[i]; SEXP _parStat; PROTECT(_parStat = AS_NUMERIC(GetVar(_crf, "par.stat"))); double *parStat = NUMERIC_POINTER(_parStat); SEXP _nll = GetVar(_crf, "nll"); double *nll = NUMERIC_POINTER(_nll); *nll = 0.0; double *gradient = NUMERIC_POINTER(GetVar(_crf, "gradient")); for (int i = 0; i < nPar; i++) gradient[i] = 0.0; crf.Update_Pot(); SEXP _belief; PROTECT(_belief = eval(_infer, _env)); *nll = NUMERIC_POINTER(AS_NUMERIC(GetListElement(_belief, "logZ")))[0] * nInstances; for (int i = 0; i < nPar; i++) { *nll -= par[i] * parStat[i]; gradient[i] = -parStat[i]; } SEXP _nodePar, _nodeBel; PROTECT(_nodePar = AS_INTEGER(GetVar(_crf, "node.par"))); PROTECT(_nodeBel = AS_NUMERIC(GetListElement(_belief, "node.bel"))); int *nodePar = INTEGER_POINTER(_nodePar); double *nodeBel = NUMERIC_POINTER(_nodeBel); for (int i = 0; i < crf.nNodes; i++) { for (int k = 0; k < crf.nStates[i]; k++) { int p = nodePar[i + crf.nNodes * k] - 1; if (p >= 0 && p < nPar) { gradient[p] += nodeBel[i + crf.nNodes * k] * nInstances; } } } SEXP _edgePar = GetVar(_crf, "edge.par"); SEXP _edgeBel = GetListElement(_belief, "edge.bel"); SEXP _edgeParI, _edgeBelI, _temp; PROTECT(_edgeParI = NEW_LIST(crf.nEdges)); PROTECT(_edgeBelI = NEW_LIST(crf.nEdges)); for (int i = 0; i < crf.nEdges; i++) { SET_VECTOR_ELT(_edgeParI, i, _temp = AS_INTEGER(GetListElement(_edgePar, i))); int *edgePar = INTEGER_POINTER(_temp); SET_VECTOR_ELT(_edgeBelI, i, _temp = AS_NUMERIC(GetListElement(_edgeBel, i))); double *edgeBel = NUMERIC_POINTER(_temp); for (int k = 0; k < crf.nEdgeStates[i]; k++) { int p = edgePar[k] - 1; if (p >= 0 && p < nPar) { gradient[p] += edgeBel[k] * nInstances; } } } UNPROTECT(7); return(_nll); }
void CRF::Update_Pot(SEXP _nodeFea, SEXP _edgeFea, SEXP _nodeExt, SEXP _edgeExt) { int nPar = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.par")))[0]; SEXP _par; PROTECT(_par = AS_NUMERIC(GetVar(_crf, "par"))); double *par = NUMERIC_POINTER(_par); for (int i = 0; i < nNodes * maxState; i++) nodePot[i] = 0; for (int i = 0; i < nEdges; i++) for (int j = 0; j < nEdgeStates[i]; j++) edgePot[i][j] = 0; if (!isNull(_nodeFea)) { PROTECT(_nodeFea = AS_NUMERIC(_nodeFea)); double *nodeFea = NUMERIC_POINTER(_nodeFea); if (!ISNAN(nodeFea[0])) { int nNodeFea = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.nf")))[0]; SEXP _nodePar; PROTECT(_nodePar = AS_INTEGER(GetVar(_crf, "node.par"))); int *nodePar = INTEGER_POINTER(_nodePar); for (int i = 0; i < nNodes; i++) { for (int j = 0; j < nNodeFea; j++) { double f = nodeFea[j + nNodeFea * i]; if (f != 0) for (int k = 0; k < nStates[i]; k++) { int p = nodePar[i + nNodes * (k + maxState * j)] - 1; if (p >= 0 && p < nPar) nodePot[i + nNodes * k] += f * par[p]; } } } UNPROTECT(1); } UNPROTECT(1); } if (!isNull(_edgeFea)) { PROTECT(_edgeFea = AS_NUMERIC(_edgeFea)); double *edgeFea = NUMERIC_POINTER(_edgeFea); if (!ISNAN(edgeFea[0])) { int nEdgeFea = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.ef")))[0]; SEXP _edgePar = GetVar(_crf, "edge.par"); for (int i = 0; i < nEdges; i++) { SEXP _edgeParI; PROTECT(_edgeParI = AS_INTEGER(GetListElement(_edgePar, i))); int *edgePar = INTEGER_POINTER(_edgeParI); for (int j = 0; j < nEdgeFea; j++) { double f = edgeFea[j + nEdgeFea * i]; if (f != 0) for (int k = 0; k < nEdgeStates[i]; k++) { int p = edgePar[k + nEdgeStates[i] * j] - 1; if (p >= 0 && p < nPar) edgePot[i][k] += f * par[p]; } } UNPROTECT(1); } } UNPROTECT(1); } if (!isNull(_nodeExt) && isNewList(_nodeExt)) { for (int i = 0; i < nPar; i++) { SEXP _nodeExtI = GetListElement(_nodeExt, i); if (!isNull(_nodeExtI)) { PROTECT(_nodeExtI = AS_NUMERIC(_nodeExtI)); double *nodeExt = NUMERIC_POINTER(_nodeExtI); if (!ISNAN(nodeExt[0])) { for (int j = 0; j < nNodes; j++) { for (int k = 0; k < nStates[j]; k++) { nodePot[j + nNodes * k] += nodeExt[j + nNodes * k] * par[i]; } } } UNPROTECT(1); } } } if (!isNull(_edgeExt) && isNewList(_edgeExt)) { for (int i = 0; i < nPar; i++) { SEXP _edgeExtI = GetListElement(_edgeExt, i); if (!isNull(_edgeExtI) && isNewList(_edgeExtI)) { for (int j = 0; j < nEdges; j++) { SEXP _edgeExtII = GetListElement(_edgeExtI, j); if (!isNull(_edgeExtII)) { PROTECT(_edgeExtII = AS_NUMERIC(_edgeExtII)); double *edgeExt = NUMERIC_POINTER(_edgeExtII); if (!ISNAN(edgeExt[0])) { for (int k = 0; k < nEdgeStates[j]; k++) { edgePot[j][k] += edgeExt[k] * par[i]; } } UNPROTECT(1); } } } } } for (int i = 0; i < nNodes * maxState; i++) nodePot[i] = exp(nodePot[i]); for (int i = 0; i < nEdges; i++) for (int j = 0; j < nEdgeStates[i]; j++) edgePot[i][j] = exp(edgePot[i][j]); UNPROTECT(1); }
SEXP fastcluster(SEXP const N_, SEXP const method_, SEXP D_, SEXP members_) { SEXP r = NULL; // return value try{ /* Input checks */ // Parameter N: number of data points PROTECT(N_); if (!IS_INTEGER(N_) || LENGTH(N_)!=1) Rf_error("'N' must be a single integer."); const int N = *INTEGER_POINTER(N_); if (N<2) Rf_error("N must be at least 2."); const std::ptrdiff_t NN = static_cast<std::ptrdiff_t>(N)*(N-1)/2; UNPROTECT(1); // N_ // Parameter method: dissimilarity index update method PROTECT(method_); if (!IS_INTEGER(method_) || LENGTH(method_)!=1) Rf_error("'method' must be a single integer."); const int method = *INTEGER_POINTER(method_) - 1; // index-0 based; if (method<METHOD_METR_SINGLE || method>METHOD_METR_MEDIAN) { Rf_error("Invalid method index."); } UNPROTECT(1); // method_ // Parameter members: number of members in each node auto_array_ptr<t_float> members; if (method==METHOD_METR_AVERAGE || method==METHOD_METR_WARD || method==METHOD_METR_CENTROID) { members.init(N); if (Rf_isNull(members_)) { for (t_index i=0; i<N; ++i) members[i] = 1; } else { PROTECT(members_ = AS_NUMERIC(members_)); if (LENGTH(members_)!=N) Rf_error("'members' must have length N."); const t_float * const m = NUMERIC_POINTER(members_); for (t_index i=0; i<N; ++i) members[i] = m[i]; UNPROTECT(1); // members } } // Parameter D_: dissimilarity matrix PROTECT(D_ = AS_NUMERIC(D_)); if (LENGTH(D_)!=NN) Rf_error("'D' must have length (N \\choose 2)."); const double * const D = NUMERIC_POINTER(D_); // Make a working copy of the dissimilarity array // for all methods except "single". auto_array_ptr<double> D__; if (method!=METHOD_METR_SINGLE) { D__.init(NN); for (std::ptrdiff_t i=0; i<NN; ++i) D__[i] = D[i]; } UNPROTECT(1); // D_ /* Clustering step */ cluster_result Z2(N-1); switch (method) { case METHOD_METR_SINGLE: MST_linkage_core(N, D, Z2); break; case METHOD_METR_COMPLETE: NN_chain_core<METHOD_METR_COMPLETE, t_float>(N, D__, NULL, Z2); break; case METHOD_METR_AVERAGE: NN_chain_core<METHOD_METR_AVERAGE, t_float>(N, D__, members, Z2); break; case METHOD_METR_WEIGHTED: NN_chain_core<METHOD_METR_WEIGHTED, t_float>(N, D__, NULL, Z2); break; case METHOD_METR_WARD: NN_chain_core<METHOD_METR_WARD, t_float>(N, D__, members, Z2); break; case METHOD_METR_CENTROID: generic_linkage<METHOD_METR_CENTROID, t_float>(N, D__, members, Z2); break; case METHOD_METR_MEDIAN: generic_linkage<METHOD_METR_MEDIAN, t_float>(N, D__, NULL, Z2); break; default: throw std::runtime_error(std::string("Invalid method.")); } D__.free(); // Free the memory now members.free(); // (not strictly necessary). SEXP m; // return field "merge" PROTECT(m = NEW_INTEGER(2*(N-1))); int * const merge = INTEGER_POINTER(m); SEXP dim_m; // Specify that m is an (N-1)×2 matrix PROTECT(dim_m = NEW_INTEGER(2)); INTEGER(dim_m)[0] = N-1; INTEGER(dim_m)[1] = 2; SET_DIM(m, dim_m); SEXP h; // return field "height" PROTECT(h = NEW_NUMERIC(N-1)); double * const height = NUMERIC_POINTER(h); SEXP o; // return fiels "order' PROTECT(o = NEW_INTEGER(N)); int * const order = INTEGER_POINTER(o); if (method==METHOD_METR_CENTROID || method==METHOD_METR_MEDIAN) generate_R_dendrogram<true>(merge, height, order, Z2, N); else generate_R_dendrogram<false>(merge, height, order, Z2, N); SEXP n; // names PROTECT(n = NEW_CHARACTER(3)); SET_STRING_ELT(n, 0, COPY_TO_USER_STRING("merge")); SET_STRING_ELT(n, 1, COPY_TO_USER_STRING("height")); SET_STRING_ELT(n, 2, COPY_TO_USER_STRING("order")); PROTECT(r = NEW_LIST(3)); // field names in the output list SET_ELEMENT(r, 0, m); SET_ELEMENT(r, 1, h); SET_ELEMENT(r, 2, o); SET_NAMES(r, n); UNPROTECT(6); // m, dim_m, h, o, r, n } // try catch (const std::bad_alloc&) { Rf_error( "Memory overflow."); } catch(const std::exception& e){ Rf_error( e.what() ); } catch(const nan_error&){ Rf_error("NaN dissimilarity value."); } #ifdef FE_INVALID catch(const fenv_error&){ Rf_error( "NaN dissimilarity value in intermediate results."); } #endif catch(...){ Rf_error( "C++ exception (unknown reason)." ); } return r; }
//This function will calculate the Jocobian for the errors SEXP jacobian_(SEXP X, SEXP n, SEXP p, SEXP theta, SEXP neurons,SEXP J, SEXP reqCores) { int i,j,k; double z,dtansig; double *pX; double *ptheta; double *pJ; int rows, columns, nneurons; SEXP list; rows=INTEGER_VALUE(n); columns=INTEGER_VALUE(p); nneurons=INTEGER_VALUE(neurons); PROTECT(X=AS_NUMERIC(X)); pX=NUMERIC_POINTER(X); PROTECT(theta=AS_NUMERIC(theta)); ptheta=NUMERIC_POINTER(theta); PROTECT(J=AS_NUMERIC(J)); pJ=NUMERIC_POINTER(J); for(i=0; i<rows; i++) { //Rprintf("i=%d\n",i); for(k=0; k<nneurons; k++) { z=0; for(j=0;j<columns;j++) { z+=pX[i+(j*rows)]*ptheta[(columns+2)*k+j+2]; } z+=ptheta[(columns+2)*k+1]; dtansig=pow(sech(z),2.0); /* Derivative with respect to the weight */ pJ[i+(((columns+2)*k)*rows)]=-tansig(z); /* Derivative with respect to the bias */ pJ[i+(((columns+2)*k+1)*rows)]=-ptheta[(columns+2)*k]*dtansig; /* Derivate with respect to the betas */ for(j=0; j<columns;j++) { pJ[i+(((columns+2)*k+j+2)*rows)]=-ptheta[(columns+2)*k]*dtansig*pX[i+(j*rows)]; } } } PROTECT(list=allocVector(VECSXP,1)); SET_VECTOR_ELT(list,0,J); UNPROTECT(4); return(list); }
SEXP do_rprocess (SEXP object, SEXP xstart, SEXP times, SEXP params, SEXP offset, SEXP gnsi) { int nprotect = 0; int *xdim, nvars, npars, nreps, nrepsx, ntimes, off; SEXP X, Xoff, copy, fn, fcall, rho; SEXP dimXstart, dimP, dimX; PROTECT(gnsi = duplicate(gnsi)); nprotect++; ntimes = length(times); if (ntimes < 2) { error("rprocess error: length(times)==0: no transitions, no work to do"); } off = *(INTEGER(AS_INTEGER(offset))); if ((off < 0)||(off>=ntimes)) error("illegal 'offset' value %d",off); PROTECT(xstart = as_matrix(xstart)); nprotect++; PROTECT(dimXstart = GET_DIM(xstart)); nprotect++; xdim = INTEGER(dimXstart); nvars = xdim[0]; nrepsx = xdim[1]; PROTECT(params = as_matrix(params)); nprotect++; PROTECT(dimP = GET_DIM(params)); nprotect++; xdim = INTEGER(dimP); npars = xdim[0]; nreps = xdim[1]; if (nrepsx > nreps) { // more ICs than parameters if (nrepsx % nreps != 0) { error("rprocess error: larger number of replicates is not a multiple of smaller"); } else { double *src, *tgt; int dims[2]; int j, k; dims[0] = npars; dims[1] = nrepsx; PROTECT(copy = duplicate(params)); nprotect++; PROTECT(params = makearray(2,dims)); nprotect++; setrownames(params,GET_ROWNAMES(GET_DIMNAMES(copy)),2); src = REAL(copy); tgt = REAL(params); for (j = 0; j < nrepsx; j++) { for (k = 0; k < npars; k++, tgt++) { *tgt = src[k+npars*(j%nreps)]; } } } nreps = nrepsx; } else if (nrepsx < nreps) { // more parameters than ICs if (nreps % nrepsx != 0) { error("rprocess error: larger number of replicates is not a multiple of smaller"); } else { double *src, *tgt; int dims[2]; int j, k; dims[0] = nvars; dims[1] = nreps; PROTECT(copy = duplicate(xstart)); nprotect++; PROTECT(xstart = makearray(2,dims)); nprotect++; setrownames(xstart,GET_ROWNAMES(GET_DIMNAMES(copy)),2); src = REAL(copy); tgt = REAL(xstart); for (j = 0; j < nreps; j++) { for (k = 0; k < nvars; k++, tgt++) { *tgt = src[k+nvars*(j%nrepsx)]; } } } } // extract the process function PROTECT(fn = GET_SLOT(object,install("rprocess"))); nprotect++; // construct the call PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++; PROTECT(fcall = LCONS(gnsi,fcall)); nprotect++; SET_TAG(fcall,install(".getnativesymbolinfo")); PROTECT(fcall = LCONS(GET_SLOT(object,install("zeronames")),fcall)); nprotect++; SET_TAG(fcall,install("zeronames")); PROTECT(fcall = LCONS(GET_SLOT(object,install("covar")),fcall)); nprotect++; SET_TAG(fcall,install("covar")); PROTECT(fcall = LCONS(GET_SLOT(object,install("tcovar")),fcall)); nprotect++; SET_TAG(fcall,install("tcovar")); PROTECT(fcall = LCONS(params,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(AS_NUMERIC(times),fcall)); nprotect++; SET_TAG(fcall,install("times")); PROTECT(fcall = LCONS(xstart,fcall)); nprotect++; SET_TAG(fcall,install("xstart")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; PROTECT(rho = (CLOENV(fn))); nprotect++; // environment of the function PROTECT(X = eval(fcall,rho)); nprotect++; // do the call PROTECT(dimX = GET_DIM(X)); nprotect++; if ((isNull(dimX)) || (length(dimX) != 3)) { error("rprocess error: user 'rprocess' must return a rank-3 array"); } xdim = INTEGER(dimX); if ((xdim[0] != nvars) || (xdim[1] != nreps) || (xdim[2] != ntimes)) { error("rprocess error: user 'rprocess' must return a %d x %d x %d array",nvars,nreps,ntimes); } if (isNull(GET_ROWNAMES(GET_DIMNAMES(X)))) { error("rprocess error: user 'rprocess' must return an array with rownames"); } if (off > 0) { xdim[2] -= off; PROTECT(Xoff = makearray(3,xdim)); nprotect++; setrownames(Xoff,GET_ROWNAMES(GET_DIMNAMES(X)),3); memcpy(REAL(Xoff),REAL(X)+off*nvars*nreps,(ntimes-off)*nvars*nreps*sizeof(double)); UNPROTECT(nprotect); return Xoff; } else { UNPROTECT(nprotect); return X; } }
/********************************************************************** * C Code Documentation ************************************************ ********************************************************************** NAME time_time_add DESCRIPTION Add or subtract two time or time span objects. To be called from R as \\ {\tt .Call("time_time_add", time1, time2, add.sign, ret.class) } where TIMECLASS is replaced by the name of the time or time span classes passed in those arguments. ARGUMENTS IARG time1 The first R time or time span vector object IARG time2 The second R time or time span vector object IARG sign Either +1. or -1., to add or subtract the second IARG ret_class Return class, as a character string. RETURN Returns a time or time span vector (depending on ret_class) that is the sum or difference of the input time and time span vectors. ALGORITHM Each element of the second object is added to or subtracted from the corresponding element of the first object, by combining their days and milliseconds and then carrying milliseconds over into days as necessary using the adjust_time or adjust_span functions. No special time zones or formats are put on the returned object. If one of the two vectors has a length that is a multiple of the other, the shorter one is repeated. EXCEPTIONS NOTE See also: time_num_op, time_rel_add **********************************************************************/ SEXP time_time_add( SEXP time1, SEXP time2, SEXP sign, SEXP ret_class ) { SEXP ret; double *in_sign; Sint *in_days1, *in_ms1, *in_days2, *in_ms2, *out_days, *out_ms; Sint i, lng1, lng2, lng, ind1, ind2, sign_na, is_span, tmp; const char *in_class; /* get the desired parts of the time objects */ if( !time_get_pieces( time1, NULL, &in_days1, &in_ms1, &lng1, NULL, NULL, NULL )) error( "Invalid time1 argument in C function time_time_add" ); if( !time_get_pieces( time2, NULL, &in_days2, &in_ms2, &lng2, NULL, NULL, NULL )) error( "Invalid time2 argument in C function time_time_add" ); if(lng1 && lng2 && ( lng1 % lng2 ) && ( lng2 % lng1 )) error( "Length of longer operand is not a multiple of length of shorter in C function time_time_add" ); /* get the sign and class */ PROTECT(sign = AS_NUMERIC(sign)); in_sign = REAL(sign); if( length(sign) < 1L ){ UNPROTECT(5); error( "Problem extracting sign argument in C function time_time_add" ); } sign_na = (Sint) ISNA( *in_sign ); if( !isString(ret_class) || length(ret_class) < 1L){ UNPROTECT(5); error( "Problem extracting class argument in C function time_time_add" ); } in_class = (char *) CHAR(STRING_ELT(ret_class, 0)); /* create output time or time span object */ if( !lng1 || !lng2 ) lng = 0; else if( lng2 > lng1 ) lng = lng2; else lng = lng1; is_span = 1; if( !strcmp( in_class, TIME_CLASS_NAME )) { is_span = 0; PROTECT(ret = time_create_new( lng, &out_days, &out_ms )); } else if( !strcmp( in_class, TSPAN_CLASS_NAME )) PROTECT(ret = tspan_create_new( lng, &out_days, &out_ms )); else{ UNPROTECT(5); error( "Unknown class argument in C function time_time_add" ); } if( !ret || !out_days || !out_ms ) error( "Could not create return object in C function time_time_add" ); /* go through input and add */ for( i = 0; i < lng; i++ ) { ind1 = i % lng1; ind2 = i % lng2; /* check for NA */ if( sign_na || in_days1[ind1] ==NA_INTEGER || in_ms1[ind1] ==NA_INTEGER || in_days2[ind2] ==NA_INTEGER || in_ms2[ind2] ==NA_INTEGER) { out_days[i] = NA_INTEGER; out_ms[i] = NA_INTEGER; continue; } /* add and adjust output */ out_days[i] = in_days1[ind1] + *in_sign * in_days2[ind2]; out_ms[i] = in_ms1[ind1] + *in_sign * in_ms2[ind2]; if( is_span ) tmp = adjust_span( &(out_days[i]), &(out_ms[i] )); else tmp = adjust_time( &(out_days[i]), &(out_ms[i] )); if( !tmp ) { out_days[i] = NA_INTEGER; out_ms[i] = NA_INTEGER; continue; } } UNPROTECT(6); //2+4 from time_get_pieces return ret; }
SEXP R_THD_write_dset(SEXP Sfname, SEXP Sdset, SEXP Opts) { SEXP Rdset, brik, head, names, opt, node_list; int i=0, ip=0, sb, cnt=0, scale = 1, overwrite=0, addFDR=0, kparts=2, *iv=NULL; char *fname = NULL, *head_str, *stmp=NULL, *hist=NULL; NI_group *ngr=NULL; NI_element *nel=NULL; char *listels[3] = {"head","brk","index_list"}; /* the brk is on purpose for backward compatibility */ double *dv=NULL; float *fv=NULL; THD_3dim_dataset *dset = NULL; int debug=0; if (!debug) debug = get_odebug(); /* get the options list, maybe */ PROTECT(Opts = AS_LIST(Opts)); if ((opt = getListElement(Opts,"debug")) != R_NilValue) { debug = (int)INTEGER_VALUE(opt); if (debug>2) set_odebug(debug); if (debug > 1) INFO_message("Debug is %d\n", debug); } /* get the filename */ PROTECT(Sfname = AS_CHARACTER(Sfname)); fname = R_alloc(strlen(CHAR(STRING_ELT(Sfname,0)))+1, sizeof(char)); strcpy(fname, CHAR(STRING_ELT(Sfname,0))); if (debug >1) INFO_message("Output filename %s\n" , fname); /* get the dset structure elements */ PROTECT(Rdset = AS_LIST(Sdset)); if ((head = AS_CHARACTER(getListElement(Rdset,"head"))) == R_NilValue) { ERROR_message("No header found"); UNPROTECT(3); return(R_NilValue); } if (debug > 1) INFO_message("First head element %s\n" , CHAR(STRING_ELT(head,0))); if ((brik = AS_NUMERIC(getListElement(Rdset,"brk"))) == R_NilValue) { ERROR_message("No brick found"); UNPROTECT(3); return(R_NilValue); } dv = NUMERIC_POINTER(brik); if (debug > 1) INFO_message("First brik value %f\n" , dv[0]); ngr = NI_new_group_element(); NI_rename_group(ngr, "AFNI_dataset" ); NI_set_attribute(ngr,"AFNI_prefix", fname); if ((opt = getListElement(Opts,"idcode")) != R_NilValue) { opt = AS_CHARACTER(opt); stmp = (char *)(CHAR(STRING_ELT(opt,0))); if (stmp && !strcmp(stmp,"SET_AT_WRITE_FILENAME")) { stmp = UNIQ_hashcode(fname); NI_set_attribute(ngr, "AFNI_idcode", stmp); free(stmp); } else if (stmp && !strcmp(stmp,"SET_AT_WRITE_RANDOM")) { stmp = UNIQ_idcode() ; NI_set_attribute(ngr, "AFNI_idcode", stmp); free(stmp); } else if (stmp) { NI_set_attribute(ngr, "AFNI_idcode", (char *)(CHAR(STRING_ELT(opt,0)))); } } if ((opt = getListElement(Opts,"scale")) != R_NilValue) { scale = (int)INTEGER_VALUE(opt); if (debug > 1) INFO_message("Scale is %d\n", scale); } if ((opt = getListElement(Opts,"overwrite")) != R_NilValue) { overwrite = (int)INTEGER_VALUE(opt); if (debug > 1) INFO_message("overwrite is %d\n", overwrite); THD_force_ok_overwrite(overwrite) ; if (overwrite) THD_set_quiet_overwrite(1); } if ((opt = getListElement(Opts,"addFDR")) != R_NilValue) { addFDR = (int)INTEGER_VALUE(opt); if (debug > 1) INFO_message("addFDR is %d\n", addFDR); } PROTECT(opt = getListElement(Opts,"hist")); if ( opt != R_NilValue) { opt = AS_CHARACTER(opt); hist = R_alloc(strlen(CHAR(STRING_ELT(opt,0)))+1, sizeof(char)); strcpy(hist, CHAR(STRING_ELT(opt,0))); if (debug > 1) INFO_message("hist is %s\n", hist); } UNPROTECT(1); for (ip=0,i=0; i<length(head); ++i) { head_str = (char *)CHAR(STRING_ELT(head,i)); if (debug > 1) { INFO_message("Adding %s\n", head_str); } nel = NI_read_element_fromstring(head_str); if (!nel->vec) { ERROR_message("Empty attribute vector for\n%s\n" "This is not expected.\n", head_str); UNPROTECT(3); return(R_NilValue); } NI_add_to_group(ngr,nel); } if (debug > 1) INFO_message("Creating dset header\n"); if (!(dset = THD_niml_to_dataset(ngr, 1))) { ERROR_message("Failed to create header"); UNPROTECT(3); return(R_NilValue); } if (debug > 2) { INFO_message("Have header of %d, %d, %d, %d, scale=%d\n", DSET_NX(dset), DSET_NY(dset), DSET_NZ(dset), DSET_NVALS(dset), scale); } for (i=0; i<DSET_NVALS(dset); ++i) { if (debug > 2) { INFO_message("Putting values in sub-brick %d, type %d\n", i, DSET_BRICK_TYPE(dset,i)); } if ( ( DSET_BRICK_TYPE(dset,i) == MRI_byte || DSET_BRICK_TYPE(dset,i) == MRI_short ) ) { EDIT_substscale_brick(dset, i, MRI_double, dv+i*DSET_NVOX(dset), DSET_BRICK_TYPE(dset,i), scale ? -1.0:1.0); } else if ( DSET_BRICK_TYPE(dset,i) == MRI_double ) { EDIT_substitute_brick(dset, i, MRI_double, dv+i*DSET_NVOX(dset)); } else if ( DSET_BRICK_TYPE(dset,i) == MRI_float ) { float *ff=(float*)calloc(DSET_NVOX(dset), sizeof(float)); double *dvi=dv+i*DSET_NVOX(dset); for (ip=0; ip<DSET_NVOX(dset); ++ip) { ff[ip] = dvi[ip]; } EDIT_substitute_brick(dset, i, MRI_float, ff); } } /* THD_update_statistics( dset ) ; */ if (addFDR) { DSET_BRICK_FDRCURVE_ALLKILL(dset) ; DSET_BRICK_MDFCURVE_ALLKILL(dset) ; /* 22 Oct 2008 */ if( addFDR > 0 ){ int nFDRmask=0; /* in the future, perhaps allow for a mask */ byte *FDRmask=NULL; /* to be sent in also, for now, mask is exact */ /* 0 voxels . */ mri_fdr_setmask( (nFDRmask == DSET_NVOX(dset)) ? FDRmask : NULL ) ; ip = THD_create_all_fdrcurves(dset) ; if( ip > 0 ){ if (debug) ININFO_message("created %d FDR curve%s in dataset header", ip,(ip==1)?"\0":"s") ; } else { if (debug) ININFO_message("failed to create FDR curves in dataset header") ; } } } /* Do we have an index_list? */ if ((node_list=AS_INTEGER(getListElement(Rdset,"index_list")))!=R_NilValue) { iv = INTEGER_POINTER(node_list); if (debug > 1) INFO_message("First node index value %d, total (%d)\n", iv[0], length(node_list)); dset->dblk->nnodes = length(node_list); dset->dblk->node_list = (int *)XtMalloc(dset->dblk->nnodes * sizeof(int)); memcpy(dset->dblk->node_list, iv, dset->dblk->nnodes*sizeof(int)); } if (hist) { tross_Append_History(dset, hist); } DSET_write(dset); UNPROTECT(3); return(R_NilValue); }
/********************************************************************** * C Code Documentation ************************************************ ********************************************************************** NAME time_num_op DESCRIPTION Perform an arithmetic operation between a time or time span and a numeric. Supported operations are "+", "-", "*", and "/". To be called from R as \\ {\tt .Call("time_num_op", time_vec, num_vec, op) } where TIMECLASS is replaced by the name of the time or time span class. ARGUMENTS IARG time_vec The R time or time span vector object IARG num_vec The numeric vector object IARG op Character string giving the operation RETURN Returns a time or time span vector (same as passed in class) that is the result of time_vec op num_vec. ALGORITHM Addition and subtraction are performed by combining the integer part of the numeric with the julian days of the time and the fractional part of the numeric (converted from fraction of a day to milliseconds) to the milliseconds of the time object. Multiplication and division are performed by converting the time object to a numeric with its integer part the number of days and fractional part the fraction of the day (found by the ms_to_fraction function), multiplying or dividing, and then converting back. No special time zones or formats are put on the returned object. If one of the two vectors has a length that is a multiple of the other, the shorter one is repeated. EXCEPTIONS NOTE See also: time_time_add, time_rel_add **********************************************************************/ SEXP time_num_op( SEXP time_vec, SEXP num_vec, SEXP op ) { SEXP ret; double *in_nums, tmpdbl; Sint *in_days, *in_ms, *out_days, *out_ms, add_sign; Sint i, lng1, lng2, lng, ind1, ind2, is_span, is_ok, tmp; const char *in_op; /* get the desired parts of the time object */ if( !time_get_pieces( time_vec, NULL, &in_days, &in_ms, &lng1, NULL, NULL, NULL )) error( "Invalid time argument in C function time_num_op" ); /* extract other input data */ PROTECT( num_vec = (SEXP) AS_NUMERIC(num_vec) ); if( (lng2 = length(num_vec)) < 1L){ UNPROTECT(3); error( "Problem extracting numeric argument in C function time_num_op" ); } in_nums = REAL(num_vec); if(lng1 && lng2 && ( lng1 % lng2 ) && ( lng2 % lng1 )){ UNPROTECT(3); error( "Length of longer operand is not a multiple of length of shorter in C function time_num_op" ); } if( !isString(op) || length(op) < 1L){ UNPROTECT(3); error( "Problem extracting operation argument in C function time_num_op" ); } if( length(op) > 1L ) warning( "Using only the first string in operation argument in C function time_num_op" ); in_op = CHAR(STRING_ELT(op, 0)); if(( *in_op != '*' ) && ( *in_op != '+' ) && ( *in_op != '-' ) && ( *in_op != '/' )){ UNPROTECT(3); error( "Unknown operator in C function time_num_op" ); } /* create output time or time span object */ if( !lng1 || !lng2 ) lng = 0; else if( lng2 > lng1 ) lng = lng2; else lng = lng1; is_span = 1; if( checkClass( time_vec, IS_TIME_CLASS, 1L )) { is_span = 0; PROTECT(ret = time_create_new( lng, &out_days, &out_ms )); } else if( checkClass( time_vec, IS_TSPAN_CLASS, 1L )){ PROTECT(ret = tspan_create_new( lng, &out_days, &out_ms )); } else { UNPROTECT(3); error( "Unknown class on first argument in C function time_num_op" ); } if( !out_days || !out_ms || !ret ){ UNPROTECT(4); error( "Could not create return object in C function time_num_op" ); } /* go through input and perform operation */ for( i = 0; i < lng; i++ ) { ind1 = i % lng1; ind2 = i % lng2; /* check for NA */ if( in_days[ind1] == NA_INTEGER || in_ms[ind1] == NA_INTEGER || ISNA( in_nums[ind2])) { out_days[i] = NA_INTEGER; out_ms[i] = NA_INTEGER; continue; } /* operate and adjust output */ add_sign = 1; is_ok = 1; switch( *in_op ) { case '-': add_sign = -1; /*LINTED: Meant to fall through here */ case '+': /* add/subtract integer part to days and fractional part to ms */ out_days[i] = in_days[ind1] + add_sign * (Sint) floor( in_nums[ind2] ); is_ok = ms_from_fraction( in_nums[ ind2 ] - floor( in_nums[ind2] ), &(out_ms[i])); out_ms[i] = in_ms[ind1] + add_sign * out_ms[i]; break; case '*': /* convert time to numeric, multiply, convert back */ if( in_ms[ind1] > 0 ) is_ok = ms_to_fraction( in_ms[ind1], &tmpdbl ); else { is_ok = ms_to_fraction( - in_ms[ind1], &tmpdbl ); tmpdbl = -tmpdbl; } tmpdbl = ( tmpdbl + in_days[ind1] ) * in_nums[ind2]; out_days[i] = (Sint) floor( tmpdbl ); is_ok = is_ok && ms_from_fraction( tmpdbl - out_days[i], &out_ms[i] ); break; case '/': /* convert time to numeric, divide, convert back */ if( in_ms[ind1] > 0 ) is_ok = ms_to_fraction( in_ms[ind1], &tmpdbl ); else { is_ok = ms_to_fraction( - in_ms[ind1], &tmpdbl ); tmpdbl = -tmpdbl; } if( in_nums[ind2] == 0 ) is_ok = 0; else tmpdbl = ( tmpdbl + in_days[ind1] ) / in_nums[ind2]; out_days[i] = (Sint) floor( tmpdbl ); is_ok = is_ok && ms_from_fraction( tmpdbl - out_days[i], &out_ms[i] ); break; default: is_ok = 0; } if( !is_ok ) { out_days[i] = NA_INTEGER; out_ms[i] = NA_INTEGER; continue; } if( is_span ) tmp = adjust_span( &(out_days[i]), &(out_ms[i] )); else tmp = adjust_time( &(out_days[i]), &(out_ms[i] )); if( !tmp ) { out_days[i] = NA_INTEGER; out_ms[i] = NA_INTEGER; continue; } } UNPROTECT(4); //2+2 from time_get_pieces return ret; }
SEXP do_dmeasure (SEXP object, SEXP y, SEXP x, SEXP times, SEXP params, SEXP log, SEXP gnsi) { int nprotect = 0; pompfunmode mode = undef; int give_log; int ntimes, nvars, npars, ncovars, nreps, nrepsx, nrepsp, nobs; SEXP Snames, Pnames, Cnames, Onames; SEXP pompfun; SEXP cvec, tvec = R_NilValue; SEXP xvec = R_NilValue, yvec = R_NilValue, pvec = R_NilValue; SEXP fn, ans, fcall, rho = R_NilValue; SEXP F; int *sidx = 0, *pidx = 0, *cidx = 0, *oidx = 0; int *dim; struct lookup_table covariate_table; pomp_measure_model_density *ff = NULL; PROTECT(times = AS_NUMERIC(times)); nprotect++; ntimes = length(times); if (ntimes < 1) errorcall(R_NilValue,"in 'dmeasure': length('times') = 0, no work to do"); PROTECT(y = as_matrix(y)); nprotect++; dim = INTEGER(GET_DIM(y)); nobs = dim[0]; if (ntimes != dim[1]) errorcall(R_NilValue,"in 'dmeasure': length of 'times' and 2nd dimension of 'y' do not agree"); PROTECT(x = as_state_array(x)); nprotect++; dim = INTEGER(GET_DIM(x)); nvars = dim[0]; nrepsx = dim[1]; if (ntimes != dim[2]) errorcall(R_NilValue,"in 'dmeasure': length of 'times' and 3rd dimension of 'x' do not agree"); PROTECT(params = as_matrix(params)); nprotect++; dim = INTEGER(GET_DIM(params)); npars = dim[0]; nrepsp = dim[1]; nreps = (nrepsp > nrepsx) ? nrepsp : nrepsx; if ((nreps % nrepsp != 0) || (nreps % nrepsx != 0)) errorcall(R_NilValue,"in 'dmeasure': larger number of replicates is not a multiple of smaller"); PROTECT(Onames = GET_ROWNAMES(GET_DIMNAMES(y))); nprotect++; PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++; give_log = *(INTEGER(AS_INTEGER(log))); // set up the covariate table covariate_table = make_covariate_table(object,&ncovars); // vector for interpolated covariates PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++; SET_NAMES(cvec,Cnames); // extract the user-defined function PROTECT(pompfun = GET_SLOT(object,install("dmeasure"))); nprotect++; PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++; // extract 'userdata' as pairlist PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++; // first do setup switch (mode) { case Rfun: // R function PROTECT(tvec = NEW_NUMERIC(1)); nprotect++; PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++; PROTECT(yvec = NEW_NUMERIC(nobs)); nprotect++; PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++; SET_NAMES(xvec,Snames); SET_NAMES(yvec,Onames); SET_NAMES(pvec,Pnames); // set up the function call PROTECT(fcall = LCONS(cvec,fcall)); nprotect++; SET_TAG(fcall,install("covars")); PROTECT(fcall = LCONS(AS_LOGICAL(log),fcall)); nprotect++; SET_TAG(fcall,install("log")); PROTECT(fcall = LCONS(pvec,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(tvec,fcall)); nprotect++; SET_TAG(fcall,install("t")); PROTECT(fcall = LCONS(xvec,fcall)); nprotect++; SET_TAG(fcall,install("x")); PROTECT(fcall = LCONS(yvec,fcall)); nprotect++; SET_TAG(fcall,install("y")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; // get the function's environment PROTECT(rho = (CLOENV(fn))); nprotect++; break; case native: // native code // construct state, parameter, covariate, observable indices oidx = INTEGER(PROTECT(name_index(Onames,pompfun,"obsnames","observables"))); nprotect++; sidx = INTEGER(PROTECT(name_index(Snames,pompfun,"statenames","state variables"))); nprotect++; pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames","parameters"))); nprotect++; cidx = INTEGER(PROTECT(name_index(Cnames,pompfun,"covarnames","covariates"))); nprotect++; // address of native routine *((void **) (&ff)) = R_ExternalPtrAddr(fn); break; default: errorcall(R_NilValue,"in 'dmeasure': unrecognized 'mode'"); // # nocov break; } // create array to store results { int dim[2] = {nreps, ntimes}; const char *dimnm[2] = {"rep","time"}; PROTECT(F = makearray(2,dim)); nprotect++; fixdimnames(F,dimnm,2); } // now do computations switch (mode) { case Rfun: // R function { int first = 1; double *ys = REAL(y); double *xs = REAL(x); double *ps = REAL(params); double *cp = REAL(cvec); double *tp = REAL(tvec); double *xp = REAL(xvec); double *yp = REAL(yvec); double *pp = REAL(pvec); double *ft = REAL(F); double *time = REAL(times); int j, k; for (k = 0; k < ntimes; k++, time++, ys += nobs) { // loop over times R_CheckUserInterrupt(); // check for user interrupt *tp = *time; // copy the time table_lookup(&covariate_table,*time,cp); // interpolate the covariates memcpy(yp,ys,nobs*sizeof(double)); for (j = 0; j < nreps; j++, ft++) { // loop over replicates // copy the states and parameters into place memcpy(xp,&xs[nvars*((j%nrepsx)+nrepsx*k)],nvars*sizeof(double)); memcpy(pp,&ps[npars*(j%nrepsp)],npars*sizeof(double)); if (first) { // evaluate the call PROTECT(ans = eval(fcall,rho)); nprotect++; if (LENGTH(ans) != 1) errorcall(R_NilValue,"in 'dmeasure': user 'dmeasure' returns a vector of length %d when it should return a scalar",LENGTH(ans)); *ft = *(REAL(AS_NUMERIC(ans))); first = 0; } else { *ft = *(REAL(AS_NUMERIC(eval(fcall,rho)))); } } } } break; case native: // native code set_pomp_userdata(fcall); { double *yp = REAL(y); double *xs = REAL(x); double *ps = REAL(params); double *cp = REAL(cvec); double *ft = REAL(F); double *time = REAL(times); double *xp, *pp; int j, k; for (k = 0; k < ntimes; k++, time++, yp += nobs) { // loop over times R_CheckUserInterrupt(); // check for user interrupt // interpolate the covar functions for the covariates table_lookup(&covariate_table,*time,cp); for (j = 0; j < nreps; j++, ft++) { // loop over replicates xp = &xs[nvars*((j%nrepsx)+nrepsx*k)]; pp = &ps[npars*(j%nrepsp)]; (*ff)(ft,yp,xp,pp,give_log,oidx,sidx,pidx,cidx,ncovars,cp,*time); } } } unset_pomp_userdata(); break; default: errorcall(R_NilValue,"in 'dmeasure': unrecognized 'mode'"); // # nocov break; } UNPROTECT(nprotect); return F; }
SEXP biosonics_ping(SEXP bytes, SEXP Rspp, SEXP Rns, SEXP Rtype) { PROTECT(bytes = AS_RAW(bytes)); PROTECT(Rspp = AS_NUMERIC(Rspp)); int spp = (int)floor(0.5 + *REAL(Rspp)); PROTECT(Rns = AS_NUMERIC(Rns)); int ns = (int)floor(0.5 + *REAL(Rns)); PROTECT(Rtype = AS_NUMERIC(Rtype)); int type = (int)floor(0.5 + *REAL(Rtype)); //double *typep = REAL(type); //int beam = (int)floor(0.5 + *typep); #ifdef DEBUG Rprintf("biosonics_ping() decoded type:%d, spp:%d, ns:%d\n", type, spp, ns); #endif int byte_per_sample = 2; if (type == 1 || type == 2) { byte_per_sample = 4; } unsigned int nbytes = LENGTH(bytes); #ifdef DEBUG Rprintf("nbytes: %d (should be 2*ns for single-beam or 4*ns for split- and dual-beam)\n", nbytes); #endif unsigned char *bytep = RAW(bytes); SEXP res; PROTECT(res = allocVector(VECSXP, 3)); SEXP res_names; PROTECT(res_names = allocVector(STRSXP, 3)); SEXP res_a; PROTECT(res_a = allocVector(REALSXP, spp)); SEXP res_b; PROTECT(res_b = allocVector(REALSXP, spp)); SEXP res_c; PROTECT(res_c = allocVector(REALSXP, spp)); // Get static storage; FIXME: is this thread-safe? biosonics_allocate_storage(spp, byte_per_sample); #ifdef DEBUG Rprintf("allocVector(REALSXP, %d)\n", spp); #endif double *resap = REAL(res_a); double *resbp = REAL(res_b); double *rescp = REAL(res_c); if (type == 0) { // single-beam rle(bytep, ns, spp, 2); for (int k = 0; k < spp; k++) { resap[k] = biosonic_float(buffer[byte_per_sample * k], buffer[1 + byte_per_sample * k]); resbp[k] = 0.0; rescp[k] = 0.0; } } else if (type == 1) { // dual-beam rle(bytep, ns, spp, 4); for (int k = 0; k < spp; k++) { // Quote [1 p37 re dual-beam]: "For an RLE-expanded sample x, the low-order // word (ie, (USHORT)(x & 0x0000FFFF)) contains the narrow-beam data. The // high-order word (ie, (USHORT)((x & 0xFFFF0000) >> 16)) contains the // wide beam data." resap[k] = biosonic_float(buffer[ byte_per_sample * k], buffer[1 + byte_per_sample * k]); resbp[k] = biosonic_float(buffer[2 + byte_per_sample * k], buffer[3 + byte_per_sample * k]); resbp[k] = 0.0; } } else if (type == 2) { // split-beam rle(bytep, ns, spp, 4); for (int k = 0; k < spp; k++) { // Quote [1 p38 split-beam e.g. 01-Fish.dt4 example]: "the low-order word // (ie, (USHORT)(x & 0x0000FFFF)) contains the amplitude data. The // high-order byte (ie, (TINY)((x & 0xFF000000) >> 24)) contains the // raw X-axis angle data. The other byte // (ie, (TINY)((x & 0x00FF0000) >> 16)) contains the raw Y-axis angle data. resap[k] = biosonic_float(buffer[byte_per_sample * k], buffer[1 + byte_per_sample * k]); resbp[k] = (double)buffer[2 + byte_per_sample * k]; rescp[k] = (double)buffer[3 + byte_per_sample * k]; } } else { error("unknown type, %d", type); } SET_VECTOR_ELT(res, 0, res_a); SET_VECTOR_ELT(res, 1, res_b); SET_VECTOR_ELT(res, 2, res_c); SET_STRING_ELT(res_names, 0, mkChar("a")); SET_STRING_ELT(res_names, 1, mkChar("b")); SET_STRING_ELT(res_names, 2, mkChar("c")); setAttrib(res, R_NamesSymbol, res_names); UNPROTECT(9); return(res); }
/*! \author Hanne Rognebakke \brief Makes a struct of type containing Makes a struct of type Data_orig (see caa.h for definition) Space allocated in this routine is reallocated in re_makedata_COST */ int makedata_COST(SEXP i_COSTList, Data_orig **o_D_orig, Data_COST **o_D_COST) { Data_orig *D_orig; Data_COST *D_COST; Data_obs *D_obs; Data_mland *D_mland; int i,f,h,n,s,t; int l_int,n_trip,n_fish,N_int,nHaul,nSize; int ind,ind_alk,ind_fish,ind_fish_l,ind_haul,ind_size,ind_orig,ind_t; long *lengths; double l; double *P_l,*int_len; SEXP elmt = R_NilValue; FILE *caa_debug; #ifdef DEBUG_COST caa_debug = fopen("caa_debug_COST.txt","w"); #endif /* Allocating space for COST object */ D_COST = CALLOC(1,Data_COST); /* Observer data */ D_obs = CALLOC(1,Data_obs); if(!Rf_isNull(elmt = getListElement(i_COSTList, "n_trip_obs"))) D_obs->n_trip = INTEGER_VALUE(elmt); // number of trips with observer data if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_trip_obs"))) D_obs->num_trip = INTEGER_POINTER(AS_INTEGER(elmt)); // number of hauls pr trip if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_haul_disc"))) D_obs->num_haul_disc = INTEGER_POINTER(AS_INTEGER(elmt)); // number of length-measured discarded fish pr haul if(!Rf_isNull(elmt = getListElement(i_COSTList, "season_obs"))) D_obs->season = INTEGER_POINTER(AS_INTEGER(elmt)); // observed month if(!Rf_isNull(elmt = getListElement(i_COSTList, "l_disc"))) D_obs->l_disc = NUMERIC_POINTER(AS_NUMERIC(elmt)); // length categories for discard samples if(!Rf_isNull(elmt = getListElement(i_COSTList, "lfreq_disc"))) D_obs->lfreq_disc = INTEGER_POINTER(AS_INTEGER(elmt)); // number at length for discards if(!Rf_isNull(elmt = getListElement(i_COSTList, "haulsize_disc"))) D_obs->haulsize_disc = NUMERIC_POINTER(AS_NUMERIC(elmt)); // number of discards in haul if(!Rf_isNull(elmt = getListElement(i_COSTList, "sampsize_disc"))) D_obs->sampsize_disc = NUMERIC_POINTER(AS_NUMERIC(elmt)); // number of discards sampled if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_alk_disc"))) D_obs->num_alk = INTEGER_POINTER(AS_INTEGER(elmt)); // number of discard age-length data within trip if(!Rf_isNull(elmt = getListElement(i_COSTList, "alk_l_disc"))) D_obs->alk_l = NUMERIC_POINTER(AS_NUMERIC(elmt)); // lengths for discard age-length data if(!Rf_isNull(elmt = getListElement(i_COSTList, "alk_a_disc"))) D_obs->alk_a = INTEGER_POINTER(AS_INTEGER(elmt)); // ages for discard age-length data if(!Rf_isNull(elmt = getListElement(i_COSTList, "alk_lfreq_disc"))) D_obs->alk_lfreq = INTEGER_POINTER(AS_INTEGER(elmt)); // numbers at length for discard age-length data if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_trip_land"))) D_obs->num_trip_land = INTEGER_POINTER(AS_INTEGER(elmt)); // number of size classes pr trip with landings if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_size_land"))) D_obs->num_size_land = INTEGER_POINTER(AS_INTEGER(elmt)); // number of measured landed fish pr size class if(!Rf_isNull(elmt = getListElement(i_COSTList, "l_land"))) D_obs->l_land = NUMERIC_POINTER(AS_NUMERIC(elmt)); // length categories for landing samples if(!Rf_isNull(elmt = getListElement(i_COSTList, "lfreq_land"))) D_obs->lfreq_land = INTEGER_POINTER(AS_INTEGER(elmt)); // number at length for landings if(!Rf_isNull(elmt = getListElement(i_COSTList, "totsize_land"))) D_obs->totsize_land = NUMERIC_POINTER(AS_NUMERIC(elmt)); // total weight landed in size class if(!Rf_isNull(elmt = getListElement(i_COSTList, "sampsize_land"))) D_obs->sampsize_land = NUMERIC_POINTER(AS_NUMERIC(elmt)); // weight of landings sampled for lengths in size class /* Market landing data */ D_mland = CALLOC(1,Data_mland); if(!Rf_isNull(elmt = getListElement(i_COSTList, "n_trip_mland"))) D_mland->n_trip = INTEGER_VALUE(elmt); // number of trips with market landing data if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_trip_mland"))) D_mland->num_trip = INTEGER_POINTER(AS_INTEGER(elmt)); // number of size classes pr trip with market landings if(!Rf_isNull(elmt = getListElement(i_COSTList, "season_mland"))) D_mland->season = INTEGER_POINTER(AS_INTEGER(elmt)); // observed month if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_alk_mland"))) D_mland->num_alk = INTEGER_POINTER(AS_INTEGER(elmt)); // number of market landing age-length data within trip if(!Rf_isNull(elmt = getListElement(i_COSTList, "alk_l_mland"))) D_mland->alk_l = NUMERIC_POINTER(AS_NUMERIC(elmt)); // lengths for market landing age-length data if(!Rf_isNull(elmt = getListElement(i_COSTList, "alk_a_mland"))) D_mland->alk_a = INTEGER_POINTER(AS_INTEGER(elmt)); // ages for market landing age-length data if(!Rf_isNull(elmt = getListElement(i_COSTList, "alk_lfreq_mland"))) D_mland->alk_lfreq = INTEGER_POINTER(AS_INTEGER(elmt)); // numbers at length for market landing age-length data if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_size_mland"))) D_mland->num_size = INTEGER_POINTER(AS_INTEGER(elmt)); // number of measured market landing fish pr size class if(!Rf_isNull(elmt = getListElement(i_COSTList, "l_mland"))) D_mland->l = NUMERIC_POINTER(AS_NUMERIC(elmt)); // length categories for market landing samples if(!Rf_isNull(elmt = getListElement(i_COSTList, "lfreq_mland"))) D_mland->lfreq = INTEGER_POINTER(AS_INTEGER(elmt)); // number at length for market landings if(!Rf_isNull(elmt = getListElement(i_COSTList, "totsize_mland"))) D_mland->totsize = NUMERIC_POINTER(AS_NUMERIC(elmt)); // total weight for market landing in size class if(!Rf_isNull(elmt = getListElement(i_COSTList, "sampsize_mland"))) D_mland->sampsize = NUMERIC_POINTER(AS_NUMERIC(elmt)); // weight of market landings sampled for lengths in size class /* Allocating space for censoring parameters */ D_COST->cens = CALLOC(1,cens_struct); D_COST->cens->ncat = D_obs->n_trip+D_mland->n_trip; D_COST->cens->r = CALLOC(D_COST->cens->ncat,double); D_COST->cens->mu = CALLOC(3,double); D_COST->cens->tau = CALLOC(3,double); /* Allocating space for 'original' parameters */ if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_fish"))) n_fish = INTEGER_VALUE(elmt); n_trip = D_obs->n_trip+D_mland->n_trip; D_orig = CALLOC(1,Data_orig); D_orig->nFishBoat = CALLOC(n_trip,int); // Free ok D_orig->totage = CALLOC(n_fish,int); // Free ok D_orig->totlength = CALLOC(n_fish,double); // Free ok D_orig->replength = CALLOC(n_fish,int); // Free ok D_orig->discard = CALLOC(n_fish,int); // Free ok D_orig->landed = CALLOC(n_fish,int); // Free ok D_orig->start_noAge = CALLOC(n_trip,int); // Free ok D_orig->start_Age = CALLOC(n_trip,int); // Free ok D_orig->num_noAge = CALLOC(n_trip,int); // Free ok D_orig->haulweight = CALLOC(n_trip,double); // Free ok D_orig->season = CALLOC(n_trip,int); // Free ok D_orig->n_discard = CALLOC(n_trip,int); // Free ok D_orig->n_landed = CALLOC(n_trip,int); // Free ok if(!Rf_isNull(elmt = getListElement(i_COSTList, "n_int_len"))) D_orig->n_int_len = INTEGER_VALUE(elmt); // number of intervals for length N_int = D_orig->n_int_len; if(!Rf_isNull(elmt = getListElement(i_COSTList, "int_len_lim"))) D_orig->int_len_lim = NUMERIC_POINTER(AS_NUMERIC(elmt)); // lower limits of length-intervals if(!Rf_isNull(elmt = getListElement(i_COSTList, "int_len_vec"))) D_orig->int_len = NUMERIC_POINTER(AS_NUMERIC(elmt)); // length value for intervals lengths = CALLOC(N_int,long); // Free ok P_l = CALLOC(N_int,double); // Free ok //printf("\nStart simulate total lengths for observer data\n"); /* Simulate total lengths for observer data */ ind_fish = 0; ind_fish_l = 0; ind_haul = 0; ind_size = 0; ind_alk = 0; ind_orig = 0; ind = 0; for(t=0;t<D_obs->n_trip;t++) { /* Discard data */ D_orig->start_noAge[t] = ind_orig + D_obs->num_alk[t]; D_orig->start_Age[t] = ind_orig; D_orig->num_noAge[t] = N_int; D_orig->nFishBoat[t] = D_obs->num_alk[t]+N_int; D_orig->season[t] = D_obs->season[t]; D_orig->n_discard[t] = 0; D_orig->n_landed[t] = 0; ind_orig = D_orig->start_noAge[t]; for(f=0;f<N_int;f++) { D_orig->totage[ind_orig] = -99999; D_orig->totlength[ind_orig] = D_orig->int_len[f]; D_orig->replength[ind_orig] = 0; D_orig->discard[ind_orig] = 0; D_orig->landed[ind_orig] = 0; ind_orig++; } ind_orig = D_orig->start_noAge[t]; for(h=0;h<D_obs->num_trip[t];h++) { if(D_obs->num_haul_disc[ind_haul]>0) { nHaul = 0; for(i=0;i<N_int;i++) P_l[i] = 0.0; for(f=0;f<D_obs->num_haul_disc[ind_haul];f++) { l = D_obs->l_disc[ind_fish]; l_int = 0; while(l > D_orig->int_len_lim[l_int]) l_int++; P_l[l_int] += D_obs->lfreq_disc[ind_fish]; D_orig->replength[ind_orig+l_int] += D_obs->lfreq_disc[ind_fish]; D_orig->discard[ind_orig+l_int] += D_obs->lfreq_disc[ind_fish]; D_orig->n_discard[t] += D_obs->lfreq_disc[ind_fish]; nHaul += D_obs->lfreq_disc[ind_fish]; ind_fish++; } // convert to probabilities for(i=0;i<N_int;i++) P_l[i] /= nHaul; // number of fish to be simulated if(nHaul==0) n=0; else n = (int) nHaul*(D_obs->haulsize_disc[ind_haul]/D_obs->sampsize_disc[ind_haul]-1); my_genmul(n,P_l,N_int,lengths); for(i=0;i<N_int;i++) { D_orig->replength[ind_orig+i] += (int) lengths[i]; D_orig->discard[ind_orig+i] += (int) lengths[i]; D_orig->n_discard[t] += (int) lengths[i]; } } ind_haul++; } // put the age-length data into D_orig object for(f=0;f<D_obs->num_alk[t];f++) { D_orig->totage[ind] = D_obs->alk_a[ind_alk]; D_orig->totlength[ind] = D_obs->alk_l[ind_alk]; D_orig->replength[ind] = D_obs->alk_lfreq[ind_alk]; D_orig->discard[ind] = D_obs->alk_lfreq[ind_alk]; // remove length count for lengths with missing ages l_int = 0; while(D_obs->alk_l[ind_alk] > D_orig->int_len_lim[l_int]) l_int++; D_orig->replength[ind_orig+l_int] -= D_obs->alk_lfreq[ind_alk]; D_orig->discard[ind_orig+l_int] -= D_obs->alk_lfreq[ind_alk]; if(D_orig->replength[ind_orig+l_int]<0) { printf("trip=%d,ind_alk=%d,ind_orig=%d,replength=%d\n", t,ind_alk,ind_orig+l_int,D_orig->replength[ind_orig+l_int]); write_warning("makedata_COST:Something is wrong\n"); write_warning("age-length data not in length-only data\n"); D_orig->replength[ind_orig+l_int] = 0; D_orig->discard[ind_orig+l_int] = 0; D_orig->n_discard[t] = 0; } ind_alk++; ind++; } ind += N_int; /* Landing data */ for(s=0;s<D_obs->num_trip_land[t];s++) { // if(D_obs->num_size_land[ind_size]==0) nSize = 0; for(i=0;i<N_int;i++) P_l[i] = 0.0; for(f=0;f<D_obs->num_size_land[ind_size];f++) { l = D_obs->l_land[ind_fish_l]; l_int = 0; while(l > D_orig->int_len_lim[l_int]) l_int++; P_l[l_int] += D_obs->lfreq_land[ind_fish_l]; D_orig->replength[ind_orig+l_int] += D_obs->lfreq_land[ind_fish_l]; D_orig->landed[ind_orig+l_int] += D_obs->lfreq_land[ind_fish_l]; D_orig->n_landed[t] += D_obs->lfreq_land[ind_fish_l]; nSize += D_obs->lfreq_land[ind_fish_l]; ind_fish_l++; } // convert to probabilities for(i=0;i<N_int;i++) P_l[i] /= nSize; // number of fish to be simulated n = nSize*(D_obs->totsize_land[ind_size]/D_obs->sampsize_land[ind_size]-1); my_genmul(n,P_l,N_int,lengths); for(i=0;i<N_int;i++) { D_orig->replength[ind_orig+i] += (int) lengths[i]; D_orig->landed[ind_orig+i] += (int) lengths[i]; D_orig->n_landed[t] += (int) lengths[i]; } ind_size++; } ind_orig += N_int; } #ifdef DEBUG_COST n=0; for(t=0;t<D_obs->n_trip;t++) { fprintf(caa_debug,"t=%d,nFishBoat=%d,start_noAge=%d,num_noAge=%d\n", t,D_orig->nFishBoat[t],D_orig->start_noAge[t],D_orig->num_noAge[t]); n += D_orig->nFishBoat[t]; } fprintf(caa_debug,"n=%d,totage[i],totlength[i],replength[i]:\n",n); n=0; for(i=0;i<n_fish;i++) { fprintf(caa_debug,"i=%d,%d,%f,%d\n",i,D_orig->totage[i], exp(D_orig->totlength[i]),D_orig->replength[i]); n += D_orig->replength[i]; } fprintf(caa_debug,"n=%d\n",n); #endif //printf("\nStart simulate total lengths for market landing data\n"); ind_fish = 0; ind_size = 0; ind_alk = 0; ind_t = D_obs->n_trip; for(t=0;t<D_mland->n_trip;t++) { D_orig->start_noAge[ind_t] = ind_orig + D_mland->num_alk[t]; D_orig->start_Age[ind_t] = ind_orig; D_orig->num_noAge[ind_t] = N_int; D_orig->nFishBoat[ind_t] = D_mland->num_alk[t]+N_int; D_orig->season[ind_t] = D_mland->season[t]; D_orig->n_discard[ind_t] = 0; D_orig->n_landed[ind_t] = 0; ind_orig = D_orig->start_noAge[ind_t]; for(f=0;f<N_int;f++) { D_orig->totage[ind_orig] = -99999; D_orig->totlength[ind_orig] = D_orig->int_len[f]; D_orig->replength[ind_orig] = 0; D_orig->discard[ind_orig] = 0; D_orig->landed[ind_orig] = 0; ind_orig++; } ind_orig = D_orig->start_noAge[ind_t]; for(s=0;s<D_mland->num_trip[t];s++) { nSize = 0; for(i=0;i<N_int;i++) P_l[i] = 0.0; for(f=0;f<D_mland->num_size[ind_size];f++) { l = D_mland->l[ind_fish]; l_int = 0; while(l > D_orig->int_len_lim[l_int]) l_int++; P_l[l_int] += D_mland->lfreq[ind_fish]; D_orig->replength[ind_orig+l_int] += D_mland->lfreq[ind_fish]; D_orig->landed[ind_orig+l_int] += D_mland->lfreq[ind_fish]; D_orig->n_landed[ind_t] += D_mland->lfreq[ind_fish]; nSize += D_mland->lfreq[ind_fish]; ind_fish++; } // convert to probabilities for(i=0;i<N_int;i++) P_l[i] /= nSize; // number of fish to be simulated n = nSize*(D_mland->totsize[ind_size]/D_mland->sampsize[ind_size]-1); my_genmul(n,P_l,N_int,lengths); for(i=0;i<N_int;i++) { D_orig->replength[ind_orig+i] += (int) lengths[i]; D_orig->landed[ind_orig+i] += (int) lengths[i]; D_orig->n_landed[ind_t] += (int) lengths[i]; } ind_size++; } // put the age-length data into D_orig object for(f=0;f<D_mland->num_alk[t];f++) { D_orig->totage[ind] = D_mland->alk_a[ind_alk]; D_orig->totlength[ind] = D_mland->alk_l[ind_alk]; D_orig->replength[ind] = D_mland->alk_lfreq[ind_alk]; D_orig->landed[ind] = D_mland->alk_lfreq[ind_alk]; // remove length count for lengths with missing ages l_int = 0; while(D_mland->alk_l[ind_alk] > D_orig->int_len_lim[l_int]) l_int++; D_orig->replength[ind_orig+l_int] -= D_mland->alk_lfreq[ind_alk]; D_orig->landed[ind_orig+l_int] -= D_mland->alk_lfreq[ind_alk]; if(D_orig->replength[ind_orig+l_int]<0) { printf("trip=%d,ind_alk=%d,ind_orig=%d,replength=%d\n", t,ind_alk,ind_orig+l_int,D_orig->replength[ind_orig+l_int]); write_warning("makedata_COST:Something is wrong\n"); write_warning("age-length data not in length-only data\n"); D_orig->replength[ind_orig+l_int] = 0; D_orig->landed[ind_orig+l_int] = 0; D_orig->n_landed[ind_t] = 0; } ind_alk++; ind++; } ind += N_int; ind_orig += N_int; ind_t++; } printf("\n"); /* Allocating space and initalize simulated discards for market landing data */ if(!Rf_isNull(elmt = getListElement(i_COSTList, "n_int_len_disc"))) N_int = INTEGER_VALUE(elmt); // number of intervals for length if(!Rf_isNull(elmt = getListElement(i_COSTList, "int_len_vec_disc"))) int_len = NUMERIC_POINTER(AS_NUMERIC(elmt)); // length value for intervals if(!Rf_isNull(elmt = getListElement(i_COSTList, "int_len_lim_disc"))) D_mland->int_len_lim = NUMERIC_POINTER(AS_NUMERIC(elmt)); // length value for intervals n_fish = (N_int)*D_mland->n_trip; D_mland->N_int_disc = N_int; D_mland->l_disc = CALLOC(n_fish,double); //Free ok D_mland->lfreq_disc = CALLOC(n_fish,int); //Free ok ind = 0; for(t=0;t<D_mland->n_trip;t++) { for(f=0;f<N_int;f++) { D_mland->l_disc[ind] = int_len[f]; D_mland->lfreq_disc[ind] = 0; ind++; } } D_mland->lambda = CALLOC(D_mland->n_trip,double); //Free ok #ifdef DEBUG_COST fclose(caa_debug); #endif FREE(lengths); FREE(P_l); D_COST->obs = D_obs; D_COST->mland = D_mland; *o_D_orig = D_orig; *o_D_COST = D_COST; return(0); } /* end of makedata_COST */
SEXP fastcluster_vector(SEXP const method_, SEXP const metric_, SEXP X_, SEXP members_, SEXP p_) { SEXP r = NULL; // return value try{ /* Input checks */ // Parameter method: dissimilarity index update method PROTECT(method_); if (!IS_INTEGER(method_) || LENGTH(method_)!=1) Rf_error("'method' must be a single integer."); int method = *INTEGER_POINTER(method_) - 1; // index-0 based; if (method<METHOD_VECTOR_SINGLE || method>METHOD_VECTOR_MEDIAN) { Rf_error("Invalid method index."); } UNPROTECT(1); // method_ // Parameter metric PROTECT(metric_); if (!IS_INTEGER(metric_) || LENGTH(metric_)!=1) Rf_error("'metric' must be a single integer."); int metric = *INTEGER_POINTER(metric_) - 1; // index-0 based; if (metric<0 || metric>5 || (method!=METHOD_VECTOR_SINGLE && metric!=0) ) { Rf_error("Invalid metric index."); } UNPROTECT(1); // metric_ // data array PROTECT(X_ = AS_NUMERIC(X_)); SEXP dims_ = PROTECT( Rf_getAttrib( X_, R_DimSymbol ) ) ; if( dims_ == R_NilValue || LENGTH(dims_) != 2 ) { Rf_error( "Argument is not a matrix."); } const int * const dims = INTEGER(dims_); const int N = dims[0]; const int dim = dims[1]; if (N<2) Rf_error("There must be at least two data points."); // Make a working copy of the dissimilarity array // for all methods except "single". double * X__ = NUMERIC_POINTER(X_); // Copy the input array and change it from Fortran-contiguous style // to C-contiguous style // (Waste of memory for 'single'; the other methods need a copy auto_array_ptr<double> X(LENGTH(X_)); for (std::ptrdiff_t i=0; i<N; ++i) for (std::ptrdiff_t j=0; j<dim; ++j) X[i*dim+j] = X__[i+j*N]; UNPROTECT(2); // dims_, X_ // Parameter members: number of members in each node auto_array_ptr<t_float> members; if (method==METHOD_VECTOR_WARD || method==METHOD_VECTOR_CENTROID) { members.init(N); if (Rf_isNull(members_)) { for (t_index i=0; i<N; ++i) members[i] = 1; } else { PROTECT(members_ = AS_NUMERIC(members_)); if (LENGTH(members_)!=N) Rf_error("The length of 'members' must be the same as the number of data points."); const t_float * const m = NUMERIC_POINTER(members_); for (t_index i=0; i<N; ++i) members[i] = m[i]; UNPROTECT(1); // members } } // Parameter p PROTECT(p_); double p = 0; if (metric==METRIC_R_MINKOWSKI) { if (!IS_NUMERIC(p_) || LENGTH(p_)!=1) Rf_error("'p' must be a single floating point number."); p = *NUMERIC_POINTER(p_); } else { if (p_ != R_NilValue) { Rf_error("No metric except 'minkowski' allows a 'p' parameter."); } } UNPROTECT(1); // p_ /* The generic_linkage_vector_alternative algorithm uses labels N,N+1,... for the new nodes, so we need a table which node is stored in which row. Instructions: Set this variable to true for all methods which use the generic_linkage_vector_alternative algorithm below. */ bool make_row_repr = (method==METHOD_VECTOR_CENTROID || method==METHOD_VECTOR_MEDIAN); R_dissimilarity dist(X, N, dim, members, static_cast<unsigned char>(method), static_cast<unsigned char>(metric), p, make_row_repr); cluster_result Z2(N-1); /* Clustering step */ switch (method) { case METHOD_VECTOR_SINGLE: MST_linkage_core_vector(N, dist, Z2); break; case METHOD_VECTOR_WARD: generic_linkage_vector<METHOD_METR_WARD>(N, dist, Z2); break; case METHOD_VECTOR_CENTROID: generic_linkage_vector_alternative<METHOD_METR_CENTROID>(N, dist, Z2); break; case METHOD_VECTOR_MEDIAN: generic_linkage_vector_alternative<METHOD_METR_MEDIAN>(N, dist, Z2); break; default: throw std::runtime_error(std::string("Invalid method.")); } X.free(); // Free the memory now members.free(); // (not strictly necessary). dist.postprocess(Z2); SEXP m; // return field "merge" PROTECT(m = NEW_INTEGER(2*(N-1))); int * const merge = INTEGER_POINTER(m); SEXP dim_m; // Specify that m is an (N-1)×2 matrix PROTECT(dim_m = NEW_INTEGER(2)); INTEGER(dim_m)[0] = N-1; INTEGER(dim_m)[1] = 2; SET_DIM(m, dim_m); SEXP h; // return field "height" PROTECT(h = NEW_NUMERIC(N-1)); double * const height = NUMERIC_POINTER(h); SEXP o; // return fiels "order' PROTECT(o = NEW_INTEGER(N)); int * const order = INTEGER_POINTER(o); if (method==METHOD_VECTOR_SINGLE) generate_R_dendrogram<false>(merge, height, order, Z2, N); else generate_R_dendrogram<true>(merge, height, order, Z2, N); SEXP n; // names PROTECT(n = NEW_CHARACTER(3)); SET_STRING_ELT(n, 0, COPY_TO_USER_STRING("merge")); SET_STRING_ELT(n, 1, COPY_TO_USER_STRING("height")); SET_STRING_ELT(n, 2, COPY_TO_USER_STRING("order")); PROTECT(r = NEW_LIST(3)); // field names in the output list SET_ELEMENT(r, 0, m); SET_ELEMENT(r, 1, h); SET_ELEMENT(r, 2, o); SET_NAMES(r, n); UNPROTECT(6); // m, dim_m, h, o, r, n } // try catch (const std::bad_alloc&) { Rf_error( "Memory overflow."); } catch(const std::exception& e){ Rf_error( e.what() ); } catch(const nan_error&){ Rf_error("NaN dissimilarity value."); } catch(...){ Rf_error( "C++ exception (unknown reason)." ); } return r; }
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; }
// for obtaining a fast empirical distribution of mean values for randomly sampled 'clusters' SEXP emp_means(SEXP matrix_, SEXP nrow_, SEXP const cols_, SEXP nsample_, SEXP niter_){ SEXP means = NULL; try{ srand(time(NULL)); PROTECT(nrow_ = AS_INTEGER(nrow_)); int const nrow = *INTEGER_POINTER(nrow_); UNPROTECT(1); PROTECT(cols_); int * const cols = INTEGER_POINTER(cols_); int const ncol = LENGTH(cols_); PROTECT(nsample_ = AS_INTEGER(nsample_)); int const nsample = *INTEGER_POINTER(nsample_); UNPROTECT(1); PROTECT(niter_ = AS_INTEGER(niter_)); int const niter = *INTEGER_POINTER(niter_); UNPROTECT(1); PROTECT(matrix_ = AS_NUMERIC(matrix_)); const double * const matrix = NUMERIC_POINTER(matrix_); PROTECT(means = NEW_NUMERIC(niter)); double * const meansp = NUMERIC_POINTER(means); t_float val(0), sum(0); int row(0), i(0), j(0); for(int iter(0); iter<niter; ++iter){ // compute mean over nsample rows for column indices cols // R matrices are filled BY COLUMN sum=0; for(i=0; i<nsample; ++i){ row = rand() % nrow; for(j=0; j<ncol; ++j){ // R is 1-indexed val = matrix[row+nrow*(cols[j]-1)]; if(ISNA(val)) continue; sum += val; } } meansp[iter] = sum/nsample/ncol; } UNPROTECT(1); // matrix_ UNPROTECT(1); // cols_ UNPROTECT(1); // means } catch (const std::bad_alloc&) { Rf_error( "Memory overflow."); } catch(const std::exception& e){ Rf_error( e.what() ); } catch(const nan_error&){ Rf_error("NaN dissimilarity value."); } catch(...){ Rf_error( "C++ exception (unknown reason)." ); } return means; }
SEXP thinjumpequal(SEXP n, SEXP p, SEXP guess) { int N; double P; int *w; /* temporary storage for selected integers */ int nw, nwmax; int i, j, k; double log1u, log1p; /* R object return value */ SEXP Out; /* external storage pointer */ int *OutP; /* protect R objects from garbage collector */ PROTECT(p = AS_NUMERIC(p)); PROTECT(n = AS_INTEGER(n)); PROTECT(guess = AS_INTEGER(guess)); /* Translate arguments from R to C */ N = *(INTEGER_POINTER(n)); P = *(NUMERIC_POINTER(p)); nwmax = *(INTEGER_POINTER(guess)); /* Allocate space for result */ w = (int *) R_alloc(nwmax, sizeof(int)); /* set up */ GetRNGstate(); log1p = -log(1.0 - P); /* main loop */ i = 0; /* last selected element of 1...N */ nw = 0; /* number of selected elements */ while(i <= N) { log1u = exp_rand(); /* an exponential rv is equivalent to -log(1-U) */ j = (int) ceil(log1u/log1p); /* j is geometric(p) */ i += j; if(nw >= nwmax) { /* overflow; allocate more space */ w = (int *) S_realloc((char *) w, 2 * nwmax, nwmax, sizeof(int)); nwmax = 2 * nwmax; } /* add 'i' to output vector */ w[nw] = i; ++nw; } /* The last saved 'i' could have exceeded 'N' */ /* For efficiency we don't check this in the loop */ if(nw > 0 && w[nw-1] > N) --nw; PutRNGstate(); /* create result vector */ PROTECT(Out = NEW_INTEGER(nw)); /* copy results into output */ OutP = INTEGER_POINTER(Out); for(k = 0; k < nw; k++) OutP[k] = w[k]; UNPROTECT(4); return(Out); }
// for obtaining a fast empirical distribution of mean differences between two sets of columns for randomly sampled 'clusters' SEXP emp_diffs(SEXP matrix_, SEXP nrow_, SEXP const colsA_, SEXP const colsB_, SEXP nsample_, SEXP niter_){ SEXP diffs = NULL; try{ srand(time(NULL)); PROTECT(nrow_ = AS_INTEGER(nrow_)); int const nrow = *INTEGER_POINTER(nrow_); UNPROTECT(1); PROTECT(colsA_); int * const colsA = INTEGER_POINTER(colsA_); int const ncolA = LENGTH(colsA_); PROTECT(colsB_); int * const colsB = INTEGER_POINTER(colsB_); int const ncolB = LENGTH(colsB_); PROTECT(nsample_ = AS_INTEGER(nsample_)); int const nsample = *INTEGER_POINTER(nsample_); UNPROTECT(1); PROTECT(niter_ = AS_INTEGER(niter_)); int const niter = *INTEGER_POINTER(niter_); UNPROTECT(1); PROTECT(matrix_ = AS_NUMERIC(matrix_)); const double * const matrix = NUMERIC_POINTER(matrix_); PROTECT(diffs = NEW_NUMERIC(niter)); double * const diffsp = NUMERIC_POINTER(diffs); t_float val(0), diff(0), sumA(0), sumB(0); int row(0), i(0), j(0); for(int iter(0); iter<niter; ++iter){ // compute mean over nsample rows for column indices colsA // R matrices are filled BY COLUMN diff=0; for(i=0; i<nsample; ++i){ row = rand() % nrow; sumA=0; sumB=0; for(j=0; j<ncolA; ++j){ // R is 1-indexed val = matrix[row+nrow*(colsA[j]-1)]; if(ISNA(val)) continue; sumA += val; } for(j=0; j<ncolB; ++j){ val = matrix[row+nrow*(colsB[j]-1)]; if(ISNA(val)) continue; sumB += val; } diff += sumB/ncolB - sumA/ncolA; } diffsp[iter] = diff/nsample; } UNPROTECT(1); // matrix_ UNPROTECT(1); // colsA_ UNPROTECT(1); // colsB_ UNPROTECT(1); // diffs } catch (const std::bad_alloc&) { Rf_error( "Memory overflow."); } catch(const std::exception& e){ Rf_error( e.what() ); } catch(const nan_error&){ Rf_error("NaN dissimilarity value."); } catch(...){ Rf_error( "C++ exception (unknown reason)." ); } return diffs; }
SEXP rph_phyloFit(SEXP msaP, SEXP treeStrP, SEXP substModP, SEXP scaleOnlyP, SEXP scaleSubtreeP, SEXP nratesP, SEXP alphaP, SEXP rateConstantsP, SEXP initModP, SEXP initBackgdFromDataP, SEXP initRandomP, SEXP initParsimonyP, SEXP clockP, SEXP emP, SEXP maxEmItsP, SEXP precisionP, SEXP gffP, SEXP ninfSitesP, SEXP quietP, SEXP noOptP, SEXP boundP, SEXP logFileP, SEXP selectionP) { struct phyloFit_struct *pf; int numProtect=0, i; double *doubleP; char *die_message=NULL; SEXP rv=R_NilValue; List *new_rate_consts = NULL; List *new_rate_weights = NULL; GetRNGstate(); //seed R's random number generator pf = phyloFit_struct_new(1); //sets appropriate defaults for RPHAST mode pf->msa = (MSA*)EXTPTR_PTR(msaP); if (treeStrP != R_NilValue) pf->tree = rph_tree_new(treeStrP); pf->use_em = LOGICAL_VALUE(emP); if (rateConstantsP != R_NilValue) { PROTECT(rateConstantsP = AS_NUMERIC(rateConstantsP)); numProtect++; doubleP = NUMERIC_POINTER(rateConstantsP); new_rate_consts = lst_new_dbl(LENGTH(rateConstantsP)); for (i=0; i < LENGTH(rateConstantsP); i++) lst_push_dbl(new_rate_consts, doubleP[i]); // pf->use_em = 1; } if (initModP != R_NilValue) { pf->input_mod = (TreeModel*)EXTPTR_PTR(initModP); pf->subst_mod = pf->input_mod->subst_mod; tm_register_protect(pf->input_mod); if (new_rate_consts == NULL && pf->input_mod->rK != NULL && pf->input_mod->nratecats > 1) { new_rate_consts = lst_new_dbl(pf->input_mod->nratecats); for (i=0; i < pf->input_mod->nratecats; i++) lst_push_dbl(new_rate_consts, pf->input_mod->rK[i]); // pf-> = 1; } if (pf->input_mod->empirical_rates && pf->input_mod->freqK != NULL && pf->input_mod->nratecats > 1) { new_rate_weights = lst_new_dbl(pf->input_mod->nratecats); for (i=0; i < pf->input_mod->nratecats; i++) lst_push_dbl(new_rate_weights, pf->input_mod->freqK[i]); } tm_reinit(pf->input_mod, rph_get_subst_mod(substModP), nratesP == R_NilValue ? pf->input_mod->nratecats : INTEGER_VALUE(nratesP), NUMERIC_VALUE(alphaP), new_rate_consts, new_rate_weights); } else { if (nratesP != R_NilValue) pf->nratecats = INTEGER_VALUE(nratesP); if (alphaP != R_NilValue) pf->alpha = NUMERIC_VALUE(alphaP); if (rateConstantsP != R_NilValue) { pf->rate_consts = new_rate_consts; if (nratesP == R_NilValue) pf->nratecats = lst_size(new_rate_consts); else if (lst_size(new_rate_consts) != pf->nratecats) die("length of new_rate_consts does not match nratecats\n"); } } pf->subst_mod = rph_get_subst_mod(substModP); pf->estimate_scale_only = LOGICAL_VALUE(scaleOnlyP); if (scaleSubtreeP != R_NilValue) { pf->subtree_name = smalloc((1+strlen(CHARACTER_VALUE(scaleSubtreeP)))*sizeof(char)); strcpy(pf->subtree_name, CHARACTER_VALUE(scaleSubtreeP)); } pf->random_init = LOGICAL_VALUE(initRandomP); pf->init_backgd_from_data = LOGICAL_VALUE(initBackgdFromDataP); pf->init_parsimony = LOGICAL_VALUE(initParsimonyP); pf->assume_clock = LOGICAL_VALUE(clockP); if (maxEmItsP != R_NilValue) pf->max_em_its = INTEGER_VALUE(maxEmItsP); pf->precision = get_precision(CHARACTER_VALUE(precisionP)); if (pf->precision == OPT_UNKNOWN_PREC) { die_message = "invalid precision"; goto rph_phyloFit_end; } if (gffP != R_NilValue) { pf->gff = (GFF_Set*)EXTPTR_PTR(gffP); gff_register_protect(pf->gff); } if (ninfSitesP != R_NilValue) pf->nsites_threshold = INTEGER_VALUE(ninfSitesP); pf->quiet = LOGICAL_VALUE(quietP); if (noOptP != R_NilValue) { int len=LENGTH(noOptP), pos=0; char *temp; for (i=0; i < LENGTH(noOptP); i++) len += strlen(CHARACTER_VALUE(STRING_ELT(noOptP, i))); temp = smalloc(len*sizeof(char)); for (i=0; i < LENGTH(noOptP); i++) { if (i != 0) temp[pos++] = ','; sprintf(&temp[pos], "%s", CHARACTER_VALUE(STRING_ELT(noOptP, i))); pos += strlen(CHARACTER_VALUE(STRING_ELT(noOptP, i))); } if (pos != len-1) die("ERROR parsing noOpt len=%i pos=%i\n", len, pos); temp[pos] = '\0'; pf->nooptstr = str_new_charstr(temp); } if (boundP != R_NilValue) { pf->bound_arg = lst_new_ptr(LENGTH(boundP)); for (i=0; i < LENGTH(boundP); i++) { String *temp = str_new_charstr(CHARACTER_VALUE(STRING_ELT(boundP, i))); lst_push_ptr(pf->bound_arg, temp); } } if (logFileP != R_NilValue) { if (IS_CHARACTER(logFileP)) pf->logf = phast_fopen(CHARACTER_VALUE(logFileP), "w+"); else if (IS_LOGICAL(logFileP) && LOGICAL_VALUE(logFileP)) { pf->logf = stdout; } } if (selectionP != R_NilValue) { pf->use_selection = TRUE; pf->selection = NUMERIC_VALUE(selectionP); } msa_register_protect(pf->msa); run_phyloFit(pf); rv = PROTECT(rph_listOfLists_to_SEXP(pf->results)); numProtect++; rph_phyloFit_end: if (pf->logf != NULL && pf->logf != stdout && pf->logf != stderr) phast_fclose(pf->logf); PutRNGstate(); if (die_message != NULL) die(die_message); if (numProtect > 0) UNPROTECT(numProtect); return rv; }
void FLQuant_pointer::Init(SEXP x) { SEXP Quant = GET_SLOT(x, install(".Data")), dims = GET_DIM(Quant), dimnames = GET_DIMNAMES(Quant); data = NUMERIC_POINTER(AS_NUMERIC(Quant)); int dim[6], n = length(dims); dim[0] = INTEGER(dims)[0]; dim[1] = INTEGER(dims)[1]; dim[2] = INTEGER(dims)[2]; dim[3] = INTEGER(dims)[3]; dim[4] = INTEGER(dims)[4]; dim[5] = n>=6 ? INTEGER(dims)[5] : 1; if (((int)dim[0]) < 1 || ((int)dim[1]) < 1 || ((int)dim[2]) < 1 || ((int)dim[3]) < 1 || ((int)dim[4]) < 1 || ((int)dim[5]) < 1) { UNPROTECT(1); return; } minquant() = 0; minyr() = 0; maxquant() = (int)dim[0] -1; maxyr() = (int)dim[1] -1; nunits() = (int)dim[2]; nseasons() = (int)dim[3]; nareas() = (int)dim[4]; niters() = (int)dim[5]; if (dimnames != R_NilValue) if (TYPEOF(dimnames) == VECSXP) { int t = 0; const char *c; if (n >= 1 && INTEGER(dims)[0] >= 1) { c = CHAR(STRING_ELT(VECTOR_ELT(dimnames, 0), 0)); //check that name is not a text string for (int i=0; i<=(signed)strlen(c); i++) if (isalpha(c[i])) t=1; if (t !=1) t = atoi(c); minquant() += t; maxquant() += t; } if (n >= 2 && INTEGER(dims)[1] >= 1) { t = 0; c = CHAR(STRING_ELT(VECTOR_ELT(dimnames, 1), 0)); //check that name is not a text string for (int i=0; i<=(signed)strlen(c); i++) if (isalpha(c[i])) t=1; if (t !=1) t = atoi(c); minyr() += t; maxyr() += t; } } InitFlag() = true; UNPROTECT(1); }