Esempio n. 1
0
SEXP rint_flmm(SEXP pexplan_sexp, SEXP presp_sexp, SEXP pn_sexp, SEXP pp_sexp, SEXP pcovar_sexp, SEXP pp_covar_sexp, SEXP pVar2_sexp, SEXP nu_naught_sexp, SEXP gamma_naught_sexp)
{

  double *pexplan, *presp,  *pnu_naught, *pgamma_naught, *pcovar, *pVar2;
  double* pchisq;
  double* pherit;
  unsigned int *pn, *pp_covar, *pp;
 

  char pret_names[][100]={"chi.sq", "herit", "null.herit"};

  SEXP preturn_list_SEXP, preturn_names_SEXP, paname_SEXP;
    
  SEXP pchisq_SEXP;
  SEXP pherit_SEXP;
  SEXP pnullherit_SEXP;

  gsl_matrix* pvar1_mat, *pvar2_mat;
  gsl_matrix* pcovar_mat;
 
  gsl_vector* presponse_vec;

  double* pnullherit;
      
  // really must check all gsl returns
  //gsl_set_error_handler_off();

  // C side pointers to R objects
  pexplan=(double*) REAL(pexplan_sexp);
  presp=(double*) REAL(presp_sexp);
  pn=(unsigned int*) INTEGER(pn_sexp);
  pp=(unsigned int*) INTEGER(pp_sexp);
  pcovar=(double*) REAL(pcovar_sexp);
  pp_covar=(unsigned int*) INTEGER(pp_covar_sexp);
  pVar2=(double*) REAL(pVar2_sexp);
  pnu_naught=(double*)REAL(nu_naught_sexp);
  pgamma_naught=(double*)REAL(gamma_naught_sexp);
  

  presponse_vec=&(gsl_vector_view_array(presp, *pn).vector);
  pvar2_mat=&(gsl_matrix_view_array(pVar2, *pn, *pn).matrix);
  pvar1_mat=gsl_matrix_alloc(*pn, *pn);
  pcovar_mat=&(gsl_matrix_view_array(pcovar, *pn, *pp_covar).matrix);
  
  gsl_matrix* pincid1_mat, *pincid2_mat;
 
  pincid1_mat=gsl_matrix_alloc(*pn,*pn);
  pincid2_mat=gsl_matrix_alloc(*pn,*pn);

  gsl_matrix_set_identity(pvar1_mat);
  // gsl_matrix_set_identity(pvar2_mat); 
  gsl_matrix_set_identity(pincid1_mat);
  gsl_matrix_set_identity(pincid2_mat); 

   
  PROTECT(pchisq_SEXP=NEW_NUMERIC(*pp));
  pchisq=NUMERIC_POINTER(pchisq_SEXP);
  PROTECT(pherit_SEXP=NEW_NUMERIC(*pp));
  pherit=NUMERIC_POINTER(pherit_SEXP);
  PROTECT(pnullherit_SEXP=NEW_NUMERIC(1));
  pnullherit=NUMERIC_POINTER(pnullherit_SEXP);

    
  TwoVarCompModel DaddyTwoVarCompModel(presponse_vec, pcovar_mat, pvar1_mat, pvar2_mat, pincid1_mat, pincid2_mat);  
  double nullminimand=0.5;
  double altminimand;
  double nulldev=DaddyTwoVarCompModel.MinimiseNullDeviance(&nullminimand);
  *pnullherit=nullminimand;
  //std::cout << "null sigmasq=" << nullminimand<<std::endl<<std::endl;
  //DaddyTwoVarCompModel.NullDeviance(0.5);
  
#pragma omp parallel shared(pexplan, pp, pn, pchisq, pherit, nulldev, nullminimand) private(altminimand)
    {
      TwoVarCompModel ChildTwoVarCompModel(DaddyTwoVarCompModel);
      
#pragma omp for
      for(int it=0;it<*pp;it++)
	{
#pragma omp critical
	  { 
	    std::cout<<".";
	  }
	  TwoVarCompModel ATwoVarCompModel(DaddyTwoVarCompModel);
	  ChildTwoVarCompModel.SetExplan(&(gsl_vector_view_array(pexplan+(*pn)*it, *pn).vector));
	  altminimand=nullminimand;
	  pchisq[it]=nulldev-ChildTwoVarCompModel.MinimiseDeviance(&altminimand);
	  pherit[it]=altminimand;
	
	}    
    }
  
  

  PROTECT(preturn_list_SEXP=allocVector(VECSXP,3));
  SET_VECTOR_ELT(preturn_list_SEXP, 0,pchisq_SEXP);
  SET_VECTOR_ELT(preturn_list_SEXP, 1,pherit_SEXP);
  SET_VECTOR_ELT(preturn_list_SEXP, 2,pnullherit_SEXP);
 
 
  PROTECT(preturn_names_SEXP=allocVector(STRSXP,3));

  
  for(int it=0;it<3;it++)
    {
      
      PROTECT(paname_SEXP=Rf_mkChar(pret_names[it]));
      SET_STRING_ELT(preturn_names_SEXP,it,paname_SEXP);
    }
  setAttrib(preturn_list_SEXP, R_NamesSymbol,preturn_names_SEXP);
  
  UNPROTECT(8);

  return preturn_list_SEXP;
}
Esempio n. 2
0
SEXP rgeos_geosring2Polygon(SEXP env, GEOSGeom lr, int hole) {
    
    GEOSContextHandle_t GEOShandle = getContextHandle(env);
    int pc=0;
    
    GEOSCoordSeq s = (GEOSCoordSequence *) GEOSGeom_getCoordSeq_r(GEOShandle, lr);
    if (s == NULL) 
        error("rgeos_geosring2Polygon: CoordSeq failure");
    
    unsigned int n;
    if (GEOSCoordSeq_getSize_r(GEOShandle, s, &n) == 0)
        error("rgeos_geosring2Polygon: CoordSeq failure");
    
    // Get coordinates
    SEXP crd;
    PROTECT(crd = rgeos_crdMatFixDir(rgeos_CoordSeq2crdMat(env, s, FALSE, hole), hole)); pc++;
    
    // Calculate area
    GEOSGeom p = GEOSGeom_createPolygon_r(GEOShandle,GEOSGeom_clone_r(GEOShandle,lr),NULL,0);
    if (p == NULL) 
        error("rgeos_geosring2Polygon: unable to create polygon");
    
    SEXP area;
    PROTECT(area = NEW_NUMERIC(1)); pc++;
    NUMERIC_POINTER(area)[0] = 0.0;
    if (!GEOSArea_r(GEOShandle, p, NUMERIC_POINTER(area)))
        error("rgeos_geosring2Polygon: area calculation failure");
    
    
    // Calculate label position
    SEXP labpt;
    PROTECT(labpt = NEW_NUMERIC(2)); pc++;
    
    GEOSGeom centroid = GEOSGetCentroid_r(GEOShandle, p);
    double xc, yc;
    rgeos_Pt2xy(env, centroid, &xc, &yc);
    
    if (!R_FINITE(xc) || !R_FINITE(yc)) {
        xc = 0.0;
        yc = 0.0;
        for(int i=0; i != n; i++) {
            xc += NUMERIC_POINTER(crd)[i];
            yc += NUMERIC_POINTER(crd)[(int) (n) +i];
        }
        
        xc /= n;
        yc /= n;
    }
    
    NUMERIC_POINTER(labpt)[0] = xc;
    NUMERIC_POINTER(labpt)[1] = yc;
    
    GEOSGeom_destroy_r(GEOShandle, centroid);
    GEOSGeom_destroy_r(GEOShandle, p);
    
    // Get ring direction
    SEXP ringDir;
    PROTECT(ringDir = NEW_INTEGER(1)); pc++;
    INTEGER_POINTER(ringDir)[0] = hole ? -1 : 1;
    
    // Get hole status
    SEXP Hole;
    PROTECT(Hole = NEW_LOGICAL(1)); pc++;
    LOGICAL_POINTER(Hole)[0] = hole;
    
    SEXP ans;
    PROTECT(ans = NEW_OBJECT(MAKE_CLASS("Polygon"))); pc++;    
    SET_SLOT(ans, install("ringDir"), ringDir);
    SET_SLOT(ans, install("labpt"), labpt);
    SET_SLOT(ans, install("area"), area);
    SET_SLOT(ans, install("hole"), Hole);
    SET_SLOT(ans, install("coords"), crd);
    
    SEXP valid;
    PROTECT(valid = SP_PREFIX(Polygon_validate_c)(ans)); pc++;
    if (!isLogical(valid)) {
        UNPROTECT(pc);
        if (isString(valid)) 
            error(CHAR(STRING_ELT(valid, 0)));
        else 
            error("invalid Polygon object");
    }
    
    UNPROTECT(pc);
    return(ans);
}
Esempio n. 3
0
SEXP rint_flmm(SEXP pexplan_sexp, SEXP presp_sexp, SEXP pn_sexp, SEXP pp_sexp, SEXP pcovar_sexp, SEXP pp_covar_sexp, SEXP pVar2_sexp, SEXP nu_naught_sexp, SEXP gamma_naught_sexp)
{

  double *pexplan, *presp,  *pnu_naught, *pgamma_naught, *pcovar, *pVar2;
  double* pchisq;
  double* pherit;
  unsigned int *pn, *pp_covar, *pp;
 

  char pret_names[][100]={"coefs", "chi.sq", "herit", "null.herit"};

  SEXP preturn_list_SEXP, preturn_names_SEXP, paname_SEXP;
    
  SEXP pchisq_SEXP;
  SEXP pherit_SEXP;
  SEXP pbeta_SEXP;
  SEXP pnullherit_SEXP;

  gsl_matrix* pvar1_mat, *pvar2_mat;
  gsl_matrix* pcovar_mat;
 
  gsl_vector* presponse_vec;

  double* pnullherit;
  double* pbeta;
  

  // really must check all gsl returns
  gsl_set_error_handler_off();

  // C side pointers to R objects
  pexplan=(double*) REAL(pexplan_sexp);
  presp=(double*) REAL(presp_sexp);
  pn=(unsigned int*) INTEGER(pn_sexp);
  pp=(unsigned int*) INTEGER(pp_sexp);
  pcovar=(double*) REAL(pcovar_sexp);
  pp_covar=(unsigned int*) INTEGER(pp_covar_sexp);
  pVar2=(double*) REAL(pVar2_sexp);
  pnu_naught=(double*) REAL(nu_naught_sexp);
  pgamma_naught=(double*) REAL(gamma_naught_sexp);
  
  
  /* gsl_vector_view response_vecview=gsl_vector_view_array(presp, *pn);
     presponse_vec=&(response_vecview.vector);*/
  gsl_matrix_view var2_matview=gsl_matrix_view_array(pVar2, *pn, *pn);
  pvar2_mat=&(var2_matview.matrix);
  // freed
  pvar1_mat=gsl_matrix_alloc(*pn, *pn);
  /* gsl_matrix_view covar_matview=gsl_matrix_view_array(pcovar, *pn, *pp_covar);
     pcovar_mat=&(covar_matview.matrix);*/

  // sort out missing in response
  // better to bulk copy then iterate?
  unsigned int it;
  unsigned int nonzerocount=0;
  // freed
  presponse_vec=gsl_vector_alloc(*pn);
  double meanval=0.0;
  for(it=0;it<*pn;it++)
    {
      if(!ISNA(presp[it]))
	{
	  meanval+=presp[it];
	  nonzerocount+=1;
	}
    }
  meanval/=(double) nonzerocount;
  
  for(it=0;it<*pn;it++)
    {
      if(ISNA(presp[it]))
	gsl_vector_set(presponse_vec, it, meanval);
      else
	gsl_vector_set(presponse_vec, it, presp[it]);  
    }

  // freed
  pcovar_mat=gsl_matrix_alloc( *pn, *pp_covar);
  unsigned it2;
  for(it2=0;it2<*pp_covar;it2++)
    {
      meanval=0.0;
      nonzerocount=0;
      for(it=0;it<*pn;it++)
	{
	  if(!ISNA(pcovar[it*(*pp_covar)+it2]))
	    {
	      meanval+=pcovar[it*(*pp_covar)+it2];
	      nonzerocount+=1;
	    }
	}
      meanval/=(double) nonzerocount;
      for(it=0;it<*pn;it++)
	{
	  if(ISNA(pcovar[it*(*pp_covar)+it2]))
	    gsl_matrix_set(pcovar_mat, it, it2, meanval);
	  else
	    gsl_matrix_set(pcovar_mat, it, it2, pcovar[it*(*pp_covar)+it2]);  
	}
    }

  
  /*std::cout<<"cov="<<pcovar[0]<<","<<pcovar[1]<<","<<pcovar[2]<<std::endl;
    std::cout<<"pcovar_mat";
  gslprint(pcovar_mat);*/
  

  gsl_matrix* pincid1_mat, *pincid2_mat;
 
  // freed
  pincid1_mat=gsl_matrix_alloc(*pn,*pn);
  //freed
  pincid2_mat=gsl_matrix_alloc(*pn,*pn);

  gsl_matrix_set_identity(pvar1_mat);
  // gsl_matrix_set_identity(pvar2_mat); 
  gsl_matrix_set_identity(pincid1_mat);
  gsl_matrix_set_identity(pincid2_mat); 

  PROTECT(pbeta_SEXP=NEW_NUMERIC(*pp));
  pbeta=NUMERIC_POINTER(pbeta_SEXP);
  PROTECT(pchisq_SEXP=NEW_NUMERIC(*pp));
  pchisq=NUMERIC_POINTER(pchisq_SEXP);
  PROTECT(pherit_SEXP=NEW_NUMERIC(*pp));
  pherit=NUMERIC_POINTER(pherit_SEXP);
  PROTECT(pnullherit_SEXP=NEW_NUMERIC(1));
  pnullherit=NUMERIC_POINTER(pnullherit_SEXP);

  
  TwoVarCompModel DaddyTwoVarCompModel(presponse_vec, pcovar_mat, pvar1_mat, pvar2_mat, pincid1_mat, pincid2_mat, pnu_naught, pgamma_naught);  
  double nullminimand=0.5;
  double altminimand;
  double nulldev=DaddyTwoVarCompModel.MinimiseNullDeviance(&nullminimand);
  *pnullherit=nullminimand;
  
  /*std::cout<<"si==0.2"<<std::endl<<DaddyTwoVarCompModel.NullDeviance(0.2)<<std::endl;	 
  std::cout<<"si==0.4"<<std::endl<<DaddyTwoVarCompModel.NullDeviance(0.4)<<std::endl;	 
  std::cout<<"si==0.6"<<std::endl<<DaddyTwoVarCompModel.NullDeviance(0.6)<<std::endl;
  std::cout<<"si==0.8"<<std::endl<<DaddyTwoVarCompModel.NullDeviance(0.8)<<std::endl;
  */
  
 
  pgsl_vector* ppexplantemp_vec = new pgsl_vector[OMP_GET_MAX_THREADS];
  pgsl_vector* ppbeta_vec=new pgsl_vector[OMP_GET_MAX_THREADS];
  for(it=0;it<OMP_GET_MAX_THREADS;it++)
    {
      ppexplantemp_vec[it]=gsl_vector_alloc(*pn);
      ppbeta_vec[it]=gsl_vector_alloc(1);

    }
  #pragma omp parallel for shared(pexplan, pp, pn, pchisq, pherit, nulldev, nullminimand, ppexplantemp_vec, pbeta, ppbeta_vec) private(altminimand, it2, meanval, nonzerocount)
  for(it=0;it<*pp;it++)
    {
      TwoVarCompModel ChildTwoVarCompModel(DaddyTwoVarCompModel);
//      std::cout<<".";
      
      meanval=0.0;
      nonzerocount=0;
      for(it2=0;it2<*pn;it2++)
	{
	  if(!ISNA(pexplan[it2+(*pn)*it]))
		{
		  meanval+=pexplan[it2+(*pn)*it];
		  nonzerocount+=1;
		}
	}
      meanval/=(double) nonzerocount;
      
      for(it2=0;it2<*pn;it2++)
	{
	  if(ISNA(pexplan[it2+(*pn)*it]))
	    gsl_vector_set(ppexplantemp_vec[OMP_GET_THREAD_NUM], it2, meanval);
	  else
	    gsl_vector_set(ppexplantemp_vec[OMP_GET_THREAD_NUM], it2, pexplan[it2+(*pn)*it]);  
	}
      ChildTwoVarCompModel.SetExplan(ppexplantemp_vec[OMP_GET_THREAD_NUM]);
      altminimand=nullminimand;
    
      pchisq[it]=nulldev-ChildTwoVarCompModel.MinimiseDeviance(&altminimand);
      
      pherit[it]=altminimand;
      ChildTwoVarCompModel.GetBeta(ppbeta_vec[OMP_GET_THREAD_NUM], altminimand);
      pbeta[it]=gsl_vector_get(ppbeta_vec[OMP_GET_THREAD_NUM], 0);
      
    }
  for(it=0;it<OMP_GET_MAX_THREADS;it++)
    {
      gsl_vector_free(ppexplantemp_vec[it]);
      gsl_vector_free(ppbeta_vec[it]);
    }
  delete[] ppexplantemp_vec;
  delete[] ppbeta_vec;
  
  gsl_matrix_free(pvar1_mat);
  gsl_vector_free(presponse_vec);
  gsl_matrix_free(pcovar_mat);
  gsl_matrix_free(pincid1_mat);
  gsl_matrix_free(pincid2_mat);
  
  
  PROTECT(preturn_list_SEXP=allocVector(VECSXP,4));
  SET_VECTOR_ELT(preturn_list_SEXP, 0,pbeta_SEXP);
  SET_VECTOR_ELT(preturn_list_SEXP, 1,pchisq_SEXP);
  SET_VECTOR_ELT(preturn_list_SEXP, 2,pherit_SEXP);
  SET_VECTOR_ELT(preturn_list_SEXP, 3,pnullherit_SEXP);
 
 
  PROTECT(preturn_names_SEXP=allocVector(STRSXP,4));

  
  for(int it=0;it<4;it++)
    {
      
      PROTECT(paname_SEXP=Rf_mkChar(pret_names[it]));
      SET_STRING_ELT(preturn_names_SEXP,it,paname_SEXP);
    }
  setAttrib(preturn_list_SEXP, R_NamesSymbol,preturn_names_SEXP);
  
  UNPROTECT(10);

  return preturn_list_SEXP;
}
Esempio n. 4
0
    sexp_p[i] = v[i];							\
  }									\
  R_PreserveObject(sexp);						\
  UNPROTECT(1);								\
  RStatus ^= RINTERF_IDLE;						\
  return sexp;								\


