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; }
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); }
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; }
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
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); }
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, >_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; }
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; }
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; }