R/PFilter-constructors.R

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

## globals.R needs to be run to avoid warnings about
## global variables 'self' and 'super'
## We need functions 'new_CdmsNoreg' and 'new_CdmsWithreg',
## which are in file 'cdms-constructors.R',
## for the code in this file to run. @include
## makes sure that the other files are run first.
#' @include globals.R cdms-constructors.R
NULL

## In this file we create the class objects first, and
## then add initialization methods later, using 'set'.
## In file 'PFilter-methods' we add further methods
## using 'set'.




## create class objects -------------------------------------------------------

## Superclass for PFilterNoReg and PFilterWithReg
PFilter <-
    R6::R6Class("PFilter",
                public = list(
                    ## fields - inputs
                    cohort = NA_integer_,        # year cohort born (used in error messages)
                    sexgender = NA_character_,   # sex/gender of cohort (used in error messages)
                    initial_stock_fixed = NA,      # whether first value for stock should be treated as fixed
                    has_births_to = NA,          # whether births attributed to this sex/gender
                    n_interval = NA_integer_,    # number of intervals being estimated
                    n_particle = NA_integer_,    # number of sample paths
                    n_thin = NA_integer_,        # return (n_particle/n_thin) samples at end
                    threshold = NA_real_,        # threshold for resampling, between 0 and 1
                    ## fields - intermediate calculations
                    logimp = numeric(),          # log probability of proposal, length n_particle
                    loglik = numeric(),          # log likelihood, length n_particle
                    wt = matrix(),               # normalised weights, numeric, matrix n_particle x (n_interval+1)
                    ## fields - outputs
                    resampled = logical()))      # whether resampling done, length n_interval TODO - CHECK LENGTH

PFilterNoReg <-
    R6::R6Class("PFilterNoReg",
                public = list(
                    ## fields - inputs
                    counts_births_of = NA_integer_,         # births of members of cohort
                    counts_births_to = integer(),           # births to members of cohort, length n_interval
                    counts_deaths = integer(),              # deaths of members of cohort, length n_interval
                    rates_births = numeric(),               # rate of births to cohort, length n_interval
                    rates_deaths = numeric(),               # death rates, length n_interval
                    rates_immigration1 = numeric(),         # immigration rates, length n_interval
                    rates_emigration1 = numeric(),          # emigration rates, length n_interval
                    rates_immigration2 = numeric(),         # immigration rates, length n_interval
                    rates_emigration2 = numeric(),          # emigration rates, length n_interval
                    cdms_stock = NULL, # new_CdmsNoreg(),          # data model, object of class "cdms_noreg"
                    cdms_immigration1 = NULL, # new_CdmsNoreg(),   # data model, object of class "cdms_noreg"
                    cdms_emigration1 = NULL, # new_CdmsNoreg(),    # data model, object of class "cdms_noreg"
                    cdms_immigration2 = NULL, # new_CdmsNoreg(),   # data model, object of class "cdms_noreg"
                    cdms_emigration2 = NULL, # new_CdmsNoreg(),    # data model, object of class "cdms_noreg"
                    ## fields - intermediate calculations
                    have_stock_data = NA,                   # whether data on stock available for current interval
                    ## fields, outputs
                    counts_stock = matrix(),                # stock estimates, matrix n_particle x (n_interval+1)
                    counts_immigration1 = matrix(),         # immigration estimates, matrix n_particle x n_interval
                    counts_emigration1 = matrix(),          # emigration estimates, matrix n_particle x n_interval
                    counts_immigration2 = matrix(),         # immigration estimates, matrix n_particle x n_interval
                    counts_emigration2 = matrix()),         # emigration estimates, matrix n_particle x n_interval
                inherit = PFilter)

