void exec() throw( general_error ) { double I = as_double("I"); double T = as_double("T"); util::matrix_t<double> data = as_matrix("input"); util::matrix_t<double> par = as_matrix("param"); if ( data.ncols() != DATACOLS ) throw general_error( util::format("input matrix must have 6 columns (Irr, Tc, Pmp, Vmp, Voc, Isc), but is %d x %d", (int)data.nrows(), (int)data.ncols() ) ); if ( par.ncols() != PARCOLS ) throw general_error( util::format("parameter matrix must have 5 columns (Il, Io, Rs, Rsh, a), but is %d x %d", (int)par.nrows(), (int)par.ncols() ) ); if ( par.nrows() != data.nrows() || data.nrows() < 3 ) throw general_error( "input and parameter matrices must have same number of rows, and at least 3" ); bool quiet = false; if ( is_assigned( "quiet" ) ) quiet = true; assign( "a", var_data((ssc_number_t) interpolate( data, par, I, T, A, quiet ) ) ); assign("Il", var_data((ssc_number_t)interpolate(data, par, I, T, IL, quiet))); assign("Io", var_data((ssc_number_t)interpolate(data, par, I, T, IO, quiet))); assign("Rs", var_data((ssc_number_t)interpolate(data, par, I, T, RS, quiet))); assign("Rsh", var_data((ssc_number_t)interpolate(data, par, I, T, RSH, quiet))); }
void exec( ) throw( general_error ) { iec61853_module_t solver; msg_handler msgs( *this ); solver._imsg = &msgs; util::matrix_t<double> input = as_matrix("input"), par; if ( input.ncols() != iec61853_module_t::COL_MAX ) throw exec_error( "iec61853", "six data columns required for input matrix: IRR,TC,PMP,VMP,VOC,ISC"); if (!solver.calculate( input, as_integer("nser"), as_integer("type"), par, as_boolean("verbose") )) throw exec_error( "iec61853", "failed to solve for parameters"); assign("n", var_data((ssc_number_t)solver.n)); assign("alphaIsc", var_data((ssc_number_t)solver.alphaIsc)); assign("betaVoc", var_data((ssc_number_t)solver.betaVoc)); assign( "gammaPmp", var_data((ssc_number_t)solver.gammaPmp) ); assign( "Il", var_data((ssc_number_t)solver.Il) ); assign( "Io", var_data((ssc_number_t)solver.Io) ); assign( "C1", var_data((ssc_number_t)solver.C1) ); assign( "C2", var_data((ssc_number_t)solver.C2) ); assign( "C3", var_data((ssc_number_t)solver.C3) ); assign( "D1", var_data((ssc_number_t)solver.D1) ); assign( "D2", var_data((ssc_number_t)solver.D2) ); assign( "D3", var_data((ssc_number_t)solver.D3) ); assign( "Egref", var_data((ssc_number_t)solver.Egref) ); ssc_number_t *output = allocate( "output", par.nrows(), par.ncols() ); size_t c = 0; for( size_t i=0;i<par.nrows();i++ ) for( size_t j=0;j<par.ncols();j++ ) output[c++] = (ssc_number_t)par(i, j); }
void base::freeself_kind(kind k) { switch (k) { case BASE: freeself_base(); break; case INTEGER: as_integer().freeself_integer(); break; case VECTOR: as_vector().freeself_vector(); break; case NUMBER_PARTITION: as_number_partition().freeself_number_partition(); break; case PERMUTATION: as_permutation().freeself_permutation(); break; case MATRIX: as_matrix().freeself_matrix(); break; case LONGINTEGER: as_longinteger().freeself_longinteger(); break; case MEMORY: as_memory().freeself_memory(); break; //case PERM_GROUP: as_perm_group().freeself_perm_group(); break; //case PERM_GROUP_STAB_CHAIN: as_perm_group_stab_chain().freeself_perm_group_stab_chain(); break; case UNIPOLY: as_unipoly().freeself_unipoly(); break; case SOLID: as_solid().freeself_solid(); break; case BITMATRIX: as_bitmatrix().freeself_bitmatrix(); break; //case PC_PRESENTATION: as_pc_presentation().freeself_pc_presentation(); break; //case PC_SUBGROUP: as_pc_subgroup().freeself_pc_subgroup(); break; //case GROUP_WORD: as_group_word().freeself_group_word(); break; //case GROUP_TABLE: as_group_table().freeself_group_table(); break; // case ACTION: as_action().freeself_action(); break; case GEOMETRY: as_geometry().freeself_geometry(); break; case HOLLERITH: as_hollerith().freeself_hollerith(); break; case GROUP_SELECTION: as_group_selection().freeself_group_selection(); break; case BT_KEY: as_bt_key().freeself_bt_key(); break; case DATABASE: as_database().freeself_database(); break; case BTREE: as_btree().freeself_btree(); break; case DESIGN_PARAMETER_SOURCE: as_design_parameter_source().freeself_design_parameter_source(); break; case DESIGN_PARAMETER: as_design_parameter().freeself_design_parameter(); break; default: cout << "base::freeself_kind(), unknown kind: k= " << kind_ascii(k) << "\n"; } }
void tcKernel::set_unit_value_ssc_matrix(int id, const char *tcs_name, const char *ssc_name) { size_t nr, nc; ssc_number_t *p = as_matrix(ssc_name, &nr, &nc); double *pt = new double[nr*nc]; for (size_t i = 0; i<nr*nc; i++) pt[i] = (double)p[i]; set_unit_value(id, tcs_name, pt, (int)nr, (int)nc); delete[] pt; return; }
void tcKernel::set_unit_value_ssc_matrix_transpose(int id, const char *tcs_name, const char *ssc_name) { size_t nr, nc; ssc_number_t *p = as_matrix(ssc_name, &nr, &nc); double *pt = new double[nr*nc]; size_t i = 0; for (size_t c = 0; c< nc; c++) for (size_t r = 0; r < nr; r++) pt[i++] = (double)p[r*nc + c]; set_unit_value(id, tcs_name, pt, (int)nc, (int)nr); delete[] pt; return; }
// @export // [[Rcpp::export]] Rcpp::NumericMatrix DistMatrixWithoutUnitDF(Rcpp::DataFrame distsDF, Rcpp::Function DistFunc, bool testNA){ // http://stackoverflow.com/questions/27391472/passing-r-function-as-parameter-to-rcpp-function Rcpp::NumericMatrix dists = as_matrix(distsDF); int nrow = dists.nrow(); double dist_value = 0.0; Rcpp::NumericMatrix dist_matrix(nrow,nrow); // http://stackoverflow.com/questions/23748572/initializing-a-matrix-to-na-in-rcpp std::fill( dist_matrix.begin(), dist_matrix.end(), Rcpp::NumericVector::get_na() ); for (int i = 0; i < nrow; i++){ for (int j = 0; j < nrow; j++){ if(Rcpp::NumericVector::is_na(dist_matrix(i,j))){ dist_value = Rcpp::as<double>(DistFunc(dists(i,Rcpp::_),dists(j,Rcpp::_), testNA)); dist_matrix(i,j) = dist_value; dist_matrix(j,i) = dist_value; } } } return dist_matrix; }
void exec( ) throw( general_error ) { size_t i, j, nrows, ncols; // rated output ac double Paco = as_double("inv_cec_cg_paco"); bool kW_units = (as_integer("inv_cec_cg_sample_power_units") == 1); // 6 columns period, tier, max usage, max usage units, buy, sell ssc_number_t *inv_cec_cg_test_samples_in = as_matrix("inv_cec_cg_test_samples", &nrows, &ncols); if (nrows != 18) { std::ostringstream ss; ss << "The samples table must have 18 rows. Number of rows in samples table provided is " << nrows << " rows."; throw exec_error("inv_cec_cg", ss.str()); } if ((ncols % 3) != 0) { std::ostringstream ss; ss << "The samples table must have number of columns divisible by 3. Number of columns in samples table provided is " << ncols << " columns."; throw exec_error("inv_cec_cg", ss.str()); } size_t num_samples = ncols / 3; size_t columns_per_sample = 3; util::matrix_t<float> inv_cec_cg_test_samples(nrows, ncols); inv_cec_cg_test_samples.assign(inv_cec_cg_test_samples_in, nrows, ncols); ssc_number_t vdc = 0, Pout = 0, eff = 0, Pin=0, Pin2=0; // set Pout, Pin=Pout/eff and Pin^2 for least squares fit // 6 is for the required power output percentages at each voltage for each sample util::matrix_t<ssc_number_t> &inv_cec_cg_Vmin = allocate_matrix("inv_cec_cg_Vmin", 6 * num_samples, 3); util::matrix_t<ssc_number_t> &inv_cec_cg_Vnom = allocate_matrix("inv_cec_cg_Vnom", 6 * num_samples, 3); util::matrix_t<ssc_number_t> &inv_cec_cg_Vmax = allocate_matrix("inv_cec_cg_Vmax", 6 * num_samples, 3); ssc_number_t *inv_cec_cg_Vdc = allocate("inv_cec_cg_Vdc", 3); ssc_number_t *inv_cec_cg_Vdc_Vnom = allocate("inv_cec_cg_Vdc_Vnom", 3); ssc_number_t *inv_cec_cg_Pdco = allocate("inv_cec_cg_Pdco", 3); ssc_number_t *inv_cec_cg_Psco = allocate("inv_cec_cg_Psco", 3); ssc_number_t *inv_cec_cg_C0 = allocate("inv_cec_cg_C0", 3); ssc_number_t *inv_cec_cg_C1 = allocate("inv_cec_cg_C1", 2); ssc_number_t *inv_cec_cg_C2 = allocate("inv_cec_cg_C2", 2); ssc_number_t *inv_cec_cg_C3 = allocate("inv_cec_cg_C3", 2); for (i = 0; i < 3; i++) inv_cec_cg_Vdc[i] = 0; for (j = 0; j < num_samples; j++) { for (i = 0; i < inv_cec_cg_test_samples.nrows(); i++) { vdc = inv_cec_cg_test_samples.at(i, j*columns_per_sample + 1); Pout = inv_cec_cg_test_samples.at(i, j*columns_per_sample); if (kW_units) Pout *= 1000; // kW to W eff = inv_cec_cg_test_samples.at(i, j*columns_per_sample+2); Pin = Pout; if (eff != 0.0f) Pin = (ssc_number_t)(100.0*Pout) / eff; Pin2 = Pin*Pin; if (i < 6) // Vmin 0 offset { inv_cec_cg_Vdc[0] += vdc; inv_cec_cg_Vmin.at(j * 6 + i, 0) = Pout; inv_cec_cg_Vmin.at(j * 6 + i, 1) = Pin; inv_cec_cg_Vmin.at(j * 6 + i, 2) = Pin2; } else if (i < 12) // Vnom 6 offset { inv_cec_cg_Vdc[1] += vdc; inv_cec_cg_Vnom.at(j * 6 + i - 6, 0) = Pout; inv_cec_cg_Vnom.at(j * 6 + i-6, 1) = Pin; inv_cec_cg_Vnom.at(j * 6 + i-6, 2) = Pin2; } else // Vmax 12 offset { inv_cec_cg_Vdc[2] += vdc; inv_cec_cg_Vmax.at(j * 6 + i - 12, 0) = Pout; inv_cec_cg_Vmax.at(j * 6 + i - 12, 1) = Pin; inv_cec_cg_Vmax.at(j * 6 + i - 12, 2) = Pin2; } } } ssc_number_t *inv_cec_cg_Vmin_abc = allocate("inv_cec_cg_Vmin_abc", 3); ssc_number_t *inv_cec_cg_Vnom_abc = allocate("inv_cec_cg_Vnom_abc", 3); ssc_number_t *inv_cec_cg_Vmax_abc = allocate("inv_cec_cg_Vmax_abc", 3); std::vector<double> Pout_vec(inv_cec_cg_Vmin.nrows()); std::vector<double> Pin_vec(inv_cec_cg_Vmin.nrows()); int info; double C[3];// initial guesses for lsqfit size_t data_size = 3; // Vmin non-linear for (i = 0; i < inv_cec_cg_Vmin.nrows(); i++) { Pin_vec[i] = inv_cec_cg_Vmin.at(i, 1); Pout_vec[i] = inv_cec_cg_Vmin.at(i, 0); } C[0] = -1e-6; C[1] = 1; C[2] = 1e3; if (!(info=lsqfit(Quadratic_fit_eqn, 0, C, data_size, &Pin_vec[0], &Pout_vec[0], inv_cec_cg_Vmin.nrows()))) { throw exec_error("inv_cec_cg", util::format("error in nonlinear least squares fit, error %d", info)); return; } inv_cec_cg_Vmin_abc[0] = (ssc_number_t)C[0]; inv_cec_cg_Vmin_abc[1] = (ssc_number_t)C[1]; inv_cec_cg_Vmin_abc[2] = (ssc_number_t)C[2]; // Vnom non-linear for (i = 0; i < inv_cec_cg_Vnom.nrows(); i++) { Pin_vec[i] = inv_cec_cg_Vnom.at(i, 1); Pout_vec[i] = inv_cec_cg_Vnom.at(i, 0); } C[0] = -1e-6; C[1] = 1; C[2] = 1e3; if (!(info = lsqfit(Quadratic_fit_eqn, 0, C, data_size, &Pin_vec[0], &Pout_vec[0], inv_cec_cg_Vnom.nrows()))) { throw exec_error("inv_cec_cg", util::format("error in nonlinear least squares fit, error %d", info)); return; } inv_cec_cg_Vnom_abc[0] = (ssc_number_t)C[0]; inv_cec_cg_Vnom_abc[1] = (ssc_number_t)C[1]; inv_cec_cg_Vnom_abc[2] = (ssc_number_t)C[2]; // Vmax non-linear for (i = 0; i < inv_cec_cg_Vmax.nrows(); i++) { Pin_vec[i] = inv_cec_cg_Vmax.at(i, 1); Pout_vec[i] = inv_cec_cg_Vmax.at(i, 0); } C[0] = -1e-6; C[1] = 1; C[2] = 1e3; if (!(info = lsqfit(Quadratic_fit_eqn, 0, C, data_size, &Pin_vec[0], &Pout_vec[0], inv_cec_cg_Vmax.nrows()))) { throw exec_error("inv_cec_cg", util::format("error in nonlinear least squares fit, error %d", info)); return; } inv_cec_cg_Vmax_abc[0] = (ssc_number_t)C[0]; inv_cec_cg_Vmax_abc[1] = (ssc_number_t)C[1]; inv_cec_cg_Vmax_abc[2] = (ssc_number_t)C[2]; // Fill in intermediate values //Vdc (Vmin, Vnom, Vmax) for (i = 0; i < 3;i++) inv_cec_cg_Vdc[i] /= (6 * num_samples); // Vdc-Vnom for (i = 0; i < 3; i++) inv_cec_cg_Vdc_Vnom[i] = inv_cec_cg_Vdc[i] - inv_cec_cg_Vdc[1]; ssc_number_t a, b, c; // Pdco and Psco and C0 a = inv_cec_cg_Vmin_abc[0]; b = inv_cec_cg_Vmin_abc[1]; c = inv_cec_cg_Vmin_abc[2]; inv_cec_cg_Pdco[0] = (ssc_number_t)(-b + sqrt(b*b - 4 * a*(c - Paco))); inv_cec_cg_Psco[0] = (-b + sqrt(b*b - 4 * a*c)); inv_cec_cg_C0[0] = a; if (a != 0) { inv_cec_cg_Pdco[0] /= (ssc_number_t)(2.0*a); inv_cec_cg_Psco[0] /= (ssc_number_t)(2.0*a); } a = inv_cec_cg_Vnom_abc[0]; b = inv_cec_cg_Vnom_abc[1]; c = inv_cec_cg_Vnom_abc[2]; inv_cec_cg_Pdco[1] = (ssc_number_t)(-b + sqrt(b*b - 4 * a*(c - Paco))); inv_cec_cg_Psco[1] = (-b + sqrt(b*b - 4 * a*c)); inv_cec_cg_C0[1] = a; if (a != 0) { inv_cec_cg_Pdco[1] /= (ssc_number_t)(2.0*a); inv_cec_cg_Psco[1] /= (ssc_number_t)(2.0*a); } // TODO - limit Psco max to not be less than zero per note in Workbook a = inv_cec_cg_Vmax_abc[0]; b = inv_cec_cg_Vmax_abc[1]; c = inv_cec_cg_Vmax_abc[2]; inv_cec_cg_Pdco[2] = (ssc_number_t)(-b + sqrt(b*b - 4 * a*(c - Paco))); inv_cec_cg_Psco[2] = (-b + sqrt(b*b - 4 * a*c)); inv_cec_cg_C0[2] = a; if (a != 0) { inv_cec_cg_Pdco[2] /= (ssc_number_t)(2.0*a); inv_cec_cg_Psco[2] /= (ssc_number_t)(2.0*a); } // C1, C2, C3 linear least squares // C1 Y=Pdco, X=Vdc-Vnom std::vector<double> X(3); std::vector<double> Y(3); double slope, intercept; // C1 using linear least squares fit for (i = 0; i < 3; i++) { X[i] = inv_cec_cg_Vdc_Vnom[i]; Y[i] = inv_cec_cg_Pdco[i]; } if ((info = linlsqfit(&slope, &intercept, &X[0], &Y[0], data_size))) { throw exec_error("inv_cec_cg", util::format("error in linear least squares fit, error %d", info)); return; } inv_cec_cg_C1[0] = (ssc_number_t)slope; inv_cec_cg_C1[1] = (ssc_number_t)intercept; // C2 using linear least squares fit for (i = 0; i < 3; i++) { X[i] = inv_cec_cg_Vdc_Vnom[i]; Y[i] = inv_cec_cg_Psco[i]; } if ((info = linlsqfit(&slope, &intercept, &X[0], &Y[0], data_size))) { throw exec_error("inv_cec_cg", util::format("error in linear least squares fit, error %d", info)); return; } inv_cec_cg_C2[0] = (ssc_number_t)slope; inv_cec_cg_C2[1] = (ssc_number_t)intercept; // C2 using linear least squares fit for (i = 0; i < 3; i++) { X[i] = inv_cec_cg_Vdc_Vnom[i]; Y[i] = inv_cec_cg_C0[i]; } if ((info = linlsqfit(&slope, &intercept, &X[0], &Y[0], data_size))) { throw exec_error("inv_cec_cg", util::format("error in linear least squares fit, error %d", info)); return; } inv_cec_cg_C3[0] = (ssc_number_t)slope; inv_cec_cg_C3[1] = (ssc_number_t)intercept; // vdco is the average of Vnom of all samples column 2 and rows 7 through 12 assign("Pdco", (var_data)inv_cec_cg_C1[1]); assign("Vdco", (var_data)inv_cec_cg_Vdc[1]); assign("Pso", (var_data)inv_cec_cg_C2[1]); assign("c0", (var_data)inv_cec_cg_C3[1]); assign("c1", (var_data)(inv_cec_cg_C1[0] / inv_cec_cg_C1[1])); assign("c2", (var_data)(inv_cec_cg_C2[0] / inv_cec_cg_C2[1])); assign("c3", (var_data)(inv_cec_cg_C3[0] / inv_cec_cg_C3[1])); }
SEXP do_rmeasure (SEXP object, SEXP x, SEXP times, SEXP params, SEXP gnsi) { int nprotect = 0; pompfunmode mode = undef; int ntimes, nvars, npars, ncovars, nreps, nrepsx, nrepsp, nobs; SEXP Snames, Pnames, Cnames, Onames; SEXP cvec, tvec = R_NilValue, xvec = R_NilValue, pvec = R_NilValue; SEXP fn, fcall, rho = R_NilValue, ans, nm; SEXP pompfun; SEXP Y; int *dim; int *sidx = 0, *pidx = 0, *cidx = 0, *oidx = 0; struct lookup_table covariate_table; pomp_measure_model_simulator *ff = NULL; PROTECT(times = AS_NUMERIC(times)); nprotect++; ntimes = length(times); if (ntimes < 1) errorcall(R_NilValue,"in 'rmeasure': length('times') = 0, no work to do"); 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 'rmeasure': 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 'rmeasure': larger number of replicates is not a multiple of smaller"); dim = INTEGER(GET_DIM(GET_SLOT(object,install("data")))); nobs = dim[0]; 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++; PROTECT(Onames = GET_ROWNAMES(GET_DIMNAMES(GET_SLOT(object,install("data"))))); nprotect++; // 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); { int dim[3] = {nobs, nreps, ntimes}; const char *dimnm[3] = {"variable","rep","time"}; PROTECT(Y = makearray(3,dim)); nprotect++; setrownames(Y,Onames,3); fixdimnames(Y,dimnm,3); } // extract the user-defined function PROTECT(pompfun = GET_SLOT(object,install("rmeasure"))); 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: // use R function PROTECT(tvec = NEW_NUMERIC(1)); nprotect++; PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++; PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++; SET_NAMES(xvec,Snames); SET_NAMES(pvec,Pnames); // set up the function call PROTECT(fcall = LCONS(cvec,fcall)); nprotect++; SET_TAG(fcall,install("covars")); PROTECT(fcall = LCONS(pvec,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(tvec,fcall)); nprotect++; SET_TAG(fcall,install("t")); PROTECT(fcall = LCONS(xvec,fcall)); nprotect++; SET_TAG(fcall,install("x")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; // get the function's environment PROTECT(rho = (CLOENV(fn))); nprotect++; break; case native: // use native routine // 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 'rmeasure': unrecognized 'mode'"); // # nocov break; } // now do computations switch (mode) { case Rfun: // R function { int first = 1; int use_names = 0; double *yt = REAL(Y); double *time = REAL(times); double *tp = REAL(tvec); double *cp = REAL(cvec); double *xp = REAL(xvec); double *pp = REAL(pvec); double *xs = REAL(x); double *ps = REAL(params); double *ys; int *posn; int i, j, k; for (k = 0; k < ntimes; k++, time++) { // loop over times R_CheckUserInterrupt(); // check for user interrupt *tp = *time; // copy the time table_lookup(&covariate_table,*tp,cp); // interpolate the covariates for (j = 0; j < nreps; j++, yt += nobs) { // loop over replicates // copy the states and parameters into place for (i = 0; i < nvars; i++) xp[i] = xs[i+nvars*((j%nrepsx)+nrepsx*k)]; for (i = 0; i < npars; i++) pp[i] = ps[i+npars*(j%nrepsp)]; if (first) { // evaluate the call PROTECT(ans = eval(fcall,rho)); nprotect++; if (LENGTH(ans) != nobs) { errorcall(R_NilValue,"in 'rmeasure': user 'rmeasure' returns a vector of %d observables but %d are expected: compare 'data' slot?", LENGTH(ans),nobs); } // get name information to fix potential alignment problems PROTECT(nm = GET_NAMES(ans)); nprotect++; use_names = !isNull(nm); if (use_names) { // match names against names from data slot posn = INTEGER(PROTECT(matchnames(Onames,nm,"observables"))); nprotect++; } else { posn = 0; } ys = REAL(AS_NUMERIC(ans)); first = 0; } else { ys = REAL(AS_NUMERIC(eval(fcall,rho))); } if (use_names) { for (i = 0; i < nobs; i++) yt[posn[i]] = ys[i]; } else { for (i = 0; i < nobs; i++) yt[i] = ys[i]; } } } } break; case native: // native routine { double *yt = REAL(Y); double *time = REAL(times); double *xs = REAL(x); double *ps = REAL(params); double *cp = REAL(cvec); double *xp, *pp; int j, k; set_pomp_userdata(fcall); GetRNGstate(); for (k = 0; k < ntimes; k++, time++) { // 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++, yt += nobs) { // loop over replicates xp = &xs[nvars*((j%nrepsx)+nrepsx*k)]; pp = &ps[npars*(j%nrepsp)]; (*ff)(yt,xp,pp,oidx,sidx,pidx,cidx,ncovars,cp,*time); } } PutRNGstate(); unset_pomp_userdata(); } break; default: errorcall(R_NilValue,"in 'rmeasure': unrecognized 'mode'"); // # nocov break; } UNPROTECT(nprotect); return Y; }
SEXP do_dmeasure (SEXP object, SEXP y, SEXP x, SEXP times, SEXP params, SEXP log, SEXP gnsi) { int nprotect = 0; pompfunmode mode = undef; int give_log; int ntimes, nvars, npars, ncovars, nreps, nrepsx, nrepsp, nobs; SEXP Snames, Pnames, Cnames, Onames; SEXP pompfun; SEXP cvec, tvec = R_NilValue; SEXP xvec = R_NilValue, yvec = R_NilValue, pvec = R_NilValue; SEXP fn, ans, fcall, rho = R_NilValue; SEXP F; int *sidx = 0, *pidx = 0, *cidx = 0, *oidx = 0; int *dim; struct lookup_table covariate_table; pomp_measure_model_density *ff = NULL; PROTECT(times = AS_NUMERIC(times)); nprotect++; ntimes = length(times); if (ntimes < 1) errorcall(R_NilValue,"in 'dmeasure': length('times') = 0, no work to do"); PROTECT(y = as_matrix(y)); nprotect++; dim = INTEGER(GET_DIM(y)); nobs = dim[0]; if (ntimes != dim[1]) errorcall(R_NilValue,"in 'dmeasure': length of 'times' and 2nd dimension of 'y' do not agree"); PROTECT(x = as_state_array(x)); nprotect++; dim = INTEGER(GET_DIM(x)); nvars = dim[0]; nrepsx = dim[1]; if (ntimes != dim[2]) errorcall(R_NilValue,"in 'dmeasure': length of 'times' and 3rd dimension of 'x' do not agree"); PROTECT(params = as_matrix(params)); nprotect++; dim = INTEGER(GET_DIM(params)); npars = dim[0]; nrepsp = dim[1]; nreps = (nrepsp > nrepsx) ? nrepsp : nrepsx; if ((nreps % nrepsp != 0) || (nreps % nrepsx != 0)) errorcall(R_NilValue,"in 'dmeasure': larger number of replicates is not a multiple of smaller"); PROTECT(Onames = GET_ROWNAMES(GET_DIMNAMES(y))); nprotect++; PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++; give_log = *(INTEGER(AS_INTEGER(log))); // set up the covariate table covariate_table = make_covariate_table(object,&ncovars); // vector for interpolated covariates PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++; SET_NAMES(cvec,Cnames); // extract the user-defined function PROTECT(pompfun = GET_SLOT(object,install("dmeasure"))); nprotect++; PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++; // extract 'userdata' as pairlist PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++; // first do setup switch (mode) { case Rfun: // R function PROTECT(tvec = NEW_NUMERIC(1)); nprotect++; PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++; PROTECT(yvec = NEW_NUMERIC(nobs)); nprotect++; PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++; SET_NAMES(xvec,Snames); SET_NAMES(yvec,Onames); SET_NAMES(pvec,Pnames); // set up the function call PROTECT(fcall = LCONS(cvec,fcall)); nprotect++; SET_TAG(fcall,install("covars")); PROTECT(fcall = LCONS(AS_LOGICAL(log),fcall)); nprotect++; SET_TAG(fcall,install("log")); PROTECT(fcall = LCONS(pvec,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(tvec,fcall)); nprotect++; SET_TAG(fcall,install("t")); PROTECT(fcall = LCONS(xvec,fcall)); nprotect++; SET_TAG(fcall,install("x")); PROTECT(fcall = LCONS(yvec,fcall)); nprotect++; SET_TAG(fcall,install("y")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; // get the function's environment PROTECT(rho = (CLOENV(fn))); nprotect++; break; case native: // native code // construct state, parameter, covariate, observable indices oidx = INTEGER(PROTECT(name_index(Onames,pompfun,"obsnames","observables"))); nprotect++; sidx = INTEGER(PROTECT(name_index(Snames,pompfun,"statenames","state variables"))); nprotect++; pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames","parameters"))); nprotect++; cidx = INTEGER(PROTECT(name_index(Cnames,pompfun,"covarnames","covariates"))); nprotect++; // address of native routine *((void **) (&ff)) = R_ExternalPtrAddr(fn); break; default: errorcall(R_NilValue,"in 'dmeasure': unrecognized 'mode'"); // # nocov break; } // create array to store results { int dim[2] = {nreps, ntimes}; const char *dimnm[2] = {"rep","time"}; PROTECT(F = makearray(2,dim)); nprotect++; fixdimnames(F,dimnm,2); } // now do computations switch (mode) { case Rfun: // R function { int first = 1; double *ys = REAL(y); double *xs = REAL(x); double *ps = REAL(params); double *cp = REAL(cvec); double *tp = REAL(tvec); double *xp = REAL(xvec); double *yp = REAL(yvec); double *pp = REAL(pvec); double *ft = REAL(F); double *time = REAL(times); int j, k; for (k = 0; k < ntimes; k++, time++, ys += nobs) { // loop over times R_CheckUserInterrupt(); // check for user interrupt *tp = *time; // copy the time table_lookup(&covariate_table,*time,cp); // interpolate the covariates memcpy(yp,ys,nobs*sizeof(double)); for (j = 0; j < nreps; j++, ft++) { // loop over replicates // copy the states and parameters into place memcpy(xp,&xs[nvars*((j%nrepsx)+nrepsx*k)],nvars*sizeof(double)); memcpy(pp,&ps[npars*(j%nrepsp)],npars*sizeof(double)); if (first) { // evaluate the call PROTECT(ans = eval(fcall,rho)); nprotect++; if (LENGTH(ans) != 1) errorcall(R_NilValue,"in 'dmeasure': user 'dmeasure' returns a vector of length %d when it should return a scalar",LENGTH(ans)); *ft = *(REAL(AS_NUMERIC(ans))); first = 0; } else { *ft = *(REAL(AS_NUMERIC(eval(fcall,rho)))); } } } } break; case native: // native code set_pomp_userdata(fcall); { double *yp = REAL(y); double *xs = REAL(x); double *ps = REAL(params); double *cp = REAL(cvec); double *ft = REAL(F); double *time = REAL(times); double *xp, *pp; int j, k; for (k = 0; k < ntimes; k++, time++, yp += nobs) { // loop over times R_CheckUserInterrupt(); // check for user interrupt // interpolate the covar functions for the covariates table_lookup(&covariate_table,*time,cp); for (j = 0; j < nreps; j++, ft++) { // loop over replicates xp = &xs[nvars*((j%nrepsx)+nrepsx*k)]; pp = &ps[npars*(j%nrepsp)]; (*ff)(ft,yp,xp,pp,give_log,oidx,sidx,pidx,cidx,ncovars,cp,*time); } } } unset_pomp_userdata(); break; default: errorcall(R_NilValue,"in 'dmeasure': unrecognized 'mode'"); // # nocov break; } UNPROTECT(nprotect); return F; }
SEXP do_rprocess (SEXP object, SEXP xstart, SEXP times, SEXP params, SEXP offset, SEXP gnsi) { int nprotect = 0; int *xdim, nvars, npars, nreps, nrepsx, ntimes, off; SEXP X, Xoff, copy, fn, fcall, rho; SEXP dimXstart, dimP, dimX; PROTECT(gnsi = duplicate(gnsi)); nprotect++; ntimes = length(times); if (ntimes < 2) { error("rprocess error: length(times)==0: no transitions, no work to do"); } off = *(INTEGER(AS_INTEGER(offset))); if ((off < 0)||(off>=ntimes)) error("illegal 'offset' value %d",off); PROTECT(xstart = as_matrix(xstart)); nprotect++; PROTECT(dimXstart = GET_DIM(xstart)); nprotect++; xdim = INTEGER(dimXstart); nvars = xdim[0]; nrepsx = xdim[1]; PROTECT(params = as_matrix(params)); nprotect++; PROTECT(dimP = GET_DIM(params)); nprotect++; xdim = INTEGER(dimP); npars = xdim[0]; nreps = xdim[1]; if (nrepsx > nreps) { // more ICs than parameters if (nrepsx % nreps != 0) { error("rprocess error: larger number of replicates is not a multiple of smaller"); } else { double *src, *tgt; int dims[2]; int j, k; dims[0] = npars; dims[1] = nrepsx; PROTECT(copy = duplicate(params)); nprotect++; PROTECT(params = makearray(2,dims)); nprotect++; setrownames(params,GET_ROWNAMES(GET_DIMNAMES(copy)),2); src = REAL(copy); tgt = REAL(params); for (j = 0; j < nrepsx; j++) { for (k = 0; k < npars; k++, tgt++) { *tgt = src[k+npars*(j%nreps)]; } } } nreps = nrepsx; } else if (nrepsx < nreps) { // more parameters than ICs if (nreps % nrepsx != 0) { error("rprocess error: larger number of replicates is not a multiple of smaller"); } else { double *src, *tgt; int dims[2]; int j, k; dims[0] = nvars; dims[1] = nreps; PROTECT(copy = duplicate(xstart)); nprotect++; PROTECT(xstart = makearray(2,dims)); nprotect++; setrownames(xstart,GET_ROWNAMES(GET_DIMNAMES(copy)),2); src = REAL(copy); tgt = REAL(xstart); for (j = 0; j < nreps; j++) { for (k = 0; k < nvars; k++, tgt++) { *tgt = src[k+nvars*(j%nrepsx)]; } } } } // extract the process function PROTECT(fn = GET_SLOT(object,install("rprocess"))); nprotect++; // construct the call PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++; PROTECT(fcall = LCONS(gnsi,fcall)); nprotect++; SET_TAG(fcall,install(".getnativesymbolinfo")); PROTECT(fcall = LCONS(GET_SLOT(object,install("zeronames")),fcall)); nprotect++; SET_TAG(fcall,install("zeronames")); PROTECT(fcall = LCONS(GET_SLOT(object,install("covar")),fcall)); nprotect++; SET_TAG(fcall,install("covar")); PROTECT(fcall = LCONS(GET_SLOT(object,install("tcovar")),fcall)); nprotect++; SET_TAG(fcall,install("tcovar")); PROTECT(fcall = LCONS(params,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(AS_NUMERIC(times),fcall)); nprotect++; SET_TAG(fcall,install("times")); PROTECT(fcall = LCONS(xstart,fcall)); nprotect++; SET_TAG(fcall,install("xstart")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; PROTECT(rho = (CLOENV(fn))); nprotect++; // environment of the function PROTECT(X = eval(fcall,rho)); nprotect++; // do the call PROTECT(dimX = GET_DIM(X)); nprotect++; if ((isNull(dimX)) || (length(dimX) != 3)) { error("rprocess error: user 'rprocess' must return a rank-3 array"); } xdim = INTEGER(dimX); if ((xdim[0] != nvars) || (xdim[1] != nreps) || (xdim[2] != ntimes)) { error("rprocess error: user 'rprocess' must return a %d x %d x %d array",nvars,nreps,ntimes); } if (isNull(GET_ROWNAMES(GET_DIMNAMES(X)))) { error("rprocess error: user 'rprocess' must return an array with rownames"); } if (off > 0) { xdim[2] -= off; PROTECT(Xoff = makearray(3,xdim)); nprotect++; setrownames(Xoff,GET_ROWNAMES(GET_DIMNAMES(X)),3); memcpy(REAL(Xoff),REAL(X)+off*nvars*nreps,(ntimes-off)*nvars*nreps*sizeof(double)); UNPROTECT(nprotect); return Xoff; } else { UNPROTECT(nprotect); return X; } }
SEXP do_init_state (SEXP object, SEXP params, SEXP t0, SEXP nsim, SEXP gnsi) { int nprotect = 0; SEXP Pnames, Snames; SEXP x = R_NilValue; int *dim; int npar, nrep, nvar, ns; int definit; int xdim[2]; const char *dimnms[2] = {"variable","rep"}; ns = *(INTEGER(AS_INTEGER(nsim))); PROTECT(params = as_matrix(params)); nprotect++; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; dim = INTEGER(GET_DIM(params)); npar = dim[0]; nrep = dim[1]; if (ns % nrep != 0) errorcall(R_NilValue,"in 'init.state': number of desired state-vectors 'nsim' is not a multiple of ncol('params')"); definit = *(INTEGER(GET_SLOT(object,install("default.init")))); if (definit) { // default initializer SEXP fcall, pat, repl, val, ivpnames, statenames; int *pidx, j, k; double *xp, *pp; PROTECT(pat = NEW_CHARACTER(1)); nprotect++; SET_STRING_ELT(pat,0,mkChar("\\.0$")); PROTECT(repl = NEW_CHARACTER(1)); nprotect++; SET_STRING_ELT(repl,0,mkChar("")); PROTECT(val = NEW_LOGICAL(1)); nprotect++; *(INTEGER(val)) = 1; // extract names of IVPs PROTECT(fcall = LCONS(val,R_NilValue)); nprotect++; SET_TAG(fcall,install("value")); PROTECT(fcall = LCONS(Pnames,fcall)); nprotect++; SET_TAG(fcall,install("x")); PROTECT(fcall = LCONS(pat,fcall)); nprotect++; SET_TAG(fcall,install("pattern")); PROTECT(fcall = LCONS(install("grep"),fcall)); nprotect++; PROTECT(ivpnames = eval(fcall,R_BaseEnv)); nprotect++; nvar = LENGTH(ivpnames); if (nvar < 1) { errorcall(R_NilValue,"in default 'initializer': there are no parameters with suffix '.0'. See '?pomp'."); } pidx = INTEGER(PROTECT(match(Pnames,ivpnames,0))); nprotect++; for (k = 0; k < nvar; k++) pidx[k]--; // construct names of state variables PROTECT(fcall = LCONS(ivpnames,R_NilValue)); nprotect++; SET_TAG(fcall,install("x")); PROTECT(fcall = LCONS(repl,fcall)); nprotect++; SET_TAG(fcall,install("replacement")); PROTECT(fcall = LCONS(pat,fcall)); nprotect++; SET_TAG(fcall,install("pattern")); PROTECT(fcall = LCONS(install("sub"),fcall)); nprotect++; PROTECT(statenames = eval(fcall,R_BaseEnv)); nprotect++; xdim[0] = nvar; xdim[1] = ns; PROTECT(x = makearray(2,xdim)); nprotect++; setrownames(x,statenames,2); fixdimnames(x,dimnms,2); for (j = 0, xp = REAL(x); j < ns; j++) { pp = REAL(params) + npar*(j%nrep); for (k = 0; k < nvar; k++, xp++) *xp = pp[pidx[k]]; } } else { // user-supplied initializer SEXP pompfun, fcall, fn, tcovar, covar, covars = R_NilValue; pompfunmode mode = undef; double *cp = NULL; // extract the initializer function and its environment PROTECT(pompfun = GET_SLOT(object,install("initializer"))); nprotect++; PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++; // extract covariates and interpolate PROTECT(tcovar = GET_SLOT(object,install("tcovar"))); nprotect++; if (LENGTH(tcovar) > 0) { // do table lookup PROTECT(covar = GET_SLOT(object,install("covar"))); nprotect++; PROTECT(covars = lookup_in_table(tcovar,covar,t0)); nprotect++; cp = REAL(covars); } // extract userdata PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++; switch (mode) { case Rfun: // use R function { SEXP par, rho, x1, x2; double *p, *pp, *xp, *xt; int j, *midx; // extract covariates and interpolate if (LENGTH(tcovar) > 0) { // add covars to call PROTECT(fcall = LCONS(covars,fcall)); nprotect++; SET_TAG(fcall,install("covars")); } // parameter vector PROTECT(par = NEW_NUMERIC(npar)); nprotect++; SET_NAMES(par,Pnames); pp = REAL(par); // finish constructing the call PROTECT(fcall = LCONS(t0,fcall)); nprotect++; SET_TAG(fcall,install("t0")); PROTECT(fcall = LCONS(par,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; // evaluation environment PROTECT(rho = (CLOENV(fn))); nprotect++; p = REAL(params); memcpy(pp,p,npar*sizeof(double)); // copy the parameters PROTECT(x1 = eval(fcall,rho)); nprotect++; // do the call PROTECT(Snames = GET_NAMES(x1)); nprotect++; if (!IS_NUMERIC(x1) || isNull(Snames)) { UNPROTECT(nprotect); errorcall(R_NilValue,"in 'init.state': user 'initializer' must return a named numeric vector"); } nvar = LENGTH(x1); xp = REAL(x1); midx = INTEGER(PROTECT(match(Pnames,Snames,0))); nprotect++; for (j = 0; j < nvar; j++) { if (midx[j]!=0) { UNPROTECT(nprotect); errorcall(R_NilValue,"in 'init.state': a state variable and a parameter share a single name: '%s'",CHARACTER_DATA(STRING_ELT(Snames,j))); } } xdim[0] = nvar; xdim[1] = ns; PROTECT(x = makearray(2,xdim)); nprotect++; setrownames(x,Snames,2); fixdimnames(x,dimnms,2); xt = REAL(x); memcpy(xt,xp,nvar*sizeof(double)); for (j = 1, xt += nvar; j < ns; j++, xt += nvar) { memcpy(pp,p+npar*(j%nrep),npar*sizeof(double)); PROTECT(x2 = eval(fcall,rho)); xp = REAL(x2); if (LENGTH(x2)!=nvar) errorcall(R_NilValue,"in 'init.state': user initializer returns vectors of non-uniform length"); memcpy(xt,xp,nvar*sizeof(double)); UNPROTECT(1); } } break; case native: // use native routine { SEXP Cnames; int *sidx, *pidx, *cidx; double *xt, *ps, time; pomp_initializer *ff = NULL; int j; PROTECT(Snames = GET_SLOT(pompfun,install("statenames"))); nprotect++; PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++; // construct state, parameter, covariate, observable indices sidx = INTEGER(PROTECT(name_index(Snames,pompfun,"statenames","state variables"))); nprotect++; pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames","parameters"))); nprotect++; cidx = INTEGER(PROTECT(name_index(Cnames,pompfun,"covarnames","covariates"))); nprotect++; // address of native routine *((void **) (&ff)) = R_ExternalPtrAddr(fn); nvar = LENGTH(Snames); xdim[0] = nvar; xdim[1] = ns; PROTECT(x = makearray(2,xdim)); nprotect++; setrownames(x,Snames,2); fixdimnames(x,dimnms,2); set_pomp_userdata(fcall); GetRNGstate(); time = *(REAL(t0)); // loop over replicates for (j = 0, xt = REAL(x), ps = REAL(params); j < ns; j++, xt += nvar) (*ff)(xt,ps+npar*(j%nrep),time,sidx,pidx,cidx,cp); PutRNGstate(); unset_pomp_userdata(); } break; default: errorcall(R_NilValue,"in 'init.state': unrecognized 'mode'"); // # nocov break; } } UNPROTECT(nprotect); return x; }
SEXP do_dprior (SEXP object, SEXP params, SEXP log, SEXP gnsi) { int nprotect = 0; pompfunmode mode = undef; int npars, nreps; SEXP Pnames, F, fn, fcall; SEXP pompfun; int *dim; PROTECT(params = as_matrix(params)); nprotect++; dim = INTEGER(GET_DIM(params)); npars = dim[0]; nreps = dim[1]; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; // extract the user-defined function PROTECT(pompfun = GET_SLOT(object,install("dprior"))); nprotect++; PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++; // extract 'userdata' as pairlist PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++; // to store results PROTECT(F = NEW_NUMERIC(nreps)); nprotect++; // first do setup switch (mode) { case Rfun: // use R function { SEXP pvec, rho; double *pp, *ps, *pt; int j; // temporary storage PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++; SET_NAMES(pvec,Pnames); // set up the function call PROTECT(fcall = LCONS(AS_LOGICAL(log),fcall)); nprotect++; SET_TAG(fcall,install("log")); PROTECT(fcall = LCONS(pvec,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; // get the function's environment PROTECT(rho = (CLOENV(fn))); nprotect++; pp = REAL(pvec); for (j = 0, ps = REAL(params), pt = REAL(F); j < nreps; j++, ps += npars, pt++) { memcpy(pp,ps,npars*sizeof(double)); *pt = *(REAL(AS_NUMERIC(eval(fcall,rho)))); } } break; case native: // use native routine { int give_log, *pidx = 0; pomp_dprior *ff = NULL; double *ps, *pt; int j; // construct state, parameter, covariate, observable indices pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames"))); nprotect++; // address of native routine ff = (pomp_dprior *) R_ExternalPtrAddr(fn); give_log = *(INTEGER(AS_INTEGER(log))); R_CheckUserInterrupt(); // check for user interrupt set_pomp_userdata(fcall); // loop over replicates for (j = 0, pt = REAL(F), ps = REAL(params); j < nreps; j++, ps += npars, pt++) (*ff)(pt,ps,give_log,pidx); unset_pomp_userdata(); } break; default: error("unrecognized 'mode' slot in 'dprior'"); break; } UNPROTECT(nprotect); return F; }
INT base::calc_size_on_file() { enum kind k; INT i, size; char c; k = s_kind(); i = (INT) k; c = (char) k; if (!ONE_BYTE_INT(i)) { cout << "write_memory(): kind not 1 byte" << endl; exit(1); } size = 1; switch (k) { case BASE: break; case INTEGER: size += 4; break; case VECTOR: size += as_vector().csf(); break; case NUMBER_PARTITION: size += as_number_partition().csf(); break; case PERMUTATION: size += as_permutation().csf(); break; case MATRIX: size += as_matrix().csf(); break; case LONGINTEGER: // size += as_longinteger().csf(); cout << "base::write_mem() no csf for LONGINTEGER" << endl; break; case MEMORY: size += as_memory().csf(); break; case HOLLERITH: size += as_hollerith().csf(); break; //case PERM_GROUP: //size += as_perm_group().csf(); //break; //case PERM_GROUP_STAB_CHAIN: //size += as_perm_group_stab_chain().csf(); //break; case UNIPOLY: size += as_unipoly().csf(); break; case SOLID: size += as_vector().csf(); break; case BITMATRIX: size += as_bitmatrix().csf(); break; //case PC_PRESENTATION: //size += as_pc_presentation().csf(); //break; //case PC_SUBGROUP: //size += as_pc_subgroup().csf(); //break; //case GROUP_WORD: //size += as_group_word().csf(); //break; //case GROUP_TABLE: //size += as_group_table().csf(); //break; #if 0 case ACTION: size += as_action().csf(); break; #endif case GEOMETRY: size += as_geometry().csf(); break; case GROUP_SELECTION: size += as_group_selection().csf(); break; case DESIGN_PARAMETER: size += as_design_parameter().csf(); break; case DESIGN_PARAMETER_SOURCE: size += as_design_parameter_source().csf(); break; default: cout << "base::calc_size_on_file() no csf() for " << kind_ascii(k) << endl; exit(1); } return size; }
void base::read_memory(memory &m, INT debug_depth) { enum kind k; INT i; char c; m.read_char(&c); k = (enum kind) c; c_kind(k); switch (k) { case BASE: break; case INTEGER: m.read_int(&i); m_i_i(i); break; case VECTOR: as_vector().read_mem(m, debug_depth); break; case NUMBER_PARTITION: as_number_partition().read_mem(m, debug_depth); break; case PERMUTATION: as_permutation().read_mem(m, debug_depth); break; case MATRIX: as_matrix().read_mem(m, debug_depth); break; case LONGINTEGER: // as_longinteger().read_mem(m, debug_depth); cout << "base::read_mem() no read_mem for LONGINTEGER" << endl; break; case MEMORY: as_memory().read_mem(m, debug_depth); break; case HOLLERITH: as_hollerith().read_mem(m, debug_depth); break; //case PERM_GROUP: //as_perm_group().read_mem(m, debug_depth); //break; //case PERM_GROUP_STAB_CHAIN: //as_perm_group_stab_chain().read_mem(m, debug_depth); //break; case UNIPOLY: as_unipoly().read_mem(m, debug_depth); break; case SOLID: as_vector().read_mem(m, debug_depth); break; case BITMATRIX: as_bitmatrix().read_mem(m, debug_depth); break; //case PC_PRESENTATION: //as_pc_presentation().read_mem(m, debug_depth); //break; //case PC_SUBGROUP: //as_pc_subgroup().read_mem(m, debug_depth); //break; //case GROUP_WORD: //as_group_word().read_mem(m, debug_depth); //break; //case GROUP_TABLE: //as_group_table().read_mem(m, debug_depth); //break; #if 0 case ACTION: as_action().read_mem(m, debug_depth); break; #endif case GEOMETRY: as_geometry().read_mem(m, debug_depth); break; case GROUP_SELECTION: as_group_selection().read_mem(m, debug_depth); break; case DESIGN_PARAMETER: as_design_parameter().read_mem(m, debug_depth); break; case DESIGN_PARAMETER_SOURCE: as_design_parameter_source().read_mem(m, debug_depth); break; default: cout << "base::read_memory() no read_mem for " << kind_ascii(k) << endl; exit(1); } }
void base::write_memory(memory &m, INT debug_depth) { enum kind k; INT i; char c; k = s_kind(); i = (INT) k; c = (char) k; if (!ONE_BYTE_INT(i)) { cout << "write_memory(): kind not 1 byte" << endl; exit(1); } m.write_char(c); if (debug_depth > 0) { cout << "base::write_memory() object of kind = " << kind_ascii(k) << endl; } switch (k) { case BASE: break; case INTEGER: m.write_int(s_i_i()); break; case VECTOR: as_vector().write_mem(m, debug_depth); break; case NUMBER_PARTITION: as_number_partition().write_mem(m, debug_depth); break; case PERMUTATION: as_permutation().write_mem(m, debug_depth); break; case MATRIX: as_matrix().write_mem(m, debug_depth); break; case LONGINTEGER: // as_longinteger().write_mem(m, debug_depth); cout << "base::write_mem() no write_mem for LONGINTEGER" << endl; break; case MEMORY: as_memory().write_mem(m, debug_depth); break; case HOLLERITH: as_hollerith().write_mem(m, debug_depth); break; //case PERM_GROUP: //as_perm_group().write_mem(m, debug_depth); //break; //case PERM_GROUP_STAB_CHAIN: //as_perm_group_stab_chain().write_mem(m, debug_depth); //break; case UNIPOLY: as_unipoly().write_mem(m, debug_depth); break; case SOLID: as_solid().write_mem(m, debug_depth); break; case BITMATRIX: as_bitmatrix().write_mem(m, debug_depth); break; //case PC_PRESENTATION: //as_pc_presentation().write_mem(m, debug_depth); //break; //case PC_SUBGROUP: //as_pc_subgroup().write_mem(m, debug_depth); //break; //case GROUP_WORD: //as_group_word().write_mem(m, debug_depth); //break; //case GROUP_TABLE: //as_group_table().write_mem(m, debug_depth); //break; #if 0 case ACTION: as_action().write_mem(m, debug_depth); break; #endif case GEOMETRY: as_geometry().write_mem(m, debug_depth); break; case GROUP_SELECTION: as_group_selection().write_mem(m, debug_depth); break; case DESIGN_PARAMETER: as_design_parameter().write_mem(m, debug_depth); break; case DESIGN_PARAMETER_SOURCE: as_design_parameter_source().write_mem(m, debug_depth); break; default: cout << "base::write_memory() no write_mem for " << kind_ascii(k) << endl; exit(1); } }