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