This part takes a census as it was published, looks at it the way Lesson 2.2 taught, and corrects it for the people the census missed. Those are steps A to C of the Population Division’s method protocol. Parts 2 and 3 carry the same population through the remaining steps; each part stands on its own, and you are asked to complete one.

The lab series is the census by single year of age, closed at 75 and over. Single years are what the digit-preference diagnostics need; the open group gives Part 2’s extension real work to do.

Fill in rows A, B and C of the decision log (sheet 03) as you go. The log is half the deliverable: the numbers show what you did, the log says why.

Running it. Put UGA_C2_lab1_data.xlsx in the same folder as this file. Then either run the chunks one at a time in RStudio, or press Knit to produce this report — from the console that is rmarkdown::render("C2_lab1_coverage.Rmd"). Nothing else is needed: the protocol functions travel with the file, in an appendix at the end.

library(readxl)     # reads the workbook
library(dplyr)      # data handling the workflow functions use
library(tibble)     # tibble(), used by one of the protocol functions
library(DemoTools)  # the demographic methods underneath everything
library(knitr)      # kable(), for readable tables

DATA <- "UGA_C2_lab1_data.xlsx"

## Stop early, with directions, if the workbook cannot be opened: a missing
## file, the wrong working directory, or a OneDrive file that has not been
## downloaded to this computer all land here.
if (!isTRUE(tryCatch({ excel_sheets(DATA); TRUE }, error = function(e) FALSE)))
  stop("Cannot open ", DATA, " from ", getwd(),
       ". Put the workbook in the same folder as this file, or give DATA ",
       "its full path. If it sits in OneDrive, right-click the file, choose ",
       "'Always keep on this device', close it in Excel, and try again.")

1 Read the workbook

Three reads, one per block of the workbook. skip says how many rows sit above the column headings, and n_max how many rows of data to take, so the notes at the bottom of a sheet are never read as numbers.

census  <- read_excel(DATA, sheet = "01_census", skip = 7,  n_max = 76)
pes     <- read_excel(DATA, sheet = "02_pes",    skip = 4,  n_max = 1)
pes_age <- read_excel(DATA, sheet = "02_pes",    skip = 11, n_max = 21)

The census details sit in the small block above the table on sheet 01. range reads those cells directly.

details <- read_excel(DATA, sheet = "01_census", range = "A4:B6",
                      col_names = c("field", "value"))
REFDATE <- as.numeric(details$value[details$field == "census_reference_date"])
LOCID   <- as.numeric(details$value[details$field == "LocID"])

2 Step A — the series you were given, and how good it is

Step A of the protocol is the choice of age series, and for this lab it has been made for you: single years of age, closed at 75 and over. Row A of the decision log is where you record that choice and the reason for it, and the diagnostics below are the reason — they are what a single-year series lets you measure and a five-year one does not.

Start with the shape of the count. A growing population shows more people at each younger age, so the line should fall from left to right — and in a single-year series the age heaping is visible to the naked eye as spikes on the ages ending in 0 and 5.

pstart()
sgl <- census[census$AgeStart < max(census$AgeStart), ]   # the open group is not an age
plot(sgl$AgeStart, sgl$Male / 1000, type = "l", lwd = 2, col = BLUE,
     bty = "l", xlab = "Age", ylab = "Thousands per single year of age",
     ylim = c(0, max(sgl$Male, sgl$Female) / 1000))
lines(sgl$AgeStart, sgl$Female / 1000, lwd = 2, col = ORANGE)
abline(v = seq(10, 70, 5), lty = 3, col = "grey85")
legend("topright", c("Males", "Females"), lwd = 2, col = c(BLUE, ORANGE), bty = "n")

The digit-preference indices of Lesson 2.2 put numbers on those spikes. Whipple reads the round ages only; Bachi reads all ten digits and is the measure the smoothing decision in Part 2 uses. The open group is excluded: 75+ is a box, not an age.

