R/account-functions.R

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

## HAS_TESTS
## Convert a data frame holding values for a single type
## of flow from a standard (long) format to an increments format.
## The data frame is assumed to consist of classifying
## variables, a measure variable called "count", and
## optionally an "iteration" variable.
## 'df' - the data frame
## 'nm_df' - the name of the data frame
## 'entry' - whether the flow is a type of entry
to_increments_flow <- function(df, nm_df, entry) {
    ans <- stats::aggregate(df["count"],
                            by = df[setdiff(names(df), c("age", "count"))],
                            FUN = sum)
    if (!entry)
        ans$count <- -1 * ans$count
    names(ans)[match("count", names(ans))] <- nm_df
    ans
}


## HAS_TESTS
## Construct a data frame of increments for flows from
## a demographic account.
## 'account' - a demographic account
## return value - a data frame with a column for each type of flow
to_increments_flows <- function(account) {
    nms_series <- names(account)
    has_one_imem <- "immigration" %in% nms_series
    has_internal <- "internal_in" %in% nms_series
    flows <- list()
    flows <- c(flows,
               list(deaths = to_increments_flow(df = account$deaths,
                                                nm_df = "deaths",
                                                entry = FALSE)))
    if (has_one_imem)
        flows <- c(flows,
                   list(immigration = to_increments_flow(df = account$immigration,
                                                         nm_df = "immigration",
                                                         entry =TRUE),
                        emigration = to_increments_flow(df = account$emigration,
                                                        nm_df = "emigration",
                                                        entry = FALSE)))
    else
        flows <- c(flows,
                   list(immigration1 = to_increments_flow(df = account$immigration1,
                                                          nm_df = "immigration1",
                                                          entry = TRUE),
                        emigration1 = to_increments_flow(df = account$emigration1,
                                                         nm_df = "emigration1",
                                                         entry = FALSE),
                        immigration2 = to_increments_flow(df = account$immigration2,
                                                          nm_df = "immigration2",
                                                          entry = TRUE),
                        emigration2 = to_increments_flow(df = account$emigration2,
                                                         nm_df = "emigration2",
                                                         entry = FALSE)))
    if (has_internal)
        flows <- c(flows,
                   list(internal_in = to_increments_flow(df = account$internal_in,
                                                         nm_df = "internal_in",
                                                         entry = TRUE),
                        internal_out = to_increments_flow(df = account$internal_out,
                                                          nm_df = "internal_out",
                                                          entry = FALSE)))
    ans <- Reduce(f = merge,
                  x = flows)
    nms_flows <- names(flows)
    ans <- sort_classif_cols(ans, ignore = nms_flows)
    ans <- sort_df(ans, ignore = nms_flows)
    ans
}
                                      

## HAS_TESTS
## Construct a data frame of increments for stocks from
## a demographic account, where births count
## as a type of stock (as accession.)
## 'account' - a demographic account
## return value - a data frame with a column called "stock"
to_increments_stock <- function(account) {
    population <- account$population
    births <- account$births
    population$cohort <- population$time - population$age
    population <- population[-match("age", names(population))]
    ## turn births into stock aged -1 at start of period,
    ## classified by characteristics of child, not parent
    births$cohort <- births$time
    births$time <- births$time - 1L
    nms_by <- setdiff(names(births), c("age", "count"))
    births <- stats::aggregate(births["count"],
                               births[nms_by],
                               sum)
    stock <- rbind(population, births)
    stock <- sort_classif_cols(stock, ignore = "count")
    stock <- sort_df(stock, ignore = "count")
    nms_x <- c("time", "count")
    x <- stock[nms_x]
    f <- stock[setdiff(names(stock), nms_x)]
    l <- split(x = x,
               f = f,
               lex.order = TRUE)
    max_time <- max(population$time)
    make_increments <- function(x) {
        time <- x$time
        count <- x$count
        max_time_x <- max(time)
        exceeds_max_age <- max_time_x < max_time
        if (exceeds_max_age) {
            time <- c(time, max_time_x + 1L)
            count <- c(count, 0L) # everyone dies
        }
        time <- time[-1L]
        stock <- diff(count)
        data.frame(time, stock)
    }
    l <- lapply(l, make_increments)
    index <- rep(seq_along(l), times = vapply(l, nrow, 1L))
    f <- unique(f)[index, ]
    x <- do.call(rbind, l)
    ans <- data.frame(f, x)
    rownames(ans) <- NULL
    ans
}


## HAS_TESTS
#' Increments in stocks and flows for a demographic account
#'
#' Create a data frame showing the increments
#' in stocks and flows implied by a demographic account.
#' The increments are arranged by cohort. Births are treated
#' as a type of stock. 
#'
#' The data frame returned by \code{to_increments}
#' includes a column called \code{"discrepancy"}
#' which shows increments calculated from stocks minus
#' increments calculated from flows. When all accounting
#' identities are satisfied, the discrepancy column should
#' consist entirely of zeros.
#'
#' @param account A named list of data frames with the
#' components of the demographic account.
#'
#' @return A data frame.
#'
#' @export
to_increments <- function(account) {
    stock <- to_increments_stock(account)
    flows <- to_increments_flows(account)
    ans <- merge(stock, flows, sort = FALSE)
    nms_flow_series <- setdiff(names(flows), names(stock))
    total_flows <- apply(flows[nms_flow_series], 1L, sum)
    ans$discrepancy <- ans$stock - total_flows
    ans
}