SEXP lik4bin(SEXP data, SEXP star, SEXP sigma, SEXP thr, SEXP var, SEXP power, SEXP restringi, SEXP tsp) { double *Pdata, *Psigma, *Pstar, Pres[22], *Rres, *wstar, *age1, *age2; double *Teff, *logg, *z, *M, *R, *Dni, *nimax, *logage, *pcage; double Vthr, maxL, maxL1, maxL2, lmult, EXP, rpcage; long nrow, ncol, count; double sq2pi, chi[NVAR], locsigma[NVAR], chi2, mult, L, mass, radius, lt, ltnlog;; double sTeffP, sTeffM, time1, time2; SEXP res, dm, sel; long i, j, nres, nres1, nres2, DIM, start, n, startT, stopT, up, low; int ii, norun, nstar, *Psel, *Pvar, restr; DATA5 *d, *d1, *d2, *d3, *d4; long lb, ub; double t_spread; // max diff. in age // cast and pointers PROTECT(data = AS_NUMERIC(data)); PROTECT(star = AS_NUMERIC(star)); PROTECT(sigma = AS_NUMERIC(sigma)); PROTECT(thr = AS_NUMERIC(thr)); PROTECT(var = AS_INTEGER(var)); PROTECT(power = AS_NUMERIC(power)); PROTECT(restringi = AS_INTEGER(restringi)); PROTECT(tsp = AS_NUMERIC(tsp)); Pdata = NUMERIC_POINTER(data); Pstar = NUMERIC_POINTER(star); Psigma = NUMERIC_POINTER(sigma); Vthr = NUMERIC_VALUE(thr); Pvar = INTEGER_POINTER(var); EXP = NUMERIC_VALUE(power); restr = NUMERIC_VALUE(restringi); t_spread = NUMERIC_VALUE(tsp); // sqrt ( 2 * pi ) sq2pi = 2.506628274631000; // dataset dimensions nrow = INTEGER(GET_DIM(data))[0]; ncol = INTEGER(GET_DIM(data))[1]; // column pointers // data are column ordered! Teff = Pdata; logg = Pdata+nrow; z = Pdata+2*nrow; Dni = Pdata+3*nrow; nimax = Pdata+4*nrow; M = Pdata+5*nrow; R = Pdata+6*nrow; logage = Pdata+7*nrow; pcage = Pdata+8*nrow; // vector for likelihood computations // 1 = include; 0 = exclude Psel = (int*)malloc(nrow*sizeof(int)); for(nstar=0;nstar<2;nstar++) { for(j=0;j<nrow;j++) Psel[j] = 0; wstar = &Pstar[(nstar)*9]; // sigma scaling for Dni,nimax,M,R (it is a % in input) for(n=0;n<NVAR;n++) locsigma[n] = Psigma[n+NVAR*nstar]; for(n=3;n<7;n++) locsigma[n] *= wstar[n]; mult = 1; for(n=0;n<NVAR;n++) if(Pvar[n] == 1) mult *= 1.0/(sq2pi * locsigma[n]); lmult = log(mult); // allowed Teff interval sTeffP = wstar[0] + Vthr*locsigma[0]; sTeffM = wstar[0] - Vthr*locsigma[0]; // ricerca righe con Teff minima e massima findrange(Teff, nrow, sTeffM, sTeffP, &startT, &stopT); if(startT == -1 || stopT == -1) { free(Psel); UNPROTECT(8); return(R_NilValue); } // sel computation nres = 0; for(j=startT;j<=stopT;j++) { for(ii=0;ii<NVAR;ii++) chi[ii] = 0; if(Pvar[0] == 1) chi[0] = (Teff[j] - wstar[0])/locsigma[0]; if(Pvar[1] == 1) chi[1] = (logg[j] - wstar[1])/locsigma[1]; if(Pvar[2] == 1) chi[2] = (z[j] - wstar[2])/locsigma[2]; if(Pvar[3] == 1) chi[3] = (Dni[j] - wstar[3])/locsigma[3]; if(Pvar[4] == 1) chi[4] = (nimax[j] - wstar[4])/locsigma[4]; if(Pvar[5] == 1) chi[5] = (M[j] - wstar[5])/locsigma[5]; if(Pvar[6] == 1) chi[6] = (R[j] - wstar[6])/locsigma[6]; norun = 0; for(ii=0;ii<NVAR;ii++) { if(fabs(chi[ii]) >= Vthr) { norun = 1; break; } } if( norun == 0 ) { chi2 = 0; for(ii=0;ii<NVAR;ii++) chi2 += chi[ii]*chi[ii]; if( restr == 1 ) { if(sqrt(chi2) <= 3 ) { nres++; Psel[j] = 1; } } else { nres++; Psel[j] = 1; } } } // no data! return if(nres == 0) { free(Psel); UNPROTECT(8); return(R_NilValue); } // init output matrix DIM = nres; if(nstar == 0) { d1 = (DATA5 *)calloc(DIM+1, sizeof(DATA5)); d = d1; } else { d2 = (DATA5 *)calloc(DIM+1, sizeof(DATA5)); d = d2; } // compute lik only if sel = 1 nres = 0; maxL = 0; for(j=startT;j<=stopT;j++) { if( Psel[j] == 1 ) { for(ii=0;ii<NVAR;ii++) chi[ii] = 0; if(Pvar[0] == 1) chi[0] = (Teff[j] - wstar[0])/locsigma[0]; if(Pvar[1] == 1) chi[1] = (logg[j] - wstar[1])/locsigma[1]; if(Pvar[2] == 1) chi[2] = (z[j] - wstar[2])/locsigma[2]; if(Pvar[3] == 1) chi[3] = (Dni[j] - wstar[3])/locsigma[3]; if(Pvar[4] == 1) chi[4] = (nimax[j] - wstar[4])/locsigma[4]; if(Pvar[5] == 1) chi[5] = (M[j] - wstar[5])/locsigma[5]; if(Pvar[6] == 1) chi[6] = (R[j] - wstar[6])/locsigma[6]; chi2 = 0; for(n=0;n<NVAR;n++) chi2 += chi[n]*chi[n]; // likelihood L = mult * exp(-0.5*chi2); if(L > maxL) maxL = L; d[nres].L = L; d[nres].M = M[j]; d[nres].R = R[j]; d[nres].logage = logage[j]; d[nres].pcage = pcage[j]; nres++; } } if(nstar==0) { nres1 = nres; maxL1 = maxL; } else { nres2 = nres; maxL2 = maxL; } } // independent estimates for(nstar=0;nstar<2;nstar++) { mass = radius = lt = ltnlog = rpcage = 0; count = 0; if(nstar==0) { nres = nres1; maxL = maxL1; d = d1; } else { nres = nres2; maxL = maxL2; d = d2; } // select only points with L >= 0.95 maxL for(j=0;j<nres;j++) { if(d[j].L >= 0.95*maxL) { mass += d[j].M; radius += d[j].R; lt += d[j].logage; rpcage += d[j].pcage; ltnlog += 1e-9*pow(10, d[j].logage); count++; } } mass /= (double)(count); radius /= (double)(count); lt /= (double)(count); ltnlog /= (double)(count); rpcage /= (double)(count); Pres[0+6*nstar] = mass; Pres[1+6*nstar] = radius; Pres[2+6*nstar] = lt; Pres[3+6*nstar] = ltnlog; Pres[4+6*nstar] = maxL; Pres[5+6*nstar] = rpcage; } // joint estimates qsort(d2, nres2, sizeof(DATA5), orderage); age2 = (double*)malloc(nres2*sizeof(double)); age1 = (double*)malloc(nres1*sizeof(double)); for(i=0;i<nres1;i++) age1[i] = 1e-9*pow(10, d1[i].logage); for(i=0;i<nres2;i++) age2[i] = 1e-9*pow(10, d2[i].logage); maxL = 0; for(j=0;j<nres1;j++) { findrange(age2, nres2, age1[j]-t_spread,age1[j]+t_spread, &lb, &ub); // the joint estimate is impossible if(lb == -1 || ub == -1) continue; if(lb == ub && fabs(age1[j] - age2[lb]) > t_spread) continue; for(i=lb;i<=ub;i++) { count++; L = d1[j].L * d2[i].L; if(L > maxL) maxL = L; } } for(j=12;j<22;j++) Pres[j] = 0; count = 0; for(j=0;j<nres1;j++) { findrange(age2, nres2, age1[j]-t_spread,age1[j]+t_spread, &lb, &ub); if(lb == -1 || ub == -1) continue; if(lb == ub && fabs(age1[j] - age2[lb]) > t_spread) continue; for(i=lb;i<=ub;i++) { L = d1[j].L * d2[i].L; if(L > 0.95*maxL) { Pres[12] += d1[j].M; Pres[13] += d1[j].R; Pres[14] += d1[j].logage; Pres[15] += age1[j]; Pres[16] += d2[i].M; Pres[17] += d2[i].R; Pres[18] += d2[i].logage; Pres[19] += age2[i]; Pres[21] += d1[j].pcage; count++; } } } Pres[20] = (double)count; for(j=12;j<20;j++) Pres[j] /= (double)(count); Pres[21] /= (double)(count); PROTECT( res = NEW_NUMERIC(22) ); Rres = NUMERIC_POINTER(res); for(j=0;j<22;j++) Rres[j] = Pres[j]; free(d1); free(d2); free(Psel); free(age1); free(age2); // exit 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 */
/* * 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 multiply( SEXP Rp, SEXP Rq, SEXP Rn ) { /* D E C L I N P U T */ const int *p, *q, *n; /* D E C L O U T P U T */ int *res; SEXP Rres; /* D E C L L O C A L */ int i, j, idx, *mon, *m, *tmp, *old; SEXP Rmon, Rm, Rtmp, Rold; /* I N I T I N P U T */ PROTECT(Rp = AS_INTEGER(Rp) ); PROTECT(Rq = AS_INTEGER(Rq) ); PROTECT(Rn = AS_INTEGER(Rn) ); p = INTEGER_POINTER(Rp); q = INTEGER_POINTER(Rq); n = INTEGER_POINTER(Rn); /* I N I T O U T P U T */ PROTECT(Rres = NEW_INTEGER((1<<(*n)))); res = INTEGER_POINTER(Rres); /* I N I T L O C A L */ PROTECT(Rm = NEW_INTEGER((*n))); PROTECT(Rmon = NEW_INTEGER((*n))); PROTECT(Rtmp = NEW_INTEGER((1<<(*n)))); PROTECT(Rold = NEW_INTEGER((1<<(*n)))); m = INTEGER_POINTER(Rm); mon = INTEGER_POINTER(Rmon); tmp = INTEGER_POINTER(Rtmp); old = INTEGER_POINTER(Rold); /* T H E F U N C T I O N */ for( i=0; i<(1<<(*n)); ++i ) res[i] = 0; for( i=0; i<(1<<(*n)); ++i ) if( p[i]!=0 ) { /* then multiply q with monomial i */ mon = toBin(mon, i, (*n)); for( j=0; j<(1<<(*n)); ++j ) { tmp[j] = 0; old[j] = res[j]; res[j] = q[j]; } /* res = mul_pm( res, mon, (*n) ); (m <-> mon) */ for(j=0; j<(1<<(*n)); ++j) if(res[j]!=0) { m = toBin (m, j, (*n)); /* get monomial j */ m = mul_mm (m, mon, (*n)); /* m <- m * mon */ idx = toInt (m, (*n)); tmp[idx] = ( tmp[idx]+1 )%2; /* add m to tmp */ } for(j=0; j<(1<<(*n)); ++j) res[j]=tmp[j]; /* res = add_pp( res, old, (*n) ); */ for(j=0; j<(1<<(*n)); ++j) res[j] = ( res[j]+old[j] )%2; } /* G O O D B Y E */ UNPROTECT(8); return Rres; }
// examines weights for filtering failure // computes log likelihood and effective sample size // computes (if desired) prediction mean, prediction variance, filtering mean. // it is assumed that ncol(x) == ncol(params). // weights are used in filtering mean computation. // if length(weights) == 1, an unweighted average is computed. // returns all of the above in a named list SEXP pfilter2_computations (SEXP x, SEXP params, SEXP Np, SEXP rw, SEXP rw_sd, SEXP predmean, SEXP predvar, SEXP filtmean, SEXP onepar, SEXP weights, SEXP tol) { int nprotect = 0; SEXP pm = R_NilValue, pv = R_NilValue, fm = R_NilValue; SEXP rw_names, ess, fail, loglik; SEXP newstates = R_NilValue, newparams = R_NilValue; SEXP retval, retvalnames; double *xpm = 0, *xpv = 0, *xfm = 0, *xw = 0, *xx = 0, *xp = 0, *xpw=0; int *xpa=0; SEXP dimX, dimP, newdim, Xnames, Pnames, pindex; SEXP pw=R_NilValue,pa=R_NilValue, psample=R_NilValue; int *dim, *pidx, lv, np; int nvars, npars = 0, nrw = 0, nreps, offset, nlost; int do_rw, do_pm, do_pv, do_fm, do_par_resamp, all_fail = 0; double sum, sumsq, vsq, ws, w, toler; int j, k; PROTECT(dimX = GET_DIM(x)); nprotect++; dim = INTEGER(dimX); nvars = dim[0]; nreps = dim[1]; xx = REAL(x); PROTECT(Xnames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++; PROTECT(dimP = GET_DIM(params)); nprotect++; dim = INTEGER(dimP); npars = dim[0]; if (nreps != dim[1]) error("'states' and 'params' do not agree in second dimension"); PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; np = INTEGER(AS_INTEGER(Np))[0]; // number of particles to resample PROTECT(rw_names = GET_NAMES(rw_sd)); nprotect++; // names of parameters undergoing random walk do_rw = *(LOGICAL(AS_LOGICAL(rw))); // do random walk in parameters? do_pm = *(LOGICAL(AS_LOGICAL(predmean))); // calculate prediction means? do_pv = *(LOGICAL(AS_LOGICAL(predvar))); // calculate prediction variances? do_fm = *(LOGICAL(AS_LOGICAL(filtmean))); // calculate filtering means? do_par_resamp = *(LOGICAL(AS_LOGICAL(onepar))); // are all cols of 'params' the same? do_par_resamp = !do_par_resamp || do_rw || (np != nreps); // should we do parameter resampling? PROTECT(ess = NEW_NUMERIC(1)); nprotect++; // effective sample size PROTECT(loglik = NEW_NUMERIC(1)); nprotect++; // log likelihood PROTECT(fail = NEW_LOGICAL(1)); nprotect++; // particle failure? xw = REAL(weights); toler = *(REAL(tol)); // failure tolerance // check the weights and compute sum and sum of squares for (k = 0, w = 0, ws = 0, nlost = 0; k < nreps; k++) { if (xw[k] >= 0) { w += xw[k]; ws += xw[k]*xw[k]; } else { // this particle is lost xw[k] = 0; nlost++; } } if (nlost >= nreps) all_fail = 1; // all particles are lost if (all_fail) { *(REAL(loglik)) = log(toler); // minimum log-likelihood *(REAL(ess)) = 0; // zero effective sample size } else { *(REAL(loglik)) = log(w/((double) nreps)); // mean of weights is likelihood *(REAL(ess)) = w*w/ws; // effective sample size } *(LOGICAL(fail)) = all_fail; if (do_rw) { // indices of parameters undergoing random walk PROTECT(pindex = matchnames(Pnames,rw_names,"parameters")); nprotect++; xp = REAL(params); pidx = INTEGER(pindex); nrw = LENGTH(rw_names); lv = nvars+nrw; } else { pidx = NULL; lv = nvars; } if (do_pm || do_pv) { PROTECT(pm = NEW_NUMERIC(lv)); nprotect++; xpm = REAL(pm); } if (do_pv) { PROTECT(pv = NEW_NUMERIC(lv)); nprotect++; xpv = REAL(pv); } if (do_fm) { if (do_rw) { PROTECT(fm = NEW_NUMERIC(nvars+npars)); nprotect++; } else { PROTECT(fm = NEW_NUMERIC(nvars)); nprotect++; } xfm = REAL(fm); } PROTECT(pa = NEW_INTEGER(np)); nprotect++; xpa = INTEGER(pa); for (j = 0; j < nvars; j++) { // state variables // compute prediction mean if (do_pm || do_pv) { for (k = 0, sum = 0; k < nreps; k++) sum += xx[j+k*nvars]; sum /= ((double) nreps); xpm[j] = sum; } // compute prediction variance if (do_pv) { for (k = 0, sumsq = 0; k < nreps; k++) { vsq = xx[j+k*nvars]-sum; sumsq += vsq*vsq; } xpv[j] = sumsq / ((double) (nreps - 1)); } // compute filter mean if (do_fm) { if (all_fail) { // unweighted average for (k = 0, ws = 0; k < nreps; k++) ws += xx[j+k*nvars]; xfm[j] = ws/((double) nreps); } else { // weighted average for (k = 0, ws = 0; k < nreps; k++) ws += xx[j+k*nvars]*xw[k]; xfm[j] = ws/w; } } } // compute means and variances for parameters (if needed) if (do_rw) { for (j = 0; j < nrw; j++) { offset = pidx[j]; // position of the parameter if (do_pm || do_pv) { for (k = 0, sum = 0; k < nreps; k++) sum += xp[offset+k*npars]; sum /= ((double) nreps); xpm[nvars+j] = sum; } if (do_pv) { for (k = 0, sumsq = 0; k < nreps; k++) { vsq = xp[offset+k*npars]-sum; sumsq += vsq*vsq; } xpv[nvars+j] = sumsq / ((double) (nreps - 1)); } } if (do_fm) { for (j = 0; j < npars; j++) { if (all_fail) { // unweighted average for (k = 0, ws = 0; k < nreps; k++) ws += xp[j+k*npars]; xfm[nvars+j] = ws/((double) nreps); } else { // weighted average for (k = 0, ws = 0; k < nreps; k++) ws += xp[j+k*npars]*xw[k]; xfm[nvars+j] = ws/w; } } } } GetRNGstate(); if (!all_fail) { // resample the particles unless we have filtering failure int xdim[2]; //int sample[np]; double *ss = 0, *st = 0, *ps = 0, *pt = 0; // create storage for new states xdim[0] = nvars; xdim[1] = np; PROTECT(newstates = makearray(2,xdim)); nprotect++; setrownames(newstates,Xnames,2); ss = REAL(x); st = REAL(newstates); // create storage for new parameters if (do_par_resamp) { xdim[0] = npars; xdim[1] = np; PROTECT(newparams = makearray(2,xdim)); nprotect++; setrownames(newparams,Pnames,2); ps = REAL(params); pt = REAL(newparams); } PROTECT(pw = NEW_NUMERIC(nreps)); nprotect++; xpw = REAL(pw); for (k = 0; k < nreps; k++) xpw[k]=REAL(weights)[k]; nosort_resamp(nreps,REAL(weights),np,xpa,0); for (k = 0; k < np; k++) { // copy the particles for (j = 0, xx = ss+nvars*xpa[k]; j < nvars; j++, st++, xx++) *st = *xx; if (do_par_resamp) { for (j = 0, xp = ps+npars*xpa[k]; j < npars; j++, pt++, xp++){ *pt = *xp; } } } } else { // don't resample: just drop 3rd dimension in x prior to return PROTECT(newdim = NEW_INTEGER(2)); nprotect++; dim = INTEGER(newdim); dim[0] = nvars; dim[1] = nreps; SET_DIM(x,newdim); setrownames(x,Xnames,2); } if (do_rw) { // if random walk, adjust prediction variance and move particles xx = REAL(rw_sd); xp = (all_fail || !do_par_resamp) ? REAL(params) : REAL(newparams); nreps = (all_fail) ? nreps : np; for (j = 0; j < nrw; j++) { offset = pidx[j]; vsq = xx[j]; if (do_pv) { xpv[nvars+j] += vsq*vsq; } for (k = 0; k < nreps; k++) xp[offset+k*npars] += rnorm(0,vsq); } } renormalize(xpw,nreps,0); PutRNGstate(); PROTECT(retval = NEW_LIST(10)); nprotect++; PROTECT(retvalnames = NEW_CHARACTER(10)); nprotect++; SET_STRING_ELT(retvalnames,0,mkChar("fail")); SET_STRING_ELT(retvalnames,1,mkChar("loglik")); SET_STRING_ELT(retvalnames,2,mkChar("ess")); SET_STRING_ELT(retvalnames,3,mkChar("states")); SET_STRING_ELT(retvalnames,4,mkChar("params")); SET_STRING_ELT(retvalnames,5,mkChar("pm")); SET_STRING_ELT(retvalnames,6,mkChar("pv")); SET_STRING_ELT(retvalnames,7,mkChar("fm")); SET_STRING_ELT(retvalnames,8,mkChar("weight")); SET_STRING_ELT(retvalnames,9,mkChar("pa")); SET_NAMES(retval,retvalnames); SET_ELEMENT(retval,0,fail); SET_ELEMENT(retval,1,loglik); SET_ELEMENT(retval,2,ess); if (all_fail) { SET_ELEMENT(retval,3,x); } else { SET_ELEMENT(retval,3,newstates); } if (all_fail || !do_par_resamp) { SET_ELEMENT(retval,4,params); } else { SET_ELEMENT(retval,4,newparams); } if (do_pm) { SET_ELEMENT(retval,5,pm); } if (do_pv) { SET_ELEMENT(retval,6,pv); } if (do_fm) { SET_ELEMENT(retval,7,fm); } SET_ELEMENT(retval,8,pw); SET_ELEMENT(retval,9,pa); UNPROTECT(nprotect); return(retval); }
double *catnetPairwiseCondLikelihood(SEXP rSamples, SEXP rPerturbations) { int *pSamples, *pRSamples, *pPerturbations; int *pSamplesPert, numsamplesPert; int *pNodeNumCats, **pNodeCats, mincat, maxcat, maxCategories; double *pprobs; int numsamples, numnodes, i, j, k, d, nnode1, nnode2, ncount; double floglik, fsum, *matPairs, fmin, fmax; SEXP dim; if(!isMatrix(rSamples)) error("Data should be a matrix"); if(!isNull(rPerturbations) && !isMatrix(rPerturbations)) error("Perturbations should be a matrix"); PROTECT(rSamples = AS_INTEGER(rSamples)); pRSamples = INTEGER(rSamples); dim = GET_DIM(rSamples); numnodes = INTEGER(dim)[0]; numsamples = INTEGER(dim)[1]; // pSamples are assumed positive indices pSamples = (int*)CATNET_MALLOC(numnodes*numsamples*sizeof(int)); memcpy(pSamples, pRSamples, numnodes*numsamples*sizeof(int)); UNPROTECT(1); //rSamples for(j = 0; j < numnodes*numsamples; j++) { pSamples[j]--; } // categoies pNodeNumCats = (int*)CATNET_MALLOC(numnodes*sizeof(int)); if (!pNodeNumCats) { CATNET_FREE(pSamples); return 0; } pNodeCats = (int**)CATNET_MALLOC(numnodes*sizeof(int*)); if (!pNodeCats) { CATNET_FREE(pSamples); CATNET_FREE(pNodeNumCats); return 0; } memset(pNodeCats, 0, numnodes*sizeof(int*)); memset(pNodeNumCats, 0, numnodes*sizeof(int)); maxCategories = 1; for(i = 0; i < numnodes; i++) { mincat = INT_MAX; maxcat = -INT_MAX; for(j = 0; j < numsamples; j++) { if(pSamples[j*numnodes + i] < mincat) mincat = pSamples[j*numnodes + i]; if(pSamples[j*numnodes + i] > maxcat) maxcat = pSamples[j*numnodes + i]; } pNodeNumCats[i] = maxcat - mincat + 1; pNodeCats[i] = (int*)CATNET_MALLOC(pNodeNumCats[i]*sizeof(int)); if (!pNodeCats[i]) { CATNET_FREE(pSamples); CATNET_FREE(pNodeCats); CATNET_FREE(pNodeNumCats); return 0; } for(j = 0; j < pNodeNumCats[i]; j++) pNodeCats[i][j] = mincat + j; } for(i = 0; i < numnodes; i++) { /* order pNodeNumCats[i] */ for(j = 0; j < pNodeNumCats[i]; j++) { for(k = j + 1; k < pNodeNumCats[i]; k++) { if(pNodeCats[i][j] > pNodeCats[i][k]) { d = pNodeCats[i][j]; pNodeCats[i][j] = pNodeCats[i][k]; pNodeCats[i][k] = d; } } } for(j = 0; j < numsamples; j++) { for(d = 0; d < pNodeNumCats[i]; d++) if(pNodeCats[i][d] == pSamples[j*numnodes + i]) break; pSamples[j*numnodes + i] = d; } if(maxCategories < pNodeNumCats[i]) maxCategories = pNodeNumCats[i]; } pprobs = (double*)CATNET_MALLOC(maxCategories*maxCategories*sizeof(double)); matPairs = (double*)CATNET_MALLOC(numnodes*numnodes*sizeof(double)); if (!pprobs || !matPairs) { CATNET_FREE(pSamples); CATNET_FREE(pNodeCats); CATNET_FREE(pNodeNumCats); if (pprobs) CATNET_FREE(pprobs); if (matPairs) CATNET_FREE(matPairs); return 0; } pSamplesPert = 0; pPerturbations = 0; if(!isNull(rPerturbations)) { PROTECT(rPerturbations = AS_INTEGER(rPerturbations)); pPerturbations = INTEGER_POINTER(rPerturbations); pSamplesPert = (int*)CATNET_MALLOC(numnodes*numsamples*sizeof(int)); } memset(matPairs, 0, numnodes*numnodes*sizeof(double)); for(nnode1 = 0; nnode1 < numnodes; nnode1++) { numsamplesPert = 0; if(pPerturbations && pSamplesPert) { for(j = 0; j < numsamples; j++) { if(!pPerturbations[j * numnodes + nnode1]) { memcpy(pSamplesPert + numsamplesPert*numnodes, pSamples + j*numnodes, numnodes*sizeof(int)); numsamplesPert++; } } } for(nnode2 = 0; nnode2 < numnodes; nnode2++) { if(nnode1 == nnode2) continue; ncount = 0; memset(pprobs, 0, maxCategories*maxCategories*sizeof(double)); // estimate logP(nnode1|nnode2) if(pPerturbations && pSamplesPert) { for(j = 0; j < numsamplesPert; j++) { pprobs[maxCategories*pSamplesPert[j*numnodes + nnode2] + pSamplesPert[j*numnodes + nnode1]]++; ncount++; } } else { for(j = 0; j < numsamples; j++) { pprobs[maxCategories*pSamples[j*numnodes + nnode2] + pSamples[j*numnodes + nnode1]]++; ncount++; } } floglik = 0; for(i = 0; i < pNodeNumCats[nnode2]; i++) { fsum = 0; fmin = 0; for(j = 0; j < pNodeNumCats[nnode1]; j++) { fsum += pprobs[maxCategories*i+j]; if(pprobs[maxCategories*i+j] > 0) fmin += (double)pprobs[maxCategories*i+j] * (double)log((double)pprobs[maxCategories*i+j]); } floglik += fmin; if(fsum > 0) floglik -= fsum*log(fsum); } if(ncount > 1 && floglik > (double)-FLT_MAX) floglik /= (double)ncount; matPairs[nnode1*numnodes + nnode2] = floglik; } fsum = 0; fmin = FLT_MAX; fmax = -FLT_MAX; for(nnode2 = 0; nnode2 < numnodes; nnode2++) { fsum += matPairs[nnode1*numnodes + nnode2]; if(fmin > matPairs[nnode1*numnodes + nnode2]) fmin = matPairs[nnode1*numnodes + nnode2]; if(fmax < matPairs[nnode1*numnodes + nnode2]) fmax = matPairs[nnode1*numnodes + nnode2]; } fsum = 1; if(fmax-fmin>0) fsum = 1 / (fmax-fmin); for(nnode2 = 0; nnode2 < numnodes; nnode2++) matPairs[nnode1*numnodes + nnode2] = (matPairs[nnode1*numnodes + nnode2] - fmin)*fsum; } if(!isNull(rPerturbations)) UNPROTECT(1); //rPerturbations if(pSamplesPert) CATNET_FREE(pSamplesPert); if(pSamples) CATNET_FREE(pSamples); if(pprobs) CATNET_FREE(pprobs); if(pNodeCats) { for(i = 0; i < numnodes; i++) if(pNodeCats[i]) CATNET_FREE(pNodeCats[i]); CATNET_FREE(pNodeCats); } if(pNodeNumCats) CATNET_FREE(pNodeNumCats); //char str[128]; //sPRINTF(str, "Mem Balance %d\n", (int)g_memcounter); //Rprintf(str); return matPairs; }
/* ****************************************************************** ****************************************************************** */ void inip (int* n,double** x,double** l, double** u,int* m, double** lambda,int** equatn,int** linear,int* coded, int* checkder) { int i; SEXP n_r,m_r,x_r,l_r,u_r,lambda_r,rho_r,equatn_r,linear_r,coded_r, checkder_r; *n = 0; *m = 0; defineVar(install("x") ,createRRealVector(*n,NULL) ,environment_r); defineVar(install("l") ,createRRealVector(*n,NULL) ,environment_r); defineVar(install("u") ,createRRealVector(*n,NULL) ,environment_r); defineVar(install("lambda") ,createRRealVector(*m,NULL) ,environment_r); defineVar(install("equatn") ,createRIntVector(*m,NULL) ,environment_r); defineVar(install("linear") ,createRIntVector(*m,NULL) ,environment_r); defineVar(install("coded") ,createRIntVector(11,NULL) ,environment_r); defineVar(install("checkder"),createRIntScalar(*checkder),environment_r); EVAL(inip_r); n_r = findVar(install("n") ,environment_r); x_r = findVar(install("x") ,environment_r); l_r = findVar(install("l") ,environment_r); u_r = findVar(install("u") ,environment_r); m_r = findVar(install("m") ,environment_r); lambda_r = findVar(install("lambda") ,environment_r); equatn_r = findVar(install("equatn") ,environment_r); linear_r = findVar(install("linear") ,environment_r); coded_r = findVar(install("coded") ,environment_r); checkder_r = findVar(install("checkder"),environment_r); *n = (INTEGER(AS_INTEGER(EVAL(n_r))))[0]; *m = (INTEGER(AS_INTEGER(EVAL(m_r))))[0]; *checkder = (INTEGER(AS_INTEGER(EVAL(checkder_r))))[0]; *x = (double *) malloc(*n * sizeof(double)); *l = (double *) malloc(*n * sizeof(double)); *u = (double *) malloc(*n * sizeof(double)); *lambda = (double *) malloc(*m * sizeof(double)); *equatn = (int *) malloc(*m * sizeof(int )); *linear = (int *) malloc(*m * sizeof(int )); for(i = 0; i < *n; i++) { (*x)[i] = (REAL(EVAL(x_r)))[i]; (*l)[i] = (REAL(EVAL(l_r)))[i]; (*u)[i] = (REAL(EVAL(u_r)))[i]; } for(i = 0; i < *m; i++) { (*lambda)[i] = (REAL(EVAL(lambda_r)))[i]; (*equatn)[i] = (INTEGER(AS_INTEGER(EVAL(equatn_r))))[i]; (*linear)[i] = (INTEGER(AS_INTEGER(EVAL(linear_r))))[i]; } for(i = 0; i < 11; i++) { coded[i] = (INTEGER(AS_INTEGER(EVAL(coded_r))))[i]; } }
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); }
//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); }
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 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); }
SEXP do_init_state (SEXP object, SEXP params, SEXP t0, SEXP nsim, SEXP gnsi) { int nprotect = 0; SEXP Pnames, Snames; SEXP x = R_NilValue; int *dim; int npar, nrep, nvar, ns; int definit; int xdim[2]; const char *dimnms[2] = {"variable","rep"}; ns = *(INTEGER(AS_INTEGER(nsim))); PROTECT(params = as_matrix(params)); nprotect++; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; dim = INTEGER(GET_DIM(params)); npar = dim[0]; nrep = dim[1]; if (ns % nrep != 0) errorcall(R_NilValue,"in 'init.state': number of desired state-vectors 'nsim' is not a multiple of ncol('params')"); definit = *(INTEGER(GET_SLOT(object,install("default.init")))); if (definit) { // default initializer SEXP fcall, pat, repl, val, ivpnames, statenames; int *pidx, j, k; double *xp, *pp; PROTECT(pat = NEW_CHARACTER(1)); nprotect++; SET_STRING_ELT(pat,0,mkChar("\\.0$")); PROTECT(repl = NEW_CHARACTER(1)); nprotect++; SET_STRING_ELT(repl,0,mkChar("")); PROTECT(val = NEW_LOGICAL(1)); nprotect++; *(INTEGER(val)) = 1; // extract names of IVPs PROTECT(fcall = LCONS(val,R_NilValue)); nprotect++; SET_TAG(fcall,install("value")); PROTECT(fcall = LCONS(Pnames,fcall)); nprotect++; SET_TAG(fcall,install("x")); PROTECT(fcall = LCONS(pat,fcall)); nprotect++; SET_TAG(fcall,install("pattern")); PROTECT(fcall = LCONS(install("grep"),fcall)); nprotect++; PROTECT(ivpnames = eval(fcall,R_BaseEnv)); nprotect++; nvar = LENGTH(ivpnames); if (nvar < 1) { errorcall(R_NilValue,"in default 'initializer': there are no parameters with suffix '.0'. See '?pomp'."); } pidx = INTEGER(PROTECT(match(Pnames,ivpnames,0))); nprotect++; for (k = 0; k < nvar; k++) pidx[k]--; // construct names of state variables PROTECT(fcall = LCONS(ivpnames,R_NilValue)); nprotect++; SET_TAG(fcall,install("x")); PROTECT(fcall = LCONS(repl,fcall)); nprotect++; SET_TAG(fcall,install("replacement")); PROTECT(fcall = LCONS(pat,fcall)); nprotect++; SET_TAG(fcall,install("pattern")); PROTECT(fcall = LCONS(install("sub"),fcall)); nprotect++; PROTECT(statenames = eval(fcall,R_BaseEnv)); nprotect++; xdim[0] = nvar; xdim[1] = ns; PROTECT(x = makearray(2,xdim)); nprotect++; setrownames(x,statenames,2); fixdimnames(x,dimnms,2); for (j = 0, xp = REAL(x); j < ns; j++) { pp = REAL(params) + npar*(j%nrep); for (k = 0; k < nvar; k++, xp++) *xp = pp[pidx[k]]; } } else { // user-supplied initializer SEXP pompfun, fcall, fn, tcovar, covar, covars = R_NilValue; pompfunmode mode = undef; double *cp = NULL; // extract the initializer function and its environment PROTECT(pompfun = GET_SLOT(object,install("initializer"))); nprotect++; PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++; // extract covariates and interpolate PROTECT(tcovar = GET_SLOT(object,install("tcovar"))); nprotect++; if (LENGTH(tcovar) > 0) { // do table lookup PROTECT(covar = GET_SLOT(object,install("covar"))); nprotect++; PROTECT(covars = lookup_in_table(tcovar,covar,t0)); nprotect++; cp = REAL(covars); } // extract userdata PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++; switch (mode) { case Rfun: // use R function { SEXP par, rho, x1, x2; double *p, *pp, *xp, *xt; int j, *midx; // extract covariates and interpolate if (LENGTH(tcovar) > 0) { // add covars to call PROTECT(fcall = LCONS(covars,fcall)); nprotect++; SET_TAG(fcall,install("covars")); } // parameter vector PROTECT(par = NEW_NUMERIC(npar)); nprotect++; SET_NAMES(par,Pnames); pp = REAL(par); // finish constructing the call PROTECT(fcall = LCONS(t0,fcall)); nprotect++; SET_TAG(fcall,install("t0")); PROTECT(fcall = LCONS(par,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; // evaluation environment PROTECT(rho = (CLOENV(fn))); nprotect++; p = REAL(params); memcpy(pp,p,npar*sizeof(double)); // copy the parameters PROTECT(x1 = eval(fcall,rho)); nprotect++; // do the call PROTECT(Snames = GET_NAMES(x1)); nprotect++; if (!IS_NUMERIC(x1) || isNull(Snames)) { UNPROTECT(nprotect); errorcall(R_NilValue,"in 'init.state': user 'initializer' must return a named numeric vector"); } nvar = LENGTH(x1); xp = REAL(x1); midx = INTEGER(PROTECT(match(Pnames,Snames,0))); nprotect++; for (j = 0; j < nvar; j++) { if (midx[j]!=0) { UNPROTECT(nprotect); errorcall(R_NilValue,"in 'init.state': a state variable and a parameter share a single name: '%s'",CHARACTER_DATA(STRING_ELT(Snames,j))); } } xdim[0] = nvar; xdim[1] = ns; PROTECT(x = makearray(2,xdim)); nprotect++; setrownames(x,Snames,2); fixdimnames(x,dimnms,2); xt = REAL(x); memcpy(xt,xp,nvar*sizeof(double)); for (j = 1, xt += nvar; j < ns; j++, xt += nvar) { memcpy(pp,p+npar*(j%nrep),npar*sizeof(double)); PROTECT(x2 = eval(fcall,rho)); xp = REAL(x2); if (LENGTH(x2)!=nvar) errorcall(R_NilValue,"in 'init.state': user initializer returns vectors of non-uniform length"); memcpy(xt,xp,nvar*sizeof(double)); UNPROTECT(1); } } break; case native: // use native routine { SEXP Cnames; int *sidx, *pidx, *cidx; double *xt, *ps, time; pomp_initializer *ff = NULL; int j; PROTECT(Snames = GET_SLOT(pompfun,install("statenames"))); nprotect++; PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++; // construct state, parameter, covariate, observable indices 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); nvar = LENGTH(Snames); xdim[0] = nvar; xdim[1] = ns; PROTECT(x = makearray(2,xdim)); nprotect++; setrownames(x,Snames,2); fixdimnames(x,dimnms,2); set_pomp_userdata(fcall); GetRNGstate(); time = *(REAL(t0)); // loop over replicates for (j = 0, xt = REAL(x), ps = REAL(params); j < ns; j++, xt += nvar) (*ff)(xt,ps+npar*(j%nrep),time,sidx,pidx,cidx,cp); PutRNGstate(); unset_pomp_userdata(); } break; default: errorcall(R_NilValue,"in 'init.state': unrecognized 'mode'"); // # nocov break; } } UNPROTECT(nprotect); return x; }
SEXP do_dprior (SEXP object, SEXP params, SEXP log, SEXP gnsi) { int nprotect = 0; pompfunmode mode = undef; int npars, nreps; SEXP Pnames, F, fn, fcall; SEXP pompfun; int *dim; PROTECT(params = as_matrix(params)); nprotect++; dim = INTEGER(GET_DIM(params)); npars = dim[0]; nreps = dim[1]; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; // extract the user-defined function PROTECT(pompfun = GET_SLOT(object,install("dprior"))); nprotect++; PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++; // extract 'userdata' as pairlist PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++; // to store results PROTECT(F = NEW_NUMERIC(nreps)); nprotect++; // first do setup switch (mode) { case Rfun: // use R function { SEXP pvec, rho; double *pp, *ps, *pt; int j; // temporary storage PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++; SET_NAMES(pvec,Pnames); // set up the function call 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(fn,fcall)); nprotect++; // get the function's environment PROTECT(rho = (CLOENV(fn))); nprotect++; pp = REAL(pvec); for (j = 0, ps = REAL(params), pt = REAL(F); j < nreps; j++, ps += npars, pt++) { memcpy(pp,ps,npars*sizeof(double)); *pt = *(REAL(AS_NUMERIC(eval(fcall,rho)))); } } break; case native: // use native routine { int give_log, *pidx = 0; pomp_dprior *ff = NULL; double *ps, *pt; int j; // construct state, parameter, covariate, observable indices pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames"))); nprotect++; // address of native routine ff = (pomp_dprior *) R_ExternalPtrAddr(fn); give_log = *(INTEGER(AS_INTEGER(log))); R_CheckUserInterrupt(); // check for user interrupt set_pomp_userdata(fcall); // loop over replicates for (j = 0, pt = REAL(F), ps = REAL(params); j < nreps; j++, ps += npars, pt++) (*ff)(pt,ps,give_log,pidx); unset_pomp_userdata(); } break; default: error("unrecognized 'mode' slot in 'dprior'"); break; } UNPROTECT(nprotect); return F; }
void SEXP_to_int(SEXP val_sexp, int *val) { PROTECT(val_sexp=AS_INTEGER(val_sexp)); *val=(int)INTEGER_POINTER(val_sexp)[0]; UNPROTECT(1); }
SEXP catnetEntropyPairwise(SEXP rSamples, SEXP rPerturbations) { int *pSamples, *pPerturbations; int *psubSamples, numsubsamples, *psamples1, numsamples1; int *pNodeNumCats, **pNodeCats, mincat, maxcat, maxCategories, *pprobs; int numsamples, numnodes, i, j, k, d, nnode1, nnode2; double floglik, faux, fsum, *pvec, *klmat; SEXP dim, rvec = R_NilValue; if(!isMatrix(rSamples)) error("Data should be a matrix"); if(!isNull(rPerturbations) && !isMatrix(rPerturbations)) error("Perturbations should be a matrix"); PROTECT(rSamples = AS_INTEGER(rSamples)); pSamples = INTEGER(rSamples); dim = GET_DIM(rSamples); numnodes = INTEGER(dim)[0]; numsamples = INTEGER(dim)[1]; // pSamples are assumed positive indices for(j = 0; j < numnodes*numsamples; j++) { pSamples[j]--; } // categoies pNodeNumCats = (int*)CATNET_MALLOC(numnodes*sizeof(int)); if (!pNodeNumCats) { UNPROTECT(1); //rSamples return rvec; } pNodeCats = (int**)CATNET_MALLOC(numnodes*sizeof(int*)); if (!pNodeCats) { CATNET_FREE(pNodeNumCats); UNPROTECT(1); //rSamples return rvec; } memset(pNodeCats, 0, numnodes*sizeof(int*)); memset(pNodeNumCats, 0, numnodes*sizeof(int)); maxCategories = 1; for(i = 0; i < numnodes; i++) { mincat = INT_MAX; maxcat = -INT_MAX; for(j = 0; j < numsamples; j++) { if(pSamples[j*numnodes + i] < mincat) mincat = pSamples[j*numnodes + i]; if(pSamples[j*numnodes + i] > maxcat) maxcat = pSamples[j*numnodes + i]; } pNodeNumCats[i] = maxcat - mincat + 1; pNodeCats[i] = (int*)CATNET_MALLOC(pNodeNumCats[i]*sizeof(int)); if (!pNodeCats[i]) { CATNET_FREE(pNodeCats); CATNET_FREE(pNodeNumCats); UNPROTECT(1); //rSamples return rvec; } for(j = 0; j < pNodeNumCats[i]; j++) pNodeCats[i][j] = mincat + j; } for(i = 0; i < numnodes; i++) { /* order pNodeNumCats[i] */ for(j = 0; j < pNodeNumCats[i]; j++) { for(k = j + 1; k < pNodeNumCats[i]; k++) { if(pNodeCats[i][j] > pNodeCats[i][k]) { d = pNodeCats[i][j]; pNodeCats[i][j] = pNodeCats[i][k]; pNodeCats[i][k] = d; } } } for(j = 0; j < numsamples; j++) { for(d = 0; d < pNodeNumCats[i]; d++) if(pNodeCats[i][d] == pSamples[j*numnodes + i]) break; pSamples[j*numnodes + i] = d; } if(maxCategories < pNodeNumCats[i]) maxCategories = pNodeNumCats[i]; } pprobs = (int*)CATNET_MALLOC(maxCategories*maxCategories*sizeof(int)); klmat = (double*)CATNET_MALLOC(numnodes*numnodes*sizeof(double)); if (!pprobs || !klmat) { CATNET_FREE(pNodeCats); CATNET_FREE(pNodeNumCats); UNPROTECT(1); //rSamples return rvec; } memset(klmat, 0, numnodes*numnodes*sizeof(double)); psubSamples = 0; pPerturbations = 0; if(!isNull(rPerturbations)) { PROTECT(rPerturbations = AS_INTEGER(rPerturbations)); pPerturbations = INTEGER_POINTER(rPerturbations); psubSamples = (int*)CATNET_MALLOC(numnodes*numsamples*sizeof(int)); } for(nnode1 = 0; nnode1 < numnodes; nnode1++) { psamples1 = pSamples; numsamples1 = numsamples; if(pPerturbations && psubSamples) { numsubsamples = 0; for(j = 0; j < numsamples; j++) { if(!pPerturbations[j * numnodes + nnode1]) { memcpy(psubSamples + numsubsamples*numnodes, pSamples + j*numnodes, numnodes*sizeof(int)); numsubsamples++; } psamples1 = psubSamples; numsamples1 = numsubsamples; } } for(nnode2 = 0; nnode2 < numnodes; nnode2++) { memset(pprobs, 0, maxCategories*maxCategories*sizeof(int)); if(nnode2 == nnode1) { for(j = 0; j < numsamples1; j++) pprobs[psamples1[j*numnodes + nnode1]]++; floglik = 0; fsum = 0; for(j = 0; j < pNodeNumCats[nnode1]; j++) { fsum += pprobs[j]; if(pprobs[j] > 0) floglik += pprobs[j]*(double)log((double)pprobs[j]); } if(fsum > 0) { floglik -= fsum*(double)log((double)fsum); floglik /= fsum; } klmat[nnode2*numnodes + nnode1] = -floglik; continue; } // estimate logP(nnode1|nnode2) for(j = 0; j < numsamples1; j++) pprobs[maxCategories*psamples1[j*numnodes + nnode2] + psamples1[j*numnodes + nnode1]]++; floglik = 0; fsum = 0; for(i = 0; i < pNodeNumCats[nnode2]; i++) { faux = 0; for(j = 0; j < pNodeNumCats[nnode1]; j++) { faux += pprobs[maxCategories*i+j]; if(pprobs[maxCategories*i+j] > 0) floglik += pprobs[maxCategories*i+j]*(double)log((double)pprobs[maxCategories*i+j]); } fsum += faux; if(faux > 0) { floglik -= faux*(double)log((double)faux); } } if(fsum > 0) { floglik /= fsum; } klmat[nnode2*numnodes + nnode1] = -floglik; } } if(!isNull(rPerturbations)) UNPROTECT(1); //rPerturbations UNPROTECT(1); //rSamples if(psubSamples) CATNET_FREE(psubSamples); if(pprobs) CATNET_FREE(pprobs); if(pNodeCats) { for(i = 0; i < numnodes; i++) if(pNodeCats[i]) CATNET_FREE(pNodeCats[i]); CATNET_FREE(pNodeCats); } if(pNodeNumCats) CATNET_FREE(pNodeNumCats); if(klmat) { PROTECT(rvec = NEW_NUMERIC(numnodes*numnodes)); pvec = NUMERIC_POINTER(rvec); if (pvec) memcpy(pvec, klmat, numnodes*numnodes*sizeof(double)); UNPROTECT(1); CATNET_FREE(klmat); } //char str[128]; //sPRINTF(str, "Mem Balance %d\n", (int)g_memcounter); //Rprintf(str); return rvec; }
SEXP ldc_rdi(SEXP buf, SEXP max) { /* ldc_rdi = locate data chunk for RDI * Ref: WorkHorse Commands and Output Data Format_Nov07.pdf * p124: header structure (note that 'number of bytes in ensemble' * does *not* count the first 2 bytes; it's really an offset to the * checksum) * p158 (section 5.8) checksum */ PROTECT(buf = AS_RAW(buf)); PROTECT(max = AS_INTEGER(max)); /* FIXME: check lengths of match and key */ unsigned char *pbuf = RAW_POINTER(buf); int max_lres = *INTEGER_POINTER(max); if (max_lres < 0) error("'max' must be positive"); int lres; int lbuf = LENGTH(buf); SEXP res; #ifdef DEBUG Rprintf("lbuf=%d, max=%d\n",lbuf,max_lres); #endif /* Count matches, so we can allocate the right length */ unsigned char byte1 = 0x7f; unsigned char byte2 = 0x7f; /* this equal 22 base 10, i.e. the number of bytes in record */ unsigned int matches = 0; unsigned short int check_sum, desired_check_sum; unsigned int bytes_to_check = 0; #ifdef DEBUG Rprintf("max_lres %d\n", max_lres); #endif for (int i = 0; i < lbuf - 1; i++) { /* note that we don't look to the very end */ if (pbuf[i] == byte1 && pbuf[i+1] == byte2) { /* match first 2 bytes, now check the checksum */ if (matches == 0) bytes_to_check = pbuf[i+2] + 256 * pbuf[i+3]; check_sum = 0; for (int c = 0; c < bytes_to_check; c++) check_sum += (unsigned short int)pbuf[i + c]; desired_check_sum = ((unsigned short)pbuf[i+bytes_to_check+0]) | ((unsigned short)pbuf[i+bytes_to_check+1] << 8); if (check_sum == desired_check_sum) { matches++; #ifdef DEBUG Rprintf("buf[%d] ok\n", i); #endif if (max_lres != 0 && matches >= max_lres) break; } else { #ifdef DEBUG Rprintf("buf[%d] checksum %d (needed %d)\n", i, check_sum, desired_check_sum); #endif } } } R_CheckUserInterrupt(); /* allocate space, then run through whole buffer again, noting the matches */ lres = matches; if (lres > 0) { PROTECT(res = NEW_INTEGER(lres)); int *pres = INTEGER_POINTER(res); #ifdef DEBUG Rprintf("getting space for %d matches\n", lres); #endif unsigned int ires = 0; for (int i = 0; i < lbuf - 1; i++) { /* note that we don't look to the very end */ check_sum = 0; if (pbuf[i] == byte1 && pbuf[i+1] == byte2) { /* match first 2 bytes, now check the checksum */ for (int c = 0; c < bytes_to_check; c++) check_sum += (unsigned short int)pbuf[i + c]; desired_check_sum = ((unsigned short)pbuf[i+bytes_to_check]) | ((unsigned short)pbuf[i+bytes_to_check+1] << 8); if (check_sum == desired_check_sum) pres[ires++] = i + 1; /* the +1 is to get R pointers */ if (ires >= lres) break; } } } else { PROTECT(res = NEW_INTEGER(1)); int *pres = INTEGER_POINTER(res); pres[0] = 0; } UNPROTECT(3); return(res); }
SEXP catnetPearsonPairwise(SEXP rSamples, SEXP rPerturbations) { int *pSamples, *pPerturbations; int *pSamplesPert, numsamplesPert; int *pNodeNumCats, **pNodeCats, mincat, maxcat, maxCategories; double *pprobs1, *pprobs2; int numsamples, numnodes, i, j, k, d, nnode1, nnode2; double floglik, faux, fsum, *pvec, *klmat; SEXP dim, rvec = R_NilValue; if(!isMatrix(rSamples)) error("Data should be a matrix"); if(!isNull(rPerturbations) && !isMatrix(rPerturbations)) error("Perturbations should be a matrix"); PROTECT(rSamples = AS_INTEGER(rSamples)); pSamples = INTEGER(rSamples); dim = GET_DIM(rSamples); numnodes = INTEGER(dim)[0]; numsamples = INTEGER(dim)[1]; if(isNull(rPerturbations)) { PROTECT(rvec = NEW_NUMERIC(numnodes*numnodes)); pvec = NUMERIC_POINTER(rvec); memset(pvec, 0, numnodes*numnodes*sizeof(double)); UNPROTECT(1); } // pSamples are assumed positive indices for(j = 0; j < numnodes*numsamples; j++) { pSamples[j]--; } // categoies pNodeNumCats = (int*)CATNET_MALLOC(numnodes*sizeof(int)); if (!pNodeNumCats) { UNPROTECT(1); //rSamples return rvec; } pNodeCats = (int**)CATNET_MALLOC(numnodes*sizeof(int*)); if (!pNodeCats) { CATNET_FREE(pNodeNumCats); UNPROTECT(1); //rSamples return rvec; } memset(pNodeCats, 0, numnodes*sizeof(int*)); memset(pNodeNumCats, 0, numnodes*sizeof(int)); maxCategories = 1; for(i = 0; i < numnodes; i++) { mincat = INT_MAX; maxcat = -INT_MAX; for(j = 0; j < numsamples; j++) { if(pSamples[j*numnodes + i] < mincat) mincat = pSamples[j*numnodes + i]; if(pSamples[j*numnodes + i] > maxcat) maxcat = pSamples[j*numnodes + i]; } pNodeNumCats[i] = maxcat - mincat + 1; pNodeCats[i] = (int*)CATNET_MALLOC(pNodeNumCats[i]*sizeof(int)); if (!pNodeCats[i]) { CATNET_FREE(pNodeCats); CATNET_FREE(pNodeNumCats); UNPROTECT(1); //rSamples return rvec; } for(j = 0; j < pNodeNumCats[i]; j++) pNodeCats[i][j] = mincat + j; } for(i = 0; i < numnodes; i++) { /* order pNodeNumCats[i] */ for(j = 0; j < pNodeNumCats[i]; j++) { for(k = j + 1; k < pNodeNumCats[i]; k++) { if(pNodeCats[i][j] > pNodeCats[i][k]) { d = pNodeCats[i][j]; pNodeCats[i][j] = pNodeCats[i][k]; pNodeCats[i][k] = d; } } } for(j = 0; j < numsamples; j++) { for(d = 0; d < pNodeNumCats[i]; d++) if(pNodeCats[i][d] == pSamples[j*numnodes + i]) break; pSamples[j*numnodes + i] = d; } if(maxCategories < pNodeNumCats[i]) maxCategories = pNodeNumCats[i]; } pprobs1 = (double*)CATNET_MALLOC(maxCategories*maxCategories*sizeof(double)); pprobs2 = (double*)CATNET_MALLOC(maxCategories*maxCategories*sizeof(double)); klmat = (double*)CATNET_MALLOC(numnodes*numnodes*sizeof(double)); if (!pprobs1 || !pprobs2 || !klmat) { CATNET_FREE(pNodeCats); CATNET_FREE(pNodeNumCats); if (pprobs1) CATNET_FREE(pprobs1); if (pprobs2) CATNET_FREE(pprobs2); if (klmat) CATNET_FREE(klmat); UNPROTECT(1); //rSamples return rvec; } pSamplesPert = 0; pPerturbations = 0; if(!isNull(rPerturbations)) { PROTECT(rPerturbations = AS_INTEGER(rPerturbations)); pPerturbations = INTEGER_POINTER(rPerturbations); pSamplesPert = (int*)CATNET_MALLOC(numnodes*numsamples*sizeof(int)); } memset(klmat, 0, numnodes*numnodes*sizeof(double)); for(nnode1 = 0; nnode1 < numnodes; nnode1++) { numsamplesPert = 0; if(pPerturbations && pSamplesPert) { for(j = 0; j < numsamples; j++) { if(!pPerturbations[j * numnodes + nnode1]) { memcpy(pSamplesPert + numsamplesPert*numnodes, pSamples + j*numnodes, numnodes*sizeof(int)); numsamplesPert++; } } } for(nnode2 = 0; nnode2 < numnodes; nnode2++) { if(nnode1 == nnode2) continue; memset(pprobs2, 0, maxCategories*maxCategories*sizeof(double)); // estimate logP(nnode1|nnode2) for the whole sample for(j = 0; j < numsamples; j++) pprobs2[maxCategories*pSamples[j*numnodes + nnode2] + pSamples[j*numnodes + nnode1]]+=1; memset(pprobs1, 0, maxCategories*maxCategories*sizeof(double)); // estimate logP(nnode1|nnode2) for the perturbed sub-sample only for(j = 0; j < numsamplesPert; j++) pprobs1[maxCategories*pSamplesPert[j*numnodes + nnode2] + pSamplesPert[j*numnodes + nnode1]]+=1; for(i = 0; i < pNodeNumCats[nnode2]; i++) { fsum = 0; for(j = 0; j < pNodeNumCats[nnode1]; j++) fsum += pprobs2[maxCategories*i+j]; if(fsum <= 0) continue; faux = 1 / fsum; for(j = 0; j < pNodeNumCats[nnode1]; j++) pprobs2[maxCategories*i+j] *= faux; } floglik = 0; for(i = 0; i < pNodeNumCats[nnode2]; i++) { fsum = 0; for(j = 0; j < pNodeNumCats[nnode1]; j++) fsum += pprobs1[maxCategories*i+j]; if(fsum <= 0) continue; for(j = 0; j < pNodeNumCats[nnode1]; j++) { faux = pprobs1[maxCategories*i+j] - fsum*pprobs2[maxCategories*i+j]; if(pprobs2[maxCategories*i+j] > 0) floglik += (double)(faux*faux) / (double)(fsum*pprobs2[maxCategories*i+j]); else if(faux != 0 && pprobs2[maxCategories*i+j] == 0) floglik = FLT_MAX; } } klmat[nnode2*numnodes + nnode1] += floglik; } } if(!isNull(rPerturbations)) UNPROTECT(1); //rPerturbations UNPROTECT(1); //rSamples if(pSamplesPert) CATNET_FREE(pSamplesPert); if(pprobs1) CATNET_FREE(pprobs1); if(pprobs2) CATNET_FREE(pprobs2); if(pNodeCats) { for(i = 0; i < numnodes; i++) if(pNodeCats[i]) CATNET_FREE(pNodeCats[i]); CATNET_FREE(pNodeCats); } if(pNodeNumCats) CATNET_FREE(pNodeNumCats); PROTECT(rvec = NEW_NUMERIC(numnodes*numnodes)); pvec = NUMERIC_POINTER(rvec); memcpy(pvec, klmat, numnodes*numnodes*sizeof(double)); UNPROTECT(1); CATNET_FREE(klmat); //char str[128]; //sPRINTF(str, "Mem Balance %d\n", (int)g_memcounter); //Rprintf(str); return rvec; }
SEXP lcs(SEXP a, SEXP b, SEXP r_n_char) { SEXP M, LCS, LLCS, va, vb, QSI, list, list_names; int *PM, *Pva, *Pvb; double *PQSI; int i, j, na,nb,l, pos, n_char, PLLCS; char *names[7] = {"a","b", "LLCS", "LCS", "QSI", "va", "vb"}; /* Converting data from R */ PROTECT(a = AS_CHARACTER(a)); PROTECT(b = AS_CHARACTER(b)); PROTECT(r_n_char = AS_INTEGER(r_n_char)); n_char = INTEGER_POINTER(r_n_char)[0]; na = length(a)+1; //vorher m nb = length(b)+1; //vorher n l = max(na, nb) - 1; char *Pa[na-1], *Pb[nb-1]; //pointers to strings //Obtain strings from R for(i = 0; i < na-1; i++) { Pa[i]= R_alloc(strlen(CHAR(STRING_ELT(a, i))), sizeof(char)); strcpy(Pa[i], CHAR(STRING_ELT(a,i))); } for(j = 0; j < nb-1; j++){ Pb[j]= R_alloc(strlen(CHAR(STRING_ELT(b, j))), sizeof(char)); strcpy(Pb[j], CHAR(STRING_ELT(b,j))); } //build matrix to store calculation results for LCS PROTECT(M = allocMatrix(INTSXP, (na),(nb))); PM = INTEGER(M); //Initialize for(i = 0; i < na; i++) { for(j = 0; j < nb; j++){ PM[i+na*j] = 0; } } //Compare each character or string. //if there is a match, the "match counter" stored //in PM is incremented by one. for(i = 1; i < na; i++) { for(j = 1; j < nb; j++){ if (strcmp(Pa[i - 1],Pb[j - 1])==0) { PM[i + na * j] = PM[(i - 1) + na*(j - 1)] + 1; } else { PM[i + na* j] = max(PM[i + na*(j - 1)], PM[(i - 1) + na* j]); } } } //Read LCS-number from bottom right corner in PM PLLCS = PM[(na-1) + (na)*(nb-1)]; PROTECT(LLCS = NEW_INTEGER(1)); INTEGER(LLCS)[0]=PLLCS; //Variables to store additional results PROTECT(va = NEW_INTEGER(PLLCS)); PROTECT(vb = NEW_INTEGER(PLLCS)); PROTECT(QSI = NEW_NUMERIC(1)); Pva = INTEGER(va); Pvb = INTEGER(vb); char *PLCS[PLLCS]; for(i=0;i<PLLCS;i++){ PLCS[i]= R_alloc(n_char, sizeof(char)); } PQSI = NUMERIC_POINTER(QSI); //build LCS-sequence by traversing PM from bottom right towards //top left i = na-1; j = nb-1; pos = PLLCS; while (i > 0 && j > 0) { if (PM[i + na* j] == (PM[(i - 1) + na*( j - 1)] + 1) && strcmp(Pa[i - 1], Pb[j - 1])==0) { strcpy(PLCS[pos-1] , Pa[i-1]); Pva[pos-1] = i; Pvb[pos-1] = j; i--; j--; pos--; } else { if (PM[(i - 1) + na* j] > PM[i + (j - 1)*na]) { i--; } else { j--; } } } //Calculate fraction PQSI[0] = (double)PLLCS/(double)l; //Prepare LCS strings for retruning to R PROTECT(LCS = allocVector(STRSXP, PLLCS)); for(i=0;i<PLLCS;i++){ SET_STRING_ELT(LCS, i, mkChar(PLCS[i])); } //Generate List // a character string vector of the "names" attribute of the objects in our list PROTECT(list_names = allocVector(STRSXP, 7)); for(i = 0; i < 7; i++) SET_STRING_ELT(list_names, i, mkChar(names[i])); PROTECT(list = allocVector(VECSXP, 7)); // Creating a list with 7 vector elements SET_VECTOR_ELT(list, 0, a); // attaching myint vector to list SET_VECTOR_ELT(list, 1, b); // attaching mydouble vector to list SET_VECTOR_ELT(list, 2, LLCS); SET_VECTOR_ELT(list, 3, LCS); SET_VECTOR_ELT(list, 4, QSI); SET_VECTOR_ELT(list, 5, va); SET_VECTOR_ELT(list, 6, vb); setAttrib(list, R_NamesSymbol, list_names); //and attaching the vector names UNPROTECT(11); return(list); }
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; }
// 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; }
void evalgjacp(int n,double *x,double *g,int m,double *p,double *q, char work,int *gotj,int *flag) { int i; SEXP g_r,p_r,q_r,gotj_r,flag_r; defineVar(install("n") ,createRIntScalar(n) ,environment_r); defineVar(install("x") ,createRRealVector(n,x) ,environment_r); defineVar(install("m") ,createRIntScalar(m) ,environment_r); defineVar(install("work"),createRCharScalar(work),environment_r); defineVar(install("gotj") ,createRIntScalar(*gotj) ,environment_r); if ( work == 'J' || work == 'T' ) { // Compute g defineVar(install("g"),createRRealVector(n,x),environment_r); } if ( work == 'j' || work == 'J' ) { // Compute p = Jac q defineVar(install("q"),createRRealVector(n,q) ,environment_r); defineVar(install("p"),createRRealVector(1,NULL) ,environment_r); } else // if ( work == 't' || work == 'T' ) { // Compute q = Jac^t p defineVar(install("p"),createRRealVector(m,p) ,environment_r); defineVar(install("q"),createRRealVector(1,NULL) ,environment_r); } EVAL(evalgjacp_r); if ( work == 'J' || work == 'T' ) { // Compute g g_r = findVar(install("g") ,environment_r); for (i = 0; i < n; i++) g[i] = (REAL(EVAL(g_r)))[i]; } if ( work == 'j' || work == 'J' ) { // Compute p = Jac q p_r = findVar(install("p"),environment_r); for (i = 0; i < n; i++) p[i] = (REAL(EVAL(p_r)))[i]; } else // if ( work == 't' || work == 'T' ) { // Compute q = Jac^t p q_r = findVar(install("q"),environment_r); for (i = 0; i < n; i++) q[i] = (REAL(EVAL(q_r)))[i]; } gotj_r = findVar(install("gotj") ,environment_r); flag_r = findVar(install("flag") ,environment_r); *gotj = (INTEGER(AS_INTEGER(EVAL(gotj_r))))[0]; *flag = (INTEGER(AS_INTEGER(EVAL(flag_r))))[0]; }
// 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; }
/* * plr_SPI_prepare - The builtin SPI_prepare command for the R interpreter */ SEXP plr_SPI_prepare(SEXP rsql, SEXP rargtypes) { const char *sql; int nargs; int i; Oid *typeids = NULL; Oid *typelems = NULL; FmgrInfo *typinfuncs = NULL; void *pplan = NULL; void *saved_plan; saved_plan_desc *plan_desc; SEXP result; MemoryContext oldcontext; PREPARE_PG_TRY; /* set up error context */ PUSH_PLERRCONTEXT(rsupport_error_callback, "pg.spi.prepare"); /* switch to long lived context to create plan description */ oldcontext = MemoryContextSwitchTo(TopMemoryContext); plan_desc = (saved_plan_desc *) palloc(sizeof(saved_plan_desc)); MemoryContextSwitchTo(oldcontext); PROTECT(rsql = AS_CHARACTER(rsql)); sql = CHAR(STRING_ELT(rsql, 0)); UNPROTECT(1); if (sql == NULL) error("%s", "cannot prepare empty query"); PROTECT(rargtypes = AS_INTEGER(rargtypes)); if (!isVector(rargtypes) || !isInteger(rargtypes)) error("%s", "second parameter must be a vector of PostgreSQL datatypes"); /* deal with case of no parameters for the prepared query */ if (rargtypes == R_MissingArg || INTEGER(rargtypes)[0] == NA_INTEGER) nargs = 0; else nargs = length(rargtypes); if (nargs < 0) /* can this even happen?? */ error("%s", "second parameter must be a vector of PostgreSQL datatypes"); if (nargs > 0) { /* switch to long lived context to create plan description elements */ oldcontext = MemoryContextSwitchTo(TopMemoryContext); typeids = (Oid *) palloc(nargs * sizeof(Oid)); typelems = (Oid *) palloc(nargs * sizeof(Oid)); typinfuncs = (FmgrInfo *) palloc(nargs * sizeof(FmgrInfo)); MemoryContextSwitchTo(oldcontext); for (i = 0; i < nargs; i++) { int16 typlen; bool typbyval; char typdelim; Oid typinput, typelem; char typalign; FmgrInfo typinfunc; typeids[i] = INTEGER(rargtypes)[i]; /* switch to long lived context to create plan description elements */ oldcontext = MemoryContextSwitchTo(TopMemoryContext); get_type_io_data(typeids[i], IOFunc_input, &typlen, &typbyval, &typalign, &typdelim, &typelem, &typinput); typelems[i] = typelem; MemoryContextSwitchTo(oldcontext); /* perm_fmgr_info already uses TopMemoryContext */ perm_fmgr_info(typinput, &typinfunc); typinfuncs[i] = typinfunc; } } else typeids = NULL; UNPROTECT(1); /* switch to SPI memory context */ oldcontext = MemoryContextSwitchTo(plr_SPI_context); /* * trap elog/ereport so we can let R finish up gracefully * and generate the error once we exit the interpreter */ PG_TRY(); { /* Prepare plan for query */ pplan = SPI_prepare(sql, nargs, typeids); } PLR_PG_CATCH(); PLR_PG_END_TRY(); if (pplan == NULL) { char buf[128]; char *reason; switch (SPI_result) { case SPI_ERROR_ARGUMENT: reason = "SPI_ERROR_ARGUMENT"; break; case SPI_ERROR_UNCONNECTED: reason = "SPI_ERROR_UNCONNECTED"; break; case SPI_ERROR_COPY: reason = "SPI_ERROR_COPY"; break; case SPI_ERROR_CURSOR: reason = "SPI_ERROR_CURSOR"; break; case SPI_ERROR_TRANSACTION: reason = "SPI_ERROR_TRANSACTION"; break; case SPI_ERROR_OPUNKNOWN: reason = "SPI_ERROR_OPUNKNOWN"; break; default: snprintf(buf, sizeof(buf), "unknown RC %d", SPI_result); reason = buf; break; } /* internal error */ error("SPI_prepare() failed: %s", reason); } /* SPI_saveplan already uses TopMemoryContext */ saved_plan = SPI_saveplan(pplan); if (saved_plan == NULL) { char buf[128]; char *reason; switch (SPI_result) { case SPI_ERROR_ARGUMENT: reason = "SPI_ERROR_ARGUMENT"; break; case SPI_ERROR_UNCONNECTED: reason = "SPI_ERROR_UNCONNECTED"; break; default: snprintf(buf, sizeof(buf), "unknown RC %d", SPI_result); reason = buf; break; } /* internal error */ error("SPI_saveplan() failed: %s", reason); } /* back to caller's memory context */ MemoryContextSwitchTo(oldcontext); /* no longer need this */ SPI_freeplan(pplan); plan_desc->saved_plan = saved_plan; plan_desc->nargs = nargs; plan_desc->typeids = typeids; plan_desc->typelems = typelems; plan_desc->typinfuncs = typinfuncs; result = R_MakeExternalPtr(plan_desc, R_NilValue, R_NilValue); POP_PLERRCONTEXT; return result; }
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; } }
SEXP countCasesPorStream(SEXP porStream, SEXP s_types){ #ifdef DEBUG Rprintf("\n############################"); Rprintf("\n#countCasesPorStream"); Rprintf("\n############################"); #endif porStreamBuf *b = get_porStreamBuf(porStream); #ifdef DEBUG Rprintf("\nBuffer contents: |%s|",b->buf); Rprintf("\nLine: %d",b->line); Rprintf("\nPosition: %d",b->pos); Rprintf("\nBuffer remainder: %s",b->buf + b->pos); #endif PROTECT(s_types = AS_INTEGER(s_types)); int nvar = LENGTH(s_types); int *types = INTEGER(s_types); int i, j; char *charbuf; int charbuflen = 0; for(j = 0; j < nvar; j++){ if(types[j]!=0 && types[j] > charbuflen) charbuflen = types[j]; } charbuf = R_alloc(charbuflen+1,sizeof(char)); for(i = 0; ; i++){ #ifdef DEBUG Rprintf("\n==================="); Rprintf("\nCase nr. %d",i); Rprintf("\nBuffer contents: |%s|",b->buf); Rprintf("\nLine: %d",b->line); Rprintf("\nPosition: %d",b->pos); Rprintf("\nCurrent char: '%c'",b->buf[b->pos]); Rprintf("\nBuffer remainder: %s",b->buf + b->pos); #endif if(atEndPorStream(b) || (b->pos < 80 && b->buf[b->pos] == 'Z')){ #ifdef DEBUG Rprintf("\nReached end of cases at i=%d",i); #endif break; } #ifdef DEBUG Rprintf("\nCase number: %d nvar = %d\n",i,nvar); #endif for(j = 0; j < nvar; j++){ if(atEndPorStream(b)) { printPorStreamBuf(b); warning("\nPremature end of data"); break; } #ifdef DEBUG1 Rprintf("\n(j = %d)",j); if(types[j]==0) Rprintf(" %f",readDoublePorStream1(b)); else Rprintf(" '%s'",readCHARPorStream(b,charbuf,types[j])); #else if(types[j]==0) readDoublePorStream1(b); else readCHARPorStream(b,charbuf,types[j]); #endif } #ifdef DEBUG Rprintf("\n"); #endif } UNPROTECT(1); return ScalarInteger(i); }
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); }
/*! \author Hanne Rognebakke \brief Writes COST data after using the routine makedata_COST Only to be used for testing. */ int write_input_model1_COST(Data_orig *i_D_orig, Data_COST *i_D_COST, SEXP i_ageList,SEXP i_lgaList,SEXP i_priorList) { SEXP elmt = R_NilValue; int a,h,i,nBoatsObs,nBoatsMl,nFishObs,nFishMl,n,nFish; FILE *caa_input; int nAges; int *a_vec; int lga_g_a_model,lga_g_a_ncat; int *lga_g_a_a2Age_vec; double *lga_g_a_avec,*lga_g_a_par_init; caa_input = fopen("caa_input_model1_COST.txt","w"); if(!Rf_isNull(elmt = getListElement(i_ageList, "nAges"))) nAges = INTEGER_VALUE(elmt); if(!Rf_isNull(elmt = getListElement(i_ageList, "a_vec"))) a_vec = INTEGER_POINTER(AS_INTEGER(elmt)); fprintf(caa_input,"nAges=%d\n",nAges); for(a=0;a<nAges;a++) fprintf(caa_input,"a_vec[%d]=%d\n",a,a_vec[a]); lga_g_a_model = INTEGER_VALUE(getListElement(i_lgaList, "g_a_model")); lga_g_a_ncat = INTEGER_VALUE(getListElement(i_lgaList,"g_a_ncat")); lga_g_a_a2Age_vec = INTEGER_POINTER(AS_INTEGER(getListElement(i_lgaList,"g_a_a2Age_vec"))); lga_g_a_avec = NUMERIC_POINTER(getListElement(i_lgaList,"g_a_avec")); fprintf(caa_input,"g_a_model=%d\n",lga_g_a_model); for(a=0;a<lga_g_a_ncat;a++) fprintf(caa_input,"lga_g_a_a_vec[%d]=%f\n",a,lga_g_a_avec[a]); for(a=0;a<nAges;a++) fprintf(caa_input,"lga_g_a_a2Age_vec[%d]=%d\n",a,lga_g_a_a2Age_vec[a]); if(lga_g_a_model == 1) { if(!Rf_isNull(elmt = getListElement(i_lgaList, "g_a_par_init"))) lga_g_a_par_init = NUMERIC_POINTER(elmt); fprintf(caa_input,"g_a_par_init\n"); fprintf(caa_input,"c=%f,theta=%f,gamma=%f\n",lga_g_a_par_init[0], lga_g_a_par_init[1],lga_g_a_par_init[2]); } fprintf(caa_input,"n_int_len_lim=%d\n",i_D_orig->n_int_len); for(i=0;i<i_D_orig->n_int_len;i++) fprintf(caa_input,"%f\n",i_D_orig->int_len_lim[i]); fprintf(caa_input,"Observer data\n"); nBoatsObs = i_D_COST->obs->n_trip; fprintf(caa_input,"Number of trips=%d\n",nBoatsObs); nFishObs = 0; nFish = 0; for(h=0;h<nBoatsObs;h++) { fprintf(caa_input,"i=%d,nFishBoat=%d,start_Age=%d,start_noAge=%d,num_noAge=%d,season=%d,ndisc=%d,nland=%d\n", h,i_D_orig->nFishBoat[h],i_D_orig->start_Age[h],i_D_orig->start_noAge[h], i_D_orig->num_noAge[h],i_D_orig->season[h], i_D_orig->n_discard[h],i_D_orig->n_landed[h]); nFishObs += i_D_orig->nFishBoat[h]; nFish += i_D_orig->n_landed[h]; } fprintf(caa_input,"n_landed_tot=%d\n",nFish); fprintf(caa_input,"n=%d,trip[i],totage[i],totlength[i],replength[i],discard[i],landed[i]:\n", nFishObs); h = 0; n = i_D_orig->nFishBoat[0]-1; for(i=0;i<nFishObs;i++) { fprintf(caa_input,"%d,%d,%d,%f,%d,%d,%d\n",i,h, i_D_orig->totage[i],i_D_orig->totlength[i],i_D_orig->replength[i], i_D_orig->discard[i],i_D_orig->landed[i]); if(i==n) { h++; n += i_D_orig->nFishBoat[h]; } } fprintf(caa_input,"Market landing data\n"); nBoatsMl = i_D_COST->mland->n_trip; fprintf(caa_input,"Number of trips=%d\n",nBoatsMl); nFishMl = 0; nFish = 0; for(h=nBoatsObs;h<nBoatsObs+nBoatsMl;h++) { fprintf(caa_input,"i=%d,nFishBoat=%d,start_Age=%d,start_noAge=%d,num_noAge=%d,season=%d,ndisc=%d,nland=%d\n", h,i_D_orig->nFishBoat[h],i_D_orig->start_Age[h],i_D_orig->start_noAge[h], i_D_orig->num_noAge[h],i_D_orig->season[h], i_D_orig->n_discard[h],i_D_orig->n_landed[h]); nFishMl += i_D_orig->nFishBoat[h]; nFish += i_D_orig->n_landed[h]; } fprintf(caa_input,"n_landed_tot=%d\n",nFish); fprintf(caa_input,"n=%d,trip[i],totage[i],totlength[i],replength[i],discard[i],landed[i]:\n", nFishMl); h = nBoatsObs; for(i=nFishObs;i<nFishObs+nFishMl;i++) { fprintf(caa_input,"%d,%d,%d,%f,%d,%d,%d\n",i,h,i_D_orig->totage[i], i_D_orig->totlength[i],i_D_orig->replength[i], i_D_orig->discard[i],i_D_orig->landed[i]); if(i==n && i<nFishObs+nFishMl-1) { h++; n += i_D_orig->nFishBoat[h]; } } fclose(caa_input); return(0); } /* end of write_input_model1_COST */
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); }
/* 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 zSplitByFixedSizeBars(SEXP xIntVect, SEXP nBy, SEXP nCount) { int i, j, N, NBy, intSplitTo, intSplitTo2, startI; long long int sum=0; int *pNUM, *pResult; SEXP result; PROTECT(xIntVect = AS_INTEGER(xIntVect)); NBy = INTEGER_VALUE(nBy); N = INTEGER_VALUE(nCount); pNUM = INTEGER(xIntVect); //get sum for(i=0; i<N; i++) { sum += pNUM[i]; } //how many rows we'll need to split the volume bars to intSplitTo = sum/NBy; if(sum % NBy > 0) intSplitTo += 1; //reserve space for the results PROTECT(result = allocMatrix(INTSXP, intSplitTo, 3)); pResult = INTEGER(result); intSplitTo2 = intSplitTo * 2; //split j=0; //j is the index for the split matrix i=0; // i is the index of the original vector sum = 0; startI = 1; while(1) { if(sum >= NBy) //split { pResult[j] = startI; pResult[j+intSplitTo] = i; pResult[j+intSplitTo2] = NBy; sum -= NBy; if(sum == 0) startI = i+1; else startI = i; j++; continue; } if(i==N && sum <= NBy) { if(sum != 0) { // final split pResult[intSplitTo-1] = startI; pResult[intSplitTo2-1] = i; pResult[intSplitTo*3-1] = sum; } break; } if(i<N) { sum += pNUM[i]; i++; } } UNPROTECT(2); return result; }