SEXP
SexpDoubleVector_new(double *v, int n) {
    RINTERF_NEWVECTOR(NUMERIC_POINTER, NEW_NUMERIC(n), double)
}

SEXP
SexpDoubleVector_new_nofill(int n) {
    RINTERF_NEWVECTOR_NOFILL(NEW_NUMERIC(n))
}

SEXP
SexpDoubleVectorMatrix_new(double *v, int nx, int ny) {
    int n = nx * ny;
    RINTERF_NEWVECTOR(NUMERIC_POINTER, allocMatrix(REALSXP, nx, ny), double)
}

SEXP
SexpDoubleVectorMatrix_new_nofill(int nx, int ny) {
    int n = nx * ny;
    RINTERF_NEWVECTOR_NOFILL(allocMatrix(REALSXP, nx, ny))
}

SEXP
Esempio n. 5
0
SEXP rgeos_geospolygon2Polygons(SEXP env, GEOSGeom geom, SEXP ID) {

    GEOSContextHandle_t GEOShandle = getContextHandle(env);
    int pc=0;
    
    int type = GEOSGeomTypeId_r(GEOShandle, geom);    
    int empty = GEOSisEmpty_r(GEOShandle, geom);
    int ngeom = GEOSGetNumGeometries_r(GEOShandle, geom);
    ngeom = ngeom ? ngeom : 1;
    
    int npoly = 0;
    
    for (int i=0; i<ngeom; i++) {
        GEOSGeom GC = (type == GEOS_MULTIPOLYGON && !empty) ?
                        (GEOSGeometry *) GEOSGetGeometryN_r(GEOShandle, geom, i) :
                        geom;
        int GCempty = GEOSisEmpty_r(GEOShandle, GC);
        int GCpolys = (GCempty) ? 1 :
                        GEOSGetNumInteriorRings_r(GEOShandle, GC) + 1;

        npoly += GCpolys;
    }
    
    SEXP polys;
    PROTECT(polys = NEW_LIST(npoly)); pc++;
    int *comm = (int *) R_alloc((size_t) npoly, sizeof(int));
    int *po = (int *) R_alloc((size_t) npoly, sizeof(int));
    double *areas = (double *) R_alloc((size_t) npoly, sizeof(double));
    
    double totalarea = 0.0;
    int k = 0;
    for (int i=0; i<ngeom; i++) {
        
        GEOSGeom GC = (type == GEOS_MULTIPOLYGON && !empty) ?
                        (GEOSGeometry *) GEOSGetGeometryN_r(GEOShandle, geom, i) :
                        geom;
        
        if (GEOSisEmpty_r(GEOShandle, GC)) {
            
            SEXP ringDir,area,labpt,hole;
            
            PROTECT(ringDir = NEW_INTEGER(1));
            INTEGER_POINTER(ringDir)[0] = 1;
            
            PROTECT(labpt = NEW_NUMERIC(2));
            NUMERIC_POINTER(labpt)[0] = NA_REAL;
            NUMERIC_POINTER(labpt)[1] = NA_REAL;
            
            PROTECT(area = NEW_NUMERIC(1));
            NUMERIC_POINTER(area)[0] = 0.0;
            
            PROTECT(hole = NEW_LOGICAL(1));
            LOGICAL_POINTER(hole)[0] = TRUE;
            
            SEXP poly;
            PROTECT(poly = NEW_OBJECT(MAKE_CLASS("Polygon")));    
            SET_SLOT(poly, install("ringDir"), ringDir);
            SET_SLOT(poly, install("labpt"), labpt);
            SET_SLOT(poly, install("area"), area);
            SET_SLOT(poly, install("hole"), hole);
            SET_SLOT(poly, install("coords"), R_NilValue);
            
            SET_VECTOR_ELT(polys, k, poly);
            UNPROTECT(5);
            
            comm[k] = 0;
            areas[k] = 0;
            po[k] = k + R_OFFSET;
// modified 131004 RSB 
// https://stat.ethz.ch/pipermail/r-sig-geo/2013-October/019470.html
//            warning("rgeos_geospolygon2Polygons: empty Polygons object");
            error("rgeos_geospolygon2Polygons: empty Polygons object");
            
            k++;
        } else {
        
            GEOSGeom lr = (GEOSGeometry *) GEOSGetExteriorRing_r(GEOShandle, GC);
            if (lr == NULL)
                error("rgeos_geospolygon2Polygons: exterior ring failure");
        
            SET_VECTOR_ELT(polys, k, rgeos_geosring2Polygon(env, lr, FALSE));
            comm[k] = 0;
        
            areas[k] = NUMERIC_POINTER( GET_SLOT(VECTOR_ELT(polys,k), install("area")) )[0];
            totalarea += areas[k];
            po[k] = k + R_OFFSET;
        
            int ownerk = k + R_OFFSET;
        
            k++;
        
            int nirs = GEOSGetNumInteriorRings_r(GEOShandle, GC);
            for (int j=0; j<nirs; j++) {
            
                lr = (GEOSGeometry *) GEOSGetInteriorRingN_r(GEOShandle, GC, j);
                if (lr == NULL)
                    error("rgeos_geospolygon2Polygons: interior ring failure");
            
                SET_VECTOR_ELT(polys, k, rgeos_geosring2Polygon(env, lr, TRUE));
                comm[k] = ownerk;
            
                areas[k] = NUMERIC_POINTER( GET_SLOT(VECTOR_ELT(polys,k), install("area")) )[0];
                po[k] = k + R_OFFSET;
            
                k++;
            }
        }
    }
    
    SEXP plotOrder;
    PROTECT(plotOrder = NEW_INTEGER(npoly)); pc++;
    revsort(areas, po, npoly);
    for (int i=0; i<npoly; i++) 
        INTEGER_POINTER(plotOrder)[i] = po[i];
    
    SEXP labpt = GET_SLOT(VECTOR_ELT(polys,po[0]-1), install("labpt"));
    
    SEXP area;
    PROTECT(area = NEW_NUMERIC(1)); pc++;
    NUMERIC_POINTER(area)[0] = totalarea;
    
    SEXP comment;
    PROTECT(comment = NEW_CHARACTER(1)); pc++;
    char *buf;
    int nc;

    nc = (int) (ceil(log10(npoly)+1.0))+1;
    buf = (char *) R_alloc((size_t) (npoly*nc)+1, sizeof(char));
    SP_PREFIX(comm2comment)(buf, (npoly*nc)+1, comm, npoly);
    SET_STRING_ELT(comment, 0, mkChar((const char*) buf));

    SEXP ans;
    PROTECT(ans = NEW_OBJECT(MAKE_CLASS("Polygons"))); pc++;    
    SET_SLOT(ans, install("Polygons"), polys);
    SET_SLOT(ans, install("plotOrder"), plotOrder);
    SET_SLOT(ans, install("labpt"), labpt);
    SET_SLOT(ans, install("ID"), ID);
    SET_SLOT(ans, install("area"), area);
    setAttrib(ans, install("comment"), comment);

    UNPROTECT(pc);
    return(ans);
}
Esempio n. 6
0
SEXP DEoptimC(SEXP lower, SEXP upper, SEXP fn, SEXP control, SEXP rho, SEXP fnMap)
{
  int i, j, P=0;

  if (!isFunction(fn))
    error("fn is not a function!");
  if (!isEnvironment(rho))
    error("rho is not an environment!");

  /*-----Initialization of annealing parameters-------------------------*/
  /* value to reach */
  double VTR = NUMERIC_VALUE(getListElement(control, "VTR"));
  /* chooses DE-strategy */
  int i_strategy = INTEGER_VALUE(getListElement(control, "strategy"));
  /* Maximum number of generations */
  int i_itermax = INTEGER_VALUE(getListElement(control, "itermax"));
  /* Dimension of parameter vector */
  int i_D = INTEGER_VALUE(getListElement(control, "npar"));
  /* Number of population members */
  int i_NP = INTEGER_VALUE(getListElement(control, "NP"));
  /* When to start storing populations */
  int i_storepopfrom = INTEGER_VALUE(getListElement(control, "storepopfrom"))-1;
  /* How often to store populations */
  int i_storepopfreq = INTEGER_VALUE(getListElement(control, "storepopfreq"));
  /* User-defined inital population */
  int i_specinitialpop = INTEGER_VALUE(getListElement(control, "specinitialpop"));
  double *initialpopv = NUMERIC_POINTER(getListElement(control, "initialpop"));
  /* stepsize */
  double d_weight = NUMERIC_VALUE(getListElement(control, "F"));
  /* crossover probability */
  double d_cross = NUMERIC_VALUE(getListElement(control, "CR"));
  /* Best of parent and child */
  int i_bs_flag = NUMERIC_VALUE(getListElement(control, "bs"));
  /* Print progress? */
  int i_trace = NUMERIC_VALUE(getListElement(control, "trace"));
  /* p to define the top 100p% best solutions */
  double d_pPct = NUMERIC_VALUE(getListElement(control, "p"));
  /* crossover adaptation (a positive constant between 0 and 1) */
  double d_c = NUMERIC_VALUE(getListElement(control, "c"));
  /* relative tolerance */
  double d_reltol = NUMERIC_VALUE(getListElement(control, "reltol"));
  /* relative tolerance steps */
  int i_steptol = NUMERIC_VALUE(getListElement(control, "steptol"));

  int i_nstorepop = ceil((i_itermax - i_storepopfrom) / i_storepopfreq);
  /* Use S_alloc, since it initializes with zeros FIXME: these should be SEXP */
  double *gd_storepop = (double *)S_alloc(i_NP,sizeof(double) * i_D * i_nstorepop);

  /* External pointers to return to R */
  SEXP sexp_bestmem, sexp_bestval, sexp_nfeval, sexp_iter,
    out, sexp_pop, sexp_storepop, sexp_bestmemit, sexp_bestvalit;

  PROTECT(sexp_bestmem = NEW_NUMERIC(i_D)); P++;
  PROTECT(sexp_pop = allocMatrix(REALSXP, i_D, i_NP)); P++;
  PROTECT(sexp_bestmemit = allocMatrix(REALSXP, i_itermax, i_D)); P++;
  PROTECT(sexp_bestvalit = allocVector(REALSXP, i_itermax)); P++;
  double *gt_bestP     = REAL(sexp_bestmem);
  double *gd_pop       = REAL(sexp_pop);
  double *gd_bestmemit = REAL(sexp_bestmemit);
  double *gd_bestvalit = REAL(sexp_bestvalit);

  /* ensure lower and upper are double */
  if(TYPEOF(lower) != REALSXP) {PROTECT(lower = coerceVector(lower, REALSXP)); P++;}
  if(TYPEOF(upper) != REALSXP) {PROTECT(upper = coerceVector(upper, REALSXP)); P++;}
  double *d_lower      = REAL(lower);
  double *d_upper      = REAL(upper);

  double gt_bestC;
  int gi_iter = 0;
  long l_nfeval = 0;

  /*---optimization--------------------------------------*/
  devol(VTR, d_weight, d_cross, i_bs_flag, d_lower, d_upper, fn, rho, i_trace,
        i_strategy, i_D, i_NP, i_itermax,
        initialpopv, i_storepopfrom, i_storepopfreq,
        i_specinitialpop,
        gt_bestP, &gt_bestC,
        gd_pop, gd_storepop, gd_bestmemit, gd_bestvalit,
        &gi_iter, d_pPct, d_c, &l_nfeval,
        d_reltol, i_steptol, fnMap);
  /*---end optimization----------------------------------*/

  j =  i_nstorepop * i_NP * i_D;
  PROTECT(sexp_storepop = NEW_NUMERIC(j)); P++;
  for (i = 0; i < j; i++)
    NUMERIC_POINTER(sexp_storepop)[i] = gd_storepop[i];

  PROTECT(sexp_nfeval = ScalarInteger(l_nfeval)); P++;
  PROTECT(sexp_iter = ScalarInteger(gi_iter)); P++;
  PROTECT(sexp_bestval = ScalarReal(gt_bestC)); P++;

  const char *out_names[] = {"bestmem", "bestval", "nfeval",
      "iter", "bestmemit", "bestvalit", "pop", "storepop", ""};
  PROTECT(out = mkNamed(VECSXP, out_names)); P++;
  SET_VECTOR_ELT(out, 0, sexp_bestmem);
  SET_VECTOR_ELT(out, 1, sexp_bestval);
  SET_VECTOR_ELT(out, 2, sexp_nfeval);
  SET_VECTOR_ELT(out, 3, sexp_iter);
  SET_VECTOR_ELT(out, 4, sexp_bestmemit);
  SET_VECTOR_ELT(out, 5, sexp_bestvalit);
  SET_VECTOR_ELT(out, 6, sexp_pop);
  SET_VECTOR_ELT(out, 7, sexp_storepop);

  UNPROTECT(P);
  return out;
}
Esempio n. 7
0
void devol(double VTR, double d_weight, double d_cross, int i_bs_flag,
           double *d_lower, double *d_upper, SEXP fcall, SEXP rho, int trace,
           int i_strategy, int i_D, int i_NP, int i_itermax,
           double *initialpopv, int i_storepopfrom, int i_storepopfreq,
           int i_specinitialpop, 
           double *gt_bestP, double *gt_bestC,
           double *gd_pop, double *gd_storepop, double *gd_bestmemit, double *gd_bestvalit,
           int *gi_iter, double d_pPct, double d_c, long *l_nfeval,
           double d_reltol, int i_steptol, SEXP fnMap)
{

#define URN_DEPTH  5   /* 4 + one index to avoid */

  int P=0;
  /* initialize parameter vector to pass to evaluate function */
  SEXP par;
  PROTECT(par = NEW_NUMERIC(i_D)); P++;
  double *d_par = REAL(par);

  /* Data structures for parameter vectors */
  SEXP sexp_gta_popP, sexp_gta_oldP, sexp_gta_newP, sexp_map_pop;
  PROTECT(sexp_gta_popP = allocMatrix(REALSXP, i_NP, i_D)); P++; /* FIXME THIS HAD 2x the rows!!! */
  PROTECT(sexp_gta_oldP = allocMatrix(REALSXP, i_NP, i_D)); P++;
  PROTECT(sexp_gta_newP = allocMatrix(REALSXP, i_NP, i_D)); P++;
  double *ngta_popP = REAL(sexp_gta_popP); /* FIXME THIS HAD 2x the rows!!! */
  double *ngta_oldP = REAL(sexp_gta_oldP);
  double *ngta_newP = REAL(sexp_gta_newP);

  /* Data structures for objective function values associated with
   * parameter vectors */
  SEXP sexp_gta_popC, sexp_gta_oldC, sexp_gta_newC;
  PROTECT(sexp_gta_popC = allocVector(REALSXP, i_NP)); P++;
  PROTECT(sexp_gta_oldC = allocVector(REALSXP, i_NP)); P++;
  PROTECT(sexp_gta_newC = allocVector(REALSXP, i_NP)); P++;
  double *ngta_popC = REAL(sexp_gta_popC);
  double *ngta_oldC = REAL(sexp_gta_oldC);
  double *ngta_newC = REAL(sexp_gta_newC);

  double *gta_popC = (double *)R_alloc(i_NP*2,sizeof(double));
  double *gta_oldC = (double *)R_alloc(i_NP,sizeof(double));
  double *gta_newC = (double *)R_alloc(i_NP,sizeof(double));

  double *t_bestitP = (double *)R_alloc(1,sizeof(double) * i_D);
  double *t_tmpP = (double *)R_alloc(1,sizeof(double) * i_D);
  double *tempP = (double *)R_alloc(1,sizeof(double) * i_D);

  SEXP sexp_t_tmpP, sexp_t_tmpC;
  PROTECT(sexp_t_tmpP = allocMatrix(REALSXP, i_NP, i_D)); P++;
  PROTECT(sexp_t_tmpC = allocVector(REALSXP, i_NP)); P++;
  double *nt_tmpP = REAL(sexp_t_tmpP);
  double *nt_tmpC = REAL(sexp_t_tmpC);

  int i, j, k;  /* counting variables */
  int i_r1, i_r2, i_r3;  /* placeholders for random indexes */

  int ia_urn2[URN_DEPTH];
  int ia_urnTemp[i_NP];
  int i_nstorepop, i_xav;
  i_nstorepop = ceil((i_itermax - i_storepopfrom) / i_storepopfreq);

  int popcnt, bestacnt, same; /* lazy cnters */

  double d_jitter, d_dither;

  double t_tmpC, tmp_best, t_bestC;

  double **initialpop = (double **)R_alloc(i_NP,sizeof(double *));
  for (int i = 0; i < i_NP; i++)
    initialpop[i] = (double *)R_alloc(i_D,sizeof(double));

  /* vars for DE/current-to-p-best/1 */
  int i_pbest;
  int p_NP = round(d_pPct * i_NP);  /* choose at least two best solutions */
      p_NP = p_NP < 2 ? 2 : p_NP;
  int sortIndex[i_NP];              /* sorted values of gta_oldC */
  for(i = 0; i < i_NP; i++) sortIndex[i] = i;
  //double goodCR = 0, goodF = 0, goodF2 = 0, meanCR = 0.5, meanF = 0.5;
  double goodCR = 0, goodF = 0, goodF2 = 0, meanCR = d_cross, meanF = d_weight;
  int i_goodNP = 0;

  /* vars for when i_bs_flag == 1 */
//  int i_len, done, step, bound;
//  double tempC;

  GetRNGstate();

  /* if initial population provided, initialize with values */
  if (i_specinitialpop > 0) {
    k = 0;

    for (j = 0; j < i_D; j++) {
      for (i = 0; i < i_NP; i++) {
        initialpop[i][j] = initialpopv[k];
        k += 1;
      }
    }
  }

  /*------Initialization-----------------------------*/
  for (j = 0; j < i_D; j++) {
    for (i = 0; i < i_NP; i++) {
      if (i_specinitialpop <= 0) { /* random initial member */
        ngta_popP[i+i_NP*j] = d_lower[j] +
        unif_rand() * (d_upper[j] - d_lower[j]);

      }
      else /* or user-specified initial member */
        ngta_popP[i+i_NP*j] = initialpop[i][j];
    }
  }
  PROTECT(sexp_map_pop  = popEvaluate(l_nfeval, sexp_gta_popP, fnMap, rho, 0));
  memmove(REAL(sexp_gta_popP), REAL(sexp_map_pop), i_NP * i_D * sizeof(double)); // valgrind reports memory overlap here
  UNPROTECT(1);  // sexp_map_pop
  PROTECT(sexp_gta_popC = popEvaluate(l_nfeval, sexp_gta_popP,  fcall, rho, 1));
  ngta_popC = REAL(sexp_gta_popC);
  for (i = 0; i < i_NP; i++) {
    if (i == 0 || ngta_popC[i] <= t_bestC) {
      t_bestC = ngta_popC[i];
      for (j = 0; j < i_D; j++)
        gt_bestP[j]=ngta_popP[i+i_NP*j];
    }
  }

  /*---assign pointers to current ("old") population---*/
  memcpy(REAL(sexp_gta_oldP), REAL(sexp_gta_popP), i_NP * i_D * sizeof(double));
  memcpy(REAL(sexp_gta_oldC), REAL(sexp_gta_popC), i_NP * sizeof(double));
  UNPROTECT(1);  // sexp_gta_popC

  /*------Iteration loop--------------------------------------------*/
  int i_iter = 0;
  popcnt = 0;
  bestacnt = 0;
  i_xav = 1;
  int i_iter_tol = 0;

  while ((i_iter < i_itermax) && (t_bestC > VTR) && (i_iter_tol <= i_steptol))
  {
    /* store intermediate populations */
    if (i_iter % i_storepopfreq == 0 && i_iter >= i_storepopfrom) {
      for (i = 0; i < i_NP; i++) {
        for (j = 0; j < i_D; j++) {
          gd_storepop[popcnt] = ngta_oldP[i+i_NP*j];
          popcnt++;
        }
      }
    } /* end store pop */

    /* store the best member */
    for(j = 0; j < i_D; j++) {
      gd_bestmemit[bestacnt] = gt_bestP[j];
      bestacnt++;
    }
    /* store the best value */
    gd_bestvalit[i_iter] = t_bestC;

    for (j = 0; j < i_D; j++)
      t_bestitP[j] = gt_bestP[j];

    i_iter++;

    /*----compute dithering factor -----------------*/
    if (i_strategy == 5)
      d_dither = d_weight + unif_rand() * (1.0 - d_weight);

    /*---DE/current-to-p-best/1 ----------------------------------------------*/
    if (i_strategy == 6) {
      /* create a copy of gta_oldC to avoid changing it */
      double temp_oldC[i_NP];
      for(j = 0; j < i_NP; j++) temp_oldC[j] = ngta_oldC[j];

      /* sort temp_oldC to use sortIndex later */
      rsort_with_index( (double*)temp_oldC, (int*)sortIndex, i_NP );
    }

    /*----start of loop through ensemble------------------------*/
    for (i = 0; i < i_NP; i++) {

      /*t_tmpP is the vector to mutate and eventually select*/
      for (j = 0; j < i_D; j++)
        nt_tmpP[i+i_NP*j] = ngta_oldP[i+i_NP*j];
      nt_tmpC[i] = ngta_oldC[i];

      permute(ia_urn2, URN_DEPTH, i_NP, i, ia_urnTemp); /* Pick 4 random and distinct */

      i_r1 = ia_urn2[1];  /* population members */
      i_r2 = ia_urn2[2];
      i_r3 = ia_urn2[3];

      if (d_c > 0) {
        d_cross = rnorm(meanCR, 0.1);
        d_cross = d_cross > 1.0 ? 1 : d_cross;
        d_cross = d_cross < 0.0 ? 0 : d_cross;
        do {
          d_weight = rcauchy(meanF, 0.1);
          d_weight = d_weight > 1 ? 1.0 : d_weight;
        }while(d_weight <= 0.0);
      }

      /*===Choice of strategy===============================================*/
      j = (int)(unif_rand() * i_D); /* random parameter */
      k = 0;
      do {
        switch (i_strategy) {
          case 1: { /*---classical strategy DE/rand/1/bin-------------------*/
            nt_tmpP[i+i_NP*j] = ngta_oldP[i_r1+i_NP*j] +
              d_weight * (ngta_oldP[i_r2+i_NP*j] - ngta_oldP[i_r3+i_NP*j]);
            break;
          }
          case 2: { /*---DE/local-to-best/1/bin-----------------------------*/
            nt_tmpP[i+i_NP*j] = nt_tmpP[i+i_NP*j] +
              d_weight * (t_bestitP[j] - nt_tmpP[i+i_NP*j]) +
              d_weight * (ngta_oldP[i_r2+i_NP*j] - ngta_oldP[i_r3+i_NP*j]);
            break;
          }
          case 3: { /*---DE/best/1/bin with jitter--------------------------*/
            d_jitter = 0.0001 * unif_rand() + d_weight;
            nt_tmpP[i+i_NP*j] = t_bestitP[j] +
              d_jitter * (ngta_oldP[i_r1+i_NP*j] - ngta_oldP[i_r2+i_NP*j]);
            break;
          }
          case 4: { /*---DE/rand/1/bin with per-vector-dither---------------*/
            nt_tmpP[i+i_NP*j] = ngta_oldP[i_r1+i_NP*j] +
              (d_weight + unif_rand()*(1.0 - d_weight))*
              (ngta_oldP[i_r2+i_NP*j]-ngta_oldP[i_r3+i_NP*j]);
            break;
          }
          case 5: { /*---DE/rand/1/bin with per-generation-dither-----------*/
            nt_tmpP[i+i_NP*j] = ngta_oldP[i_r1+i_NP*j] +
              d_dither * (ngta_oldP[i_r2+i_NP*j] - ngta_oldP[i_r3+i_NP*j]);
            break;
          }
          case 6: { /*---DE/current-to-p-best/1 (JADE)----------------------*/
            /* select from [0, 1, 2, ..., (pNP-1)] */
            i_pbest = sortIndex[(int)(unif_rand() * p_NP)];
            nt_tmpP[i+i_NP*j] = ngta_oldP[i+i_NP*j] +
              d_weight * (ngta_oldP[i_pbest+i_NP*j] - ngta_oldP[i+i_NP*j]) +
              d_weight * (ngta_oldP[i_r1+i_NP*j]    - ngta_oldP[i_r2+i_NP*j]);
            break;
          }
          default: { /*---variation to DE/rand/1/bin: either-or-algorithm---*/
            if (unif_rand() < 0.5) { /* differential mutation, Pmu = 0.5 */
              nt_tmpP[i+i_NP*j] = ngta_oldP[i_r1+i_NP*j] + d_weight *
                (ngta_oldP[i_r2+i_NP*j] - ngta_oldP[i_r3+i_NP*j]);
            } else {
            /* recombination with K = 0.5*(F+1) -. F-K-Rule */
            nt_tmpP[i+i_NP*j] = ngta_oldP[i_r1+i_NP*j] +
              0.5 * (d_weight + 1.0) * (ngta_oldP[i_r2+i_NP*j]
              + ngta_oldP[i_r3+i_NP*j] - 2 * ngta_oldP[i_r1+i_NP*j]);
            }
          }
        } /* end switch */
        j = (j + 1) % i_D;
        k++;
      }while((unif_rand() < d_cross) && (k < i_D));
      /*===End choice of strategy===========================================*/

      /*----boundary constraints, bounce-back method was not enforcing bounds correctly*/
      for (j = 0; j < i_D; j++) {
        if (nt_tmpP[i+i_NP*j] < d_lower[j]) {
          nt_tmpP[i+i_NP*j] = d_lower[j] + unif_rand() * (d_upper[j] - d_lower[j]);
        }
        if (nt_tmpP[i+i_NP*j] > d_upper[j]) {
          nt_tmpP[i+i_NP*j] = d_upper[j] - unif_rand() * (d_upper[j] - d_lower[j]);
        }
      }

    } /* NEW End mutation loop through ensemble */

    /*------Trial mutation now in t_tmpP-----------------*/
    /* evaluate mutated population */
    PROTECT(sexp_map_pop = popEvaluate(l_nfeval, sexp_t_tmpP,  fnMap, rho, 0));
    memmove(REAL(sexp_t_tmpP), REAL(sexp_map_pop), i_NP * i_D * sizeof(double)); // valgrind reports memory overlap here
    UNPROTECT(1);  // sexp_map_pop
    PROTECT(sexp_t_tmpC  = popEvaluate(l_nfeval, sexp_t_tmpP, fcall, rho, 1));
    nt_tmpC = REAL(sexp_t_tmpC);

    /* compare old pop with mutated pop */
    for (i = 0; i < i_NP; i++) {

      /* note that i_bs_flag means that we will choose the
       *best NP vectors from the old and new population later*/
      if (nt_tmpC[i] <= ngta_oldC[i] || i_bs_flag) {
        /* replace target with mutant */
        for (j = 0; j < i_D; j++)
          ngta_newP[i+i_NP*j]=nt_tmpP[i+i_NP*j];
        ngta_newC[i]=nt_tmpC[i];
        if (nt_tmpC[i] <= t_bestC) {
          for (j = 0; j < i_D; j++)
            gt_bestP[j]=nt_tmpP[i+i_NP*j];
          t_bestC=nt_tmpC[i];
        }
        if (d_c > 0) { /* calculate new goodCR and goodF */
          goodCR += d_cross / ++i_goodNP;
          goodF += d_weight;
          goodF2 += pow(d_weight,2.0);
        }
      }
      else {
        for (j = 0; j < i_D; j++)
          ngta_newP[i+i_NP*j]=ngta_oldP[i+i_NP*j];
        ngta_newC[i]=ngta_oldC[i];

      }
    } /* End mutation loop through ensemble */
    UNPROTECT(1);  // sexp_t_tmpC

    if (d_c > 0) { /* calculate new meanCR and meanF */
      meanCR = (1-d_c)*meanCR + d_c*goodCR;
      meanF = (1-d_c)*meanF + d_c*goodF2/goodF;
    }

    if(i_bs_flag) {  /* FIXME */
      error("bs = TRUE not currently supported");
//      /* examine old and new pop. and take the best NP members
//       * into next generation */
//      for (i = 0; i < i_NP; i++) {
//        for (j = 0; j < i_D; j++)
//          gta_popP[i][j] = gta_oldP[i][j];
//        gta_popC[i] = gta_oldC[i];
//      }
//      for (i = 0; i < i_NP; i++) {
//        for (j = 0; j < i_D; j++)
//          gta_popP[i_NP+i][j] = gta_newP[i][j];
//        gta_popC[i_NP+i] = gta_newC[i];
//      }
//      i_len = 2 * i_NP;
//      step = i_len;  /* array length */
//      while (step > 1) {
//        step /= 2;   /* halve the step size */
//        do {
//          done = 1;
//          bound  = i_len - step;
//          for (j = 0; j < bound; j++) {
//              i = j + step + 1;
//              if (gta_popC[j] > gta_popC[i-1]) {
//                  for (k = 0; k < i_D; k++)
//                    tempP[k] = gta_popP[i-1][k];
//                  tempC = gta_popC[i-1];
//                  for (k = 0; k < i_D; k++)
//                    gta_popP[i-1][k] = gta_popP[j][k];
//                  gta_popC[i-1] = gta_popC[j];
//                  for (k = 0; k < i_D; k++)
//                    gta_popP[j][k] = tempP[k];
//                  gta_popC[j] = tempC;
//                    done = 0;
//                    /* if a swap has been made we are not finished yet */
//              }  /* if */
//          }  /* for */
//        } while (!done);   /* while */
//      } /*while (step > 1) */
//      /* now the best NP are in first NP places in gta_pop, use them */
//      for (i = 0; i < i_NP; i++) {
//        for (j = 0; j < i_D; j++)
//          gta_newP[i][j] = gta_popP[i][j];
//        gta_newC[i] = gta_popC[i];
//      }
    } /*i_bs_flag*/

    /* have selected NP mutants move on to next generation */
    for (i = 0; i < i_NP; i++) {
      for (j = 0; j < i_D; j++)
        ngta_oldP[i+i_NP*j] = ngta_newP[i+i_NP*j];
      ngta_oldC[i] = ngta_newC[i];
    }
    for (j = 0; j < i_D; j++)
	t_bestitP[j] = gt_bestP[j];
      
    if( trace > 0 ) {
      if( (i_iter % trace) == 0 ) {
        Rprintf("Iteration: %d bestvalit: %f bestmemit:", i_iter, t_bestC);
        for (j = 0; j < i_D; j++)
          Rprintf("%12.6f", gt_bestP[j]);
        Rprintf("\n");
      }
    }

    /* check for user interrupt */
    /*if( i_iter % 10000 == 999 ) R_CheckUserInterrupt();*/

    /* check relative tolerance (as in src/main/optim.c) */
    /* kmm: not sure where the above is, but was not working as
       advertised in help file; changed 
     */ 
    if( fabs(t_bestC - gd_bestvalit[i_iter-1]) <
        (d_reltol * (fabs(gd_bestvalit[i_iter-1]) + d_reltol))) {
      i_iter_tol++;
    } else {
      i_iter_tol = 0;
    }

  } /* end iteration loop */

  /* last population */
  k = 0;
  for (i = 0; i < i_NP; i++) {
    for (j = 0; j < i_D; j++) {
      gd_pop[k] = ngta_oldP[i+i_NP*j];
      k++;
    }
  }

  *gi_iter = i_iter;
  *gt_bestC = t_bestC;

  PutRNGstate();
  UNPROTECT(P);

}
SEXP match_BOC2_preprocess(SEXP s_xp, SEXP s_offset, SEXP s_length,
		SEXP p_length,
		SEXP code1, SEXP code2, SEXP code3, SEXP code4,
		SEXP buf_xp)
{
	int subj_offset, subj_length, pat_length, c1, c2, c3, c4;
	const Rbyte *subj;
	SEXP buf, ans, ans_names, ans_elt;

	subj_offset = INTEGER(s_offset)[0];
	subj_length = INTEGER(s_length)[0];
	subj = RAW(R_ExternalPtrTag(s_xp)) + subj_offset;
	pat_length = INTEGER(p_length)[0];
	c1 = INTEGER(code1)[0];
	c2 = INTEGER(code2)[0];
	c3 = INTEGER(code3)[0];
	c4 = INTEGER(code4)[0];
	buf = R_ExternalPtrTag(buf_xp);

	PROTECT(ans = NEW_LIST(5));
	/* set the names */
	PROTECT(ans_names = NEW_CHARACTER(5));
	SET_STRING_ELT(ans_names, 0, mkChar("means"));
	SET_STRING_ELT(ans_names, 1, mkChar("table1"));
	SET_STRING_ELT(ans_names, 2, mkChar("table2"));
	SET_STRING_ELT(ans_names, 3, mkChar("table3"));
	SET_STRING_ELT(ans_names, 4, mkChar("table4"));
	SET_NAMES(ans, ans_names);
	UNPROTECT(1);
	/* set the "means" element */
	PROTECT(ans_elt = NEW_NUMERIC(4));
	SET_ELEMENT(ans, 0, ans_elt);
	UNPROTECT(1);
	/* set the "table1" element */
	PROTECT(ans_elt = NEW_INTEGER(pat_length + 1));
	SET_ELEMENT(ans, 1, ans_elt);
	UNPROTECT(1);
	/* set the "table2" element */
	PROTECT(ans_elt = NEW_INTEGER(pat_length + 1));
	SET_ELEMENT(ans, 2, ans_elt);
	UNPROTECT(1);
	/* set the "table3" element */
	PROTECT(ans_elt = NEW_INTEGER(pat_length + 1));
	SET_ELEMENT(ans, 3, ans_elt);
	UNPROTECT(1);
	/* set the "table4" element */
	PROTECT(ans_elt = NEW_INTEGER(pat_length + 1));
	SET_ELEMENT(ans, 4, ans_elt);
	UNPROTECT(1);

	BOC2_preprocess((char *) subj, subj_length, pat_length,
			(char) c1, (char) c2, (char) c3, (char) c4,
			INTEGER(buf),
			REAL(VECTOR_ELT(ans, 0)),
			INTEGER(VECTOR_ELT(ans, 1)),
			INTEGER(VECTOR_ELT(ans, 2)),
			INTEGER(VECTOR_ELT(ans, 3)),
			INTEGER(VECTOR_ELT(ans, 4)));

	UNPROTECT(1);
	return ans;
}
SEXP
m_log_lambda(SEXP X1, SEXP X1_Columns, SEXP X1_Rows, 
             SEXP X2, SEXP X2_Columns,
             SEXP realS, SEXP OPTSimplicit_noisevar,
             SEXP hp_prior, SEXP hp_posterior) {
  long datalen;
  int  dim1, dim2, ncentroids;
  double *Mu_mu, *S2_mu, *Mu_bar, *Mu_tilde, 
    *Alpha_ksi, *Beta_ksi, *Ksi_alpha, *Ksi_beta, *U_p, *prior_alpha,
    *post_gamma, *log_lambda;
  double *data1;
  double *data2;
  SEXP olog_lambda, oU_hat;
  SEXP* U_hat;

  double *Ns;
  double implicit_noisevar;
  
  /******************** input variables ********************/
  
  
  /************ CONVERTED input variables ******************/
  /* data */
  PROTECT(X1 = AS_NUMERIC(X1));  
  data1   = NUMERIC_POINTER(X1);
  dim1    = INTEGER_VALUE(X1_Columns);
  datalen = INTEGER_VALUE(X1_Rows);

  PROTECT(X2 = AS_NUMERIC(X2));  
  data2   = NUMERIC_POINTER(X2);
  dim2    = INTEGER_VALUE(X2_Columns);

  Ns = NUMERIC_POINTER(realS);
  implicit_noisevar = NUMERIC_VALUE(OPTSimplicit_noisevar);
  

  /* Converted Initial Values of Model Parameters */

  if(dim1) {
    Mu_mu       = NUMERIC_POINTER(getListElement(hp_prior,"Mu_mu"));
    S2_mu       = NUMERIC_POINTER(getListElement(hp_prior,"S2_mu"));
    Alpha_ksi   = NUMERIC_POINTER(getListElement(hp_prior,"Alpha_ksi"));
    Beta_ksi    = NUMERIC_POINTER(getListElement(hp_prior,"Beta_ksi"));
    Mu_bar      = NUMERIC_POINTER(getListElement(hp_posterior,"Mu_bar"));
    Mu_tilde    = NUMERIC_POINTER(getListElement(hp_posterior,"Mu_tilde"));
    Ksi_alpha   = NUMERIC_POINTER(getListElement(hp_posterior,"Ksi_alpha"));
    Ksi_beta    = NUMERIC_POINTER(getListElement(hp_posterior,"Ksi_beta"));
  }
  if(dim2) {
    U_p         = NUMERIC_POINTER(getListElement(hp_prior,"U_p"));
    oU_hat      = getListElement(hp_posterior,"Uhat");
    U_hat      = &oU_hat;
  }
  

  prior_alpha = NUMERIC_POINTER(getListElement(hp_prior,"alpha"));
  post_gamma  = NUMERIC_POINTER(getListElement(hp_posterior,"gamma"));

  ncentroids = INTEGER_POINTER( GET_DIM(getListElement(hp_posterior,"Mu_bar")) )[0];

  /*printf("\nMu_mu ");  
  for(i=0; i< dim1;i++)
    printf("%f ", Mu_mu[i]);
  printf("\nS2_mu ");
  for(i=0; i< dim1;i++)
    printf("%f ", S2_mu[i]);
  printf("\nAlpha_ksi ");
  for(i=0; i< dim1;i++)
    printf("%f ", Alpha_ksi[i]);
  printf("\nBeta_ksi ");
  for(i=0; i< dim1;i++)
    printf("%f ", Beta_ksi[i]);
  
  printf("\nMu_bar ");
  for(i=0;i<ncentroids*dim1;i++)
    printf("%f ", Mu_bar[i]);
  printf("\nMu_tilde ");
  for(i=0;i<ncentroids*dim1;i++)
    printf("%f ", Mu_tilde[i]);
  printf("\nKsi_alpha ");
  for(i=0;i<ncentroids*dim1;i++)
    printf("%f ", Ksi_alpha[i]);
  printf("\nKsi_beta ");
  for(i=0;i<ncentroids*dim1;i++)
    printf("%f ", Ksi_beta[i]);
  printf("\nprior_alpha = %f", *prior_alpha);
  printf("\npost_gamma ");
  for(i=0;i<2*ncentroids;i++)
    printf("%f ", post_gamma[i]);
  printf("ncentroids = %d\n", ncentroids);
  printf("dim2 = %d\n",dim2);*/
  /******************** output variables ********************/
  PROTECT(olog_lambda     = NEW_NUMERIC(datalen*ncentroids));
  log_lambda = NUMERIC_POINTER(olog_lambda);


  vdp_mk_log_lambda(Mu_mu, S2_mu, Mu_bar, Mu_tilde, 
		    Alpha_ksi, Beta_ksi, Ksi_alpha, Ksi_beta, 
		    post_gamma, log_lambda, prior_alpha,
		    U_p, U_hat,
		    datalen, dim1, dim2, data1, data2, 
		    Ns, ncentroids, implicit_noisevar);

  UNPROTECT(3);

  return olog_lambda;
}
Esempio n. 10
0
File: partrans.c Progetto: cran/pomp
SEXP do_partrans (SEXP object, SEXP params, SEXP dir, SEXP gnsi)
{
  int nprotect = 0;
  SEXP fn, fcall, rho, ans, nm;
  SEXP pdim, pvec;
  SEXP pompfun;
  SEXP tparams = R_NilValue;
  pompfunmode mode = undef;
  char direc;
  int qmat;
  int ndim[2], *dim, *idx;
  double *pp, *ps, *pt, *pa;
  int npar1, npar2, nreps;
  pomp_transform_fn *ff = NULL;
  int k;

  direc = *(INTEGER(dir));
  // extract the user-defined function
  switch (direc) {
  case 1:			// forward transformation
    PROTECT(pompfun = GET_SLOT(object,install("from.trans"))); nprotect++;
    PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
    break;
  case -1:			// inverse transformation
    PROTECT(pompfun = GET_SLOT(object,install("to.trans"))); nprotect++;
    PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
    break;
  default:
    errorcall(R_NilValue,"impossible error"); // # nocov
    break;
  }

  // extract 'userdata' as pairlist
  PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;

  PROTECT(pdim = GET_DIM(params)); nprotect++;
  if (isNull(pdim)) {		// a single vector
    npar1 = LENGTH(params); nreps = 1;
    qmat = 0;
  } else {			// a parameter matrix
    dim = INTEGER(pdim);
    npar1 = dim[0]; nreps = dim[1];
    qmat = 1;
  }

  switch (mode) {

  case Rfun: 			// use user-supplied R function

    // set up the function call
    if (qmat) {		// matrix case
      PROTECT(pvec = NEW_NUMERIC(npar1)); nprotect++;
      SET_NAMES(pvec,GET_ROWNAMES(GET_DIMNAMES(params)));
      PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
    } else {			// vector case
      PROTECT(fcall = LCONS(params,fcall)); nprotect++;
    }
    SET_TAG(fcall,install("params"));
    PROTECT(fcall = LCONS(fn,fcall)); nprotect++;

    // the function's environment
    PROTECT(rho = (CLOENV(fn))); nprotect++;

    if (qmat) {		// matrix case
      const char *dimnm[2] = {"variable","rep"};
      ps = REAL(params);
      pp = REAL(pvec);

      memcpy(pp,ps,npar1*sizeof(double));

      PROTECT(ans = eval(fcall,rho)); nprotect++;

      PROTECT(nm = GET_NAMES(ans)); nprotect++;
      if (isNull(nm))
	errorcall(R_NilValue,"in 'partrans': user transformation functions must return a named numeric vector");

      // set up matrix to hold the results
      npar2 = LENGTH(ans);
      ndim[0] = npar2; ndim[1] = nreps;
      PROTECT(tparams = makearray(2,ndim)); nprotect++;
      setrownames(tparams,nm,2);
      fixdimnames(tparams,dimnm,2);
      pt = REAL(tparams);

      pa = REAL(AS_NUMERIC(ans));
      memcpy(pt,pa,npar2*sizeof(double));

      ps += npar1;
      pt += npar2;
      for (k = 1; k < nreps; k++, ps += npar1, pt += npar2) {
	memcpy(pp,ps,npar1*sizeof(double));
	pa = REAL(AS_NUMERIC(eval(fcall,rho)));
	memcpy(pt,pa,npar2*sizeof(double));
      }

    } else {			// vector case

      PROTECT(tparams = eval(fcall,rho)); nprotect++;
      if (isNull(GET_NAMES(tparams)))
	errorcall(R_NilValue,"in 'partrans': user transformation functions must return a named numeric vector");

    }

    break;

  case native:			// use native routine

    *((void **) (&ff)) = R_ExternalPtrAddr(fn);

    if (qmat) {
      idx = INTEGER(PROTECT(name_index(GET_ROWNAMES(GET_DIMNAMES(params)),pompfun,"paramnames","parameters"))); nprotect++;
    } else {
      idx = INTEGER(PROTECT(name_index(PROTECT(GET_NAMES(params)),pompfun,"paramnames","parameters"))); nprotect+=2;
    }

    set_pomp_userdata(fcall);

    PROTECT(tparams = duplicate(params)); nprotect++;

    for (k = 0, ps = REAL(params), pt = REAL(tparams); k < nreps; k++, ps += npar1, pt += npar1) {
      R_CheckUserInterrupt();
      (*ff)(pt,ps,idx);
    }

    unset_pomp_userdata();

    break;

  default:

    errorcall(R_NilValue,"in 'partrans': unrecognized 'mode'"); // # nocov

    break;

  }

  UNPROTECT(nprotect);
  return tparams;
}