Exemplo n.º 1
0
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);
}
Exemplo n.º 2
0
/*!
  \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 */
Exemplo n.º 3
0
Arquivo: do_mdwt.c Projeto: cran/rwt
/*
 * 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;
}
Exemplo n.º 4
0
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;    
}
Exemplo n.º 5
0
// 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);
}
Exemplo n.º 6
0
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;

}
Exemplo n.º 7
0
/* ******************************************************************
   ****************************************************************** */
   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];
   }

   }
Exemplo n.º 8
0
Arquivo: Train.cpp Projeto: rforge/crf
SEXP CRF_NLL(SEXP _crf, SEXP _par, SEXP _instances, SEXP _nodeFea, SEXP _edgeFea, SEXP _nodeExt, SEXP _edgeExt, SEXP _infer, SEXP _env)
{
	CRF crf(_crf);

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

		UNPROTECT(3);
	}

	UNPROTECT(4);

	return(_nll);
}
Exemplo n.º 9
0
//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);
}
Exemplo n.º 10
0
Arquivo: Train.cpp Projeto: rforge/crf
void CRF::Update_Pot(SEXP _nodeFea, SEXP _edgeFea, SEXP _nodeExt, SEXP _edgeExt)
{
	int nPar = INTEGER_POINTER(AS_INTEGER(GetVar(_crf, "n.par")))[0];

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

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

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

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

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

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

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

	UNPROTECT(1);
}
Exemplo n.º 11
0
Arquivo: Train.cpp Projeto: rforge/crf
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);
}
Exemplo n.º 12
0
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;
}
Exemplo n.º 13
0
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;
}
Exemplo n.º 14
0
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);
}
Exemplo n.º 15
0
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;
}
Exemplo n.º 16
0
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);
}
Exemplo n.º 17
0
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;

}
Exemplo n.º 18
0
Arquivo: lcs.c Projeto: cran/qualV
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);

}
Exemplo n.º 19
0
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;
	}
Exemplo n.º 21
0
   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;
	}
Exemplo n.º 23
0
/*
 * 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;
}
Exemplo n.º 24
0
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;
  }
}
Exemplo n.º 25
0
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);
}
Exemplo n.º 26
0
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);  
}
Exemplo n.º 27
0
/*!
  \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 */
Exemplo n.º 28
0
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);
}
Exemplo n.º 29
0
/*
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;
}