PFilterWithReg <-
    R6::R6Class("PFilterWithReg",
                public = list(
                    ## fields - inputs
                    n_region = NA_integer_,                  # number of regions
                    counts_births_of = integer(),            # births of members of cohort, length n_region
                    counts_births_to = matrix(),             # births to members of cohort, int matrix n_region x n_interval
                    counts_deaths = matrix(),                # deaths of members of cohort, int matrix n_region x n_interval
                    rates_births = matrix(),                 # rate of births to cohort, dbl matrix n_region x n_interval
                    rates_deaths = matrix(),                 # death rates, dbl matrix n_region x n_interval
                    rates_internal_in = matrix(),            # internal mig rates, dbl matrix n_region x n_interval
                    rates_internal_out = matrix(),           # internal mig rates, dbl matrix n_region x n_interval
                    rates_immigration1 = matrix(),           # immigration rates, dbl matrix n_region x n_interval
                    rates_emigration1 = matrix(),            # emigration rates, dbl matrix n_region x n_interval
                    rates_immigration2 = matrix(),           # immigration rates, dbl matrix n_region x n_interval
                    rates_emigration2 = matrix(),            # emigration rates, dbl matrix n_region x n_interval
                    cdms_stock = NULL, # new_CdmsWithreg(),         # data model, object of class "cdms_withreg"
                    cdms_internal_in = NULL, # new_CdmsWithreg(),   # data model, object of class "cdms_withreg"
                    cdms_internal_out = NULL, # new_CdmsWithreg(),  # data model, object of class "cdms_withreg"
                    cdms_immigration1 = NULL, # new_CdmsWithreg(),  # data model, object of class "cdms_withreg"
                    cdms_emigration1 = NULL, # new_CdmsWithreg(),   # data model, object of class "cdms_withreg"
                    cdms_immigration2 = NULL, # new_CdmsWithreg(),  # data model, object of class "cdms_withreg"
                    cdms_emigration2 = NULL, # new_CdmsWithreg(),   # data model, object of class "cdms_withreg"
                    ## fields - intermediate calculations
                    have_stock_data = logical(),             # whether data on stock available for current interval
                    ## fields - outputs
                    counts_stock = array(),                  # stock estimates, int array n_particle x n_region x (n_interval+1)
                    counts_internal_in = array(),            # internal mig estimates, int array n_particle x n_region x n_interval
                    counts_internal_out = array(),           # internal mig estimates, int array n_particle x n_region x n_interval
                    counts_immigration1 = array(),           # immigration estimates, int array n_particle x n_region x n_interval
                    counts_emigration1 = array(),            # emigration estimates, int array n_particle x n_region x n_interval
                    counts_immigration2 = array(),           # immigration estimates, int array n_particle x n_region x n_interval
                    counts_emigration2 = array()),           # emigration estimates, int array n_particle x n_region x n_interval
                inherit = PFilter)

    

## initialisation functions ---------------------------------------------------

## These functions are called internally, and are never seen by
## users. We assume inputs have all been checked and are valid.

## Function 'initialize_pfilter' is called by the specific
## initialization methods for PFilterNoReg and PFilterWithReg,
## but, as noted, some of the inputs have different dimensions/classes
initialize_pfilter <- function(df_row,
                               n_particle,
                               n_thin,
                               threshold) {
    ## fields - inputs
    self$cohort <- df_row$cohort[[1L]]
    self$sexgender <- df_row$sexgender[[1L]]
    self$initial_stock_fixed <- df_row$initial_stock_fixed[[1L]]
    self$has_births_to <- df_row$has_births_to[[1L]]
    self$n_interval <- df_row$n_interval[[1L]]          
    self$n_particle <- n_particle                 
    self$n_thin <- n_thin                               
    self$threshold <- threshold
    self$counts_births_of <- df_row$counts_births_of[[1L]]       # noreg = scalar, withreg = vector
    self$counts_births_to <- df_row$counts_births_to[[1L]]       # noreg = vector, withreg = matrix
    self$counts_deaths <- df_row$counts_deaths[[1L]]             # noreg = vector, withreg = matrix
    self$rates_births <- df_row$rates_births[[1L]]               # noreg = vector, withreg = matrix
    self$rates_deaths <- df_row$rates_deaths[[1L]]               # noreg = vector, withreg = matrix
    self$rates_immigration1 <- df_row$rates_immigration1[[1L]]   # noreg = vector, withreg = matrix
    self$rates_emigration1 <- df_row$rates_emigration1[[1L]]     # noreg = vector, withreg = matrix
    self$rates_immigration2 <- df_row$rates_immigration2[[1L]]   # noreg = vector, withreg = matrix
    self$rates_emigration2 <- df_row$rates_emigration2[[1L]]     # noreg = vector, withreg = matrix
    self$cdms_stock <- df_row$cdms_stock[[1L]]                   # noreg = "cdms_noreg", withreg = "cdms_withreg", 
    self$cdms_immigration1 <- df_row$cdms_immigration1[[1L]]     # noreg = "cdms_noreg", withreg = "cdms_withreg", 
    self$cdms_emigration1 <- df_row$cdms_emigration1[[1L]]       # noreg = "cdms_noreg", withreg = "cdms_withreg", 
    self$cdms_immigration2 <- df_row$cdms_immigration2[[1L]]     # noreg = "cdms_noreg", withreg = "cdms_withreg", 
    self$cdms_emigration2 <- df_row$cdms_emigration2[[1L]]       # noreg = "cdms_noreg", withreg = "cdms_withreg", 
    ## fields - intermediate calculations
    n_interval <- self$n_interval
    self$loglik <- matrix(nrow = n_particle, ncol = n_interval + 1L)
    self$logratio <- matrix(nrow = n_particle, ncol = n_interval + 1L) ## ratio of transition prob to importance function
    self$wt <- matrix(nrow = n_particle, ncol = n_interval + 1L)
}