whipple <- function(v, a) {
  in_range <- a >= 23 & a <= 62            # 40 ages, 8 of them ending in 0 or 5
  round(100 * sum(v[a %in% seq(25, 60, 5)]) / (sum(v[in_range]) / 5), 1)
}
bachi <- function(v, a)
  round(check_heaping_bachi(v, a, ageMin = 23, ageMax = 74, method = "pasex"), 1)
myers <- function(v, a)
  round(check_heaping_myers(v, a, ageMin = 10, ageMax = 74), 1)

kable(data.frame(
  Index = c("Whipple (ages 23-62)", "Myers blended (ages 10-74)", "Bachi (ages 23-74)"),
  Males   = c(whipple(sgl$Male, sgl$AgeStart),   myers(sgl$Male, sgl$AgeStart),
              bachi(sgl$Male, sgl$AgeStart)),
  Females = c(whipple(sgl$Female, sgl$AgeStart), myers(sgl$Female, sgl$AgeStart),
              bachi(sgl$Female, sgl$AgeStart)),
  check.names = FALSE))
## 
## ageMax lowered to 67 
## 
## ageMax lowered to 67
Index Males Females
Whipple (ages 23-62) 108.5 106.3
Myers blended (ages 10-74) 3.4 2.9
Bachi (ages 23-74) 4.1 3.3

The Whipple window is the standard 23-62, which fits inside a series open at 75 — one reason the lab closes there rather than lower. These are the same values the Lesson 2.2 worked example reports, computed on the same counts. All three indices agree: mild, visible heaping — Bachi in the “approximate” band — of the size the moving average in Part 2 is built to iron out.

Your turn. Fill in row A of the decision log: the series you are working from, and why it was chosen. Then add one or two sentences on what the indices show — which ages people round to, how severe it is, and whether it differs by sex. Name the indices and their bands.

3 Step B — cap the open age group

The protocol requires the open age group to start at a multiple of five and no higher than 100, so that everything downstream lines up. The lab series is topped at 75+, which already satisfies both, so this step changes nothing here — but it is the step that would fix a series topped at 98+ or 102+, and it has a row in the decision log either way.

pop <- census_workflow_oag100_mult5(Age  = census$AgeStart,
                                    popF = census$Female,
                                    popM = census$Male)
cat("open age group:", max(pop$Age), "\n")
## open age group: 75

4 Step C — adjust for coverage

A post-enumeration survey re-counts a sample of households and compares the result with the census. Uganda’s 2024 survey found 95.7 per cent coverage, published as a net coverage error of 4.3 per cent — an undercount. The protocol writes an undercount as a negative number, so the first thing to do is flip the sign.

NCE_total <- -pes$NCE_pct[1]
cat("national net census error:", NCE_total, "per cent\n")
## national net census error: -4.3 per cent

A survey that publishes results by age and sex says more: that the miss was not spread evenly. Those differences go in the optional block of sheet 02, as departures from the national rate in percentage points. Uganda’s 2024 survey published no such breakdown, so the block is empty, and empty means zero difference at every age — the same rate applied to everybody.

NCE_m <- ifelse(is.na(pes_age$NCE_M_diff), 0, pes_age$NCE_M_diff)
NCE_f <- ifelse(is.na(pes_age$NCE_F_diff), 0, pes_age$NCE_F_diff)
cat("age-sex detail supplied:", any(NCE_m != 0 | NCE_f != 0), "\n")
## age-sex detail supplied: FALSE

Now the adjustment itself. Each count is divided by (1 + its own net error ÷ 100), which is what raises the census to the population the survey implies. The function then rescales both sexes together so that the total matches the national rate exactly — a safeguard that matters when the age and sex differences are supplied, and does nothing when they are not.

adj <- census_workflow_adjust_pes(Age  = pop$Age, popF = pop$popF, popM = pop$popM,
                                  census_reference_date = REFDATE,
                                  NCE_total = NCE_total,
                                  NCE_m = NCE_m, NCE_f = NCE_f,
                                  NCE_age = pes_age$AgeStart)
