std::map<STM::ParName, double> Metropolis::do_sample(int n, bool saveDeviance)
// n is the number of samples to take
// returns a map of acceptance rates keyed by parameter name
{
// shuffle the order of parameters
std::vector<STM::ParName> parNames (parameters.active_names());
std::random_shuffle(parNames.begin(), parNames.end(),
[this](int n){ return gsl_rng_uniform_int(rng.get(), n); });
std::map<STM::ParName, int> numAccepted;
for(const auto & par : parNames)
numAccepted[par] = 0;
for(int i = 0; i < n; i++)
{
for(int j = 0; j < thinSize; j++)
{
// step through each parameter
for(const auto & par : parNames) {
STM::ParPair proposal = propose_parameter(par);
numAccepted[par] += select_parameter(proposal);
}
}
parameters.increment();
currentSamples.push_back(parameters.current_state());
if(saveDeviance)
sampleDeviance.push_back(std::pair<double, int>(-2 * currentLL, 1));
// if desired, some debugging output
if(outputLevel >= EngineOutputLevel::Verbose) {
std::cerr << " iteration " << parameters.iteration() - 1 <<
" posterior probability: " << currentPosteriorProb <<
" likelihood: " << currentLL << "\n";
if(outputLevel >= EngineOutputLevel::ExtraVerbose) {
std::ios_base::fmtflags oldflags = std::cerr.flags();
std::streamsize oldprecision = std::cerr.precision();
std::cerr << std::fixed << std::setprecision(3) << " ";
STM::ParMap st = parameters.current_state();
int coln = 0;
for(auto pa : st) {
std::cerr << std::setw(6) << pa.first << std::setw(8) << pa.second;
if(++coln >= 7) {
std::cerr << "\n ";
coln = 0;
}
}
std::cerr << std::endl;
std::cerr.flags (oldflags);
std::cerr.precision (oldprecision);
}
}
}
std::map<STM::ParName, double> acceptanceRates;
for(const auto & par : parNames)
acceptanceRates[par] = double(numAccepted[par]) / (n*thinSize);
return acceptanceRates;
}
void tabbing_format
( MPL *mpl,
SYMBOL *altval /* not changed */
)
{ SET *set = NULL;
PARAMETER *par;
SLICE *list, *col;
TUPLE *tuple;
int next_token, j, dim = 0;
char *last_name = NULL;
/* read the optional <prefix> */
if (is_symbol(mpl))
{ get_token(mpl /* <symbol> */);
next_token = mpl->token;
unget_token(mpl /* <symbol> */);
if (next_token == T_COLON)
{ /* select the set to saturate it with data */
set = select_set(mpl, mpl->image);
/* the set must be simple (i.e. not set of sets) */
if (set->dim != 0)
error(mpl, "%s must be a simple set", set->name);
/* and must not be defined yet */
if (set->array->head != NULL)
error(mpl, "%s already defined", set->name);
/* add new (the only) member to the set and assign it empty
elemental set */
add_member(mpl, set->array, NULL)->value.set =
create_elemset(mpl, set->dimen);
last_name = set->name, dim = set->dimen;
get_token(mpl /* <symbol> */);
insist(mpl->token == T_COLON);
get_token(mpl /* : */);
}
}
/* read the table heading that contains parameter names */
list = create_slice(mpl);
while (mpl->token != T_ASSIGN)
{ /* there must be symbolic name of parameter */
if (!is_symbol(mpl))
error(mpl, "parameter name or := missing where expected");
/* select the parameter to saturate it with data */
par = select_parameter(mpl, mpl->image);
/* the parameter must be subscripted */
if (par->dim == 0)
error(mpl, "%s not a subscripted parameter", mpl->image);
/* the set (if specified) and all the parameters in the data
block must have identical dimension */
if (dim != 0 && par->dim != dim)
{ insist(last_name != NULL);
error(mpl, "%s has dimension %d while %s has dimension %d",
last_name, dim, par->name, par->dim);
}
/* set default value for the parameter (if specified) */
if (altval != NULL)
set_default(mpl, par, copy_symbol(mpl, altval));
/* append the parameter to the column list */
list = expand_slice(mpl, list, (SYMBOL *)par);
last_name = par->name, dim = par->dim;
get_token(mpl /* <symbol> */);
/* skip optional comma */
if (mpl->token == T_COMMA) get_token(mpl /* , */);
}
if (slice_dimen(mpl, list) == 0)
error(mpl, "at least one parameter name required");
get_token(mpl /* := */);
/* skip optional comma */
if (mpl->token == T_COMMA) get_token(mpl /* , */);
/* read rows that contain tabbing data */
while (is_symbol(mpl))
{ /* read subscript list */
tuple = create_tuple(mpl);
for (j = 1; j <= dim; j++)
{ /* read j-th subscript */
if (!is_symbol(mpl))
{ int lack = slice_dimen(mpl, list) + dim - j + 1;
insist(tuple != NULL);
insist(lack > 1);
error(mpl, "%d items missing in data group beginning wit"
"h %s", lack, format_symbol(mpl, tuple->sym));
}
/* read and append j-th subscript to the n-tuple */
tuple = expand_tuple(mpl, tuple, read_symbol(mpl));
/* skip optional comma *between* <symbols> */
if (j < dim && mpl->token == T_COMMA)
get_token(mpl /* , */);
}
/* if the set is specified, add to it new n-tuple, which is a
copy of the subscript list just read */
if (set != NULL)
check_then_add(mpl, set->array->head->value.set,
copy_tuple(mpl, tuple));
/* skip optional comma between <symbol> and <value> */
if (mpl->token == T_COMMA) get_token(mpl /* , */);
/* read values accordingly to the column list */
for (col = list; col != NULL; col = col->next)
{ /* if the token is single point, no value is provided */
if (is_literal(mpl, "."))
{ get_token(mpl /* . */);
continue;
}
/* read value and assign it to new parameter member */
if (!is_symbol(mpl))
{ int lack = slice_dimen(mpl, col);
insist(tuple != NULL);
if (lack == 1)
error(mpl, "one item missing in data group beginning "
"with %s", format_symbol(mpl, tuple->sym));
else
error(mpl, "%d items missing in data group beginning "
"with %s", lack, format_symbol(mpl, tuple->sym));
}
read_value(mpl, (PARAMETER *)col->sym, copy_tuple(mpl,
tuple));
/* skip optional comma preceding the next value */
if (col->next != NULL && mpl->token == T_COMMA)
get_token(mpl /* , */);
}
/* delete the original subscript list */
delete_tuple(mpl, tuple);
/* skip optional comma (only if there is next data group) */
if (mpl->token == T_COMMA)
{ get_token(mpl /* , */);
if (!is_symbol(mpl)) unget_token(mpl /* , */);
}
}
/* delete the column list (it contains parameters, not symbols,
so nullify it before) */
for (col = list; col != NULL; col = col->next) col->sym = NULL;
delete_slice(mpl, list);
return;
}
void parameter_data(MPL *mpl)
{ PARAMETER *par;
SYMBOL *altval = NULL;
SLICE *slice;
int tr = 0;
insist(is_literal(mpl, "param"));
get_token(mpl /* param */);
/* read optional default value */
if (is_literal(mpl, "default"))
{ get_token(mpl /* default */);
if (!is_symbol(mpl))
error(mpl, "default value missing where expected");
altval = read_symbol(mpl);
/* if the default value follows the keyword 'param', the next
token must be only the colon */
if (mpl->token != T_COLON)
error(mpl, "colon missing where expected");
}
/* being used after the keyword 'param' or the optional default
value the colon begins data in the tabbing format */
if (mpl->token == T_COLON)
{ get_token(mpl /* : */);
/* skip optional comma */
if (mpl->token == T_COMMA) get_token(mpl /* , */);
/* read parameter data in the tabbing format */
tabbing_format(mpl, altval);
/* on reading data in the tabbing format the default value is
always copied, so delete the original symbol */
if (altval != NULL) delete_symbol(mpl, altval);
/* the next token must be only semicolon */
if (mpl->token != T_SEMICOLON)
error(mpl, "symbol, number, or semicolon missing where expe"
"cted");
get_token(mpl /* ; */);
goto done;
}
/* in other cases there must be symbolic name of parameter, which
follows the keyword 'param' */
if (!is_symbol(mpl))
error(mpl, "parameter name missing where expected");
/* select the parameter to saturate it with data */
par = select_parameter(mpl, mpl->image);
get_token(mpl /* <symbol> */);
/* read optional default value */
if (is_literal(mpl, "default"))
{ get_token(mpl /* default */);
if (!is_symbol(mpl))
error(mpl, "default value missing where expected");
altval = read_symbol(mpl);
/* set default value for the parameter */
set_default(mpl, par, altval);
}
/* create initial fake slice of all asterisks */
slice = fake_slice(mpl, par->dim);
/* read zero or more data assignments */
for (;;)
{ /* skip optional comma */
if (mpl->token == T_COMMA) get_token(mpl /* , */);
/* process current assignment */
if (mpl->token == T_ASSIGN)
{ /* assignment ligature is non-significant element */
get_token(mpl /* := */);
}
else if (mpl->token == T_LBRACKET)
{ /* left bracket begins new slice; delete the current slice
and read new one */
delete_slice(mpl, slice);
slice = read_slice(mpl, par->name, par->dim);
/* each new slice resets the "transpose" indicator */
tr = 0;
}
else if (is_symbol(mpl))
{ /* number or symbol begins data in the plain format */
plain_format(mpl, par, slice);
}
else if (mpl->token == T_COLON)
{ /* colon begins data in the tabular format */
if (par->dim == 0)
err1: error(mpl, "%s not a subscripted parameter",
par->name);
if (slice_arity(mpl, slice) != 2)
err2: error(mpl, "slice currently used must specify 2 asterisk"
"s, not %d", slice_arity(mpl, slice));
get_token(mpl /* : */);
/* read parameter data in the tabular format */
tabular_format(mpl, par, slice, tr);
}
else if (mpl->token == T_LEFT)
{ /* left parenthesis begins the "transpose" indicator, which
is followed by data in the tabular format */
get_token(mpl /* ( */);
if (!is_literal(mpl, "tr"))
err3: error(mpl, "transpose indicator (tr) incomplete");
if (par->dim == 0) goto err1;
if (slice_arity(mpl, slice) != 2) goto err2;
get_token(mpl /* tr */);
if (mpl->token != T_RIGHT) goto err3;
get_token(mpl /* ) */);
/* in this case the colon is optional */
if (mpl->token == T_COLON) get_token(mpl /* : */);
/* set the "transpose" indicator */
tr = 1;
/* read parameter data in the tabular format */
tabular_format(mpl, par, slice, tr);
}
else if (mpl->token == T_SEMICOLON)
{ /* semicolon terminates the data block */
get_token(mpl /* ; */);
break;
}
else
error(mpl, "syntax error in parameter data block");
}
/* delete the current slice */
delete_slice(mpl, slice);
done: return;
}