PFilter$set(which = "public",
            name = "initialize",
            value = initialize_pfilter)
            


initialize_pfilter_noreg <- function(df_row,
                                     n_particle,
                                     n_thin,
                                     threshold) {
    super$initialize(df_row = df_row, 
                     n_particle = n_particle,
                     n_thin = n_thin,
                     threshold = threshold)
    ## fields - outputs
    n_interval <- self$n_interval
    self$counts_stock <- matrix(NA_integer_, nrow = n_particle, ncol = n_interval + 1L)
    self$counts_immigration1 <- matrix(NA_integer_, nrow = n_particle, ncol = n_interval)
    self$counts_emigration1 <- matrix(NA_integer_, nrow = n_particle, ncol = n_interval)
    self$counts_immigration2 <- matrix(NA_integer_, nrow = n_particle, ncol = n_interval)
    self$counts_emigration2 <- matrix(NA_integer_, nrow = n_particle, ncol = n_interval)
    if (df_row$is_new_cohort)
        self$counts_stock[, 1L] <- rep(df_row$count_births_of, times = n_particle)
    ## fields - intermediate calculations
    self$have_stock_data <- TRUE
}



PFilterNoReg$set(which = "public",
                 name = "initialize",
                 value = initialize_pfilter_noreg)


initialize_pfilter_withreg <- function(df_row,
                                       n_particle,
                                       n_thin,
                                       threshold) {
    super$initialize(df_row = df_row, 
                     n_particle = n_particle,
                     n_thin = n_thin,
                     threshold = threshold)
    ## fields - inputs
    self$n_region <- nrow(df_row$rates_deaths[[1L]])
    self$rates_internal_in <- df_row$rates_internal_in[[1L]]
    self$rates_internal_out <- df_row$rates_internal_out[[1L]]
    self$cdms_internal_in <- df_row$cdms_internal_in[[1L]]
    self$cdms_internal_out <- df_row$cdms_internal_out[[1L]]
    ## fields - intermediate calculations
    self$have_stock_data <- rep(TRUE, times = n_region)
    ## fields - outputs
    n_region <- self$n_region
    n_interval <- self$n_interval
    self$counts_stock <- array(NA_integer_, dim = c(n_particle, n_region, n_interval + 1L))
    self$counts_internal_in <- array(NA_integer_, dim = c(n_particle, n_region, n_interval))
    self$counts_internal_out <- array(NA_integer_, dim = c(n_particle, n_region, n_interval))
    self$counts_immigration1 <- array(NA_integer_, dim = c(n_particle, n_region, n_interval))
    self$counts_emigration1 <- array(NA_integer_, dim = c(n_particle, n_region, n_interval))
    self$counts_immigration2 <- array(NA_integer_, dim = c(n_particle, n_region, n_interval))
    self$counts_emigration2 <- array(NA_integer_, dim = c(n_particle, n_region, n_interval))
    if (df_row$is_new_cohort)
        self$counts_stock[ , , 1L] <- rep(df_row$count_births_of, each = n_particle)
}


PFilterWithReg$set(which = "public",
                   name = "initialize",
                   value = initialize_pfilter_withreg)