## Warning in popM/(1 + NCEAge_m): longer object length is not a multiple of
## shorter object length
## Warning in popF/(1 + NCEAge_f): longer object length is not a multiple of
## shorter object length

5 What changed

With sixty-one rows, a full table would drown the point; five-year groups summarise what the adjustment did, and the chart below shows it on the single years.

grp <- function(v, a) tapply(v, pmin(a %/% 5 * 5, 75), sum)
kable(data.frame(
  `Age group` = paste0(seq(0, 75, 5), c(rep("-", 15), "+"),
                       c(seq(4, 74, 5), "")),
  Reported = format(round(grp(pop$popM + pop$popF, pop$Age)), big.mark = ","),
  Adjusted = format(round(grp(adj$popM + adj$popF, adj$Age)), big.mark = ","),
  `Added by the adjustment` =
    format(round(grp((adj$popM + adj$popF) - (pop$popM + pop$popF), adj$Age)), big.mark = ","),
  check.names = FALSE, row.names = NULL))
Age group Reported Adjusted Added by the adjustment
0-4 6,778,329 7,082,893 304,564
5-9 6,543,330 6,837,335 294,005
10-14 6,075,943 6,348,948 273,005
15-19 5,328,696 5,568,125 239,429
20-24 4,422,615 4,621,332 198,717
25-29 3,647,553 3,811,445 163,892
30-34 2,897,280 3,027,461 130,181
35-39 2,423,710 2,532,612 108,902
40-44 1,943,971 2,031,318 87,347
45-49 1,465,678 1,531,534 65,856
50-54 1,262,094 1,318,803 56,709
55-59 826,074 863,191 37,117
60-64 757,394 791,425 34,031
65-69 436,397 456,005 19,608
70-74 366,422 382,886 16,464
75+ 729,931 762,728 32,797 
cat("reported total ", format(round(sum(pop$popM  + pop$popF)),  big.mark = ","), "\n")
## reported total  45,905,417
cat("adjusted total ", format(round(sum(adj$popM  + adj$popF)),  big.mark = ","), "\n")
## adjusted total  47,968,043
pstart()
keep <- adj$Age < max(adj$Age)
plot(adj$Age[keep], (adj$popM + adj$popF)[keep] / 1000, type = "l", lwd = 2, col = BLUE,
     bty = "l", xlab = "Age", ylab = "Thousands per single year of age",
     ylim = c(0, max((adj$popM + adj$popF)[keep]) / 1000))
lines(pop$Age[keep], (pop$popM + pop$popF)[keep] / 1000, lwd = 2, col = GREY)
legend("topright", c("Coverage-adjusted", "Reported"), lwd = 2,
       col = c(BLUE, GREY), bty = "n")

Because the same rate was applied at every age, the two lines have exactly the same shape; only the level has moved. That is worth stating plainly in the decision log, because it means the age pattern of the census — the heaping, and any shortfall among young children — is still there, untouched. Part 2 addresses the heaping and Part 3 the children.

Your turn. Before reading the totals above, work out what the adjusted total should be from the reported total and the coverage rate alone. Then check. If your country’s survey did publish results by age and sex, type them into the optional block on sheet 02 and run this part again: the two lines will no longer be parallel.

dir.create("out1", showWarnings = FALSE)
write.csv(data.frame(Age = adj$Age, Male = adj$popM, Female = adj$popF),
          "out1/part1_adjusted_single_year.csv", row.names = FALSE)

6 Where this part ends

The population is now at the level the post-enumeration survey implies: single years of age, still heaped, still topped at 75+. Part 2 extends that open group and smooths the heaping; Part 3 rebuilds the young children and dates the result. Both start from a workbook that already contains the table this part just produced, so they can be done in any order — or on their own.

7 Bring your own census

Copy the provided input file, clear the green cells, and enter your own values with their sources and reference dates.

Expect that to take much longer than the lab does, and to happen outside the session. Many offices may find that some of the inputs are not published for their country, and finding out which ones is worth as much as the run itself. Record each one in the decision log.

8 Appendix — the protocol functions this part uses

