R/estimate_account.R

In ONSdigital/Bayesian-demographic-accounts: Bayesian Demographic Accounts

#' Estimate a demographic account
#'
#' Estimate consistent counts of population,
#' births, deaths, and migration. All counts
#' are estimated from scratch.
#'
#' If \code{rates} and \code{data_models} have \code{"region"},
#' columns, the order of the regions is taken from
#' the deaths dataset in \code{rates}.
#'
#' @param rates A named list of data frames giving rates
#' for births, deaths, and migration, as described
#' in \code{\link{rates-arg}}.
#' @param data_models A list of data models.
#' Within each series, the models should be ordered according
#' to reliability of the data, with most reliable coming first.
#' @param dominant Which sex/gender is used in the denominantor
#' when calculating fertility rates. Defaults to \code{"Female"}.
#' @param n_particle The number of particles to create.
#' Defaults to 1000.
#' @param n_thin Outputs contain \code{n_particle/n_thin}
#' particles. Defaults to 1, so that all particles are returned.
#' @param threshold Threshold for triggering resampling.
#' A number between 0 and 1. Defaults to 0.5.
#' @param n_thread Number of threads to be used in
#' parallel processing. Currently ignored.
#'
#' @return A data frame holding a demographic account.
#'
#' @seealso \code{\link{extend_account}}, \code{\link{forecast_account}}
#'
#' @export
estimate_account <- function(rates,
                             data_models,
                             dominant = "Female",
                             n_particle = 1000,
                             n_thin = 1,
                             threshold = 0.5,
                             n_thread = NULL) {
    ## check and process arguments
    check_rates(rates)
    check_data_models(data_models)
    check_consistent_rates_data_models(rates = rates,
                                       data_models = data_models)    
    check_dominant(dominant)
    check_n_particle(n_particle)
    check_n_thin(n_thin)
    check_threshold(threshold)
    check_n_thread(n_thread)
    ## create inputs for cohort-level calculations
    df <- make_df_estimate(rates = rates,
                           data_models = data_models,
                           dominant = dominant)
    df_rows <- split_into_rows(df)
    ## do the estimation
    output <- use_pfilters(df_rows = df_rows,
                           n_particle = n_particle,
                           n_thin = n_thin,
                           threshold = threshold,
                           n_thread = n_thread,
                           draw_init = TRUE)
    ## assemble estimates and diagnostics, and return
    account <- make_account(output)
    diagnostics <- make_diagnostics(output)
    list(account = account,
         diagnostics = diagnostics)
}



#' Extend an existing demographic account
#'
#' Add new periods to an existing demographic
#' account, based on new data.
#' The number of additional periods is inferred
#' from the \code{rates} argument.
#'
#' @inheritParams estimate_account
#' @param account A data frame holding a demographic account,
#' typically created by a call to \code{estimate_account}
#' or \code{extend account}.
#'
#' @return A data frame holding a demographic account.
#'
#' @seealso \code{\link{estimate_account}}, \code{\link{forecast_account}}
#'
#' @export
extend_account <- function(account,
                           rates,
                           data_models,
                           dominant = "Female",
                           n_particle = 1000,
                           n_thin = 1,
                           threshold = 0.5,
                           n_thread = NULL) {
    ## check arguments
    check_account(account)
    check_rates(rates)
    check_data_models(data_models)
    check_consistent_account_rates(account = account,
                                   rates = rates)
    check_consistent_rates_data_models(rates = rates,
                                       data_models = data_models)    
    check_dominant(dominant)
    check_n_particle(n_particle)
    check_n_thin(n_thin)
    check_threshold(threshold)
    check_n_thread(n_thread)
    ## create inputs for cohort-level calculations
    df <- make_df_extend(account = account,
                         rates = rates,
                         data_models = data_models,
                         dominant = dominant)
    df_rows <- split_into_rows(df)
    ## do estimation
    output <- use_pfilters(df_rows = df_rows,
                           n_particle = n_particle,
                           n_thin = n_thin,
                           threshold = threshold,
                           n_thread = n_thread,
                           draw_init = FALSE)
    ## assemble estimates and diagnostics, and return
    account <- make_account(output)
    diagnostics <- make_diagnostics(output)
    list(account = account,
         diagnostics = diagnostics)
}


#' Forecast an existing demographic account
#'
#' Add extra periods to an existing demographic
#' account, based on forecasted demographic rates.
#' The number of extra periods is inferred
#' from the \code{rates} argument.
#'
#' @inheritParams estimate_account
#' @param account A data frame holding a demographic account,
#' typically created by a call to \code{estimate_account}
#' or \code{extend account}.
#'
#' @return A data frame holding a demographic account.
#'
#' @seealso \code{\link{estimate_account}}, \code{\link{extend_account}}
#'
#' @export
forecast_account <- function(account,
                             rates,
                             dominant = "Female",
                             n_particle = 1000,
                             n_thin = 1,
                             threshold = 0.5,
                             n_thread = NULL) {
    ## check arguments
    check_account(account)
    check_rates(rates)
    check_consistent_account_rates(account = account,
                                   rates = rates)
    check_dominant(dominant)
    check_n_particle(n_particle)
    check_n_thin(n_thin)
    check_threshold(threshold)
    check_n_thread(n_thread)
    ## create inputs for cohort-level calculations
    df <- make_df_forecast(account = account,
                           rates = rates,
                           dominant = dominant)
    df_rows <- split_into_rows(df)
    ## do estimation
    output <- use_pfilters(df_rows = df_rows,
                           n_particle = n_particle,
                           n_thin = n_thin,
                           threshold = threshold,
                           n_thread = n_thread,
                           draw_init = FALSE)
    ## assemble estimates and diagnostics, and return
    account <- make_account(output)
    diagnostics <- make_diagnostics(output)
    list(account = account,
         diagnostics = diagnostics)
}
                        


## 'use_pfilters' is and internal function, and will
## will eventually need to be translated into C++
## The 'n_thread' argument is currently ignored, but in future
## if 'n_thread' is non-NULL, we will process in parallel,
## probably using RcppParallel
use_pfilters <- function(df_rows,
                         n_particle,
                         n_thin,
                         threshold,
                         n_thread,
                         draw_init) {
    n_pfilter <- length(df_rows)
    ans <- vector(mode = "list", length = n_pfilter)
    ## make particle filters
    has_region <- "region" %in% names(df_rows[[1L]])
    class_obj <- if (has_region) PFilterWithReg else PFilterNoReg
    for (i in seq_len(n_pfilter))
        ans[[i]] <- class_obj$new(df_row = df_rows[[i]],
                                  n_particle = n_particle,
                                  n_thin = n_thin,
                                  threshold = threshold)
    ## run particle filters
    for (i in seq_len(n_pfilter))
        ans[[i]]$run(draw_init)
    ## make output from particle filters
    for (i in seq_len(n_pfilter))
        ans[[i]]$make_output() ## possibly take a 'draw_init' argument
    ## return result as list
    ans
}