These are the Population Division’s own censusAdjust files.Underneath they call DemoTools; what they add is the protocol’s decision rules.

## ==== census_workflow_oag100_mult5.R ========================
# Ensure that the open age group is less than or equal to 100 and is a multiple of five

census_workflow_oag100_mult5 <- function(Age, popF, popM) {

  Age <- Age
  popM <- popM
  popF <- popF
  maxage <- max(Age)
  
  
  # collapse open age over 100 to 100+  
  if (maxage > 100) {
    popM   <- c(popM[Age < 100], sum(popM[Age >= 100]))
    popF   <- c(popF[Age < 100], sum(popF[Age >= 100]))
    Age    <- c(Age[Age<100], 100) 
    maxage <- 100
    nAge   <- length(Age)
  }

  # If the open age group is larger than OpenAge5, then truncate back
  OpenAge5 <- as.integer(maxage / 5) * 5
  if (maxage > OpenAge5) {
    popM   <- c(popM[Age < OpenAge5], sum(popM[Age >= OpenAge5]))
    popF   <- c(popF[Age < OpenAge5], sum(popF[Age >= OpenAge5]))
    Age    <- c(Age[Age < OpenAge5], OpenAge5)
    maxage <- OpenAge5
    nAge   <- length(Age)
  }
  
  outdata <- data.frame(Age = Age,
                        popF = popF,
                        popM = popM)
  
  return(outdata)

}

## ==== census_workflow_adjust_pes.R ==========================
## census_workflow_adjust_pes
## 
## Adjust census populations per post-enumeration survey or user-defined adjustment factors
## as described in protocol flowchart xx
## 
## @param popM numeric. vector of male population counts
## @param popF numeric. vector of female population counts
## @return A data frame with adjusted population counts by age
## @export

census_workflow_adjust_pes <- function(Age,
                                       popF,
                                       popM,
                                       census_reference_date,
                                       NCE_total = NULL, # overall adjustment factor
                                       NCE_m = NULL, # age-specific adjustment relative to total for males
                                       NCE_f = NULL, # age-specific adjustment relative to total for females
                                       NCE_age = NULL) { # ages associated with age-specific adjustments

    # detect age structure of input data
    sgl <- DemoTools::is_single(Age)
    abr <- DemoTools::is_abridged(Age)

    # if only five year values, then collapse the adjustment for the first age group
    if (!sgl & !abr) {
      NCE_m <- c(0.2 * NCE_m[1] + 0.8 * NCE_m[2], NCE_m[3:length(NCE_m)])
      NCE_f <- c(0.2 * NCE_f[1] + 0.8 * NCE_f[2], NCE_f[3:length(NCE_f)])
      NCE_age <- c(0, seq(5, max(NCE_age), 5))
    }

    maxage <- max(Age)

    # truncate sex-age specific nce diff to the ages of the available population data
    NCE_m   <- c(NCE_m[NCE_age < maxage], mean(NCE_m[NCE_age >= maxage]))
    NCE_f   <- c(NCE_f[NCE_age < maxage], mean(NCE_f[NCE_age >= maxage]))

    # PES adjustment

      # compute age- and sex-specific adjustment factors
      NCEAge_m <- NCE_total/100 + NCE_m/100
      NCEAge_f <- NCE_total/100 + NCE_f/100

      # adjust population
      pop_m_adj <- popM  / (1 + NCEAge_m)
      pop_f_adj <- popF  / (1 + NCEAge_f)

      # totals
      TotBSpopAdj <- sum(pop_m_adj + pop_f_adj)
      TotBStargetPop <- sum(popM + popF) / (1 + NCE_total/100)
      Adj2factor <- TotBStargetPop / TotBSpopAdj

      # adjust again per second adjustment factor
      pop_m_adj <- pop_m_adj * Adj2factor
      pop_f_adj <- pop_f_adj * Adj2factor

      out.data <- data.frame(Age = Age,
                             popF = pop_f_adj,
                             popM = pop_m_adj)

      return(out.data)

}