diff --git a/.RData b/.RData index 9488d7f18..c18bcffd3 100644 Binary files a/.RData and b/.RData differ diff --git a/.Rbuildignore b/.Rbuildignore index f24c34683..38a2c484d 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -27,3 +27,4 @@ Spreadsheets ^tic\.R$ rcppExports.cpp stanExports_* +^data-raw$ \ No newline at end of file diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 2194984ce..ff26be5c5 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -55,14 +55,16 @@ jobs: uses: actions/cache@v2 with: path: ${{ env.R_LIBS_USER }} - key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- + # For the later part of v1, this serves to invalidate the cache whenever is needed. + # See https://stackoverflow.com/questions/63521430/clear-cache-in-github-actions + key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }}-v1 + restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-v1 # To install rgl in macOS it needs xquartz - name: macOS dependencies if: runner.os == 'macOS' run: | - brew cask install xquartz + brew install xquartz # Adds manual deps to rgl in first line - name: Linux dependencies @@ -86,6 +88,7 @@ jobs: run: | remotes::install_deps(dependencies = TRUE) remotes::install_cran("rcmdcheck") + install.packages("rgl") shell: Rscript {0} # Why a separate check for macOS/Linux? Because rgl needs to export DISPLAY diff --git a/.gitignore b/.gitignore index b8df4b66b..e14e8b1da 100644 --- a/.gitignore +++ b/.gitignore @@ -21,3 +21,5 @@ Spreadsheets *.so docs/ .gitsum +.RData + diff --git a/DESCRIPTION b/DESCRIPTION index 7586fba62..331e09950 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: DemoTools Type: Package Title: Standardize, Evaluate, and Adjust Demographic Data -Version: 01.11.03 -Date: 2021-01-12 +Version: 01.13.55 +Date: 2021-05-31 Authors@R: c( person("Tim", "Riffe", role = c("aut", "cre"), email = "tim.riffe@gmail.com", comment = c(ORCID = "0000-0002-2673-4622")), @@ -12,6 +12,7 @@ Authors@R: c( person("Marius D.", "Pascariu", role = "aut", comment = c(ORCID = "0000-0002-2568-6489")), person("Sara", "Hertog", role = "aut"), person("Sean", "Fennell", role = "aut"), + person("Peter", "Johnson", role = "ctb"), person("Jorge", "Cimentada", role = "ctb", comment = c(ORCID = "0000-0001-5594-1156")), person("Juan", "Galeano", role = "ctb", comment = c(ORCID = "0000-0002-3682-1797")), person("Derek", "Burk", role = "ctb"), @@ -24,35 +25,34 @@ Roxygen: list(markdown = TRUE) RoxygenNote: 7.1.1 Depends: R (>= 3.6), - Rcpp (>= 0.12.0) + Rcpp (>= 0.12.0), Suggests: covr, testthat (>= 2.1.0), knitr, rmarkdown, + markdown, DT, ggplot2 RdMacros: Rdpack Imports: + data.table (>= 1.13.6), demogR, + DemoToolsData (>= 0.1.1), dplyr, + fertestr (>= 0.0.5), + lubridate, magrittr, - methods, MortalityLaws (>= 1.7.0), - RcppParallel (>= 5.0.1), Rdpack, rlang, rstan (>= 2.18.1), tibble, tidybayes, - ungroup, - lubridate, - fertestr, - DemoToolsData + ungroup BugReports: https://github.com/timriffe/DemoTools/issues Remotes: - https://github.com/josehcms/fertestr, - https://github.com/mpascariu/ungroup, - https://github.com/timriffe/DemoToolsData + github::josehcms/fertestr, + github::timriffe/DemoToolsData Encoding: UTF-8 VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index 5975afed5..cbc1bafd5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -23,7 +23,6 @@ export(basepop_five) export(birthCohorts) export(calcAgeAbr) export(calcAgeN) -export(census_cohort_adjust) export(check_heaping_bachi) export(check_heaping_coale_li) export(check_heaping_jdanov) @@ -35,8 +34,10 @@ export(check_heaping_sawtooth) export(check_heaping_spoorenberg) export(check_heaping_whipple) export(dec.date) +export(downloadAsfr) export(downloadSRB) export(downloadnLx) +export(fetch_wpp_births) export(getModelLifeTable) export(graduate) export(graduate_beers) @@ -57,7 +58,12 @@ export(inferAgeIntAbr) export(int2age) export(int2ageN) export(interp) -export(interp_coh_bare) +export(interp_coh) +export(interp_lc_lim) +export(interp_lc_lim_abk_m) +export(interp_lc_lim_estimate) +export(interp_lc_lim_group) +export(interp_lc_lim_kt_min) export(interpolatePop) export(is_abridged) export(is_age_coherent) @@ -69,9 +75,14 @@ export(lt_a_closeout) export(lt_a_pas) export(lt_a_un) export(lt_abridged) +export(lt_abridged2single) +export(lt_ambiguous) export(lt_id_L_T) export(lt_id_Ll_S) +export(lt_id_d_l) +export(lt_id_d_q) export(lt_id_l_d) +export(lt_id_l_q) export(lt_id_lda_L) export(lt_id_ma_q) export(lt_id_morq_a) @@ -92,15 +103,19 @@ export(lt_rule_m_extrapolate) export(lt_single2abridged) export(lt_single_mx) export(lt_single_qx) +export(lt_smooth_ambiguous) export(lthat.logquad) export(ma) export(mav) export(maxA2abridged) +export(mig_beta) export(mig_calculate_rc) export(mig_estimate_rc) +export(mig_resid) export(mig_resid_cohort) export(mig_resid_stock) export(mig_resid_time) +export(mig_un_fam) export(names2age) export(poly_smth1) export(ratx) @@ -109,6 +124,7 @@ export(rescale_vector) export(rlog) export(sexRatioScore) export(shift.vector) +export(shift_census_ages_to_cohorts) export(simplify.text) export(single2abridged) export(smooth_age_5) @@ -135,17 +151,29 @@ import(Rdpack) import(demogR) importFrom(MortalityLaws,MortalityLaw) importFrom(Rdpack,reprompt) +importFrom(data.table,":=") +importFrom(data.table,as.data.table) +importFrom(data.table,between) +importFrom(data.table,data.table) +importFrom(data.table,dcast) +importFrom(data.table,melt) +importFrom(data.table,rbindlist) +importFrom(data.table,setDT) +importFrom(data.table,uniqueN) importFrom(demogR,cdmltw) importFrom(dplyr,group_by) importFrom(dplyr,mutate) importFrom(dplyr,rename) importFrom(dplyr,summarise) +importFrom(fertestr,get_location_code) +importFrom(fertestr,is_LocID) importFrom(magrittr,"%>%") -importFrom(rlang,.data) importFrom(rlang,sym) importFrom(rstan,extract) importFrom(rstan,stan) +importFrom(stats,aggregate) importFrom(stats,approx) +importFrom(stats,as.formula) importFrom(stats,coef) importFrom(stats,filter) importFrom(stats,lm) @@ -155,6 +183,8 @@ importFrom(stats,optim) importFrom(stats,optimize) importFrom(stats,predict) importFrom(stats,quantile) +importFrom(stats,reshape) +importFrom(stats,setNames) importFrom(stats,splinefun) importFrom(stats,uniroot) importFrom(tibble,as.tibble) diff --git a/R/AGEINT.R b/R/AGEINT.R index fa5357424..e875e4b16 100644 --- a/R/AGEINT.R +++ b/R/AGEINT.R @@ -89,6 +89,7 @@ interpolatePop <- #' @param datesOut vector of dates. The desired dates to interpolate to. See details for ways to express it. #' @param method string. The method to use for the interpolation, either \code{"linear"}, \code{"exponential"}, or \code{"power"}. Default \code{"linear"}. #' @param power numeric power to interpolate by, if \code{method = "power"}. Default 2. +#' @param extrap logical. In case \code{datesOut} is out of range of datesIn, do extrapolation using slope in extreme pairwise. Deafult \code{FALSE}. #' @param ... arguments passed to \code{stats::approx}. For example, \code{rule}, which controls extrapolation behavior. #' @details The age group structure of the output is the same as that of the input. Ideally, \code{datesOut} should be within the range of \code{datesIn}. If not, the left-side and right-side output are held constant outside the range if \code{rule = 2} is passed in, otherwise \code{NA} is returned (see examples). Dates can be given in three ways 1) a \code{Date} class object, 2) an unambiguous character string in the format \code{"YYYY-MM-DD"}, or 3) as a decimal date consisting in the year plus the fraction of the year passed as of the given date. #' @@ -196,30 +197,51 @@ interp <- function(popmat, datesOut, method = c("linear", "exponential", "power"), power = 2, + extrap = FALSE, ...) { # ... args passed to stats::approx . Can give control over extrap assumptions + # IW: extrap=T for extrapolate following each slope in extreme pairwise. + # If not is explicit extrap=T, returns NA at those points + # a basic check stopifnot(ncol(popmat) == length(datesIn)) # no sense documenting this wrapper ... - .approxwrap <- function(x, y, xout, ...) { - stats::approx(x = x, - y = y, - xout = xout, - ...)$y + .approxwrap <- function(x, y, xout, extrap, ...) { + + # interp + yout = stats::approx(x = x, + y = y, + xout = xout, + ...)$y + + if (extrap){ + # extrap (each side) + rg <- range(x) + xext <- xout < rg[1] + if(any(xext)) + yout[xext] <- (y[2]-y[1])/(x[2]-x[1])*(xout[xext]-x[1])+y[1] + xext <- xout > rg[2] + n <- length(y) + if(any(xext)) + yout[xext] <- (y[n]-y[n-1])/(x[n]-x[n-1])*(xout[xext]-x[n-1])+y[n-1] + } + + return(yout) } + # ----------------------- # clean method declaration # match.arg does partial matching and it's safer: # match.arg("lin", c("linear", "exponential", "power")) - method <- tolower(match.arg(method)) + method <- tolower(match.arg(method, + choices = c("linear", "exponential", "power"))) # ----------------------- # coerce dates to decimal if necessary - datesIn <- sapply(datesIn, dec.date) - datesOut <- sapply(datesOut, dec.date) - + datesIn <- dec.date(datesIn) + datesOut <- dec.date(datesOut) # carry out transform 1 if (method == "exponential") { @@ -241,6 +263,7 @@ interp <- function(popmat, .approxwrap, x = datesIn, xout = datesOut, + extrap = extrap, ...) dims <- dim(int) if (!is.null(dims)) { @@ -259,5 +282,11 @@ interp <- function(popmat, int <- int ^ power } + # IW: no negatives when extrapolate. Thinking in pop and lt expressions + if(all(!is.na(int)) & any(int<0)){ + cat("Negative values were turned 0. No accepted in population counts, fertility rates or life table functions.\n") + int[int<0] <- 0 + } + int } diff --git a/R/MAV.R b/R/MAV.R index f57291a54..659dfca6f 100644 --- a/R/MAV.R +++ b/R/MAV.R @@ -1,22 +1,22 @@ -# Author: JG -# Edited 9-Dec-2017 by TR -# Edited Aug 2018 by TR - -############################################################################### #' Calculate the moving average (mav) over 3 or 5 years. #' @description This arithmetic smoothing technique aims to eliminate irregularities of the population pyramid by averaging values in a moving window of user-defined width. -#' @details The moving window is applied symmetrically. Data endpoints are imputed with \code{NA}s in output: the is nothing under 0 or over the highest closed age group to average with. The open age group is imputed with \code{NA} prior to calculations, since it cannot be averaged into the next lowest group. For example, for \code{n=3}, age 0 will be \code{NA}, as will the open age group and next lowest age. Age intervals are assumed uniform. This function could be used with either single or 5-year age groups. +#' @details +#' The moving window is applied symmetrically. By default (`tails = FALSE`) data endpoints are imputed with `NA`s in output: the is nothing under 0 or over the highest closed age group to average with. The open age group is not used in averaging, and it is returned as-is. Age intervals are assumed uniform. This function could be used with either single or 5-year age groups. +#' +#' If `tails` is set to `TRUE`, then tails have been imputed using moving averages with successively smaller values of `n`, the cascade method. #' @param Value numeric. A vector of demographic counts in single age groups. #' @param n integer. A single number, (often 3 or 5), indicating the number of years taken to smooth the population distribution by single ages. #' @param Age integer. A vector of ages corresponding to the lower integer bound of the counts. -#' @param OAG logical. Whether or not the top age group is open. Default \code{TRUE}. -#' @details Ages may be single or grouped, but all age intervals are assumed equal. +#' @param OAG logical. Whether or not the top age group is open. Default `TRUE`. +#' @param tails logical. If set to `TRUE`, smaller-n moving averages are applied on both tails +#' such that all values are non-NA. If `FALSE` (default), tails are set to NA +#' due to the lag of moving averages. #' @return Vector with the smoothed demographic counts. +#' #' @export -#' @author Juan Galeano #' @references #' \insertRef{GDA1981IREDA}{DemoTools} @@ -31,9 +31,16 @@ #' 323263,9535,13906,9063,8294,90459,9817,6376,8884,3773,160609) #'Age <- 0:70 #'# final age group assumed open -#'mav(Pop, n = 3, Age = Age) +#' mav(Pop, n = 3, Age = Age) +#' #'\dontrun{ -#' nwindows <- sapply(seq(3, 11, by = 2),mav, Value = Pop, Age = Age) +#' odds <- seq(3, 11, by = 2) +#' nwindows <- sapply(odds, +#' mav, +#' Value = Pop, +#' Age = Age, +#' OAG = TRUE, +#' tails = FALSE) #' cols <- gray(seq(.8, 0, length = 5)) #' lwds <- seq(3, 1, length = 5) #' plot(Age,Pop, col = "red", xlab = "Age", ylab = "The counts", pch=16, @@ -45,21 +52,92 @@ #' lwd = lwds, #' legend = paste0("n=",seq(3,11,by=2))) #'} +#' +#' # For cascading smoothing on the tails: +#' mav(Pop, Age, tails = TRUE) +#' +#'\dontrun{ +#'# Compare +#' nwindows_tails <- sapply(odds, +#' mav, +#' Value = Pop, +#' Age = Age, +#' OAG = TRUE, +#' tails = TRUE) +#' +#' colnames(nwindows) <- odds +#' colnamaes(nwindows_tails) <- odds +#' +#' # NA triangles are completed with +#' # successively smaller ns. +#' head(nwindows) +#' head(nwindows_tails) +#' +#' tail(nwindows) +#' tail(nwindows_tails) +#' } -mav <- function(Value, Age, n = 3, OAG = TRUE) { +mav <- function(Value, Age, n = 3, OAG = TRUE, tails = FALSE) { In <- Value if (missing(Age)) { Age <- as.integer(names(Value)) } + + # save OAG if (OAG) { + OrigOAGpop <- Value[length(Value)] Value[length(Value)] <- NA } - # TR: not sure why n needs to be hard coded + Out <- ma(Value, n) + # apply cascading tails if needed + if (tails){ + Out <- mav_tails(Value = Value, + Age = Age, + MavOut = Out, + n = n, + OAG = OAG) + } + # plug OAG back in + if (OAG){ + Out[length(Value)] <- OrigOAGpop + } + structure(Out, names = Age) } +# Not exported since it can be called with tails = FALSE on mav. +mav_tails <- function(Value, Age, MavOut, n = 3, OAG = TRUE) { + NewMavOut <- MavOut + + #Last should point to last age group to use + Last <- length(Age) + if (OAG) { + Last <- Last - 1 + NewMavOut[Last+1] <- Value[Last+1] + } + + NewMavOut[1] <- Value[1] + NewMavOut[Last] <- Value[Last] + + MavLev <- c(1,2,4,6,8) + + if (n >= 2) { + for(i in 2:(as.integer(n/2))) { + + # TR: why not just calculate the whole thing and once and pick out + # the two values as needed? + NewMavOut[i] <- ma(Value[1:(MavLev[i]+1)], n = MavLev[i])[i] + # subscripts right and select just the correct age + NewMavOut[Last - i + 1] <- ma(Value[(Last - MavLev[i] ):Last], + n = MavLev[i])[ i ] + + } + } + + NewMavOut +} #Pop <-c(303583,390782,523903,458546,517996,400630,485606,325423,471481,189710, diff --git a/R/OPAG.R b/R/OPAG.R index 63ed8efc0..f1768e33b 100644 --- a/R/OPAG.R +++ b/R/OPAG.R @@ -2,19 +2,26 @@ # [ ] All choice of Age_fit / AgeInt_fit based on criteria (see PJ Drive folder) # [ ] ensure age groups are flexible as required. # [ ] what happens when one input is in a different age group than another? -# [ ] OPAG_simple() should allow for non-single ages +# [x] OPAG_simple() should allow for non-single ages # [ ] add unit tests # [ ] check for age group commensurability and warn if necessary # [ ] add more examples to OPAG? -# [ ] remove rownames message from DownloadLx(), haha +# [ ] remove rownames message from DownloadLx(), haha I DON'T SEE THIS # [ ] test OPAG_simple() with non-single ages groups, update documentation if necessary. # [ ] harmonize args betwenn OPAG_simple and OPAG family. +# [x] make AgeInt not required +# [ ] document Age_fit better +# [x] change open age formula in warp function +# [x] fix continuous = FALSE formula/ then removed +# [x] ensure Lx is single ages once for use throughout +# [x] change default method to "mono" + # Author: tim ############################################################################### # distribute population in open age group over higher ages. # The PAS implementation uses stable populations, and it will be added -# here in the future, as well as other optiond. The main missing piece +# here in the future, as well as other options. The main missing piece # is a good collection of model lifetables. #' redistripute an open age group count over higher ages proportional to an arbitrary standard @@ -72,7 +79,7 @@ OPAG_simple <- StPop, StAge, OAnew = max(StAge)) { - # # assume single + # # assume single NOT NEEDED See age concordance # stopifnot(is_single(Age)) # stopifnot(is_single(StAge)) # OAG can be less than or equal to max age @@ -80,13 +87,15 @@ OPAG_simple <- stopifnot(OAnew %in% StAge) # age and pop vectors must match lengths, assume ordered stopifnot(length(Pop) == length(Age)) + stopifnot(length(StPop) == length(StAge)) # age concordance - #stopifnot(all(Age %in% StAge)) + minStAge = min(StAge) + stopifnot(all(Age[Age >= minStAge] %in% StAge)) # group pop down to OAG Pop <- groupOAG(Pop, Age, OAnow) StPop <- groupOAG(StPop, StAge, OAnew) - + # even up lengths N <- length(Pop) Age <- Age[1:N] @@ -94,19 +103,19 @@ OPAG_simple <- # same for standard StN <- length(StPop) StAge <- StAge[1:StN] - - # make stadnard distribution. + + # make standard distribution. standard <- rescale_vector(StPop[StAge >= OAnow], scale = 1) # redistribute OAG PopUpper <- OAtot * standard # keep lower ages of Pop PopLower <- Pop[1:(N - 1)] - + # graft, name, and return out <- c(PopLower, PopUpper) Ageout <- sort(unique(c(Age, StAge))) names(out) <- Ageout - + out } @@ -114,15 +123,13 @@ OPAG_simple <- #' Warps a given stationary population into a stable population #' @description We take `nLx` as indicative of a stationary population age structure, #' then subject the population structure to long-term growth by a constant rate, `r`. -#' @details `nLx` could be any population structure of any scale, as long as you're comfortable +#' @details `Lx1` could be any population structure of any scale, as long as you're comfortable #' assuming it's stationary and can be warped into stable. For the oldest ages, this is probably #' quite often an acceptable and useful approximation. The transformation is applied at the single-age scale, even if the input `nLx` is in wider (e.g. abridged) age groups. When needed, we reduce to single ages using (default) `graduate_uniform()`, then apply the transformation, then group back. This is innocuous if `nLx` is given in single ages. You may want to change `method` to `"mono"` or `"pclm"`. #' -#' @param nLx numeric vector of stationary population age structure in arbitrary integer age groups -#' @param Age interger vector of lower bounds of age groups of `nLx` +#' @param Lx1 numeric vector of stationary population age structure in arbitrary integer age groups +#' @param Age_Lx1 interger vector of lower bounds of age groups of `nLx` #' @param r stable growth rate -#' @param AgeInt optional integer vector of widths of age groups, inferred if not given. -#' @param continuous logical. If `TRUE` we use the growth adjustment. `e^(-age*r)`. If `FALSE` we assume `r` is geometric growth, and we use `(1+r)^age` for the growth adjustment. #' @param method character, graduation method used for intermediate graduation. Default `"uniform"`. Other reasonable choices include `"mono"` or `"pclm"`. #' @return numeric vector of the transformed `nLx`. Note, this vector sums to `1`. #' @export @@ -138,47 +145,40 @@ OPAG_simple <- #' } #' -OPAG_nLx_warp_r <- function(nLx, - Age, - r, - AgeInt = NULL, - continuous = TRUE, - method = "uniform"){ - # Let's do this in single ages :-) - # for now, just uniform, but could pass in args to graduate of course - # if that is preferred. - Lx1 <- graduate(nLx, Age, method = method, constrain = TRUE) - a1 <- names2age(Lx1) - if (continuous){ - wLx <- exp(-r * (a1 + .5)) * Lx1 +OPAG_nLx_warp_r <- function(Lx1, + Age_Lx1, + r +){ + a1 <- Age_Lx1 + w1Lx <- exp(-r * (a1 + .5)) * Lx1 + # still need to fix open-ended age group value ********* + nAges <- length(Age_Lx1) + + if (r == 0 ) { + w1Lx[nAges] <- Lx1[nAges] } else { - # then geometric - w <- (1 + r) ^ (a1 + .5) - wLx <- w * nLx - } - wLx <- wLx / sum(wLx) - if (is.null(AgeInt)){ - AgeInt <- age2int(Age, OAvalue = 1) + Tlast <- Lx1[nAges] + Tprev <- Tlast + Lx1[nAges-1] + abar <- -((log(Lx1[nAges-1])-r*a1[nAges-1])-log(Tprev*exp(r)-Tlast)) / r + w1Lx[nAges] <- exp(-r * abar) * Tlast } - a12A <- rep(Age, AgeInt) - nwLx <- groupAges(wLx, Age = a1, AgeN = a12A) - nwLx + + w1Lx <- w1Lx / sum(w1Lx) + + w1Lx } #' calculates residual for optimizing growth rate r for OPAG family #' @description For a given set of age groups to fit against, and a given stable growth rate, $r$, #' what is the error implied given the current $r$ and stationary standard? -#' @details This is a utiltiy function for `OPAG()`, which needs to optimize $r$ for a +#' @details This is a utility function for `OPAG()`, which needs to optimize $r$ for a #' given population vector and stationary standard. #' @param r given stable growth rate #' @param Pop_fit numeric vector of at least two population counts to use for fitting #' @param Age_fit integer vector of lower bounds for age groups of `Pop_fit` #' @param AgeInt_fit integer vector of widths of age groups of `Pop_fit` -#' @param nLx numeric vector of stable population standard -#' @param Age_nLx integer vector of lower bounds for age groups of `nLx` -#' @param AgeInt_nLx optional integer vector of widths of age groups of `nLx`, inferred if not given. -#' @param continuous logical. If `TRUE` we use the growth adjustment. `e^(-age*r)`. If `FALSE` we assume `r` is geometric growth, and we use `(1+r)^age` for the growth adjustment. -#' @param method character. Graduation method, default `"uniform"`. `"mono"` or `"pclm"` would also be good choices. +#' @param Lx1 numeric vector of stable population standard by single ages +#' @param Age_Lx1 integer vector of lower bounds for age groups of `Lx1` #' @return numeric. A residual that you're presumably trying to minimize. #' @export @@ -218,65 +218,47 @@ OPAG_nLx_warp_r <- function(nLx, #' } OPAG_r_min <- function(r, - Pop_fit, Age_fit, + Pop_fit, AgeInt_fit, # necessary - nLx, - Age_nLx, - AgeInt_nLx = NULL, - continuous = TRUE, - method = "uniform"){ - if (is.null(AgeInt_nLx)){ - AgeInt_nLx <- age2int(Age_nLx, OAvalue = 1) - } + Lx1, + Age_Lx1 +){ + AgeInt_nLx <- age2int(Age_Lx1, OAvalue = 1) + # This is the standard we want to match to Pop, # which has presumably been cut down / grouped to the # ages we want to calibrate to. - wnLx <- OPAG_nLx_warp_r( - nLx = nLx, - Age = Age_nLx, - r = r, - AgeInt = AgeInt_nLx, - continuous = continuous) - + w1Lx <- OPAG_nLx_warp_r( + Lx1 = Lx1, + Age_Lx1 = Age_Lx1, + r = r + ) + # now need to get it to the same age groups as Pop # so that we can get a residual - - # 1) Move stable pop to single ages - w1Lx <- graduate( - wnLx, - Age = Age_nLx, - AgeInt = AgeInt_nLx, - method = method) - a1t <- names2age(w1Lx) - a1t <- as.integer(a1t) - - # 2) which single ages implied by Pop? - N <- length(AgeInt_fit) - a1match <- Age_fit[1]:(max(Age_fit) + AgeInt_fit[N] - 1) - a1match <- as.integer(a1match) - - # 3) select down to just those ages: - ind <- a1t %in% a1match - w1Lx <- w1Lx[ind] - - # 4) group w1Lx to same as Pop_fit - ageN <- rep(Age_fit, times = AgeInt_fit) - stand <- groupAges(w1Lx, Age = a1match, AgeN = ageN) - - # 5) rescale standard and Pop_fit to sum to 1 - stand <- rescale_vector(stand, scale = 1) + + w1Lx_fit <- rep(NA, length(Age_fit)) + + for (i in 1:length(Age_fit)){ + ind <- Age_Lx1 >= Age_fit[i] & Age_Lx1 < (Age_fit[i] + AgeInt_fit[i]) + w1Lx_fit[i] <- sum(w1Lx[ind]) + } + + # 5) rescale standard and Pop_fit to sum to 1 + stand <- rescale_vector(w1Lx_fit, scale = 1) Pop_fit <- rescale_vector(Pop_fit, scale = 1) - + # 6) return the residual sum(abs(stand - Pop_fit)) } #' creates stable standard based on optimizing the growth rate -#' @description The stationary standard, `nLx` is transformed into a stable standard by optimizing a growth rate, `r` such that the stable standard matches observed population counts in selected age groups. Usually the ages used for fitting are wide age groups in older ages preceding the open age group. The standard output by this function is used by `OPAG` to creat the standard used to redistribute counts over older age groups up to a specified open age group, such as 100. -#' @details The arguments `method` and `continous` don't have much leverage on the result. In short, the stable population transformation is done by ungrouping `nLx` to single ages (if it isn't already), and `method` controls which graduation method is used for this, where `"uniform"`, `"mono"`, `"pclm"` are the reasonable choices at this writing. In single ages, the difference between using a geometric `r` versus continuous `r` are quite small for this task. -#' +#' @description The stationary standard, `nLx` is transformed into a stable standard by optimizing a growth rate, `r` such that the stable standard matches observed population counts in selected age groups. Usually the ages used for fitting are wide age groups in older ages preceding the open age group. The standard output by this function is used by `OPAG` to create the standard used to redistribute counts over older age groups up to a specified open age group, such as 100. +#' @details The argument `method` don't have much leverage on the result. In short, the stable population transformation is done by ungrouping `nLx` to single ages (if it isn't already), and `method` controls which graduation method is used for this, where `"uniform"`, `"mono"`, `"pclm"` are the reasonable choices at this writing. +#' +#' #' @inheritParams OPAG_r_min #' @return #' list constaining @@ -289,7 +271,6 @@ OPAG_r_min <- function(r, #' @examples #' Pop_fit <- c(85000,37000) #' Age_fit <- c(70,80) -#' AgeInt_fit <- c(10,10) #' nLx <- downloadnLx(NULL, "Spain","female",1971) #' Age_nLx <- names2age(nLx) #' @@ -299,11 +280,11 @@ OPAG_r_min <- function(r, #' method = "Arriaga") #' Pop80 <- groupOAG(Pop, names2age(Pop), 80) #' Age <- names2age(Pop80) -#' AgeInt <- age2int(Age, OAvalue = 1) #' #' nLx <- downloadnLx(NULL, "India","male",1971) #' Age_nLx <- names2age(nLx) -#' AgeInt_nLx <- age2int(Age_nLx,OAvalue = 1) + +# graduate to get Lx1 #' #' Pop_fit <- groupAges(Pop80, Age, N = 10)[c("60","70")] #' Age_fit <- c(60,70) @@ -313,11 +294,9 @@ OPAG_r_min <- function(r, #' Pop_fit, #' Age_fit, #' AgeInt_fit, -#' nLx = nLx, -#' Age_nLx = Age_nLx, -#' AgeInt_nLx = AgeInt_nLx, -#' method = "uniform", -#' continuous = TRUE) +#' Lx1=Lx1, +#' Age_Lx1 = Age_Lx1 +#' ) #' #' # A visual comparison: #' nL60 <- rescale_vector(nLx[Age_nLx >= 60]) @@ -331,29 +310,25 @@ OPAG_r_min <- function(r, OPAG_fit_stable_standard <- function(Pop_fit, Age_fit, AgeInt_fit, - nLx, - Age_nLx, - AgeInt_nLx, - method = "uniform", - continuous = TRUE){ - - + Lx1, + Age_Lx1 +){ + + # optimize the parameter r r_opt <- optimize(OPAG_r_min, Pop_fit = Pop_fit, Age_fit = Age_fit, AgeInt_fit = AgeInt_fit, - nLx = nLx, - Age_nLx = Age_nLx, - interval = c(-0.05, .05)) - - - standard <- OPAG_nLx_warp_r(nLx = nLx, - Age = Age_nLx, - r = r_opt$min, - AgeInt = AgeInt_nLx, - continuous = continuous, - method = method) + Lx1 = Lx1, + Age_Lx1 = Age_Lx1, + interval = c(-0.02, .05)) # changed interval + + + standard <- OPAG_nLx_warp_r(Lx1 = Lx1, + Age_Lx1 = Age_Lx1, + r = r_opt$min + ) # return both stable standard and the optimization output, # which will let us know if r is simply unreasonable or similar. out <- list(Standard = standard, @@ -373,12 +348,6 @@ OPAG_fit_stable_standard <- function(Pop_fit, #' @details It may be helpful to try more than one fitting possibility, #' and more than one `Redistribute_from` cut point, as results may vary. #' -#' The argument `"method"` refers to which graduation method (see `?graduate`) -#' is only relevant if input data are in grouped ages. This is innocuous if -#' ages are single to begin with. The choice of whether to assume -#' `continuous = TRUE` constant growth versus geometric (`FALSE`) growth -#' has little leverage. -#' #' `Redistribute_from` can be lower than your current open age group, #' and `OAnew` can be higher, as long as it is within the range of `Age_nLx`. #' If `Age_nLx` doesn't go high enough for your needs, you can extrapolate @@ -427,29 +396,58 @@ OPAG_fit_stable_standard <- function(Pop_fit, #'} OPAG <- function(Pop, - Age_Pop, - AgeInt_Pop, - nLx, - Age_nLx, - AgeInt_nLx = NULL, - Age_fit = NULL, - AgeInt_fit = NULL, - Redistribute_from = max(Age_Pop), - OAnew = max(Age_nLx), - method = "uniform", - continuous = TRUE){ - + Age_Pop, + nLx, + Age_nLx, + Age_fit = NULL, + AgeInt_fit = NULL, + Redistribute_from = max(Age_Pop), + OAnew = max(Age_nLx), + method = "mono" +){ + + # ensure OAnew is possible + stopifnot(OAnew <= max(Age_nLx)) + + # TB: if OAnew < min(Age_nLx) that's an error + + method <- match.arg(method, choices = c("uniform","pclm","mono")) + + #TB: checking if pop and nLx have different intervals and warning users - still working on it + if(!identical(as.integer(unique(diff(Age_Pop))), as.integer(unique(diff(Age_nLx))))){ # put a different + cat("\nAge_Pop and Age_nLx age intervals are different!\n") + } + + AgeInt_Pop <- diff(Age_Pop) + AgeInt_nLx <- diff(Age_Pop) + # setup, prelims: # 0) if Age_fit isn't given assume last two 10-year age groups. + if (is.null(Age_fit)){ OA <- max(Age_Pop) Age_fit <- OA - c(20,10) AgeInt_fit <- c(10,10) stopifnot(Age_fit %in% Age_Pop) } - + if (is.null(AgeInt_fit)){ + # assume age intervals are age differences, and repeat last one + AgeInt_fit <- diff(Age_fit) + AgeInt_fit <- c(AgeInt_fit, tail(AgeInt_fit, n=1)) + # if Age_fit includes pop OA then set last fit age int to Inf + if (tail(Age_fit,1) == tail(Age_Pop,1)) { + AgeInt_fit[length(AgeInt_fit)] <- Inf + } + } + if (any(!Age_fit %in% Age_Pop)){ + ind <- Age_fit %in% Age_Pop + Age_fit <- Age_fit[ind] + AgeInt_fit <- AgeInt_fit[ind] + stopifnot(length(Age_fit) > 1) + } + # 1) get Pop_fit - + # TR: note: this calls for a special age utility function I think # earmarking this code chunk to swap it out in the future. Pop_fit <- rep(NA, length(Age_fit)) @@ -457,47 +455,54 @@ OPAG <- function(Pop, ind <- Age_Pop >= Age_fit[i] & Age_Pop < (Age_fit[i] + AgeInt_fit[i]) Pop_fit[i] <- sum(Pop[ind]) } - - # 2) get the standard + + # 2) make sure Lx is single ages + Lx1 <- graduate(nLx, Age_nLx, method = method, constrain = TRUE) + Age_Lx1 <- as.integer(names(Lx1)) + Stab_stand <- OPAG_fit_stable_standard(Pop_fit, Age_fit, AgeInt_fit, - nLx, - Age_nLx, - AgeInt_nLx, - method = method, - continuous = continuous) + Lx1, + Age_Lx1 + ) StPop <- Stab_stand$Standard - + # 3) get total to redistribute: OAG_total <- sum(Pop[Age_Pop >= Redistribute_from]) - + # 4) select standard in those age groups. - StPop_sel <- StPop[Age_nLx >= Redistribute_from] + StPop_sel <- StPop[Age_Lx1 >= Redistribute_from] StPop_sel <- rescale_vector(StPop_sel, scale = 1) - + # 5) redistribute Pop_redistributed <- StPop_sel * OAG_total - + + # 5a) regroup into original pop age grouping + if (tail(AgeInt_Pop, n=2)[-1] == 5) { + Pop_redistributed <- groupAges(Pop_redistributed, N = 5) + } + # 6) graft together Pop_grafted <- c(Pop[Age_Pop < Redistribute_from], Pop_redistributed) Age_grafted <- c(Age_Pop[Age_Pop < Redistribute_from], Age_nLx[Age_nLx >= Redistribute_from]) - + + names(Pop_grafted) <- Age_grafted # 7) potentially group down OAG Pop_out <- groupOAG(Value = Pop_grafted, Age = Age_grafted, OAnew = OAnew) Age_out <- names2age(Pop_out) - + # 8) compose list for output out <- list( - Pop_out = Pop_out, - Age_out = Age_out, - Pop_in = Pop, - Standard = StPop, - r_opt = Stab_stand$r_opt) - + Pop_out = Pop_out, + Age_out = Age_out, + Pop_in = Pop, + Standard = StPop, + r_opt = Stab_stand$r_opt) + out } diff --git a/R/basepop.R b/R/basepop.R index 664cf2c2e..46d1e27fd 100644 --- a/R/basepop.R +++ b/R/basepop.R @@ -11,7 +11,7 @@ #' adjust using the BPE method. #' #' For \code{basepop_five}, adjusting the female population counts is the -#' default. For this, only the \code{country}, \code{refDate} and +#' default. For this, only the \code{location}, \code{refDate} and #' \code{Females_five} are needed. All other arguments are downloaded #' or set to sensible defaults. For adjusting the male population #' counts, the user needs to specify the \code{Males_five} population @@ -144,17 +144,19 @@ #' * `Bt` births at three time points prior to census corrsponding to the midpoints of the cohorts entering ages 0, 1-4, and 5-9. #' * `SRB` sex ratio at birth at three time points prior to census corrsponding to the midpoints of the cohorts entering ages 0, 1-4, and 5-9. Potentially downloaded. #' * `Age` age groups of the input population counts. -#' +#' # #' `basepop_single` is used, the return value is a numeric vector with # #' **single year age groups** where the counts between 0 and 10 are adjusted. #' -#' @param country The country name or location code from which to download the n -#' Lx and asfr data. See `fertestr::locs_avail()` for all country -#' names/codes. -#' +#' @param location UN Pop Division `LocName` or `LocID` #' @param refDate The reference year for which the reported population pertain #' (these are the population counts in `Females_five` and -#' \code{Males_five}). Can either be a decimal date, a `Date` class +#' \code{Males_five}). Can either be a decimal date, a `Date` class. +#' If \code{nLxDatesIn} or \code{AsfrDatesIn} are not supplied and the +#' corresponding \code{nLxFemale/Male}/\code{AsfrMat} is not supplied, +#' \code{refDate} must be at a minimum 1962.5. This is because we can only +#' fetch WPP data from 1955 onwards, and these minimum date is assumed to be +#' 7.5 years before \code{refDate}, meaning 1955. #' #' @param Age integer vector of lower bounds of abridged age groups given in `Females_five` and `Males_five`. #' @@ -168,7 +170,7 @@ #' 7.5 years before the reference date of the "reported" population. The later #' date should be no earlier than one-half year before the reference date of #' the "reported" population. If not provided, it's automatically downloaded if -#' `country`, `refDate` and the equivalent population counts +#' `location`, `refDate` and the equivalent population counts #' `*_five` are provided. #' #' @param nLxDatesIn A vector of numeric years (for example, 1986). The dates @@ -204,7 +206,13 @@ #' automatically downloaded for the dates in `nLxDatesIn`. #' #' @param SRB A numeric. Sex ratio at birth (males / females). Default is set -#' to 1.05 +#' to 1.046. Only a maximum of three values permitted. +#' +#' @param SRBDatesIn A vector of numeric years (for example, 1986). Only a maximum +#' number of three dates allowed. These are +#' the dates which pertain to the values in `SRB`. If not provided, +#' the function automatically determines three dates which are 7.5 years, +#' 2.5 and 0.5 years before `refDate`. #' #' @param radix starting point to use in the adjustment of the three first age #' groups. Default is NULL. If not provided, it is inferred based on the scale of age `1L0`. @@ -224,23 +232,23 @@ #' #' # Grab population counts for females #' refDate <- 1986 -#' country <- "Brazil" -#' pop_female_single <- fertestr::FetchPopWpp2019(country, -#' refDate, -#' ages = 0:100, +#' location <- "Brazil" +#' pop_female_single <- fertestr::FetchPopWpp2019(location, +#' refDate, +#' ages = 0:100, #' sex = "female") -#' pop_female_counts <- single2abridged(setNames(pop_female_single$pop, +#' pop_female_counts <- single2abridged(setNames(pop_female_single$pop, #' pop_female_single$ages)) -#' pop_male_single <- fertestr::FetchPopWpp2019(country, -#' refDate, -#' ages = 0:100, +#' pop_male_single <- fertestr::FetchPopWpp2019(location, +#' refDate, +#' ages = 0:100, #' sex = "male") -#' pop_male_counts <- single2abridged(setNames(pop_male_single$pop, +#' pop_male_counts <- single2abridged(setNames(pop_male_single$pop, #' pop_male_single$ages)) #' Age <- names2age(pop_male_counts) #' # Automatically downloads the nLx, ASFR, and SRB data #' bpe <- basepop_five( -#' country = country, +#' location = location, #' refDate = refDate, #' Females_five = pop_female_counts, #' Males_five = pop_male_counts, @@ -259,14 +267,14 @@ #' # blocked out for now, until single age function refactored as #' # TR: actually, it just needs to be rethought for single ages.. #' # pop_female_single <- setNames(pop_female_single$pop, pop_female_single$ages) -#' # +#' # #' # # Automatically downloads the nLx and ASFR data #' # bpe_female <- basepop_single( -#' # country = country, +#' # location = location, #' # refDate = refDate, #' # Females_single = pop_female_single #' # ) -#' # +#' # #' # # The counts for the first 10 age groups have been adjusted: #' # bpe_female[1:10] #' # pop_female_single[1:10] @@ -289,7 +297,7 @@ #' #' # Automatically downloads the nLx, ASFR, and SRB data #' bpa <- basepop_five( -#' country = country, +#' location = location, #' refDate = refDate, #' Females_five = smoothed_females, #' Males_five = smoothed_males, @@ -313,9 +321,9 @@ #' # (2) Reported population by 5-year age groups and sex in the base year #' # (Include unknowns). #' -#' pop_male_counts <- c(11684, 46738, 55639, 37514, 29398, 27187, 27770, 20920, 16973, +#' pop_male_counts <- c(11684, 46738, 55639, 37514, 29398, 27187, 27770, 20920, 16973, #' 14999, 11330, 10415, 6164, 7330, 3882, 3882, 1840, 4200) -#' +#' #' pop_female_counts <- c(11673, 46693, 55812, 35268, 33672, 31352, 33038, 24029, 16120, #' 14679, 8831, 9289, 4172, 6174, 2715, 3344, 1455, 4143) #' Age <- c(0,1, seq(5, 80, by = 5)) @@ -330,9 +338,9 @@ #' nLxMale <- matrix(c(87732, 304435, 361064, 88451, 310605, 370362), #' nrow = 3, ncol = 2) #' -#' nLxFemale <- matrix(c(89842, 314521, 372681, 353053, 340650, 326588, +#' nLxFemale <- matrix(c(89842, 314521, 372681, 353053, 340650, 326588, #' 311481, 295396, 278646, 261260, 241395,217419, -#' 90478, 320755, 382531, 364776, 353538, 340687, +#' 90478, 320755, 382531, 364776, 353538, 340687, #' 326701, 311573, 295501, 278494, 258748,234587), #' nrow = 12, #' ncol = 2) @@ -341,10 +349,10 @@ #' # date #' #' asfrmat <- structure( -#' c(0.2, 0.3, 0.3, 0.25, 0.2, 0.15, 0.05, 0.15, 0.2, -#' 0.275, 0.225, 0.175, 0.125, 0.05), .Dim = c(7L, 2L), +#' c(0.2, 0.3, 0.3, 0.25, 0.2, 0.15, 0.05, 0.15, 0.2, +#' 0.275, 0.225, 0.175, 0.125, 0.05), .Dim = c(7L, 2L), #' .Dimnames = list( -#' c("15-19", "20-24", "25-29", "30-34", "35-39", "40-44", "45-49"), +#' c("15-19", "20-24", "25-29", "30-34", "35-39", "40-44", "45-49"), #' c("1977.81", "1985.71"))) #' #' # for BPA, smooth counts in advance @@ -409,31 +417,31 @@ #' #' pop_female_counts[1:3] #' bpe$Females_adjusted[1:3] -#' +#' #' # basepop_single for single ages #' # Single ages for males and females #' #' # pop_male_counts <- -#' # c(11684, 11473, 11647, 11939, 11680, 10600, 11100, 11157, 11238, -#' # 11544, 7216, 7407, 7461, 7656, 7774, 5709, 5629, 5745, 6056, -#' # 6259, 5303, 5423, 5497, 5547, 5417, 5441, 5466, 5500, 5668, 5694, -#' # 4365, 4252, 4122, 4142, 4039, 3210, 3222, 3258, 3413, 3871, 2684, -#' # 2844, 3052, 3182, 3237, 2263, 2298, 2318, 2257, 2194, 2231, 2172, -#' # 2072, 2008, 1932, 1301, 1262, 1213, 1197, 1191, 1601, 1593, 1490, -#' # 1348, 1299, 568, 745, 843, 801, 925, 806, 883, 796, 725, 672, +#' # c(11684, 11473, 11647, 11939, 11680, 10600, 11100, 11157, 11238, +#' # 11544, 7216, 7407, 7461, 7656, 7774, 5709, 5629, 5745, 6056, +#' # 6259, 5303, 5423, 5497, 5547, 5417, 5441, 5466, 5500, 5668, 5694, +#' # 4365, 4252, 4122, 4142, 4039, 3210, 3222, 3258, 3413, 3871, 2684, +#' # 2844, 3052, 3182, 3237, 2263, 2298, 2318, 2257, 2194, 2231, 2172, +#' # 2072, 2008, 1932, 1301, 1262, 1213, 1197, 1191, 1601, 1593, 1490, +#' # 1348, 1299, 568, 745, 843, 801, 925, 806, 883, 796, 725, 672, #' # 470, 441, 340, 300, 289, 4200) -#' # +#' # #' # pop_female_counts <- -#' # c(11673, 11474, 11670, 11934, 11614, 10603, 11144, 11179, 11269, -#' # 11617, 6772, 6948, 7030, 7211, 7306, 6531, 6443, 6535, 6951, -#' # 7213, 6096, 6234, 6327, 6410, 6285, 6464, 6492, 6549, 6739, 6795, -#' # 5013, 4888, 4735, 4747, 4646, 3040, 3068, 3107, 3246, 3658, 2650, -#' # 2788, 2977, 3108, 3156, 1756, 1784, 1802, 1764, 1724, 1982, 1935, -#' # 1846, 1795, 1731, 863, 850, 825, 819, 816, 1348, 1342, 1246, -#' # 1138, 1101, 391, 520, 585, 560, 659, 670, 750, 686, 634, 604, +#' # c(11673, 11474, 11670, 11934, 11614, 10603, 11144, 11179, 11269, +#' # 11617, 6772, 6948, 7030, 7211, 7306, 6531, 6443, 6535, 6951, +#' # 7213, 6096, 6234, 6327, 6410, 6285, 6464, 6492, 6549, 6739, 6795, +#' # 5013, 4888, 4735, 4747, 4646, 3040, 3068, 3107, 3246, 3658, 2650, +#' # 2788, 2977, 3108, 3156, 1756, 1784, 1802, 1764, 1724, 1982, 1935, +#' # 1846, 1795, 1731, 863, 850, 825, 819, 816, 1348, 1342, 1246, +#' # 1138, 1101, 391, 520, 585, 560, 659, 670, 750, 686, 634, 604, #' # 353, 340, 270, 246, 247, 4143) #' # Age <- 0:80 -#' # +#' # #' # smoothed_females <- smooth_age_5(Value = pop_female_counts, #' # Age = Age, #' # method = "Arriaga", @@ -447,7 +455,7 @@ #' #' # For adjusting using BPA for males, we need to specify #' # female = FALSE with Males and nLxMale. -#' +#' #' # This needs work still #' # bpa_male <- #' # basepop_single( @@ -481,7 +489,7 @@ #' #' # pop_female_counts[1:10] #' # bpa_female[1:10] -#' # +#' # #' # # For adjustment using BPE, we use exactly the same definitions as above #' # # but remove SmoothedFemales. #' # bpe_male <- @@ -514,7 +522,7 @@ #' # AsfrMat = asfrmat, #' # AsfrDatesIn = AsfrDatesIn #' # ) -#' # +#' # #' # pop_female_counts[1:10] #' # bpa_female[1:10] #' # bpe_female[1:10] @@ -525,7 +533,7 @@ #' \insertRef{arriaga1994population}{DemoTools} #' \insertRef{PAS}{DemoTools} #' -basepop_five <- function(country = NULL, +basepop_five <- function(location = NULL, refDate, Age = NULL, Females_five, @@ -537,6 +545,7 @@ basepop_five <- function(country = NULL, AsfrDatesIn = NULL, ..., SRB = NULL, + SRBDatesIn = NULL, radix = NULL, verbose = TRUE) { @@ -546,9 +555,10 @@ basepop_five <- function(country = NULL, # Ensure census date is numeric. # "YYYY-MM-DD" input is acceptable refDate <- dec.date(refDate) - + if (!is.null(Age)){ stopifnot(is_abridged(Age)) + stopifnot(length(Age) == length(Females_five)) } else { if (!is.null(names(Females_five))){ Age <- names2age(Females_five) @@ -560,40 +570,47 @@ basepop_five <- function(country = NULL, Age <- inferAgeIntAbr(Females_five) } } - + if (is.null(nLxDatesIn)) { - nLxDatesIn <- c(abs(8 - refDate), refDate + 0.5) + # re PJ issue #183 suggested default + nLxDatesIn <- refDate - c(0.5, 7.5) + #nLxDatesIn <- c(abs(8 - refDate), refDate + 0.5) if (verbose) { cat(paste0("Assuming the two prior dates for the nLx matrix to be: ", paste0(nLxDatesIn, collapse = ", ")), sep = "\n") } } if (is.null(AsfrDatesIn)) { - AsfrDatesIn <- abs(c(8, 0.5) - refDate) + # re PJ issue #183 suggested default + AsfrDatesIn <- refDate - c(0.5, 7.5) + #AsfrDatesIn <- abs(c(8, 0.5) - refDate) if (verbose) { cat(paste0("Assuming the two prior dates for the Asfr matrix to be: ", paste0(AsfrDatesIn, collapse = ", ")), sep = "\n") } } + # ensure vectors named, for purposes of selection + names(Females_five) <- Age + names(Males_five) <- Age ## obtain nLx for males and females ## If these arguments have been specified, they return ## the same thing and don't download the data nLxFemale <- downloadnLx( nLx = nLxFemale, - country = country, + location = location, gender = "female", nLxDatesIn = nLxDatesIn ) - + nLxMale <- downloadnLx( nLx = nLxMale, - country = country, + location = location, gender = "male", nLxDatesIn = nLxDatesIn ) - + if (is.null(radix)) { # TR: not perfect, but it's a better guess. It would seem the radix # being pulled before was always 1, whereas the nLx columns was based on 100000 @@ -602,33 +619,32 @@ basepop_five <- function(country = NULL, cat(paste0("Setting radix to value of lx: ", radix, ". Can be overwritten with the `radix` argument"), sep = "\n") } } - + AsfrMat <- downloadAsfr( Asfrmat = AsfrMat, - country = country, + location = location, AsfrDatesIn = AsfrDatesIn ) - # get a vector of 3 SRB estimates matching the DatesOut dates. - # if SRB was given as a vector of length 3 then we take it as-is - # if only one value was given (or a vector of length not equal to 3), - # we repeat it 3 times and take the first 3 elements. - # if it's NULL and we have the country in the DB then we look it up. - # if it's NULL and we don't have the country then we assume 1.05, - # because tradition. - - # TR saw no need for sapply() - # DatesOut <- sapply(c(0.5, 2.5, 7.5), function(x) refDate - x) + DatesOut <- refDate - c(0.5, 2.5, 7.5) - - SRB <- downloadSRB(SRB, - country, - DatesOut) - + SRBDatesIn <- if (!is.null(SRBDatesIn)) SRBDatesIn else DatesOut + + SRB <- downloadSRB(SRB, + location, + DatesOut = SRBDatesIn, + verbose = verbose) + ## Check all arguments AllArgs <- as.list(environment()) ArgsCheck(AllArgs) + lower_bound <- abs(min(nLxDatesIn) - min(DatesOut)) + upper_bound <- abs(max(nLxDatesIn) - max(DatesOut)) + + if (lower_bound > 5 || upper_bound > 5) { + stop("nLxDatesIn implies an extrapolation of > 5 years to achieve the needed reference dates") + } # Interpolate the gender specific nLx to the requested # dates out @@ -638,6 +654,7 @@ basepop_five <- function(country = NULL, datesOut = DatesOut, ... ) + nLxm <- interp( nLxMale, datesIn = nLxDatesIn, @@ -645,6 +662,13 @@ basepop_five <- function(country = NULL, ... ) + lower_bound <- abs(min(AsfrDatesIn) - min(DatesOut)) + upper_bound <- abs(max(AsfrDatesIn) - max(DatesOut)) + + if (lower_bound > 5 || upper_bound > 5) { + stop("AsfrDatesIn implies an extrapolation of > 5 years to achieve the needed reference dates") + } + # Interpolate the asfr to the requested dates. # This is gender agnostic. Asfr <- interp( @@ -663,21 +687,21 @@ basepop_five <- function(country = NULL, ages_15_45 <- ages_15_55[-c(8,9)] ages_20_45 <- ages_15_55[-c(1,8,9)] ages_15_40 <- ages_15_55[-c(7,8,9)] - + FMiddleages <- Females_five[ages_15_55] - Ft_minus_5 <- FMiddleages[ages_20_55] * + Ft_minus_5 <- FMiddleages[ages_20_55] * nLxf[ages_15_50, 2] / nLxf[ages_20_55, 2] names(Ft_minus_5) <- ages_15_50 - - Ft_minus_10 <- Ft_minus_5[ages_20_50] * + + Ft_minus_10 <- Ft_minus_5[ages_20_50] * nLxf[ages_15_45, 3] / nLxf[ages_20_50, 3] names(Ft_minus_10) <- ages_15_45 - + # Now we take some averages to get to midpoints Ft_minus_.5 <- FMiddleages[ages_15_45] * .9 + Ft_minus_5[ages_15_45] * .1 Ft_minus_2.5 <- FMiddleages[ages_15_45] * .5 + Ft_minus_5[ages_15_45] * .5 Ft_minus_7.5 <- Ft_minus_5[ages_15_45] * .5 + Ft_minus_10[ages_15_45] * .5 - + # 3 column matrix of sort-of-exposures for ages 15-45, matched to ASFR fExpos <- cbind(Ft_minus_.5, Ft_minus_2.5, Ft_minus_7.5) @@ -689,32 +713,32 @@ basepop_five <- function(country = NULL, Males_five_out <- Males_five Females_five_out <- Females_five ## Currently, this assumes that there can only be 3 dates. - + ## We only have 3 age groups to adjust and 3 dates PF <- 1 / (SRB + 1) - + # Age 0 Females_five_out[1] <- Bt[1] * PF[1] * nLxf[1, 1] / radix - Males_five_out[1] <- Bt[1] * (1 - PF[1]) * nLxm[1, 1] / radix - + Males_five_out[1] <- Bt[1] * (1 - PF[1]) * nLxm[1, 1] / radix + # Age 1-4 - Females_five_out[2] <- Bt[2] * PF[2] * 5 * - sum(nLxf[1:2, 2]) / (radix * 5) - - Females_five_out[1] - - Males_five_out[2] <- Bt[2] * (1 - PF[2]) * 5 * - sum(nLxm[1:2, 2]) / (radix * 5) - + Females_five_out[2] <- Bt[2] * PF[2] * 5 * + sum(nLxf[1:2, 2]) / (radix * 5) - + Females_five_out[1] + + Males_five_out[2] <- Bt[2] * (1 - PF[2]) * 5 * + sum(nLxm[1:2, 2]) / (radix * 5) - Males_five_out[1] - + # Age 5-9 - Females_five_out[3] <- Bt[3] * PF[3] * 5 * + Females_five_out[3] <- Bt[3] * PF[3] * 5 * sum(nLxf[1:2,3]) / (radix * 5) * nLxf[3,2] / sum(nLxf[1:2,2]) - - Males_five_out[3] <- Bt[3] * (1 - PF[3]) * 5 * + + Males_five_out[3] <- Bt[3] * (1 - PF[3]) * 5 * sum(nLxm[1:2,3]) / (radix * 5) * nLxm[3,2] / sum(nLxm[1:2,2]) - + # return the important things list( Females_adjusted = Females_five_out, @@ -739,7 +763,7 @@ basepop_five <- function(country = NULL, # #' # #' @export # #' -# basepop_single <- function(country = NULL, +# basepop_single <- function(location = NULL, # refDate, # Females_single, # nLxFemale = NULL, @@ -754,31 +778,31 @@ basepop_five <- function(country = NULL, # SRB = 1.05, # radix = NULL, # verbose = TRUE) { -# +# # stopifnot( # !is.null(names(Females_single)), # is_single(as.numeric(names(Females_single))) # ) -# +# # Females_abridged <- single2abridged(Females_single) # males_present <- !is.null(Males_single) -# +# # if (males_present) { # stopifnot( # !is.null(names(Males_single)), # is_single(as.numeric(names(Males_single))) # ) -# +# # Males_abridged <- single2abridged(Males_single) # gender_single <- Males_single # } else { # Males_abridged <- Males_single # gender_single <- Females_single # } -# +# # res <- # basepop_five( -# country = country, +# location = location, # refDate = refDate, # Females_five = Females_abridged, # nLxFemale = nLxFemale, @@ -793,12 +817,12 @@ basepop_five <- function(country = NULL, # SRB = SRB, # radix = radix # ) -# +# # # Since diff always returns a vector of length `length(x) - 1`, # # the 1 in the end is to reflct the the open ages for 80+ or 100+ # AgeBins1 <- c(diff(as.integer(names(gender_single))), 1) # AgeBins2 <- c(diff(as.integer(names(res))), 1) -# +# # rescaled_res <- # rescaleAgeGroups( # Value1 = gender_single, @@ -807,7 +831,7 @@ basepop_five <- function(country = NULL, # AgeInt2 = AgeBins2, # splitfun = graduate_uniform # ) -# +# # round(rescaled_res, 3) # } @@ -827,7 +851,7 @@ ArgsCheck <- function(ArgList) { ncol(nLxFemale) == length(nLxDatesIn), ncol(nLxMale) == length(nLxDatesIn) # TR no check on ASFRmat dates? - )}) + )}) } @@ -836,10 +860,10 @@ lt_infer_radix_from_1L0 <- function(L0){ if (L0 > 1){ radix_check <- L0 %>% as.integer() %>% log10() is_it_a_radix <- (radix_check - round(radix_check)) == 0 - + if (!is_it_a_radix){ pow <- L0 %>% round() %>% as.integer() %>% nchar() - + the_radix <- 10^pow } else { the_radix <- L0 @@ -849,135 +873,3 @@ lt_infer_radix_from_1L0 <- function(L0){ } the_radix } - -#' Extract Lx estimates from WPP2019 -#' @description We use the `FetchLifeTableWpp2019` function of the `fertestr` to extract `Lx` from `wpp2019`, interpolated to an exact date. -#' @param nLx either `NULL` or a numeric vector of lifetable exposure. If it's the second then we just pass it back. -#' @param country character country name available UN Pop Div `LocName` set -#' @param gender `"male"`, `"female"`, or `"both"` -#' @param nLxDatesIn numeric vector of three decimal dates produced by (or passed through) `basepop_ive()` -#' -#' @return numeric matrix of `nLx` with `length(nLxDatesIn)` and abrdiged ages in rows. -#' @export -#' -#' @importFrom rlang .data -downloadnLx <- function(nLx, country, gender, nLxDatesIn) { - requireNamespace("fertestr", quietly = TRUE) - requireNamespace("magrittr", quietly = TRUE) - requireNamespace("dplyr", quietly = TRUE) - verbose <- getOption("basepop_verbose", TRUE) - if (!is.null(nLx)) { - # TR: ensure colnames passed - nLx <- as.matrix(nLx) - colnames(nLx) <- nLxDatesIn - n <- nrow(nLx) - Age <- c(0,1,seq(5,(n-2)*5,by=5)) - rownames(nLx) <- Age - return(nLx) - } - - if (is.null(nLx)){ - - if (is.null(country)) stop("You need to provide a country to download the data for nLx") - - if (verbose) { - cat(paste0("Downloading nLx data for ", country, ", years ", paste(nLxDatesIn,collapse=", "), ", gender ", gender), sep = "\n") - } - nLx <- - lapply(nLxDatesIn, function(x) { - fertestr::FetchLifeTableWpp2019(country, x, gender)$Lx - }) %>% dplyr::bind_cols() %>% as.matrix() - - colnames(nLx) <- nLxDatesIn - n <- nrow(nLx) - Age <- c(0,1,seq(5,(n-2)*5,by=5)) - rownames(nLx) <- Age - return(nLx) - } -} - -downloadAsfr <- function(Asfrmat, country, AsfrDatesIn) { - requireNamespace("fertestr", quietly = TRUE) - verbose <- getOption("basepop_verbose", TRUE) - - if (!is.null(Asfrmat)) { - # TR: can we assume colnames are AsfrDatesIn ? - return(Asfrmat) - } - - if (is.null(country)) stop("You need to provide a country to download the data for Asfrmat") - - tmp <- - lapply(AsfrDatesIn, function(x) { - - if (verbose) { - cat(paste0("Downloading Asfr data for ", country, ", year ", x), sep = "\n") - } - - res <- fertestr::FetchFertilityWpp2019(country, x)["asfr"] - names(res) <- NULL - as.matrix(res)[2:nrow(res), , drop = FALSE] - }) - - Asfrmat <- do.call(cbind, tmp) - colnames(Asfrmat) <- AsfrDatesIn - Asfrmat -} - -#' Extract SRB estimates from WPP2019 -#' @description We use the `WPP2019_births` dataset from `DemoToolsData` for the sex ratio at birth. Births from WPP 2019 were graduates to single year totals. -#' @param SRB sex ratio at birth. Either `NULL`, a scalar to assume constant, or a vector of length 3, assumed. -#' @param country character country name available UN Pop Div `LocName` set -#' @param DatesOut numeric vector of three decimal dates produced by `basepop_ive()` -#' -#' @return numeric vector with three SRB estimates -#' @export -#' -#' @importFrom rlang .data - -downloadSRB <- function(SRB, country, DatesOut){ - requireNamespace("dplyr", quietly = TRUE) - requireNamespace("DemoToolsData", quietly = TRUE) - requireNamespace("rlang", quietly = TRUE) # for .data - verbose <- getOption("basepop_verbose", TRUE) - - WPP2019_births <- DemoToolsData::WPP2019_births - # If not given and we have the country, then we use it - if (is.null(SRB) & !is.null(country)){ - if (country %in% WPP2019_births$LocName){ - # TODO: really this should take a weighted average of SRB - # over the period represented by each cetral date? - - SRB <- WPP2019_births %>% - dplyr::filter(.data$LocName == country, - .data$Year %in% floor(DatesOut)) %>% - dplyr::pull(SRB) - } else { - if (verbose){ - cat(paste(country,"not available in WPP LocName list\n")) - } - } - # otherwise will need to assume - } - - # if still not given then assume something - if (is.null(SRB)){ - SRB <- rep(1.05,3) - if (verbose){ - cat(paste(country,"not available in WPP LocName list\n")) - } - } - - # if given but not with 3 elements then repeat and cut as necessary - if (is.numeric(SRB) & length(SRB) != 3){ - SRB <- rep(SRB, 3)[1:3] - } - names(SRB) <- DatesOut - # return, potentially the same as input - SRB -} - - - - - diff --git a/R/check_heaping.R b/R/check_heaping.R index 8b470a79e..5fa8949d1 100644 --- a/R/check_heaping.R +++ b/R/check_heaping.R @@ -203,9 +203,10 @@ check_heaping_myers <- function(Value, #' @param ageMax the maximum age used for estimation, default `77` #' @param method either `"orig"` or `"pasex"` #' @param details logical. Should a list of output be given +#' @param OAG logical. Is the highest age group open? #' #' @details `ageMax` is an inclusive upper bound, treated as interval. If you want ages -#' 23 to 77, then give `ageMin = 23` and `ageMax = 77`, not 80. The `ageMin` is respected strictly, whereas `ageMax` could be higher than the actual maximum age used. You can see the age ranges actually used by specifying `details = TRUE`. +#' 23 to 77, then give `ageMin = 23` and `ageMax = 77`. The `ageMin` is respected strictly, whereas `ageMax` is calculated flexibly- if you specify something too high then it is reduced and we warn accordingly, and if it's missing then we pick something reasonable. You can see the age ranges actually used by specifying `details = TRUE`. #' @return The value of the index. #' @references #' \insertRef{PAS}{DemoTools} @@ -213,26 +214,57 @@ check_heaping_myers <- function(Value, #' \insertRef{shryock1973methods}{DemoTools} #' @export #' @examples -#' Age <- 0:99 -#' check_heaping_bachi(pop1m_pasex, Age, ageMin = 23, ageMax = 77, method = "orig") -#' check_heaping_bachi(pop1m_ind, Age, ageMin = 23, ageMax = 77, method = "orig") +#' check_heaping_bachi(pop1m_pasex, Age = 0:99, +#' ageMin = 23, ageMax = 77, method = "orig", OAG =FALSE) +#' check_heaping_bachi(pop1m_ind, Age = 0:100, +#' ageMin = 23, ageMax = 77, method = "orig") #' # default simpler -#' check_heaping_bachi(pop1m_pasex, Age, ageMin = 23, ageMax = 77, method = "pasex") +#' check_heaping_bachi(pop1m_pasex, Age = 0:99, +#' ageMin = 23, ageMax = 77, method = "pasex", OAG = FALSE) #' # linear population, should give 0 for pasex -#' check_heaping_bachi(seq(100000,1000,by=-1000),Age, ageMin = 23, ageMax = 77, method = "pasex") +#' check_heaping_bachi(seq(100000,1000,by=-1000),Age = 0:99, +#' ageMin = 23, ageMax = 77, method = "pasex", OAG = FALSE) #' # fully concentrated, should give 90 #' pop_concetrated <- rep(c(100,rep(0,9)),10) -#' check_heaping_bachi(pop_concetrated,Age, ageMin = 23, ageMax = 77, method = "pasex") -#' check_heaping_bachi(pop_concetrated,Age, ageMin = 23, ageMax = 77, method = "orig") +#' check_heaping_bachi(pop_concetrated, Age = 0:99, +#' ageMin = 23, ageMax = 77, method = "pasex") +#' check_heaping_bachi(pop_concetrated, Age = 0:99, +#' ageMin = 23, ageMax = 77, method = "orig") check_heaping_bachi <- function( Value, Age, ageMin = 23, - ageMax = 77, + ageMax = NULL, method = "orig", - details = FALSE + details = FALSE, + OAG = TRUE ){ method <- match.arg(method, c("orig","pasex")) + stopifnot(length(Age) == length(Value)) + + if (OAG){ + N <- length(Value) + Value <- Value[-N] + Age <- Age[-N] + } + + # ensure ageMax in range + ageMaxin <- ageMax + maxA <- max(Age) + + if (is.null(ageMaxin)){ + ageMax <- ageMin + 4 + 10 * min(floor((maxA - ageMin - 4)/10), 5) + } else { + if ( ageMaxin > maxA){ + ageMax <- ageMin + 4 + 10 *floor((maxA - ageMin - 4)/10) + } + } + + if(!is.null(ageMaxin)){ + if (ageMax < ageMaxin){ + cat("\nageMax lowered to", ageMax, "\n") + } + } Diff <- ageMax - ageMin age_inteveral <- Diff - Diff %% 10 - 1 @@ -305,6 +337,7 @@ check_heaping_bachi <- function( pctdev = (fractions - .1) * 100, ageMin = ageMin, ageMax = ageMax, + ageMax_given = ageMaxin, max_age_used = max_age_used, decades = decades) } diff --git a/R/data.R b/R/data.R index 2441f9214..02c79d70b 100644 --- a/R/data.R +++ b/R/data.R @@ -113,6 +113,30 @@ #' \url{http://} "popA_later" +#' Russian census 2002 male population by 1 year age groups +#' +#' Male population by 1 year age groups from Russian census help on 2002-10-16 +#' @docType data +#' @format +#' A numeric vector of length 101 +#' +#' @source +#' The data comes from +#' \url{http://www.demoscope.ru/weekly/ssp/rus2002_01.php} +"pop1m_rus2002" + +#' Russian census 2010 male population by 1 year age groups +#' +#' Male population by 1 year age groups from Russian census help on 2010-10-25 +#' @docType data +#' @format +#' A numeric vector of length 101 +#' +#' @source +#' The data comes from +#' \url{http://www.demoscope.ru/weekly/ssp/rus_age1_10.php} +"pop1m_rus2010" + # model life tables --fitted LogQuad models ------------------------------- @@ -149,6 +173,7 @@ #' } #' @source Human Mortality Database. Retrieved 2019-11-28, from "fitted_logquad_f" + #' #' LogQuad model for MALES fitted for all HMD life tables #' @@ -165,4 +190,257 @@ #' \item{model.info}{Model formula.} #' } #' @source Human Mortality Database. Retrieved 2019-11-28, from -"fitted_logquad_m" \ No newline at end of file +"fitted_logquad_m" + +#' Swedish abridged mortality rates +#' +#' Mortality rates in tidy format for each sex in dates 1990-07-01, 2000-07-01, 2010-07-01 +#' @docType data +#' @format +#' A data frame with: +#' \describe{ +#' \item{Date}{Reference time for the rates estimate.} +#' \item{Age}{Inferior age for abridged groups. Carefull: last age 100 is not an OAG} +#' \item{Sex}{Male \code{m} and female \code{m}.} +#' \item{nMx}{Mortality rates.} +#' } +#' @source Human Mortality Database. Retrieved 2021-20-01, from +"mA_swe" + +#' Swedish life expectancy at birth +#' +#' Life expectancy at birth by sex in tidy format for dates from 1960-07-01 to 2015-07-01 by 5 calendar years. +#' @docType data +#' @format +#' A data frame with: +#' \describe{ +#' \item{Date}{Reference time.} +#' \item{Sex}{Male \code{m} and female \code{m}.} +#' \item{e0}{Life expectancy at birth.} +#' } +#' @source Human Mortality Database. Retrieved 2021-20-01, from +"e0_swe" + +#' Population matrix for males five year age groups between 1950 and 2050 +#' +#' Population matrix for males five year age groups between 1950 and 2050 for +#' unknown country +#' @docType data +#' @format +#' A matrix of dimensions 21 x 21 +#' +#' @source +#' Migration residual PAS spreadhseet +"pop_m_mat_five" + +#' Population matrix for females five year age groups between 1950 and 2050 +#' +#' Population matrix for females five year age groups between 1950 and 2050 for +#' unknown country +#' @docType data +#' @format +#' A matrix of dimensions 21 x 21 +#' +#' @source +#' Migration residual PAS spreadhseet +"pop_f_mat_five" + +#' Survival rates matrix for males five year age groups between 1950 and 2045 +#' +#' Survival rates matrix for males five year age groups between 1950 and 2045 +#' for unknown country +#' @docType data +#' @format +#' A matrix of dimensions 21 x 20 +#' +#' @source +#' Migration residual PAS spreadhseet +"sr_m_mat_five" + +#' Survival rates matrix for females five year age groups between 1950 and 2045 +#' +#' Survival rates matrix for females five year age groups between 1950 and 2045 +#' for unknown country +#' @docType data +#' @format +#' A matrix of dimensions 21 x 20 +#' +#' @source +#' Migration residual PAS spreadhseet +"sr_f_mat_five" + +#' Age-specific fertility rates for age groups 15 to 45 between 1950 and 2045 +#' +#' Age-specific fertility rates for age groups 15 to 45 between 1950 and 2045 +#' for unknown country +#' @docType data +#' @format +#' A matrix of dimensions 7 x 20 +#' +#' @source +#' Migration residual PAS spreadhseet +"asfr_mat_five" + +#' Sex ratio at birth between 1950 and 2045 +#' +#' Sex ratio at birth between 1950 and 2045 for unknown country +#' @docType data +#' @format +#' A vector of length 20 +#' +#' @source +#' Migration residual PAS spreadhseet +"srb_vec_five" + +#' Ages between 0 and 100 abridged in five year age groups +#' +#' Ages between 0 and 100 abridged in five year age groups for unknown +#' country +#' @docType data +#' @format +#' A vector of length 21 +#' +#' @source +#' Migration residual PAS spreadhseet +"ages_five" + +#' Ages between 15 and 45 in five year age groups +#' +#' Ages between 15 and 45 in five year age groups for unknown +#' country +#' @docType data +#' @format +#' A vector of length 7 +#' +#' @source +#' Migration residual PAS spreadhseet +"ages_asfr_five" + +#' Population matrix for males single ages between 1999 and 2019 +#' +#' Population matrix for males single ages between 1999 and 2019 for +#' Sweden +#' @docType data +#' @format +#' A matrix of dimensions 101 x 21 +#' +#' @source +#' Migration residual PAS spreadhseet +"pop_m_mat_single" + +#' Population matrix for females single ages between 1999 and 2019 +#' +#' Population matrix for females single ages between 1999 and 2019 for +#' Sweden +#' @docType data +#' @format +#' A matrix of dimensions 101 x 21 +#' +#' @source +#' Migration residual PAS spreadhseet +"pop_f_mat_single" + +#' Survival rates matrix for males single ages between 1999 and 2019 +#' +#' Survival rates matrix for males single ages between 1999 and 2019 for +#' Sweden +#' +#' @docType data +#' @format +#' A matrix of dimensions 101 x 20 +#' +#' @source +#' Migration residual PAS spreadhseet +"sr_m_mat_single" + +#' Survival rates matrix for females single ages between 1999 and 2019 +#' +#' Survival rates matrix for females single ages between 1999 and 2019 for +#' Sweden +#' +#' @docType data +#' @format +#' A matrix of dimensions 101 x 20 +#' +#' @source +#' Migration residual PAS spreadhseet +"sr_f_mat_single" + +#' Age-specific fertility rates for single ages 15 to 49 between 1999 and 2018 +#' +#' Age-specific fertility rates for single ages 15 to 49 between 1999 and 2018 +#' for Sweden +#' +#' @docType data +#' @format +#' A matrix of dimensions 35 x 20 +#' +#' @source +#' Migration residual PAS spreadhseet +"asfr_mat_single" + +#' Sex ratio at birth between 1999 and 2019 +#' +#' Sex ratio at birth between 1999 and 2019 for Sweden +#' +#' @docType data +#' @format +#' A vector of length 20 +#' +#' @source +#' Migration residual PAS spreadhseet +"srb_vec_single" + +#' Single ages between 0 and 100 +#' +#' Single ages between 0 and 100 for Sweden, 1999-2019. +#' @docType data +#' @format +#' A vector of length 101 +#' +#' @source +#' Migration residual PAS spreadhseet +"ages_single" + +#' Single ages between 15 and 49 +#' +#' Single ages between 15 and 49 for Sweden +#' @docType data +#' @format +#' A vector of length 36 +#' +#' @source +#' Migration residual PAS spreadhseet +"ages_asfr_single" + +#' Parameters for considered migration profiles +#' +#' Roger-Castro estimated parameters using `mig_estimate_rc` for Pre Working Age and Working Age profiles of migration. +#' @docType data +#' @format +#' A data frame with: +#' \describe{ +#' \item{family}{Types Family, Male Labor or Female Labor.} +#' \item{sex}{Male and Female.} +#' \item{mig_sign}{Inmigration or Emigration.} +#' \item{param}{Parameters from Roger-Castro.} +#' \item{median}{median of posterior distribution using Monte Carlo Markov Chains in `mig_estimate_rc`.} +#' } +#' @source UN spreadsheet "UNPD_Migration Age Profiles.xlsx" +"mig_un_params" + +#' Proportion of net migrants by age and sex for considered migration profiles +#' +#' Roger-Castro estimated proportion of total net migrants using parameters from `mig_un_params` data. +#' @docType data +#' @format +#' A data frame with: +#' \describe{ +#' \item{family}{Types Family, Male Labor or Female Labor.} +#' \item{sex}{Male and Female.} +#' \item{mig_sign}{Inmigration or Emigration.} +#' \item{age}{Simple ages from 0 to 80 (OAG).} +#' \item{prop}{Proportion of net migrants due to that sex and age.} +#' } +#' @source UN spreadsheet "UNPD_Migration Age Profiles.xlsx" +"mig_un_families" \ No newline at end of file diff --git a/R/extra_mortality.R b/R/extra_mortality.R index ad534fafd..6e8ed4d4d 100644 --- a/R/extra_mortality.R +++ b/R/extra_mortality.R @@ -23,6 +23,7 @@ #' \item{\code{"beard_makeham"}} -- The Beard-Makeham model; #' \item{\code{"quadratic"}} -- The Quadratic model. #' } +#' @param opt.method character. Default `"LF2"`, see `MortalityLaws::MortalityLaw` for a description of choices. #' @param ... Other arguments to be passed on to the #' \code{\link[MortalityLaws]{MortalityLaw}} function. #' @seealso @@ -141,20 +142,23 @@ lt_rule_m_extrapolate <- function(mx, x, x_fit = x, x_extr, - law = c("kannisto", - "kannisto_makeham", - "makeham", - "gompertz", - "ggompertz", - "beard", - "beard_makeham", - "quadratic" - ), - opt.method = c("LF2", "LF1", "LF3", - "LF4", "LF5", "LF6", - "poissonL", "binomialL"), + law = "kannisto", + opt.method = "LF2", ...) { + all_the_laws_we_care_about <- c("kannisto", + "kannisto_makeham", + "makeham", + "gompertz", + "ggompertz", + "beard", + "beard_makeham", + "quadratic") + law <- match.arg(law, choices = all_the_laws_we_care_about) + + opt.choices <- c("poissonL","LF2", "LF1", "LF3", + "LF4", "LF5", "LF6", "binomialL") + opt.method <- match.arg(opt.method, opt.choices) # Save the input input <- as.list(environment()) @@ -163,8 +167,8 @@ lt_rule_m_extrapolate <- function(mx, x = x, mx = mx, fit.this.x = x_fit, - law = match.arg(law), - opt.method = match.arg(opt.method), + law = law, + opt.method = opt.method, ... ) diff --git a/R/graduate.R b/R/graduate.R index bcfc4a7eb..d6d8dd49b 100644 --- a/R/graduate.R +++ b/R/graduate.R @@ -11,7 +11,7 @@ #' #' @return Numeric vector of counts for single year age groups. #' -#' @details Assumes that the population is uniformly distributed across each age interval, and that initial age intervals are integers greater than or equal to 1. If \code{AgeInt} is given, its final value is used as the interval for the final age group. If \code{AgeInt} is missing, then \code{Age} must be given, and the open age group is by default preserved \code{OAvalue} rather than split. To instead split the final age group into, e.g., a 5-year age class, either give \code{AgeInt}, *or* give \code{Age}, \code{OAG = TRUE}, and \code{OAvalue = 5}. +#' @details Assumes that the population is uniformly distributed across each age interval, and that initial age intervals are integers greater than or equal to 1. If \code{AgeInt} is given, its final value is used as the interval for the final age group. If \code{AgeInt} is missing, then \code{Age} must be given, and the open age group is by default preserved \code{OAvalue} rather than split. To instead split the final age group into, e.g., a 5-year age class, either give \code{AgeInt}, *or* give \code{Age}, \code{OAG = TRUE}, and \code{OAvalue = 5}. `Age` be any age range, it does not need to start at 0. #' #' @export #' @examples @@ -22,8 +22,8 @@ #' graduate_uniform(MalePop, Age = Ages) graduate_uniform <- function(Value, - AgeInt, Age, + AgeInt, OAG = TRUE, OAvalue = 1) { @@ -89,12 +89,25 @@ graduate_uniform <- graduate_sprague <- function(Value, Age, + AgeInt, OAG = TRUE) { + if (missing(Age) & missing(AgeInt)) { + Age <- names2age(Value) + } + if (missing(AgeInt)) { + # give 1 to final interval to preserve + AgeInt <- age2int(Age, OAG = OAG, OAvalue = 1) + } + if (missing(Age)) { + Age <- int2age(AgeInt) + } + punif1 <- graduate_uniform( - Value = Value, - Age = Age, - OAG = OAG) + Value = Value, + AgeInt = AgeInt, + Age = Age, + OAG = OAG) # this is innocuous if ages are already grouped a1 <- as.integer(names(punif1)) pop5 <- groupAges( @@ -190,6 +203,8 @@ graduate_sprague_expand <- function( # get the split coefficients # block for ages 0-9 + + # TR: 5-5-2021, this assumes ages start at 0... g1g2 <- matrix( c( 0.3616, -0.2768, 0.1488, -0.0336, 0.0000, 0.2640, -0.0960, 0.0400, @@ -409,10 +424,23 @@ graduate_grabill_expand <- function(Value, Age, OAG = TRUE) { graduate_grabill <- function( Value, Age, + AgeInt, OAG = TRUE) { + if (missing(Age) & missing(AgeInt)) { + Age <- names2age(Value) + } + if (missing(AgeInt)) { + # give 1 to final interval to preserve + AgeInt <- age2int(Age, OAG = OAG, OAvalue = 1) + } + if (missing(Age)) { + Age <- int2age(AgeInt) + } + punif1 <- graduate_uniform( Value = Value, + AgeInt = AgeInt, Age = Age, OAG = OAG) # this is innocuous if ages are already grouped @@ -685,14 +713,16 @@ graduate_beers_expand <- function(Value, #' The ordinary modified Beers splitting methods #' -#' @description This method offers both ordinary and modified Beers splitting, with an optional \href{https://www.census.gov/data/software/dapps.html}{Demographic Analysis & Population Projection System Software} adjustment \code{johnson} for ages under 10. +#' @description This method offers both ordinary and modified Beers splitting, with an optional \href{https://www.census.gov/data/software/dapps.html}{Demographic Analysis & Population Projection System Software} adjustment `johnson` for ages under 10. #' #' @inheritParams graduate -#' @param method character. Valid values are \code{"mod"} or \code{"ord"}. Default \code{"mod"}. -#' @param johnson logical. Whether or not to adjust young ages according to the \href{https://www.census.gov/data/software/dapps.html}{Demographic Analysis & Population Projection System Software} method. Default \code{FALSE}. -#' @details Ages should refer to lower age bounds. \code{Value} must be labelled with ages unless \code{Age} is given separately. There must be at least six 5-year age groups (including the open group, 5 otherwise). If you want the \code{johnson} adjustment then \code{Value} must contain a single-year estimate of the population count in age 0. That means \code{Value} must come either as standard abridged or single age data. +#' @param method character. Valid values are `"ord"` or `"mod"`. Default `"ord"`. +#' @param johnson logical. Whether or not to adjust young ages according to the \href{https://www.census.gov/data/software/dapps.html}{Demographic Analysis & Population Projection System Software} method. Default `FALSE.` +#' @details Ages should refer to lower age bounds. `Value` must be labelled with ages unless `Age` is given separately. There must be at least six 5-year age groups (including the open group, 5 otherwise). If you want the `johnson` adjustment then `Value` must contain a single-year estimate of the population count in age 0. That means `Value` must come either as standard abridged or single age data. +#' +#' `method` option `"ord"` conserves sums in 5-year age groups, whereas `"mod"` does some smoothing between 5-year age groups too, and is not constrained. #' -#' If the highest age does not end in a 0 or 5, and \code{OAG == TRUE}, then the open age will be grouped down to the next highest age ending in 0 or 5. If the highest age does not end in a 0 or 5, and \code{OAG == FALSE}, then results extend to single ages covering the entire 5-year age group. +#' If the highest age does not end in a 0 or 5, and `OAG == TRUE`, then the open age will be grouped down to the next highest age ending in 0 or 5. If the highest age does not end in a 0 or 5, and `OAG = FALSE`, then results extend to single ages covering the entire 5-year age group. #' #' @return A numeric vector of single age data. #' @references @@ -753,11 +783,18 @@ graduate_beers <- function(Value, Age, AgeInt, OAG = TRUE, - method = "mod", + method = "ord", johnson = FALSE) { - if (missing(AgeInt)){ - AgeInt <- age2int(Age, OAG = OAG, OAvalue = 1) + if (missing(Age) & missing(AgeInt)) { + Age <- names2age(Value) + } + if (missing(AgeInt)) { + # give 1 to final interval to preserve + AgeInt <- age2int(Age, OAG = OAG, OAvalue = 1) + } + if (missing(Age)) { + Age <- int2age(AgeInt) } punif1 <- graduate_uniform( @@ -856,6 +893,10 @@ graduate_beers_johnson <- function(Age0, pop5, pop1) { #' #' @description This is exactly the function \code{pclm()} from the \code{ungroup} package, except with arguments using standard \code{DemoTools} argument names. #' @details The PCLM method can also be used to graduate rates using an offset if both numerators and denominators are available. In this case \code{Value} is the event count and \code{offset} is person years of exposure. The denominator must match the length of \code{Value} or else the length of the final single age result \code{length(min(Age):OAnew)}. This method can be used to redistribute counts in the open age group if \code{OAnew} gives sufficient space. Likewise, it can give a rate extrapolation beyond the open age. +#' +#' If there are 0s in `Value`, these are replaced with a small value prior to fitting. If negatives result from the pclm fit, we retry after multiplying `Value` by 10, 100, or 1000, as sometimes a temporary rescale for fitting can help performance. +#' +#' `Age` be any age range, it does not need to start at 0. #' #' @inheritParams graduate #' @param ... further arguments passed to \code{ungroup::pclm()} @@ -892,11 +933,28 @@ graduate_beers_johnson <- function(Age0, pop5, pop1) { #' lines(0:85, mx, col = "red") #' } -graduate_pclm <- function(Value, Age, OAnew = max(Age), ...) { - nlast <- OAnew - max(Age) + 1 +graduate_pclm <- function(Value, Age, AgeInt, OAnew = max(Age), OAG = TRUE, ...) { + + if (missing(Age) & missing(AgeInt)) { + Age <- names2age(Value) + } + if (missing(AgeInt)) { + # give 1 to final interval to preserve + AgeInt <- age2int(Age, OAG = OAG, OAvalue = 1) + } + if (missing(Age)) { + Age <- int2age(AgeInt) + } + + if (OAnew > max(Age)){ + nlast <- OAnew - max(Age) + 1 + } else { + nlast <- 1 + } a1 <- min(Age):OAnew DOTS <- list(...) if ("offset" %in% names(DOTS)) { + # offset could be one or another thing.. lo <- length(DOTS$offset) o1 <- length(a1) == lo @@ -904,10 +962,42 @@ graduate_pclm <- function(Value, Age, OAnew = max(Age), ...) { stopifnot(o1 | o5) } + # TR 22 March 2021 + # 0s cause breakage + # check for 0s + ind0 <- Value == 0 + have0s <- any(ind0) + if (have0s){ + cat("\n0s detected in Value, replacing with .01\n") + Value[ind0] <- .01 + } + A <- pclm(x = Age, y = Value, nlast = nlast, ...) - B <- A$fitted - names(B) <- min(Age):OAnew - B + fac <- 1 + for (i in 1:3){ + if (any(A$fitted < 0)){ + # let's assume it's a scale issue + fac <- 10^i + A <- pclm(x = Age, y = Value * fac, nlast = nlast, ...) + } else { + break + } + } + if (any(A$fitted < 0)){ + # TR: just let the error propagate instead of interpreting it? + cat("\nCareful, results of PCLM produced some negatives. + \nWe tried rescaling inputs by as much as",fac,"\nbut alas it wasn't enough.\n") + } + if (fac > 1){ + cat("\nPossible small counts issue with these data and the PCLM method\nIt seems to have worked without producing negatives when fitting Value is scaled by",fac,"\nCouldn't hurt to eyeball results!\n") + } + + B <- A$fitted / fac + a1.fitted <- A$bin.definition$output$breaks["left", ] + names(B) <- a1.fitted + # in case OAnew is lower than max(Age) + C <- groupOAG(Value = B, Age = a1.fitted, OAnew = OAnew) + C } @@ -918,7 +1008,7 @@ graduate_pclm <- function(Value, Age, OAnew = max(Age), ...) { #' Graduate age groups using a monotonic spline. #' @description Take the cumulative sum of \code{Value} and then run a monotonic spline through it. The first differences split back single-age estimates of \code{Value}. Optionally keep the open age group untouched. #' -#' @details The \code{"monoH.FC"} method of \code{stats::splinefun()} is used to fit the spline because 1) it passes exactly through the points, 2) it is monotonic and therefore guarantees positive counts, and 3) it seems to be a bit less wiggly (lower average first differences of split counts). Single-age data is returned as-is. If you want to use this function as a smoother you first need to group to non-single ages. +#' @details The \code{"hyman"} method of \code{stats::splinefun()} is used to fit the spline because 1) it passes exactly through the points, 2) it is monotonic and therefore guarantees positive counts, and 3) it seems to be a bit less wiggly (lower average first differences of split counts). Single-age data is returned as-is. If you want to use this function as a smoother you first need to group to non-single ages. `Age` be any age range, it does not need to start at 0. #' @inheritParams graduate #' @return Numeric. vector of single smoothed age counts. #' @importFrom stats splinefun @@ -932,24 +1022,27 @@ graduate_pclm <- function(Value, Age, OAnew = max(Age), ...) { #' "10", "15", "20", "25", "30", "35", "40", "45", "50", "55", "60", #' "65", "70", "75", "80", "85", "90", "95", "100")) #' -#' # overwrite open age group with a single age estimate for that age -#' # (doesn't extrapolate) -#' graduate_mono(Value) -#' # or respect open age group +#' # if the last age group is closed, then it's best to use AgeInt, otherwise, +#' # one is assumed from the age siphoned from the names attribute of Value. +#' graduate_mono(Value, OAG = FALSE) +#' # or leave open age group in tact #' graduate_mono(Value, OAG = TRUE) #' -#' # Also accepts single ages: -#' Value <- structure(pop1m_ind, .Names = 0:100) -#' -#' \dontrun{ -#' ages <- seq(0,100,5) -#' plot(graduate_mono(Value),xlab = 'Age', ylab = 'Counts', type = 'l',main = 'Ungrouped counts') -#' } +#' data(pop1m_ind) +#' Value5 <- groupAges(pop1m_ind,Age=0:100,N=5) +#' +#' Value1 <- graduate_mono(Value = Value5, Age = names2age(Value5), OAG =TRUE) +#' +#' \dontrun{ +#' +#' plot(seq(0,100,5),Value5 / 5, xlab = 'Age', ylab = 'Counts', type = 's') +#' lines(0:100,Value1) +#' } graduate_mono <- function( Value, - AgeInt, Age, + AgeInt, OAG = TRUE) { if (missing(Age) & missing(AgeInt)) { @@ -965,6 +1058,7 @@ graduate_mono <- function( # if age is single return as-is if (is_single(Age)) { + names(Value) <- Age return(Value) } @@ -979,19 +1073,20 @@ graduate_mono <- function( # if the final age is Open, then we should remove it and then # stick it back on - AgePred <- c(min(Age), cumsum(AgeInt)) + AgePred <- c(min(Age), cumsum(AgeInt) + min(Age)) y <- c(0, cumsum(Value)) - AgeS <- min(Age):sum(AgeInt) - y1 <- splinefun(y ~ AgePred, method = "monoH.FC")(AgeS) + AgeS <- min(Age):(sum(AgeInt)+ min(Age)) + # TR: changed from monoH.FC to hyman 3.3.2021 + y1 <- splinefun(y ~ AgePred, method = "hyman")(AgeS) out <- diff(y1) names(out) <- AgeS[-length(AgeS)] # The open age group is maintained as-is. if (OAG) { out <- c(out, OAvalue) - names(out) <- AgeS } - + age1 <- min(Age):(min(Age) + length(out) - 1) + names(out) <- age1 out } @@ -1009,7 +1104,7 @@ graduate_mono <- function( #' @return numeric matrix of age by year estimates of single-age counts. #' #' @details The \code{pivotAge} must be at least 10 years below the maximum age detected from -#' \code{rownames(popmat)}, but not lower than 75. In the exact \code{pivotAge}, we may either take the Sprague estimates or the spline estimates, depending on which is larger, then the single-age estimates for this 5-year age group are rescaled to sum to the original total in \code{Value}. Higher ages are taken from the spline-based age splits. The spline results are derive from the \code{"monoH.FC"} method of \code{splinefun()} on the cumulative sum of the original age grouped data. One could use this function to perform the same closeout to Grabill estimates, if these are given via the \code{pops} argument. See examples. Note that the Grabill split method mixed with this closeout will not necessarily preserve the annual totals, and this function performs to rescaling. The open age group is preserved (and must be included in \code{Value}). +#' \code{rownames(popmat)}, but not lower than 75. In the exact \code{pivotAge}, we may either take the Sprague estimates or the spline estimates, depending on which is larger, then the single-age estimates for this 5-year age group are rescaled to sum to the original total in \code{Value}. Higher ages are taken from the spline-based age splits. The spline results are derive from the \code{"hyman"} method of \code{splinefun()} on the cumulative sum of the original age grouped data. One could use this function to perform the same closeout to Grabill estimates, if these are given via the \code{pops} argument. See examples. Note that the Grabill split method mixed with this closeout will not necessarily preserve the annual totals, and this function performs to rescaling. The open age group is preserved (and must be included in \code{Value}). #' #' @export #' @@ -1329,7 +1424,7 @@ graduate <- function(Value, } n <- length(out) - a1 <- min(Age):(n - 1) + a1 <- min(Age):(min(Age) + n - 1) # detect negatives. Have default option to replace. # Favor quick over perfect, since this only can arise @@ -1339,6 +1434,7 @@ graduate <- function(Value, ind0 <- out < 0 if (any(ind0)){ # which + agen <- rep(Age, times = AgeInt) problem.ages <- agen[ind0] out[ind0] <- 0 diff --git a/R/interp_coh.R b/R/interp_coh.R index 79c24c296..3cb28b478 100644 --- a/R/interp_coh.R +++ b/R/interp_coh.R @@ -1,180 +1,1161 @@ #' shift census populations to match single year cohorts #' @description Matches the (single) ages of a census to single cohorts. For use in intercensal interpolations. Ages are potentially blended to match single cohort line assuming that the population in each age is uniformly distributed over the age group. -#' @param Pop numeric vector. Population counts in single ages -#' @param Age integer. Lower bound of single age groups +#' @param pop numeric vector. Population counts in age groups, presumably from a census with an exact reference date. +#' @param age integer vector. Lower bound of single age groups #' @param date Either a \code{Date} class object or an unambiguous character string in the format \code{"YYYY-MM-DD"}. -#' @export +#' @param censusYearOpt character or `NA`. Options include: +#' * `"frac"` keep the partial cohort observed in the year of the census. +#' * `"drop"` remove the partial cohort from the census year (and trim other outputs to match) +#' * `"extrap"` inflate the partial cohort from the census year. Specifically we keep it the same as the input age 0. +#' * `NA` return `NA` for the census year cohort size. +#' @param OAG logical. Is the highest age group an open age? If `TRUE` +#'@export #' @examples -#' Pop <- seq(10000,100,length.out = 101) -#' Age <- 0:100 +#' pop <- seq(10000,100,length.out = 101) +#' age <- 0:100 #' d1 <- "2020-01-01" #' d2 <- "2020-07-01" #' d3 <- "2020-12-21" -#' -#' census_cohort_adjust(Pop,Age,d1) -#' census_cohort_adjust(Pop,Age,d2) -#' census_cohort_adjust(Pop,Age,d3) -#' census_cohort_adjust(Pop,Age,2020.5) - -census_cohort_adjust <- function(Pop, Age, date){ - - stopifnot(is_single(Age)) - +#' +#' shift_census_ages_to_cohorts(pop, age, d1) +#' shift_census_ages_to_cohorts(pop, age, d2) +#' shift_census_ages_to_cohorts(pop, age, d3) +#' shift_census_ages_to_cohorts(pop, age, 2020.5) + +shift_census_ages_to_cohorts <- function(pop, + age, + date, + censusYearOpt = "frac", + OAG = TRUE){ + + + stopifnot(is_single(age)) + date <- dec.date(date) yr <- floor(date) - f1 <- date - yr - - upper_part_of_cohort <- Pop * f1 - lower_part_of_cohort <- Pop * (1 - f1) - + + if (OAG){ + N <- length(pop) + pop <- pop[-N] + age <- age[-N] + } + + if (is.na(censusYearOpt)){ + censusYearOpt <- "NA" + } + + upper_part_of_cohort <- pop * f1 + lower_part_of_cohort <- pop * (1 - f1) + shift <- ceiling(f1) pop_out <- shift.vector(lower_part_of_cohort,shift) + upper_part_of_cohort - cohorts <- yr - Age - 1 + shift - - list(Pop = pop_out, Cohort = cohorts, date = date, f1 = f1) -} + cohorts <- yr - age - 1 + shift -# C1 <- seq(10000,10,length.out = 10) -# C2 <- seq(15000,10,length.out = 10) -# -# d1 <- "2020-07-01" -# d2 <- "2025-10-14" -# -# C1_coh <-census_cohort_adjust(C1, 0:9, d1) -# C2_coh <-census_cohort_adjust(C2, 0:9, d2) -# -# cohs_match <- -# -# matrix(C1_coh$Pop) -# -# interp() + age_out <- round(f1) + age + + if (censusYearOpt == "drop"){ + pop_out <- pop_out[-1] + age_out <- age_out[-1] + cohorts <- cohorts[-1] + } + if (censusYearOpt == "extrap"){ + pop_out[1] <- pop[1] + # identical to: + # pop_out[1] <- pop_out[1] + (1-f1) * pop[1] + } + if (censusYearOpt == "NA"){ + pop_out[1] <- NA_real_ + } -# c1 = seq(10000,10,length.out = 10); c2 = seq(15000,10,length.out = 10); date1 = "2020-07-01"; date2 = "2025-10-14"; age1 = 0:9; age2 = 0:9 + list(cohort_size = pop_out, + birth_year = cohorts, + age = age_out, + date = date, + f1 = f1) +} -#' component-free intercensalcohort interpolation -#' @description Cohorts between two censuses are interpolated flexibly using linear, exponential, or power rules. The lower and upper intercensal triangles are filled using within-age interpolation. This function is experimental and still in development. +#' Cohort component intercensal interpolation +#' @description Cohorts between two censuses are interpolated using a cohort component approach. #' @seealso interp #' @param c1 numeric vector. The first (left) census in single age groups #' @param c2 numeric vector. The second (right) census in single age groups #' @param date1 reference date of c1`. Either a Date class object or an unambiguous character string in the format "YYYY-MM-DD". #' @param date2 reference date of c2`. Either a Date class object or an unambiguous character string in the format "YYYY-MM-DD". #' @param age1 integer vector. single ages of `c1` -#' @param age2 integer vector. single ages of `c2` -#' @param ... extra arguments passed to `interp()`. Not currently in use. +#' @param age2 integer vector. single ages of `c2` +#' @param dates_out vector of desired output dates coercible to numeric using `dec.date()` +#' @param lxMat numeric matrix containing lifetable survivorship, `l(x)`. Each row is an age group and each column a time point. At least two intercensal time points needed. +#' @param age_lx integer vector. Age classes in `lxMat` +#' @param dates_lx date, character, or numeric vector of the column time points for `lxMat`. If these are calendar-year estimates, then you can choose mid-year time points +#' @param births integer vector. Raw birth counts for the corresponding (sub)-population, one value per each year of the intercensal period including both census years. The first and last years should include all births in the given year; don't discount them in advance. +#' @param years_births numeric vector of calendar years of births. +#' @param location UN Pop Division `LocName` or `LocID` +#' @param sex character string, either `"male"`, `"female"`, or `"both"` +#' @param midyear logical. `FALSE` means all Jan 1 dates between `date1` and `date2` are returned. `TRUE` means all July 1 intercensal dates are returned. +#' @param verbose logical. Shall we send informative messages to the console? +#' @param ... optional arguments passed to +#' @details The basic approach is to i) align the censuses to single-year cohorts by blending adjacent ages assuming that the birthdays in each age group are uniformly distributed through the year ii) decrement the first census forward within cohorts using period-cohort survival probabilities calculated from (supplied or downloaded) `l(x)` values, iii) redistribute the residual at the time of the second census uniformly over time within cohorts. These steps are always done on Jan 1 reference dates. If `midyear = TRUE`, then we do within-age band arithmetic interpolation to July 1 reference dates. #' @export -interp_coh_bare <- function(c1, c2, date1, date2, age1, age2, ...){ - +#' @importFrom data.table := as.data.table melt data.table dcast between +#' @examples +#' +#' \dontrun{ +#' interp_coh( +#' location = "Russian Federation", +#' sex = "male", +#' c1 = pop1m_rus2002, +#' c2 = pop1m_rus2010, +#' date1 = "2002-10-16", +#' date2 = "2010-10-25", +#' age1 = 0:100, +#' births = c(719511L, 760934L, 772973L, 749554L, 760831L, 828772L, 880543L, 905380L, 919639L) +#' ) +#' } +interp_coh <- function( + c1, + c2, + date1, + date2, + age1 = 1:length(c1) - 1, + age2 = 1:length(c2) - 1, + dates_out = NULL, + lxMat = NULL, + age_lx = NULL, + dates_lx = NULL, + births = NULL, + years_births = NULL, + location = NULL, + sex = "both", + midyear = FALSE, + verbose = TRUE, + ... + ) { + + # convert the dates into decimal numbers date1 <- dec.date(date1) date2 <- dec.date(date2) - - # !!! do we plan to allow age1 != age2 ? - - c1c <-census_cohort_adjust(c1, age1, date1) - c2c <-census_cohort_adjust(c2, age2, date2) - - # Connect cohorts observed (completely) in both censuses - obs_coh <- intersect(c1c$Cohort, c2c$Cohort) - - # remove first cohort is not observed in full - if(c1c$date - c1c$Cohort[1] != 1){ - obs_coh <- obs_coh[-1] - } - - # Tim: select, make some intermediate data objects as necessary - - # fully observed cohorts in a pop matrix - obs_coh_mat <- cbind( - c1c$Pop[match(obs_coh, c1c$Cohort)], - c1c$Pop[match(obs_coh, c2c$Cohort)] - ) - # set names - dimnames(obs_coh_mat) <- list(obs_coh, c(c1c$date, c2c$date)) - - # Tim: then use interp() - - # interpolate - dates_in <- dimnames(obs_coh_mat)[[2]] %>% as.numeric() - dates_out <- seq(floor(dates_in[1]), ceiling(dates_in[-1]), 1) - # what should be the default behavior here? - # I start off with the one year step period, inclusive - - interpolated_coh_mat <- interp( - popmat = obs_coh_mat, - datesIn = dates_in, - datesOut = dates_out, - method = "linear", - rule = 2 + + res_list <- rup( + c1 = c1, + c2 = c2, + date1 = date1, + date2 = date2, + age1 = age1, + age2 = age2, + dates_out = dates_out, + lxMat = lxMat, + age_lx = age_lx, + dates_lx = dates_lx, + births = births, + years_births = years_births, + location = location, + sex = sex, + midyear = midyear, + verbose = verbose, + ... = ... ) - - - - ######## - - # Do something to fill in the lower triangle - # The most basic thing (suggested by Patrick) - # Just do a between-age interpolation and select out - # that triangle. - - # !!! between-age interpolation - period_mat <- cbind(c1, c2) - # set names - dimnames(period_mat) <- list(age1, c(date1, date2)) - - - interpolated_period_mat <- interp( - popmat = period_mat, - datesIn = dimnames(period_mat)[[2]] %>% as.numeric(), - datesOut = seq(floor(dates_in[1]), ceiling(dates_in[-1]), 1) , - method = "linear", - rule = 2 + + pop_jan1 <- res_list$pop_jan1 + dates_out <- res_list$dates_out + + . <- NULL + age <- NULL + discount <- NULL + pop_jan1_pre <- NULL + resid <- NULL + year <- NULL + + # add "cumulative" residual to the RUP (pop_jan1_pre) + pop_jan1[, `:=`(pop_jan1 = pop_jan1 + resid * discount)] + pop_jan1 <- pop_jan1[!is.na(cohort)] + + # TR: to get residualmigbeta prelim result, one takes the cumulative + # resid (resid * discount), then decumulates it (within cohorts!), + # then sum over age. boo ya Lexis + + PopAP <- + pop_jan1 %>% + .[, list(age, year, pop_jan1)] %>% + data.table::dcast(age ~ year, value.var = "pop_jan1") %>% + .[order(age)] + + + matinterp <- PopAP[age <= max(age1), -1] %>% as.matrix() + rownames(matinterp) <- age1 + + # Handle NAs perhaps c1 needs OPAG beforehand?) + ind <- is.na(matinterp) + if (any(ind) & verbose){ + cat("\n",sum(ind),"NA detected in output.\nThese have been imputed with 0s.\nThis could happen in the highest ages,\nand you may consider extending the open ages of the census inputs?\n") + matinterp[ind] <- 0 + } + + # Handle negatives (small pops, or large negative residuals relative to pop size) + ind <- matinterp < 0 + if (any(ind) & verbose){ + cat("\n",sum(ind),"negatives detected in output.\nThese have been imputed with 0s.\n") + matinterp[ind] <- 0 + } + + yrsIn <- as.numeric(colnames(matinterp)) + if (all(yrsIn > date1)){ + matinterp <- cbind(c1, matinterp) + yrsIn <- c(date1, yrsIn) + } + + if (all(yrsIn < date2)){ + matinterp <- cbind(matinterp, c2[1:length(c2)]) + yrsIn <- c(yrsIn, date2) + } + + colnames(matinterp) <- yrsIn + # now we either return Jan1 dates or July 1 dates. + + out <- interp( + matinterp, + datesIn = yrsIn, + datesOut = as.numeric(dates_out), + rule = 1 ) - ######## - - # Now fill in the upper triangle, doing something - # simple and robust - - ######## - - # now the task is to take interpolated_period_mat - # and overwrite the matching values from interpolated_coh_mat - - # achieved using a for loop that iterates across columns - # so I use the period interpolated matrix as canvas - # and overwrite the matching values from the cohort matrix - - for (i in dimnames(interpolated_coh_mat)[[2]]) { - # take the i-th column from cohort interpolated matrix - replacement <- interpolated_coh_mat[,i] - # calculate the corresponding ages fo the interpolated values - ages <- as.numeric(i) - as.numeric(names(replacement)) - # overwrite the cohort values in the period matrix - interpolated_period_mat[ages,i] <- replacement - } - - - # The remaining task is to frame the output - return(interpolated_period_mat) - -} + if (any(out < 0)) { + if (verbose) { + cat("\nSome of the interpolated values resulted to be negative, replacing with zeroes\n") #nolintr + } + + out[out < 0] <- 0 + } + + out +} +# old code kept for now --------------------------------------------------- -# try out -# -# boo <- interpolated_period_mat -# -# boo[is.numeric(boo)] <- 0 -# -# foo <- interpolated_coh_mat -# -# -# -# for (i in dimnames(foo)[[2]]) { -# -# replacement <- foo[,i] -# ages <- as.numeric(i) - as.numeric(names(replacement)) -# -# boo[ages,i] <- replacement +# c1 <- seq(10000,10,length.out = 10) +# c2 <- seq(15000,10,length.out = 10) +# +# d1 <- "2020-07-01" +# d2 <- "2025-10-14" +# +# c1_coh <-census_cohort_adjust(c1, 0:9, d1) +# c2_coh <-census_cohort_adjust(c2, 0:9, d2) +# +# cohs_match <- +# +# matrix(c1_coh$pop) +# +# interp() +# +## commenting out interp_coh_bare won't be used +# interp_coh_bare <- function(c1, c2, date1, date2, age1, age2, ...){ +# +# date1 <- dec.date(date1) +# date2 <- dec.date(date2) +# +# # !!! do we plan to allow age1 != age2 ? +# +# c1c <-census_cohort_adjust(c1, age1, date1) +# c2c <-census_cohort_adjust(c2, age2, date2) +# +# # Connect cohorts observed (completely) in both censuses +# obs_coh <- intersect(c1c$cohort, c2c$cohort) +# +# # remove first cohort if not observed in full +# if(c1c$date - c1c$cohort[1] != 1){ +# obs_coh <- obs_coh[-1] +# } +# +# # Tim: select, make some intermediate data objects as necessary +# +# # fully observed cohorts in a pop matrix +# obs_coh_mat <- cbind( +# c1c$pop[match(obs_coh, c1c$cohort)], +# c2c$pop[match(obs_coh, c2c$cohort)] +# ) +# # set names +# dimnames(obs_coh_mat) <- list(obs_coh, c(c1c$date, c2c$date)) +# +# # Tim: then use interp() +# +# # interpolate +# dates_in <- dimnames(obs_coh_mat)[[2]] %>% as.numeric() +# dates_out <- seq(floor(dates_in[1]), ceiling(dates_in[-1]), 1) +# # what should be the default behavior here? +# # I start off with the one year step period, inclusive +# +# interpolated_coh_mat <- interp( +# popmat = obs_coh_mat, +# datesIn = dates_in, +# datesOut = dates_out, +# method = "linear", +# rule = 2 +# ) +# +# +# +# ######## +# +# # Do something to fill in the lower triangle +# # The most basic thing (suggested by Patrick) +# # Just do a between-age interpolation and select out +# # that triangle. +# +# # !!! between-age interpolation +# period_mat <- cbind(c1, c2) +# # set names +# dimnames(period_mat) <- list(age1, c(date1, date2)) +# +# +# interpolated_period_mat <- interp( +# popmat = period_mat, +# datesIn = dimnames(period_mat)[[2]] %>% as.numeric(), +# datesOut = seq(floor(dates_in[1]), ceiling(dates_in[-1]), 1) , +# method = "linear", +# rule = 2 +# ) +# ######## +# +# # Now fill in the upper triangle, doing something +# # simple and robust +# +# ######## +# +# # now the task is to take interpolated_period_mat +# # and overwrite the matching values from interpolated_coh_mat +# +# # achieved using a for loop that iterates across columns +# # so I use the period interpolated matrix as canvas +# # and overwrite the matching values from the cohort matrix +# +# # dup interpolated_period_mat +# out <- interpolated_period_mat +# +# for (i in dimnames(interpolated_coh_mat)[[2]]) { +# # take the i-th column from cohort interpolated matrix +# replacement <- interpolated_coh_mat[,i] +# # calculate the corresponding ages fo the interpolated values +# ages <- as.numeric(i) - as.numeric(names(replacement)) +# # overwrite the cohort values in the period matrix +# out[ages,i] <- replacement +# } +# +# +# # The remaining task is to frame the output +# return(out) +# # } +# +# +# # above rudimentary code works; below goes the new development +# +# # c1 = seq(10000,10,length.out = 10); c2 = seq(15000,10,length.out = 10); date1 = "2020-07-01"; date2 = "2025-10-14"; age1 = 0:9; age2 = 0:9 +# +# +# +# canvas <- interpolated_period_mat %>% +# as_tibble(rownames = "age") %>% +# pivot_longer(names_to = "year", values_to = "value", cols = -age) %>% +# mutate( +# age = age %>% as.numeric, +# year = year %>% as.numeric, +# cohort = year - age +# ) +# +# patch <- interpolated_coh_mat %>% +# as_tibble(rownames = "cohort") %>% +# pivot_longer( +# names_to = "year", values_to = "value", cols = -1, +# values_drop_na = TRUE +# )%>% +# mutate( +# cohort = cohort %>% as.numeric, +# year = year %>% as.numeric, +# age = year - (cohort+1) +# ) +# +# final <- canvas %>% +# rows_upsert( +# patch %>% filter(!year %in% c(2020, 2026)), +# by = c("age", "year") +# ) %>% +# select(-cohort) %>% +# pivot_wider(names_from = year) +# +# +# +# +# view_ap <- function(long_apc_df) { +# long_apc_df %>% +# select(-cohort) %>% +# pivot_wider(names_from = year) +# } +# +# patch %>% view_ap +# +# canvas %>% view_ap +# +# final %>% view_ap +# +# +# +# +# +# +# # the survival probabilities approach ------------------------------------- +# load_this <- FALSE +# if (load_this) { +# # blocking this off lets us to +# devtools::load_all() +# library(magrittr) +# library(tidyverse) +# pxt <- suppressMessages(interp_coh_download_mortality("Russian Federation","male","2002-10-16","2010-10-25")) +# +# # convert the AP output to CP +# px_triangles <- pxt %>% +# as_tibble(rownames = "age") %>% +# pivot_longer( +# names_to = "year", values_to = "px", cols = -1, +# values_drop_na = TRUE +# ) %>% +# mutate( +# age = age %>% as.numeric, +# year = year %>% as.numeric, +# # cohort = floor(year) - age +# ) %>% +# # in triangles +# mutate( +# # year_frac = year - floor(year) # for now just .5 ~ sqrt +# lower = px %>% raise_to_power(.5), +# upper = px %>% raise_to_power(1 - .5) # .5 to be changed to year_frac +# ) %>% +# select(-px) %>% +# pivot_longer( +# names_to = "triangle", values_to = "value", cols = lower:upper +# ) %>% +# mutate( +# adj = case_when(triangle=="upper" ~ 1, TRUE ~ 0), +# cohort = year %>% subtract(age) %>% subtract(adj) %>% floor +# ) +# +# +# +# # cohort changes over the whole period +# px_cum <- px_triangles %>% +# group_by(cohort) %>% +# summarise( +# n_triangles = n(), +# coh_p = value %>% prod +# ) %>% +# ungroup() +# +# # foo %>% interp_coh_tidy_pc("1971-01-14","1978-02-01") %>% view +# +# # # generate two census populations -- single years of age +# # set.seed(911) +# # c1 <- spline(c(6,7,9,8,7,6,4,2,1)*1e3,n = 101)$y * runif(101, 1, 1.1) +# # set.seed(444) +# # c2 <- spline(c(6,7,9,8,7,6,4,2,1)*1e3,n = 101)$y * runif(101, 1.05, 1.15) +# # # births as random +-10% of the c1 and c2 age 0 average +# # births <- runif(6, .9*mean(c1[1], c2[1]), 1.1*mean(c1[1], c2[1])) %>% round +# +# # EXAMPLE DATA: Russian male population from the last two censuses +# # 2002 -- http://www.demoscope.ru/weekly/ssp/rus2002_01.php +# # 2020 -- http://www.demoscope.ru/weekly/ssp/rus_age1_10.php +# rus2002m <- c(682698L, 641551L, 644671L, 644652L, 662998L, 659306L, 678341L, 717053L, 740366L, 753300L, 875113L, 963123L, 1081671L, 1145059L, 1247787L, 1314341L, 1291147L, 1266227L, 1306873L, 1325599L, 1234028L, 1162951L, 1170248L, 1115312L, 1100598L, 1088833L, 1092321L, 1070733L, 1045802L, 1016461L, 1061391L, 994896L, 1007712L, 933628L, 916902L, 929632L, 957895L, 981477L, 1039571L, 1116279L, 1195521L, 1210704L, 1278766L, 1216728L, 1182385L, 1167289L, 1123058L, 1117150L, 1087663L, 998307L, 1035886L, 951627L, 960428L, 963751L, 730354L, 798841L, 604983L, 382611L, 298788L, 280702L, 493677L, 625270L, 694930L, 741777L, 695339L, 693911L, 559111L, 467811L, 358252L, 364999L, 427681L, 405822L, 435844L, 385155L, 379150L, 317841L, 258185L, 193023L, 154406L, 112987L, 89944L, 73858L, 63570L, 54955L, 47194L, 30300L, 28748L, 29419L, 26635L, 20166L, 16673L, 10857L, 8189L, 4839L, 3333L, 2287L, 1458L, 984L, 644L, 488L, 967L) +# rus2010m <- c(842354L, 859562L, 849138L, 788376L, 744105L, 750282L, 748514L, 746626L, 709493L, 675127L, 683827L, 656887L, 678395L, 669374L, 696685L, 743449L, 774172L, 800765L, 923952L, 1035555L, 1167860L, 1187193L, 1252421L, 1300116L, 1262584L, 1247974L, 1230926L, 1249086L, 1156502L, 1125283L, 1182017L, 1088248L, 1073221L, 1038733L, 1051852L, 1046293L, 1008882L, 983045L, 985075L, 949072L, 980924L, 881915L, 866214L, 859808L, 885432L, 926771L, 951739L, 1015812L, 1051749L, 1093184L, 1155128L, 1076307L, 1043777L, 1005283L, 967830L, 964217L, 919814L, 837341L, 841362L, 789019L, 787516L, 775999L, 585545L, 624976L, 471186L, 295668L, 222526L, 205594L, 336318L, 431670L, 471562L, 485883L, 446533L, 438107L, 337694L, 273086L, 198303L, 190828L, 210878L, 195219L, 200564L, 162820L, 151191L, 120794L, 93394L, 66247L, 48072L, 32932L, 23840L, 18087L, 13839L, 10228L, 7790L, 4327L, 3544L, 3137L, 2380L, 1666L, 1137L, 687L, 1379L) +# # MALE BIRTHS IN RUSSIA 2002--2010 (https://www.fedstat.ru/indicator/31606) +# births <- c( +# 719511L, 760934L, 772973L, 749554L, 760831L, +# 828772L, 880543L, 905380L, 919639L +# ) +# +# +# c1 = rus2002m; c2 = rus2010m +# +# date1 = "2002-10-16"; date2 = "2010-10-25"; age1 = 0:100; age2 = 0:100 +# +# date1 <- dec.date(date1) +# date2 <- dec.date(date2) +# +# # let's store the proportions separately +# f1 <- date1 %>% subtract(date1 %>% floor) +# f2 <- date2 %>% subtract(date2 %>% floor) +# +# # IK: do we plan to allow age1 != age2 ? +# # TR: for now we force them to be equal. Later a wrapper can take care of cleaning up these details. +# # we have OPAG() to extend open ages; graduate() to spit to single- +# # any other adjustments should be done in advance (smoothing, __ ) +# +# c1c <-census_cohort_adjust(c1, age1, date1) +# c2c <-census_cohort_adjust(c2, age2, date2) +# +# # correction for the first year age 0 -- only take first for the remaining of the year +# births[1] <- births[1] * (1 - f1) # TR: good +# +# # TR: correction for the last year age 0 +# n_yrs <- length(births) +# births[n_yrs] <- births[n_yrs] * f2 +# +# # input +# input <- tibble( +# cohort = c1c$cohort, +# pop = c1c$pop +# ) %>% +# arrange(cohort) %>% +# bind_rows( +# tibble( +# cohort = 1:length(births) + floor(date1) - 1, +# pop = births +# ) +# ) %>% +# # treat the duplicated cohort of the first census year, 2002 +# group_by(cohort) %>% +# summarise( +# pop = pop %>% sum, +# .groups = "drop" +# ) +# +# # population c2 observed +# pop_c2 <- tibble( +# cohort = c2c$cohort, +# pop_c2_obs = c2c$pop +# ) +# +# # # cohort survival to the second census +# # input %>% +# # left_join(px_cum, by = "cohort") %>% +# # mutate(pop_c2_prj = pop * coh_p) %>% +# # left_join(pop_c2, by = "cohort") %>% +# # mutate( +# # discrepancy = pop_c2_obs - pop_c2_prj, +# # disc_rel = discrepancy / pop_c2_obs * 100 +# # ) +# +# +# # estimates of jan 1 population, +# # prior to redistribution of the residual +# # includes partial year estimate on the right-hand side, +# # excludes c1. +# +# pop_jan1_pre <- +# px_triangles %>% +# group_by(year, cohort) %>% +# summarise( +# n_triangles = n(), +# coh_p = value %>% prod, +# .groups = "drop" +# ) %>% +# arrange(cohort, year) %>% +# group_by(cohort) %>% +# mutate(coh_lx = cumprod(coh_p)) %>% +# ungroup() %>% +# left_join(input, by = "cohort") %>% +# mutate( +# pop_jan1_pre = pop * coh_lx, +# age = floor(year) - cohort, +# year = floor(year) + 1, +# year = ifelse(year == max(year), year + f2 - 1, year) +# ) +# +# resid <- +# pop_jan1_pre %>% +# dplyr::filter(year == max(year)) %>% +# left_join(pop_c2, by = "cohort") %>% +# mutate( +# resid = pop_c2_obs - pop_jan1_pre, +# rel_resid = resid / pop_c2_obs +# ) %>% +# select(cohort, resid) +# +# # determine uniform error discounts: +# +# resid_discounts <- +# approx( +# x=c(date1, date2), +# y=c(0,1), +# xout=seq(ceiling(date1),floor(date2)) +# ) %>% +# as.data.frame() %>% +# select(year = x, discount= y) +# +# pop_jan1 <- +# pop_jan1_pre %>% +# left_join(resid, by = "cohort") %>% +# left_join(resid_discounts, by = "year") %>% +# mutate( +# resid = ifelse(is.na(resid),0,resid), +# discount = ifelse(year == max(year),1,discount), +# pop_jan1 = pop_jan1_pre + resid * discount +# ) +# +# pop_jan1 %>% +# # reshape2::acast(age~year, value.var = "pop_jan1") %>% +# select(age, year, pop_jan1) %>% +# pivot_wider(names_from = year, values_from = "pop_jan1") %>% +# view() +# +# } +# +# + +# This script does nothing yet, still in development, deciding how to +# graduate abridged lifetables + +# This is a temporary script to hold a utility function for +# interp_coh() + +# goal will be to fill a mortality surface between two censuses. +# args should be date1, date2, location + +# A few temporary functions internal to interp_coh(). These can be replaced as better +# or more efficient options become available. + +lt_a2s_chunk <- function(chunk, OAnew, ...){ + nMx <- chunk$mx + Age <- chunk$x + lt_abridged2single(nMx = nMx, + Age = Age, + OAnew = OAnew, + control = list(deg = 3, lambda = 100), + ...) +} + + +# lxMat <-suppressMessages(lapply(dates_out,fertestr::FetchLifeTableWpp2019, +# locations = location, +# sex = sex) %>% +# lapply("[[","lx") %>% +# dplyr::bind_cols() %>% +# as.matrix()) + +interp_coh_lxMat_pxt <- function(lxMat, + dates_lx, + age_lx, + date1, + date2, + OAnew, ...){ + # TR: this is a temp functin, a stop-gap. Some redundant code with + # interp_coh_download_mortality(), which it itself temporary. + # the age graduation will move to lt_abridged2single() as soon as it's + # fixed. + date1 <- dec.date(date1) + date2 <- dec.date(date2) + + year1 <- floor(date1) + 1 + year2 <- floor(date2) + + year_seq <- year1:year2 + + dates_out <- c(dec.date(date1), year_seq) + + # get ndx andnLx from lt_abridged() + + a1 <- 0:OAnew + qx1 <- matrix(ncol = ncol(lxMat), + nrow = length(a1), + dimnames = list(a1, + dates_lx)) + for (i in 1:ncol(lxMat)){ + + if (is_abridged(age_lx)){ + # LTA <- lt_abridged(Age = age_lx, + # lx = lxMat[, i], + # OAnew = OAnew, + # radix = 1e6, + # ...) + LT1 <- lt_abridged2single(lx = lxMat[, i], + Age = age_lx, + OAnew = OAnew, + ...) + qx1[, i] <- LT1$nqx + } else { + qx <- lt_id_l_q(lxMat[, i]) + + LT1 <- lt_single_qx(nqx = qx, + Age=1:length(qx)-1, + OAnew = OAnew, + ...) + + + qx1[, i] <- LT1$nqx + } + + } + + # We do linear interpolation of the logit-transformed qx. + logit_qx <- log(qx1 / (1 - qx1)) + + logit_qx_interp <- + interp( + popmat = logit_qx, + datesIn = dates_lx, + datesOut = dates_out, + rule = 2) + # transform back + QX <- exp(logit_qx_interp) / (1 + exp(logit_qx_interp)) + + QX[nrow(QX), ] <- 1 + + + f1 <- diff(dates_out)[1] + f2 <- date2 - floor(date2) + + # assume linear px change within age class + PX <- 1 - QX + PX[,1] <- PX[, 1] ^f1 + PX[,ncol(PX)] <- PX[, ncol(PX)] ^f2 + + + PX +} + + +transform_pxt <- function(lxMat, + location, + sex, + date1, + date2, + dates_lx, + verbose, + age_lx, + age1, + ...) { + + # get the lexis surface of survival probabilities + if (is.null(lxMat)){ + + pxt <- suppressMessages( + interp_coh_download_mortality(location = location, + sex = sex, + date1 = date1, + date2 = date2, + OAnew = max(age1) + 1, + verbose = verbose) + ) + } else { + + if (is.null(dates_lx)){ + # if lx dates not given we assume dates evenly distributed from date1 to date2? + dates_lx <- seq(date1,date2,length.out = ncol(lxMat)) + if (verbose) { + cat("lxMat specified, but not dates_lx\nAssuming:",paste(dates_lx,collapse=", "),"\n") + } + } + + available_dates <- data.table::between(dates_lx, date1, date2) + if (!all(available_dates)) stop("All `dates_lx` must be within the range of `date1` and `date2`") + + # if the shortest distance from dates_lx to date1 or date2 is greater than 7 + # warn + dates_df <- expand.grid(dates_lx = dates_lx, dates = c(date1, date2)) + dates_df$diff <- with(dates_df, abs(dates_lx - dates)) + if (min(dates_df$diff) > 7 && verbose) { + d_lx <- dates_df$dates_lx[which.min(dates_df$dif)] + date_compare <- dates_df$dates[which.min(dates_df$dif)] + cat( + "The shortest distance from `dates_lx` (", + d_lx, + ") to `date1/date2`(", + date_compare, + ") is greater than 7 years. Be wary." + ) + } + + ic_period <- date2 - date1 + lx_mm <- range(dates_lx) + overlap <- min(c(lx_mm[2], date2)) - c(max(lx_mm[1], date1)) + extrap_low <- lx_mm[1] - min(lx_mm[1],date1) + extrap_high <- max(lx_mm[2],date2) - lx_mm[2] + t1 <- overlap / ic_period < .25 + t2 <- extrap_low > 6 + t3 <- extrap_high > 6 + if (any(c(t1, t2, t3))) cat("\nRange between `date1` and `date2` must overlap with `lx_dates` for at least 25% of the range or 6 years.\n") + + if (is.null(age_lx)){ + if (nrow(lxMat) < 26){ + + N <- nrow(lxMat) + age_lx <- c(0,1,seq(5,5*(N-2),by=5)) + } else { + age_lx <- 1:nrow(lxMat) - 1 + } + if (verbose) { + cat("lxMat specified, but Age_lx missing\nAssuming:",paste(age_lx,collapse=", "),"\n") + } + } + + # ensure lx fills timepoints. + # would like to pass ... here for the lifetable part + pxt <- interp_coh_lxMat_pxt( + lxMat = lxMat, + dates_lx = dates_lx, + age_lx = age_lx, + date1 = date1, + date2 = date2, + OAnew = max(age1) + 1, + control = list(deg = 3, lambda = 100), + ...) + } + + pxt +} + + +check_args <- function(lxMat, births, location, age1, age2, c1, c2, verbose) { + stopifnot(length(age1) == length(c1)) + stopifnot(length(age2) == length(c2)) + stopifnot(is_single(age1)) + stopifnot(is_single(age2)) + + if (length(age1) != length(age2) & verbose){ + cat("\nFYI: age ranges are different for c1 and c2\nWe'll still get intercensal estimates,\nbut returned data will be chopped off after age", max(age1), "\n") + } + + + # If lxMat or births are missing -- message requiring location and sex + if (is.null(lxMat) & is.null(location)) { + stop("lxMat not specified, please specify location and sex\n") + } + if (is.null(births) & is.null(location)) { + stop("births not specified, please specify location and sex\n") + } + + if (!is.null(lxMat) && ncol(lxMat) == 1) { + stop("lxMat should have at least two or more dates as columns. lxMat contains only one column") #nolintr + } + + if (any(c1 < 0)) stop("No negative values allowed in `c1`") + if (any(c2 < 0)) stop("No negative values allowed in `c2`") + if (any(lxMat < 0)) stop("No negative values allowed in `lxMat`") + +} + +# If dates_out not given, then we resolve using the midyear argument. +# If FALSE (default) we return intermediate Jan 1, not including c1 and c2 +# If TRUE we return intermediate July 1 (.5) dates, not including c1 and c2 +transform_datesout <- function(dates_out, date1, date2, midyear) { + + if (is.null(dates_out)){ + if (! midyear){ + # jan 1 dates + left_date <- floor(date1) + 1 + right_date <- ceiling(date2) - 1 + dates_out <- left_date:right_date + } + if (midyear){ + left_date <- floor(date1) + .5 + right_date <- ceiling(date2) - .5 + dates_out <- left_date:right_date + dates_out_lgl <- data.table::between(dates_out, + date1, + date2, + incbounds = FALSE) + dates_out <- dates_out[dates_out_lgl] + } + } + + dates_out +} + +reshape_pxt <- function( + pxt, + births, + c1, + c2, + age1, + age2, + date1, + date2, + f1, + f2, + yrs_births + ) { + + # Since we're using data.table, we need to create these empty + # variables to avoid having R CMD checks with no visible binding + # for global variable. + + age <- NULL + year <- NULL + px <- NULL + lower <- NULL + upper <- NULL + triangle <- NULL + adj <- NULL + value <- NULL + pop <- NULL + coh_p <- NULL + coh_lx <- NULL + pop_c2_obs <- NULL + x <- NULL + y <- NULL + discount <- NULL + .N <- NULL + . <- NULL + + px_triangles <- + pxt %>% + data.table::as.data.table(keep.rownames = "age") %>% + data.table::melt( + id.vars = "age", + variable.name = "year", + value.name = "px", + variable.factor = FALSE + ) + + # No need for assignment: data.table assigns without creating a copy + px_triangles[, `:=`(age = as.numeric(age), + year = as.numeric(year), + lower = magrittr::raise_to_power(px, 0.5), + upper = magrittr::raise_to_power(px, 1 - 0.5))] + + px_triangles <- + px_triangles[, list(age, year, lower, upper)] %>% + data.table::melt( + id.vars = c("age", "year"), + measure.vars = c("lower", "upper"), + variable.name = "triangle", + value.name = "value", + variable.factor = FALSE + ) + + px_triangles[, `:=`(adj = ifelse(triangle == "upper", 1, 0))] + px_triangles[, `:=`(cohort = magrittr::subtract(year, age) %>% magrittr::subtract(adj) %>% floor())] + + # cohort changes over the whole period + # px_cum1 <- px_triangles[, list(n_triangles = .N, coh_p = prod(value)), + # keyby = list(cohort)] + + # adjust the census population vectors + c1c <- shift_census_ages_to_cohorts(c1, age1, date1, censusYearOpt = "frac") + c2c <- shift_census_ages_to_cohorts(c2, age2, date2, censusYearOpt = "frac") + + # correction for the first year age 0 -- only take first for the remaining of + # the year + births[1] <- births[1] * (1 - f1) + + # correction for the last year age 0 + n_yrs <- length(births) + births[n_yrs] <- births[n_yrs] * f2 + + cohort_dt <- + data.table::data.table( + cohort = yrs_births, + pop = births + ) + + input <- + data.table::data.table(cohort = c1c$birth_year, pop = c1c$cohort_size) %>% + .[order(cohort)] %>% + rbind(cohort_dt) %>% + .[, list(pop = sum(pop)), keyby = list(cohort)] + + # population c2 observed + pop_c2 <- data.frame( + cohort = c2c$birth_year, + pop_c2_obs = c2c$cohort_size + ) + + pop_jan1_pre <- + px_triangles %>% + .[, list(n_triangles = .N, coh_p = prod(value)), keyby = list(year, cohort)] %>% + .[order(cohort, year)] + + pop_jan1_pre[, `:=`(coh_lx = cumprod(coh_p)), keyby = list(cohort)] + + pop_jan1_pre <- pop_jan1_pre[input, on = "cohort"] + + pop_jan1_pre[, `:=`( + pop_jan1 = pop * coh_lx, + age = floor(year) - cohort, + year = floor(year) + 1 + )] + + pop_jan1_pre[, `:=`(year = ifelse(year == max(year), year + f2 - 1, year))] + # calculate the discrepancy (migration) -- to be disrtibuted uniformly in + # cohorts + resid <- + pop_jan1_pre %>% + .[year == max(year)] %>% + .[pop_c2, on = "cohort"] + + resid[, `:=`(resid = pop_c2_obs - pop_jan1)] + # Only used in the process for diagnostics + # resid[, `:=`(rel_resid = resid / pop_c2_obs)] + resid <- resid[, list(cohort, resid)] + + # This should just be one value per cohort. + + # determine uniform error discounts: + resid_discounts <- + stats::approx( + x = c(date1, date2), + y = c(0, 1), + xout = yrs_births + ) %>% + data.table::as.data.table() %>% + .[, list(year = x, discount = y)] + + # output + pop_jan1 <- + pop_jan1_pre %>% + merge(resid, by = "cohort", all = TRUE) %>% + merge(resid_discounts, by = "year", all = TRUE) + + # for the residual discount, account for boundaries + pop_jan1[, `:=`( + resid = ifelse(is.na(resid), 0, resid), + discount = ifelse(year == max(year), 1, discount) + )] + + + pop_jan1 +} + +rup <- function( + c1, + c2, + date1, + date2, + age1, + age2, + dates_out, + lxMat, + age_lx, + dates_lx, + births, + years_births, + location, + sex, + midyear, + verbose, + ... + ) { + + check_args( + lxMat = lxMat, + births = births, + location = location, + age1 = age1, + age2 = age2, + c1 = c1, + c2 = c2, + verbose = verbose + ) + + if (is.na(date1) | is.na(date2)){ + stop("\nCensus dates didn't parse\n") + } + + # TR: resolve dates_out + # if some dates were given, let's coerce to numeric and ensure valid + if (!is.null(dates_out)){ + dates_out <- sapply(dates_out, dec.date) + if (any(is.na(dates_out))){ + cat("\nSome dates_out didn't parse, FYI, you should have a look\n") + dates_out <- dates_out[!is.na(dates_out)] + } + if (length(dates_out) == 0){ + stop("\nno valid dates to interpolate to\n") + } + + # if we still have valid dates, then check we're not extrapolating + dates_out_keep <- data.table::between(dates_out, + date1, + date2, + incbounds = FALSE) + + dates_out_for_real <- dates_out[dates_out_keep] + + # warn about any dates lost due to extrap request: + if (length(dates_out_for_real) != length(dates_out) & verbose){ + cat("\nFollowing dates requested, but not returned\nbecause they'd require extrapolation:\n",paste(dates_out[!dates_out_keep],collapse = ", "),"\n") + } + if (length(dates_out) == 0){ + stop("\nuh oh! This method is strictly for cohort component interpolation\nYour requested dates_out didn't have anything between date1 and date2\n") + } + } + + # If dates_out not given, then we resolve using the midyear argument. + # If FALSE (default) we return intermediate Jan 1, not including c1 and c2 + # If TRUE we return intermediate July 1 (.5) dates, not including c1 and c2 + dates_out <- transform_datesout(dates_out, date1, date2, midyear) + + DD <- date2 - date1 + if (DD >= 15 & verbose){ + cat("\nFYI, there are",DD,"years between c1 and c2\nBe wary.\n") + } + + # let's store the proportions separately + f1 <- date1 %>% magrittr::subtract(date1 %>% floor) + f2 <- date2 %>% magrittr::subtract(date2 %>% floor) + + # And download if needed + pxt <- transform_pxt( + lxMat = lxMat, + location = location, + sex = sex, + date1 = date1, + date2 = date2, + dates_lx = dates_lx, + verbose = verbose, + age_lx = age_lx, + age1 = age1, + ... = ... + ) + + yrs_births <- seq(floor(date1), floor(date2), 1) + # TR: if right-side is jan 1 then we can cut it off of pxt. + if (f2 == 0){ + pxt <- pxt[, -ncol(pxt), drop = FALSE] + yrs_births <- yrs_births[-length(yrs_births)] + f2 <- 1 + } + + # Download wpp births if needed + births <- + fetch_wpp_births( + births = births, + yrs_births = yrs_births, + location = location, + sex = sex, + verbose = verbose + ) + + # check length of births, also filter using provided dates if necessary + if (!is.null(years_births)){ + stopifnot(length(births) == length(years_births)) + + years_births <- floor(years_births) + yrs_keep <- data.table::between(years_births, + min(yrs_births), + max(yrs_births), + incbounds = TRUE) + + births <- births[yrs_keep] + } + + # now that births should be available we can do this check. + stopifnot(length(births) == length(yrs_births)) + + pop_jan1 <- reshape_pxt( + pxt = pxt, + births = births, + c1 = c1, + c2 = c2, + age1 = age1, + age2 = age2, + date1 = date1, + date2 = date2, + f1 = f1, + f2 = f2, + yrs_births = yrs_births + ) + + list( + pop_jan1 = pop_jan1, + dates_out = dates_out + ) +} diff --git a/R/interp_lc_lim.R b/R/interp_lc_lim.R new file mode 100644 index 000000000..281cbf434 --- /dev/null +++ b/R/interp_lc_lim.R @@ -0,0 +1,514 @@ +#' Lee-Carter method with limited data. +#' +#' @description Given a data frame with dates, sex and mortality data by age (rates, conditionated probabilities of death +#' or survival function), this function interpolate/extrapolate life tables +#' using the method for limited data suggested by Li et. al (2004) (at least three observed years). +#' +#' @details Based on spreedsheet "Li_2018_Limited_Lee-Carter-v4.xlsm" from UN. +#' Useful for abridged or single ages, and allows output in both formats also. +#' One option is the use of non-divergent method for sex coherency (Li & Lee, 2005). +#' The other is the possibility of fitting `"k"` to replicate `"e_0"` at some given dates. +#' +#' @note Draft Version +#' +#' @param input data.frame with cols: Date, Sex, Age, nMx (opt), nqx (opt), lx (opt) +#' @param dates_out numeric. Vector of decimal years to interpolate or extrapolate. +#' @param Single logical. Wheter or not the lifetable output is by single ages. +#' @param dates_e0 numeric. Vector of decimal years where `"e_0"` should be fitted when apply method. +#' @param e0_Males numeric. Vector of life expectancy by year to be fitted. Same length than `"dates_e0"`. +#' @param e0_Females numeric. Vector of life expectancy by year to be fitted. Same length than `"dates_e0"`. +#' @param prev_divergence logical. Whether or not prevent divergence and sex crossover. Default `FALSE.` +#' @param OAG logical. Whether or not the last element of `nMx` (or `nqx` or `lx`) is an open age group. Default `TRUE.` +#' @param verbose logical. Default `FALSE`. +#' @param SVD logical. Use Singular Value Decomposition for estimate b and k or Maximum Likelihood Estimation. Default `FALSE` for Maximum Likelihood Estimation. +#' @param ... Other arguments to be passed on to the \code{\link[DemoTools]{lt_abridged}} function. +#' @seealso +#' \code{\link[DemoTools]{lt_abridged}} +#' @export +# TR: you can use markdown for this sort of thing, just getting used to it +#' @return List with: +#' \itemize{ +#' \item Interpolated/extrapolated lifetables in a data.frame with columns: +#' * `Date` numeric. Dates included in dates_out, +#' * `Sex` character. Male `"m"` or female `"f"`, +#' * `Age` integer. Lower bound of abridged age class, +#' * `AgeInt`` integer. Age class widths. +#' * `nMx` numeric. Age-specific central death rates. +#' * `nAx` numeric. Average time spent in interval by those deceased in interval. +#' * `nqx` numeric. Age-specific conditional death probabilities. +#' * `lx` numeric. Lifetable survivorship +#' * `ndx` numeric. Lifetable deaths distribution. +#' * `nLx` numeric. Lifetable exposure. +#' * `Sx` numeric. Survivor ratios in uniform 5-year age groups. +#' * `Tx` numeric. Lifetable total years left to live above age x. +#' * `ex` numeric. Age-specific remaining life expectancy. +#' \item List with estimated Lee-Carter parameters for each sex: +#' * `kt` numeric time vector. Time trend in mortality level. +#' * `ax` numeric age vector. Average time of `log(m_{x,t})`. +#' * `bx` numeric age vector. Pattern of change in response to `kt`. +#' } +#' @references +#' \insertRef{Li2005}{DemoTools} +#' \insertRef{Li2004}{DemoTools} +#' +#' @examples +#' # mortality rates from Sweden, for specific dates + +#' +#' # needs mortality rates in this dates: +#' dates_out <- as.Date(paste0(seq(1948,2018,5),"-07-01")) +#' +#' # apply LC with limited data to extrap/interpolate +#' lc_lim_data <- interp_lc_lim(input = mA_swe, dates_out = dates_out, OAG = FALSE)$lt_hat +#' +#' \dontrun{ +#' lc_lim_data %>% ggplot(aes(Age,nMx,col=factor(round(Date,1)))) + +#' geom_step() + scale_color_viridis_d() + +#' scale_y_log10() + theme_classic() + facet_wrap(~Sex) +#' } +#' +#' # with simple ages as output +#' lc_lim_data_single <- interp_lc_lim(input = mA_swe, dates_out = dates_out, OAG = FALSE, +#' Single = TRUE)$lt_hat +#' +#' \dontrun{ +#' lc_lim_data_single %>% ggplot(aes(Age,nMx,col=factor(round(Date,1)))) + +#' geom_step() + scale_color_viridis_d() + +#' scale_y_log10() + theme_classic() + facet_wrap(~Sex) +#' } +#' +#' # Avoiding cross-over between sex. +#' lc_lim_nondiv <- interp_lc_lim(input = mA_swe, dates_out = dates_out, OAG = FALSE, +#' prev_divergence = TRUE)$lt_hat +#' \dontrun{ +#' lc_lim_nondiv %>% ggplot(aes(Age,nMx,col=factor(round(Date,1)))) + +#' geom_step() + scale_color_viridis_d() + +#' scale_y_log10() + theme_classic() + facet_wrap(~Sex) +#' } +#' +#' # Fitting information about e0 in Sweden for past years. +#' lc_lim_fite0 <- interp_lc_lim(input = mA_swe, dates_out = dates_out, OAG = FALSE, +#' dates_e0 = unique(e0_swe$Date), +#' e0_Males = e0_swe$e0[e0_swe$Sex=="m"], +#' e0_Females = e0_swe$e0[e0_swe$Sex=="f"])$lt_hat +#' \dontrun{ +#' ggplot() + +#' geom_point(data = e0_swe, aes(Date,e0,col=factor(Sex)))+ +#' geom_line(data = lc_lim_fite0[lc_lim_fite0$Age==0,], aes(Date,ex,col=factor(Sex)))+ +#' labs(color = "Sex")+ +#' theme_classic() +#' } +#' +#' # smooth and/or extend open age group, in this case input is for 80+, and chosen law is Makeham. +#' lc_lim_extOAg <- interp_lc_lim(input = mA_swe[mA_swe$Age<=80,], dates_out = dates_out, +#' OAG = FALSE, +#' OAnew=100, +#' extrapLaw = "makeham")$lt_hat +#' \dontrun{ +#' ggplot() + +#' geom_step(data = lc_lim_extOAg, aes(Age,nMx,col=factor(round(Date,1)))) + +#' scale_y_log10() + scale_color_viridis_d() + theme_classic() + facet_wrap(~Sex) +#' } +#' #End + +interp_lc_lim <- function(input = NULL, + dates_out = dates_in, + Single = FALSE, + dates_e0 = NULL, + e0_Males = NULL, + e0_Females = NULL, + prev_divergence = FALSE, + OAG = TRUE, + verbose = TRUE, + SVD = FALSE, + ...){ + + # TR: ExtraArgs has a problem in that it won't capture & pass NULL defaults + # mget(names(formals()),sys.frame(sys.nframe())) + # IW: this captures everything: dots & NULLS + ExtraArgs = c(as.list(environment()), list(...)) + ExtraArgs = ExtraArgs[! names(ExtraArgs) %in% c("input","Single")] + + # dates + dates_in <- unique(input$Date) %>% dec.date() + dates_out <- dec.date(dates_out) + + # take care if lc with limited data is suitable + if (length(dates_in)<3){ + stop("\nYou need three observed dates at least.") + } + if (all(diff(dates_in)==1)){ + stop("\nYou have single-year-interval data and probably should use basic Lee-Carter method.") + } + + # Two tries for dates_e0, otherwise we error + if(!is.null(e0_Males)){ + if (is.null(dates_e0)){ + if (length(e0_Males) == length(dates_in)){ + dates_e0 <- dates_in + if (verbose){ + cat("\ndates_e0 not specified, assuming:\n",paste(dates_in,collapse = ", "),"\n" ) + } + } + } + if (is.null(dates_e0)){ + if (length(e0_Males) == length(dates_out)){ + dates_e0 <- dates_out + if (verbose){ + cat("\ndates_e0 not specified, assuming:\n",paste(dates_out, collapse = ", "),"\n" ) + } + } + } + if (is.null(dates_e0)){ + stop("\nSorry we can't guess the argument dates_e0, you'll need to specify it\n") + } + } + + if (!any(names(input)%in%c("nMx", "nqx", "lx"))){ + stop("\nSorry we need some column called nMx, nqx or lx\n") + } + + # get always Mx ----------------------------------------------------------- + + # TR data.table() is preferred, + # and maybe this function shouldn't be anonymous, but rather called inside + # inputdt[, new_function(.SD,...),by=list(Sex,Date)] # or similar. + . <- NULL + # inputdt <- split(input, list(input$Sex, input$Date)) %>% + # lapply( + # function(X) do.call(lt_smooth_ambiguous, + # c(list(input=X), ExtraArgs))) %>% + # do.call("rbind", .)%>% + # as.data.table() + + inputdt <- split(input, list(input$Sex, input$Date)) %>% + lapply( function(X) { + + Age <- X$Age + Sex_i <- unique(X$Sex) + + types <- c("nMx","nqx","lx") + this_type <- types[types %in% colnames(X)] + if (length(this_type) > 1){ + ind <- X[,this_type] %>% + as.matrix() %>% + is.na() %>% + colSums() %>% + which.min() + this_type <- this_type[ind] + } + + LT <- lt_ambiguous(nMx_or_nqx_or_lx = X[[this_type]], + type = this_type, + Age = Age, + Sex = Sex_i, + Single = Single, + ...) + LT$Sex <- Sex_i + LT$Date <- unique(X$Date) + LT + }) %>% + do.call("rbind", .)%>% + as.data.table() + + + # avoids 'no visible binding' warning + Sex <- NULL + + nMxf <- + inputdt %>% + subset(Sex == "f") %>% + data.table::dcast(Age ~ Date, value.var = "nMx") %>% + .[order(Age)] + Age <- nMxf[["Age"]] + + nMxf <- nMxf[, -1] %>% as.matrix() + rownames(nMxf) <- Age + + nMxm <- + inputdt %>% + subset(Sex == "m") %>% + data.table::dcast(Age ~ Date, value.var = "nMx") %>% + .[order(Age)] + nMxm <- nMxm[, -1] %>% as.matrix() + rownames(nMxm) <- Age + + # LC at unequal intervals --------------------------------------------------------- + + #Age = sort(unique(input$Age)) # defined above for rownames + ndates_in <- length(dates_in) + ndates_out <- length(dates_out) + nAge <- length(Age) + + # males + lc_estimate_m <- interp_lc_lim_estimate(nMxm, dates_in, dates_out, SVD) + axm <- lc_estimate_m[[1]] + bxm <- lc_estimate_m[[2]] + ktm <- lc_estimate_m[[3]] + k0m <- lc_estimate_m[[4]] + # females + lc_estimate_f <- interp_lc_lim_estimate(nMxf, dates_in, dates_out, SVD) + axf <- lc_estimate_f[[1]] + bxf <- lc_estimate_f[[2]] + ktf <- lc_estimate_f[[3]] + k0f <- lc_estimate_f[[4]] + + # ask if prevent divergence and replicate target e0 --------------------------------------------------------- + + if (is.null(dates_e0)){ # not rep e0 + + # basic + nMxm_hat <- exp(axm + bxm %*% t(ktm)) + nMxf_hat <- exp(axf + bxf %*% t(ktf)) + + # avoid divergence extrapolating + if (prev_divergence){ + kt = (ktm + ktf) * .5 # equal size male and female + bx = (bxm + bxf) * .5 # # error in vba code line 335. A parameter controls that only for reproducing purpose + k0 = (k0m + k0f) * .5 + + # apply common factor to rates with already specific factor (formula 6 in Li (2005)), + # not like Li´s paper way in this case. IW: we can improve this if UN wants. + nMxm_hat_div <- nMxm[,1] * exp(bx %*% t(kt-k0)) + nMxf_hat_div <- nMxf[,1] * exp(bx %*% t(kt-k0)) + + # only for those years before min(dates_in). UN code explicit on that. + # IW: why not for dates_out>max(dates_in) also? Ask UN. + dates_extrap <- dates_out < min(dates_in) + nMxm_hat[,dates_extrap] <- nMxm_hat_div[,dates_extrap] + nMxf_hat[,dates_extrap] <- nMxf_hat_div[,dates_extrap] + } + } else { # fit e0 at each target year + stopifnot(length(e0_Males) == length(dates_e0)) + stopifnot(length(e0_Females) == length(dates_e0)) + # stepwise linear intra/extrapolation to target years. + # IW: Use interp(). Accepts matrix, so have to rbind and only get 1st row + e0m <- interp(rbind(e0_Males, + e0_Males), + dates_e0, + dates_out, + extrap = TRUE)[1, ] + + e0f <- interp(rbind(e0_Females, + e0_Females), + dates_e0, + dates_out, + extrap = TRUE)[1, ] + + # avoid divergence: same bx but not kt. + if (prev_divergence){ + bxm <- bxf <- (bxm + bxf) * .5 + } + + # Optimize kt for each LC extrap/interp and sex + ktm_star = ktf_star = c() + for (j in 1:ndates_out){ + ktm_star[j] <- optimize(f = interp_lc_lim_kt_min, + interval = c(-20, 20), + ax = axm, + bx = bxm, + age = Age, + sex = "m", + e0_target = e0m[j], + ...)$minimum + ktf_star[j] <- optimize(f = interp_lc_lim_kt_min, # TR: add ... + interval = c(-20, 20), + ax = axf, + bx = bxf, + age = Age, + sex = "f", + e0_target = e0f[j], + ...)$minimum + } + + # get rates with optim k. + nMxm_hat <- exp(axm + bxm %*% t(ktm_star)) + nMxf_hat <- exp(axf + bxf %*% t(ktf_star)) + ktm <- ktm_star + ktf <- ktf_star + } + + # life tables output ------------------------------------------------------------ + + colnames(nMxm_hat) <- dates_out + colnames(nMxf_hat) <- dates_out + . = NULL + + Males_out <- + lapply(colnames(nMxm_hat), function(xx,MX,Age) { + + mx <- MX[, xx] + LT <- lt_ambiguous(nMx_or_nqx_or_lx = mx, + type = "m", + Age = Age, + Sex = "m", + Single = Single, + ...) + LT$Sex <- "m" + LT$Date <- as.numeric(xx) + LT + + }, MX = nMxm_hat, Age = Age) %>% + do.call("rbind", .) + + Females_out <- + lapply(colnames(nMxf_hat), function(xx,MX,Age) { + mx <- MX[, xx] + LT <- lt_ambiguous(nMx_or_nqx_or_lx = mx, + type = "m", + Age = Age, + Sex = "f", + Single = Single, + ...) + LT$Sex <- "f" + LT$Date <- as.numeric(xx) + LT + }, MX = nMxf_hat, Age = Age) %>% + do.call("rbind", .) + lt_hat <- rbind(Males_out, Females_out) + + # for output + lc_params <- list(ax = data.frame(Male = axm, Female = axf), + bx = data.frame(Male = bxm, Female = bxf), + kt = data.frame(Male = ktm, Female = ktf)) + return(list(lt_hat = lt_hat, + lc_params = lc_params) + ) +} + +#' Optimize k +#' @description Optimize estimated k from LC with limited data model, +#' for fitting given e_0 at same dates +#' @details Given LC parameters at some date, change a bit k for replicate already know e_0 values. +#' This is useful to give some sort of flexibility, and not follow strictly linear model implied in LC model, +#' but taking advantage of estimated structure (ax) and change by age (bx) for some trustable period. +#' @param k numeric. k parameter from LC model. +#' @param ax numeric. Vector (same length of age) of parameters from LC model. +#' @param bx numeric. Vector (same length of age) of parameters from LC model. +#' @param age numeric. +#' @param sex numeric. +#' @param e0_target numeric. +#' @param ... Other arguments to be passed on to the \code{\link[DemoTools]{lt_abridged}} function. +#' @export +interp_lc_lim_kt_min <- function(k, + ax, + bx, + age, + sex, + e0_target, + ...){ + Mx_hat <- as.numeric(interp_lc_lim_abk_m(k, ax, bx)) + e0 <- lt_ambiguous(nMx_or_nqx_or_lx = Mx_hat, + Age = age, + Sex = sex, + ...)$ex[1] + return(((e0-e0_target)/e0_target)^2) +} + +#' wrapper fun for `"interp_lc_lim_estimate"` function +#' @description wrapper fun to estimate rates from LC parameters +#' @inheritParams interp_lc_lim_kt_min +#' @export +interp_lc_lim_abk_m <- function(k,ax,bx){ + exp(ax + bx * k) +} + +# estimate LC for limited data +#' Estimate LC with limited data params +#' @description Estimate LC with limited data from a matrix of rates (age by dates). +#' @details SVD for ax and bx. Fit a simmple linear model for k and interp/extrapolate for objective dates. +#' @param M numeric. Matrix with many rows as ages and columns as dates_in. +#' @param dates_in numeric. Vector of dates with input rates. +#' @param dates_out numeric. Vector of dates for estimate a set of rates. +#' @param SVD logical. Use Singular Value Decomposition for estimate b and k or Maximum Likelihood Estimation. Default `FALSE` for Maximum Likelihood Estimation. +#' @references +#' \insertRef{Li2004}{DemoTools} +#' @export +interp_lc_lim_estimate <- function(M, dates_in, dates_out, SVD = F){ + ndates_in <- length(dates_in) + ax <- rowSums(log(M))/ndates_in + if(SVD==TRUE){ + # Singular Value Decomposition + M_svd <- svd(log(M)-ax) + bx <- M_svd$u[, 1]/sum(M_svd$u[, 1]) + kto <- M_svd$d[1] * M_svd$v[, 1] * sum(M_svd$u[, 1]) + }else{ + # likelihood method + kto <- colSums(log(M))-sum(ax) # because sum(bx)==1 + bx <- (log(M) - ax)%*%kto/sum(kto^2) + } + c <- 0 + c[2] <- (kto[ndates_in] - kto[1])/(dates_in[ndates_in] - dates_in[1]) + c[1] <- kto[1] - c[2] * dates_in[1] + # explanation ratio + R = 1- sum((log(M) - (ax + bx %*% t(kto)))^2)/sum((log(M)-ax)^2) + # extrapolated k + kt <- c[1] + c[2] * dates_out + # initial k (useful for avoiding divegence case) + k0 <- c[1] + c[2] * dates_in[1] + return(list(ax=ax,bx=bx,kt=kt,k0=k0,R=R)) +} + +# smooth rule previous to solve ambiguous +#' Smooth and apply lt_ambiguous +#' @description Considering different mortality input for each sex/year data, +#' smooth olders with makeham or kannisto in case no law was specified, +#' and return a data.frame with standard LT. +#' @details Makeham is chosen if last age is less than 90. Else Kannisto. +#' @param input data.frame. with cols: Date, Sex, Age, nMx (opt), nqx (opt), lx (opt) +#' @param ... Other arguments to be passed on to the \code{\link[DemoTools]{lt_abridged}} function. +#' @export +lt_smooth_ambiguous <- function(input, ...){ + + ExtraArgs = c(as.list(environment()), list(...)) + ExtraArgs = ExtraArgs[! names(ExtraArgs) %in% c("input")] + + # get only cols with values (could entry nMx for some sex/year and nqx or lx for other) + X <- input[!sapply(input, function(x) all(is.na(x)))] + + types <- c("nMx","nqx","lx") + this_type <- types[types %in% colnames(X)] + this_sex <- unique(X[["Sex"]]) + this_date <- unique(X[["Date"]]) + + # cases for smooth older ages by default + if(!"extrapLaw" %in% names(ExtraArgs)){ + Ageext <- sort(unique(X$Age)) + this_extrapFrom <- max(Ageext) + this_OAnew = 100 + if(this_extrapFrom < 90){ + this_extrapLaw <- "makeham" + if (ExtraArgs$verbose) cat(paste0("A Makeham function was fitted for older ages for sex ", + this_sex, " and date ",this_date,".\n")) + # TR: changed this. 30 could be sort of low in some situations. + this_extrapFit = Ageext[Ageext >= (this_extrapFrom - 30) & ifelse(ExtraArgs$OAG, Ageext < max(Ageext), TRUE)] + }else{ + this_extrapLaw <- "kannisto" + if (ExtraArgs$verbose) cat(paste0("A Kannisto function was fitted for older ages for sex ", + this_sex, " and date ",this_date,".\n")) + this_extrapFit = Ageext[Ageext >= 60 & ifelse(ExtraArgs$OAG, Ageext < max(Ageext), TRUE)] + } + # TR: other args not passed in are scoped one level up + thisExtraArgs <- ExtraArgs[!names(ExtraArgs) %in% + c("extrapLaw","extrapFit","extrapFrom","OAnew","Single")] + out <- lt_ambiguous(nMx_or_nqx_or_lx = X[[this_type]], + Age = X[["Age"]], + type = this_type, + Sex = this_sex, + extrapLaw = this_extrapLaw, + extrapFit = this_extrapFit, + extrapFrom = this_extrapFrom, + OAnew = this_OAnew, + ...) + }else{ + out <- lt_ambiguous(nMx_or_nqx_or_lx = X[[this_type]], + Age = X[["Age"]], + type = this_type, + Sex = this_sex, + ...) + } + + out$Sex <- this_sex + out$Date <- this_date + out +} diff --git a/R/interp_lc_lim_group.R b/R/interp_lc_lim_group.R new file mode 100644 index 000000000..502ab21e9 --- /dev/null +++ b/R/interp_lc_lim_group.R @@ -0,0 +1,305 @@ +#' Lee-Carter method with limited data for groups. + +# tests: +# Tests againts spreadsheet +# test output againts `interp_lc_lim` function. +# testing args from main fun +# mixing input: single/abr with output single/abr, and mixing input nMx and lx +# passing lt arguments +# text/messages/warnings. Specially the case when no `id` is given + +#' +#' @description Given a data frame with groups (country, region, sex), dates, sex and mortality data by age (rates, conditionated probabilities of death +#' or survival function), this function interpolate/extrapolate life tables +#' using the method for limited data suggested by Li et. al (2004) (at least three observed years). +#' +#' @details Based on spreedsheet "Li_2018_Limited_Lee-Carter-v4.xlsm" from UN. +#' Useful for abridged or single ages, and allows output in both formats also. +#' One option is the use of non-divergent method for sex coherency (Li & Lee, 2005). +#' The other is the possibility of fitting `"k"` to replicate `"e_0"` at some given dates. +#' `id` column in `input` argument works for separate between groups. In case only one population/sex is given, +#' is recommended to give some group name to `id`, if not the function will try to infer the case. +#' +#' @note Draft Version +#' +#' @param input data.frame. Columns: id, Date, Sex, Age, nMx (opt), nqx (opt), lx (opt). +#' The first column (id) cn be a numeric index or charcter vector identifying each group. +#' @param dates_out numeric. Vector of decimal years to interpolate or extrapolate. +#' @param Single logical. Wheter or not the lifetable output is by single ages. +#' @param input_e0 data.frame with cols: id, Date, Sex and `"e_0"`. This should be fitted when apply method. +#' @param prev_divergence logical. Whether or not prevent divergence and sex crossover between groups. Default `FALSE.` +#' @param weights list. For `prev_divergence` option. A double for each element of a list with names as `id` columns. Should sum up to 1. Default: same weight for each group. +#' @param OAG logical. Whether or not the last element of `nMx` (or `nqx` or `lx`) is an open age group. Default `TRUE.` +#' @param verbose logical. Default `FALSE`. +#' @param SVD logical. Use Singular Value Decomposition for estimate b and k or Maximum Likelihood Estimation. Default `FALSE` for Maximum Likelihood Estimation. +#' @param ... Other arguments to be passed on to the \code{\link[DemoTools]{lt_abridged}} function. +#' @seealso +#' \code{\link[DemoTools]{lt_abridged}} +#' @export +#' @importFrom data.table rbindlist +#' @importFrom data.table setDT +#' @importFrom data.table uniqueN +#' @return List with: +#' \itemize{ +#' \item Lifetable in a data.frame with columns: +#' * `Date` numeric. Dates included in dates_out, +#' * `Sex` character. Male `"m"` or female `"f"`, +#' * `Age` integer. Lower bound of abridged age class, +#' * `AgeInt`` integer. Age class widths. +#' * `nMx` numeric. Age-specific central death rates. +#' * `nAx` numeric. Average time spent in interval by those deceased in interval. +#' * `nqx` numeric. Age-specific conditional death probabilities. +#' * `lx` numeric. Lifetable survivorship +#' * `ndx` numeric. Lifetable deaths distribution. +#' * `nLx` numeric. Lifetable exposure. +#' * `Sx` numeric. Survivor ratios in uniform 5-year age groups. +#' * `Tx` numeric. Lifetable total years left to live above age x. +#' * `ex` numeric. Age-specific remaining life expectancy. +#' \item List with parameters estimated for each group: +#' * `kt` numeric time vector. Time trend in mortality level. +#' * `ax` numeric age vector. Average time of `log(m_{x,t})`. +#' * `bx` numeric age vector. Pattern of change in response to `kt`. +#' } +#' @references +#' \insertRef{Li2005}{DemoTools} +#' \insertRef{Li2004}{DemoTools} +#' +#' @examples +#' # mortality rates from Sweden, for specific dates. Each sex a group. +#' mA_swe$id = c(rep("A",nrow(mA_swe)/2), +#' rep("B",nrow(mA_swe)/2)) +#' +#' # needs mortality rates in this dates: +#' dates_out <- as.Date(paste0(seq(1948,2018,5),"-07-01")) +#' +#' # apply LC with limited data to extrap/interpolate +#' lc_lim_data <- interp_lc_lim_group(input = mA_swe, dates_out = dates_out) +#' +#' \dontrun{ +#' lc_lim_data[["lt_hat"]] %>% ggplot(aes(Age,nMx,col=factor(round(Date,1)))) + +#' geom_step() + scale_color_viridis_d() + +#' scale_y_log10() + theme_classic() + facet_wrap(~Sex) +#' } +#' +#' # avoid cross-over between groups +#' lc_lim_data <- interp_lc_lim_group(input = mA_swe, dates_out = dates_out, +#' prev_divergence = TRUE, weights=list(A=.4,B=.6)) +#' +#' \dontrun{ +#' lc_lim_data[["lt_hat"]] %>% ggplot(aes(Age,nMx,col=factor(round(Date,1)))) + +#' geom_step() + scale_color_viridis_d() + +#' scale_y_log10() + theme_classic() + facet_wrap(~id) +#' } + +# fun --------------------------------------------------------------------- + +interp_lc_lim_group <- function(input = NULL, + dates_out = NULL, + Single = FALSE, + input_e0 = NULL, + prev_divergence = FALSE, + weights = NULL, + OAG = TRUE, + verbose = TRUE, + SVD = FALSE, + ...){ + + # just make up empty placeholders for stuff used inside data.table + . <- NULL + Date <- NULL + id <- NULL + + ExtraArgs = c(as.list(environment()), list(...)) + ExtraArgs = ExtraArgs[! names(ExtraArgs) %in% c("input","Single")] + dates_out <- dec.date(dates_out) + ndates_out <- length(dates_out) + + # enough obs dates + min_dates_in <- min(setDT(input)[, .(count = uniqueN(Date)), + by = id][,2]) + if (min_dates_in<3){ + stop("\nYou need three observed dates at least.") + } + + # is data limited? + diff_dates_in <- unique(setDT(input)[, .(count = diff.Date(Date)), + by = id][,2]) + if (all(diff_dates_in %in% c(0,1))){ + stop("\nYou have single-year-interval data and probably should use basic Lee-Carter method.") + } + + # check input + if (!any(names(input)%in%c("nMx", "nqx", "lx"))){ + stop("\nSorry we need some column called nMx, nqx or lx\n") + } + + # TR: I commented this out. + # 1) id is used earlier than this, so there's still an error if it's missing + # 2) + # # you gave no id - save it + # if (!"id" %in% colnames(input)){ + # # but two sex + # cases <- aggregate(Age~Date+Sex,input,FUN=length) + # if(!any(cases$Age)==cases$Age[1]){ + # input$id = ifelse(Sex=="f",1,2) + # } + # } + + ngroups <- length(unique(input$id)) + groups <- unique(input$id) + # three objects, with number of elements as groups + nMx <- list() + nMx_hat <- list() + lc_estimate <- list() + + # get always Mx ----------------------------------------------------------- + . <- NULL + for(i in groups){ + input_id <- as.data.frame(input[input$id == i,]) + # inputdt <- split(input_id, list(input_id$Date)) %>% + # lapply( + # function(X) do.call(lt_smooth_ambiguous, + # c(list(input=X), ExtraArgs))) %>% + # do.call("rbind", .)%>% + # as.data.table()%>% + # data.table::dcast(Age ~ Date, value.var = "nMx") %>% + # .[order(Age)] + # + # + input_id <- as.data.frame(input[input$id == i,]) + inputdt <- split(input_id, list(input_id$Date)) %>% + lapply(., function(X) { + Age <- X$Age + Sex_i <- unique(X$Sex) + + + types <- c("nMx","nqx","lx") + this_type <- types[types %in% colnames(X)] + if (length(this_type) > 1){ + ind <- X[,this_type] %>% + as.matrix() %>% + is.na() %>% + colSums() %>% + which.min() + this_type <- this_type[ind] + } + + LT <- lt_ambiguous(nMx_or_nqx_or_lx = X[[this_type]], + type = this_type, + Age = Age, + Sex = Sex_i, + Single = Single, + ...) + + LT$Date <- unique(X$Date) + LT + }) %>% + do.call("rbind", .)%>% + as.data.table()%>% + data.table::dcast(Age ~ Date, value.var = "nMx") %>% + .[order(Age)] + + + Age <- inputdt[["Age"]] + nMx[[i]] <- inputdt[, -1] %>% as.matrix() + rownames(nMx[[i]]) <- Age + nAge <- length(Age) + + # LC and estimate + dates_in <- unique(input_id$Date) %>% dec.date() + lc_estimate[[i]] <- interp_lc_lim_estimate(nMx[[i]], dates_in, dates_out, SVD) + nMx_hat[[i]] <- exp(lc_estimate[[i]][["ax"]] + lc_estimate[[i]][["bx"]] %*% t(lc_estimate[[i]][["kt"]])) + } + + # options ----------------------------------------------------------------- + + # prevent divergence/cross-over + if (prev_divergence){ + if(ngroups==1) stop("No subgroups no divergence.") + # weigths + if(is.null(weights)){ + weights <- list() + for(i in 1:ngroups) weights[[i]] = 1/ngroups + }else{ + if(sum(unlist(weights))!=1) stop("Weights do not sum up to 1.") + } + # weighted mean of parameters + bx_div <- rep(0,nrow(lc_estimate[[1]][["bx"]])) + kt_div <- rep(0,length(lc_estimate[[1]][["kt"]])) + k0_div <- 0 + for(i in 1:ngroups){ + # i =1 + bx_div = bx_div + lc_estimate[[i]][["bx"]] * weights[[i]] + kt_div = kt_div + lc_estimate[[i]][["kt"]] * weights[[i]] + k0_div = k0_div + lc_estimate[[i]][["k0"]] * weights[[i]] + } + for(i in 1:ngroups){ + lc_estimate[[i]][["bx"]] <- bx_div + lc_estimate[[i]][["kt"]] <- kt_div + lc_estimate[[i]][["k0"]] <- k0_div + } + } + + # fit e_0 and/or prev_divergence + for(i in groups){ + ax_i <- lc_estimate[[i]][["ax"]] + bx_i <- lc_estimate[[i]][["bx"]] + kt_i <- lc_estimate[[i]][["kt"]] + k0_i <- lc_estimate[[i]][["k0"]] + e0 = input_e0[input_e0$id==i,"e0"] + dates_in <- unique(input$Date[input$id == i]) %>% dec.date() + + if (!is.null(e0)){ + dates_e0 = input_e0[input_e0$id==i,"Date"] + ndates_e0 = length(dates_e0) + Sex_e0 = unique(input_e0[input_e0$id==i,"Sex"]) + e0_star <- interp(rbind(e0, e0), + dates_e0,dates_out, + extrap = TRUE)[1, ] + kt_star = c() + for (j in 1:ndates_out){ + kt_star[j] <- optimize(f = interp_lc_lim_kt_min, + interval = c(-20, 20), + ax = ax_i, + bx = bx_i, + age = Age, + sex = Sex_e0, + e0_target = e0_star[j], + ...)$minimum + } + nMx_hat[[i]] <- exp(ax_i + bx_i %*% t(kt_star)) + }else{ + if(prev_divergence){ + nMx_hat_div <- nMx[[i]][,1] * exp(bx_i %*% t(kt_i-k0_i)) + dates_extrap <- dates_out < min(dates_in) + nMx_hat[[i]][,dates_extrap] <- nMx_hat_div[,dates_extrap] + } + } + + # return lt + colnames(nMx_hat[[i]]) <- dates_out + Sex_i = unique(input$Sex[input$id == i]) + out <- + lapply(colnames(nMx_hat[[i]]), function(xx,MX,Age) { + mx <- MX[, xx] + LT <- lt_ambiguous(nMx_or_nqx_or_lx = mx, + type = "m", + Age = Age, + Sex = Sex_i, + Single = Single, + ...) + LT$Sex <- Sex_i + LT$Date <- as.numeric(xx) + LT + }, MX = nMx_hat[[i]], Age = Age) %>% + rbindlist() + nMx_hat[[i]] <- out + } + + return(list( + lt_hat = rbindlist(nMx_hat, idcol = "id"), + lc_params = lc_estimate #IW: must bind + + )) +} + diff --git a/R/lt_abridged.R b/R/lt_abridged.R index 317575473..33ba38fd2 100644 --- a/R/lt_abridged.R +++ b/R/lt_abridged.R @@ -40,7 +40,7 @@ #' @param OAnew integer. Desired open age group (5-year ages only). Default \code{max(Age)}. If higher then rates are extrapolated. #' @param OAG logical. Whether or not the last element of \code{nMx} (or \code{nqx} or \code{lx}) is an open age group. Default \code{TRUE}. #' @param extrapLaw character. If extrapolating, which parametric mortality law should be invoked? Options include -#' \code{"Kannisto", "Kannisto_Makeham", "Makeham", "Gompertz", "GGompertz", "Beard", "Beard_Makeham", "Quadratic"}. Default \code{"Kannisto"}. See details. +#' \code{"Kannisto", "Kannisto_Makeham", "Makeham", "Gompertz", "GGompertz", "Beard", "Beard_Makeham", "Quadratic"}. Default \code{"Kannisto"} if the highest age is at least 90, otherwise `"makeham"`. See details. #' @inheritParams lt_a_closeout #' @export #' @return Lifetable in data.frame with columns @@ -179,26 +179,43 @@ lt_abridged <- function(Deaths = NULL, SRB = 1.05, OAG = TRUE, OAnew = max(Age), - extrapLaw = "kannisto", + extrapLaw = NULL, extrapFrom = max(Age), - extrapFit = Age[Age >= 60 & ifelse(OAG, Age < max(Age), TRUE)], + extrapFit = NULL, ...) { axmethod <- match.arg(axmethod, choices = c("pas","un")) Sex <- match.arg(Sex, choices = c("m","f","b")) a0rule <- match.arg(a0rule, choices = c("ak","cd")) - extrapLaw <- match.arg(extrapLaw, choices = c("kannisto", - "kannisto_makeham", - "makeham", - "gompertz", - "ggompertz", - "beard", - "beard_makeham", - "quadratic" - )) + if (!is.null(extrapLaw)){ + extrapLaw <- tolower(extrapLaw) + extrapLaw <- match.arg(extrapLaw, choices = c("kannisto", + "kannisto_makeham", + "makeham", + "gompertz", + "ggompertz", + "beard", + "beard_makeham", + "quadratic" + )) + } else { + extrapLaw <- ifelse(max(Age)>=90, "kannisto","makeham") + } + region <- match.arg(region, choices = c("w","n","s","e")) # ages must be abridged. stopifnot(is_abridged(Age)) + if (is.null(extrapFit)){ + maxAclosed <- ifelse(OAG, Age[which.max(Age)-1],max(Age)) + if (maxAclosed < 85){ + extrapFit <- Age[Age >= (maxAclosed - 20) & Age <= maxAclosed] + } else { + extrapFit <- Age[Age >= 60 & Age <= maxAclosed] + } + } else { + stopifnot(all(extrapFit %in% Age)) + } + #cat("\nextrapFit:",paste(extrapFit,collapse = ", "),"\n") # now overwriting raw nMx is allowed by lowering this # arbitrary lower bound to accept the fitted model. Really # this functionality is intended for extrapolation and not @@ -213,7 +230,7 @@ lt_abridged <- function(Deaths = NULL, qxflag <- !is.null(nqx) # 1) if lx given but not qx: if ((!qxflag) & (!is.null(lx))) { - nqx <- lt_id_l_d(lx) / lx + nqx <- lt_id_l_d(lx) / lx # Calculating dx/lx nqx[1] <- ifelse(imr_flag, IMR, nqx[1]) qxflag <- TRUE } @@ -248,7 +265,11 @@ lt_abridged <- function(Deaths = NULL, OAG = OAG, mod = mod, IMR = IMR, - SRB = SRB) + SRB = SRB, + extrapLaw = extrapLaw, + extrapFrom = extrapFrom, + extrapFit = extrapFit + ) } else { nAx <- lt_id_morq_a( nMx = nMx, @@ -261,7 +282,10 @@ lt_abridged <- function(Deaths = NULL, OAG = OAG, mod = mod, IMR = IMR, - SRB = SRB) + SRB = SRB, + extrapLaw = extrapLaw, + extrapFrom = extrapFrom, + extrapFit = extrapFit) } # TR, these nAx ought to turn out to be the same... @@ -294,27 +318,30 @@ lt_abridged <- function(Deaths = NULL, momega <- nMx[length(nMx)] } # -------------------------------- - # begin extrapolation: - # TR: 13 Oct 2018. always extrapolate to 130 no matter what, - # then truncate to OAnew in all cases. This will ensure more robust closeouts - # and an e(x) that doesn't depend on OAnew. 130 is used similarly by HMD. - x_extr <- seq(extrapFrom, 130, by = 5) - - Mxnew <- lt_rule_m_extrapolate( - x = Age, - mx = nMx, - x_fit = extrapFit, - x_extr = x_extr, - law = extrapLaw, - ...) - - nMxext <- Mxnew$values - Age2 <- names2age(nMxext) - - keepi <- Age2 < extrapFrom - nMxext[keepi] <- nMx[Age < extrapFrom] - nMx <- nMxext - Age <- Age2 + + if (max(Age) < 130){ + # begin extrapolation: + # TR: 13 Oct 2018. always extrapolate to 130 no matter what, + # then truncate to OAnew in all cases. This will ensure more robust closeouts + # and an e(x) that doesn't depend on OAnew. 130 is used similarly by HMD. + x_extr <- seq(extrapFrom, 130, by = 5) + + Mxnew <- lt_rule_m_extrapolate( + x = Age, + mx = nMx, + x_fit = extrapFit, + x_extr = x_extr, + law = extrapLaw, + ...) + + nMxext <- Mxnew$values + Age2 <- names2age(nMxext) + + keepi <- Age2 < extrapFrom + nMxext[keepi] <- nMx[Age < extrapFrom] + nMx <- nMxext + Age <- Age2 + } AgeInt <- age2int( Age, OAG = TRUE, @@ -392,7 +419,7 @@ lt_abridged <- function(Deaths = NULL, nMx[N] <- lx[N] / Tx[N] } - Sx <- lt_id_Ll_S(nLx, lx, AgeInt, N = 5) + Sx <- lt_id_Ll_S(nLx, lx, Age, AgeInt, N = 5) # output is an unrounded, unsmoothed lifetable out <- data.frame( Age = Age, diff --git a/R/lt_id.R b/R/lt_id.R index bce6f5ea9..ec4ecad59 100644 --- a/R/lt_id.R +++ b/R/lt_id.R @@ -115,6 +115,60 @@ lt_id_l_d <- function(lx) { diff(-c(lx, 0)) } +#' @title Derive lifetable death probabilities from survivorship. +#' @description This lifetable identity is the same no matter what kind of lifetable is required. +#' You can find it in any demography textbook. +#' @details The vector returned is the same length as \code{lx} and it sums to the lifetable radix. +#' If the radix is one then this is the discrete deaths distribution. +#' +#' @param lx numeric. Vector of age-specific lifetable survivorship. +#' @references +#' \insertRef{preston2000demography}{DemoTools} +#' @return ndx vector of lifetable deaths. +#' @export +lt_id_l_q <- function(lx) { + dx <- lt_id_l_d(lx) + dx / lx +} + +#' @title Derive survivorship from lifetable deaths +#' @description This lifetable identity is the same no matter what kind of lifetable is required. You can find it in any demography textbook. +#' @details The vector returned is the same length as \code{dx} and it sums to the lifetable radix. If the radix is one then this is the discrete deaths distribution. +#' +#' @param ndx numeric. Vector of age-specific lifetable deaths. +#' @param radix numeric. +#' @references +#' \insertRef{preston2000demography}{DemoTools} +#' @return lx vector of lifetable survivorship +#' @export +lt_id_d_l <- function(ndx, radix = sum(ndx)) { + ndx <- ndx / sum(ndx) + N <- length(ndx) + CDF <- cumsum(ndx) + radix * c(1,1 - CDF[-N]) +} + + + +#' @title Derive death probabilities from lifetable deaths +#' @description This lifetable identity is the same no matter what kind of lifetable is required. You can find it in any demography textbook. +#' @details The vector returned is the same length as \code{dx}. +#' +#' @param ndx numeric. Vector of age-specific lifetable survivorship. +#' @references +#' \insertRef{preston2000demography}{DemoTools} +#' @return nqx vector of lifetable death probabilities. +#' @export +lt_id_d_q <- function(ndx) { + rad <- sum(ndx) + ndx <- ndx / rad + N <- length(ndx) + CDF <- cumsum(ndx) + lx <- c(sum(ndx),1 - CDF[-N]) + ndx / lx +} + + #' @title Derive lifetable exposure from lx, ndx and nax. #' @description This is a common approximation of lifetable exposure: #' All persons surviving to the end of the interval time the interval width, plus all those that died @@ -133,7 +187,7 @@ lt_id_lda_L <- function(lx, ndx, nax, AgeInt) { nLx <- rep(0, N) nLx[1:(N - 1)] <- AgeInt[1:(N - 1)] * lx[2:N] + nax[1:(N - 1)] * ndx[1:(N - 1)] - nLx[N] <- lx[N] * nax[N] + nLx[N] <- lx[N] * nax[N] #open interval nLx } @@ -223,7 +277,7 @@ lt_id_ma_q <- function(nMx, nax, AgeInt, closeout = TRUE, IMR) { #' @param nLx numeric vector of lifetable exposure. #' @param N integer, the age width for survivor ratios, either 5 or 1. Default 5. #' @export -lt_id_Ll_S <- function(nLx, lx, AgeInt, N = c(5, 1)) { +lt_id_Ll_S <- function(nLx, lx, Age, AgeInt, N = c(5, 1)) { n <- length(nLx) stopifnot(length(lx) == n) # either we're in 1 or 5 year age groups @@ -235,7 +289,9 @@ lt_id_Ll_S <- function(nLx, lx, AgeInt, N = c(5, 1)) { # double check because assuming abridged nLx is given... stopifnot(length(AgeInt) == n) ageintcompare <- inferAgeIntAbr(vec = nLx) - stopifnot(all(ageintcompare[-n] == AgeInt[-n])) + if (Age[1] == 0){ + stopifnot(all(ageintcompare[-n] == AgeInt[-n])) + } # birth until 0-4 Sx[1] <- (nLx[1] + nLx[2]) / ((AgeInt[1] + AgeInt[2]) * lx[1]) # second age group is survival age 0-4 to age 5-9 diff --git a/R/lt_model_lq.R b/R/lt_model_lq.R index e3f4ef42e..ee601dea1 100644 --- a/R/lt_model_lq.R +++ b/R/lt_model_lq.R @@ -11,457 +11,456 @@ #' Estimate Wilmoth Model Life Table -#' +#' #' Construct model life tables based on the Log-Quadratic (wilmoth) estimates -#' with various choices of 2 input parameters: -#' \code{q0_5, q0_1, q15_45, q15_35} and \code{e0}. There are 8 possible -#' combinations (see examples below). -#' -#' @details Due to limitations of the R language the notation for probability -#' of dying \code{nqx} is written \code{qx_n}, where \code{x} and \code{n} are +#' with various choices of 2 input parameters: +#' \code{q0_5, q0_1, q15_45, q15_35} and \code{e0}. There are 8 possible +#' combinations (see examples below). +#' +#' @details Due to limitations of the R language the notation for probability +#' of dying \code{nqx} is written \code{qx_n}, where \code{x} and \code{n} are #' integers. For example \code{45q15} is represented as \code{q45_15}. #' @note This function is ported from \code{MortalityEstimate::wilmothLT} experimental package by Marius Pascariu. The package is no longe maintained. The latest version can be found here: \url{https://github.com/mpascariu/MortalityEstimate} #' @param Sex Choose the sex of the population. This choice defines the use #' of a corresponding Log-Quadratic (\code{wilmoth}) -#' model fitted for the whole Human Mortality Database (as of Dec 2019, +#' model fitted for the whole Human Mortality Database (as of Dec 2019, #' there are 968 life tables for each sex). #' The following options are available: \itemize{ -#' \item{\code{"b"}} -- Both sex; +#' \item{\code{"b"}} -- Both sex; #' \item{\code{"f"}} -- Females; #' \item{\code{"m"}} -- Males. #' } #' @param fitted_logquad Optional, defaults to \code{NULL}. An object of class -#' \code{wilmoth}. If full HMD is not enough, one -#' can fit a Log-Quadratic (\url{https://github.com/mpascariu/MortalityEstimate}) model +#' \code{wilmoth}. If full HMD is not enough, one +#' can fit a Log-Quadratic (\url{https://github.com/mpascariu/MortalityEstimate}) model #' based on any other collection of life tables; -#' @param q0_5 5q0. The probability that a new-born will die during the +#' @param q0_5 5q0. The probability that a new-born will die during the #' subsequent 5 years; -#' @param q0_1 1q0. The probability that a life aged 0 will die during the +#' @param q0_1 1q0. The probability that a life aged 0 will die during the #' following year; -#' @param q15_45 45q15. The probability that a life aged 15 will die during +#' @param q15_45 45q15. The probability that a life aged 15 will die during #' the subsequent 45 years; -#' @param q15_35 35q15. The probability that a life aged 15 will die during +#' @param q15_35 35q15. The probability that a life aged 15 will die during #' the subsequent 35 years; #' @param e0 Life expectancy at birth; #' @param radix Life table radix. Default: 10^5; -#' @param tol Tolerance level for convergence. The tolerance level, is relevant +#' @param tol Tolerance level for convergence. The tolerance level, is relevant #' for case 7 and 8 (e0 and 45q15 or 35q15 are known); #' @param maxit Maximum number of iterations allowed. Default: 100; #' @inheritParams lt_abridged #' @return The output is of class \code{lt_model_lq} with the components: #' \item{lt}{ Life table matching given inputs} -#' \item{values}{ Associated values of \code{q0_5, q0_1, q15_45, q15_35} +#' \item{values}{ Associated values of \code{q0_5, q0_1, q15_45, q15_35} #' and \code{e0}.} #' @importFrom stats uniroot -#' @examples -#' +#' @examples +#' #' # Build life tables with various choices of 2 input parameters -#' \dontrun{ #' # case 1: Using 5q0 and e0 #' L1 <- lt_model_lq(Sex = "b", q0_5 = 0.05, e0 = 65) #' L1 #' ls(L1) -#' +#' #' L1f <- lt_model_lq(Sex = "f", q0_5 = 0.05, e0 = 65) #' L1m <- lt_model_lq(Sex = "m", q0_5 = 0.05, e0 = 65) -#' +#' #' # case 2: Using 5q0 and 45q15 #' L2 <- lt_model_lq(Sex = "b", q0_5 = 0.05, q15_45 = 0.2) -#' +#' #' # case 3: Using 5q0 and 35q15 #' L3 <- lt_model_lq(Sex = "b", q0_5 = 0.05, q15_35 = 0.125) -#' +#' #' # case 4: Using 1q0 and e0 #' L4 <- lt_model_lq(Sex = "b", q0_1 = 0.01, e0 = 65) -#' +#' #' # case 5: Using 1q0 and 45q15 #' L5 <- lt_model_lq(Sex = "b", q0_1 = 0.05, q15_45 = 0.2) -#' +#' #' # case 6: Using 1q0 and 35q15 #' L6 <- lt_model_lq(Sex = "b", q0_1 = 0.05, q15_35 = 0.125) -#' +#' #' # case 7: Using 45q15 and e0 #' L7 <- lt_model_lq(Sex = "b", q15_45 = 0.125, e0 = 65) -#' +#' #' # case 8: Using 35q15 and e0 #' L8 <- lt_model_lq(Sex = "b", q15_35 = 0.15, e0 = 65) -#' } +#' #' @export lt_model_lq <- function( - Sex, # has to be specified always - fitted_logquad = NULL, - q0_5 = NULL, - q0_1 = NULL, - q15_45 = NULL, - q15_35 = NULL, - e0 = NULL, - radix = 1e5, - tol = 1e-9, - maxit = 200, - axmethod = "pas", - a0rule = "ak", - IMR = NA, - region = "w", - mod = TRUE, - SRB = 1.05) { - # TR: strict name checking of new args - axmethod <- match.arg(axmethod, choices = c("pas","un")) - a0rule <- match.arg(a0rule, choices = c("ak","cd")) - Sex <- match.arg(Sex, choices = c("m","f","b")) - region <- match.arg(region, choices =c("w","n","s","e")) - - # check if an optional fitted_logquad is specified - if(is.null(fitted_logquad)){ - - if(Sex == "b"){ - fitted_logquad <- DemoTools::fitted_logquad_b - } - if(Sex == "f"){ - fitted_logquad <- DemoTools::fitted_logquad_f - } - if(Sex == "m"){ - fitted_logquad <- DemoTools::fitted_logquad_m - } - } - - # TR: I see this is why you want NULLs, but maybe there's - # a better way? Rather then passing in values, we can pass - # in logicals. Looking inside find.my.case I see that it - # just composes vectors of length 5. We can mimick this like so. - par_ind <- c(q0_5 = !is.null(q0_5), - q0_1 = !is.null(q0_1), - q15_45 = !is.null(q15_45), - q15_35 = !is.null(q15_35), - e0 = !is.null(e0)) - my_case <- find.my.case(par_ind = par_ind) - - cf <- coef(fitted_logquad) - x <- fitted_logquad$input$x - - # Cases 1-3: 5q0 is known, plus e0, 45q15 or 45q15 - # TR: functions should have all parameters passed in. - if (my_case %in% c("C1", "C2", "C3")) { - if (my_case == "C1"){ - fun.k <- function(k, cf, x, q0_5, radix, Sex, par2) { - lthat.logquad(coefs = cf, - x = x, - q0_5 = q0_5, - k = k, - radix = radix, - Sex = Sex, - axmethod = axmethod, - a0rule = a0rule, - IMR = IMR, - mod = mod)$lt$ex[1] - par2 - } - par2 <- e0 - } - if (my_case == "C2"){ - fun.k <- function(k, cf, x, q0_5, radix, Sex, par2) { - lt <- lthat.logquad(coefs = cf, - x = x, - q0_5 = q0_5, - k = k, - radix = radix, - Sex = Sex, - axmethod = axmethod, - a0rule = a0rule, - IMR = IMR, - mod = mod)$lt - (1 - (lt[lt$Age == 60, "lx"] / lt[lt$Age == 15, "lx"])) - par2 - } - par2 <- q15_45 - } - if (my_case == "C3"){ - fun.k <- function(k, cf, x, q0_5, radix, Sex, par2) { - lt <- lthat.logquad(coefs = cf, - x = x, - q0_5 = q0_5, - k = k, - radix = radix, - Sex = Sex, - axmethod = axmethod, - a0rule = a0rule, - IMR = IMR, - mod = mod)$lt - (1 - (lt[lt$Age == 50, "lx"] / lt[lt$Age == 15, "lx"])) - par2 - } - par2 <- q15_35 - } - - kroot <- uniroot(f = fun.k, - interval = c(-10, 10), - cf = cf, - x = x, - q0_5 = q0_5, - radix = radix, - Sex = Sex, - axmethod = axmethod, - a0rule = a0rule, - IMR = IMR, - mod = mod, - par2 = par2)$root - tmp <- lthat.logquad(coefs = cf, - x = x, - q0_5 = q0_5, - k = kroot, - radix = radix, - Sex = Sex, - axmethod = axmethod, - a0rule = a0rule, - IMR = IMR, - mod = mod) - } - - # Cases 4-6: 1q0 is known, plus e0, 45q15 or 35q15; - # after finding 5q0 (assume k=0, but it doesn't matter), these become Cases 1-3 - - if (my_case %in% c("C4","C5","C6") ) { - fun.q0_5a <- function(q0_5, q0_1, cf, x, radix, Sex){ - lthat.logquad(coefs = cf, - x = x, - q0_5 = q0_5, - k = 0, - radix = radix, - Sex = Sex, - axmethod = axmethod, - a0rule = a0rule, - IMR = IMR, - mod = mod)$lt$nqx[1] - q0_1 - } - q0_5 <- uniroot(f = fun.q0_5a, interval = c(1e-5, 0.8), - cf = cf, - x = x, - q0_1 = q0_1, - radix = radix, - Sex = Sex, - axmethod = axmethod, - a0rule = a0rule, - IMR = IMR, - mod = mod - )$root - } - - if (my_case == "C4"){ - tmp <- lt_model_lq(fitted_logquad = fitted_logquad, - q0_5 = q0_5, - e0 = e0, - q0_1 = NULL, - q15_35 = NULL, - q15_45 = NULL, + Sex, # has to be specified always + fitted_logquad = NULL, + q0_5 = NULL, + q0_1 = NULL, + q15_45 = NULL, + q15_35 = NULL, + e0 = NULL, + radix = 1e5, + tol = 1e-9, + maxit = 200, + axmethod = "pas", + a0rule = "ak", + IMR = NA, + region = "w", + mod = TRUE, + SRB = 1.05) { + # TR: strict name checking of new args + axmethod <- match.arg(axmethod, choices = c("pas","un")) + a0rule <- match.arg(a0rule, choices = c("ak","cd")) + Sex <- match.arg(Sex, choices = c("m","f","b")) + region <- match.arg(region, choices =c("w","n","s","e")) + + # check if an optional fitted_logquad is specified + if(is.null(fitted_logquad)){ + + if(Sex == "b"){ + fitted_logquad <- DemoTools::fitted_logquad_b + } + if(Sex == "f"){ + fitted_logquad <- DemoTools::fitted_logquad_f + } + if(Sex == "m"){ + fitted_logquad <- DemoTools::fitted_logquad_m + } + } + + # TR: I see this is why you want NULLs, but maybe there's + # a better way? Rather then passing in values, we can pass + # in logicals. Looking inside find_my_case I see that it + # just composes vectors of length 5. We can mimick this like so. + par_ind <- c(q0_5 = !is.null(q0_5), + q0_1 = !is.null(q0_1), + q15_45 = !is.null(q15_45), + q15_35 = !is.null(q15_35), + e0 = !is.null(e0)) + my_case <- find_my_case(par_ind = par_ind) + + cf <- coef(fitted_logquad) + x <- fitted_logquad$input$x + + # Cases 1-3: 5q0 is known, plus e0, 45q15 or 45q15 + # TR: functions should have all parameters passed in. + if (my_case %in% c("C1", "C2", "C3")) { + if (my_case == "C1"){ + fun.k <- function(k, cf, x, q0_5, radix, Sex, par2, axmethod, a0rule, IMR, mod) { + lthat.logquad(coefs = cf, + x = x, + q0_5 = q0_5, + k = k, + radix = radix, + Sex = Sex, + axmethod = axmethod, + a0rule = a0rule, + IMR = IMR, + mod = mod)$lt$ex[1] - par2 + } + par2 <- e0 + } + if (my_case == "C2"){ + fun.k <- function(k, cf, x, q0_5, radix, Sex, par2, axmethod, a0rule, IMR, mod) { + lt <- lthat.logquad(coefs = cf, + x = x, + q0_5 = q0_5, + k = k, + radix = radix, + Sex = Sex, + axmethod = axmethod, + a0rule = a0rule, + IMR = IMR, + mod = mod)$lt + (1 - (lt[lt$Age == 60, "lx"] / lt[lt$Age == 15, "lx"])) - par2 + } + par2 <- q15_45 + } + if (my_case == "C3"){ + fun.k <- function(k, cf, x, q0_5, radix, Sex, par2, axmethod, a0rule, IMR, mod) { + lt <- lthat.logquad(coefs = cf, + x = x, + q0_5 = q0_5, + k = k, + radix = radix, + Sex = Sex, + axmethod = axmethod, + a0rule = a0rule, + IMR = IMR, + mod = mod)$lt + (1 - (lt[lt$Age == 50, "lx"] / lt[lt$Age == 15, "lx"])) - par2 + } + par2 <- q15_35 + } + + kroot <- uniroot(f = fun.k, + interval = c(-10, 10), + cf = cf, + x = x, + q0_5 = q0_5, + radix = radix, + Sex = Sex, + axmethod = axmethod, + a0rule = a0rule, + IMR = IMR, + mod = mod, + par2 = par2)$root + tmp <- lthat.logquad(coefs = cf, + x = x, + q0_5 = q0_5, + k = kroot, + radix = radix, Sex = Sex, axmethod = axmethod, a0rule = a0rule, - IMR = IMR, - mod = mod, - radix = radix, - tol = tol) - } - if (my_case == "C5"){ - tmp <- lt_model_lq(fitted_logquad = fitted_logquad, - q0_1 = NULL, - q15_35 = NULL, - e0 = NULL, - q0_5 = q0_5, + IMR = IMR, + mod = mod) + } + + # Cases 4-6: 1q0 is known, plus e0, 45q15 or 35q15; + # after finding 5q0 (assume k=0, but it doesn't matter), these become Cases 1-3 + + if (my_case %in% c("C4","C5","C6") ) { + fun.q0_5a <- function(q0_5, q0_1, cf, x, radix, Sex, axmethod, a0rule, IMR, mod){ + lthat.logquad(coefs = cf, + x = x, + q0_5 = q0_5, + k = 0, + radix = radix, + Sex = Sex, + axmethod = axmethod, + a0rule = a0rule, + IMR = IMR, + mod = mod)$lt$nqx[1] - q0_1 + } + q0_5 <- uniroot(f = fun.q0_5a, interval = c(1e-5, 0.8), + cf = cf, + x = x, + q0_1 = q0_1, + radix = radix, + Sex = Sex, + axmethod = axmethod, + a0rule = a0rule, + IMR = IMR, + mod = mod + )$root + } + + if (my_case == "C4"){ + tmp <- lt_model_lq(fitted_logquad = fitted_logquad, + q0_5 = q0_5, + e0 = e0, + q0_1 = NULL, + q15_35 = NULL, + q15_45 = NULL, + Sex = Sex, + axmethod = axmethod, + a0rule = a0rule, + IMR = IMR, + mod = mod, + radix = radix, + tol = tol) + } + if (my_case == "C5"){ + tmp <- lt_model_lq(fitted_logquad = fitted_logquad, + q0_1 = NULL, + q15_35 = NULL, + e0 = NULL, + q0_5 = q0_5, + q15_45 = q15_45, + Sex = Sex, + axmethod = axmethod, + a0rule = a0rule, + IMR = IMR, + mod = mod, + radix = radix, + tol = tol) + } + if (my_case == "C6"){ + tmp <- lt_model_lq(fitted_logquad = fitted_logquad, + q0_1 = NULL, + q15_45 = NULL, + e0 = NULL, + q0_5 = q0_5, + q15_35 = q15_35, + Sex = Sex, + axmethod = axmethod, + a0rule = a0rule, + IMR = IMR, + mod = mod, + radix = radix, + tol = tol) + } + + # Case 7 and 8: e0 and 45q15 or 35q15 are known; must find both 5q0 and k + if (my_case %in% c("C7", "C8")) { + k <- q0_5 <- 0 + iter <- crit <- 1 + + fun.q0_5b = function(q0_5, + cf = cf, + x, + k, + radix, + Sex, + axmethod = "pas", + a0rule ="ak", + IMR = NA, + mod = TRUE, + e0) { + lthat.logquad(coefs = cf, + x = x, + q0_5 = q0_5, + k = k, + radix, + Sex = Sex, + axmethod = axmethod, + a0rule = a0rule, + IMR = IMR, + mod = mod)$lt$ex[1] - e0 + } + while (crit > tol & iter <= maxit) { + k.old <- k + q0_5.old <- q0_5 + # Get new 5q0 from e0 given k (case 9 from MortalityEstimate::wilmothLT) + + + q0_5i <- uniroot(f = fun.q0_5b, + interval = c(1e-4, 0.8), + x = x, + cf = cf, + k = k, + radix = radix, + Sex = Sex, + axmethod = axmethod, + a0rule = a0rule, + IMR = IMR, + mod = mod, + e0 = e0)$root + # get new q0_5 + q0_5 <- lthat.logquad( + coefs = cf, + x = x, + q0_5 = q0_5i, + k = k, + radix = radix, + Sex = Sex, + axmethod = axmethod, + a0rule = a0rule, + IMR = IMR, + mod = mod + )$values$q0_5 + # Get k from 45q15 or 35q15 assuming 5q0 + if (my_case == "C7"){ + tmp = lt_model_lq(fitted_logquad = fitted_logquad, + q0_5 = q0_5, q15_45 = q15_45, Sex = Sex, axmethod = axmethod, a0rule = a0rule, - IMR = IMR, - mod = mod, - radix = radix, - tol = tol) - } - if (my_case == "C6"){ - tmp <- lt_model_lq(fitted_logquad = fitted_logquad, - q0_1 = NULL, - q15_45 = NULL, - e0 = NULL, + IMR = IMR, + mod = mod, + tol = tol, + radix = radix) + } + if (my_case == "C8"){ + tmp = lt_model_lq(fitted_logquad = fitted_logquad, q0_5 = q0_5, q15_35 = q15_35, Sex = Sex, axmethod = axmethod, a0rule = a0rule, - IMR = IMR, - mod = mod, - radix = radix, - tol = tol) - } - - # Case 7 and 8: e0 and 45q15 or 35q15 are known; must find both 5q0 and k - if (my_case %in% c("C7", "C8")) { - k <- q0_5 <- 0 - iter <- crit <- 1 - - fun.q0_5b = function(q0_5, - cf = cf, - x, - k, - radix, - Sex, - axmethod = "pas", - a0rule ="ak", - IMR = NA, - mod = TRUE, - e0) { - lthat.logquad(coefs = cf, - x = x, - q0_5 = q0_5, - k = k, - radix, - Sex = Sex, - axmethod = axmethod, - a0rule = a0rule, - IMR = IMR, - mod = mod)$lt$ex[1] - e0 - } - while (crit > tol & iter <= maxit) { - k.old <- k - q0_5.old <- q0_5 - # Get new 5q0 from e0 given k (case 9 from MortalityEstimate::wilmothLT) - - - q0_5i <- uniroot(f = fun.q0_5b, - interval = c(1e-4, 0.8), - x = x, - cf = cf, - k = k, - radix = radix, - Sex = Sex, - axmethod = axmethod, - a0rule = a0rule, - IMR = IMR, - mod = mod, - e0 = e0)$root - # get new q0_5 - q0_5 <- lthat.logquad( - coefs = cf, - x = x, - q0_5 = q0_5i, - k = k, - radix = radix, - Sex = Sex, - axmethod = axmethod, - a0rule = a0rule, - IMR = IMR, - mod = mod - )$values$q0_5 - # Get k from 45q15 or 35q15 assuming 5q0 - if (my_case == "C7"){ - tmp = lt_model_lq(fitted_logquad = fitted_logquad, - q0_5 = q0_5, - q15_45 = q15_45, - Sex = Sex, - axmethod = axmethod, - a0rule = a0rule, - IMR = IMR, - mod = mod, - tol = tol, - radix = radix) - } - if (my_case == "C8"){ - tmp = lt_model_lq(fitted_logquad = fitted_logquad, - q0_5 = q0_5, - q15_35 = q15_35, - Sex = Sex, - axmethod = axmethod, - a0rule = a0rule, - IMR = IMR, - mod = mod, - tol = tol, - radix = radix - ) - } - k <- tmp$values$k - crit <- sum(abs(c(k, q0_5) - c(k.old, q0_5.old))) - iter <- iter + 1 - } - if (iter > maxit) { - warning("number of iterations reached maximum without convergence", - call. = FALSE) - } - } - - # Return life table plus values of the 6 possible inputs - out = list(lt = tmp$lt, - values = tmp$values) - out = structure(class = "lt_model_lq", out) - return(out) + IMR = IMR, + mod = mod, + tol = tol, + radix = radix + ) + } + k <- tmp$values$k + crit <- sum(abs(c(k, q0_5) - c(k.old, q0_5.old))) + iter <- iter + 1 + } + if (iter > maxit) { + warning("number of iterations reached maximum without convergence", + call. = FALSE) + } + } + + # Return life table plus values of the 6 possible inputs + out = list(lt = tmp$lt, + values = tmp$values) + out = structure(class = "lt_model_lq", out) + return(out) } #' Estimated life table using the log-quadratic model -#' +#' #' @param coefs Estimated coefficients #' @inheritParams lt_model_lq #' @keywords internal #' @export -lthat.logquad <- function(coefs, - x, - q0_5, - k, - radix, - axmethod = "pas", - a0rule = "ak", - Sex = "m", - IMR = NA, - region = "w", - mod = TRUE, - SRB = 1.05){ - axmethod <- match.arg(axmethod, choices = c("pas","un")) - a0rule <- match.arg(a0rule, choices = c("ak","cd")) - Sex <- match.arg(Sex, choices = c("m","f","b")) - region <- match.arg(region, choices =c("w","n","s","e")) - - h <- log(q0_5) - mx <- with(as.list(coefs), exp(ax + bx*h + cx*h^2 + vx*k)) - # estimate ax - age_int <- age2int(Age = x, OAG = TRUE, OAvalue = NA) - - # ruh roh, we need to do something about Sex = "b" - ax <- lt_id_morq_a( - nMx = mx, - Age = x, - AgeInt = age_int, - axmethod = axmethod, - a0rule = a0rule, - # This is temporary - Sex = Sex, - IMR = IMR, - region = region, - mod = mod, - SRB = SRB) - - # qx from mx and estimated ax - qx <- lt_id_ma_q(nMx = mx, nax = ax, AgeInt = age_int, IMR = NA) - # Force 4q1 (and thus 4m1) to be consistent with 1q0 and 5q0 - qx[2] <- 1 - (1 - q0_5)/(1 - qx[1]) - mx[2] <- lt_id_qa_m(nqx = qx, nax = ax, AgeInt = age_int)[2] - names(mx) = names(qx) <- rownames(coefs) - - LT <- lt_abridged( - Age = x, - nMx = mx, - radix = radix, - lt_abridged = age_int, - axmethod = axmethod, - a0rule = a0rule, - Sex = Sex, - IMR = IMR, - region = region, - mod = mod, - SRB = SRB) - e0 <- LT$ex[1] - q0_1 <- LT$nqx[1] - q15_45 <- 1 - LT[LT$Age == 60, "lx"] / LT[LT$Age == 15, "lx"] - q15_35 <- 1 - LT[LT$Age == 50, "lx"] / LT[LT$Age == 15, "lx"] - values <- data.frame(k, q0_1, q0_5, q15_35, q15_45, e0, row.names = "") - - # Exit - out <- list(lt = LT, values = values) - return(out) +lthat.logquad <- function(coefs, + x, + q0_5, + k, + radix, + axmethod = "pas", + a0rule = "ak", + Sex = "m", + IMR = NA, + region = "w", + mod = TRUE, + SRB = 1.05){ + axmethod <- match.arg(axmethod, choices = c("pas","un")) + a0rule <- match.arg(a0rule, choices = c("ak","cd")) + Sex <- match.arg(Sex, choices = c("m","f","b")) + region <- match.arg(region, choices =c("w","n","s","e")) + + h <- log(q0_5) + mx <- with(as.list(coefs), exp(ax + bx*h + cx*h^2 + vx*k)) + # estimate ax + age_int <- age2int(Age = x, OAG = TRUE, OAvalue = NA) + + # ruh roh, we need to do something about Sex = "b" + ax <- lt_id_morq_a( + nMx = mx, + Age = x, + AgeInt = age_int, + axmethod = axmethod, + a0rule = a0rule, + # This is temporary + Sex = Sex, + IMR = IMR, + region = region, + mod = mod, + SRB = SRB) + + # qx from mx and estimated ax + qx <- lt_id_ma_q(nMx = mx, nax = ax, AgeInt = age_int, IMR = NA) + # Force 4q1 (and thus 4m1) to be consistent with 1q0 and 5q0 + qx[2] <- 1 - (1 - q0_5)/(1 - qx[1]) + mx[2] <- lt_id_qa_m(nqx = qx, nax = ax, AgeInt = age_int)[2] + names(mx) = names(qx) <- rownames(coefs) + + LT <- lt_abridged( + Age = x, + nMx = mx, + radix = radix, + lt_abridged = age_int, + axmethod = axmethod, + a0rule = a0rule, + Sex = Sex, + IMR = IMR, + region = region, + mod = mod, + SRB = SRB) + e0 <- LT$ex[1] + q0_1 <- LT$nqx[1] + q15_45 <- 1 - LT[LT$Age == 60, "lx"] / LT[LT$Age == 15, "lx"] + q15_35 <- 1 - LT[LT$Age == 50, "lx"] / LT[LT$Age == 15, "lx"] + values <- data.frame(k, q0_1, q0_5, q15_35, q15_45, e0, row.names = "") + + # Exit + out <- list(lt = LT, values = values) + return(out) } @@ -470,41 +469,41 @@ lthat.logquad <- function(coefs, #' @details \code{par_ind} should consist in logicals in the following order: \code{q0_5}, \code{q0_1}, \code{q15_45}, \code{q15_35}, \code{e0}. This is faithfully constructed in calling functions as required. #' @param par_ind logical vector of length 5 #' @keywords internal - -find.my.case <- function(par_ind) { - # need to reverse logicals to minimize code changes below - - # TR: more robust would be to pick out by name: - if (sum(par_ind[c('q0_1', 'q0_5')]) == 2) { - stop("cannot have both 'q0_1' and 'q0_5' as inputs", call. = FALSE) - } - - # TR: changed logic - if (sum(par_ind[c('q15_45', 'q15_35')]) == 2) { - stop("cannot have both 'q15_45' and 'q15_35' as inputs", call. = FALSE) - } - - # Test that exactly two inputs are non-null - if (sum(par_ind) != 2) { - stop("must have exactly two inputs", call. = FALSE) - } - - case <- "Invalid par combo" - # There are 8 cases: "5 choose 2" = 10, but we disallow two cases - # (1q0 and 5q0, or 45q15 and 35q15) - # 'q0_5' 'q0_1' 'q15_45' 'q15_35' 'e0' - if (sum(par_ind[ c('q0_5', 'e0')]) == 2 ) case = "C1" - if (sum(par_ind[c('q0_5','q15_45')]) == 2) case = "C2" - if (sum(par_ind[c('q0_5','q15_35')]) == 2) case = "C3" - - if (sum(par_ind[ c('q0_1', 'e0')]) == 2 ) case = "C4" - if (sum(par_ind[c('q0_1','q15_45')]) == 2) case = "C5" - if (sum(par_ind[c('q0_1','q15_35')]) == 2) case = "C6" - - if (sum(par_ind[ c('q15_45', 'e0')]) == 2 ) case = "C7" - if (sum(par_ind[ c('q15_35', 'e0')]) == 2 ) case = "C8" - - stopifnot(case != "Invalid parameter combo") - - return(case) + +find_my_case <- function(par_ind) { + # need to reverse logicals to minimize code changes below + + # TR: more robust would be to pick out by name: + if (sum(par_ind[c('q0_1', 'q0_5')]) == 2) { + stop("cannot have both 'q0_1' and 'q0_5' as inputs", call. = FALSE) + } + + # TR: changed logic + if (sum(par_ind[c('q15_45', 'q15_35')]) == 2) { + stop("cannot have both 'q15_45' and 'q15_35' as inputs", call. = FALSE) + } + + # Test that exactly two inputs are non-null + if (sum(par_ind) != 2) { + stop("must have exactly two inputs", call. = FALSE) + } + + case <- "Invalid par combo" + # There are 8 cases: "5 choose 2" = 10, but we disallow two cases + # (1q0 and 5q0, or 45q15 and 35q15) + # 'q0_5' 'q0_1' 'q15_45' 'q15_35' 'e0' + if (sum(par_ind[ c('q0_5', 'e0')]) == 2 ) case = "C1" + if (sum(par_ind[c('q0_5','q15_45')]) == 2) case = "C2" + if (sum(par_ind[c('q0_5','q15_35')]) == 2) case = "C3" + + if (sum(par_ind[ c('q0_1', 'e0')]) == 2 ) case = "C4" + if (sum(par_ind[c('q0_1','q15_45')]) == 2) case = "C5" + if (sum(par_ind[c('q0_1','q15_35')]) == 2) case = "C6" + + if (sum(par_ind[ c('q15_45', 'e0')]) == 2 ) case = "C7" + if (sum(par_ind[ c('q15_35', 'e0')]) == 2 ) case = "C8" + + stopifnot(case != "Invalid parameter combo") + + return(case) } diff --git a/R/lt_regroup_age.R b/R/lt_regroup_age.R new file mode 100644 index 000000000..83dc2fedb --- /dev/null +++ b/R/lt_regroup_age.R @@ -0,0 +1,324 @@ +# An abridged life table that is coherent with an input life table by single year of age + +#' calculate an abridged life table that is consistent with a life table by single year of age +#' @description Computes abridged life table columns based on the lx, nLx , and ex values from +#' a single year life table, in accordance with step 2.2 of the Human Life Table Protocol +#' https://www.lifetable.de/methodology.pdf. Output abridged life table has same open age group +#' as input single age life table +#' @details Similar to \code{lt_abridged()} details, forthcoming +#' @param Age integer. Lower bounds of single ages. +#' @param lx numeric. Vector of lifetable survivorship at single ages. +#' @param nLx numeric. Vector of lifetable exposure at single ages. +#' @param ex numeric. Vector of Age-specific remaining life expectancy at single ages. +#' @param ... optional args, not currently used. +#' @return Abridged lifetable in data.frame with columns +#' \itemize{ +#' \item{Age}{integer. Lower bound of abridged age class}, +#' \item{AgeInt}{integer. Age class widths.} +#' \item{nMx}{numeric. Age-specific central death rates.} +#' \item{nAx}{numeric. Average time spent in interval by those deceased in interval. } +#' \item{nqx}{numeric. Age-specific conditional death probabilities.} +#' \item{lx}{numeric. Lifetable survivorship} +#' \item{ndx}{numeric. Lifetable deaths distribution.} +#' \item{nLx}{numeric. Lifetable exposure.} +#' \item{Sx}{numeric. Survivor ratios in uniform 5-year age groups.} +#' \item{Tx}{numeric. Lifetable total years left to live above age x.} +#' \item{ex}{numeric. Age-specific remaining life expectancy.} +#' } +#' +#' @export +#' +lt_single2abridged <- function(lx, + nLx, + ex, + Age = 1:length(lx) - 1, + ...) { + + stopifnot(is_single(Age)) + NN <- length(lx) + stopifnot(length(nLx) == NN & length(ex) == NN & length(Age) == NN) + + # define abridged age groups + Age5 <- c(0, 1, seq(5, max(Age), 5)) + AgeInt <- age2int(Age = Age5, OAvalue = 5) + N <- length(Age5) + + # compute abridged lifetable columns + lx <- lx[Age %in% Age5] + nLx <- single2abridged(nLx) + ex <- ex[Age %in% Age5] + ndx <- lt_id_l_d(lx) + nqx <- ndx / lx + nAx <- (nLx - (AgeInt * shift.vector(lx,-1,NA))) / ndx + nAx[N] <- ex[N] + nMx <- ndx/nLx + Tx <- lt_id_L_T(nLx) + Sx <- lt_id_Ll_S(nLx, lx, Age, AgeInt, N = 5) + + out <- data.frame( + Age = Age5, + AgeInt = AgeInt, + nMx = nMx, + nAx = nAx, + nqx = nqx, + lx = lx, + ndx = ndx, + nLx = nLx, + Sx = Sx, + Tx = Tx, + ex = ex + ) + return(out) +} + + +# TODO this needs to be speed profiled. Why is pclm() slow? Is it just my machine? + +# A life table by single year of age obtained by graduating the abridged lt using ungroup package + +#' create a life table by single year of age by graduating an abridged life table +#' @description Computes single year of age life table by graduating the mortality schedule of an abridged life table, using the `ungroup::pclm()` to ungroup binned count data. Returns complete single-age lifetable. +#' @details Similar to `lt_abridged()` details, forthcoming. +#' @inheritParams lt_abridged +#' @param ... optional arguments passed to `pclm()`. For example, if you pass an expicit `lambda` parameter via the `control` argument, you can speed up estimation +#' @return Single-year lifetable in data.frame with columns +#' \itemize{ +#' \item{Age}{integer. Lower bound of single year age class}, +#' \item{AgeInt}{integer. Age class widths.} +#' \item{nMx}{numeric. Age-specific central death rates.} +#' \item{nAx}{numeric. Average time spent in interval by those deceased in interval. } +#' \item{nqx}{numeric. Age-specific conditional death probabilities.} +#' \item{lx}{numeric. Lifetable survivorship} +#' \item{ndx}{numeric. Lifetable deaths distribution.} +#' \item{nLx}{numeric. Lifetable exposure.} +#' \item{Sx}{numeric. Survivor ratios.} +#' \item{Tx}{numeric. Lifetable total years left to live above age x.} +#' \item{ex}{numeric. Age-specific remaining life expectancy.} +#' } +#' +#' @export +#' @importFrom ungroup pclm +#' @examples +#' Mx <- c(.23669,.04672,.00982,.00511,.00697,.01036,.01169, +#' .01332,.01528,.01757,.02092,.02517,.03225,.04241,.06056, +#' .08574,.11840,.16226,.23745) +#' Age = c(0,1,seq(5,85,by=5)) +#' AgeInt <- inferAgeIntAbr(vec = Mx) +#' LTabr <- lt_abridged(nMx = Mx, +#' Age = Age, +#' axmethod = "un", +#' Sex = "m", +#' mod = TRUE) +#' +#' LT1 <- lt_abridged2single(nMx = Mx, +#' Age = Age, +#' axmethod = "un", +#' Sex = "m", +#' mod = TRUE) +#' LTabr$ex[1] +#' LT1$ex[1] +#' \dontrun{ +#' plot(Age, LTabr$nMx,type = 's', log = 'y') +#' lines(LT1$Age, LT1$nMx) +#' +#' plot(Age, LTabr$lx,type='S') +#' lines(LT1$Age, LT1$lx) +#' } +lt_abridged2single <- function( + Deaths = NULL, + Exposures = NULL, + nMx = NULL, + nqx = NULL, + lx = NULL, + Age, + radix = 1e5, + axmethod = "un", + a0rule = "ak", + Sex = "m", + region = "w", + IMR = NA, + mod = TRUE, + SRB = 1.05, + OAG = TRUE, + OAnew = max(Age), + extrapLaw = NULL, + extrapFrom = max(Age), + extrapFit = NULL, + ...) { + + stopifnot(is_abridged(Age)) + NN <- length(Age) + #stopifnot(length(nMx) == NN) + + if (!is.null(extrapLaw)){ + extrapLaw <- tolower(extrapLaw) + extrapLaw <- match.arg(extrapLaw, choices = c("kannisto", + "kannisto_makeham", + "makeham", + "gompertz", + "ggompertz", + "beard", + "beard_makeham", + "quadratic" + )) + } else { + extrapLaw <- ifelse(max(Age)>=90, "kannisto","makeham") + } + if (is.null(extrapFit)){ + maxAclosed <- ifelse(OAG, Age[which.max(Age)-1],max(Age)) + if (maxAclosed < 85){ + extrapFit <- Age[Age >= (maxAclosed - 20) & Age <= maxAclosed] + } else { + extrapFit <- Age[Age >= 60 & Age <= maxAclosed] + } + } else { + stopifnot(all(extrapFit %in% Age)) + } + + # first extend the abridged life table to OAG = 130 with a big radix so that we don't lose info later when rounding ndx and nLx to integers + lt_abr <- lt_abridged(Deaths = Deaths, + Exposures = Exposures, + nMx = nMx, + nqx = nqx, + lx = lx, + Age = Age, + Sex = Sex, + radix = 1e8, + axmethod = axmethod, + a0rule = a0rule, + region = region, + IMR = IMR, + mod = mod, + SRB = SRB, + OAG = OAG, + OAnew = 130, + extrapLaw = extrapLaw, + extrapFrom = extrapFrom, + extrapFit = extrapFit) + + # use pclm to ungroup to single year of age from 1 to 129 + # need to round ndx and nLx since pclm doesn't perform with values bw 0 and 1 + ndx <- round(lt_abr$ndx) + nLx <- round(lt_abr$nLx) + ind <- lt_abr$Age >= 1 & lt_abr$Age <= 125 & ndx>0 & nLx>0 + + # TR: removed ... because in practice we were passing in a large + # set of ... indirectly that aren't recognized in pclm + M <- suppressWarnings(pclm(x = lt_abr$Age[ind], + y = ndx[ind], + nlast = 5, + offset = nLx[ind], + ...)) + + # splice original 1M0 with fitted 1Mx and momega from extended abridged LT + M <- c(lt_abr$nMx[1], M$fitted) + + # TR: handle closeout nMx as well. Should depend on OAnew and Age to + # a certain extent. + + # redefine Age and extrapFit for single year ages and new maxage + a1 <- 1:length(M) - 1 + extrapFit <- a1[a1 >= min(extrapFit, (max(a1)-20)) & a1 <= max(Age)] + # always refit from 110 even if extrapFrom > 110 + extrapFrom <- min(max(a1), 110) + + # compute life table columns from single year mx + LT <- lt_single_mx(nMx = M, + Age = a1, + radix = radix, + a0rule = a0rule, + Sex = Sex, + region = region, + IMR = IMR, + mod = mod, + SRB = SRB, + OAG = FALSE, + OAnew = OAnew, + extrapLaw = extrapLaw, + extrapFrom = extrapFrom, + extrapFit = extrapFit) + + return(LT) + +} + +#' calculate an abidged or single age lifetable from abridged or sinlge age data +#' @description This is a wrapper around the other lifetable utilities. We start with either `nMx`, `nqx`, or `lx` in single or abridged ages, and returns a full lifetable in either single or abridged ages. All optional arguments of `lt_abridged()` or `lt_single*()` can be passed in, for instance the `nax` assumptions or the extrapolation arguments. +#' +#' @param nMx_or_nqx_or_lx numeric vector of either `nMx`, `nqx`, or `lx` +#' @param type character, which variable is `x`?, either `"m"`, `"q"`, or `"l"`. Default `"m"` +#' @param Age integer vector of the lower age bounds of `x` +#' @param Sex character, `"m"`, `"f"`, or `"b"`. +#' @param Single logical, do we want output in single ages? +#' @param ... optional arguments passed to `lt_abridged()` or `lt_single*()` +#' @export + +lt_ambiguous <- function(nMx_or_nqx_or_lx = NULL, + type = "m", + Age = NULL, + Sex = NULL, + Single = FALSE, + ...){ + + #extras <- list(...) + + xx <- nMx_or_nqx_or_lx + # TR: adds flexibility when specifying type to reduce user errors + type <- tolower(type) + possible_types <- c("m","m","m","q","q","q","l","l") + names(possible_types) <- c("m","mx","nmx","q","qx","nqx","l","lx") + stopifnot(type %in% names(possible_types) ) + type <- possible_types[type] + + if (type == "l"){ + xx = lt_id_l_q(xx) + type = "q" + } + + # a final catch + out <- NULL + # Abridged input lt + if (is_abridged(Age)){ + + # If we have nMx + if (type == "m" & Single){ + + # args_could_have <- formals(lt_abridged2single) + + out <- lt_abridged2single(nMx = xx, Age = Age, Sex = Sex, ...) + } + if (type == "m" & !Single){ + out <- lt_abridged(nMx = xx, Age = Age, Sex = Sex, ...) + } + # If we have nMx + if (type == "q" & Single){ + out <- lt_abridged2single(nqx = xx, Age = Age, Sex = Sex, ...) + } + if (type == "q" & !Single){ + out <- lt_abridged(nqx = xx, Age = Age, Sex = Sex, ...) + } + } + + if (is_single(Age)){ + if (type == "m" & Single){ + out <- lt_single_mx(nMx = xx, Age = Age, Sex = Sex, ...) + } + if (type == "m" & !Single){ + out <- lt_single_mx(nMx = xx, Age = Age, Sex = Sex, ...) + out <- lt_single2abridged(lx = out$lx,nLx = out$nLx, ex = out$ex) + } + if (type == "q" & Single){ + out <- lt_single_qx(nqx = xx, Age = Age, Sex = Sex, ...) + } + if (type == "q" & !Single){ + out <- lt_single_qx(qx = xx, Age = Age, Sex = Sex, ...) + out <- lt_single2abridged(lx = out$lx,nLx = out$nLx, ex = out$ex) + } + } + + if (is.null(out)){ + # a final catch + stop("please check function arguments") + } + return(out) +} diff --git a/R/lt_rule.R b/R/lt_rule.R index 828e81541..42729b057 100644 --- a/R/lt_rule.R +++ b/R/lt_rule.R @@ -328,9 +328,9 @@ lt_rule_ak_m0_a0 <- function(M0, Sex ){ #' #' @description This function wraps the two approximations for a0 based on either q0 (IMR) or m0. #' -#' @param M0 a value or vector of values of m0, the death probability in the first year of life. -#' @param q0 a value or vector of values of m0, the death risk in the first year of life. -#' @param Sex either "m" or "f" +#' @param M0 a value or vector of values of `1m0``, the death risk in the first year of life. +#' @param q0 a value or vector of values of `1q0``, the death probability in the first year of life, sometimes approximated with IMR. +#' @param Sex either `"m"` or `"f"` #' #' @return a0, the estimated average age at death of those dying in the first year of life, either a single value or a vector of values. #' @@ -343,7 +343,7 @@ lt_rule_1a0_ak <- function(M0 = NULL, q0 = NULL, Sex){ a0 <- lt_rule_ak_q0_a0(q0,Sex) } if (is.null(q0) & !is.null(M0)){ - a0 <- lt_rule_ak_q0_a0(M0,Sex) + a0 <- lt_rule_ak_m0_a0(M0,Sex) } a0 } diff --git a/R/lt_single.R b/R/lt_single.R index 627f700f1..08bdb3abf 100644 --- a/R/lt_single.R +++ b/R/lt_single.R @@ -30,25 +30,42 @@ lt_single_mx <- function(nMx, SRB = 1.05, OAG = TRUE, OAnew = max(Age), - extrapLaw = "kannisto", + extrapLaw = NULL, extrapFrom = max(Age), - extrapFit = Age[Age >= 60], + extrapFit = NULL, ...) { stopifnot(extrapFrom <= max(Age)) Sex <- match.arg(Sex, choices = c("m","f","b")) a0rule <- match.arg(a0rule, choices = c("ak","cd")) - extrapLaw <- match.arg(extrapLaw, choices = c("kannisto", - "kannisto_makeham", - "makeham", - "gompertz", - "ggompertz", - "beard", - "beard_makeham", - "quadratic" - )) + if (!is.null(extrapLaw)){ + extrapLaw <- tolower(extrapLaw) + extrapLaw <- match.arg(extrapLaw, choices = c("kannisto", + "kannisto_makeham", + "makeham", + "gompertz", + "ggompertz", + "beard", + "beard_makeham", + "quadratic" + )) + } else { + extrapLaw <- ifelse(max(Age)>=90, "kannisto","makeham") + } + region <- match.arg(region, choices = c("w","n","s","e")) - + + if (is.null(extrapFit)){ + maxAclosed <- ifelse(OAG, Age[which.max(Age)-1],max(Age)) + if (maxAclosed < 85){ + extrapFit <- Age[Age >= (maxAclosed - 20) & Age <= maxAclosed] + } else { + extrapFit <- Age[Age >= 60 & Age <= maxAclosed] + } + } else { + stopifnot(all(extrapFit %in% Age)) + } + # setup Open Age handling OA <- max(Age) # TR: save for later, in case OAG preserved @@ -57,37 +74,40 @@ lt_single_mx <- function(nMx, } # -------------------------- # Now all vectors may end up being longer - x_extr <- seq(extrapFrom, 130, by = 1) - Mxnew <- lt_rule_m_extrapolate( - x = Age, - mx = nMx, - x_fit = extrapFit, - x_extr = x_extr, - law = extrapLaw, - ...) - - nMxext <- Mxnew$values - Age2 <- names2age(nMxext) - - keepi <- Age2 < extrapFrom - nMxext[keepi] <- nMx[Age < extrapFrom] - - # overwrite some variables: - nMx <- nMxext - Age <- Age2 + if (max(Age) < 130){ + x_extr <- seq(extrapFrom, 130, by = 1) + Mxnew <- lt_rule_m_extrapolate( + x = Age, + mx = nMx, + x_fit = extrapFit, + x_extr = x_extr, + law = extrapLaw, + ...) + + nMxext <- Mxnew$values + Age2 <- names2age(nMxext) + + keepi <- Age2 < extrapFrom + nMxext[keepi] <- nMx[Age < extrapFrom] + + # overwrite some variables: + nMx <- nMxext + Age <- Age2 + } N <- length(Age) AgeInt <- rep(1, N) # get ax: nAx <- rep(.5, N) - nAx[1] <- lt_rule_1a0( - rule = a0rule, - M0 = nMx[1], - IMR = IMR, - Sex = Sex, - region = region, - SRB = SRB) - + if (Age[1] == 0){ + nAx[1] <- lt_rule_1a0( + rule = a0rule, + M0 = nMx[1], + IMR = IMR, + Sex = Sex, + region = region, + SRB = SRB) + } # get qx (if pathological qx > 1, ax replaced, assumed constant hazard) qx <- lt_id_ma_q( nMx = nMx, @@ -129,7 +149,7 @@ lt_single_mx <- function(nMx, AgeInt[N] <- NA # Survival ratios computed only after nLx is closed out - Sx <- lt_id_Ll_S(nLx, lx, AgeInt = AgeInt, N = 1) + Sx <- lt_id_Ll_S(nLx, lx, Age, AgeInt = AgeInt, N = 1) if (OAG) { if (OAnew == OA) { diff --git a/R/lt_single2abridged.R b/R/lt_single2abridged.R deleted file mode 100644 index 624255cf7..000000000 --- a/R/lt_single2abridged.R +++ /dev/null @@ -1,71 +0,0 @@ -# An abridged life table that is coherent with an input life table by single year of age - -#' calculate an abridged life table that is consistent with a life table by single year of age -#' @description Computes abridged life table columns based on the lx, nLx , and ex values from -#' a single year life table, in accordance with step 2.2 of the Human Life Table Protocol -#' https://www.lifetable.de/methodology.pdf. Output abridged life table has same open age group -#' as input single age life table -#' @details Similar to \code{lt_abridged()} details, forthcoming -#' @param Age integer. Lower bounds of single ages. -#' @param lx numeric. Vector of lifetable survivorship at single ages. -#' @param nLx numeric. Vector of lifetable exposure at single ages. -#' @param ex numeric. Vector of Age-specific remaining life expectancy at single ages. -#' @return Abridged lifetable in data.frame with columns -#' \itemize{ -#' \item{Age}{integer. Lower bound of abridged age class}, -#' \item{AgeInt}{integer. Age class widths.} -#' \item{nMx}{numeric. Age-specific central death rates.} -#' \item{nAx}{numeric. Average time spent in interval by those deceased in interval. } -#' \item{nqx}{numeric. Age-specific conditional death probabilities.} -#' \item{lx}{numeric. Lifetable survivorship} -#' \item{ndx}{numeric. Lifetable deaths distribution.} -#' \item{nLx}{numeric. Lifetable exposure.} -#' \item{Sx}{numeric. Survivor ratios in uniform 5-year age groups.} -#' \item{Tx}{numeric. Lifetable total years left to live above age x.} -#' \item{ex}{numeric. Age-specific remaining life expectancy.} -#' } -#' -#' @export -#' -lt_single2abridged <- function(lx, - nLx, - ex, - Age = 1:length(lx) - 1) { - - stopifnot(is_single(Age)) - NN <- length(lx) - stopifnot(length(nLx) == NN & length(ex) == NN & length(Age) == NN) - - # define abridged age groups - Age5 <- c(0, 1, seq(5, max(Age), 5)) - AgeInt <- age2int(Age = Age5, OAvalue = 5) - N <- length(Age5) - - # compute abridged lifetable columns - lx <- lx[Age %in% Age5] - nLx <- single2abridged(nLx) - ex <- ex[Age %in% Age5] - ndx <- lt_id_l_d(lx) - nqx <- ndx / lx - nAx <- (nLx - (AgeInt * shift.vector(lx,-1,NA))) / ndx - nAx[N] <- ex[N] - nMx <- ndx/nLx - Tx <- lt_id_L_T(nLx) - Sx <- lt_id_Ll_S(nLx, lx, AgeInt, N = 5) - - out <- data.frame( - Age = Age5, - AgeInt = AgeInt, - nMx = nMx, - nAx = nAx, - nqx = nqx, - lx = lx, - ndx = ndx, - nLx = nLx, - Sx = Sx, - Tx = Tx, - ex = ex - ) - return(out) -} - diff --git a/R/lt_single_qx.R b/R/lt_single_qx.R index c3f9baa1a..97eb42ed1 100644 --- a/R/lt_single_qx.R +++ b/R/lt_single_qx.R @@ -32,25 +32,42 @@ lt_single_qx <- function(nqx, SRB = 1.05, OAG = TRUE, OAnew = max(Age), - extrapLaw = "kannisto", + extrapLaw = NULL, extrapFrom = max(Age), - extrapFit = Age[Age >= 60], + extrapFit = NULL, ...) { stopifnot(extrapFrom <= max(Age)) Sex <- match.arg(Sex, choices = c("m","f","b")) a0rule <- match.arg(a0rule, choices = c("ak","cd")) - extrapLaw <- match.arg(extrapLaw, choices = c("kannisto", - "kannisto_makeham", - "makeham", - "gompertz", - "ggompertz", - "beard", - "beard_makeham", - "quadratic" - )) + if (!is.null(extrapLaw)){ + extrapLaw <- tolower(extrapLaw) + extrapLaw <- match.arg(extrapLaw, choices = c("kannisto", + "kannisto_makeham", + "makeham", + "gompertz", + "ggompertz", + "beard", + "beard_makeham", + "quadratic" + )) + } else { + extrapLaw <- ifelse(max(Age)>=90, "kannisto","makeham") + } + region <- match.arg(region, choices = c("w","n","s","e")) + if (is.null(extrapFit)){ + maxAclosed <- ifelse(OAG, Age[which.max(Age)-1],max(Age)) + if (maxAclosed < 85){ + extrapFit <- Age[Age >= (maxAclosed - 20) & Age <= maxAclosed] + } else { + extrapFit <- Age[Age >= 60 & Age <= maxAclosed] + } + } else { + stopifnot(all(extrapFit %in% Age)) + } + # Remove open age group 1qx=1 if it is included in the input vector if (OAG == TRUE | nqx[length(nqx)] >= 1.0) { @@ -64,13 +81,14 @@ lt_single_qx <- function(nqx, # compute ax: nAx <- rep(.5, N) - nAx[1] <- lt_rule_1a0(rule = a0rule, - q0 = nqx[1], - IMR = IMR, - Sex = Sex, - region = region, - SRB = SRB) - + if (Age[1] == 0){ + nAx[1] <- lt_rule_1a0(rule = a0rule, + q0 = nqx[1], + IMR = IMR, + Sex = Sex, + region = region, + SRB = SRB) + } # compute 1mx from 1qx and 1ax nMx <- lt_id_qa_m(nqx = nqx, nax = nAx, diff --git a/R/mig_beta.R b/R/mig_beta.R new file mode 100644 index 000000000..ffb1d21a8 --- /dev/null +++ b/R/mig_beta.R @@ -0,0 +1,235 @@ +# [ ] Jan 1 thing not ideal. +# [ ] C2 and last year can produce big negative in age 0. +# maybe cut it off and not return estimate for partial year +# [ ] use Lx ratios to project + +#' Estimate intercensal migration by comparing census population, by age and +#' sex, to the results of a RUP projection. +#' +#' @description +#' This methods projects population from the first starting point to next census +#' without migration and computes the "Net Census Error" (NCE) which is +#' Census - Estimate by age from projection. It then distributes the NCE over +#' the cohort parallelogram assuming uniform distribution assuming it is all +#' migration. It finalizes by summing the estimate by age groups across the entire +#' intercensal period to have a total migration during the entire period. +#' Alternatively, a child adjustment and an old age adjustment can be applied. +#' +#' @param c1 numeric vector. The first (left) census in single age groups +#' @param c2 numeric vector. The second (right) census in single age groups +#' @param date1 reference date of c1`. Either a Date class object or an unambiguous character string in the format "YYYY-MM-DD". +#' @param date2 reference date of c2`. Either a Date class object or an unambiguous character string in the format "YYYY-MM-DD". +#' @param age1 integer vector. single ages of `c1` +#' @param age2 integer vector. single ages of `c2` +#' @param dates_out vector of desired output dates coercible to numeric using `dec.date()` +#' @param lxMat numeric matrix containing lifetable survivorship, `l(x)`. Each row is an age group and each column a time point. At least two intercensal time points needed. +#' @param age_lx integer vector. Age classes in `lxMat` +#' @param dates_lx date, character, or numeric vector of the column time points for `lxMat`. If these are calendar-year estimates, then you can choose mid-year time points +#' @param births integer vector. Raw birth counts for the corresponding (sub)-population, one value per each year of the intercensal period including both census years. The first and last years should include all births in the given year; don't discount them in advance. +#' @param years_births numeric vector of calendar years of births. +#' @param location country name or LocID +#' @param sex character string, either `"male"`, `"female"`, or `"both"` +#' @param midyear logical. `FALSE` means all Jan 1 dates between `date1` and `date2` are returned. `TRUE` means all July 1 intercensal dates are returned. +#' @param verbose logical. Shall we send informative messages to the console? +#' +#' @param child_adjust The method with which to adjust the youngest age groups. +#' If \code{"none"}, no adjustment is applied (default). If +#' child-woman ratio (\code{"cwr"}) is chosen, the first cohorts reflecting the +#' difference between \code{date2 - date1} are adjusted (plus age 0). If +#' child constant ratio (\code{"constant"}) is chosen, the first 15 age groups +#' are adjusted. +#' +#' @param childage_max The maximum age from which to apply \code{child_adjust}. +#' By default, set to \code{NULL}, which gets translated into all the cohorts +#' between \code{date2} and \code{date1}. If \code{date2} is 2010 and +#' \code{date1} is 2002, the first 8 cohorts are adjusted. Otherwise, the user +#' can supply an integer. +#' +#' @param cwr_factor A numeric between 0 and 1 to which adjust the CWR method +#' for the young ages from \code{child_adjust}. \strong{This is only used +#' when \code{child_adjust} is \code{"cwr"}}. +#' +#' @param oldage_adjust The type of adjustment to apply to ages at and above +#' \code{oldage_min}. \code{'beers'} applies a beers graduation method +#' while \code{'mav'} applies a moving average with cascading on the tails. +#' For more information see \code{?mav} and \code{?graduation_beers}. +#' +#' @param oldage_min The minimum age from which to apply \code{oldage_adjust}. +#' By default, set to 65, so any adjustment from \code{oldage_adjust} will be +#' applied for 65+. +#' +#' @param ... optional arguments passed to \code{lt_single_qx} +#' @export +#' +#' @return a numeric vector of the total migration in the intercensal period +#' for each age. Ages are set as names of each migration estimate. +#' +#' @importFrom data.table := dcast +#' +#' @examples +#' +#' \dontrun{ +#' +#' mig_beta( +#' location = "Russian Federation", +#' sex = "male", +#' c1 = pop1m_rus2002, +#' c2 = pop1m_rus2010, +#' date1 = "2002-10-16", +#' date2 = "2010-10-25", +#' age1 = 0:100, +#' births = c(719511L, 760934L, 772973L, 749554L, 760831L, 828772L, 880543L, 905380L, 919639L) +#' ) +#' } +mig_beta <- function( + c1, + c2, + date1, + date2, + age1 = 1:length(c1) - 1, + age2 = 1:length(c2) - 1, + dates_out = NULL, + lxMat = NULL, + age_lx = NULL, + dates_lx = NULL, + births = NULL, + years_births = NULL, + location = NULL, + sex = "both", + midyear = FALSE, + verbose = TRUE, + child_adjust = c("none", "cwr", "constant"), + childage_max = NULL, + cwr_factor = 0.3, + oldage_adjust = c("none", "beers", "mav"), + oldage_min = 65, + ...) { + child_adjust <- match.arg(child_adjust) + oldage_adjust <- match.arg(oldage_adjust) + + # convert the dates into decimal numbers + date1 <- dec.date(date1) + date2 <- dec.date(date2) + + # If null, assume, the cohorts between censuses date2 and dates2 + if (is.null(childage_max)) { + childage_max <- as.integer(ceiling(date2) - floor(date1)) + } + + res_list <- rup( + c1 = c1, + c2 = c2, + date1 = date1, + date2 = date2, + age1 = age1, + age2 = age2, + dates_out = dates_out, + lxMat = lxMat, + age_lx = age_lx, + dates_lx = dates_lx, + births = births, + years_births = years_births, + location = location, + sex = sex, + midyear = midyear, + verbose = verbose, + ... = ... + ) + + pop_jan1 <- res_list$pop_jan1 + dates_out <- res_list$dates_out + + age <- NULL + year <- NULL + cum_resid <- NULL + decum_resid <- NULL + discount <- NULL + resid <- NULL + + # add "cumulative" residual to the RUP (pop_jan1_pre) + pop_jan1[, `:=`(cum_resid = resid * discount)] + pop_jan1 <- pop_jan1[!is.na(cohort)] + # Group by cohort and decumulate the residual with the first + # value being the first year of the cohort + pop_jan1 <- pop_jan1[, decum_resid := c(cum_resid[1], diff(cum_resid)), key = cohort] + + # Transform the long data frame to wide with ages on rows, years on columns + # and the decum_resid on the values. + mat_resid <- + data.table::dcast( + pop_jan1[, list(year, age, decum_resid)], + age ~ year, + value.var = "decum_resid" + ) + + # Sum over all ages to get a total decum_resid over all years for each age. + mig <- stats::setNames(rowSums(mat_resid, na.rm = TRUE), mat_resid$age) + + # Child adjustment + mig <- + switch( + child_adjust, + "none" = mig, + "cwr" = mig_beta_cwr(mig, c1, c2, date1, date2, n_cohs = childage_max, cwr_factor = cwr_factor), + "constant" = mig_beta_constant_child(mig, c1, c2, ageMax = childage_max) + ) + + # Old age adjustment + mig_oldage <- + switch( + oldage_adjust, + "none" = mig, + "beers" = graduate_beers(mig, as.integer(names(mig)), AgeInt = 1), + "mav" = mav(mig, names(mig), tails = TRUE) + ) + + # Only apply the old age adjustment on ages above oldage_min + ages_oldages <- as.integer(names(mig_oldage)) + mig[ages_oldages >= oldage_min] <- mig_oldage[ages_oldages >= oldage_min] + + mig +} + + +mig_beta_cwr <- function(mig, + c1_females, + c2_females, + date1, + date2, + maternal_window = 30, + maternal_min = 15, + n_cohs = NULL, + cwr_factor = 0.3) { + + age <- names2age(mig) + + # conservative guess at how many child ages to cover: + if (is.null(n_cohs)) n_cohs <- as.integer(ceiling(date2) - floor(date1)) + + mig_out <- mig + for (i in 1:n_cohs) { + # index maternal ages + a_min <- i + maternal_min + a_max <- min(i + maternal_min + maternal_window, 49) + mat_ind <- a_min:a_max + cwr_i <- (c1_females[i] / sum(c1_females[mat_ind]) + c2_females[i] / sum(c2_females[mat_ind])) / 2 + # proportional to maternal neg mig. + mig_out[i] <- cwr_factor * cwr_i * sum(mig[mat_ind]) + } + + mig_out +} + +# rough stb at constant child adjustment +mig_beta_constant_child <- function(mig, c1, c2, ageMax = 14) { + age <- names2age(mig) + + denom <- (c1 + c2) / 2 + + ind <- age <= ageMax + mig_rate_const <- sum(mig[ind]) / sum(denom[ind]) + + mig[ind] <- denom[ind] * mig_rate_const + + mig +} diff --git a/R/mig_rc.R b/R/mig_rc.R index a5bfc6716..8ec34743c 100644 --- a/R/mig_rc.R +++ b/R/mig_rc.R @@ -1,124 +1,125 @@ - # Functions to calculate and estimate Rogers-Castro migration age schedules - - # Author: MJA - ############################################################################### - - - #' Calculate Rogers-Castro migration age schedule - - #' @description Given a set of ages and parameters, calculate the migration age schedule based on the Rogers and Castro formula. - #' Choose between a 7,9,11 or 13 parameter model. - - #' @param ages numeric. A vector of ages for migration rates to be calculated. - #' @param pars numeric. A named list of parameters. See below for details. - #' @export - - #' @details In the full 13 parameter model, the migration rate at age x, \eqn{m(x)} is defined as - #' \deqn{m(x) = a1*exp(-1*alpha1*x) + a2*exp(-1*alpha2*(x - mu2) - exp(-1*lambda2*(x - mu2))) + a3*exp(-1*alpha3*(x - 3) - exp(-1*lambda3*(x - mu3))) + a4*exp(lambda4*x) + c} - #' - #' The first, second, third and fourth pieces of the equation represent pre-working age, working age, retirement and post-retirement age patterns, respectively. - #' Models with less parameters gradually remove terms at the older ages. Parameters in each family are: - #' \itemize{ - #' \item pre-working age: {a1, alpha1} - #' \item working age: {a2, alpha2, mu2, lambda2} - #' \item retirement: {a3, alpha3, mu3, lambda3} - #' \item post retirement: {a4, lambda4} - #' } - #' For a specific family to be included, values for all parameters in that family must be specified. - #' - #' @references - #' \insertRef{rogers1981model}{DemoTools} - #' @examples - #' pars <- c(a1= 0.09, alpha1= 0.1, a2= 0.2, - #' alpha2= 0.1, mu2= 21, lambda2= 0.39, a3= 0.001, - #' alpha3= 1, mu3= 67, lambda3= 0.6, c= 0.01) - #' ages <- 0:75 - #' mx <- mig_calculate_rc(ages = ages, pars = pars) - #' \dontrun{ - #' plot(ages, mx, type = 'l') - #'} - mig_calculate_rc <- function(ages, - pars){ - - # parameter name groups - comp1 <- c("a1", "alpha1") - comp2 <- c("a2", "alpha2", "lambda2", "mu2") - comp3 <- c("a3", "alpha3", "lambda3", "mu3") - comp4 <- c("a4", "lambda4") - - - # check for specific parameter groups - if (any(comp1 %in% names(pars))){ - stopifnot(all(comp1 %in% names(pars))) - } - if (any(comp2 %in% names(pars))){ - stopifnot(all(comp2 %in% names(pars))) - } - if (any(comp3 %in% names(pars))){ - stopifnot(all(comp3 %in% names(pars))) - } - if (any(comp4 %in% names(pars))){ - stopifnot(all(comp4 %in% names(pars))) - } - - pars_blank <- c(a1 = 0, alpha1 = 0, - a2 = 0, alpha2 = 0, mu2 = 0, lambda2 = 0, - a3 = 0, alpha3 = 0, mu3 = 0, lambda3 = 0, - a4 = 0, lambda4 = 0, - c = 0) - - pars_blank[names(pars)] <- pars - pars <- pars_blank - - x <- ages - mx <- - # pre working age - pars[["a1"]]*exp(-1 * pars[["alpha1"]]*x) + - - # working - pars[["a2"]]*exp(-1 * pars[["alpha2"]] * (x - pars[["mu2"]]) - - exp(-1 * pars[["lambda2"]] * (x - pars[["mu2"]]))) + - - # retirement - pars[["a3"]] * exp(-1 * pars[["alpha3"]] * (x - pars[["mu3"]]) - - exp(-1 * pars[["lambda3"]] * (x - pars[["mu3"]]))) + - - # post-retirement - pars[["a4"]] * exp(pars[["lambda4"]] *x ) + - - # intensity parameter - pars[["c"]] - - return(mx) - } - +# Functions to calculate and estimate Rogers-Castro migration age schedules + +# Author: MJA +############################################################################### + + +#' Calculate Rogers-Castro migration age schedule + +#' @description Given a set of ages and parameters, calculate the migration age schedule based on the Rogers and Castro formula. +#' Choose between a 7,9,11 or 13 parameter model. + +#' @param ages numeric. A vector of ages for migration rates to be calculated. +#' @param pars numeric. A named list of parameters. See below for details. +#' @export + +#' @details In the full 13 parameter model, the migration rate at age x, \eqn{m(x)} is defined as +#' \deqn{m(x) = a1*exp(-1*alpha1*x) + a2*exp(-1*alpha2*(x - mu2) - exp(-1*lambda2*(x - mu2))) + a3*exp(-1*alpha3*(x - 3) - exp(-1*lambda3*(x - mu3))) + a4*exp(lambda4*x) + c} +#' +#' The first, second, third and fourth pieces of the equation represent pre-working age, working age, retirement and post-retirement age patterns, respectively. +#' Models with less parameters gradually remove terms at the older ages. Parameters in each family are: +#' \itemize{ +#' \item pre-working age: {a1, alpha1} +#' \item working age: {a2, alpha2, mu2, lambda2} +#' \item retirement: {a3, alpha3, mu3, lambda3} +#' \item post retirement: {a4, lambda4} +#' } +#' For a specific family to be included, values for all parameters in that family must be specified. +#' +#' @references +#' \insertRef{rogers1981model}{DemoTools} +#' @examples +#' \dontrun{ +#' pars <- c(a1= 0.09, alpha1= 0.1, a2= 0.2, +#' alpha2= 0.1, mu2= 21, lambda2= 0.39, a3= 0.001, +#' alpha3= 1, mu3= 67, lambda3= 0.6, c= 0.01) +#' ages <- 0:75 +#' mx <- mig_calculate_rc(ages = ages, pars = pars) +#' plot(ages, mx, type = 'l') +#'} +mig_calculate_rc <- function(ages, + pars){ + + # parameter name groups + comp1 <- c("a1", "alpha1") + comp2 <- c("a2", "alpha2", "lambda2", "mu2") + comp3 <- c("a3", "alpha3", "lambda3", "mu3") + comp4 <- c("a4", "lambda4") + + + # check for specific parameter groups + if (any(comp1 %in% names(pars))){ + stopifnot(all(comp1 %in% names(pars))) + } + if (any(comp2 %in% names(pars))){ + stopifnot(all(comp2 %in% names(pars))) + } + if (any(comp3 %in% names(pars))){ + stopifnot(all(comp3 %in% names(pars))) + } + if (any(comp4 %in% names(pars))){ + stopifnot(all(comp4 %in% names(pars))) + } + + pars_blank <- c(a1 = 0, alpha1 = 0, + a2 = 0, alpha2 = 0, mu2 = 0, lambda2 = 0, + a3 = 0, alpha3 = 0, mu3 = 0, lambda3 = 0, + a4 = 0, lambda4 = 0, + c = 0) + + pars_blank[names(pars)] <- pars + pars <- pars_blank + + x <- ages + mx <- + # pre working age + pars[["a1"]]*exp(-1 * pars[["alpha1"]]*x) + + + # working + pars[["a2"]]*exp(-1 * pars[["alpha2"]] * (x - pars[["mu2"]]) - + exp(-1 * pars[["lambda2"]] * (x - pars[["mu2"]]))) + + + # retirement + pars[["a3"]] * exp(-1 * pars[["alpha3"]] * (x - pars[["mu3"]]) - + exp(-1 * pars[["lambda3"]] * (x - pars[["mu3"]]))) + + + # post-retirement + pars[["a4"]] * exp(pars[["lambda4"]] *x ) + + + # intensity parameter + pars[["c"]] + + return(mx) +} + # Author: MJA ############################################################################### #' Estimate Rogers-Castro migration age schedule - -#' @description Given a set of ages and observed age-specific migration rates, estimate the parameters of a Roger-Castro model migration schedule. -#' Choose between a 7,9,11 or 13 parameter model. - -#' @param ages numeric. A vector of ages. -#' @param mx numeric. A vector of observed age-specific migration rates. -#' @param pre_working_age logical (TRUE/FALSE). Whether or not to include pre working age component. -#' @param working_age logical (TRUE/FALSE). Whether or not to include working age component. -#' @param retirement logical (TRUE/FALSE). Whether or not to include retirement age component. -#' @param post_retirement logical (TRUE/FALSE). Whether or not to include post retirement age component. -#' @param ... additional inputs to stan, see ?rstan::stan for details. + +#' @description Given a set of ages and observed age-specific migration rates, estimate the parameters of a Roger-Castro model migration schedule. +#' Choose between a 7,9,11 or 13 parameter model. + +#' @param ages numeric. A vector of ages. +#' @param mx numeric. A vector of observed age-specific migration rates. +#' @param pre_working_age logical (TRUE/FALSE). Whether or not to include pre working age component. +#' @param working_age logical (TRUE/FALSE). Whether or not to include working age component. +#' @param retirement logical (TRUE/FALSE). Whether or not to include retirement age component. +#' @param post_retirement logical (TRUE/FALSE). Whether or not to include post retirement age component. +#' @param ... additional inputs to stan, see ?rstan::stan for details. #' @importFrom rstan stan extract #' @import Rcpp #' @importFrom stats quantile -#' @importFrom dplyr group_by summarise rename mutate +#' @importFrom dplyr group_by summarise rename mutate #' @importFrom rlang sym #' @importFrom tibble tibble #' @importFrom tibble as.tibble #' @importFrom tidybayes gather_draws #' @importFrom rstan extract #' @export -#' @examples +#' @examples +#' \dontrun{ #' # define ages and migration rates #' ages <- 0:75 #' mig_rate <- c(0.1014,0.0984,0.0839,0.0759,0.0679,0.0616, @@ -132,45 +133,45 @@ #' 0.0102,0.0109,0.0107,0.0143,0.0135,0.0134,0.0116,0.0099, #' 0.0093,0.0083,0.0078,0.0067,0.0069,0.0054) #' # fit the model -#' -#' res <- mig_estimate_rc(ages, mig_rate, -#' pre_working_age = TRUE, -#' working_age = TRUE, -#' retirement = FALSE, +#' +#' res <- mig_estimate_rc(ages, mig_rate, +#' pre_working_age = TRUE, +#' working_age = TRUE, +#' retirement = FALSE, #' post_retirement = FALSE) -#' \dontrun{ +#' #' # plot the results and data #' plot(ages, mig_rate, ylab = "migration rate", xlab = "age") #' lines(ages, res[["fit_df"]]$median, col = "red") #' legend("topright", legend=c("data", "fit"), col=c("black", "red"), lty=1, pch = 1) #' } -mig_estimate_rc <- function(ages, - mx, - pre_working_age, - working_age, - retirement, - post_retirement, - ...){ - - stopifnot(any(pre_working_age, working_age, retirement, post_retirement)) - - # data for model input - y <- mx - x <- ages - - mig_data <- list( - N = length(x), - y = y, - x = x, - pre_working_age = as.numeric(pre_working_age), - working_age = as.numeric(working_age), - retirement = as.numeric(retirement), - post_retirement = as.numeric(post_retirement) - ) - - # model - - rc_flexible <- 'data { +mig_estimate_rc <- function(ages, + mx, + pre_working_age, + working_age, + retirement, + post_retirement, + ...){ + + stopifnot(any(pre_working_age, working_age, retirement, post_retirement)) + + # data for model input + y <- mx + x <- ages + + mig_data <- list( + N = length(x), + y = y, + x = x, + pre_working_age = as.numeric(pre_working_age), + working_age = as.numeric(working_age), + retirement = as.numeric(retirement), + post_retirement = as.numeric(post_retirement) + ) + + # model + + rc_flexible <- 'data { int pre_working_age; // 0 = no, 1 = yes int working_age; // 0 = no, 1 = yes int retirement; // 0 = no, 1 = yes @@ -202,12 +203,12 @@ real sigma; vector[N] mu_rc_3; vector[N] mu_rc_4; vector[N] zero; - + for(i in 1:N){ zero[i] = 0; } - - + + mu_rc_1 = pre_working_age==1?a1[1]*exp(-alpha1[1]*x):zero; mu_rc_2 = working_age==1?a2[1]*exp(-alpha2[1]*(x - mu2[1]) - exp(-lambda2[1]*(x - mu2[1]))):zero; mu_rc_3 = retirement==1?a3[1]*exp(-alpha3[1]*(x - mu3[1]) - exp(-lambda3[1]*(x - mu3[1]))):zero; @@ -217,9 +218,9 @@ real sigma; model { // likelihood y ~ normal(mu_rc, sigma); - + //priors - + if(pre_working_age==1){ alpha1 ~ normal(0,1); a1 ~ normal(0,0.1); @@ -244,57 +245,57 @@ real sigma; sigma ~ normal(0,1); } ' - - # fit the model - #rc_fit <- rstan::sampling(stanmodels$rc_flexible, data = mig_data, ...) - rc_fit <- rstan::stan(model_code = rc_flexible, data = mig_data, ...) - - # extract the posterior samples - list_of_draws <- rstan::extract(rc_fit) - - # create a matrix to store fitted values - y_hat <- matrix(nrow = length(list_of_draws[[1]]), ncol = length(x)) - these_pars <- list() - parnames <- names(list_of_draws)[grep("alpha|a[0-9]|mu[0-9]|lambda|^c$",names(list_of_draws))] - for(j in 1:length(list_of_draws[[1]])){ - for(i in 1:length(parnames)){ - these_pars[[names(list_of_draws)[i]]] <- list_of_draws[[names(list_of_draws)[i]]][j] - } - y_hat[j,] <- mig_calculate_rc(ages = ages, pars = these_pars) - } - - dfit <- tibble(age = x, - data = y, median = apply(y_hat, 2, median), - lower = apply(y_hat, 2, quantile,0.025), - upper = apply(y_hat, 2, quantile, 0.975), - diff_sq = (!!sym("median") - !!sym("data"))^2) - - #TR: experimenting rm pipes re segfault error on osx... - pars_df <- gather_draws(rc_fit, !!sym("a[0-9]\\[1\\]"), - !!sym("alpha[0-9]\\[1\\]"), - !!sym("mu[0-9]\\[1\\]"), - !!sym("lambda[0-9]\\[1\\]"), - !!sym("^c$"), - regex = TRUE) %>% - group_by(!!sym(".variable")) %>% - summarise(median = median(!!sym(".value")), - lower = quantile(!!sym(".value"), 0.025), - upper = quantile(!!sym(".value"), 0.975)) %>% - dplyr::rename("variable" = !!sym(".variable")) %>% - mutate("variable" = gsub("\\[1\\]", "", "variable")) - - return(list(pars_df = pars_df, fit_df = dfit)) - - # for sake of R CMD checks - # .value <- .variable <- NULL - # dt <- as.data.table(pars_df) - # dt <- - # dt[, list(median = median( .value ), - # lower = quantile(.value, 0.025), - # upper = quantile(.value, 0.975)), - # by = list( .variable )] %>% - # setnames(".variable","variable") %>% - # as.tibble() - - return(list(pars_df = pars_df, fit_df = dfit)) + + # fit the model + #rc_fit <- rstan::sampling(stanmodels$rc_flexible, data = mig_data, ...) + rc_fit <- rstan::stan(model_code = rc_flexible, data = mig_data, ...) + + # extract the posterior samples + list_of_draws <- rstan::extract(rc_fit) + + # create a matrix to store fitted values + y_hat <- matrix(nrow = length(list_of_draws[[1]]), ncol = length(x)) + these_pars <- list() + parnames <- names(list_of_draws)[grep("alpha|a[0-9]|mu[0-9]|lambda|^c$",names(list_of_draws))] + for(j in 1:length(list_of_draws[[1]])){ + for(i in 1:length(parnames)){ + these_pars[[names(list_of_draws)[i]]] <- list_of_draws[[names(list_of_draws)[i]]][j] + } + y_hat[j,] <- mig_calculate_rc(ages = ages, pars = these_pars) + } + + dfit <- tibble(age = x, + data = y, median = apply(y_hat, 2, median), + lower = apply(y_hat, 2, quantile,0.025), + upper = apply(y_hat, 2, quantile, 0.975), + diff_sq = (!!sym("median") - !!sym("data"))^2) + + #TR: experimenting rm pipes re segfault error on osx... + pars_df <- gather_draws(rc_fit, !!sym("a[0-9]\\[1\\]"), + !!sym("alpha[0-9]\\[1\\]"), + !!sym("mu[0-9]\\[1\\]"), + !!sym("lambda[0-9]\\[1\\]"), + !!sym("^c$"), + regex = TRUE) %>% + group_by(!!sym(".variable")) %>% + summarise(median = median(!!sym(".value")), + lower = quantile(!!sym(".value"), 0.025), + upper = quantile(!!sym(".value"), 0.975))%>% + dplyr::rename("variable" = !!sym(".variable")) #%>% + #mutate("variable" = gsub("\\[1\\]", "", "variable")) + + return(list(pars_df = pars_df, fit_df = dfit)) + + # for sake of R CMD checks + # .value <- .variable <- NULL + # dt <- as.data.table(pars_df) + # dt <- + # dt[, list(median = median( .value ), + # lower = quantile(.value, 0.025), + # upper = quantile(.value, 0.975)), + # by = list( .variable )] %>% + # setnames(".variable","variable") %>% + # as.tibble() + + return(list(pars_df = pars_df, fit_df = dfit)) } diff --git a/R/mig_resid.R b/R/mig_resid.R index 00a7e6bb1..9f387864b 100644 --- a/R/mig_resid.R +++ b/R/mig_resid.R @@ -1,3 +1,30 @@ + +# TODO +# This is a high priority +# -[ ] make sure mig_resid_cohort() handles dimensions properly (named indexing; no waste dims) +# -[ ] make sure mig_resid_time() handles dimensions properly +# -[ ] check dims of incoming arguments. +# -[ ] new args years_pop, years_asfr, years_sr, years_srb (to be fed to checker) +# -[ ] write a dimension checker + trimming mig_resid_dim_check() +# -[ ] make this checker/trimmer the first step in mig_resid*() + +# This can come next +# -[ ] make new package data. usethis::use_data(pop_m_mat) +# -[ ] document new package data in data.R following other examples + +# Then this +# -[ ] write wrapper function, mig_resid() with an argumet 'method' +# with options "cohort", "stock" or "time", and all other args the same. + +# Then this +# -[ ] unit tests + +# Then this +# -[ ] sanity checks: do estimated migration patterns actually look reasonable in +# periods/places that are known to be strong in or out migration places. + + + #' Estimate net migration using residual methods: stock change, #' time even flow and cohort even flow #' @@ -20,6 +47,10 @@ #' an evenly distribution within the 5-year period, and half of the migrants #' get exposed both fertility and mortality within this period. #' +#' \code{mig_resid} is a general function able to call the three methods only by +#' specifying the \code{method} argument. By default it is set to the +#' \code{stock} method. See the examples section. +#' #' @param pop_m_mat A \code{numeric} matrix with population counts. Rows should #' be ages and columns should be years. Only five year age groups are supported. #' See examples. @@ -46,7 +77,7 @@ #' if the last year in these matrices is 2050, then the last year in #' \code{asfr_mat} should be 2045**. This row will usually have fewer age groups #' (rows) than in the population matrices or survival matrices, so the user -#' needs to supply the specific ages in the \code{ages_fertility} argument. +#' needs to supply the specific ages in the \code{ages_asfr} argument. #' #' @param srb_vec A \code{numeric} vector of sex ratios at birth for every year. #' The years should be the same as the years in \code{sr_m_mat}, @@ -55,427 +86,91 @@ #' @param ages A \code{numeric} vector of ages used in the rows in #' \code{pop_m_mat}, \code{pop_f_mat}, \code{sr_m_mat}, \code{sr_f_mat}. #' -#' @param ages_fertility A \code{numeric} vector of ages used in the rows in +#' @param ages_asfr A \code{numeric} vector of ages used in the rows in #' \code{asfr_mat}. #' +#' @param years_pop Years used in the column names of population. If +#' \code{pop_m_mat} or \code{pop_f_mat} doesn't have column names, these +#' names are used. Otherwise ignored. +#' +#' @param years_sr Years used in the column names of survival rates. If +#' \code{sr_r_mat} doesn't have column names, these names are used. Otherwise +#' ignored. +#' +#' @param years_asfr Years used in the column names of age-specific fertility +#' rate. If code{asfr_r_mat} doesn't have column names, these names are used. +#' Otherwise ignored. +#' +#' @param years_srb Years used in the column names of sex-ratio at birth. If +#' \code{srb_r_mat} is not named, these names are used. Otherwise ignored. +#' +#' @param verbose Default set to TRUE. If TRUE, the function prints important +#' operations carried out in the function like if years were trimmed from the +#' data. +#' +#' @param method which residual migration method to use. This only works when +#' using \code{mig_resid} and the possible options are 'stock', 'cohort' and +#' 'time', with 'stock' being the default. +#' #' @return A list with two matrices. One is for males (called `mig_m`) and the #' other for females (called `mig_f`). Both matrices contain net migration #' estimates by age/period using one of the three methods. #' #' @examples #' +#' library(DemoTools) +#' +#' # The data is loaded with DemoTools +#' #' ################ Stock change method ##################### #' -#' # Vector of population for males -#' pop_m <- -#' c(835, 671, 570.999, 544, 552, 550, 513, 487.998, 432.002, -#' 378.001, 338.001, 295.999, 263.001, 220.999, 156, 92.001, 42.204, -#' 18.001, 4.331, 0.639, 0.07, 989.592, 880.029, 697.435, 575.575, -#' 561.146, 595.087, 582.08, 544.567, 507.247, 440.909, 373.935, -#' 316.617, 265.548, 235.035, 182.951, 110.75, 57.555, 18.737, 5.459, -#' 0.807, 0.065, 1133.424, 1037.502, 905.664, 698.771, 586.798, -#' 616.9, 638.007, 615.889, 550.076, 504.215, 430.131, 353.696, -#' 286.403, 238.634, 194.496, 130.76, 69.399, 26.238, 5.809, 1.011, -#' 0.083, 1149.519, 1149.942, 1042.707, 897.087, 691.317, 605.519, -#' 628.132, 641.442, 608.262, 532.131, 486.313, 401.381, 321.04, -#' 251.388, 197.567, 138.127, 81.716, 32.255, 8.386, 1.152, 0.112, -#' 959.81, 1167.439, 1166.318, 1054.263, 929.596, 770.233, 655.408, -#' 649.175, 641.542, 602.148, 513.273, 463.968, 371.397, 286.345, -#' 203.426, 141.486, 87.742, 38.904, 10.533, 1.647, 0.131, 904.577, -#' 990.842, 1195.275, 1192.299, 1096.101, 1010.808, 817.203, 673.368, -#' 657.377, 631.756, 591.218, 483.434, 432.18, 330.595, 237.691, -#' 147.718, 86.849, 42.396, 13.172, 2.217, 0.2, 914.965, 926.002, -#' 1008.784, 1224.923, 1217.653, 1099.911, 1019.023, 813.755, 676.39, -#' 643.237, 614.691, 562.266, 449.355, 383.548, 273.038, 176.289, -#' 92.764, 43.563, 15.48, 3.067, 0.316, 943.289, 927.824, 937.572, -#' 1036.631, 1265.185, 1225.442, 1108.122, 1014.48, 806.487, 659.135, -#' 627.186, 594.356, 527.096, 404.537, 320.095, 205.116, 112.331, -#' 47.821, 16.391, 3.791, 0.466, 982.718, 980.995, 958.024, 988.65, -#' 1076.907, 1293.734, 1267.032, 1135.973, 1031.081, 804.56, 654.945, -#' 615.926, 567.992, 487.466, 348.485, 248.7, 133.025, 58.273, 17.722, -#' 3.888, 0.553, 1012.228, 1014.939, 1019.3, 1013.749, 1016.987, -#' 1100.959, 1315.154, 1281.21, 1143.215, 1026.976, 788.317, 641.579, -#' 592.945, 521.839, 418.599, 270.316, 163.215, 70.003, 21.874, -#' 4.186, 0.549, 914.063, 1038.649, 1049.297, 1073.621, 1055.672, -#' 1047.487, 1138.313, 1344.753, 1295.431, 1144.702, 1016.992, 771.165, -#' 615.065, 550.259, 457.748, 334.624, 185.735, 87.221, 26.085, -#' 4.898, 0.538, 879.05, 952.912, 1081.565, 1116.92, 1130.826, 1092.34, -#' 1097.179, 1186.645, 1381.02, 1305.446, 1143.75, 989.552, 751.696, -#' 577.344, 489.506, 377.661, 245.003, 105.627, 34.645, 6.138, 0.619, -#' 967.471, 930.238, 993.227, 1141.416, 1220.943, 1218.465, 1152.732, -#' 1154.005, 1219.105, 1404.229, 1303.056, 1126.891, 960.563, 712.717, -#' 522.094, 415.611, 295.598, 149.226, 44.788, 8.64, 0.793, 996.168, -#' 1002.283, 955.049, 1097.332, 1284.199, 1236.929, 1269.189, 1192.192, -#' 1174.32, 1216.076, 1400.008, 1311.348, 1099.315, 941.078, 652.11, -#' 452.242, 319.415, 186.665, 65.652, 11.458, 1.11, 1020.925, 1011.765, -#' 1014.23, 1017.281, 1208.233, 1389.541, 1315.956, 1321.892, 1224.232, -#' 1189.671, 1215.983, 1380.774, 1275.239, 1047.397, 867.426, 568.286, -#' 355.943, 205.33, 83.6, 17, 1.474, 1028.191, 1035.869, 1023.388, -#' 1074.814, 1125.935, 1311.078, 1465.662, 1367.022, 1352.787, 1239.604, -#' 1191.356, 1203.245, 1346.713, 1220.838, 973.366, 765.273, 455.163, -#' 235.912, 97.148, 22.528, 2.061, 1035.917, 1043.755, 1047.947, -#' 1086.086, 1187.203, 1232.794, 1390.453, 1518.531, 1399.596, 1369.011, -#' 1242.733, 1181.749, 1178.339, 1295.414, 1142.767, 869.016, 624.221, -#' 310.175, 115.614, 27.037, 2.784, 1045.967, 1052.236, 1056.4, -#' 1113.398, 1203.477, 1298.811, 1316.2, 1446.37, 1552.621, 1417.392, -#' 1372.669, 1234.502, 1160.392, 1138.346, 1219.39, 1029.28, 718.949, -#' 434.576, 156.257, 33.016, 3.417, 1068.682, 1062.337, 1064.906, -#' 1121.9, 1230.868, 1315.242, 1382.275, 1372.643, 1481.225, 1570.215, -#' 1421.698, 1364.113, 1214.291, 1124.645, 1077.332, 1107.059, 862.313, -#' 510.375, 224.598, 45.72, 4.224, 1102.822, 1085.121, 1075.057, -#' 1130.572, 1239.683, 1342.955, 1399.057, 1438.921, 1408.243, 1499.967, -#' 1574.252, 1414.059, 1343.384, 1179.959, 1069.144, 985.391, 938.14, -#' 623.089, 270.065, 67.236, 5.855, 1140.8, 1119.328, 1097.897, -#' 1140.924, 1248.743, 1352.213, 1427.121, 1456.061, 1474.768, 1428.008, -#' 1505.633, 1566.169, 1394.527, 1308.152, 1126.043, 984.266, 844, -#' 689.026, 337.068, 82.618, 8.662) -#' -#' # Vector of population for females -#' pop_f <- -#' c(801, 645, 554.001, 534, 557.999, 564, 521.001, 478.001, -#' 410.999, 352.999, 318, 276, 239, 196.998, 147, 92, 49.354, 23.001, -#' 6.5, 1.164, 0.135, 948.057, 844.618, 670.281, 562.978, 556.695, -#' 589.153, 595.677, 545.622, 488.336, 410.687, 346.698, 303.994, -#' 257.339, 222.218, 177.703, 111.516, 66.076, 25.155, 8.267, 1.423, -#' 0.145, 1082.85, 993.185, 866.81, 675.391, 590.032, 594.559, 626.777, -#' 624.823, 547.167, 485.337, 406.556, 337.02, 285.388, 243.185, -#' 202.252, 135.464, 80.488, 34.773, 9.379, 1.88, 0.182, 1091.999, -#' 1101.593, 998.637, 870.126, 696.038, 607.414, 608.372, 634.123, -#' 618.287, 534.182, 476.099, 390.902, 323.659, 270.819, 222.629, -#' 158.211, 99.985, 43.526, 13.425, 2.209, 0.243, 916.285, 1113.846, -#' 1116.448, 1022.769, 918.839, 752.674, 635.897, 619.411, 627.163, -#' 613.115, 524.316, 470.068, 384.21, 315.25, 247.486, 184.146, -#' 119.509, 56.879, 17.577, 3.347, 0.307, 858.616, 944.546, 1141.242, -#' 1148.666, 1080.544, 977.493, 784.947, 647.137, 627.282, 623.897, -#' 615.885, 510.514, 460.492, 370.614, 286.566, 207.64, 136.385, -#' 70.415, 24.027, 4.599, 0.483, 868.926, 877.749, 959.791, 1175.057, -#' 1195.136, 1093.776, 991.924, 782.722, 651.731, 622.015, 618.687, -#' 605.778, 500.641, 442.912, 341.607, 245.476, 158.844, 84.752, -#' 32.378, 7.171, 0.792, 895.173, 880.805, 893.824, 982.635, 1215.112, -#' 1205.436, 1108.77, 989.171, 783.703, 645.936, 620.163, 616.473, -#' 594.188, 483.99, 407.959, 294.664, 188.001, 102.344, 41.293, -#' 10.454, 1.36, 936.591, 930.873, 909.761, 937.09, 1040.314, 1261.087, -#' 1253.31, 1138.156, 1013.326, 789.43, 647.395, 618.625, 607.737, -#' 578.414, 450.459, 356.927, 227.408, 122.534, 50.048, 13.221, -#' 1.968, 962.734, 966.476, 967.107, 957.99, 982.293, 1078.452, -#' 1289.82, 1276.239, 1152.444, 1021.414, 790.697, 651.846, 612.561, -#' 584.997, 533.268, 389.96, 277.225, 150.795, 61.026, 16.175, 2.495, -#' 872.149, 989.229, 998.47, 1014.575, 1007.4, 1019.803, 1118.597, -#' 1322.793, 1295.408, 1160.933, 1017.656, 782.288, 640.445, 591.004, -#' 544.271, 468.132, 312.504, 184.648, 74.05, 18.888, 2.818, 831.614, -#' 907.289, 1032.916, 1054.491, 1087.81, 1064.803, 1079.765, 1163.223, -#' 1358.369, 1304.687, 1162.716, 1010.927, 777.628, 621.991, 554.866, -#' 485.032, 385.873, 214.234, 93.771, 23.583, 3.281, 918.838, 876.318, -#' 944.356, 1087.72, 1156.023, 1189.243, 1155.079, 1142.97, 1200.737, -#' 1385.864, 1307.092, 1157.85, 1000.01, 756.228, 585.003, 501.751, -#' 414.881, 275.154, 114.55, 31.799, 4.292, 950.252, 955.845, 901.601, -#' 1034.682, 1232.517, 1230.147, 1278.363, 1207.768, 1177.793, 1204.356, -#' 1388.633, 1309.444, 1137.271, 975.544, 718.972, 536.404, 423.543, -#' 303.137, 151.219, 39.364, 5.675, 972.207, 966.024, 968.771, 971.038, -#' 1155.236, 1343.606, 1310.409, 1330.404, 1239.077, 1193.687, 1207.497, -#' 1378.179, 1287.326, 1102.782, 925.427, 657.537, 458.654, 313.372, -#' 169.081, 52.593, 7.072, 976.405, 987.332, 978.581, 1036.217, -#' 1088.349, 1263.153, 1421.22, 1360.854, 1360.488, 1254.47, 1197.429, -#' 1200.365, 1355.979, 1250.443, 1049.613, 850.295, 565.065, 343.486, -#' 179.947, 59.846, 9.474, 983.61, 992.108, 1000.337, 1048.292, -#' 1157.406, 1200.03, 1343.652, 1473.399, 1392.3, 1376.507, 1258.974, -#' 1191.956, 1183.853, 1320.389, 1194.661, 970.4, 737.82, 429.619, -#' 201.231, 64.936, 11.111, 993.232, 1000.063, 1005.704, 1073.068, -#' 1174.732, 1273.909, 1284.275, 1398.562, 1506.421, 1409.749, 1381.642, -#' 1254.544, 1177.896, 1156.569, 1266.895, 1112.005, 851.243, 570.482, -#' 257.474, 74.251, 12.326, 1014.748, 1009.727, 1013.685, 1078.453, -#' 1199.539, 1291.299, 1358.178, 1339.471, 1432.104, 1523.907, 1415.474, -#' 1377.117, 1241.194, 1153.335, 1113.937, 1185.875, 984.267, 667.614, -#' 348.639, 96.877, 14.172, 1047.114, 1031.299, 1023.389, 1086.588, -#' 1205.189, 1316.366, 1375.813, 1413.531, 1373.503, 1450.422, 1529.735, -#' 1411.833, 1363.681, 1217.645, 1114.502, 1048.481, 1058.718, 782.58, -#' 415.883, 133.756, 18.362, 1083.119, 1063.736, 1045.012, 1096.489, -#' 1213.687, 1322.39, 1401.18, 1431.462, 1447.757, 1392.552, 1457.502, -#' 1526.287, 1399.672, 1340.065, 1180.192, 1054.342, 943.985, 853.051, -#' 496.821, 162.711, 25.414) -#' -#' # Vector of age-specific fertility rates -#' asfr <- c(50.369, 202.131, 206.141, 149.211, 87.253, 31.052, -#' 2.843, 57.919, 226.709, 222.516, 148.992, 87.888, 29.736, 2.64, -#' 54.096, 223.587, 211.46, 140.311, 76.881, 26.533, 2.132, 45.049, -#' 159.679, 156.131, 93.96, 50.059, 15.713, 1.409, 37.188, 119.39, -#' 132.748, 70.029, 28.02, 7.311, 0.514, 30.209, 101.658, 125.692, -#' 65.483, 19.804, 3.711, 0.243, 24.9, 88.815, 121.231, 68.621, -#' 20.031, 3.039, 0.163, 23.238, 78.247, 118.743, 75.403, 24.014, -#' 3.426, 0.129, 25.141, 75.764, 118.592, 85.555, 29.309, 4.303, -#' 0.136, 20.117, 64.41, 104.081, 85.589, 32.737, 5.247, 0.219, -#' 14.645, 53.484, 98.176, 92.658, 37.567, 6.397, 0.273, 13.677, -#' 51.37, 100.418, 104.868, 48.196, 8.278, 0.393, 11.494, 43.287, -#' 93.809, 106.904, 53.5, 10.662, 0.544, 8.387, 37.053, 86.307, -#' 106.038, 55.169, 11.345, 0.701, 6.625, 31.576, 80.064, 106.128, -#' 58.423, 13.087, 0.917, 5.468, 27.869, 76.196, 107.843, 62.296, -#' 15.036, 1.172, 4.686, 25.34, 73.943, 110.575, 66.487, 17.107, -#' 1.462, 4.134, 23.539, 72.551, 113.398, 70.423, 19.099, 1.756, -#' 3.732, 22.206, 71.53, 115.597, 73.588, 20.803, 2.024, 3.467, -#' 21.39, 71.244, 117.758, 76.268, 22.224, 2.249) -#' -#' # Vector of survival rates for males -#' sr_m <- c(0.95557549, 0.9921273, 0.99594764, 0.99510483, 0.99178483, -#' 0.99134461, 0.99100899, 0.98929784, 0.98473229, 0.97588706, -#' 0.96048519, 0.93812765, 0.90615821, 0.8622277, 0.8047363, -#' 0.71333856, 0.596832, 0.44396816, 0.30330032, 0.18642771, -#' 0.0911662462413327, 0.96275471, 0.99399428, 0.9968488, 0.99563281, -#' 0.99229006, 0.99196446, 0.99180061, 0.99013625, 0.98594365, -#' 0.97719516, 0.96239426, 0.93950426, 0.90620399, 0.86117682, -#' 0.80225284, 0.71307413, 0.60022645, 0.4558758, 0.31005161, -#' 0.18518342, 0.0956313878791117, 0.96951141, 0.99496609, 0.99727649, -#' 0.99607245, 0.99233725, 0.99205108, 0.99228027, 0.99056435, -#' 0.98605767, 0.97783685, 0.96314897, 0.9406932, 0.90642888, -#' 0.86286999, 0.80387894, 0.71498269, 0.6066814, 0.46479967, -#' 0.31958557, 0.19836001, 0.101989015830425, 0.97545992, 0.99563858, -#' 0.99741385, 0.99592654, 0.99152023, 0.99192115, 0.9924163, -#' 0.990644, 0.98617665, 0.97752991, 0.96353815, 0.94114166, -#' 0.90833701, 0.86170391, 0.80301014, 0.72151551, 0.6128495, -#' 0.47608317, 0.32653048, 0.19655555, 0.103730263806538, 0.98060776, -#' 0.99617149, 0.99761403, 0.99542383, 0.99054495, 0.99194397, -#' 0.99266261, 0.99089428, 0.98611279, 0.97789594, 0.96434779, -#' 0.94341044, 0.91191009, 0.86748795, 0.80686197, 0.72532159, -#' 0.61846149, 0.48319275, 0.33857582, 0.2104904, 0.112385162790671, -#' 0.98550309, 0.99688352, 0.99803301, 0.9959062, -#' 0.99126003, 0.99231634, 0.99301369, 0.99160392, 0.98761021, -#' 0.97986329, 0.96646197, 0.94623899, 0.91718051, 0.87584219, -#' 0.81662218, 0.73700918, 0.6303803, 0.50160307, 0.3651526, -#' 0.23288489, 0.130850768617506, 0.98931819, 0.99775357, 0.9984583, -#' 0.99673481, 0.99301824, 0.99346278, 0.99369545, 0.99294003, -#' 0.98994327, 0.98356936, 0.97206458, 0.95389895, 0.92644026, -#' 0.88661213, 0.82907732, 0.74960973, 0.64331764, 0.51551648, -#' 0.37629084, 0.24487989, 0.137677217644374, 0.99112504, 0.99814201, -#' 0.99879926, 0.99711429, 0.99389061, 0.99409107, 0.99396033, -#' 0.99290953, 0.99073493, 0.98586868, 0.97625645, 0.95984456, -#' 0.93401387, 0.89576747, 0.84146086, 0.76230416, 0.6528808, -#' 0.51875327, 0.37059318, 0.23716232, 0.129879589178461, 0.99268153, -#' 0.99853182, 0.99902021, 0.99755244, 0.99471893, 0.99453053, -#' 0.99383731, 0.99242559, 0.99039498, 0.98664094, 0.97888902, -#' 0.96514568, 0.94232807, 0.90695918, 0.85686765, 0.78068285, -#' 0.6693777, 0.52625072, 0.37539746, 0.23620331, 0.123653858706926, -#' 0.99378702, 0.99880557, 0.99916867, 0.99795758, 0.99537754, -#' 0.99534488, 0.99484455, 0.99357678, 0.99141921, 0.9878473, -#' 0.98134482, 0.96932265, 0.94941573, 0.91742454, 0.86776992, -#' 0.79533967, 0.68311452, 0.5343893, 0.37262307, 0.2239178, -#' 0.113720633638293, 0.99399248, 0.99897976, 0.99932852, 0.99822431, -#' 0.99601855, 0.99591387, 0.99569633, 0.99470259, 0.99268715, -#' 0.98892298, 0.98249955, 0.97238094, 0.9552462, 0.92844911, -#' 0.88653064, 0.82114141, 0.71875477, 0.56869525, 0.39721252, -#' 0.23529357, 0.113792166251756, 0.99425766, 0.99909623, 0.99940998, -#' 0.99846006, 0.99631257, 0.99603178, 0.99592291, 0.99518752, -#' 0.99322132, 0.98983274, 0.98368064, 0.9741733, 0.9602258, -#' 0.93745239, 0.9016288, 0.8444638, 0.75222073, 0.60907965, -#' 0.4240168, 0.24939352, 0.117336219766853, 0.99471736, 0.99933256, -#' 0.99947765, 0.99871556, 0.99694493, 0.99649396, 0.99655801, -#' 0.99589338, 0.99413263, 0.99084735, 0.98542046, 0.97725847, -#' 0.96497949, 0.9452114, 0.9134356, 0.8610204, 0.7737601, 0.63147622, -#' 0.43996206, 0.25585397, 0.117677375365884, 0.99489165, 0.99937715, -#' 0.99951763, 0.99880472, 0.99710652, 0.99665932, 0.99675852, -#' 0.99614922, 0.99444005, 0.99122406, 0.98598437, 0.97827319, -#' 0.96683874, 0.94835124, 0.91833471, 0.86821514, 0.78398104, -#' 0.64282533, 0.44786339, 0.25892654, 0.117310656081295, 0.99547488, -#' 0.99923281, 0.99957341, 0.99911343, 0.99802214, 0.99709297, -#' 0.99680896, 0.99635099, 0.99498899, 0.99222347, 0.9875931, -#' 0.98060053, 0.97014661, 0.9536392, 0.92634894, 0.87987019, -#' 0.79856151, 0.66278044, 0.47312791, 0.2694788, 0.111570323438865, -#' 0.99610316, 0.99933917, 0.9996362, 0.99923203, 0.99825186, -#' 0.99737383, 0.99710434, 0.99670571, 0.99548655, 0.99299216, -#' 0.9888173, 0.98253469, 0.97316181, 0.95828527, 0.93341992, -#' 0.89062075, 0.81386423, 0.68145805, 0.49006978, 0.27830681, -#' 0.113218864970809, 0.99653042, 0.99941146, 0.99967816, 0.99931356, -#' 0.99841616, 0.99758578, 0.9973301, 0.99697294, 0.99585907, -#' 0.99356834, 0.9897352, 0.98398011, 0.97540572, 0.96174959, -#' 0.93872789, 0.89876001, 0.8256409, 0.69618678, 0.50377247, -#' 0.28557404, 0.114591438080939, 0.99688677, 0.99947174, 0.99971275, -#' 0.99938206, 0.99855794, 0.99777511, 0.99753337, 0.99721139, -#' 0.99619015, 0.99408084, 0.99055187, 0.98526355, 0.97739317, -#' 0.9648224, 0.94346085, 0.90607063, 0.83636949, 0.70989474, -#' 0.51681708, 0.29260349, 0.115932510195963, 0.99718332, 0.99952193, -#' 0.9997412, 0.99943948, 0.99868001, 0.99794372, 0.99771578, -#' 0.99742349, 0.99648352, 0.99453532, 0.99127626, 0.98639967, -#' 0.97914803, 0.96753912, 0.94766613, 0.91261037, 0.84609618, -#' 0.7225789, 0.52915469, 0.29935668, 0.117233382382913, 0.99743526, -#' 0.99956461, 0.99976514, 0.9994886, 0.99878699, 0.99809597, -#' 0.99788161, 0.99761483, 0.99674727, 0.99494418, 0.99192807, -#' 0.98742013, 0.98072071, 0.96997658, 0.95145635, 0.91854221, -#' 0.85503156, 0.73446104, 0.54096047, 0.30591861, -#' 0.118509238191645) -#' -#' # Vector of survival rates for females -#' sr_f <- c(0.854489854276296, 0.935421167801612, 0.97813792986728, -#' 0.982021189677661, 0.976828336081795, 0.97244561985297, -#' 0.968812772150047, 0.96483427499772, 0.96010802339363, -#' 0.954056165687121, 0.943306039954761, 0.92448836548943, -#' 0.890690237758345, 0.835639114030282, 0.754796751406155, -#' 0.644175707707241, 0.510754359186887, 0.367690608641792, -#' 0.24038748937665, 0.145450728453873, 0.0826258994519641, -#' 0.872081445760557, 0.944846444000478, 0.981301676540409, -#' 0.98454923599414, 0.980025670920247, 0.976133157582757, -#' 0.972813894527646, 0.968976434023376, 0.964396307993652, -#' 0.958650557701456, 0.948256461919103, 0.930336619590153, -#' 0.898721683064412, 0.846943744756808, 0.7693050373115, -#' 0.660761281137989, 0.526356065457763, 0.380513624627523, -#' 0.249631099810745, 0.150641910916079, 0.0845984581684562, -#' 0.886848633625797, 0.952485090106336, 0.983750072193038, -#' 0.986500893000163, 0.982460467395807, 0.978978117640805, -#' 0.975938233552867, 0.972378413253193, 0.967941794833695, -#' 0.962223931611845, 0.952268831689409, 0.935291261627555, -#' 0.905449822961756, 0.856292233575997, 0.781888442354377, -#' 0.676068647825169, 0.542224475987347, 0.394762631381521, -#' 0.260252774164775, 0.156857215747202, 0.0874135544568921, -#' 0.900784558263659, 0.9596839642243, 0.986196123803518, -#' 0.988385232322206, 0.984769248387878, 0.981657532920333, -#' 0.978917213857464, 0.975642526638743, 0.971423457946261, -#' 0.965729507599766, 0.956020853088256, 0.939966236835617, -#' 0.912171280137383, 0.865872642393594, 0.794508147678775, -#' 0.691547047753295, 0.558414706244368, 0.408689574652693, -#' 0.269878505194327, 0.1624396495176, 0.0898671492416105, -#' 0.912633835108388, 0.965550681132028, 0.987920059015778, -#' 0.989848240747598, 0.986695608763104, 0.983981235542121, -#' 0.981570190639542, 0.97861812228183, 0.974635289736998, -#' 0.9691431860219, 0.959749667932423, 0.944374872196883, -#' 0.918112298204692, 0.874309263183862, 0.80582736469469, -#' 0.705435057343639, 0.573891155573389, 0.423123546270893, -#' 0.280818298136084, 0.169320472983824, 0.0930347806338448, -#' 0.922791200429312, 0.970414095250172, 0.989432301168788, -#' 0.990708732285749, 0.987862933459543, 0.98554556950358, -#' 0.983439950663867, 0.980726138018158, 0.976956585172812, -#' 0.971679032024458, 0.962795297767379, 0.948303265698793, -#' 0.923561621562827, 0.882274284142424, 0.817184362828982, -#' 0.720298723984997, 0.590336398050365, 0.439061608307152, -#' 0.293893306863672, 0.178752339638971, 0.0979770657163587, -#' 0.933750711567667, 0.975650023350237, 0.991430129981753, -#' 0.99247477931302, 0.989942622594004, 0.987846767986695, -#' 0.98591292962169, 0.983362542545618, 0.979767042495056, -#' 0.974726611965329, 0.96628359885727, 0.95251185213316, -#' 0.929005505885616, 0.889790085932051, 0.827762556372604, -#' 0.734212960407364, 0.606322257595734, 0.453895037584414, -#' 0.305625301261282, 0.186403154530675, 0.101364444633525, -#' 0.942022185331379, 0.979147123918558, 0.992515619501369, -#' 0.9933310350342, 0.990999245807151, 0.98905130373017, -#' 0.987257739978207, 0.984897031588263, 0.981492787306857, -#' 0.9766673141557, 0.968686240948038, 0.955634366723833, -#' 0.9333801029294, 0.895907358522987, 0.836661271636903, -#' 0.746801163214231, 0.621415950298903, 0.468910608066693, -#' 0.317915153427838, 0.195039481469627, 0.105384282613558, -#' 0.94718229582512, 0.980790142908247, 0.992803300931434, -#' 0.993541163348349, 0.991307476656705, 0.989225443921528, -#' 0.987176469101693, 0.98460623719428, 0.981246509709472, -#' 0.976718447241337, 0.969160984177711, 0.956833654346736, -#' 0.935783935128507, 0.900223655022325, 0.843512027545961, -#' 0.75698552882669, 0.634658767009268, 0.482935300037292, -#' 0.329848456620383, 0.20331169504299, 0.10978246168398, -#' 0.953756599857967, 0.984059901645376, 0.993955214747401, -#' 0.994268297381336, 0.991878910452198, 0.989316711233698, -#' 0.98661050317541, 0.983509725457937, 0.980068840413112, -#' 0.975865841537748, 0.96873162752321, 0.957191306973029, -#' 0.937336013374256, 0.903694171906013, 0.84952642553648, -#' 0.76536853834578, 0.645403389194791, 0.494479119379901, -#' 0.339863899010747, 0.210826549541289, 0.113471459046826, -#' 0.960713535654886, 0.987033073900882, 0.994716009106623, -#' 0.994894234746082, 0.992525302465177, 0.9895538842758, -#' 0.986152805334012, 0.982472321949589, 0.979073662581534, -#' 0.975395328209274, 0.968932259296626, 0.958359612326248, -#' 0.939967835580358, 0.908680780255339, 0.857541392392623, -#' 0.777353828146545, 0.661131513296524, 0.512711981039796, -#' 0.357346432815676, 0.224662101978509, 0.121638559000661, -#' 0.967668081909087, 0.990008068984907, 0.995560889886471, -#' 0.995641991716643, 0.993624470509278, 0.991059373658537, -#' 0.988040353436121, 0.984673329703723, 0.981470430737054, -#' 0.977934939728761, 0.971766487949973, 0.961780792273926, -#' 0.944588362056491, 0.915303175185752, 0.867175365253056, -#' 0.790635307536064, 0.677656963580601, 0.530729783448463, -#' 0.374404597176352, 0.237203123872316, 0.127388492872508, -#' 0.973550993968318, 0.99237559671888, 0.996334437474569, -#' 0.996302569319733, 0.994665042785698, 0.992854350176394, -#' 0.990804628097226, 0.988299827070781, 0.985427217612243, -#' 0.98180549401774, 0.975726794918091, 0.966103852460658, -#' 0.949838547130851, 0.92234926803937, 0.877071883537886, -#' 0.804140728455995, 0.694271895287286, 0.548487335263838, -#' 0.389191763586342, 0.24733085854494, 0.131770634512774, -#' 0.977644495019607, 0.993809059507753, 0.996921848401461, -#' 0.996813848508293, 0.995383460235151, 0.993952685083984, -#' 0.992408034278954, 0.990393195059418, 0.987756840918104, -#' 0.984187864274535, 0.978346485320431, 0.969132680765175, -#' 0.953701455005333, 0.92763044136048, 0.884677298385547, -#' 0.814988789377917, 0.708878868603095, 0.565946568832964, -#' 0.40677396957209, 0.26150417331884, 0.138468877454496, 0.99589669, -#' 0.99939439, 0.99968965, 0.99946356, 0.99900599, 0.99861604, -#' 0.99832041, 0.99779148, 0.99668581, 0.9946399, 0.9913872, -#' 0.98672374, 0.97979077, 0.96855904, 0.94971941, 0.9172498, -#' 0.85796829, 0.74889563, 0.57422822, 0.35395265, 0.158786622360056, -#' 0.9963443, 0.99946056, 0.99972569, 0.99951979, 0.99909662, -#' 0.99871978, 0.99844108, 0.9979583, 0.99694158, 0.99505178, -#' 0.99204825, 0.98775485, 0.98138426, 0.97102475, 0.95351064, -#' 0.92310744, 0.86661424, 0.76030246, 0.58585433, 0.36085561, -#' 0.160294341407215, 0.99679414, 0.99952694, 0.99976136, 0.99957681, -#' 0.99919131, 0.99883301, 0.99857404, 0.99814009, 0.99721897, -#' 0.99549888, 0.99276597, 0.98887133, 0.98310375, 0.97368874, -#' 0.95762803, 0.92951136, 0.87619312, 0.77320377, -#' 0.59930763, 0.36898278, 0.162083812814283, 0.9971375, 0.99957757, -#' 0.99978821, 0.99962071, 0.99926645, 0.99892672, 0.99868509, -#' 0.9982903, 0.99744714, 0.99586696, 0.99335694, 0.98978824, -#' 0.98451115, 0.97587178, 0.96101941, 0.93482131, 0.88424374, -#' 0.78427805, 0.61113191, 0.37625625, 0.163698785477625, 0.99744017, -#' 0.99962217, 0.9998116, 0.99965971, 0.99933486, 0.99901498, -#' 0.99879044, 0.99843159, 0.99766096, 0.99621214, 0.99391125, -#' 0.99064648, 0.985825, 0.97791169, 0.9642029, 0.93983665, -#' 0.89194494, 0.79508552, 0.62293587, 0.38364594, 0.165352911452495, -#' 0.99771115, 0.99966211, 0.99983233, 0.99969485, 0.99939794, -#' 0.99909887, 0.9988912, 0.99856572, 0.9978633, 0.996539, 0.9944362, -#' 0.99145779, 0.98706409, 0.97983722, 0.96722115, 0.94462117, -#' 0.89938678, 0.80574358, 0.63485152, 0.39124343, 0.167067858821075) -#' -#' -#' all_years <- c("1950", "1955", "1960", "1965", "1970", "1975", -#' "1980", "1985", "1990", "1995", "2000", "2005", -#' "2010", "2015", "2020", "2025", "2030", "2035", -#' "2040", "2045", "2050") -#' -#' # Population for males as matrix -#' pop_m_mat <- matrix(pop_m, nrow = 21, ncol = 21) -#' colnames(pop_m_mat) <- all_years -#' -#' # Population for females as matrix -#' pop_f_mat <- matrix(pop_f, nrow = 21, ncol = 21) -#' colnames(pop_f_mat) <- all_years -#' -#' # Age-specific-fertility-rate for as matrix -#' asfr_mat <- matrix(asfr, nrow = 7, ncol = 20) -#' colnames(asfr_mat) <- all_years[-length(all_years)] -#' -#' # Sex ratio at birth as vector -#' srb_vec <- c(1.058, 1.057, 1.055, 1.055, 1.06, 1.056, 1.056, 1.052, 1.056, -#' 1.054, 1.054, 1.053, 1.054, 1.053, 1.056, 1.056, 1.056, 1.056, -#' 1.056, 1.056) -#' -#' names(srb_vec) <- all_years[-length(all_years)] -#' -#' # Survival ratio for males as matrix -#' sr_m_mat <- matrix(sr_m, nrow = 21, ncol = 20) -#' colnames(sr_m_mat) <- all_years[-length(all_years)] -#' -#' # Survival ratio for females as matrix -#' sr_f_mat <- matrix(sr_f, nrow = 21, ncol = 20) -#' colnames(sr_f_mat) <- all_years[-length(all_years)] -#' -#' # Age/year sequence of all the data from above -#' interval <- 5 -#' ages <- seq(0, 100, by = interval) -#' years <- seq(1950, 2050, by = interval) -#' ages_fertility <- seq(15, 45, by = interval) +#' # Generic mig_resid method which allows to choose either stock, +#' # cohort or time method for five year ages groups #' #' mig_res <- -#' mig_resid_stock( -#' pop_m_mat = pop_m_mat, -#' pop_f_mat = pop_f_mat, -#' sr_m_mat = sr_m_mat, -#' sr_f_mat = sr_f_mat, -#' asfr_mat = asfr_mat, -#' srb_vec = srb_vec, -#' ages = ages, -#' ages_fertility = ages_fertility -#' ) +#' mig_resid( +#' pop_m_mat = pop_m_mat_five, +#' pop_f_mat = pop_f_mat_five, +#' sr_m_mat = sr_m_mat_five, +#' sr_f_mat = sr_f_mat_five, +#' asfr_mat = asfr_mat_five, +#' srb_vec = srb_vec_five, +#' ages = ages_five, +#' ages_asfr = ages_asfr_five, +#' # With the stock method +#' method = "stock" +#' ) +#' +#' # For single ages +#' +#' mig_res <- +#' mig_resid( +#' pop_m_mat = pop_m_mat_single, +#' pop_f_mat = pop_f_mat_single, +#' sr_m_mat = sr_m_mat_single, +#' sr_f_mat = sr_f_mat_single, +#' asfr_mat = asfr_mat_single, +#' srb_vec = srb_vec_single, +#' ages = ages_single, +#' ages_asfr = ages_asfr_single, +#' # With the stock method +#' method = "stock" +#' ) +#' +#' # Or directly the mid_resid_stock function +#' # (works for both single and five year age groups) +#' +#' mig_res <- +#' mig_resid_stock( +#' pop_m_mat = pop_m_mat_five, +#' pop_f_mat = pop_f_mat_five, +#' sr_m_mat = sr_m_mat_five, +#' sr_f_mat = sr_f_mat_five, +#' asfr_mat = asfr_mat_five, +#' srb_vec = srb_vec_five, +#' ages = ages_five, +#' ages_asfr = ages_asfr_five +#' ) #' #' # Net migration for males using stock change method #' mig_res$mig_m @@ -487,17 +182,50 @@ #' ################ cohort even flow method ##################### #' #' # We reuse the same data from before +#' # Either use the generic mig_resid choosing 'cohort' +#' +#' # Five year age groups +#' mig_res <- +#' mig_resid( +#' pop_m_mat = pop_m_mat_five, +#' pop_f_mat = pop_f_mat_five, +#' sr_m_mat = sr_m_mat_five, +#' sr_f_mat = sr_f_mat_five, +#' asfr_mat = asfr_mat_five, +#' srb_vec = srb_vec_five, +#' ages = ages_five, +#' ages_asfr = ages_asfr_five, +#' # With the cohort method +#' method = "cohort" +#' ) +#' +#' # Single ages +#' mig_res <- +#' mig_resid( +#' pop_m_mat = pop_m_mat_single, +#' pop_f_mat = pop_f_mat_single, +#' sr_m_mat = sr_m_mat_single, +#' sr_f_mat = sr_f_mat_single, +#' asfr_mat = asfr_mat_single, +#' srb_vec = srb_vec_single, +#' ages = ages_single, +#' ages_asfr = ages_asfr_single, +#' # With the stock method +#' method = "cohort" +#' ) +#' +#' # Or directly the mid_resid_cohort function #' #' mig_res <- #' mig_resid_cohort( -#' pop_m_mat = pop_m_mat, -#' pop_f_mat = pop_f_mat, -#' sr_m_mat = sr_m_mat, -#' sr_f_mat = sr_f_mat, -#' asfr_mat = asfr_mat, -#' srb_vec = srb_vec, -#' ages = ages, -#' ages_fertility = ages_fertility +#' pop_m_mat = pop_m_mat_five, +#' pop_f_mat = pop_f_mat_five, +#' sr_m_mat = sr_m_mat_five, +#' sr_f_mat = sr_f_mat_five, +#' asfr_mat = asfr_mat_five, +#' srb_vec = srb_vec_five, +#' ages = ages_five, +#' ages_asfr = ages_asfr_five #' ) #' #' # Net migration for males using the cohort even flow method @@ -509,17 +237,51 @@ #' ################ time even flow method ##################### #' #' # We reuse the same data from before +#' # Either use the generic mig_resid with the 'time' method +#' +#' # For five year age groups +#' mig_res <- +#' mig_resid( +#' pop_m_mat = pop_m_mat_five, +#' pop_f_mat = pop_f_mat_five, +#' sr_m_mat = sr_m_mat_five, +#' sr_f_mat = sr_f_mat_five, +#' asfr_mat = asfr_mat_five, +#' srb_vec = srb_vec_five, +#' ages = ages_five, +#' ages_asfr = ages_asfr_five, +#' # With the time method +#' method = "time" +#' ) +#' +#' # For single ages +#' mig_res <- +#' mig_resid( +#' pop_m_mat = pop_m_mat_single, +#' pop_f_mat = pop_f_mat_single, +#' sr_m_mat = sr_m_mat_single, +#' sr_f_mat = sr_f_mat_single, +#' asfr_mat = asfr_mat_single, +#' srb_vec = srb_vec_single, +#' ages = ages_single, +#' ages_asfr = ages_asfr_single, +#' # With the stock method +#' method = "stock" +#' ) +#' +#' # Or directly the mid_resid_time function +#' # (works for both five and single year ages) #' #' mig_res <- #' mig_resid_time( -#' pop_m_mat = pop_m_mat, -#' pop_f_mat = pop_f_mat, -#' sr_m_mat = sr_m_mat, -#' sr_f_mat = sr_f_mat, -#' asfr_mat = asfr_mat, -#' srb_vec = srb_vec, -#' ages = ages, -#' ages_fertility = ages_fertility +#' pop_m_mat = pop_m_mat_five, +#' pop_f_mat = pop_f_mat_five, +#' sr_m_mat = sr_m_mat_five, +#' sr_f_mat = sr_f_mat_five, +#' asfr_mat = asfr_mat_five, +#' srb_vec = srb_vec_five, +#' ages = ages_five, +#' ages_asfr = ages_asfr_five #' ) #' #' # Net migration for males using the time even flow method @@ -529,14 +291,74 @@ #' mig_res$mig_f #' #' @export +mig_resid <- function(pop_m_mat, + pop_f_mat, + sr_m_mat, + sr_f_mat, + asfr_mat, + srb_vec, + ages = NULL, + ages_asfr = NULL, + years_pop = NULL, + years_sr = NULL, + years_asfr = NULL, + years_srb = NULL, + verbose = TRUE, + method = c("stock", "cohort", "time")) { + + method <- match.arg(method) + if (verbose) cat(paste0("Using ", method, " residual migration method\n")) + + fun <- switch( + method, + stock = mig_resid_stock, + cohort = mig_resid_cohort, + time = mig_resid_time + ) + + res <- fun(pop_m_mat = pop_m_mat, + pop_f_mat = pop_f_mat, + sr_m_mat = sr_m_mat, + sr_f_mat = sr_f_mat, + asfr_mat = asfr_mat, + srb_vec = srb_vec, + ages = ages, + ages_asfr = ages_asfr, + years_pop = years_pop, + years_sr = years_sr, + years_asfr = years_asfr, + years_srb = years_srb, + verbose = verbose) + + res +} + +#' @rdname mig_resid +#' @export mig_resid_stock <- function(pop_m_mat, pop_f_mat, sr_m_mat, sr_f_mat, asfr_mat, srb_vec, - ages, - ages_fertility) { + ages = NULL, + ages_asfr = NULL, + years_pop = NULL, + years_sr = NULL, + years_asfr = NULL, + years_srb = NULL, + verbose = TRUE) { + + args_list_raw <- as.list(environment()) + + args_list <- mig_resid_dim_checker(args_list_raw) + + pop_m_mat <- args_list$pop_m_mat + pop_f_mat <- args_list$pop_f_mat + sr_m_mat <- args_list$sr_m_mat + sr_f_mat <- args_list$sr_f_mat + asfr_mat <- args_list$asfr_mat + srb_vec <- args_list$srb_vec stopifnot( is.matrix(pop_m_mat), @@ -546,51 +368,74 @@ mig_resid_stock <- function(pop_m_mat, is.matrix(asfr_mat), is.numeric(srb_vec), is.numeric(ages), - is.numeric(ages_fertility) + is.numeric(ages_asfr) ) + +# # Check in dimensions are ok - still working on this +# if(ncol(asfr_mat) == ncol(pop_f_mat) -1 & nrow(sr_f_mat) == nrow(pop_f_mat) -1){ +# print("matrix dimensions are correct") +# } +# else { +# print("check matrix dimensions") +# } +# +# #if there are extra years, drop it - still thinking the best way to deal with it +# if(ncols(asfr_mat) != ncols(sr_f_mat)){ +# asfr_mat <- asfr_mat[, colnames(sr_f_mat)] +# sr_f_mat <- sr_f_mat[, colnames(asfr_mat)] +# } +# else { +# asfr_mat +# sr_f_mat +# } + + # Migration net of only survivors - net_mig_m <- migresid_net_surv(pop_m_mat, sr_m_mat) - net_mig_f <- migresid_net_surv(pop_f_mat, sr_f_mat) + net_mig_m <- migresid_net_surv(pop_mat = pop_m_mat, + sr_mat = sr_m_mat) + net_mig_f <- migresid_net_surv(pop_mat = pop_f_mat, + sr_mat = sr_f_mat) - fertility_index <- which(ages %in% ages_fertility) + # fertility_index <- which(ages %in% ages_asfr) # Returns all births for all years age_interval <- unique(diff(ages)) all_births <- migresid_births( - pop_f_mat, - asfr_mat, - fertility_index, - age_interval + pop_f_mat = pop_f_mat, + asfr_mat = asfr_mat, + # fertility_index, + age_interval = age_interval ) # With all_births already calculated, separate between # female/male births with the sex ratio at birth - births_m <- all_births[2:length(all_births)] * (srb_vec / (1 + srb_vec)) - births_f <- all_births[2:length(all_births)] * (1 / (1 + srb_vec)) + byrs <- names(all_births) + births_m <- all_births * (srb_vec[byrs] / (1 + srb_vec[byrs])) + births_f <- all_births * (1 / (1 + srb_vec[byrs])) net_mig_m <- migresid_net_surv_first_ageg( - net_mig_m, - pop_m_mat, - births_m, - sr_m_mat + net_mig = net_mig_m, + pop_mat = pop_m_mat, + births = births_m, + sr_mat = sr_m_mat ) net_mig_f <- migresid_net_surv_first_ageg( - net_mig_f, - pop_f_mat, - births_f, - sr_f_mat + net_mig = net_mig_f, + pop_mat = pop_f_mat, + births = births_f, + sr_mat = sr_f_mat ) # First year is empty, so we exclude list( - mig_m = net_mig_m[, -1], - mig_f = net_mig_f[, -1] + mig_m = net_mig_m, + mig_f = net_mig_f ) } -#' @rdname mig_resid_stock +#' @rdname mig_resid #' @export mig_resid_cohort <- function(pop_m_mat, pop_f_mat, @@ -598,8 +443,25 @@ mig_resid_cohort <- function(pop_m_mat, sr_f_mat, asfr_mat, srb_vec, - ages, - ages_fertility) { + ages = NULL, + ages_asfr = NULL, + years_pop = NULL, + years_sr = NULL, + years_asfr = NULL, + years_srb = NULL, + verbose = TRUE) { + + # this arg list can feed into the checker + args_list_raw <- as.list(environment()) + + args_list <- mig_resid_dim_checker(args_list_raw) + + pop_m_mat <- args_list$pop_m_mat + pop_f_mat <- args_list$pop_f_mat + sr_m_mat <- args_list$sr_m_mat + sr_f_mat <- args_list$sr_f_mat + asfr_mat <- args_list$asfr_mat + srb_vec <- args_list$srb_vec # Estimate stock method mig_res <- @@ -611,7 +473,7 @@ mig_resid_cohort <- function(pop_m_mat, asfr_mat = asfr_mat, srb_vec = srb_vec, ages = ages, - ages_fertility = ages_fertility + ages_asfr = ages_asfr ) net_mig_m <- mig_res$mig_m @@ -629,12 +491,12 @@ mig_resid_cohort <- function(pop_m_mat, # Adjust last age group in the bounds mig_bounds <- migresid_bounds_last_ageg( - net_mig_m, - net_mig_f, - mig_upper_m, - mig_lower_m, - mig_upper_f, - mig_lower_f + net_mig_m = net_mig_m, + net_mig_f = net_mig_f, + mig_upper_m = mig_upper_m, + mig_lower_m = mig_lower_m, + mig_upper_f = mig_upper_f, + mig_lower_f = mig_lower_f ) mig_upper_m <- mig_bounds$mig_upper_m @@ -646,13 +508,13 @@ mig_resid_cohort <- function(pop_m_mat, mig_rectangle_m <- mig_upper_m + mig_lower_m mig_rectangle_f <- mig_upper_f + mig_lower_f - list( - mig_m = mig_rectangle_m[, -1], - mig_f = mig_rectangle_f[, -1] - ) + list( + mig_m = mig_rectangle_m, + mig_f = mig_rectangle_f + ) } -#' @rdname mig_resid_stock +#' @rdname mig_resid #' @export mig_resid_time <- function(pop_m_mat, pop_f_mat, @@ -660,8 +522,24 @@ mig_resid_time <- function(pop_m_mat, sr_f_mat, asfr_mat, srb_vec, - ages, - ages_fertility) { + ages = NULL, + ages_asfr = NULL, + years_pop = NULL, + years_sr = NULL, + years_asfr = NULL, + years_srb = NULL, + verbose = TRUE) { + # this arg list can feed into the checker + args_list_raw <- as.list(environment()) + + args_list <- mig_resid_dim_checker(args_list_raw) + + pop_m_mat <- args_list$pop_m_mat + pop_f_mat <- args_list$pop_f_mat + sr_m_mat <- args_list$sr_m_mat + sr_f_mat <- args_list$sr_f_mat + asfr_mat <- args_list$asfr_mat + srb_vec <- args_list$srb_vec # Estimate stock method mig_res <- @@ -673,7 +551,7 @@ mig_resid_time <- function(pop_m_mat, asfr_mat = asfr_mat, srb_vec = srb_vec, ages = ages, - ages_fertility = ages_fertility + ages_asfr = ages_asfr ) # Separate male/female net migration @@ -684,7 +562,7 @@ mig_resid_time <- function(pop_m_mat, net_mig_m[1, ] <- 2 * net_mig_m[1, ] net_mig_f[1, ] <- 2 * net_mig_f[1, ] - # Adjust age groups 5-10 to 100+ (of whatever maximum age groups) + # Adjust age groups 5-10 to 100+ (or whatever maximum age groups) for (i in 2:nrow(net_mig_m)) { double_pop_m <- (2 * net_mig_m[i, ]) double_pop_f <- (2 * net_mig_f[i, ]) @@ -708,54 +586,87 @@ mig_resid_time <- function(pop_m_mat, # Net migration is pop minus the people that survived from the previous # age/cohort migresid_net_surv <- function(pop_mat, sr_mat) { - n <- nrow(pop_mat) - p <- ncol(pop_mat) - survived <- pop_mat[-n, -p] * sr_mat[-1, ] - res <- pop_mat[-1, -1] - survived + n <- nrow(pop_mat) + p <- ncol(pop_mat) + survived <- pop_mat[-n, -p] * sr_mat[-1, ] + res <- pop_mat[-1, -1] - survived + + # We convert the first/last age group to NA because + # they need special treatment and will be treated. + # The last age group is treated by + # migresid_net_surv_last_age and the first age group + # is treated by migresid_net_surv_first_ageg. res[nrow(res), ] <- NA - res <- rbind(matrix(NA, nrow = 1, ncol = ncol(res)), res) - res <- cbind(matrix(NA, nrow = nrow(res), ncol = 1), res) - res <- migresid_net_surv_last_ageg(res, pop_mat, sr_mat) + res <- rbind(matrix(NA, nrow = 1, ncol = ncol(res)), res) + res <- migresid_net_surv_last_ageg(net_mig = res, + pop_mat = pop_mat, + sr_mat = sr_mat) + rownames(res) <- rownames(pop_mat) + colnames(res) <- colnames(pop_mat)[-p] res } # Net migration for last age group is pop for that age group in # year j, minus the people from the previous age group the survived migresid_net_surv_last_ageg <- function(net_mig, pop_mat, sr_mat) { + # TR: this uses position indexing. n <- nrow(pop_mat) p <- ncol(pop_mat) previous_year <- 1:(p - 1) - survived <- - (pop_mat[n, previous_year] + pop_mat[n - 1, previous_year]) * - sr_mat[n, previous_year] - - net_mig[nrow(net_mig), 2:ncol(net_mig)] <- pop_mat[n, 2:p] - survived + survived <- (pop_mat[n, previous_year] + pop_mat[n - 1, previous_year]) * sr_mat[n, previous_year] + + # Why -1? Because we want to get the ones that survived + # from the previous cohort. So for example, pop_mat begins + # with 1955 and survived begins in 1950 with the same length. + # Or in others, getting the migration in 1995 net of who survived + # in -1 year. + net_mig[nrow(net_mig), ] <- pop_mat[n, -1] - survived net_mig } migresid_births <- function(pop_f_mat, asfr_mat, - fertility_index, + #fertility_index, age_interval) { - p <- ncol(pop_f_mat) + p <- ncol(pop_f_mat) + asfr_ages <- rownames(asfr_mat) # Sum female pop from previous year and this year - f_pop <- pop_f_mat[fertility_index, -1] + pop_f_mat[fertility_index, -p] - + # f_pop <- pop_f_mat[asfr_ages, -1] + pop_f_mat[asfr_ages, -p] + yrs <- colnames(pop_f_mat) %>% as.numeric() + yrs_out <- yrs[-p] + diff(yrs) / 2 + f_expos <- interp( + pop_f_mat[asfr_ages, ], + datesIn = yrs, + datesOut = yrs_out, + method = "linear") + asfr_years <- yrs[-p] %>% as.character() # Births that occurred for all age groups for all years # based on the age-specific fertility rate (asfr) from # previous years to the population - these_births <- age_interval * (0.5 * (f_pop) * asfr_mat[, -p]) / 1000 - - all_births <- c(NA, colSums(these_births)) - col_names <- attr(pop_f_mat, "dimnames")[[2]] - all_births <- stats::setNames(all_births, col_names) - all_births + these_births <- age_interval * (f_expos * asfr_mat[ , asfr_years]) # / 1000 + these_births <- colSums(these_births) + names(these_births) <- asfr_years + # all_births <- c(NA, colSums(these_births)) + # col_names <- attr(pop_f_mat, "dimnames")[[2]] + # all_births <- stats::setNames(all_births, col_names) + # all_births + these_births } migresid_net_surv_first_ageg <- function(net_mig, pop_mat, births, sr_mat) { - p <- ncol(net_mig) - net_mig[1, 2:p] <- pop_mat[1, 2:p] - births * sr_mat[1, ] + # 20 yrs of births + # 21 yrs of population + # 20 yrs of sr + p <- ncol(net_mig) + pyrs <- colnames(pop_mat)[-1] + + # TR: a little hack + D <- pyrs %>% as.numeric() %>% diff() %>% '['(1) + byrs <- pyrs %>% as.numeric() %>% '-'(D ) %>% as.character() + # TR: note net_mig col labels seem to be one too high + # we want byrs indexing on the left + net_mig[1, ] <- pop_mat[1, pyrs] - births[byrs] * sr_mat[1, byrs] net_mig } @@ -769,21 +680,19 @@ migresid_bounds <- function(net_mig, sr_mat) { p <- ncol(net_mig) # Upper bound is net mig / 2 times the survival ratio ^ 0.5 - mig_upper <- net_mig / (2 * sr_mat^0.5) - mig_upper <- cbind(matrix(NA, ncol = 1, nrow = n), mig_upper) - mig_lower <- mig_upper + mig_upper <- net_mig / (2 * sr_mat^0.5) + mig_lower <- mig_upper mig_upper[1, ] <- NA mig_upper[n, ] <- NA mig_lower[n, ] <- NA - mig_lower <- mig_lower[-1, ] - empty_matrix <- matrix(NA, ncol = ncol(mig_lower), nrow = 1) - mig_lower <- rbind(mig_lower, empty_matrix) + mig_lower <- mig_lower[-1, ] + empty_matrix <- matrix(NA, ncol = ncol(mig_lower), nrow = 1) + mig_lower <- rbind(mig_lower, empty_matrix) # Estimate upper bounds for the first age group. Why # no lower bound for the first age group? because we have # no previous age group. - p_upper <- ncol(mig_upper) - mig_upper[1, 2:p_upper] <- net_mig[1, -p_upper] / (sr_mat[1, -p_upper]^0.5) + mig_upper[1, ] <- net_mig[1, ] / (sr_mat[1, ]^0.5) list(upper = mig_upper, lower = mig_lower) } @@ -798,15 +707,14 @@ migresid_bounds_last_ageg <- function(net_mig_m, # last age group - n <- nrow(mig_upper_m) - p <- ncol(mig_upper_m) + nr <- nrow(mig_upper_m) - mig_lower_m[n - 1, ] <- mig_upper_m[n - 1, ] - mig_lower_f[n - 1, ] <- mig_upper_f[n - 1, ] - mig_upper_m[n, 2:p] <- net_mig_m[n, -p] * 0.5 - mig_upper_f[n, 2:p] <- net_mig_f[n, -p] * 0.5 - mig_lower_m[n, 2:p] <- net_mig_m[n, -p] * 0.5 - mig_lower_f[n, 2:p] <- net_mig_f[n, -p] * 0.5 + mig_lower_m[nr - 1, ] <- mig_upper_m[nr - 1, ] + mig_lower_f[nr - 1, ] <- mig_upper_f[nr - 1, ] + mig_upper_m[nr, ] <- net_mig_m[nr, ] * 0.5 + mig_upper_f[nr, ] <- net_mig_f[nr, ] * 0.5 + mig_lower_m[nr, ] <- net_mig_m[nr, ] * 0.5 + mig_lower_f[nr, ] <- net_mig_f[nr, ] * 0.5 list( mig_lower_m = mig_lower_m, @@ -815,3 +723,172 @@ migresid_bounds_last_ageg <- function(net_mig_m, mig_upper_f = mig_upper_f ) } + + +mig_resid_dim_checker <- function(arg_list){ + + # TR: objectives, either we get args from a properly captured arg_list, + # or we simply pass in all args by name (maybe the easiest to be certain of) + # ground rules: + # age ranges should match for sr and pop. If they don't then we should trim to the + # lowest common denominator, right? + # year ranges depend on the input: + # sr, asfr, srb need to have same years, but pop needs one extra year on the right side. + + # Each data argument should be given adequate dimnames for purposes of named selection + # Each data argument should be trimmed as appropriate for conformable computations + # If trimming happens, we warn if verbose. + # This function basically just needs to return data inputs whose dimensions are + # guaranteed to not cause problems in downstream mig_resid*() calcs. + # the reason why we do this here is so that these many lines of code aren't repeated. + + pop_m_mat <- arg_list$pop_m_mat + pop_f_mat <- arg_list$pop_f_mat + sr_m_mat <- arg_list$sr_m_mat + sr_f_mat <- arg_list$sr_f_mat + asfr_mat <- arg_list$asfr_mat + srb_vec <- arg_list$srb_vec + ages <- arg_list$ages + ages_asfr <- arg_list$ages_asfr + + # Make sure to add these year args to top level mig_resid* funcions. + years_pop <- arg_list$years_pop + years_sr <- arg_list$years_sr + years_asfr <- arg_list$years_asfr + years_srb <- arg_list$years_srb + verbose <- arg_list$verbose + + # These are easier to insist on: + stopifnot(all(dim(pop_m_mat) == dim(pop_f_mat))) + stopifnot(all(dim(sr_m_mat) == dim(sr_f_mat))) + + # These args, could be NULL, so look to dimnames: + if (is.null(ages)){ + ages <- rownames(pop_m_mat) %>% as.numeric() + } + + if (ages[1] != 0) { + stop( + paste0( + "Ages must begin at zero. Ages currently begin at ", ages[1] + ) + ) + } + + if (is.null(years_pop)){ + ages_asfr <- rownames(asfr_mat) %>% as.numeric() + years_pop <- colnames(pop_m_mat) %>% as.numeric() + } + + if (is.null(years_asfr)){ + # TR: let's be careful that this doesn't end up hard coded at 15-45 or 15-49 + # when used throughout the functions. Hypothetically, it could have same ages + # as pop or mort, but have 0s in non-fertile ages, make sense? This note + # may be out of place, but came to mind here. + years_asfr <- colnames(asfr_mat) %>% as.numeric() + } + + if (is.null(years_sr)){ + years_sr <- colnames(sr_m_mat) %>% as.numeric() + } + + if (is.null(years_srb)){ + years_srb <- names(srb_vec) %>% as.numeric() + } + + # Note, after the above, the years/ ages could still be NULL, + # In this case we demand that dimensions already conform with expectations + + # For ages, we can guess from dims. For years, we can't guess from dims. + # Therefore at least one of the year vectors needs to be non-NULL, AND + # the dims of matrices to which NULL years correspond must already be correct. + + np <- ncol(pop_f_mat) + nsr <- ncol(sr_m_mat) + nfert <- ncol(asfr_mat) + nsrb <- length(srb_vec) + + dims_already_correct <- all(diff(c(np-1,nsr,nfert,nsrb) == 0)) + + ind_nulls <- c(years_pop = is.null(years_pop), + years_asfr = is.null(years_asfr), + years_srb = is.null(years_srb), + years_sr = is.null(years_sr)) + + # it's easiest to just force users to give year ranges via args + # or dimnames. If neither is available, just make them do it. + if (any(ind_nulls)){ + stop("Year references must be given, either via function args or dimnames. Following references missing:\n",paste(names(ind_nulls)[ind_nulls],collapse=", ")) + } + + # 1) assign names + colnames(pop_m_mat) <- years_pop + colnames(pop_f_mat) <- years_pop + colnames(asfr_mat) <- years_asfr + colnames(sr_m_mat) <- years_sr + colnames(sr_f_mat) <- years_sr + names(srb_vec) <- years_srb + + # maybe there should be more thorough checks on age? + # we might be assigning NULL here... + rownames(pop_m_mat) <- ages + rownames(pop_f_mat) <- ages + rownames(sr_m_mat) <- ages + rownames(sr_f_mat) <- ages + rownames(asfr_mat) <- ages_asfr + + # 2) determine ranges + # if dims aren't already correct + yr1 <- max(c(min(years_pop), + min(years_sr), + min(years_asfr), + min(years_srb))) + yrlast <- min(c(max(years_pop[-np]), + max(years_sr), + max(years_asfr), + max(years_srb))) + + interval <- diff(years_asfr)[1] %>% as.integer() + + # just remember we need 1 more for pops! + years_final <- seq(yr1, yrlast, by = interval) + years_final_p <- c(years_final, max(years_final) + interval) + + # Turn to character to be able to subset as column names + years_final <- as.character(years_final) + years_final_p <- as.character(years_final_p) + + # trim + pop_m_mat_trim <- pop_m_mat[, years_final_p] + + if (ncol(pop_m_mat) != length(years_final_p) && verbose) { + + years_excluded <- paste0( + setdiff(colnames(pop_m_mat), years_final_p), + collapse = ", " + ) + + warn_msg <- paste0( + "Years ", + years_excluded, + " have been trimmed from all the data\n" + ) + + cat(warn_msg) + } + + pop_f_mat_trim <- pop_f_mat[, years_final_p ] + sr_m_mat_trim <- sr_m_mat[, years_final ] + sr_f_mat_trim <- sr_f_mat[, years_final ] + asfr_mat_trim <- asfr_mat[, years_final ] + srb_vec_trim <- srb_vec[ years_final ] + + out <- list(pop_m_mat = pop_m_mat_trim, + pop_f_mat = pop_f_mat_trim, + sr_m_mat = sr_m_mat_trim, + sr_f_mat = sr_f_mat_trim, + asfr_mat = asfr_mat_trim, + srb_vec = srb_vec_trim) + + +} diff --git a/R/mig_un_fam.R b/R/mig_un_fam.R new file mode 100644 index 000000000..a5f516c19 --- /dev/null +++ b/R/mig_un_fam.R @@ -0,0 +1,206 @@ +#' Net migration by age for an UN family +#' @description Given a total net migration, +#' calculate the net migration age schedule based on the Rogers and Castro formula for UN families. +#' @param NM numeric. Total net migration to distribuite between ages and sex. +#' @param family character. Could be "Family", "Female Labor", "Male Labor". +#' @param Single logical. Results by simple age. Default `FALSE`. +#' Typically from pre-working age and working age parts of in Roger-Castro formula. +#' @param OAnew The age from which to group all ages into an open ended age group. +#' By default it is set to 100, so it groups all ages up to 120, which is the +#' maximum age. +#' @export +#' @importFrom stats aggregate +#' @importFrom stats as.formula +#' @return List with +#' \itemize{ +#' \item{params_RC} {data.frame. Roger-Castro parameters in a data.frame. Same as `mig_un_params` data.} +#' \item{net_migr} {data.frame. Net migrants by age and sex for the chosen family.} +#' } +#' @examples +#' # 10000 net migrants, comparing two possible families +#' nm1 <- mig_un_fam(NM = 10000, family = "Male Labor", OAnew = 100) +#' nm2 <- mig_un_fam(NM = 10000, family = "Family", OAnew = 100) +#' # See the female profile in for these models: +#' \dontrun{ +#' plot(nm1$net_migr$age[nm1$net_migr$sex=="Female"], +#' nm1$net_migr$nm[nm1$net_migr$sex=="Female"], +#' xlab="Age",ylab="nm",ylim=c(0,300)) +#' points(nm2$net_migr$age[nm2$net_migr$sex=="Female"], +#' nm2$net_migr$nm[nm2$net_migr$sex=="Female"], col=2) +#' } +mig_un_fam <- function(NM, family, Single = TRUE, OAnew = 100){ + + # TR added for global binding warnings + sex <- NULL + age <- NULL + . <- NULL + + mig_un_families <- DemoTools::mig_un_families + mig_un_params <- DemoTools::mig_un_params + + mig_sign <- ifelse(NM < 0, "Emigration", "Inmigration") + + # get asked + ind <- mig_un_params$family == family & + mig_un_params$mig_sign == mig_sign + this_params <- mig_un_params[ind, c("family","sex","param","median")] + + # TR: not priority, but it is also the case that we can do all this with only params + # see commented-out code below for how to estimate 'family' from params. + + ind <- mig_un_families$family == family & + mig_un_families$mig_sign == mig_sign + this_family <- mig_un_families[ind, c("family","sex","age","prop")] + + # get exact 1 + this_family$prop <- this_family$prop + this_family$prop/sum(this_family$prop) * (1-sum(this_family$prop)) + + # results + this_family$nm <- this_family$prop * NM + this_family$prop <- NULL + + # Group by family and sex and group ages according to the open + # age group defined in OAnew. + this_family <- as.data.table(this_family) + this_family <- this_family[, .(nm = groupOAG(nm, age, OAnew = OAnew), age = 0:OAnew), by = list(family, sex)] + + # single age + if(!Single){ + nm <- NULL + this_family$age <- trunc(this_family$age/5)*5 + this_family <- setDT(this_family)[order(sex,age), .(nm=sum(nm)), + by=.(family, age, sex)] %>% as.data.frame() + } + + # out + list(net_migr = this_family, + params_RC = this_params) +} + + +# data construction ------------------------------------------------------- + +## library(devtools) +## library(tidyverse) +## load_all() + +## # families from UN +## UN_flies <- readxl::read_excel("~/Downloads/UNPD_Migration Age Patterns-Lookup.xlsx", +## skip = 3, col_names = T) %>% +## rename(Type=1, Age=2) %>% +## gather(Sex,Prop,-Age,-Type) %>% +## mutate(Prop = Prop/100000) + +## # no retirement or old-age pattern +## UN_flies %>% ggplot() + +## geom_line(aes(Age, Prop, col=Type)) + +## facet_grid(~Sex) + coord_flip() + +## # one case - OK +## db <- UN_flies %>% dplyr::filter(Type == "Female Labor Emigration", Sex == "Male") +## a <- graduate(abs(db$Prop),db$Age,method = "sprague") +## b <- graduate(abs(db$Prop),db$Age,method = "beers(ord)") +## c <- graduate(abs(db$Prop),db$Age,method = "uniform") +## sum(a);sum(b);sum(c);sum(db$Prop) +## plot(db$Age,db$Prop/5,t="s",ylim=c(-.015,.015)) +## lines(0:80,-a,col=2) +## lines(0:80,-b,col=3) +## lines(0:80,-c,t="s",col=4) +## res <- mig_estimate_rc(0:120,as.numeric(a), +## pre_working_age = TRUE, +## working_age = TRUE, +## retirement = FALSE, +## post_retirement = FALSE) + +## lines(0:80, -res[["fit_df"]]$median, col = "violet") +## pars <- res$pars_df$median +## pars <- list(a1 =pars[1], alpha1 = pars[3], +## a2 = pars[2], alpha2 = pars[4], mu2 = pars[7], lambda2 = pars[6], +## c = pars[5]) + +## ages <- 0:120 +## mx_RC <- mig_calculate_rc(ages = ages, pars = pars) +## lines(0:80, -mx_RC, col = "black") +## sum(UN_flies %>% dplyr::filter(Type == "Female Labor Emigration", Sex == "Male") %>% pull(Prop)) +## sum(-res[["fit_df"]]$median) + +## # fit RC params +## .=NULL +## UN_params <- UN_flies %>% split(list(UN_flies$Sex,UN_flies$Type)) +## UN_params <- lapply(names(UN_params), +## function(X,M){ +## x = M[[X]] +## x_grad <- data.frame(mx = as.numeric(graduate(abs(x$Prop),x$Age,method = "sprague")), +## Age = 0:max(x$Age)) +## res <- mig_estimate_rc(x_grad$Age, x_grad$mx, +## pre_working_age = TRUE, +## working_age = TRUE, +## retirement = FALSE, +## post_retirement = FALSE) +## params <- res$pars_df +## params$Type = unique(x$Type) +## params$Sex = unique(x$Sex) +## params +## }, M = UN_params) %>% +## do.call("rbind",.) + +## # test gof +## UN_estimates <- UN_params %>% +## split(list(UN_params$Type,UN_params$Sex)) + +## UN_estimates <- lapply(names(UN_estimates), +## function(X,M){ +## x = M[[X]] +## pars <- pull(x[,"median"]) +## params <- c(a1 = pars[1], alpha1 = pars[3], +## a2 = pars[2], alpha2 = pars[4], mu2 = pars[7], lambda2 = pars[6], +## c = pars[5]) +## ages <- 0:120 +## out <- data.frame(Type = unique(x$Type), +## Sex = unique(x$Sex), +## Age = ages, +## Prop = mig_calculate_rc(ages, params)) +## out$Prop <- ifelse(stringr::str_detect(out$Type,"Emigration"),-out$Prop,out$Prop) +## out +## }, M = UN_estimates) %>% +## do.call("rbind",.) + +## UN_estimates %>% ggplot() + +## geom_line(aes(Age, Prop, col=Type)) + +## facet_grid(~Sex) + coord_flip() + +## tolerance_admited <- .005 +## test_that("lc w lim data works", { +## # total +## expect_equal( +## UN_flies %>% arrange(Type,Sex) %>% +## group_by(Type,Sex) %>% +## summarise(Prop = sum(Prop)) %>% pull(Prop), +## UN_estimates %>% arrange(Type,Sex) %>% +## mutate(Age = trunc(Age/5)*5) %>% +## group_by(Type,Sex) %>% +## summarise(Prop = sum(Prop)) %>% pull(Prop), +## tolerance = tolerance_admited) +## # by age +## expect_equal( +## UN_flies %>% arrange(Type,Sex,Age) %>% pull(Prop), +## UN_estimates %>% arrange(Type,Sex,Age) %>% +## mutate(Age = trunc(Age/5)*5) %>% +## group_by(Type,Sex,Age) %>% +## summarise(Prop = sum(Prop)) %>% pull(Prop), +## tolerance = tolerance_admited) +## }) + +## # save data +## UN_params$family <- trimws(gsub("Emigration|Immigration", "", UN_params$Type)) +## UN_params$mig_sign <- ifelse(stringr::str_detect(UN_params$Type,"Emigration"), +## "Emigration","Inmigration") +## UN_params$param <- rep(c("a1","a2","alpha1","alpha2","c","lambda2","mu2"), +## length(unique(UN_params$Type))*2) +## UN_estimates$family <- trimws(gsub("Emigration|Immigration", "", UN_estimates$Type)) +## UN_estimates$mig_sign <- ifelse(stringr::str_detect(UN_estimates$Type,"Emigration"), +## "Emigration","Inmigration") +## mig_un_params <- UN_params %>% select(family, sex=Sex, mig_sign, param, median) +## mig_un_families <- UN_estimates %>% select(family, sex=Sex, mig_sign, age=Age, prop=Prop) +## usethis::use_data(mig_un_params, overwrite = TRUE) +## usethis::use_data(mig_un_families, overwrite = TRUE) diff --git a/R/nAx.R b/R/nAx.R index 13ad93ef1..d7c0e5f7d 100644 --- a/R/nAx.R +++ b/R/nAx.R @@ -838,8 +838,12 @@ lt_a_un <- function(nMx, } else { axi[N] <- 1 / nMx[N] } - - + # patch + ind <- is.nan(axi) | axi < 0 + if (any(ind)){ + axi[ind] <- AgeInt[ind] / 2 + } + # if mx, qx, or both are given, then by now we have ax axi } @@ -996,6 +1000,7 @@ lt_id_morq_a <- function(nMx, OAG = TRUE, SRB = SRB) } + } if (axmethod == "un") { # UN method just CD west for now, so no region arg @@ -1033,9 +1038,10 @@ lt_id_morq_a <- function(nMx, extrapFit = extrapFit, ...) } - } + + # TR: shall we do ak patch just here at the end? # the alternative would be to mesh it in everywhere a0 happens. # ergo lt_rule_a0() as a new function diff --git a/R/smooth_age_5.R b/R/smooth_age_5.R index 45c8a1392..81d31490f 100644 --- a/R/smooth_age_5.R +++ b/R/smooth_age_5.R @@ -63,11 +63,11 @@ smooth_age_5_cf <- function(Value, out <- Value5 * NA # cut back down (depending) and name interleaf <- c(rbind(vodds, vevens)) - + if (start_on == 5){ interleaf <- interleaf[-1] } - + n <- min(c(length(interleaf), N)) out[1:n] <- interleaf[1:n] @@ -133,21 +133,21 @@ smooth_age_5_kkn <- function(Value, vodds <- Value10 / 2 + (v10R - v10L) / 16 # constrained in 10-year age groups vevens <- Value10 - vodds - + # if (start_on == 5){ # # this is the KNN operation # vevens <- Value10 / 2 + (v10R - v10L) / 16 # # constrained in 10-year age groups # vodds <- Value10 - vevens # } - # + # # stagger odd even 5s interleaf <- c(rbind(vodds, vevens)) - + if (start_on == 5){ interleaf <- interleaf[-1] } - + # produce results vector out <- Value5 * NA n <- min(c(length(interleaf), N)) @@ -442,14 +442,24 @@ smooth_age_5_zigzag <- function(Value, } #' Smooth in 5-year age groups using a moving average +#' #' @description Smooth data in 5-year age groups. #' @details This function calls \code{smooth_age_5_zigzag_inner()}, but prepares data in a way consistent with other methods called by \code{smooth_age_5()}. It is probably preferable to call \code{zigzag()} from the top level, or else call this method from \code{agesmth()} for more control over tail imputations. +#' #' @param Value numeric vector of (presumably) counts in 5-year age groups. #' @param Age integer vector of age group lower bounds. #' @param OAG logical. Whether or not the top age group is open. Default \code{TRUE}. #' @param n integer. The width of the moving average. Default 3 intervals (x-5 to x+9). +#' @param tails loglcal. If tails is \code{FALSE}, both tails are left untouched. +#' Otherwise, the tails are filled out using a cascade method. +#' #' @return numeric vector of smoothed counts in 5-year age groups. -#' @details This function calls \code{mav()}, which itself relies on the more general \code{ma()}. We lose the lowest and highest ages with this method, unless \code{n=1}, in which case data is returned in the original 5-year age groups. The total population count is not constrained to sum to the orignal total. +#' +#' @details If tails is set to \code{FALSE}, this function calls \code{mav()}, which itself relies on the more general \code{ma()}. We lose the lowest and highest ages with this method, unless \code{n=1}, in which case data is returned in the original 5-year age groups. The total population count is not constrained to sum to the orignal total. +#' +#' If tails is \code{TRUE}, the same results are expected but the tails are +#' filled in using a cascading method. +#' #' @examples #' Age <- c(0,1,seq(5,90,by=5)) #' # defaults @@ -466,11 +476,11 @@ smooth_age_5_zigzag <- function(Value, #' legend("topright", col = cols, lty = 1, lwd = lwds, legend = paste("n =",1:5)) #' } #' @export - smooth_age_5_mav <- function(Value, Age, OAG = TRUE, - n = 3) { + n = 3, + tails = FALSE) { Value <- groupAges(Value, Age = Age, N = 5) Age <- as.integer(names(Value)) @@ -479,7 +489,8 @@ smooth_age_5_mav <- function(Value, Value = Value, Age = Age, OAG = OAG, - n = n + n = n, + tails = tails ) Smoothed @@ -615,10 +626,10 @@ smooth_age_5_feeney <- function(Value, #' Smooth populations in 5-year age groups using various methods #' #' @description Smooth population counts in 5-year age groups using the Carrier-Farrag, -#' Karup-King-Newton, Arriaga, United Nations, Stong, or Zigzag methods. Allows for imputation +#' Karup-King-Newton, Arriaga, United Nations, Strong, MAV or Zigzag methods. Allows for imputation #' of values in the youngest and oldest age groups for the Carrier-Farrag, Karup-King-Newton, #' and United Nations methods. - +#' #' @details The Carrier-Farrag, Karup-King-Newton (KKN), and Arriaga methods do not modify the totals #' in each 10-year age group, whereas the United Nations, Strong, Zigzag, and moving average (MAV) methods do. The age intervals #' of input data could be any integer structure (single, abridged, 5-year, other), but @@ -627,8 +638,8 @@ smooth_age_5_feeney <- function(Value, #' #' The Carrier-Farrag, Karup-King-Newton, and United Nations methods do not produce estimates #' for the first and final 10-year age groups. By default, these are imputed with the original 5-year age group totals, but -#' you can also specify to impute with \code{NA}, or the results of the Arriaga or -#' Strong methods. If the terminal digit of the open age group is 5, then the terminal 10-year +#' you can also specify to impute with \code{NA}, or the results of the Arriaga, +#' Strong and Cascade methods. If the terminal digit of the open age group is 5, then the terminal 10-year #' age group shifts down, so imputations may affect more ages in this case. Imputation can follow #' different methods for young and old ages. #' @@ -640,7 +651,7 @@ smooth_age_5_feeney <- function(Value, #' #' @param Value numeric vector of counts in single, abridged, or 5-year age groups. #' @param Age integer vector of ages corresponding to the lower integer bound of the counts. -#' @param method character string. Options include \code{"Carrier-Farrag"},\code{"Arriaga"},\code{"KKN"},\code{"United Nations"}, \code{"Strong"}, and \code{"Zigzag"}. See details. Default \code{"Carrier-Farrag"}. +#' @param method character string. Options include \code{"Carrier-Farrag"},\code{"Arriaga"},\code{"KKN"},\code{"United Nations"}, \code{"Strong"}, \code{MAV} and \code{"Zigzag"}. See details. Default \code{"Carrier-Farrag"}. #' @param OAG logical. Whether or not the top age group is open. Default \code{TRUE}. #' @param ageMin integer. The lowest age included included in intermediate adjustment. Default 10. Only relevant for Strong method. #' @param ageMax integer. The highest age class included in intermediate adjustment. Default 65. Only relevant for Strong method. @@ -756,7 +767,7 @@ smooth_age_5 <- function(Value, ageMin = 10, ageMax = 65, n = 3, - young.tail = c("Original", "Arriaga", "Strong", NA), + young.tail = c("Original", "Arriaga", "Strong", "Cascade", NA), old.tail = young.tail) { method <- match.arg(method, c("Carrier-Farrag", @@ -766,8 +777,10 @@ smooth_age_5 <- function(Value, "Strong", "Zigzag", "MAV")) - young.tail <- match.arg(young.tail, c("Original", "Arriaga", "Strong", NA)) - old.tail <- match.arg(old.tail, c("Original", "Arriaga", "Strong", NA)) + + tail_methods <- c("Original", "Arriaga", "Strong", "Cascade", NA) + young.tail <- match.arg(young.tail, tail_methods) + old.tail <- match.arg(old.tail, tail_methods) method <- simplify.text(method) young.tail <- simplify.text(young.tail) @@ -858,6 +871,8 @@ smooth_age_5 <- function(Value, original <- groupAges(Value, Age = Age, N = 5) arriaga <- smooth_age_5_arriaga(Value, Age = Age, OAG = OAG) strong <- smooth_age_5_strong(Value, Age = Age, OAG = OAG) + mav_tails <- smooth_age_5_mav(Value, Age = Age, OAG = OAG, tails = TRUE) + # are the final entries NAs? if (nrle$values[length(nrle$values)] == 1 & !is.na(old.tail)) { nrle$values[1] <- 0 @@ -877,7 +892,10 @@ smooth_age_5 <- function(Value, stopifnot(length(strong) == length(out)) out[old.ind] <- strong[old.ind] } - + if (old.tail == "cascade") { + stopifnot(length(mav_tails) == length(out)) + out[old.ind] <- mav_tails[old.ind] + } } nrle <- rle(as.integer(nas)) # take care of young tail @@ -900,6 +918,11 @@ smooth_age_5 <- function(Value, stopifnot(length(strong) == length(out)) out[young.ind] <- strong[young.ind] } + if (young.tail == "cascade") { + stopifnot(length(mav_tails) == length(out)) + out[young.ind] <- mav_tails[young.ind] + } + } } # end tail operations diff --git a/R/utils-pipe.R b/R/utils-pipe.R index e79f3d808..fd0b1d13d 100644 --- a/R/utils-pipe.R +++ b/R/utils-pipe.R @@ -8,4 +8,7 @@ #' @export #' @importFrom magrittr %>% #' @usage lhs \%>\% rhs +#' @param lhs A value or the magrittr placeholder. +#' @param rhs A function call using the magrittr semantics. +#' @return The result of calling `rhs(lhs)`. NULL diff --git a/R/utilsAge.R b/R/utilsAge.R index 347c9f758..1320f2213 100644 --- a/R/utilsAge.R +++ b/R/utilsAge.R @@ -324,6 +324,7 @@ groupOAG <- function(Value, Age, OAnew) { N <- length(Value[Age <= OAnew]) Value[N] <- sum(Value[Age >= OAnew]) Value <- Value[1:N] + names(Value) <- Age[1:N] Value } @@ -568,16 +569,16 @@ names2age <- function(...) { #' @description This method rescales a vector of counts in arbitrary (integer) age groups to approximate a vector of counts in a potentially different age grouping. Common use cases will be to scale single ages (whose age pattern we wish to roughly maintain) to sum to abridged or 5-year age groups from another source. The counts to be rescaled could potentially be in any grouping (see example). #' @details If the final age group is open, define its age interval as 1. #' -#' Presently the intermediate splitting function can either be \code{graduate_uniform()} or \code{graduate_mono()}. +#' Presently the intermediate splitting function can either be `graduate_uniform()` or `graduate_mono()`. #' -#' The method is an original contribution. It works by first splitting the counts of \code{Value1} to single ages using the assumptions of \code{splitfun()}. \code{Value1} is then rescaled such that were it re-grouped to match the age classes of \code{Value2} they would be identical. If \code{recursive = FALSE}, the single-age rescaled \code{Value1} data are returned regrouped to their original ages. If \code{recursive = TRUE}, the process is repeated until \code{Value1} is rescaled such that it could be split and regrouped to \code{Value2} using the same process a single time with no need for further rescaling. If age groups in \code{Value1} are very irregular, \code{recursive = TRUE} can induce noise (see example). If the age groups of \code{Value1} nest cleanly within the age groups of \code{Value2} then recursion is unnecessary. This is the case, for example, whenever \code{Value1} is in single ages and \code{Value2} is in grouped ages, which is likely the most common usage scenario. +#' The method is an original contribution. It works by first splitting the counts of `Value1` to single ages using the assumptions of `splitfun()`. `Value1` is then rescaled such that were it re-grouped to match the age classes of `Value2` they would be identical. If `recursive = FALSE`, the single-age rescaled `Value1` data are returned regrouped to their original ages. If `recursive = TRUE`, the process is repeated until `Value1` is rescaled such that it could be split and regrouped to `Value2` using the same process a single time with no need for further rescaling. If age groups in `Value1` are very irregular, `recursive = TRUE` can induce noise (see example). If the age groups of `Value1` nest cleanly within the age groups of `Value2` then recursion is unnecessary. This is the case, for example, whenever `Value1` is in single ages and `Value2` is in grouped ages, which is likely the most common usage scenario. #' @param Value1 numeric vector. A vector of demographic counts for population 1. #' @param AgeInt1 integer vector. Age interval widths for population 1. #' @param Value2 numeric vector. A vector of demographic counts for population 2. #' @param AgeInt2 integer vector. Age interval widths for population 2. -#' @param splitfun function to use for splitting \code{pop1}. Presently on \code{graduate_uniform()} works. -#' @param recursive logical. Shall we repeat the split/regroup/rescale process until stable? See details. Default \code{FALSE}. -#' @param tol numeric. Default 1e-3. The numerical tolerance for the residual. Used to detect stability if \code{recursive = TRUE}. +#' @param splitfun function to use for splitting `Value1`. Reasonable (and tested) choices are either `graduate_uniform` or `graduate_mono`. +#' @param recursive logical. Shall we repeat the split/regroup/rescale process until stable? See details. Default `FALSE`. +#' @param tol numeric. Default `1e-3`. The numerical tolerance for the residual. Used to detect stability if `recursive = TRUE`. #' @export #' #' @examples @@ -654,7 +655,7 @@ rescaleAgeGroups <- function(Value1, AgeInt1, Value2, AgeInt2, - splitfun = c(graduate_uniform, graduate_mono), + splitfun = graduate_uniform, recursive = FALSE, tol = 1e-3) { N1 <- length(Value1) @@ -676,7 +677,11 @@ rescaleAgeGroups <- function(Value1, # step 2) regroup to groups of Value2 AgeN2 <- rep(Age2, times = AgeInt2) - beforeN <- groupAges(ValueS, AgeS, AgeN = AgeN2) + + # breaks here w graduate_mono() + beforeN <- groupAges(Value = ValueS, + Age = AgeS, + AgeN = AgeN2) # step 3) now repeat values of Value1 and Value2 for each single age # then rescale single age values. @@ -687,7 +692,9 @@ rescaleAgeGroups <- function(Value1, # step 4) group back to original age classes AgeN1 <- rep(Age1, times = AgeInt1) - out <- groupAges(SRescale, AgeS, AgeN = AgeN1) + out <- groupAges(Value = SRescale, + Age = AgeS, + AgeN = AgeN1) # step 5a) if no recursion, return now if (!recursive) { @@ -698,7 +705,9 @@ rescaleAgeGroups <- function(Value1, # Risky if an arbitrary splitting function is used... # equivalent of a while loop with no escape. newN <- splitfun(out, AgeInt = AgeInt1) - check <- groupAges(newN, AgeS, AgeN = AgeN2) + check <- groupAges(Value = newN, + Age = AgeS, + AgeN = AgeN2) if (max(abs(check - Value2)) < tol) { return(out) } else { diff --git a/R/utils_downloads.R b/R/utils_downloads.R new file mode 100644 index 000000000..af435bda2 --- /dev/null +++ b/R/utils_downloads.R @@ -0,0 +1,391 @@ + +# These utils might be used by basepop, interp_coh, OPAG, mig_resid*, +# and potentially others. + +#' Extract Lx estimates from WPP2019. Mainly an util function for other ones. +#' @description We extract `Lx` from `wpp2019`, interpolated to exact dates. Different methods availables. +#' A vector of countries can handle, but with an unique sex. Row names are not indicative of countries. +#' @param nLx numeric. either `NULL` or a numeric vector of lifetable exposure. If it's the second then we just pass it back. +#' @param location vector. UN Pop Div `LocName` or `LocID` +#' @param gender character. `"male"`, `"female"`, or `"both"` +#' @param nLxDatesIn numeric. Vector of three decimal dates produced by (or passed through) `basepop_five()` +#' @param method character. Could be `"linear"`, `"exponential"`, or `"power"` +#' +#' @return numeric matrix of `nLx` with `length(nLxDatesIn)` and abrdiged ages in rows. +#' @export +#' @importFrom stats setNames +#' @importFrom stats reshape +#' @importFrom fertestr is_LocID +#' @examples +#' # life expectancy calculated from Lx downloaded from WPP19. Using names or codes. +#' Lxs_name <- downloadnLx(nLx=NULL, location = "Argentina", +#' gender = "both", nLxDatesIn = 1950:2030) +#' Lxs_code <- downloadnLx(nLx=NULL, location = "32", +#' gender = "both", nLxDatesIn = 1950:2030) +#' \dontrun{ +#' plot(1950:2030, as.numeric(colSums(Lxs_name)), xlab = "Year", ylab="e0") +#' lines(1950:2030, as.numeric(colSums(Lxs_code))) +#' } +#' # life expectancy for different countries +#' Lxs_countries <- downloadnLx(nLx=NULL, location = c("Argentina","Brazil","Uruguay"), +#' gender = "both", nLxDatesIn = 1950:2025) +#' \dontrun{ +#' plot(1950:2025, as.numeric(colSums(Lxs_countries[1:22,])), +#' t="l", xlab = "Year", ylab="e0", ylim = c(40,80)) +#' lines(1950:2025, as.numeric(colSums(Lxs_countries[23:44,])), col=2) +#' lines(1950:2025, as.numeric(colSums(Lxs_countries[45:64,])), col=3) +#' legend("bottomright",c("Argentina","Brazil","Uruguay"),lty=1,col=1:3) +#' } +downloadnLx <- function(nLx, location, gender, nLxDatesIn, method="linear") { + + verbose <- getOption("basepop_verbose", TRUE) + + if (!is.null(nLx)) { + # TR: ensure colnames passed + nLx <- as.matrix(nLx) + colnames(nLx) <- nLxDatesIn + n <- nrow(nLx) + Age <- c(0,1,seq(5,(n-2)*5,by=5)) + rownames(nLx) <- Age + return(nLx) + } + + if (is.null(nLx)){ + + # stop/warnings + if (is.null(location)){ + stop("You need to provide a location to download the data for nLx") + } + if (!any(fertestr::is_LocID(location))) { + location_code <- fertestr::get_location_code(location) + }else { + location_code <- as.integer(location) + } + + if (verbose) { + cat(paste0("Downloading nLx data for ", location, ", years ", paste(nLxDatesIn,collapse=", "), ", gender ", gender), sep = "\n") + } + if(any(nLxDatesIn<1950,nLxDatesIn>2025)){ + cat("Careful, extrapolating beyond range 1950-2025") + } + + # handle sex + sex_code <- ifelse(tolower(gender) == "both", "b", + ifelse(tolower(gender) == "female", "f", + ifelse(tolower(gender) == "male", "m", NA))) + Sex_mortlaws <- ifelse(sex_code == "b", "total", tolower(gender)) + stopifnot(`Invalid sex name, please set it to 'both', 'male' or 'female'` = !is.na(sex_code)) + + # initial data + lt_wpp19 <-DemoToolsData::WPP2019_lt + + # filter and matrix shape + lt_ctry <- lt_wpp19[lt_wpp19$LocID %in% location_code & + lt_wpp19$Sex %in% sex_code,] %>% as.data.frame() %>% + stats::reshape(data = ., + direction = "wide", idvar = c("LocID","AgeStart","Sex"), + timevar = "Year", v.names = "mx", drop = c("AgeSpan","lx")) + + # intert/extrap rates and built life tables for each combination location/Sex/Year + .<-NULL + out <- cbind(lt_ctry[,c(1:3)], + interp(lt_ctry[,-c(1:3)], + seq(1953,2023,5), as.numeric(nLxDatesIn), + extrap = TRUE, method = method) %>% + as.data.frame() %>% + stats::setNames(as.character(nLxDatesIn)) + ) %>% + split(., list(lt_ctry$LocID, lt_ctry$Sex)) %>% + lapply(function(X){ + Age <- X[["AgeStart"]] + apply(X[,-c(1:3)] %>% + as.data.frame()%>% stats::setNames(as.character(nLxDatesIn)), 2, + function(S){ + # MortalityLaws::LifeTable(x = Age, + # mx = S, + # lx0 = 1, + # sex = Sex_mortlaws)$lt$Lx + DemoTools::lt_abridged(nMx=S, + Age = Age, + radix = 1, + Sex=sex_code)$nLx + }) + }) %>% + do.call("rbind", .) + + # combination as rowname + rownames(out) <- lt_ctry$AgeStart + + return(out) + } +} + +#' Extract ASFR estimates from WPP2019. Mainly an util function for other ones. +#' @description We extract `ASFRx` from `wpp2019`, interpolated to exact dates. Different methods availables. +#' A vector of countries can handle, but with an unique sex. Row names are not indicative of countries. +#' @param Asfrmat numeric. +#' @param location vector. UN Pop Div `LocName` or `LocID` +#' @param AsfrDatesIn numeric. Vector of decimal dates. +#' @param method character. Could be `"linear"`, `"exponential"`, or `"power"` +#' +#' @return numeric matrix interpolated asfr +#' @export +#' @importFrom fertestr get_location_code +#' @importFrom fertestr is_LocID +#' @importFrom stats setNames +#' @examples +#' # Total fertility ratio calculated from ASFRx downloaded from WPP19. +#' # See `downloadnLx` for analogous examples on multiple countries or using codes instead of names. +#' ASFR_Arg <- downloadAsfr(Asfrmat = NULL, location = "Argentina", AsfrDatesIn = 1950:2025) +#' \dontrun{ +#' plot(1950:2025, as.numeric(colSums(ASFR_Arg))*5, xlab = "Year", ylab="TFR", ylim=c(1.5,4), t="l") +#' } +downloadAsfr <- function(Asfrmat, location = NULL, AsfrDatesIn, method="linear") { + + verbose <- getOption("basepop_verbose", TRUE) + + if (!is.null(Asfrmat)) { + # TR: can we assume colnames are AsfrDatesIn ? + return(Asfrmat) + } + + # stop/warnings + if (is.null(location)){ + stop("You need to provide a location to download the data for Asfrmat") + } + if (!any(fertestr::is_LocID(location))) { + location_code <- fertestr::get_location_code(location) + }else { + location_code <- as.integer(location) + } + if (verbose) { + cat(paste0("Downloading ASFR data for ", location, ", years ", paste(AsfrDatesIn,collapse=", ")), sep = "\n") + } + if(any(AsfrDatesIn<1950,AsfrDatesIn>2025)){ + cat("Careful, extrapolating beyond range 1950-2025") + } + + # initial data + asfr_wpp19 <-DemoToolsData::WPP2019_asfr + + # spread format + asfr_ctry <- asfr_wpp19[asfr_wpp19$LocID %in% location_code,] %>% + as.data.frame() %>% + stats::reshape(direction = "wide", idvar = c("LocID","AgeStart"), + timevar = "Year", v.names = "ASFR") + + # interp/extrap + out <- interp(asfr_ctry[,-c(1:3)], seq(1953,2023,5), + as.numeric(AsfrDatesIn), + extrap = TRUE, method = method) %>% + as.data.frame() %>% + stats::setNames(as.character(AsfrDatesIn)) %>% + as.matrix() + + # combination as rowname + rownames(out) <- asfr_ctry$AgeStart + + return(out) +} + +#' Extract SRB estimates from WPP2019 +#' @description We use the `WPP2019_births` dataset from `DemoToolsData` for the sex ratio at birth. Births from WPP 2019 were graduates to single year totals. +#' @param SRB sex ratio at birth. Either `NULL`, a scalar to assume constant, or a vector of length 3, assumed. +#' @param location UN Pop Div `LocName` or `LocID` +#' @param DatesOut numeric vector of three decimal dates produced by `basepop_ive()` +#' @param verbose logical, shall we send optional messages to the console? +#' @return numeric vector with three SRB estimates +#' @export +#' @importFrom stats setNames + + +downloadSRB <- function(SRB, location, DatesOut, verbose = TRUE){ + + + + if (!is.null(SRB)) { + if (length(SRB) > 3) stop("SRB can only accept three dates at maximum") + + rep_times <- 3 - length(SRB) + SRB <- c(SRB, rep(SRB, times = rep_times)) + return(stats::setNames(SRB[1:3], DatesOut)) + } + + + if (length(DatesOut) > 3) stop("SRB can only accept three dates at maximum") + WPP2019_births <- DemoToolsData::WPP2019_births + SRB_default <- round((1 - .4886) / .4886, 3) + + if (! is_Loc_available(location)) { + if (verbose) { + cat(paste(location, "not available in DemoToolsData::WPP2019_births\n")) + cat(paste("Assuming SRB to be", SRB_default, "\n")) + } + + return(stats::setNames(rep(SRB_default, 3), DatesOut)) + } + + if (verbose){ + cat(paste0("\nbirths not provided. Downloading births for ", loc_message(location), ", for years between ", round(DatesOut[1], 1), " and ", round(DatesOut[length(DatesOut)], 1), "\n")) + } + LocID <- get_LocID(location) + ind <- WPP2019_births$LocID == LocID & + WPP2019_births$Year %in% floor(DatesOut) + years_srb <- WPP2019_births[ind, "Year", drop = TRUE] + SRB <- stats::setNames(WPP2019_births[ind, "SRB", drop = TRUE], years_srb) + + if (length(SRB) == 0) return(stats::setNames(rep(SRB_default, 3), DatesOut)) + + DatesOut <- floor(DatesOut) + yrs_present <- DatesOut %in% years_srb + if (any(!yrs_present)) { + yrs_not_present <- mean(SRB[as.character(DatesOut[yrs_present])]) + yrs_not_present <- stats::setNames(rep(yrs_not_present, sum(!yrs_present)), DatesOut[!yrs_present]) + SRB <- c(SRB, yrs_not_present) + } + + SRB <- SRB[order(as.numeric(names(SRB)))] + SRB +} + + +#' extract births from wpp2019 +#' @param births `NULL` or else a vector of births to simply return +#' @param yrs_births vector of years to extract +#' @param location UN Pop Dov `LocName` or `LocID` +#' @param sex `"male"`, `"female"`, or `"both"` +#' @param verbose logical, shall we send optional messages to the console? +#' @return vector of births +#' @export +#' @importFrom fertestr is_LocID +#' @importFrom fertestr get_location_code +fetch_wpp_births <- function(births, yrs_births, location, sex, verbose) { + + # fetch WPP births if not provided by user + if (is.null(births)) { + + # load WPP births + requireNamespace("DemoToolsData", quietly = TRUE) + WPP2019_births <- DemoToolsData::WPP2019_births + + + + + # filter out location and years + ind <- WPP2019_births$LocID == get_LocID(location) & + WPP2019_births$Year %in% yrs_births + b_filt <- WPP2019_births[ind, ] + bt <- b_filt$TBirths + SRB <- b_filt$SRB + + # extract births depending on sex + if (sex == "both") births <- bt + if (sex == "male") births <- bt * SRB / ( 1 + SRB) + if (sex == "female") births <- bt / (SRB + 1) + + if (verbose){ + cat(paste0("\nbirths not provided. Downloading births for ", loc_message(location), ", gender: ", "`", sex, "`, years: ",paste(yrs_births,collapse = ", "), "\n")) + } + } + + births +} + +interp_coh_download_mortality <- function(location, sex, date1, date2, OAnew = 100, verbose){ + + . <- NULL + + date1 <- dec.date(date1) + date2 <- dec.date(date2) + + year1 <- floor(date1) + 1 + year2 <- floor(date2) + + year_seq <- year1:year2 + + dates_out <- c(dec.date(date1), year_seq) + if (verbose){ + cat(paste0("\nlxMat not provided. Downloading lxMat for ", loc_message(location), ", gender: ", "`", sex, "`, for years between ", round(date1, 1), " and ", round(date2, 1), "\n")) + } + + PX <- suppressMessages(lapply(dates_out,fertestr::FetchLifeTableWpp2019, + locations = location, + sex = sex)) %>% + lapply(function(X){ + X[,c("year","x","mx")] + }) %>% + lapply(lt_a2s_chunk, OAnew = OAnew) %>% + lapply(function(X){ + 1 - X$nqx + }) %>% + do.call("cbind",.) + + + dimnames(PX) <- list(0:OAnew, dates_out) + + PX[PX > 1] <- 1 + # discount first and last periods. + + f1 <- diff(dates_out)[1] + f2 <- date2 - floor(date2) + + # assume linear px change within age class + PX[, 1] <- PX[, 1] ^f1 + PX[,ncol(PX)] <- PX[, ncol(PX)] ^f2 + + PX +} + + + +loc_message <- function(location){ + cds <- DemoToolsData::WPP_codes + if (fertestr::is_LocID(location)){ + LocName <- get_LocName(location) + LocID <- location + } else { + LocID <- get_LocID(location) + LocName <- location + } + paste0(LocName," (LocID = ",LocID,")") + +} + +get_LocID <- function(location){ + if (fertestr::is_LocID(location)){ + return(location) + } else { + cds <- DemoToolsData::WPP_codes + ind <- cds$LocName == location + if (!any(ind)){ + stop("requested LocName not found") + } + LocID <- cds[ind,"LocID"] %>% c() + return(LocID) + } +} +get_LocName <- function(location){ + if (fertestr::is_LocID(location)){ + cds <- DemoToolsData::WPP_codes + ind <- cds$LocID == location + if (!any(ind)){ + stop("requested LocID not found") + } + LocName <- cds[ind,"LocName"] %>% c() + return(LocName) + } else { + return(location) + } +} + +is_Loc_available <- function(location){ + isID <- fertestr::is_LocID(location) + cds <- DemoToolsData::WPP_codes + if (isID){ + out <- location %in% cds$LocID + } else { + out <- location %in% cds$LocName + } + out +} + diff --git a/README.md b/README.md index b8e89f835..df768eb4f 100644 --- a/README.md +++ b/README.md @@ -4,12 +4,14 @@ [![R build status](https://github.com/timriffe/DemoTools/workflows/R-CMD-check/badge.svg)](https://github.com/timriffe/DemoTools/actions) [![codecov](https://codecov.io/gh/timriffe/DemoTools/branch/master/graph/badge.svg)](https://codecov.io/gh/timriffe/DemoTools) -[![](https://img.shields.io/badge/devel%20version-01.11.03-yellow.svg)](https://github.com/timriffe/DemoTools) + +[![](https://img.shields.io/badge/devel%20version-01.13.55-yellow.svg)](https://github.com/timriffe/DemoTools) [![issues](https://img.shields.io/github/issues-raw/timriffe/DemoTools.svg)](https://github.com/timriffe/DemoTools/issues) [![lifecycle](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://www.tidyverse.org/lifecycle/#experimental) # Tools for aggregate demographic analysis -Date: 2021-01-12 +Date: 2021-05-31 + `DemoTools` is an R package that contains simple functions often used in demographic analysis. It is in active development. @@ -30,7 +32,8 @@ You can load the ```DemoTools``` package in R like so: # install.packages("devtools") library(devtools) - +# requires the development version of rstan, sorry! +install.packages("rstan", repos = c("https://mc-stan.org/r-packages/", getOption("repos"))) install_github("timriffe/DemoTools") ``` diff --git a/_pkgdown.yml b/_pkgdown.yml index fa1b5ac3b..0c43c45ef 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -20,7 +20,7 @@ reference: desc: Indicators to evaluate the degreee of age heaping contents: - starts_with("check_heaping") - - title: "Evaluate consitenty of age structures" + - title: "Evaluate consistency of age structures" desc: Methods to assess the consistency of age structures contents: - '`ageRatioScore`' @@ -51,13 +51,16 @@ reference: desc: Functions to interpolate counts contents: - '`interp`' - - '`interp_coh_bare`' + - '`interp_coh`' + - title: "Extrapolation" + desc: Functions to interpolate/extrapolate rates or counts + - '`interp_lc_lim`' + - '`lt_rule_m_extrapolate`' + - '`OPAG`' - title: "Migration" - desc: Functions for migration models + desc: Functions for migration models or estimation contents: - - '`mig_calculate_rc`' - - '`mig_estimate_rc`' - - '`mig_resid_stock`' + - starts_with("mig_") - title: "Miscelaneous data operations" contents: - '`groupAges`' @@ -85,9 +88,8 @@ reference: - title: "Auxiliary population structure functions" contents: - '`basepop_five`' - - '`basepop_single`' - '`calcAgeN`' - - '`census_cohort_adjust`' + - '`shift_census_ages_to_cohorts`' - '`dec.date`' - '`dth5_zigzag`' - '`fitted_logquad_b`' @@ -96,8 +98,12 @@ reference: - title: "Internal" desc: Internal functions contents: + - '`OPAG_fit_stable_standard`' + - '`OPAG_nLx_warp_r`' + - '`OPAG_r_min`' - '`OPAG_simple`' - - '`interp`' + - '`downloadSRB`' + - '`downloadnLx`' - '`ADM`' - '`age2ageN`' - '`age2int`' diff --git a/data-raw/examples_migresid.R b/data-raw/examples_migresid.R new file mode 100644 index 000000000..7e7a91643 --- /dev/null +++ b/data-raw/examples_migresid.R @@ -0,0 +1,682 @@ + + +################### For single ages year age groups ##################### + +# Vector of population for males +pop_m <- + c(46011,46514,48735,53185,57403,60020,63472,64955,65268,61853,60372,56365,55737,54188,51960,50854,51302,51310,52906,52011,50482,52187,53403,56249,59642,59454,60947,61687,59757,59948,63005,67548,68574,69056,68923,64527,61492,59630,58540,59615,59451,59775,60793,59447,58431,60118,59595,59054,61898,63808,65958,66805,67780,67466,66619,62014,56901,50008,47556,47461,45041,42714,40984,39320,37387,36423,37212,36594,36499,35006,35263,33928,33718,33577,32654,32342,30482,31057,30845,23826,21610,20155,18066,15752,14433.59,12565.72,10606.96,8911.94,7299.2,5877.03,4414.61,3413.12,2429.45,1701.38,1173,823,540,332,187,115,133, + 45309,46291,46652,48893,53295,57477,60109,63588,65113,65406,61972,60506,56490,55876,54329,52138,50992,51514,51417,53036,52080,50558,52339,53620,56529,59958,59699,61147,61921,59900,60083,63142,67572,68719,69057,68920,64522,61450,59574,58477,59496,59341,59681,60676,59338,58304,59960,59475,58840,61668,63597,65714,66546,67507,67153,66213,61645,56536,49656,47191,47017,44638,42259,40541,38794,36789,35827,36530,35863,35671,34119,34278,32821,32595,32348,31216,30866,28957,29257,28872,22116,19872,18353,16218,14027,12714.59,10894.72,8955.96,7456.94,5964.2,4659.03,3481.61,2579.12,1815.45,1208.38,834,547,358,213,119,141, + 46764,45641,46503,46902,49080,53464,57625,60277,63755,65302,65588,62175,60765,56697,56080,54532,52392,51201,51730,51581,53199,52292,50866,52734,54154,57028,60395,60091,61449,62287,60254,60359,63366,67716,68870,69188,69053,64574,61542,59641,58485,59539,59334,59663,60670,59303,58237,59869,59322,58712,61537,63422,65494,66298,67198,66857,65848,61287,56194,49291,46796,46586,44233,41804,40030,38222,36251,35201,35895,35039,34813,33233,33288,31712,31451,31048,29834,29311,27348,27458,26887,20484,18136,16584,14466,12372,10974.59,9236.72,7498.96,6149.94,4836.2,3683.03,2642.61,1898.12,1318.45,845.38,536,358,228,127,155, + 47214,47187,45911,46749,47174,49297,53704,57797,60499,63980,65488,65854,62407,61039,56953,56322,54784,52659,51464,51924,51788,53427,52569,51300,53292,54680,57583,60869,60499,61883,62701,60620,60721,63617,67914,69044,69319,69192,64703,61595,59677,58618,59555,59294,59661,60596,59275,58151,59769,59190,58588,61375,63243,65259,66010,66917,66522,65478,60878,55819,48910,46398,46164,43766,41301,39450,37643,35650,34550,35151,34283,33931,32268,32267,30604,30201,29709,28390,27797,25751,25507,24892,18733,16478,14772,12844,10744,9438.59,7775.72,6165.96,4955.94,3732.2,2837.03,1931.61,1386.12,928.45,567.38,330,222,140,152, + 49275,47631,47449,46190,47047,47404,49544,53918,58034,60706,64210,65720,66135,62678,61290,57198,56598,55088,52949,51653,52139,52029,53944,53130,51965,53855,55288,58066,61339,60942,62297,63041,60923,61052,63910,68152,69190,69502,69310,64788,61649,59764,58642,59590,59320,59636,60604,59214,58086,59681,59092,58416,61149,63023,65019,65725,66601,66155,65087,60415,55381,48519,46006,45689,43267,40773,38877,37005,35010,33827,34321,33438,33027,31233,31135,29419,28913,28302,26841,26193,23948,23648,22779,16970,14815,13035,11171,9106,7901.59,6376.72,4935.96,3914.94,2856.2,2091.03,1343.61,978.12,621.45,355.38,206,134,158, + 51138,49687,47852,47680,46438,47322,47587,49748,54127,58274,60944,64393,65920,66380,62910,61546,57461,56887,55386,53137,51846,52409,52501,54561,53777,52613,54324,55770,58540,61714,61327,62604,63342,61217,61231,64056,68304,69360,69569,69287,64913,61657,59692,58662,59591,59284,59608,60531,59084,57967,59520,58920,58275,60914,62775,64722,65380,66266,65776,64672,59973,54971,48023,45558,45202,42665,40145,38251,36338,34308,33048,33427,32529,31994,30152,30008,28174,27503,26855,25325,24466,22200,21645,20660,15182,13146,11340,9582,7641,6509.59,5193.72,3942.96,2971.94,2153.2,1531.03,964.61,660.12,384.45,225.38,133,168, + 52037,51460,49910,48059,47877,46626,47510,47765,49940,54321,58481,61124,64585,66113,66551,63125,61740,57660,57117,55563,53308,52116,52854,53141,55164,54451,53228,54824,56254,58916,61992,61571,62778,63495,61412,61329,64151,68445,69263,69559,69279,64884,61579,59679,58620,59564,59190,59496,60390,58940,57789,59335,58709,58087,60662,62447,64402,64951,65874,65357,64197,59441,54478,47559,45068,44602,42045,39511,37572,35595,33573,32234,32520,31598,30940,29081,28858,26921,26166,25390,23808,22760,20446,19821,18588,13518,11538,9807,8085,6317,5332.59,4143.72,3056.96,2234.94,1576.2,1106.03,666.61,449.12,252.45,128.38,173, + 52135,52476,51641,50081,48207,48036,46782,47628,47971,50044,54481,58658,61303,64765,66293,66740,63290,61943,57850,57260,55710,53562,52637,53643,53936,55904,55213,53850,55348,56727,59376,62391,61828,63065,63660,61621,61449,64245,68522,69253,69609,69227,64900,61549,59669,58555,59458,59118,59386,60260,58809,57656,59182,58462,57790,60371,62115,64025,64595,65432,64821,63645,58896,53957,47036,44481,43972,41360,38833,36853,34835,32821,31426,31615,30511,29780,27975,27598,25592,24683,23781,22099,21031,18591,17927,16484,11883,9905,8270,6715,5119,4237.59,3242.72,2267.96,1582.94,1105.2,759.03,442.61,293.12,159.45,187.38, + 54684,52730,52925,52057,50472,48506,48509,47110,48009,48357,50436,54929,59025,61708,65166,66672,67172,63729,62364,58240,57733,56425,54503,53887,54949,55071,57098,56200,54757,56183,57472,59954,63080,62324,63689,64108,62167,61730,64522,68782,69481,69807,69345,65088,61666,59757,58700,59456,59116,59376,60225,58724,57527,58972,58267,57567,60104,61790,63637,64191,64973,64312,63066,58312,53411,46426,43844,43340,40724,38154,36108,34067,31942,30585,30692,29424,28681,26757,26289,24177,23248,22129,20394,19299,16773,15983,14416,10342,8377,6904,5437,4081,3297.59,2435.72,1705.96,1135.94,781.2,496.03,296.61,173.12,205.83, + 55427,55242,53140,53368,52417,50809,48946,48864,47516,48396,48776,50878,55344,59407,62045,65580,67281,67882,64281,62724,58644,58335,57323,55781,55288,56233,56220,58145,57236,55710,57016,58225,60706,63731,62908,64245,64574,62635,62129,64924,69069,69797,69987,69487,65250,61813,59865,58787,59504,59105,59379,60134,58569,57411,58802,58074,57322,59820,61451,63257,63758,64522,63785,62464,57661,52790,45798,43215,42631,40063,37397,35379,33295,31074,29718,29722,28296,27550,25448,24966,22753,21700,20439,18669,17507,14996,14100,12528,8826,7027,5612,4337,3163,2501.59,1738.72,1210.96,750.94,544.2,318.03,181.61,210.95, + 56528,56162,55789,53638,53870,52819,51221,49360,49307,47970,48790,49197,51329,55769,59919,62549,66175,67953,68411,64643,63152,59088,59128,58441,56997,56507,57291,57286,59076,58162,56473,57777,58936,61243,64195,63406,64664,64851,62994,62475,65140,69208,69947,70109,69590,65308,61846,59891,58773,59425,59010,59277,60015,58384,57222,58607,57850,57028,59495,61075,62811,63294,63989,63231,61809,57004,52106,45155,42586,41852,39304,36610,34559,32464,30143,28720,28687,27181,26297,24186,23559,21196,20080,18714,16918,15705,13254,12229,10677,7391,5720,4540,3389,2355,1826.59,1271.72,816.96,510.94,359.2,208.03,218.56, + 57720,57188,56635,56210,54073,54261,53193,51641,49753,49726,48339,49239,49596,51849,56215,60461,63344,66904,68513,68789,65092,63694,60203,60518,59998,58452,57899,58534,58288,60107,58993,57266,58502,59544,61838,64743,63871,65097,65178,63352,62786,65436,69359,70120,70229,69650,65460,61913,59934,58819,59410,58968,59214,59893,58261,57088,58418,57604,56726,59160,60747,62429,62795,63483,62686,61125,56320,51438,44546,41911,41115,38544,35827,33680,31534,29167,27724,27557,25953,25017,22816,22049,19689,18512,17004,15185,13898,11538,10459,8928,6108,4622,3545,2552,1705,1285.59,880.72,545.96,325.94,214.2,236.59, + 59496,58366,57606,56944,56519,54366,54549,53547,51884,50102,50016,48645,49552,49897,52223,56659,61106,64082,67450,68877,69153,65572,64671,61600,62005,61517,59933,59093,59646,59035,60964,59638,57840,58996,59954,62268,65009,64119,65289,65299,63567,62942,65544,69419,70115,70231,69629,65398,61835,59920,58724,59326,58801,59051,59686,58075,56798,58152,57307,56365,58765,60306,61953,62249,62821,61983,60397,55560,50743,43873,41117,40303,37679,34976,32758,30575,28146,26678,26308,24602,23649,21337,20490,18116,16878,15315,13418,12133,9890,8801,7360,4897,3626,2725,1888,1228,903.59,582.72,357.96,205.94,233.79, + 57359,60199,58808,57971,57288,56802,54614,54836,53794,52202,50400,50332,48971,49896,50306,52783,57550,62016,64628,67791,69202,69571,66177,65504,62435,62850,62430,60669,59751,60222,59660,61504,60123,58297,59456,60300,62583,65334,64383,65513,65536,63774,63080,65686,69517,70172,70229,69610,65367,61856,59831,58676,59205,58678,58906,59507,57827,56571,57900,56975,56008,58388,59865,61425,61706,62157,61199,59594,54772,49929,43091,40341,39445,36778,34055,31853,29533,27003,25513,25033,23263,22282,19868,18924,16487,15120,13666,11727,10443,8352,7322,5911,3827,2780,2021,1355,844,608.59,391.72,225.96,263.73, + 58309,58059,60713,59270,58372,57661,57207,55017,55213,54209,52588,50781,50768,49421,50408,51005,53772,58464,62590,64959,68172,69633,70276,67072,66421,63400,63620,63151,61321,60362,60767,60172,62061,60544,58693,59813,60609,62958,65651,64659,65707,65763,63964,63192,65873,69612,70232,70267,69610,65318,61798,59777,58627,59031,58567,58701,59245,57585,56338,57606,56688,55619,58009,59398,60879,61085,61424,60441,58785,53921,49114,42318,39520,38540,35781,33028,30811,28446,25802,24313,23682,21831,20745,18293,17278,14824,13434,11897,10092,8743,6849,5869,4660,2913,2054,1428,935,544,392.59,249.72,261.7, + 58649,59039,58721,61260,59825,59012,58259,57858,55695,55908,54901,53319,51412,51540,50159,51294,52075,54930,59303,63191,65509,68717,70380,71269,68113,67543,64434,64599,63986,62199,61068,61415,60722,62630,61120,59198,60299,61052,63295,66041,64953,66017,66035,64284,63400,66064,69752,70370,70368,69655,65313,61816,59707,58581,58927,58434,58619,59028,57390,56059,57265,56292,55179,57532,58871,60249,60413,60677,59620,57952,53017,48189,41429,38671,37574,34699,31947,29708,27360,24658,23059,22309,20425,19214,16730,15603,13222,11861,10280,8546,7232,5545,4551,3579,2156,1462,1001,629,334,260.59,295.41, + 59584,59489,59807,59395,61909,60375,59709,58891,58475,56305,56538,55521,53958,52106,52295,51042,52562,53392,55983,60076,63988,66497,69807,71632,72659,69542,68963,65739,65838,65156,63210,61908,62292,61486,63464,61905,59855,60893,61568,63888,66529,65490,66433,66449,64664,63745,66353,69945,70575,70465,69788,65351,61861,59711,58567,58857,58327,58441,58834,57097,55781,56899,55916,54719,57057,58321,59610,59693,59804,58761,56989,52043,47217,40598,37734,36498,33581,30774,28511,26177,23460,21739,20870,18938,17589,15178,13953,11671,10260,8792,7103,5873,4449,3504,2703,1595,1019,698,415,206,314, + 59994,60640,60292,60662,60196,62686,61064,60445,59572,59189,57076,57224,56218,54687,52930,53287,52338,54090,54569,56738,60980,64998,67834,71230,73156,74108,70944,70264,66794,66873,66050,64131,62723,63016,62086,64146,62458,60446,61504,62109,64301,67023,65852,66894,66798,65017,64020,66594,70122,70648,70537,69871,65335,61817,59610,58464,58745,58200,58239,58643,56807,55456,56522,55515,54290,56539,57633,58884,58854,58965,57842,55898,51013,46178,39566,36691,35344,32475,29571,27213,24870,22113,20396,19335,17456,15899,13556,12261,10096,8707,7299,5805,4597,3386,2653,1953,1107,694,448,254,307, + 61005,61352,61817,61378,61840,61241,63718,62065,61409,60568,60092,57999,58201,57211,55766,54366,55217,54633,56389,55970,58246,62753,66921,69854,73247,75157,76198,73101,72176,68585,68631,67738,65662,64040,64250,63207,65309,63415,61383,62275,62848,65049,67683,66374,67451,67252,65397,64393,66912,70318,70850,70720,69963,65468,61865,59613,58410,58637,58069,58083,58403,56461,55117,56107,55074,53727,55938,56982,58101,58026,57977,56884,54759,49925,45028,38563,35574,34133,31214,28284,25911,23418,20783,18979,17826,15847,14233,11956,10671,8731,7259,5917,4631,3533,2514,1939,1350,712,464,296,328, + 59899,62531,62258,62825,62332,62742,62154,64652,62973,62365,61423,60983,58927,59056,58168,57017,56202,57284,58077,57482,56782,59099,63967,68404,71283,74734,76708,77718,74573,73635,69972,69933,68898,66723,65009,65301,63991,66102,64107,62043,62854,63394,65491,68126,66786,67842,67519,65717,64677,67104,70472,70929,70758,69966,65410,61811,59464,58275,58503,57852,57876,58071,56075,54706,55562,54552,53201,55266,56269,57296,57076,56955,55850,53625,48784,43877,37482,34368,32825,29894,27002,24520,22041,19257,17432,16212,14239,12543,10382,9065,7157,5900,4634,3568,2666,1803,1324,927,443,289,348, + 60032,60973,63361,63030,63640,63087,63441,62905,65385,63716,63197,62172,61758,59680,59838,58915,57928,57108,58716,61135,59115,57501,60048,65065,69439,72416,75873,77948,78928,75783,74871,71078,70994,69885,67627,65850,66033,64670,66751,64708,62516,63259,63806,65851,68483,67096,68161,67733,65874,64826,67216,70496,70938,70698,69839,65308,61738,59263,58138,58287,57581,57551,57691,55654,54220,54980,53986,52503,54578,55476,56382,56132,55859,54707,52391,47508,42615,36201,33125,31488,28459,25539,23013,20477,17718,15899,14566,12574,10883,8857,7538,5809,4717,3597,2682,1936,1288,897,607,264,359) +# Vector of population for females +pop_f <- + c(43223,44201,46785,50270,55029,57483,60108,61137,62014,58559,56838,54092,52692,51013,48980,47946,48405,49020,50491,49770,48387,49690,51371,54350,57556,57378,58737,59423,58131,57421,60791,63912,64855,65160,65747,60738,58457,56937,56440,56870,56841,58290,57987,57846,56706,58136,58011,57659,59922,62718,65031,65443,66164,65300,64080,60379,54951,49118,46646,47274,45624,43454,42597,40532,40079,39246,40884,40748,41680,40175,41456,40087,40559,40998,40948,40531,40114,41820,42633,33718,32125,31086,28696,26808,25475.62,23187.66,21172.03,18152.55,15774.37,13757.16,11231.82,9027.71,7096.01,5321.9,3950.87,2892.06,1996.22,1330,863,519,755, + 43058,43599,44356,46880,50383,55150,57586,60189,61253,62139,58685,56948,54201,52820,51148,49082,48083,48576,49267,50587,50113,48684,50036,51740,54672,57858,57724,58974,59665,58313,57586,60945,64070,64973,65235,65838,60845,58559,56961,56472,56883,56851,58282,58004,57811,56659,58100,57949,57606,59862,62580,64909,65287,65978,65160,63885,60158,54718,48912,46454,47053,45357,43184,42308,40212,39745,38855,40462,40301,41169,39617,40827,39437,39814,40118,39943,39441,38859,40493,40983,32102,30444,29335,26817,24911,23316.62,20964.66,18921.03,15990.55,13573.37,11666.16,9347.82,7311.71,5606.01,4099.9,3015.87,2143.06,1404.22,906,554,752, + 43950,43589,43801,44555,47065,50619,55297,57776,60351,61446,62314,58898,57149,54411,52959,51326,49271,48259,48865,49423,51050,50511,49155,50562,52199,55151,58326,58124,59374,59933,58655,57891,61150,64352,65177,65452,65947,61026,58625,57040,56624,56962,56960,58285,58041,57852,56682,58088,57947,57568,59785,62442,64779,65194,65819,64947,63648,59900,54490,48719,46242,46796,45101,42881,42008,39897,39391,38491,40037,39835,40655,39053,40142,38701,39027,39205,38875,38287,37605,39020,39109,30450,28734,27509,24914,22815,21181.62,18740.66,16725.03,13846.55,11551.37,9753.16,7609.82,5842.71,4356.01,3114.9,2189.87,1526.06,948.22,614,809, + 44439,44441,43868,44027,44757,47291,50810,55534,57963,60525,61652,62561,59100,57415,54639,53160,51573,49493,48549,49133,49862,51471,51017,49743,51164,52691,55676,58771,58545,59723,60326,59057,58186,61440,64542,65416,65684,66170,61182,58771,57195,56758,57062,57053,58341,58052,57908,56703,58054,57901,57499,59696,62335,64630,65053,65661,64760,63440,59668,54254,48493,46017,46550,44849,42629,41668,39554,38984,38054,39575,39319,40012,38388,39426,37931,38106,38280,37764,36995,36152,37333,37130,28858,26911,25532,22942,20634,18964.62,16475.66,14514.03,11774.55,9617.37,7868.16,6019.82,4487.71,3335.01,2306.9,1568.87,1047.06,646.22,863, + 46751,45055,44731,44131,44239,44976,47531,51001,55739,58183,60720,61924,62781,59300,57632,54877,53400,51824,49804,48835,49553,50367,51943,51571,50363,51727,53244,56138,59225,58924,60130,60695,59354,58506,61703,64770,65639,65898,66365,61304,58893,57315,56917,57133,57127,58448,58113,57951,56715,58026,57868,57458,59653,62248,64510,64922,65455,64539,63214,59409,54006,48221,45800,46320,44570,42312,41348,39164,38555,37621,39019,38671,39357,37701,38609,37089,37170,37215,36516,35608,34496,35534,35095,27019,25040,23388,20807,18389,16613.62,14333.66,12214.03,9686.55,7800.37,6239.16,4603.82,3370.71,2404.01,1589.9,1064.87,705.06,929.22, + 48092,47392,45352,44934,44321,44446,45187,47750,51206,55952,58413,60898,62145,63004,59498,57835,55095,53622,52170,50161,49426,50022,50800,52537,52138,50989,52191,53720,56530,59560,59356,60492,61035,59655,58844,61951,64999,65818,66076,66476,61437,59050,57389,56979,57197,57181,58471,58112,57928,56706,57981,57791,57368,59556,62118,64354,64772,65228,64296,62962,59158,53725,47938,45527,45999,44198,41995,40947,38736,38094,37101,38454,38062,38650,36980,37799,36171,36163,36057,35187,34092,32864,33656,32970,25202,23054,21315,18673,16260,14428.62,12212.66,10258.03,7947.55,6192.37,4860.16,3494.82,2450.71,1708.01,1083.9,698.87,974.28, + 49053,48821,47715,45484,45142,44514,44633,45344,47861,51405,56121,58565,61093,62288,63183,59673,58064,55310,53928,52517,50575,49895,50617,51469,53173,52800,51562,52671,54121,56892,59908,59666,60789,61201,59825,59028,62123,65185,65902,66167,66576,61549,59099,57458,57042,57229,57206,58470,58075,57878,56642,57905,57726,57290,59441,61954,64149,64549,64975,64028,62659,58834,53421,47632,45195,45639,43832,41606,40553,38293,37620,36561,37843,37418,37886,36178,36922,35165,35070,34806,33787,32567,31195,31676,30823,23330,20956,19211,16595,14195,12328.62,10289.66,8489.03,6429.55,4865.37,3682.16,2589.82,1747.71,1189.01,739.9,1050.15, + 49420,49715,49157,47890,45623,45300,44601,44781,45507,48037,51557,56266,58713,61254,62454,63365,59862,58263,55558,54249,52925,50992,50449,51267,52147,53839,53395,52071,53161,54553,57300,60162,59903,61118,61473,60077,59219,62280,65296,66053,66300,66635,61586,59193,57496,57107,57221,57238,58463,58047,57814,56558,57788,57628,57131,59272,61763,63898,64277,64734,63726,62327,58496,53074,47304,44838,45220,43382,41184,40138,37792,37082,36026,37188,36719,37075,35363,35882,34129,33861,33398,32331,30935,29336,29624,28530,21346,18893,17080,14510,12172,10385.62,8457.66,6793.03,5068.55,3728.37,2759.16,1881.82,1195.71,793.01,1101.05, + 51594,50183,50166,49522,48250,45947,45688,44906,45115,45874,48413,51954,56659,59086,61607,62779,63745,60236,58707,56078,54885,53656,51905,51416,52218,53103,54747,54002,52755,53818,55110,57826,60629,60402,61559,61856,60502,59613,62573,65594,66284,66506,66836,61852,59397,57644,57251,57346,57309,58490,58064,57802,56487,57748,57479,57064,59161,61592,63711,64040,64440,63399,62007,58149,52780,46913,44503,44884,42971,40795,39663,37297,36518,35447,36475,35997,36240,34453,34804,33013,32512,31960,30733,29193,27380,27356,26145,19338,16841,14878,12515,10260,8502.62,6823.66,5363.03,3814.55,2715.37,1978.16,1317.82,780.71,1159.06, + 52330,52289,50657,50530,49905,48602,46305,46055,45254,45491,46243,48787,52318,56951,59441,61920,63142,64114,60769,59335,56716,55506,54471,52961,52501,53236,54025,55542,54729,53376,54435,55751,58372,61178,60879,62024,62285,60876,59944,62856,65822,66509,66737,67013,62016,59570,57789,57356,57450,57389,58480,58108,57795,56437,57687,57426,56949,59062,61418,63483,63770,64182,63097,61671,57793,52357,46490,44136,44458,42548,40310,39174,36747,35904,34836,35716,35157,35258,33415,33603,31745,31060,30362,28949,27373,25273,25044,23550,17185,14627,12804,10549,8471,6743.62,5312.66,4073.03,2785.55,1921.37,1340.16,892.82,1194.77, + 53136,53001,52823,51118,50917,50307,48980,46707,46412,45652,45870,46630,49159,52682,57340,59830,62322,63608,64637,61280,59884,57330,56537,55603,54175,53563,54214,54854,56477,55459,54151,55219,56382,59025,61836,61407,62605,62705,61296,60308,63172,66141,66792,66964,67187,62226,59772,57926,57509,57523,57437,58505,58083,57760,56377,57605,57294,56800,58924,61228,63248,63509,63902,62781,61285,57385,51966,46062,43746,43959,42081,39838,38634,36203,35276,34168,34922,34270,34241,32363,32369,30349,29589,28629,27110,25359,23076,22663,20942,15059,12502,10713,8630,6786,5319.62,4071.66,2979.03,1999.55,1316.37,889.16,1268.59, + 54400,53714,53495,53263,51524,51321,50719,49372,47097,46851,46035,46236,47085,49578,53114,57765,60344,62833,64254,65326,61986,60734,58389,57893,56946,55401,54699,55273,55608,57498,56329,54956,55964,57034,59643,62425,61895,63045,63138,61754,60716,63555,66507,67075,67277,67405,62377,59926,58047,57615,57615,57494,58528,58044,57709,56310,57520,57182,56643,58703,61033,63058,63248,63555,62421,60871,56974,51573,45647,43352,43442,41589,39269,38000,35574,34583,33445,34095,33353,33167,31136,31067,28931,28035,26860,25142,23282,20938,20246,18404,12968,10632,8920,6971,5270,4092.62,3051.66,2157.03,1383.55,857.37,1355.75, + 56414,55057,54111,53710,53565,51764,51557,50945,49578,47365,47101,46349,46500,47367,49864,53413,58130,60745,63385,64758,65878,62648,61738,59627,59124,58057,56485,55645,56155,56357,58206,56937,55490,56357,57487,60080,62798,62199,63368,63453,62050,60897,63813,66689,67190,67397,67557,62465,60005,58090,57631,57612,57454,58476,57972,57660,56220,57412,56996,56454,58446,60780,62781,62921,63123,61967,60397,56525,51075,45165,42854,42918,41063,38634,37313,34872,33836,32609,33130,32286,32002,29881,29589,27367,26313,25002,23136,21131,18691,17807,15923,10914,8796,7211,5433,4032,3062.62,2234.66,1533.03,950.55,1376.12, + 54755,57043,55477,54473,53996,53828,52021,51811,51183,49846,47615,47407,46598,46818,47621,50230,53825,58532,61214,63807,65190,66300,63330,62588,60565,59907,58875,57169,56368,56895,56991,58784,57484,55943,56869,57914,60492,63203,62579,63647,63717,62323,61184,64029,66867,67383,67526,67616,62534,60118,58097,57662,57601,57444,58402,57909,57518,56121,57257,56852,56247,58247,60513,62452,62570,62719,61545,59921,56063,50564,44680,42315,42312,40446,37969,36612,34102,33054,31753,32099,31144,30710,28438,27989,25750,24510,22974,21035,18873,16481,15385,13528,9059,7083,5705,4153,2987,2251.62,1551.66,1040.03,1449.67, + 55178,55393,57511,55905,54873,54410,54185,52405,52131,51555,50220,48075,47861,46960,47201,47980,50709,54332,59099,61717,64395,65817,67221,64449,63697,61637,60870,59677,57906,57116,57677,57596,59375,58088,56514,57317,58371,60851,63619,62929,63972,64001,62574,61425,64225,67024,67516,67631,67668,62612,60116,58125,57685,57580,57402,58337,57850,57396,56007,57121,56664,56019,58024,60160,62107,62141,62244,61071,59386,55433,50055,44120,41765,41605,39775,37239,35795,33279,32109,30789,30927,29872,29328,26904,26294,23926,22497,20873,18772,16548,14163,13075,11206,7316,5476,4329,3058,2128,1547.62,1040.66,1513.7, + 55359,55884,55839,58024,56419,55491,55037,54800,53099,52791,52180,50890,48649,48492,47590,47892,48753,51433,55043,59713,62395,65043,66677,68255,65582,64809,62631,61849,60426,58779,57818,58314,58205,60080,58617,57076,57808,58812,61303,64028,63266,64348,64301,62909,61686,64499,67194,67673,67767,67787,62710,60144,58159,57698,57520,57362,58251,57754,57287,55851,56948,56463,55800,57736,59809,61696,61651,61772,60511,58815,54841,49460,43600,41126,40923,39037,36458,34926,32359,31152,29662,29645,28518,27813,25292,24509,22089,20495,18789,16511,14348,12010,10792,9141,5818,4247,3215,2206,1459,1023.62,1570.37, + 56296,56083,56582,56429,58583,57024,56106,55641,55404,53684,53364,52753,51450,49199,49078,48184,48627,49442,52155,55773,60532,63057,65991,67789,69577,66754,65984,63617,62807,61355,59655,58615,59039,58930,60779,59182,57655,58375,59288,61759,64433,63611,64725,64606,63174,61929,64715,67340,67767,67910,67926,62789,60156,58213,57682,57503,57346,58147,57649,57107,55667,56743,56217,55543,57420,59441,61215,61133,61237,59923,58208,54188,48852,42977,40451,40182,38288,35612,34030,31428,30146,28580,28325,27109,26168,23617,22594,20184,18472,16686,14442,12285,10032,8794,7257,4503,3214,2324,1544,980,1611.98, + 55884,57292,56834,57297,57127,59253,57748,56851,56272,56038,54402,53989,53410,52088,49783,49781,48995,49443,50346,52885,56630,61405,64097,67142,68976,70649,67776,66894,64532,63579,62224,60279,59298,59740,59524,61427,59759,58154,58845,59722,62161,64873,64000,65084,64958,63449,62199,64912,67560,67902,68054,67992,62839,60211,58199,57680,57448,57264,58030,57481,56940,55469,56481,55919,55248,57082,58999,60737,60604,60634,59271,57521,53430,48179,42271,39688,39364,37380,34674,33077,30374,28936,27332,26833,25534,24417,21864,20615,18264,16377,14540,12354,10194,8154,6968,5614,3371,2320,1619,1057,1567, + 58018,57216,58348,57775,58292,58092,60258,58604,57759,57139,56862,55212,54752,54149,52856,50526,50694,49977,50542,51298,54032,57679,62872,65697,68878,70528,72240,69341,68358,66003,64938,63471,61455,60386,60605,60418,62364,60532,58908,59506,60254,62680,65474,64495,65508,65359,63848,62537,65200,67775,68104,68254,68150,62962,60348,58257,57719,57402,57272,57956,57313,56770,55296,56247,55634,54935,56687,58548,60230,60092,60001,58592,56713,52612,47420,41544,38911,38487,36460,33616,31957,29228,27678,25973,25277,23865,22556,19992,18542,16313,14219,12323,10351,8322,6439,5422,4189,2455,1602,1128,1644.99, + 56715,59444,58123,59233,58684,59279,58916,61077,59410,58612,57936,57688,55943,55436,54893,53557,51353,51508,51083,51275,52151,54920,58872,64263,67178,70320,72030,73732,70759,69794,67193,66138,64686,62531,61410,61495,61178,63145,61249,59582,60163,60791,63208,65995,64867,65858,65698,64129,62766,65367,67947,68266,68353,68215,62984,60368,58228,57689,57304,57120,57803,57102,56556,55026,55930,55289,54520,56251,58049,59699,59444,59301,57810,55893,51746,46580,40689,38033,37459,35393,32489,30728,27919,26285,24448,23638,22099,20605,17943,16417,14223,12142,10357,8446,6572,4939,4072,3038,1688,1042,1726, + 56807,57789,60164,58792,59910,59388,60056,59582,61763,60150,59409,58669,58337,56602,56096,55462,54240,51997,52341,51671,51958,52827,55923,60187,65530,68439,71550,73283,75086,72016,71014,68303,67238,65650,63481,62250,62345,61856,63801,61855,60119,60699,61239,63585,66279,65186,66180,65942,64364,62977,65531,68095,68376,68451,68209,63010,60297,58148,57577,57201,56939,57580,56860,56282,54708,55570,54916,54101,55730,57471,59046,58745,58481,56937,54968,50787,45668,39805,37004,36418,34250,31285,29393,26572,24821,22866,21880,20265,18589,15922,14245,12196,10206,8427,6796,5065,3691,2972,2115,1139,1697.99) + +# Vector of age-specific fertility rates +asfr <- c(0.000415,0.00209,0.004145,0.010155,0.017665,0.027095,0.038225,0.046765,0.0582,0.07097,0.083335,0.09792,0.10819,0.11661,0.117465,0.11389,0.10584,0.095805,0.081925,0.07266,0.06205,0.05031,0.0402,0.029295,0.023435,0.015425,0.010325,0.006225,0.00378,0.001845,0.00083,0.00046,0.00005,0.000085,0.00003, + 0.00052,0.001915,0.005605,0.009435,0.01871,0.02803,0.03896,0.04524,0.057105,0.070205,0.084105,0.1004,0.10972,0.12058,0.121825,0.11956,0.109495,0.099345,0.090625,0.075065,0.064575,0.05104,0.0413,0.03231,0.02354,0.01639,0.009985,0.00634,0.004215,0.001875,0.00091,0.00048,0.00014,0.00012,0.000065, + 0.000685,0.00211,0.00459,0.009075,0.0181,0.026515,0.036495,0.04599,0.058185,0.070745,0.082965,0.097255,0.10583,0.116975,0.12034,0.121645,0.118705,0.105155,0.0935,0.078975,0.069225,0.055105,0.04294,0.032315,0.024895,0.01653,0.012175,0.007115,0.003845,0.002,0.00081,0.000385,0.000135,0.0001,0.00007, + 0.000395,0.002155,0.00538,0.01025,0.01744,0.02757,0.03798,0.047435,0.059845,0.070295,0.085905,0.097875,0.113365,0.12143,0.12913,0.13287,0.126885,0.11332,0.098785,0.08711,0.070315,0.05895,0.044535,0.034625,0.026315,0.018275,0.012505,0.007335,0.00418,0.002295,0.000985,0.000415,0.000175,0.000105,0.000035, + 0.00056,0.001925,0.00536,0.00899,0.01594,0.02764,0.0387,0.048325,0.05559,0.069995,0.085535,0.09787,0.11428,0.126135,0.135655,0.13816,0.132265,0.12517,0.106395,0.09231,0.07695,0.06148,0.05132,0.037605,0.0289,0.019855,0.013335,0.007535,0.00457,0.002155,0.00108,0.00065,0.00012,0.000105,0.000035, + 0.000515,0.00204,0.00449,0.008325,0.01641,0.027835,0.03772,0.046995,0.054845,0.071795,0.08601,0.09841,0.11213,0.129055,0.137675,0.138955,0.136445,0.128615,0.11401,0.09782,0.0793,0.06689,0.051755,0.04049,0.030265,0.02152,0.014165,0.00863,0.00531,0.00286,0.0009,0.000485,0.00024,0.00005,0.000035, + 0.00061,0.001715,0.004275,0.00819,0.017095,0.02619,0.03677,0.047475,0.05763,0.069865,0.081945,0.09929,0.110015,0.13017,0.13437,0.14298,0.13867,0.13124,0.114545,0.10012,0.0854,0.07069,0.05289,0.04139,0.0313,0.021265,0.01365,0.009055,0.005025,0.0026,0.001515,0.000605,0.00019,0.00014,0.00005, + 0.00043,0.001745,0.00483,0.00803,0.017205,0.026975,0.03812,0.0498,0.05848,0.0711,0.085385,0.099465,0.116595,0.132605,0.141035,0.145675,0.14637,0.13643,0.1226,0.109555,0.09091,0.07415,0.05954,0.044,0.03277,0.023015,0.015135,0.009085,0.00577,0.00288,0.000945,0.000925,0.000365,0.00016,0.000035, + 0.00058,0.00181,0.00414,0.007795,0.0171,0.02706,0.040175,0.0497,0.06138,0.0754,0.0849,0.101365,0.113765,0.12703,0.14095,0.145175,0.1454,0.13895,0.125435,0.109375,0.0931,0.07791,0.060535,0.046815,0.03495,0.02434,0.01647,0.010475,0.006015,0.003015,0.00146,0.000735,0.000505,0.000145,0.000085, + 0.0005,0.00131,0.00409,0.007815,0.016955,0.02869,0.041145,0.05194,0.062625,0.07733,0.089215,0.09915,0.114505,0.13087,0.14321,0.1474,0.14718,0.13722,0.125395,0.110985,0.09451,0.078285,0.060645,0.049175,0.036805,0.024725,0.01707,0.01021,0.00565,0.002975,0.001535,0.000875,0.000295,0.00017,0.00007, + 0.00059,0.00142,0.004095,0.007065,0.01605,0.028775,0.038975,0.05168,0.062965,0.07423,0.08839,0.102815,0.11722,0.128075,0.140695,0.14827,0.147145,0.139575,0.124925,0.115005,0.10046,0.07994,0.065455,0.05039,0.036865,0.02644,0.018245,0.01033,0.006675,0.003285,0.0018,0.00082,0.0003,0.000275,0.000155, + 0.000415,0.001565,0.00368,0.007465,0.015375,0.027185,0.039185,0.05004,0.06393,0.078245,0.091495,0.10549,0.119415,0.132825,0.14508,0.146535,0.152615,0.14506,0.129695,0.116805,0.100135,0.08581,0.06692,0.0517,0.04117,0.027675,0.01863,0.01183,0.006305,0.00375,0.00199,0.00091,0.000435,0.000115,0.000185, + 0.00039,0.00167,0.003365,0.00721,0.015025,0.02415,0.03536,0.0473,0.05979,0.07669,0.08609,0.099455,0.11409,0.127615,0.135055,0.139255,0.142215,0.13442,0.12758,0.11536,0.095805,0.084415,0.06851,0.050215,0.03904,0.028855,0.01871,0.011115,0.00661,0.00322,0.001785,0.000885,0.00032,0.00016,0.00017, + 0.00037,0.00139,0.00349,0.00648,0.013235,0.022885,0.03429,0.04627,0.06062,0.0747,0.08875,0.102265,0.113975,0.126025,0.133335,0.14266,0.145635,0.135565,0.125785,0.11608,0.099185,0.082475,0.064515,0.053475,0.03974,0.028015,0.01857,0.012445,0.006835,0.003715,0.00195,0.001035,0.000495,0.000385,0.000245, + 0.00055,0.00141,0.003325,0.0063,0.013195,0.02156,0.03351,0.044095,0.057585,0.07177,0.08555,0.10087,0.11176,0.12691,0.133945,0.14199,0.14091,0.140015,0.126205,0.11514,0.096115,0.082895,0.06829,0.05249,0.04038,0.0289,0.018745,0.0116,0.006765,0.00338,0.00179,0.000925,0.00052,0.000375,0.00023, + 0.00046,0.001105,0.00294,0.006765,0.01239,0.019805,0.029245,0.04243,0.056205,0.071675,0.086795,0.104835,0.113775,0.126065,0.136305,0.140305,0.139335,0.134685,0.12758,0.11418,0.0979,0.080865,0.066865,0.052935,0.04007,0.030485,0.01916,0.01159,0.0076,0.003765,0.00198,0.00097,0.0007,0.000265,0.000115, + 0.000295,0.00114,0.003045,0.0056,0.0115,0.02006,0.028345,0.042025,0.053665,0.0689,0.088195,0.102155,0.11291,0.126765,0.13238,0.139095,0.137405,0.13127,0.119895,0.11279,0.097485,0.08156,0.06475,0.05382,0.03895,0.029045,0.018885,0.01236,0.006625,0.003655,0.002055,0.00118,0.00053,0.000275,0.000295, + 0.0005,0.001235,0.002775,0.005245,0.01218,0.019915,0.029575,0.038195,0.052965,0.06899,0.084725,0.101895,0.11375,0.126235,0.135615,0.13995,0.13603,0.130845,0.119245,0.11024,0.09851,0.083725,0.067125,0.053155,0.041975,0.03034,0.020565,0.0128,0.0077,0.00427,0.00218,0.00107,0.000655,0.000375,0.000175, + 0.00033,0.00123,0.002695,0.00597,0.01165,0.01963,0.03009,0.03768,0.048195,0.063535,0.078305,0.09598,0.107535,0.119215,0.129095,0.131615,0.133445,0.128725,0.120115,0.10175,0.09485,0.081035,0.06597,0.05288,0.040885,0.030075,0.020595,0.01365,0.0073,0.00487,0.00216,0.001375,0.0006,0.000285,0.000465, + 0.00026,0.00117,0.00229,0.00592,0.011875,0.01965,0.027745,0.039155,0.04793,0.061335,0.0765,0.0926,0.10439,0.120235,0.12707,0.13096,0.13116,0.12526,0.116655,0.10556,0.092845,0.07854,0.063975,0.05414,0.04103,0.02982,0.0198,0.01193,0.00737,0.003905,0.002225,0.00128,0.000515,0.000455,0.0002) + +# Vector of survival rates for males +sr_m <- c(0.9966,0.9993,0.9998,0.9999,0.9999,0.9999,0.9999,0.9998,0.9999,0.9999,0.9999,0.9998,0.9998,0.9998,0.9998,0.9998,0.9998,0.9997,0.9996,0.9995,0.9994,0.9993,0.9993,0.9994,0.9994,0.9993,0.9993,0.9994,0.9993,0.9992,0.9993,0.9993,0.9993,0.9993,0.9992,0.9991,0.999,0.9989,0.9989,0.9987,0.9986,0.9985,0.9983,0.9981,0.9982,0.998,0.9979,0.9978,0.9973,0.9969,0.9967,0.9965,0.9963,0.9957,0.9951,0.9945,0.9941,0.9938,0.9931,0.9922,0.9913,0.9908,0.99,0.9882,0.9866,0.9856,0.9844,0.9823,0.9796,0.9775,0.9755,0.9718,0.9685,0.9664,0.9631,0.958,0.9541,0.9495,0.9423,0.9358,0.929,0.9193,0.9094,0.9001,0.8908,0.8804,0.8633,0.849,0.8363,0.8167,0.7994,0.7831,0.7606,0.74,0.7174,0.6948,0.6811,0.6598,0.6388,0.6174,0.7246, + 0.9965,0.9993,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9995,0.9993,0.9992,0.9992,0.9992,0.9992,0.9993,0.9993,0.9991,0.9993,0.9993,0.9993,0.9993,0.9993,0.9992,0.9992,0.9992,0.9991,0.9991,0.9991,0.9989,0.9989,0.9989,0.9987,0.9987,0.9986,0.9981,0.9979,0.9979,0.9977,0.9971,0.9968,0.997,0.9966,0.996,0.9959,0.9954,0.995,0.9946,0.9941,0.9934,0.9925,0.9918,0.9907,0.9896,0.9891,0.9875,0.9857,0.9845,0.983,0.9812,0.9785,0.9757,0.9736,0.9701,0.9668,0.9641,0.9599,0.9556,0.95,0.9447,0.9384,0.9315,0.925,0.9143,0.9031,0.8924,0.8799,0.8653,0.8488,0.8359,0.8257,0.8106,0.7911,0.7647,0.7396,0.7218,0.6989,0.6796,0.6577,0.6363,0.6142,0.5535, + 0.9966,0.9993,0.9998,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9997,0.9996,0.9995,0.9992,0.9991,0.9991,0.9992,0.9993,0.9993,0.9993,0.9993,0.9993,0.9994,0.9994,0.9993,0.9993,0.9992,0.9991,0.9992,0.9991,0.999,0.9989,0.9987,0.9986,0.9986,0.9985,0.9984,0.9982,0.9981,0.9978,0.9973,0.9971,0.9971,0.9969,0.9967,0.9965,0.9958,0.9953,0.9951,0.9945,0.9937,0.9929,0.9926,0.9923,0.9906,0.99,0.9892,0.9874,0.9864,0.9848,0.983,0.981,0.979,0.9775,0.9747,0.9715,0.969,0.9653,0.9612,0.9565,0.9513,0.9466,0.9398,0.932,0.924,0.9177,0.9076,0.8949,0.8828,0.8699,0.8589,0.8413,0.8234,0.8063,0.782,0.7602,0.7399,0.7241,0.7089,0.679,0.6563,0.6344,0.6134,0.5604, + 0.9969,0.9993,0.9996,0.9997,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9997,0.9996,0.9994,0.9993,0.9993,0.9992,0.999,0.9992,0.9993,0.9993,0.9993,0.9994,0.9995,0.9994,0.9992,0.9992,0.9993,0.9993,0.9993,0.9992,0.9991,0.9991,0.9989,0.9987,0.9987,0.9985,0.9984,0.9983,0.9981,0.998,0.9978,0.9976,0.9976,0.9971,0.9966,0.9962,0.996,0.9956,0.995,0.9947,0.9943,0.9931,0.9923,0.9916,0.991,0.9906,0.9893,0.9879,0.987,0.9851,0.9833,0.9817,0.9789,0.9767,0.9754,0.9719,0.9679,0.9651,0.9612,0.9577,0.9521,0.9454,0.94,0.9328,0.9256,0.9161,0.9066,0.8969,0.8831,0.87,0.8527,0.8364,0.8206,0.8016,0.7879,0.7665,0.7305,0.7086,0.7018,0.6734,0.6506,0.628,0.6056,0.587, + 0.9969,0.9993,0.9997,0.9997,0.9998,0.9999,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9996,0.9994,0.9993,0.9993,0.9993,0.9993,0.9993,0.9992,0.9994,0.9995,0.9994,0.9994,0.9994,0.9995,0.9995,0.9994,0.9992,0.9991,0.9992,0.9992,0.999,0.9989,0.9988,0.9987,0.9986,0.9985,0.9981,0.9981,0.998,0.9976,0.9974,0.9972,0.9969,0.9968,0.9966,0.9962,0.9955,0.995,0.9945,0.994,0.9938,0.9933,0.9924,0.9914,0.9902,0.9893,0.9885,0.9866,0.9846,0.9837,0.9819,0.9799,0.9778,0.9739,0.9718,0.9695,0.9655,0.9622,0.958,0.9527,0.9476,0.9424,0.9355,0.9248,0.9156,0.9069,0.8979,0.8869,0.8705,0.8563,0.8412,0.8249,0.8104,0.7927,0.7748,0.7577,0.7306,0.7084,0.6884,0.6664,0.6454,0.6234,0.5009, + 0.9972,0.9994,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9995,0.9994,0.9992,0.9991,0.9992,0.9993,0.9992,0.9992,0.9993,0.9994,0.9993,0.9993,0.9994,0.9994,0.9993,0.9994,0.9993,0.9992,0.9993,0.9991,0.9991,0.9991,0.9989,0.9989,0.9989,0.9986,0.9983,0.9981,0.998,0.9979,0.9977,0.9972,0.9966,0.9965,0.9965,0.9963,0.9957,0.9953,0.9947,0.994,0.9936,0.9932,0.9925,0.9917,0.991,0.9903,0.9886,0.9869,0.9858,0.9843,0.9825,0.9805,0.9785,0.9756,0.9725,0.9705,0.9681,0.9653,0.9608,0.9554,0.9514,0.946,0.9386,0.9299,0.9223,0.9144,0.9018,0.8894,0.8776,0.8645,0.8453,0.8273,0.8171,0.8011,0.7761,0.749,0.7403,0.7271,0.6924,0.6703,0.6479,0.6255,0.5403, + 0.9979,0.9994,0.9997,0.9998,0.9998,0.9999,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9998,0.9997,0.9996,0.9995,0.9994,0.9993,0.9993,0.9993,0.9994,0.9993,0.9992,0.9993,0.9993,0.9992,0.9993,0.9994,0.9993,0.9994,0.9994,0.9992,0.9992,0.9993,0.9993,0.999,0.9989,0.9989,0.9986,0.9985,0.9984,0.9983,0.9981,0.9979,0.9978,0.9974,0.9972,0.9972,0.9967,0.9958,0.9954,0.9953,0.9946,0.9943,0.9941,0.9933,0.9922,0.9917,0.9908,0.9897,0.989,0.9875,0.9851,0.9841,0.983,0.981,0.9792,0.9772,0.9748,0.9708,0.967,0.9638,0.96,0.9559,0.9513,0.9442,0.9363,0.9294,0.9214,0.9121,0.9011,0.8887,0.8762,0.8614,0.8452,0.8306,0.8111,0.7966,0.7811,0.7447,0.7124,0.6993,0.6873,0.665,0.6426,0.6206,0.6098, + 0.9974,0.9994,0.9998,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9996,0.9996,0.9995,0.9994,0.9994,0.9993,0.9992,0.9993,0.9994,0.9994,0.9994,0.9995,0.9994,0.9993,0.9995,0.9995,0.9993,0.9993,0.9994,0.9992,0.9991,0.9991,0.999,0.999,0.9989,0.9986,0.9986,0.9986,0.9984,0.9982,0.9979,0.9979,0.9978,0.9974,0.9969,0.9965,0.9959,0.9954,0.9953,0.9949,0.9943,0.994,0.9935,0.9926,0.9918,0.991,0.9902,0.9891,0.9872,0.9852,0.985,0.9844,0.9824,0.9797,0.9771,0.975,0.9725,0.9691,0.9658,0.9617,0.9568,0.9522,0.9466,0.9394,0.9306,0.9237,0.916,0.9036,0.8915,0.8787,0.8654,0.8498,0.8306,0.8147,0.7989,0.7774,0.7561,0.7387,0.7168,0.6941,0.672,0.6496,0.6273,0.5327, + 0.9977,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9996,0.9993,0.9992,0.9993,0.9993,0.9994,0.9993,0.9992,0.9992,0.9992,0.9993,0.9993,0.9993,0.9994,0.9994,0.9994,0.9993,0.9993,0.9993,0.9992,0.9992,0.9991,0.9989,0.9989,0.9988,0.9986,0.9985,0.9983,0.998,0.998,0.9979,0.9976,0.9971,0.9967,0.9963,0.9962,0.9961,0.9957,0.9952,0.9947,0.994,0.9933,0.993,0.9922,0.991,0.99,0.9888,0.9874,0.9866,0.9854,0.9839,0.9827,0.9807,0.9788,0.9765,0.9734,0.9711,0.9675,0.9634,0.9591,0.9524,0.9475,0.9414,0.9329,0.9248,0.916,0.9056,0.8949,0.8821,0.8679,0.8541,0.8379,0.8184,0.7978,0.7775,0.7522,0.7237,0.7016,0.6906,0.6677,0.6448,0.6226,0.5853, + 0.9979,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9996,0.9995,0.9994,0.9993,0.9993,0.9993,0.9992,0.9993,0.9993,0.9993,0.9992,0.9993,0.9992,0.9992,0.9992,0.9993,0.9993,0.9993,0.9992,0.9992,0.9992,0.9992,0.9991,0.999,0.9988,0.9986,0.9985,0.9984,0.9982,0.9982,0.9981,0.9977,0.9973,0.9968,0.9967,0.9963,0.9957,0.9958,0.9955,0.9947,0.9939,0.9935,0.993,0.9923,0.9914,0.9903,0.9891,0.9879,0.9872,0.9862,0.9843,0.982,0.9807,0.9791,0.9766,0.9743,0.9704,0.9665,0.9646,0.9606,0.954,0.9489,0.9427,0.9326,0.9246,0.9172,0.9075,0.8967,0.8833,0.8673,0.8531,0.8359,0.817,0.8054,0.784,0.7543,0.7308,0.7135,0.6957,0.6731,0.6503,0.6278,0.5519, + 0.9978,0.9994,0.9997,0.9997,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9998,0.9997,0.9997,0.9996,0.9994,0.9994,0.9994,0.9994,0.9992,0.9993,0.9994,0.9993,0.9994,0.9993,0.9992,0.9993,0.9993,0.9993,0.9993,0.9992,0.9991,0.9992,0.9991,0.9991,0.9992,0.9991,0.999,0.9986,0.9984,0.9984,0.9983,0.9981,0.998,0.9977,0.9972,0.997,0.9968,0.9964,0.996,0.9958,0.9955,0.9946,0.994,0.9936,0.9934,0.9926,0.9914,0.9908,0.9901,0.9885,0.9874,0.9868,0.9857,0.9835,0.9818,0.9801,0.9777,0.9748,0.9712,0.968,0.9642,0.9599,0.9554,0.9506,0.9432,0.935,0.9293,0.9207,0.9097,0.8971,0.8852,0.8716,0.854,0.8404,0.8243,0.803,0.7838,0.7586,0.728,0.7077,0.693,0.6698,0.6468,0.6233,0.5746, + 0.9977,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9996,0.9995,0.9995,0.9994,0.9993,0.9993,0.9993,0.9992,0.9994,0.9994,0.9993,0.9992,0.9993,0.9993,0.9992,0.9993,0.9994,0.9994,0.9993,0.9994,0.9994,0.9992,0.999,0.9989,0.9989,0.9987,0.9988,0.9988,0.9984,0.9981,0.9978,0.9976,0.9974,0.9972,0.997,0.9966,0.9961,0.9957,0.9953,0.9949,0.9946,0.9938,0.993,0.9925,0.9918,0.9909,0.9895,0.9883,0.9876,0.9864,0.9857,0.9839,0.9812,0.9796,0.9779,0.9757,0.973,0.9686,0.9652,0.961,0.954,0.949,0.9435,0.9366,0.9294,0.9196,0.9108,0.9006,0.887,0.8732,0.8575,0.8421,0.8245,0.8028,0.7852,0.7671,0.741,0.7179,0.6987,0.6757,0.6526,0.6298,0.55, + 0.9981,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9996,0.9995,0.9995,0.9994,0.9993,0.9993,0.9993,0.9993,0.9994,0.9993,0.9993,0.9993,0.9994,0.9992,0.9993,0.9994,0.9993,0.9993,0.9993,0.9993,0.9993,0.9992,0.9991,0.9991,0.9991,0.9989,0.9986,0.9985,0.9985,0.9982,0.9979,0.9976,0.9974,0.9972,0.9972,0.9969,0.9964,0.9959,0.9952,0.9952,0.9947,0.9934,0.9931,0.9928,0.9922,0.9915,0.9904,0.989,0.9876,0.9867,0.9852,0.9834,0.9819,0.9804,0.9788,0.9763,0.9734,0.9707,0.9659,0.9608,0.9562,0.9509,0.9461,0.9416,0.9336,0.9209,0.9098,0.9,0.8881,0.8748,0.8621,0.8474,0.8282,0.8065,0.7817,0.763,0.7445,0.7198,0.6988,0.6753,0.6519,0.6284,0.5699, + 0.9975,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9997,0.9996,0.9995,0.9993,0.9993,0.9993,0.9993,0.9992,0.9992,0.9993,0.9993,0.9994,0.9994,0.9994,0.9993,0.9993,0.9993,0.9994,0.9994,0.9992,0.9991,0.999,0.999,0.9991,0.999,0.9988,0.9986,0.9985,0.9983,0.9981,0.9978,0.9977,0.9976,0.9972,0.9967,0.9962,0.9958,0.9954,0.9952,0.995,0.9944,0.9936,0.9927,0.992,0.9915,0.9907,0.9897,0.9881,0.987,0.9865,0.9849,0.9826,0.9814,0.9796,0.976,0.9724,0.9698,0.9668,0.9622,0.9571,0.9525,0.9464,0.9377,0.93,0.9225,0.9122,0.9007,0.8877,0.8723,0.8573,0.8414,0.8204,0.8008,0.7855,0.7631,0.7423,0.7212,0.6924,0.6687,0.6449,0.6221,0.5931, + 0.9976,0.9995,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9999,0.9999,0.9998,0.9997,0.9995,0.9994,0.9994,0.9994,0.9994,0.9993,0.9993,0.9993,0.9992,0.9992,0.9992,0.9992,0.9992,0.9992,0.9993,0.9994,0.9994,0.9992,0.999,0.9991,0.9992,0.9992,0.999,0.999,0.999,0.9988,0.9986,0.9984,0.9983,0.9983,0.998,0.9975,0.9974,0.9974,0.9967,0.9962,0.9961,0.996,0.9956,0.995,0.9945,0.9937,0.9925,0.9919,0.9913,0.9904,0.9897,0.9885,0.9873,0.9861,0.9846,0.9831,0.9812,0.9794,0.9775,0.9742,0.9706,0.9669,0.9635,0.9607,0.9554,0.9482,0.9416,0.9347,0.9267,0.9148,0.9034,0.894,0.8806,0.8662,0.8452,0.8279,0.8102,0.7831,0.7623,0.7356,0.7147,0.6972,0.6729,0.649,0.6247,0.5506, + 0.9978,0.9995,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9997,0.9996,0.9994,0.9993,0.9994,0.9993,0.9993,0.9993,0.9993,0.9994,0.9993,0.9993,0.9992,0.9992,0.9992,0.9991,0.9991,0.9992,0.9993,0.9992,0.9993,0.9993,0.9992,0.9991,0.9989,0.9988,0.9987,0.9987,0.9986,0.9984,0.998,0.9978,0.9976,0.9972,0.9973,0.9972,0.9969,0.9965,0.996,0.9954,0.995,0.9946,0.9939,0.9929,0.9921,0.9914,0.9909,0.9904,0.9891,0.9874,0.9861,0.9848,0.9831,0.9815,0.9801,0.9787,0.9751,0.9712,0.9683,0.9641,0.9599,0.9562,0.9503,0.9433,0.9355,0.9263,0.9181,0.9065,0.8934,0.8813,0.8702,0.8525,0.8296,0.8156,0.7995,0.7766,0.7577,0.7371,0.7097,0.6864,0.6629,0.6394,0.5187, + 0.9976,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9995,0.9994,0.9994,0.9994,0.9994,0.9993,0.9991,0.9991,0.9992,0.9992,0.9993,0.9993,0.9994,0.9994,0.9992,0.9992,0.9992,0.9991,0.9991,0.9992,0.9993,0.9991,0.999,0.9989,0.9989,0.9989,0.9988,0.9988,0.9985,0.9982,0.9981,0.9978,0.9977,0.9973,0.9967,0.9964,0.9961,0.9958,0.9954,0.9948,0.9944,0.9939,0.9934,0.9928,0.9917,0.9908,0.9898,0.9885,0.9875,0.9868,0.9856,0.984,0.9813,0.9792,0.9781,0.9749,0.9713,0.9693,0.9664,0.9605,0.9552,0.949,0.9427,0.9372,0.9288,0.9191,0.9054,0.8918,0.8799,0.8657,0.8477,0.8314,0.814,0.7884,0.767,0.7501,0.7284,0.7013,0.6772,0.6533,0.6287,0.6158, + 0.9978,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9996,0.9996,0.9995,0.9995,0.9994,0.9995,0.9993,0.9992,0.9993,0.9993,0.9994,0.9993,0.9992,0.9991,0.9992,0.9992,0.9992,0.9992,0.9992,0.9992,0.999,0.9991,0.9991,0.9988,0.9988,0.9988,0.9988,0.9986,0.9984,0.9983,0.9979,0.9978,0.9977,0.9976,0.9974,0.9967,0.9962,0.9959,0.9958,0.9955,0.9949,0.9941,0.993,0.992,0.9918,0.991,0.99,0.9888,0.9874,0.9866,0.9855,0.9839,0.9821,0.9802,0.9775,0.9757,0.9738,0.9693,0.9656,0.9612,0.9563,0.9508,0.9438,0.9375,0.9309,0.9202,0.9081,0.8966,0.8827,0.8714,0.8598,0.8396,0.8147,0.7931,0.772,0.7499,0.7294,0.7059,0.6818,0.6574,0.6333,0.554, + 0.9979,0.9996,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9999,0.9998,0.9996,0.9995,0.9995,0.9995,0.9994,0.9993,0.9993,0.9992,0.9993,0.9993,0.9991,0.9992,0.9992,0.9993,0.9993,0.9992,0.9993,0.9994,0.9991,0.9991,0.9992,0.9991,0.9989,0.9989,0.999,0.9989,0.9988,0.9987,0.9986,0.9986,0.9985,0.9981,0.998,0.9979,0.9974,0.9972,0.997,0.9965,0.9961,0.9956,0.9955,0.9953,0.9946,0.994,0.9932,0.9917,0.9903,0.9901,0.9895,0.9883,0.9877,0.9857,0.9834,0.9828,0.9815,0.979,0.9768,0.9747,0.9716,0.9667,0.9611,0.9571,0.9539,0.9471,0.9387,0.9296,0.9189,0.9088,0.8982,0.8842,0.8669,0.847,0.8249,0.8068,0.7907,0.7732,0.7507,0.7199,0.6941,0.6689,0.6435,0.6187,0.6097, + 0.9981,0.9996,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9999,0.9997,0.9996,0.9996,0.9996,0.9994,0.9993,0.9994,0.9993,0.9993,0.9994,0.9993,0.9992,0.9993,0.9993,0.9994,0.9994,0.9993,0.9992,0.9991,0.9992,0.9992,0.9992,0.9992,0.999,0.999,0.999,0.999,0.9988,0.9988,0.9987,0.9985,0.9985,0.9983,0.9979,0.9978,0.9975,0.997,0.9969,0.9968,0.9964,0.996,0.9956,0.9949,0.9941,0.9935,0.9928,0.9921,0.9912,0.99,0.9888,0.9877,0.9867,0.9856,0.9839,0.9826,0.9807,0.9793,0.9773,0.9739,0.9704,0.9663,0.9632,0.9589,0.953,0.9456,0.9376,0.9295,0.9208,0.9115,0.8987,0.8831,0.8685,0.8532,0.8322,0.8139,0.7997,0.7768,0.7487,0.7253,0.7054,0.681,0.6567,0.6329,0.5357) + +# Vector of survival rates for females +sr_f <- c(0.9966,0.9993,0.9998,0.9999,0.9999,0.9999,0.9999,0.9998,0.9999,0.9999,0.9999,0.9998,0.9998,0.9998,0.9998,0.9998,0.9998,0.9997,0.9996,0.9995,0.9994,0.9993,0.9993,0.9994,0.9994,0.9993,0.9993,0.9994,0.9993,0.9992,0.9993,0.9993,0.9993,0.9993,0.9992,0.9991,0.999,0.9989,0.9989,0.9987,0.9986,0.9985,0.9983,0.9981,0.9982,0.998,0.9979,0.9978,0.9973,0.9969,0.9967,0.9965,0.9963,0.9957,0.9951,0.9945,0.9941,0.9938,0.9931,0.9922,0.9913,0.9908,0.99,0.9882,0.9866,0.9856,0.9844,0.9823,0.9796,0.9775,0.9755,0.9718,0.9685,0.9664,0.9631,0.958,0.9541,0.9495,0.9423,0.9358,0.929,0.9193,0.9094,0.9001,0.8908,0.8804,0.8633,0.849,0.8363,0.8167,0.7994,0.7831,0.7606,0.74,0.7174,0.6948,0.6811,0.6598,0.6388,0.6174,0.5734, + 0.9965,0.9993,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9995,0.9993,0.9992,0.9992,0.9992,0.9992,0.9993,0.9993,0.9991,0.9993,0.9993,0.9993,0.9993,0.9993,0.9992,0.9992,0.9992,0.9991,0.9991,0.9991,0.9989,0.9989,0.9989,0.9987,0.9987,0.9986,0.9981,0.9979,0.9979,0.9977,0.9971,0.9968,0.997,0.9966,0.996,0.9959,0.9954,0.995,0.9946,0.9941,0.9934,0.9925,0.9918,0.9907,0.9896,0.9891,0.9875,0.9857,0.9845,0.983,0.9812,0.9785,0.9757,0.9736,0.9701,0.9668,0.9641,0.9599,0.9556,0.95,0.9447,0.9384,0.9315,0.925,0.9143,0.9031,0.8924,0.8799,0.8653,0.8488,0.8359,0.8257,0.8106,0.7911,0.7647,0.7396,0.7218,0.6989,0.6796,0.6577,0.6363,0.6142,0.57, + 0.9966,0.9993,0.9998,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9997,0.9996,0.9995,0.9992,0.9991,0.9991,0.9992,0.9993,0.9993,0.9993,0.9993,0.9993,0.9994,0.9994,0.9993,0.9993,0.9992,0.9991,0.9992,0.9991,0.999,0.9989,0.9987,0.9986,0.9986,0.9985,0.9984,0.9982,0.9981,0.9978,0.9973,0.9971,0.9971,0.9969,0.9967,0.9965,0.9958,0.9953,0.9951,0.9945,0.9937,0.9929,0.9926,0.9923,0.9906,0.99,0.9892,0.9874,0.9864,0.9848,0.983,0.981,0.979,0.9775,0.9747,0.9715,0.969,0.9653,0.9612,0.9565,0.9513,0.9466,0.9398,0.932,0.924,0.9177,0.9076,0.8949,0.8828,0.8699,0.8589,0.8413,0.8234,0.8063,0.782,0.7602,0.7399,0.7241,0.7089,0.679,0.6563,0.6344,0.6134,0.5669, + 0.9969,0.9993,0.9996,0.9997,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9997,0.9996,0.9994,0.9993,0.9993,0.9992,0.999,0.9992,0.9993,0.9993,0.9993,0.9994,0.9995,0.9994,0.9992,0.9992,0.9993,0.9993,0.9993,0.9992,0.9991,0.9991,0.9989,0.9987,0.9987,0.9985,0.9984,0.9983,0.9981,0.998,0.9978,0.9976,0.9976,0.9971,0.9966,0.9962,0.996,0.9956,0.995,0.9947,0.9943,0.9931,0.9923,0.9916,0.991,0.9906,0.9893,0.9879,0.987,0.9851,0.9833,0.9817,0.9789,0.9767,0.9754,0.9719,0.9679,0.9651,0.9612,0.9577,0.9521,0.9454,0.94,0.9328,0.9256,0.9161,0.9066,0.8969,0.8831,0.87,0.8527,0.8364,0.8206,0.8016,0.7879,0.7665,0.7305,0.7086,0.7018,0.6734,0.6506,0.628,0.6056,0.5611, + 0.9969,0.9993,0.9997,0.9997,0.9998,0.9999,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9996,0.9994,0.9993,0.9993,0.9993,0.9993,0.9993,0.9992,0.9994,0.9995,0.9994,0.9994,0.9994,0.9995,0.9995,0.9994,0.9992,0.9991,0.9992,0.9992,0.999,0.9989,0.9988,0.9987,0.9986,0.9985,0.9981,0.9981,0.998,0.9976,0.9974,0.9972,0.9969,0.9968,0.9966,0.9962,0.9955,0.995,0.9945,0.994,0.9938,0.9933,0.9924,0.9914,0.9902,0.9893,0.9885,0.9866,0.9846,0.9837,0.9819,0.9799,0.9778,0.9739,0.9718,0.9695,0.9655,0.9622,0.958,0.9527,0.9476,0.9424,0.9355,0.9248,0.9156,0.9069,0.8979,0.8869,0.8705,0.8563,0.8412,0.8249,0.8104,0.7927,0.7748,0.7577,0.7306,0.7084,0.6884,0.6664,0.6454,0.6234,0.5784, + 0.9972,0.9994,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9995,0.9994,0.9992,0.9991,0.9992,0.9993,0.9992,0.9992,0.9993,0.9994,0.9993,0.9993,0.9994,0.9994,0.9993,0.9994,0.9993,0.9992,0.9993,0.9991,0.9991,0.9991,0.9989,0.9989,0.9989,0.9986,0.9983,0.9981,0.998,0.9979,0.9977,0.9972,0.9966,0.9965,0.9965,0.9963,0.9957,0.9953,0.9947,0.994,0.9936,0.9932,0.9925,0.9917,0.991,0.9903,0.9886,0.9869,0.9858,0.9843,0.9825,0.9805,0.9785,0.9756,0.9725,0.9705,0.9681,0.9653,0.9608,0.9554,0.9514,0.946,0.9386,0.9299,0.9223,0.9144,0.9018,0.8894,0.8776,0.8645,0.8453,0.8273,0.8171,0.8011,0.7761,0.749,0.7403,0.7271,0.6924,0.6703,0.6479,0.6255,0.5791, + 0.9979,0.9994,0.9997,0.9998,0.9998,0.9999,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9998,0.9997,0.9996,0.9995,0.9994,0.9993,0.9993,0.9993,0.9994,0.9993,0.9992,0.9993,0.9993,0.9992,0.9993,0.9994,0.9993,0.9994,0.9994,0.9992,0.9992,0.9993,0.9993,0.999,0.9989,0.9989,0.9986,0.9985,0.9984,0.9983,0.9981,0.9979,0.9978,0.9974,0.9972,0.9972,0.9967,0.9958,0.9954,0.9953,0.9946,0.9943,0.9941,0.9933,0.9922,0.9917,0.9908,0.9897,0.989,0.9875,0.9851,0.9841,0.983,0.981,0.9792,0.9772,0.9748,0.9708,0.967,0.9638,0.96,0.9559,0.9513,0.9442,0.9363,0.9294,0.9214,0.9121,0.9011,0.8887,0.8762,0.8614,0.8452,0.8306,0.8111,0.7966,0.7811,0.7447,0.7124,0.6993,0.6873,0.665,0.6426,0.6206,0.5745, + 0.9974,0.9994,0.9998,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9996,0.9996,0.9995,0.9994,0.9994,0.9993,0.9992,0.9993,0.9994,0.9994,0.9994,0.9995,0.9994,0.9993,0.9995,0.9995,0.9993,0.9993,0.9994,0.9992,0.9991,0.9991,0.999,0.999,0.9989,0.9986,0.9986,0.9986,0.9984,0.9982,0.9979,0.9979,0.9978,0.9974,0.9969,0.9965,0.9959,0.9954,0.9953,0.9949,0.9943,0.994,0.9935,0.9926,0.9918,0.991,0.9902,0.9891,0.9872,0.9852,0.985,0.9844,0.9824,0.9797,0.9771,0.975,0.9725,0.9691,0.9658,0.9617,0.9568,0.9522,0.9466,0.9394,0.9306,0.9237,0.916,0.9036,0.8915,0.8787,0.8654,0.8498,0.8306,0.8147,0.7989,0.7774,0.7561,0.7387,0.7168,0.6941,0.672,0.6496,0.6273,0.5804, + 0.9977,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9996,0.9993,0.9992,0.9993,0.9993,0.9994,0.9993,0.9992,0.9992,0.9992,0.9993,0.9993,0.9993,0.9994,0.9994,0.9994,0.9993,0.9993,0.9993,0.9992,0.9992,0.9991,0.9989,0.9989,0.9988,0.9986,0.9985,0.9983,0.998,0.998,0.9979,0.9976,0.9971,0.9967,0.9963,0.9962,0.9961,0.9957,0.9952,0.9947,0.994,0.9933,0.993,0.9922,0.991,0.99,0.9888,0.9874,0.9866,0.9854,0.9839,0.9827,0.9807,0.9788,0.9765,0.9734,0.9711,0.9675,0.9634,0.9591,0.9524,0.9475,0.9414,0.9329,0.9248,0.916,0.9056,0.8949,0.8821,0.8679,0.8541,0.8379,0.8184,0.7978,0.7775,0.7522,0.7237,0.7016,0.6906,0.6677,0.6448,0.6226,0.5743, + 0.9979,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9996,0.9995,0.9994,0.9993,0.9993,0.9993,0.9992,0.9993,0.9993,0.9993,0.9992,0.9993,0.9992,0.9992,0.9992,0.9993,0.9993,0.9993,0.9992,0.9992,0.9992,0.9992,0.9991,0.999,0.9988,0.9986,0.9985,0.9984,0.9982,0.9982,0.9981,0.9977,0.9973,0.9968,0.9967,0.9963,0.9957,0.9958,0.9955,0.9947,0.9939,0.9935,0.993,0.9923,0.9914,0.9903,0.9891,0.9879,0.9872,0.9862,0.9843,0.982,0.9807,0.9791,0.9766,0.9743,0.9704,0.9665,0.9646,0.9606,0.954,0.9489,0.9427,0.9326,0.9246,0.9172,0.9075,0.8967,0.8833,0.8673,0.8531,0.8359,0.817,0.8054,0.784,0.7543,0.7308,0.7135,0.6957,0.6731,0.6503,0.6278,0.58, + 0.9978,0.9994,0.9997,0.9997,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9998,0.9997,0.9997,0.9996,0.9994,0.9994,0.9994,0.9994,0.9992,0.9993,0.9994,0.9993,0.9994,0.9993,0.9992,0.9993,0.9993,0.9993,0.9993,0.9992,0.9991,0.9992,0.9991,0.9991,0.9992,0.9991,0.999,0.9986,0.9984,0.9984,0.9983,0.9981,0.998,0.9977,0.9972,0.997,0.9968,0.9964,0.996,0.9958,0.9955,0.9946,0.994,0.9936,0.9934,0.9926,0.9914,0.9908,0.9901,0.9885,0.9874,0.9868,0.9857,0.9835,0.9818,0.9801,0.9777,0.9748,0.9712,0.968,0.9642,0.9599,0.9554,0.9506,0.9432,0.935,0.9293,0.9207,0.9097,0.8971,0.8852,0.8716,0.854,0.8404,0.8243,0.803,0.7838,0.7586,0.728,0.7077,0.693,0.6698,0.6468,0.6233,0.575, + 0.9977,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9996,0.9995,0.9995,0.9994,0.9993,0.9993,0.9993,0.9992,0.9994,0.9994,0.9993,0.9992,0.9993,0.9993,0.9992,0.9993,0.9994,0.9994,0.9993,0.9994,0.9994,0.9992,0.999,0.9989,0.9989,0.9987,0.9988,0.9988,0.9984,0.9981,0.9978,0.9976,0.9974,0.9972,0.997,0.9966,0.9961,0.9957,0.9953,0.9949,0.9946,0.9938,0.993,0.9925,0.9918,0.9909,0.9895,0.9883,0.9876,0.9864,0.9857,0.9839,0.9812,0.9796,0.9779,0.9757,0.973,0.9686,0.9652,0.961,0.954,0.949,0.9435,0.9366,0.9294,0.9196,0.9108,0.9006,0.887,0.8732,0.8575,0.8421,0.8245,0.8028,0.7852,0.7671,0.741,0.7179,0.6987,0.6757,0.6526,0.6298,0.5808, + 0.9981,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9996,0.9995,0.9995,0.9994,0.9993,0.9993,0.9993,0.9993,0.9994,0.9993,0.9993,0.9993,0.9994,0.9992,0.9993,0.9994,0.9993,0.9993,0.9993,0.9993,0.9993,0.9992,0.9991,0.9991,0.9991,0.9989,0.9986,0.9985,0.9985,0.9982,0.9979,0.9976,0.9974,0.9972,0.9972,0.9969,0.9964,0.9959,0.9952,0.9952,0.9947,0.9934,0.9931,0.9928,0.9922,0.9915,0.9904,0.989,0.9876,0.9867,0.9852,0.9834,0.9819,0.9804,0.9788,0.9763,0.9734,0.9707,0.9659,0.9608,0.9562,0.9509,0.9461,0.9416,0.9336,0.9209,0.9098,0.9,0.8881,0.8748,0.8621,0.8474,0.8282,0.8065,0.7817,0.763,0.7445,0.7198,0.6988,0.6753,0.6519,0.6284,0.5786, + 0.9975,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9997,0.9996,0.9995,0.9993,0.9993,0.9993,0.9993,0.9992,0.9992,0.9993,0.9993,0.9994,0.9994,0.9994,0.9993,0.9993,0.9993,0.9994,0.9994,0.9992,0.9991,0.999,0.999,0.9991,0.999,0.9988,0.9986,0.9985,0.9983,0.9981,0.9978,0.9977,0.9976,0.9972,0.9967,0.9962,0.9958,0.9954,0.9952,0.995,0.9944,0.9936,0.9927,0.992,0.9915,0.9907,0.9897,0.9881,0.987,0.9865,0.9849,0.9826,0.9814,0.9796,0.976,0.9724,0.9698,0.9668,0.9622,0.9571,0.9525,0.9464,0.9377,0.93,0.9225,0.9122,0.9007,0.8877,0.8723,0.8573,0.8414,0.8204,0.8008,0.7855,0.7631,0.7423,0.7212,0.6924,0.6687,0.6449,0.6221,0.5723, + 0.9976,0.9995,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9999,0.9999,0.9998,0.9997,0.9995,0.9994,0.9994,0.9994,0.9994,0.9993,0.9993,0.9993,0.9992,0.9992,0.9992,0.9992,0.9992,0.9992,0.9993,0.9994,0.9994,0.9992,0.999,0.9991,0.9992,0.9992,0.999,0.999,0.999,0.9988,0.9986,0.9984,0.9983,0.9983,0.998,0.9975,0.9974,0.9974,0.9967,0.9962,0.9961,0.996,0.9956,0.995,0.9945,0.9937,0.9925,0.9919,0.9913,0.9904,0.9897,0.9885,0.9873,0.9861,0.9846,0.9831,0.9812,0.9794,0.9775,0.9742,0.9706,0.9669,0.9635,0.9607,0.9554,0.9482,0.9416,0.9347,0.9267,0.9148,0.9034,0.894,0.8806,0.8662,0.8452,0.8279,0.8102,0.7831,0.7623,0.7356,0.7147,0.6972,0.6729,0.649,0.6247,0.5746, + 0.9978,0.9995,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9997,0.9996,0.9994,0.9993,0.9994,0.9993,0.9993,0.9993,0.9993,0.9994,0.9993,0.9993,0.9992,0.9992,0.9992,0.9991,0.9991,0.9992,0.9993,0.9992,0.9993,0.9993,0.9992,0.9991,0.9989,0.9988,0.9987,0.9987,0.9986,0.9984,0.998,0.9978,0.9976,0.9972,0.9973,0.9972,0.9969,0.9965,0.996,0.9954,0.995,0.9946,0.9939,0.9929,0.9921,0.9914,0.9909,0.9904,0.9891,0.9874,0.9861,0.9848,0.9831,0.9815,0.9801,0.9787,0.9751,0.9712,0.9683,0.9641,0.9599,0.9562,0.9503,0.9433,0.9355,0.9263,0.9181,0.9065,0.8934,0.8813,0.8702,0.8525,0.8296,0.8156,0.7995,0.7766,0.7577,0.7371,0.7097,0.6864,0.6629,0.6394,0.5885, + 0.9976,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9995,0.9994,0.9994,0.9994,0.9994,0.9993,0.9991,0.9991,0.9992,0.9992,0.9993,0.9993,0.9994,0.9994,0.9992,0.9992,0.9992,0.9991,0.9991,0.9992,0.9993,0.9991,0.999,0.9989,0.9989,0.9989,0.9988,0.9988,0.9985,0.9982,0.9981,0.9978,0.9977,0.9973,0.9967,0.9964,0.9961,0.9958,0.9954,0.9948,0.9944,0.9939,0.9934,0.9928,0.9917,0.9908,0.9898,0.9885,0.9875,0.9868,0.9856,0.984,0.9813,0.9792,0.9781,0.9749,0.9713,0.9693,0.9664,0.9605,0.9552,0.949,0.9427,0.9372,0.9288,0.9191,0.9054,0.8918,0.8799,0.8657,0.8477,0.8314,0.814,0.7884,0.767,0.7501,0.7284,0.7013,0.6772,0.6533,0.6287,0.5782, + 0.9978,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9996,0.9996,0.9995,0.9995,0.9994,0.9995,0.9993,0.9992,0.9993,0.9993,0.9994,0.9993,0.9992,0.9991,0.9992,0.9992,0.9992,0.9992,0.9992,0.9992,0.999,0.9991,0.9991,0.9988,0.9988,0.9988,0.9988,0.9986,0.9984,0.9983,0.9979,0.9978,0.9977,0.9976,0.9974,0.9967,0.9962,0.9959,0.9958,0.9955,0.9949,0.9941,0.993,0.992,0.9918,0.991,0.99,0.9888,0.9874,0.9866,0.9855,0.9839,0.9821,0.9802,0.9775,0.9757,0.9738,0.9693,0.9656,0.9612,0.9563,0.9508,0.9438,0.9375,0.9309,0.9202,0.9081,0.8966,0.8827,0.8714,0.8598,0.8396,0.8147,0.7931,0.772,0.7499,0.7294,0.7059,0.6818,0.6574,0.6333,0.5815, + 0.9979,0.9996,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9999,0.9998,0.9996,0.9995,0.9995,0.9995,0.9994,0.9993,0.9993,0.9992,0.9993,0.9993,0.9991,0.9992,0.9992,0.9993,0.9993,0.9992,0.9993,0.9994,0.9991,0.9991,0.9992,0.9991,0.9989,0.9989,0.999,0.9989,0.9988,0.9987,0.9986,0.9986,0.9985,0.9981,0.998,0.9979,0.9974,0.9972,0.997,0.9965,0.9961,0.9956,0.9955,0.9953,0.9946,0.994,0.9932,0.9917,0.9903,0.9901,0.9895,0.9883,0.9877,0.9857,0.9834,0.9828,0.9815,0.979,0.9768,0.9747,0.9716,0.9667,0.9611,0.9571,0.9539,0.9471,0.9387,0.9296,0.9189,0.9088,0.8982,0.8842,0.8669,0.847,0.8249,0.8068,0.7907,0.7732,0.7507,0.7199,0.6941,0.6689,0.6435,0.6187,0.5669, + 0.9981,0.9996,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9999,0.9997,0.9996,0.9996,0.9996,0.9994,0.9993,0.9994,0.9993,0.9993,0.9994,0.9993,0.9992,0.9993,0.9993,0.9994,0.9994,0.9993,0.9992,0.9991,0.9992,0.9992,0.9992,0.9992,0.999,0.999,0.999,0.999,0.9988,0.9988,0.9987,0.9985,0.9985,0.9983,0.9979,0.9978,0.9975,0.997,0.9969,0.9968,0.9964,0.996,0.9956,0.9949,0.9941,0.9935,0.9928,0.9921,0.9912,0.99,0.9888,0.9877,0.9867,0.9856,0.9839,0.9826,0.9807,0.9793,0.9773,0.9739,0.9704,0.9663,0.9632,0.9589,0.953,0.9456,0.9376,0.9295,0.9208,0.9115,0.8987,0.8831,0.8685,0.8532,0.8322,0.8139,0.7997,0.7768,0.7487,0.7253,0.7054,0.681,0.6567,0.6329,0.5804) + + +all_years <- c("1999", "2000", "2001", "2002", "2003", "2004", + "2005", "2006", "2007", "2008", "2009", "2010", + "2011", "2012", "2013", "2014", "2015", "2016", + "2017", "2018", "2019") + +# Population for males as matrix +pop_m_mat <- matrix(pop_m, nrow = 101, ncol = 21) +colnames(pop_m_mat) <- all_years + +# Population for females as matrix +pop_f_mat <- matrix(pop_f, nrow = 101, ncol = 21) +colnames(pop_f_mat) <- all_years + +# Age-specific-fertility-rate for as matrix +asfr_mat <- matrix(asfr, nrow = 35, ncol = 20) +colnames(asfr_mat) <- all_years[-length(all_years)] + +# Sex ratio at birth as vector +srb_vec <- c(1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, + 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06) + +names(srb_vec) <- all_years[-length(all_years)] + +# Survival ratio for males as matrix +sr_m_mat <- matrix(sr_m, nrow = 101, ncol = 20) +colnames(sr_m_mat) <- all_years[-length(all_years)] + +# Survival ratio for females as matrix +sr_f_mat <- matrix(sr_f, nrow = 101, ncol = 20) +colnames(sr_f_mat) <- all_years[-length(all_years)] + +# Age/year sequence of all the data from above +interval <- 1 +ages <- seq(0, 100, by = interval) +years <- seq(1999, 2019, by = interval) +ages_fertility <- seq(15, 50, by = interval) + +row.names(pop_m_mat) <- ages +row.names(pop_f_mat) <- ages +row.names(sr_m_mat) <- ages +row.names(sr_f_mat) <- ages +row.names(asfr_mat) <- 15:49 +names(srb_vec) <- years + +mig_res <- + mig_resid_stock( + pop_m_mat = pop_m_mat, + pop_f_mat = pop_f_mat, + sr_m_mat = sr_m_mat, + sr_f_mat = sr_f_mat, + asfr_mat = asfr_mat, + srb_vec = srb_vec, + ages = ages, + ages_asfr = ages_fertility + ) + +mig_res <- + mig_resid_cohort( + pop_m_mat = pop_m_mat, + pop_f_mat = pop_f_mat, + sr_m_mat = sr_m_mat, + sr_f_mat = sr_f_mat, + asfr_mat = asfr_mat, + srb_vec = srb_vec, + ages = ages, + ages_asfr = ages_fertility + ) + +mig_res <- + mig_resid_time( + pop_m_mat = pop_m_mat, + pop_f_mat = pop_f_mat, + sr_m_mat = sr_m_mat, + sr_f_mat = sr_f_mat, + asfr_mat = asfr_mat, + srb_vec = srb_vec, + ages = ages, + ages_asfr = ages_fertility + ) + +# Save data +## pop_m_mat_single = pop_m_mat +## pop_f_mat_single = pop_f_mat +## sr_m_mat_single = sr_m_mat +## sr_f_mat_single = sr_f_mat +## asfr_mat_single = asfr_mat +## srb_vec_single = srb_vec +## ages_single = ages +## ages_asfr_single = ages_fertility + +## usethis::use_data(pop_m_mat_single, +## pop_f_mat_single, +## sr_m_mat_single, +## sr_f_mat_single, +## asfr_mat_single, +## srb_vec_single, +## ages_single, +## ages_asfr_single, +## overwrite = TRUE) + +################### For five year age groups ##################### + +# Vector of population for males +pop_m <- + c(835, 671, 570.999, 544, 552, 550, 513, 487.998, 432.002, + 378.001, 338.001, 295.999, 263.001, 220.999, 156, 92.001, 42.204, + 18.001, 4.331, 0.639, 0.07, 989.592, 880.029, 697.435, 575.575, + 561.146, 595.087, 582.08, 544.567, 507.247, 440.909, 373.935, + 316.617, 265.548, 235.035, 182.951, 110.75, 57.555, 18.737, 5.459, + 0.807, 0.065, 1133.424, 1037.502, 905.664, 698.771, 586.798, + 616.9, 638.007, 615.889, 550.076, 504.215, 430.131, 353.696, + 286.403, 238.634, 194.496, 130.76, 69.399, 26.238, 5.809, 1.011, + 0.083, 1149.519, 1149.942, 1042.707, 897.087, 691.317, 605.519, + 628.132, 641.442, 608.262, 532.131, 486.313, 401.381, 321.04, + 251.388, 197.567, 138.127, 81.716, 32.255, 8.386, 1.152, 0.112, + 959.81, 1167.439, 1166.318, 1054.263, 929.596, 770.233, 655.408, + 649.175, 641.542, 602.148, 513.273, 463.968, 371.397, 286.345, + 203.426, 141.486, 87.742, 38.904, 10.533, 1.647, 0.131, 904.577, + 990.842, 1195.275, 1192.299, 1096.101, 1010.808, 817.203, 673.368, + 657.377, 631.756, 591.218, 483.434, 432.18, 330.595, 237.691, + 147.718, 86.849, 42.396, 13.172, 2.217, 0.2, 914.965, 926.002, + 1008.784, 1224.923, 1217.653, 1099.911, 1019.023, 813.755, 676.39, + 643.237, 614.691, 562.266, 449.355, 383.548, 273.038, 176.289, + 92.764, 43.563, 15.48, 3.067, 0.316, 943.289, 927.824, 937.572, + 1036.631, 1265.185, 1225.442, 1108.122, 1014.48, 806.487, 659.135, + 627.186, 594.356, 527.096, 404.537, 320.095, 205.116, 112.331, + 47.821, 16.391, 3.791, 0.466, 982.718, 980.995, 958.024, 988.65, + 1076.907, 1293.734, 1267.032, 1135.973, 1031.081, 804.56, 654.945, + 615.926, 567.992, 487.466, 348.485, 248.7, 133.025, 58.273, 17.722, + 3.888, 0.553, 1012.228, 1014.939, 1019.3, 1013.749, 1016.987, + 1100.959, 1315.154, 1281.21, 1143.215, 1026.976, 788.317, 641.579, + 592.945, 521.839, 418.599, 270.316, 163.215, 70.003, 21.874, + 4.186, 0.549, 914.063, 1038.649, 1049.297, 1073.621, 1055.672, + 1047.487, 1138.313, 1344.753, 1295.431, 1144.702, 1016.992, 771.165, + 615.065, 550.259, 457.748, 334.624, 185.735, 87.221, 26.085, + 4.898, 0.538, 879.05, 952.912, 1081.565, 1116.92, 1130.826, 1092.34, + 1097.179, 1186.645, 1381.02, 1305.446, 1143.75, 989.552, 751.696, + 577.344, 489.506, 377.661, 245.003, 105.627, 34.645, 6.138, 0.619, + 967.471, 930.238, 993.227, 1141.416, 1220.943, 1218.465, 1152.732, + 1154.005, 1219.105, 1404.229, 1303.056, 1126.891, 960.563, 712.717, + 522.094, 415.611, 295.598, 149.226, 44.788, 8.64, 0.793, 996.168, + 1002.283, 955.049, 1097.332, 1284.199, 1236.929, 1269.189, 1192.192, + 1174.32, 1216.076, 1400.008, 1311.348, 1099.315, 941.078, 652.11, + 452.242, 319.415, 186.665, 65.652, 11.458, 1.11, 1020.925, 1011.765, + 1014.23, 1017.281, 1208.233, 1389.541, 1315.956, 1321.892, 1224.232, + 1189.671, 1215.983, 1380.774, 1275.239, 1047.397, 867.426, 568.286, + 355.943, 205.33, 83.6, 17, 1.474, 1028.191, 1035.869, 1023.388, + 1074.814, 1125.935, 1311.078, 1465.662, 1367.022, 1352.787, 1239.604, + 1191.356, 1203.245, 1346.713, 1220.838, 973.366, 765.273, 455.163, + 235.912, 97.148, 22.528, 2.061, 1035.917, 1043.755, 1047.947, + 1086.086, 1187.203, 1232.794, 1390.453, 1518.531, 1399.596, 1369.011, + 1242.733, 1181.749, 1178.339, 1295.414, 1142.767, 869.016, 624.221, + 310.175, 115.614, 27.037, 2.784, 1045.967, 1052.236, 1056.4, + 1113.398, 1203.477, 1298.811, 1316.2, 1446.37, 1552.621, 1417.392, + 1372.669, 1234.502, 1160.392, 1138.346, 1219.39, 1029.28, 718.949, + 434.576, 156.257, 33.016, 3.417, 1068.682, 1062.337, 1064.906, + 1121.9, 1230.868, 1315.242, 1382.275, 1372.643, 1481.225, 1570.215, + 1421.698, 1364.113, 1214.291, 1124.645, 1077.332, 1107.059, 862.313, + 510.375, 224.598, 45.72, 4.224, 1102.822, 1085.121, 1075.057, + 1130.572, 1239.683, 1342.955, 1399.057, 1438.921, 1408.243, 1499.967, + 1574.252, 1414.059, 1343.384, 1179.959, 1069.144, 985.391, 938.14, + 623.089, 270.065, 67.236, 5.855, 1140.8, 1119.328, 1097.897, + 1140.924, 1248.743, 1352.213, 1427.121, 1456.061, 1474.768, 1428.008, + 1505.633, 1566.169, 1394.527, 1308.152, 1126.043, 984.266, 844, + 689.026, 337.068, 82.618, 8.662) +#' +# Vector of population for females +pop_f <- + c(801, 645, 554.001, 534, 557.999, 564, 521.001, 478.001, + 410.999, 352.999, 318, 276, 239, 196.998, 147, 92, 49.354, 23.001, + 6.5, 1.164, 0.135, 948.057, 844.618, 670.281, 562.978, 556.695, + 589.153, 595.677, 545.622, 488.336, 410.687, 346.698, 303.994, + 257.339, 222.218, 177.703, 111.516, 66.076, 25.155, 8.267, 1.423, + 0.145, 1082.85, 993.185, 866.81, 675.391, 590.032, 594.559, 626.777, + 624.823, 547.167, 485.337, 406.556, 337.02, 285.388, 243.185, + 202.252, 135.464, 80.488, 34.773, 9.379, 1.88, 0.182, 1091.999, + 1101.593, 998.637, 870.126, 696.038, 607.414, 608.372, 634.123, + 618.287, 534.182, 476.099, 390.902, 323.659, 270.819, 222.629, + 158.211, 99.985, 43.526, 13.425, 2.209, 0.243, 916.285, 1113.846, + 1116.448, 1022.769, 918.839, 752.674, 635.897, 619.411, 627.163, + 613.115, 524.316, 470.068, 384.21, 315.25, 247.486, 184.146, + 119.509, 56.879, 17.577, 3.347, 0.307, 858.616, 944.546, 1141.242, + 1148.666, 1080.544, 977.493, 784.947, 647.137, 627.282, 623.897, + 615.885, 510.514, 460.492, 370.614, 286.566, 207.64, 136.385, + 70.415, 24.027, 4.599, 0.483, 868.926, 877.749, 959.791, 1175.057, + 1195.136, 1093.776, 991.924, 782.722, 651.731, 622.015, 618.687, + 605.778, 500.641, 442.912, 341.607, 245.476, 158.844, 84.752, + 32.378, 7.171, 0.792, 895.173, 880.805, 893.824, 982.635, 1215.112, + 1205.436, 1108.77, 989.171, 783.703, 645.936, 620.163, 616.473, + 594.188, 483.99, 407.959, 294.664, 188.001, 102.344, 41.293, + 10.454, 1.36, 936.591, 930.873, 909.761, 937.09, 1040.314, 1261.087, + 1253.31, 1138.156, 1013.326, 789.43, 647.395, 618.625, 607.737, + 578.414, 450.459, 356.927, 227.408, 122.534, 50.048, 13.221, + 1.968, 962.734, 966.476, 967.107, 957.99, 982.293, 1078.452, + 1289.82, 1276.239, 1152.444, 1021.414, 790.697, 651.846, 612.561, + 584.997, 533.268, 389.96, 277.225, 150.795, 61.026, 16.175, 2.495, + 872.149, 989.229, 998.47, 1014.575, 1007.4, 1019.803, 1118.597, + 1322.793, 1295.408, 1160.933, 1017.656, 782.288, 640.445, 591.004, + 544.271, 468.132, 312.504, 184.648, 74.05, 18.888, 2.818, 831.614, + 907.289, 1032.916, 1054.491, 1087.81, 1064.803, 1079.765, 1163.223, + 1358.369, 1304.687, 1162.716, 1010.927, 777.628, 621.991, 554.866, + 485.032, 385.873, 214.234, 93.771, 23.583, 3.281, 918.838, 876.318, + 944.356, 1087.72, 1156.023, 1189.243, 1155.079, 1142.97, 1200.737, + 1385.864, 1307.092, 1157.85, 1000.01, 756.228, 585.003, 501.751, + 414.881, 275.154, 114.55, 31.799, 4.292, 950.252, 955.845, 901.601, + 1034.682, 1232.517, 1230.147, 1278.363, 1207.768, 1177.793, 1204.356, + 1388.633, 1309.444, 1137.271, 975.544, 718.972, 536.404, 423.543, + 303.137, 151.219, 39.364, 5.675, 972.207, 966.024, 968.771, 971.038, + 1155.236, 1343.606, 1310.409, 1330.404, 1239.077, 1193.687, 1207.497, + 1378.179, 1287.326, 1102.782, 925.427, 657.537, 458.654, 313.372, + 169.081, 52.593, 7.072, 976.405, 987.332, 978.581, 1036.217, + 1088.349, 1263.153, 1421.22, 1360.854, 1360.488, 1254.47, 1197.429, + 1200.365, 1355.979, 1250.443, 1049.613, 850.295, 565.065, 343.486, + 179.947, 59.846, 9.474, 983.61, 992.108, 1000.337, 1048.292, + 1157.406, 1200.03, 1343.652, 1473.399, 1392.3, 1376.507, 1258.974, + 1191.956, 1183.853, 1320.389, 1194.661, 970.4, 737.82, 429.619, + 201.231, 64.936, 11.111, 993.232, 1000.063, 1005.704, 1073.068, + 1174.732, 1273.909, 1284.275, 1398.562, 1506.421, 1409.749, 1381.642, + 1254.544, 1177.896, 1156.569, 1266.895, 1112.005, 851.243, 570.482, + 257.474, 74.251, 12.326, 1014.748, 1009.727, 1013.685, 1078.453, + 1199.539, 1291.299, 1358.178, 1339.471, 1432.104, 1523.907, 1415.474, + 1377.117, 1241.194, 1153.335, 1113.937, 1185.875, 984.267, 667.614, + 348.639, 96.877, 14.172, 1047.114, 1031.299, 1023.389, 1086.588, + 1205.189, 1316.366, 1375.813, 1413.531, 1373.503, 1450.422, 1529.735, + 1411.833, 1363.681, 1217.645, 1114.502, 1048.481, 1058.718, 782.58, + 415.883, 133.756, 18.362, 1083.119, 1063.736, 1045.012, 1096.489, + 1213.687, 1322.39, 1401.18, 1431.462, 1447.757, 1392.552, 1457.502, + 1526.287, 1399.672, 1340.065, 1180.192, 1054.342, 943.985, 853.051, + 496.821, 162.711, 25.414) / 1000 +#' +# Vector of age-specific fertility rates +asfr <- c(50.369, 202.131, 206.141, 149.211, 87.253, 31.052, + 2.843, 57.919, 226.709, 222.516, 148.992, 87.888, 29.736, 2.64, + 54.096, 223.587, 211.46, 140.311, 76.881, 26.533, 2.132, 45.049, + 159.679, 156.131, 93.96, 50.059, 15.713, 1.409, 37.188, 119.39, + 132.748, 70.029, 28.02, 7.311, 0.514, 30.209, 101.658, 125.692, + 65.483, 19.804, 3.711, 0.243, 24.9, 88.815, 121.231, 68.621, + 20.031, 3.039, 0.163, 23.238, 78.247, 118.743, 75.403, 24.014, + 3.426, 0.129, 25.141, 75.764, 118.592, 85.555, 29.309, 4.303, + 0.136, 20.117, 64.41, 104.081, 85.589, 32.737, 5.247, 0.219, + 14.645, 53.484, 98.176, 92.658, 37.567, 6.397, 0.273, 13.677, + 51.37, 100.418, 104.868, 48.196, 8.278, 0.393, 11.494, 43.287, + 93.809, 106.904, 53.5, 10.662, 0.544, 8.387, 37.053, 86.307, + 106.038, 55.169, 11.345, 0.701, 6.625, 31.576, 80.064, 106.128, + 58.423, 13.087, 0.917, 5.468, 27.869, 76.196, 107.843, 62.296, + 15.036, 1.172, 4.686, 25.34, 73.943, 110.575, 66.487, 17.107, + 1.462, 4.134, 23.539, 72.551, 113.398, 70.423, 19.099, 1.756, + 3.732, 22.206, 71.53, 115.597, 73.588, 20.803, 2.024, 3.467, + 21.39, 71.244, 117.758, 76.268, 22.224, 2.249) +#' +# Vector of survival rates for males +sr_m <- c(0.95557549, 0.9921273, 0.99594764, 0.99510483, 0.99178483, + 0.99134461, 0.99100899, 0.98929784, 0.98473229, 0.97588706, + 0.96048519, 0.93812765, 0.90615821, 0.8622277, 0.8047363, + 0.71333856, 0.596832, 0.44396816, 0.30330032, 0.18642771, + 0.0911662462413327, 0.96275471, 0.99399428, 0.9968488, 0.99563281, + 0.99229006, 0.99196446, 0.99180061, 0.99013625, 0.98594365, + 0.97719516, 0.96239426, 0.93950426, 0.90620399, 0.86117682, + 0.80225284, 0.71307413, 0.60022645, 0.4558758, 0.31005161, + 0.18518342, 0.0956313878791117, 0.96951141, 0.99496609, 0.99727649, + 0.99607245, 0.99233725, 0.99205108, 0.99228027, 0.99056435, + 0.98605767, 0.97783685, 0.96314897, 0.9406932, 0.90642888, + 0.86286999, 0.80387894, 0.71498269, 0.6066814, 0.46479967, + 0.31958557, 0.19836001, 0.101989015830425, 0.97545992, 0.99563858, + 0.99741385, 0.99592654, 0.99152023, 0.99192115, 0.9924163, + 0.990644, 0.98617665, 0.97752991, 0.96353815, 0.94114166, + 0.90833701, 0.86170391, 0.80301014, 0.72151551, 0.6128495, + 0.47608317, 0.32653048, 0.19655555, 0.103730263806538, 0.98060776, + 0.99617149, 0.99761403, 0.99542383, 0.99054495, 0.99194397, + 0.99266261, 0.99089428, 0.98611279, 0.97789594, 0.96434779, + 0.94341044, 0.91191009, 0.86748795, 0.80686197, 0.72532159, + 0.61846149, 0.48319275, 0.33857582, 0.2104904, 0.112385162790671, + 0.98550309, 0.99688352, 0.99803301, 0.9959062, + 0.99126003, 0.99231634, 0.99301369, 0.99160392, 0.98761021, + 0.97986329, 0.96646197, 0.94623899, 0.91718051, 0.87584219, + 0.81662218, 0.73700918, 0.6303803, 0.50160307, 0.3651526, + 0.23288489, 0.130850768617506, 0.98931819, 0.99775357, 0.9984583, + 0.99673481, 0.99301824, 0.99346278, 0.99369545, 0.99294003, + 0.98994327, 0.98356936, 0.97206458, 0.95389895, 0.92644026, + 0.88661213, 0.82907732, 0.74960973, 0.64331764, 0.51551648, + 0.37629084, 0.24487989, 0.137677217644374, 0.99112504, 0.99814201, + 0.99879926, 0.99711429, 0.99389061, 0.99409107, 0.99396033, + 0.99290953, 0.99073493, 0.98586868, 0.97625645, 0.95984456, + 0.93401387, 0.89576747, 0.84146086, 0.76230416, 0.6528808, + 0.51875327, 0.37059318, 0.23716232, 0.129879589178461, 0.99268153, + 0.99853182, 0.99902021, 0.99755244, 0.99471893, 0.99453053, + 0.99383731, 0.99242559, 0.99039498, 0.98664094, 0.97888902, + 0.96514568, 0.94232807, 0.90695918, 0.85686765, 0.78068285, + 0.6693777, 0.52625072, 0.37539746, 0.23620331, 0.123653858706926, + 0.99378702, 0.99880557, 0.99916867, 0.99795758, 0.99537754, + 0.99534488, 0.99484455, 0.99357678, 0.99141921, 0.9878473, + 0.98134482, 0.96932265, 0.94941573, 0.91742454, 0.86776992, + 0.79533967, 0.68311452, 0.5343893, 0.37262307, 0.2239178, + 0.113720633638293, 0.99399248, 0.99897976, 0.99932852, 0.99822431, + 0.99601855, 0.99591387, 0.99569633, 0.99470259, 0.99268715, + 0.98892298, 0.98249955, 0.97238094, 0.9552462, 0.92844911, + 0.88653064, 0.82114141, 0.71875477, 0.56869525, 0.39721252, + 0.23529357, 0.113792166251756, 0.99425766, 0.99909623, 0.99940998, + 0.99846006, 0.99631257, 0.99603178, 0.99592291, 0.99518752, + 0.99322132, 0.98983274, 0.98368064, 0.9741733, 0.9602258, + 0.93745239, 0.9016288, 0.8444638, 0.75222073, 0.60907965, + 0.4240168, 0.24939352, 0.117336219766853, 0.99471736, 0.99933256, + 0.99947765, 0.99871556, 0.99694493, 0.99649396, 0.99655801, + 0.99589338, 0.99413263, 0.99084735, 0.98542046, 0.97725847, + 0.96497949, 0.9452114, 0.9134356, 0.8610204, 0.7737601, 0.63147622, + 0.43996206, 0.25585397, 0.117677375365884, 0.99489165, 0.99937715, + 0.99951763, 0.99880472, 0.99710652, 0.99665932, 0.99675852, + 0.99614922, 0.99444005, 0.99122406, 0.98598437, 0.97827319, + 0.96683874, 0.94835124, 0.91833471, 0.86821514, 0.78398104, + 0.64282533, 0.44786339, 0.25892654, 0.117310656081295, 0.99547488, + 0.99923281, 0.99957341, 0.99911343, 0.99802214, 0.99709297, + 0.99680896, 0.99635099, 0.99498899, 0.99222347, 0.9875931, + 0.98060053, 0.97014661, 0.9536392, 0.92634894, 0.87987019, + 0.79856151, 0.66278044, 0.47312791, 0.2694788, 0.111570323438865, + 0.99610316, 0.99933917, 0.9996362, 0.99923203, 0.99825186, + 0.99737383, 0.99710434, 0.99670571, 0.99548655, 0.99299216, + 0.9888173, 0.98253469, 0.97316181, 0.95828527, 0.93341992, + 0.89062075, 0.81386423, 0.68145805, 0.49006978, 0.27830681, + 0.113218864970809, 0.99653042, 0.99941146, 0.99967816, 0.99931356, + 0.99841616, 0.99758578, 0.9973301, 0.99697294, 0.99585907, + 0.99356834, 0.9897352, 0.98398011, 0.97540572, 0.96174959, + 0.93872789, 0.89876001, 0.8256409, 0.69618678, 0.50377247, + 0.28557404, 0.114591438080939, 0.99688677, 0.99947174, 0.99971275, + 0.99938206, 0.99855794, 0.99777511, 0.99753337, 0.99721139, + 0.99619015, 0.99408084, 0.99055187, 0.98526355, 0.97739317, + 0.9648224, 0.94346085, 0.90607063, 0.83636949, 0.70989474, + 0.51681708, 0.29260349, 0.115932510195963, 0.99718332, 0.99952193, + 0.9997412, 0.99943948, 0.99868001, 0.99794372, 0.99771578, + 0.99742349, 0.99648352, 0.99453532, 0.99127626, 0.98639967, + 0.97914803, 0.96753912, 0.94766613, 0.91261037, 0.84609618, + 0.7225789, 0.52915469, 0.29935668, 0.117233382382913, 0.99743526, + 0.99956461, 0.99976514, 0.9994886, 0.99878699, 0.99809597, + 0.99788161, 0.99761483, 0.99674727, 0.99494418, 0.99192807, + 0.98742013, 0.98072071, 0.96997658, 0.95145635, 0.91854221, + 0.85503156, 0.73446104, 0.54096047, 0.30591861, + 0.118509238191645) +#' +# Vector of survival rates for females +sr_f <- c(0.854489854276296, 0.935421167801612, 0.97813792986728, + 0.982021189677661, 0.976828336081795, 0.97244561985297, + 0.968812772150047, 0.96483427499772, 0.96010802339363, + 0.954056165687121, 0.943306039954761, 0.92448836548943, + 0.890690237758345, 0.835639114030282, 0.754796751406155, + 0.644175707707241, 0.510754359186887, 0.367690608641792, + 0.24038748937665, 0.145450728453873, 0.0826258994519641, + 0.872081445760557, 0.944846444000478, 0.981301676540409, + 0.98454923599414, 0.980025670920247, 0.976133157582757, + 0.972813894527646, 0.968976434023376, 0.964396307993652, + 0.958650557701456, 0.948256461919103, 0.930336619590153, + 0.898721683064412, 0.846943744756808, 0.7693050373115, + 0.660761281137989, 0.526356065457763, 0.380513624627523, + 0.249631099810745, 0.150641910916079, 0.0845984581684562, + 0.886848633625797, 0.952485090106336, 0.983750072193038, + 0.986500893000163, 0.982460467395807, 0.978978117640805, + 0.975938233552867, 0.972378413253193, 0.967941794833695, + 0.962223931611845, 0.952268831689409, 0.935291261627555, + 0.905449822961756, 0.856292233575997, 0.781888442354377, + 0.676068647825169, 0.542224475987347, 0.394762631381521, + 0.260252774164775, 0.156857215747202, 0.0874135544568921, + 0.900784558263659, 0.9596839642243, 0.986196123803518, + 0.988385232322206, 0.984769248387878, 0.981657532920333, + 0.978917213857464, 0.975642526638743, 0.971423457946261, + 0.965729507599766, 0.956020853088256, 0.939966236835617, + 0.912171280137383, 0.865872642393594, 0.794508147678775, + 0.691547047753295, 0.558414706244368, 0.408689574652693, + 0.269878505194327, 0.1624396495176, 0.0898671492416105, + 0.912633835108388, 0.965550681132028, 0.987920059015778, + 0.989848240747598, 0.986695608763104, 0.983981235542121, + 0.981570190639542, 0.97861812228183, 0.974635289736998, + 0.9691431860219, 0.959749667932423, 0.944374872196883, + 0.918112298204692, 0.874309263183862, 0.80582736469469, + 0.705435057343639, 0.573891155573389, 0.423123546270893, + 0.280818298136084, 0.169320472983824, 0.0930347806338448, + 0.922791200429312, 0.970414095250172, 0.989432301168788, + 0.990708732285749, 0.987862933459543, 0.98554556950358, + 0.983439950663867, 0.980726138018158, 0.976956585172812, + 0.971679032024458, 0.962795297767379, 0.948303265698793, + 0.923561621562827, 0.882274284142424, 0.817184362828982, + 0.720298723984997, 0.590336398050365, 0.439061608307152, + 0.293893306863672, 0.178752339638971, 0.0979770657163587, + 0.933750711567667, 0.975650023350237, 0.991430129981753, + 0.99247477931302, 0.989942622594004, 0.987846767986695, + 0.98591292962169, 0.983362542545618, 0.979767042495056, + 0.974726611965329, 0.96628359885727, 0.95251185213316, + 0.929005505885616, 0.889790085932051, 0.827762556372604, + 0.734212960407364, 0.606322257595734, 0.453895037584414, + 0.305625301261282, 0.186403154530675, 0.101364444633525, + 0.942022185331379, 0.979147123918558, 0.992515619501369, + 0.9933310350342, 0.990999245807151, 0.98905130373017, + 0.987257739978207, 0.984897031588263, 0.981492787306857, + 0.9766673141557, 0.968686240948038, 0.955634366723833, + 0.9333801029294, 0.895907358522987, 0.836661271636903, + 0.746801163214231, 0.621415950298903, 0.468910608066693, + 0.317915153427838, 0.195039481469627, 0.105384282613558, + 0.94718229582512, 0.980790142908247, 0.992803300931434, + 0.993541163348349, 0.991307476656705, 0.989225443921528, + 0.987176469101693, 0.98460623719428, 0.981246509709472, + 0.976718447241337, 0.969160984177711, 0.956833654346736, + 0.935783935128507, 0.900223655022325, 0.843512027545961, + 0.75698552882669, 0.634658767009268, 0.482935300037292, + 0.329848456620383, 0.20331169504299, 0.10978246168398, + 0.953756599857967, 0.984059901645376, 0.993955214747401, + 0.994268297381336, 0.991878910452198, 0.989316711233698, + 0.98661050317541, 0.983509725457937, 0.980068840413112, + 0.975865841537748, 0.96873162752321, 0.957191306973029, + 0.937336013374256, 0.903694171906013, 0.84952642553648, + 0.76536853834578, 0.645403389194791, 0.494479119379901, + 0.339863899010747, 0.210826549541289, 0.113471459046826, + 0.960713535654886, 0.987033073900882, 0.994716009106623, + 0.994894234746082, 0.992525302465177, 0.9895538842758, + 0.986152805334012, 0.982472321949589, 0.979073662581534, + 0.975395328209274, 0.968932259296626, 0.958359612326248, + 0.939967835580358, 0.908680780255339, 0.857541392392623, + 0.777353828146545, 0.661131513296524, 0.512711981039796, + 0.357346432815676, 0.224662101978509, 0.121638559000661, + 0.967668081909087, 0.990008068984907, 0.995560889886471, + 0.995641991716643, 0.993624470509278, 0.991059373658537, + 0.988040353436121, 0.984673329703723, 0.981470430737054, + 0.977934939728761, 0.971766487949973, 0.961780792273926, + 0.944588362056491, 0.915303175185752, 0.867175365253056, + 0.790635307536064, 0.677656963580601, 0.530729783448463, + 0.374404597176352, 0.237203123872316, 0.127388492872508, + 0.973550993968318, 0.99237559671888, 0.996334437474569, + 0.996302569319733, 0.994665042785698, 0.992854350176394, + 0.990804628097226, 0.988299827070781, 0.985427217612243, + 0.98180549401774, 0.975726794918091, 0.966103852460658, + 0.949838547130851, 0.92234926803937, 0.877071883537886, + 0.804140728455995, 0.694271895287286, 0.548487335263838, + 0.389191763586342, 0.24733085854494, 0.131770634512774, + 0.977644495019607, 0.993809059507753, 0.996921848401461, + 0.996813848508293, 0.995383460235151, 0.993952685083984, + 0.992408034278954, 0.990393195059418, 0.987756840918104, + 0.984187864274535, 0.978346485320431, 0.969132680765175, + 0.953701455005333, 0.92763044136048, 0.884677298385547, + 0.814988789377917, 0.708878868603095, 0.565946568832964, + 0.40677396957209, 0.26150417331884, 0.138468877454496, 0.99589669, + 0.99939439, 0.99968965, 0.99946356, 0.99900599, 0.99861604, + 0.99832041, 0.99779148, 0.99668581, 0.9946399, 0.9913872, + 0.98672374, 0.97979077, 0.96855904, 0.94971941, 0.9172498, + 0.85796829, 0.74889563, 0.57422822, 0.35395265, 0.158786622360056, + 0.9963443, 0.99946056, 0.99972569, 0.99951979, 0.99909662, + 0.99871978, 0.99844108, 0.9979583, 0.99694158, 0.99505178, + 0.99204825, 0.98775485, 0.98138426, 0.97102475, 0.95351064, + 0.92310744, 0.86661424, 0.76030246, 0.58585433, 0.36085561, + 0.160294341407215, 0.99679414, 0.99952694, 0.99976136, 0.99957681, + 0.99919131, 0.99883301, 0.99857404, 0.99814009, 0.99721897, + 0.99549888, 0.99276597, 0.98887133, 0.98310375, 0.97368874, + 0.95762803, 0.92951136, 0.87619312, 0.77320377, + 0.59930763, 0.36898278, 0.162083812814283, 0.9971375, 0.99957757, + 0.99978821, 0.99962071, 0.99926645, 0.99892672, 0.99868509, + 0.9982903, 0.99744714, 0.99586696, 0.99335694, 0.98978824, + 0.98451115, 0.97587178, 0.96101941, 0.93482131, 0.88424374, + 0.78427805, 0.61113191, 0.37625625, 0.163698785477625, 0.99744017, + 0.99962217, 0.9998116, 0.99965971, 0.99933486, 0.99901498, + 0.99879044, 0.99843159, 0.99766096, 0.99621214, 0.99391125, + 0.99064648, 0.985825, 0.97791169, 0.9642029, 0.93983665, + 0.89194494, 0.79508552, 0.62293587, 0.38364594, 0.165352911452495, + 0.99771115, 0.99966211, 0.99983233, 0.99969485, 0.99939794, + 0.99909887, 0.9988912, 0.99856572, 0.9978633, 0.996539, 0.9944362, + 0.99145779, 0.98706409, 0.97983722, 0.96722115, 0.94462117, + 0.89938678, 0.80574358, 0.63485152, 0.39124343, 0.167067858821075) +#' +#' +all_years <- c("1950", "1955", "1960", "1965", "1970", "1975", + "1980", "1985", "1990", "1995", "2000", "2005", + "2010", "2015", "2020", "2025", "2030", "2035", + "2040", "2045", "2050") +#' +# Population for males as matrix +pop_m_mat <- matrix(pop_m, nrow = 21, ncol = 21) +colnames(pop_m_mat) <- all_years +#' +# Population for females as matrix +pop_f_mat <- matrix(pop_f, nrow = 21, ncol = 21) +colnames(pop_f_mat) <- all_years +#' +# Age-specific-fertility-rate for as matrix +asfr_mat <- matrix(asfr, nrow = 7, ncol = 20) +colnames(asfr_mat) <- all_years[-length(all_years)] +#' +# Sex ratio at birth as vector +srb_vec <- c(1.058, 1.057, 1.055, 1.055, 1.06, 1.056, 1.056, 1.052, 1.056, + 1.054, 1.054, 1.053, 1.054, 1.053, 1.056, 1.056, 1.056, 1.056, + 1.056, 1.056) +#' +names(srb_vec) <- all_years[-length(all_years)] +#' +# Survival ratio for males as matrix +sr_m_mat <- matrix(sr_m, nrow = 21, ncol = 20) +colnames(sr_m_mat) <- all_years[-length(all_years)] +#' +# Survival ratio for females as matrix +sr_f_mat <- matrix(sr_f, nrow = 21, ncol = 20) +colnames(sr_f_mat) <- all_years[-length(all_years)] +#' +# Age/year sequence of all the data from above +interval <- 5 +ages <- seq(0, 100, by = interval) +years <- seq(1950, 2050, by = interval) +ages_fertility <- seq(15, 45, by = interval) +rownames(asfr_mat) <- ages_fertility +rownames(pop_m_mat) <- ages +rownames(pop_f_mat) <- ages +rownames(sr_m_mat) <- ages +rownames(sr_f_mat) <- ages + +mig_res <- + mig_resid_stock( + pop_m_mat = pop_m_mat, + pop_f_mat = pop_f_mat, + sr_m_mat = sr_m_mat, + sr_f_mat = sr_f_mat, + asfr_mat = asfr_mat, + srb_vec = srb_vec, + ages = ages, + ages_asfr = ages_fertility + ) + +mig_res <- + mig_resid_cohort( + pop_m_mat = pop_m_mat, + pop_f_mat = pop_f_mat, + sr_m_mat = sr_m_mat, + sr_f_mat = sr_f_mat, + asfr_mat = asfr_mat, + srb_vec = srb_vec, + ages = ages, + ages_asfr = ages_fertility + ) + +mig_res <- + mig_resid_time( + pop_m_mat = pop_m_mat, + pop_f_mat = pop_f_mat, + sr_m_mat = sr_m_mat, + sr_f_mat = sr_f_mat, + asfr_mat = asfr_mat, + srb_vec = srb_vec, + ages = ages, + ages_asfr = ages_fertility + ) + +# Save data +pop_m_mat_five = pop_m_mat +pop_f_mat_five = pop_f_mat +sr_m_mat_five = sr_m_mat +sr_f_mat_five = sr_f_mat +asfr_mat_five = asfr_mat +srb_vec_five = srb_vec +ages_five = ages +ages_asfr_five = ages_fertility + +usethis::use_data(pop_m_mat_five, + pop_f_mat_five, + sr_m_mat_five, + sr_f_mat_five, + asfr_mat_five, + srb_vec_five, + ages_five, + ages_asfr_five, + overwrite = TRUE) + + +# End diff --git a/data/ages_asfr_five.rda b/data/ages_asfr_five.rda new file mode 100644 index 000000000..32dad2d8c Binary files /dev/null and b/data/ages_asfr_five.rda differ diff --git a/data/ages_asfr_single.rda b/data/ages_asfr_single.rda new file mode 100644 index 000000000..d9f99a534 Binary files /dev/null and b/data/ages_asfr_single.rda differ diff --git a/data/ages_five.rda b/data/ages_five.rda new file mode 100644 index 000000000..3cab04c8e Binary files /dev/null and b/data/ages_five.rda differ diff --git a/data/ages_single.rda b/data/ages_single.rda new file mode 100644 index 000000000..23a1cbde6 Binary files /dev/null and b/data/ages_single.rda differ diff --git a/data/asfr_mat_five.rda b/data/asfr_mat_five.rda new file mode 100644 index 000000000..3aa59a764 Binary files /dev/null and b/data/asfr_mat_five.rda differ diff --git a/data/asfr_mat_single.rda b/data/asfr_mat_single.rda new file mode 100644 index 000000000..8ee130c73 Binary files /dev/null and b/data/asfr_mat_single.rda differ diff --git a/data/e0_swe.rda b/data/e0_swe.rda new file mode 100644 index 000000000..1883cd51d Binary files /dev/null and b/data/e0_swe.rda differ diff --git a/data/mA_swe.rda b/data/mA_swe.rda new file mode 100644 index 000000000..cbdd090fd Binary files /dev/null and b/data/mA_swe.rda differ diff --git a/data/mig_un_families.rda b/data/mig_un_families.rda new file mode 100644 index 000000000..374830a58 Binary files /dev/null and b/data/mig_un_families.rda differ diff --git a/data/mig_un_params.rda b/data/mig_un_params.rda new file mode 100644 index 000000000..98415694b Binary files /dev/null and b/data/mig_un_params.rda differ diff --git a/data/pop1m_rus2002.rda b/data/pop1m_rus2002.rda new file mode 100644 index 000000000..ef668bbd6 Binary files /dev/null and b/data/pop1m_rus2002.rda differ diff --git a/data/pop1m_rus2010.rda b/data/pop1m_rus2010.rda new file mode 100644 index 000000000..e3a1c9358 Binary files /dev/null and b/data/pop1m_rus2010.rda differ diff --git a/data/pop_f_mat_five.rda b/data/pop_f_mat_five.rda new file mode 100644 index 000000000..115355c24 Binary files /dev/null and b/data/pop_f_mat_five.rda differ diff --git a/data/pop_f_mat_single.rda b/data/pop_f_mat_single.rda new file mode 100644 index 000000000..bc239ff65 Binary files /dev/null and b/data/pop_f_mat_single.rda differ diff --git a/data/pop_m_mat_five.rda b/data/pop_m_mat_five.rda new file mode 100644 index 000000000..76997fbec Binary files /dev/null and b/data/pop_m_mat_five.rda differ diff --git a/data/pop_m_mat_single.rda b/data/pop_m_mat_single.rda new file mode 100644 index 000000000..f5a60e4cd Binary files /dev/null and b/data/pop_m_mat_single.rda differ diff --git a/data/sr_f_mat_five.rda b/data/sr_f_mat_five.rda new file mode 100644 index 000000000..3417dedc4 Binary files /dev/null and b/data/sr_f_mat_five.rda differ diff --git a/data/sr_f_mat_single.rda b/data/sr_f_mat_single.rda new file mode 100644 index 000000000..e2fbdeaeb Binary files /dev/null and b/data/sr_f_mat_single.rda differ diff --git a/data/sr_m_mat_five.rda b/data/sr_m_mat_five.rda new file mode 100644 index 000000000..5f396b8df Binary files /dev/null and b/data/sr_m_mat_five.rda differ diff --git a/data/sr_m_mat_single.rda b/data/sr_m_mat_single.rda new file mode 100644 index 000000000..401242f33 Binary files /dev/null and b/data/sr_m_mat_single.rda differ diff --git a/data/srb_vec_five.rda b/data/srb_vec_five.rda new file mode 100644 index 000000000..5d9a513c2 Binary files /dev/null and b/data/srb_vec_five.rda differ diff --git a/data/srb_vec_single.rda b/data/srb_vec_single.rda new file mode 100644 index 000000000..8b8d395d9 Binary files /dev/null and b/data/srb_vec_single.rda differ diff --git a/dev/.gitignore b/dev/.gitignore index 22b71f5fc..cafb6c2a1 100644 --- a/dev/.gitignore +++ b/dev/.gitignore @@ -3,5 +3,5 @@ /Deprecated/ transitivitytests.R scratch.R -testLT.R junk.R +testLT.R diff --git a/dev/build.R b/dev/build.R index cc91f223d..e5c512842 100644 --- a/dev/build.R +++ b/dev/build.R @@ -1,6 +1,14 @@ # Author: tim ############################################################################### +# old: +# rstan (>= 2.18.1), +# new: +# rstan (>= 2.26.1), +# Tried adding this to Remotes: +# list in DESCRIPTION: +# github::hsbadr/rstan/StanHeaders@develop, +# github::hsbadr/rstan/rstan/rstan@develop shhh <- function(expr){ capture.output(x <- suppressPackageStartupMessages( @@ -17,7 +25,8 @@ library(TimUtils) # do this whenever new functions are added to /R, or whenever roxygen is updated devtools::document() - # do this whenever the vignette text is updated + +# do this whenever the vignette text is updated devtools::build_vignettes() # devtools::install_github("r-lib/pkgdown") @@ -30,6 +39,14 @@ versionIncrement( maxdigits = c(2,2,3),# maybe 4 required? README = TRUE) # update README dev version badge +# add line to immediately commit and tag. +library(magrittr) +library(git2r) +D <- readLines("DESCRIPTION") +vs <- D[grepl(D,pattern = "Version: ")] %>% gsub(pattern = "Version: ", replacement = "") %>% + paste0("v",.) +commit(message = vs) +tag() # run this to get access to already-written functions shhh(load_all()) diff --git a/dev/data-define-reusable.R b/dev/data-define-reusable.R index d8fa432ed..04e7b5e30 100644 --- a/dev/data-define-reusable.R +++ b/dev/data-define-reusable.R @@ -1,5 +1,5 @@ # Author: IK -# Date: 2018-10-12 +# Date: 2018-10-12 UPD: 2021-01-13 ################################################################################ @@ -30,7 +30,7 @@ pop1m_ind <- c( 329149, 48004, 28574, 9200, 7003, 75195, 13140, 5889, 18915, 21221, 72373 ) -devtools::use_data(pop1m_ind, overwrite = T) +usethis::use_data(pop1m_ind, overwrite = T) @@ -52,7 +52,7 @@ pop5_mat <- structure( .Dimnames = list(seq(0, 100, by = 5), 1950:1954) ) -devtools::use_data(pop5_mat, overwrite = T) +usethis::use_data(pop5_mat, overwrite = T) # Male population by 5 year age groups from PASEX AGESMTH @@ -61,7 +61,7 @@ pop5m_pasex <- c( 165937, 122756, 96775, 59307, 63467, 32377, 29796, 16183, 34729 ) -devtools::use_data(pop5m_pasex, overwrite = T) +usethis::use_data(pop5m_pasex, overwrite = T) # Male single year age group population from PASEX SINGAGE @@ -80,7 +80,7 @@ pop1m_pasex <- c( 4137, 133, 169, 157, 89, 2068, 68, 81, 66, 57 ) -devtools::use_data(pop1m_pasex, overwrite = T) +usethis::use_data(pop1m_pasex, overwrite = T) # Feeney zigzag -- deaths in South Africa 1997 @@ -89,7 +89,7 @@ dth5_zigzag <- c( 12473, 11513, 12899, 11413, 12710, 11516, 11408, 6733, 4031, 2069 ) -devtools::use_data(dth5_zigzag, overwrite = T) +usethis::use_data(dth5_zigzag, overwrite = T) # Abridged populations from PAS AGEINT @@ -98,11 +98,22 @@ popA_earlier <- c( 223014, 172260, 149338, 127242, 105715, 79614, 53660, 31021, 34596 ) -devtools::use_data(popA_earlier, overwrite = T) +usethis::use_data(popA_earlier, overwrite = T) popA_later <- c( 201916, 932550, 1248268, 1119118, 893472, 741306, 603724, 498818, 494946, 446028, 344520, 298676, 254484, 211430, 159228, 107320, 62042, 69192 ) -devtools::use_data(popA_later, overwrite = T) +usethis::use_data(popA_later, overwrite = T) + + +# Male population by 1 year age groups from Russian census help on 2002-10-16 +# Source: http://www.demoscope.ru/weekly/ssp/rus2002_01.php +pop1m_rus2002 <- c(682698L, 641551L, 644671L, 644652L, 662998L, 659306L, 678341L, 717053L, 740366L, 753300L, 875113L, 963123L, 1081671L, 1145059L, 1247787L, 1314341L, 1291147L, 1266227L, 1306873L, 1325599L, 1234028L, 1162951L, 1170248L, 1115312L, 1100598L, 1088833L, 1092321L, 1070733L, 1045802L, 1016461L, 1061391L, 994896L, 1007712L, 933628L, 916902L, 929632L, 957895L, 981477L, 1039571L, 1116279L, 1195521L, 1210704L, 1278766L, 1216728L, 1182385L, 1167289L, 1123058L, 1117150L, 1087663L, 998307L, 1035886L, 951627L, 960428L, 963751L, 730354L, 798841L, 604983L, 382611L, 298788L, 280702L, 493677L, 625270L, 694930L, 741777L, 695339L, 693911L, 559111L, 467811L, 358252L, 364999L, 427681L, 405822L, 435844L, 385155L, 379150L, 317841L, 258185L, 193023L, 154406L, 112987L, 89944L, 73858L, 63570L, 54955L, 47194L, 30300L, 28748L, 29419L, 26635L, 20166L, 16673L, 10857L, 8189L, 4839L, 3333L, 2287L, 1458L, 984L, 644L, 488L, 967L) +usethis::use_data(pop1m_rus2002, overwrite = T) + +# Male population by 1 year age groups from Russian census help on 2010-10-25 +# Source: http://www.demoscope.ru/weekly/ssp/rus_age1_10.php +pop1m_rus2010 <- c(842354L, 859562L, 849138L, 788376L, 744105L, 750282L, 748514L, 746626L, 709493L, 675127L, 683827L, 656887L, 678395L, 669374L, 696685L, 743449L, 774172L, 800765L, 923952L, 1035555L, 1167860L, 1187193L, 1252421L, 1300116L, 1262584L, 1247974L, 1230926L, 1249086L, 1156502L, 1125283L, 1182017L, 1088248L, 1073221L, 1038733L, 1051852L, 1046293L, 1008882L, 983045L, 985075L, 949072L, 980924L, 881915L, 866214L, 859808L, 885432L, 926771L, 951739L, 1015812L, 1051749L, 1093184L, 1155128L, 1076307L, 1043777L, 1005283L, 967830L, 964217L, 919814L, 837341L, 841362L, 789019L, 787516L, 775999L, 585545L, 624976L, 471186L, 295668L, 222526L, 205594L, 336318L, 431670L, 471562L, 485883L, 446533L, 438107L, 337694L, 273086L, 198303L, 190828L, 210878L, 195219L, 200564L, 162820L, 151191L, 120794L, 93394L, 66247L, 48072L, 32932L, 23840L, 18087L, 13839L, 10228L, 7790L, 4327L, 3544L, 3137L, 2380L, 1666L, 1137L, 687L, 1379L) +usethis::use_data(pop1m_rus2010, overwrite = T) diff --git a/dev/ik-startup-lines.R b/dev/ik-startup-lines.R index bc65994c9..7e42d49a6 100644 --- a/dev/ik-startup-lines.R +++ b/dev/ik-startup-lines.R @@ -3,7 +3,8 @@ # Sturtup lines to work on package development ################################################################################ +library(tidyverse) library(magrittr) library(devtools) library(testthat) -library(DemoTools) \ No newline at end of file +library(DemoTools) diff --git a/dev/mig_resid_sa.R b/dev/mig_resid_sa.R new file mode 100644 index 000000000..1d4fd1dd8 --- /dev/null +++ b/dev/mig_resid_sa.R @@ -0,0 +1,1101 @@ +#' Estimate net migration using residual methods: stock change, +#' time even flow and cohort even flow +#' +#' @details +#' +#' 1. The stock method (\code{mig_resid_stock}) is the difference in stocks that +#' survive between t and t+5, and the first age group is based on the difference +#' with the surviving births by sex. It provides net migrants by lexis cohort +#' parallelograms, and basically such info gets used as end-period migration +#' since the migrants don't get exposed to mortality within the period. +#' +#' 2. The time even flow (\code{mig_resid_time}) method uses the result from +#' the first option, but splits it back into lexis period squares and assumes +#' that half of the net migrants get exposed to the mortality risk during this +#' period. Such info can get used as evenly distributed migration by period, +#' but the assumptions lead to zig-zag age patterns that are highly implausible. +#' +#' 3. The cohort even flow (\code{mig_resid_cohort}) method provides the most +#' meaningful pattern of net migration by age consistent by cohort and assumes +#' an evenly distribution within the 5-year period, and half of the migrants +#' get exposed both fertility and mortality within this period. +#' +#' @param pop_m_mat A \code{numeric} matrix with population counts. Rows should +#' be ages and columns should be years. Only five year age groups are supported. +#' See examples. +#' +#' @param pop_f_mat A \code{numeric} matrix with population counts. Rows should +#' be ages and columns should be years. Only five year age groups are supported. +#' See examples. +#' +#' @param sr_m_mat A \code{numeric} matrix with survival rates for males. Rows +#' should be ages and columns should be years. ** This matrix should have +#' one column less than \code{pop_m_mat} and \code{pop_f_mat}. For example, +#' if the last year in these matrices is 2050, then the last year in +#' \code{sr_m_mat} should be 2045. ** +#' +#' @param sr_f_mat A \code{numeric} matrix with survival rates for females. Rows +#' should be ages and columns should be years. ** This matrix should have +#' one column less than \code{pop_m_mat} and \code{pop_f_mat}. For example, +#' if the last year in these matrices is 2050, then the last year in +#' \code{sr_f_mat} should be 2045. **. +#' +#' @param asfr_mat A \code{numeric} matrix with age specific fertility rates. +#' Rows should be ages and columns should be years. ** This matrix should have +#' one column less than \code{pop_m_mat} and \code{pop_f_mat}. For example, +#' if the last year in these matrices is 2050, then the last year in +#' \code{asfr_mat} should be 2045**. This row will usually have fewer age groups +#' (rows) than in the population matrices or survival matrices, so the user +#' needs to supply the specific ages in the \code{ages_asfr} argument. +#' +#' @param srb_vec A \code{numeric} vector of sex ratios at birth for every year. +#' The years should be the same as the years in \code{sr_m_mat}, +#' \code{sr_f_mat}, and \code{asfr_mat}. +#' +#' @param ages A \code{numeric} vector of ages used in the rows in +#' \code{pop_m_mat}, \code{pop_f_mat}, \code{sr_m_mat}, \code{sr_f_mat}. +#' +#' @param ages_asfr A \code{numeric} vector of ages used in the rows in +#' \code{asfr_mat}. +#' +#' @return A list with two matrices. One is for males (called `mig_m`) and the +#' other for females (called `mig_f`). Both matrices contain net migration +#' estimates by age/period using one of the three methods. +#' +#' @examples +#' +#' ################ Stock change method ##################### +#' +#' # Vector of population for males +#' pop_m <- +#' c(38, 45, 51, 55, 59, 61, 62, 62, 62, 61, 60, 59, 58, 56, 54, 52, 51, 51, 51, 51, 51, 52, 54, +#' 55, 57, 59, 61, 62, 63, 64, 65, 65, 65, 65, 65, 65, 64, 63, 62, 61, 60, 60, 59, 59, 59, 58, 59, +#' 60, 62, 64, 66, 67, 67, 65, 63, 61, 59, 56, 53, 49, 46, 43, 41, 40, 39, 38, 37, 36, 35, 35, 34, +#' 34, 34, 33, 33, 33, 32, 30, 28, 25, 23, 20, 18, 16, 15, 13, 11, 9, 8, 6, 5, 4, 3, 2, 1, 1, +#' 1, 1, 0, 0, 0, 36, 43, 49, 53, 57, 59, 61, 62, 62, 62, 62, 61, 59, 58, 56, 54, 53, 51, 51, +#' 51, 51, 52, 52, 54, 55, 57, 59, 61, 62, 63, 64, 65, 65, 65, 65, 65, 65, 64, 63, 62, 61, 60, 59, +#' 59, 59, 59, 58, 58, 60, 62, 64, 66, 67, 66, 64, 63, 61, 59, 56, 52, 49, 45, 42, 41, 39, 38, 37, +#' 36 ,35, 35, 34, 34, 33, 33, 32, 32, 31, 30, 28, 26, 24, 21, 19, 17, 15, 13, 11, 9, 8, 6, 5, +#' 3, 3, 2, 1, 1, 1, 0, 0, 0, 0, 38, 38, 44, 49, 53, 56, 59, 61, 62, 63, 62, 62, 61, 60, 58, 56, 5, +#' 53, 52, 51, 52, 52, 52, 53, 54, 56, 58, 60, 61, 62, 63, 64, 65, 66, 66, 65, 65, 65, 64, 63, 62, +#' 61, 60, 59, 59, 59, 58, 58, 58, 60, 62, 64, 66, 67, 66, 64, 62, 61, 58, 55, 52, 49, 45, 42, 40, +#' 39, 38, 36, 35, 34, 34, 33, 33, 32, 32, 31, 30, 30, 29, 27, 24, 22, 19, 17, 15, 13, 11, 10, 8, +#' 7, 5, 4, 3, 2, 2, 1, 1, 0, 0, 0, 0, 43, 45, 40, 44, 48, 52, 55, 58, 61, 63, 63, 63, 62, +#' 61, 60, 58, 57, 55, 53, 52, 52, 52, 52, 53, 53, 55, 56, 58, 60, 61, 63, 64, 64, 65, 66, 66, 65, +#' 65, 65, 64, 63, 62, 61, 60, 59, 59, 59, 58, 58, 58, 60, 62, 64, 65, 66, 66, 64, 62, 60, 58, +#' 55, 51, 48, 44, 41, 39, 38, 37, 36, 34, 34,33, 32, 32, 31, 30, 30, 29, 28, 27, 25, 22, 20, 17, +#' 15, 13, 12, 10, 8, 7, 6, 4, 3, 2, 2, 1, 1, 0, 0, 0, 0, 50, 48, 47, 41, 45, 48, 52, +#' 55, 58, 61, 63, 64, 63, 62, 61, 60, 58, 57, 55, 53, 52, 52, 52, 53, 53, 54, 55, 57, 59, 60, 62, +#' 63, 64, 65, 65, 66, 66, 65, 65, 65, 64, 63, 62, 61, 60, 59, 59, 58, 58, 58, 58, 59, 61, 63, 65, +#' 66, 65, 63, 62, 60, 57, 54, 51, 47, 44, 41, 39, 37, 36, 35, 34, 33, 32, 31, 30, 30, 29, 28, 27, +#' 26, 25, 23, 21, 18, 16, 13, 11, 0, 8, 7, 6, 4, 3, 2, 2, 1, 1, 1, 0, 0, 0, 56, 51, 47, +#' 46, 43, 45, 48, 51, 54, 58, 61, 64, 64, 63, 62, 61, 60, 59, 57, 55, 54, 52, 52, 53, 53, 54, 55, +#' 56, 57, 59, 61, 62, 63, 64, 65, 66, 66, 66, 66, 65, 65, 64, 63, 62, 61, 60, 59, 59, 58, 58, 58, +#' 58, 59, 61, 63, 65, 66, 65, 63, 61, 59, 57, 54, 50, 47, 43, 40, 38, 37, 35, 34, 33, 32, 31, 30, +#' 29, 29, 28, 27, 26, 25, 23, 21, 19, 16, 14, 12, 10, 8, 7, 5, 4, 3, 2, 2, 1, 1, 1, 0, 0, 0, 60, +#' 53, 49, 46, 45, 45, 46, 48, 51, 54, 57, 62, 64, 65, 64, 63, 62, 61, 59, 57, 56, 54, 53, 53, 53, +#' 54, 54, 55, 56, 58, 59, 61, 62, 64, 64, 65, 66, 66, 66, 66, 65, 65, 64, 63, 62, 61, 60, 59, 59, +#' 58, 58, 58, 58, 59, 61, 63, 65, 65, 65, 63, 61, 59, 57, 53, 50, 46, 43, 40, 38, 36, 35, 33, 32, +#' 31, 30, 29, 28, 27, 26, 25, 24, 23, 22, 19, 17, 15, 12, 10, 8, 7, 5, 4, 3, 2, 1, 1, 1, +#' 1, 0, 0, 0, 62, 59, 53, 49, 47, 45, 45, 46, 48, 51, 54, 58, 62, 65, 65, 64, 63, 62, 61, 60, 58, +#' 57, 55, 54, 54, 54, 54, 55, 56, 57, 58, 60, 61, 63, 64, 65, 65, 66, 67, 66, 66, 65, 65, 64, 63, +#' 62, 61, 60, 59, 58, 58, 58, 57, 57, 59, 61, 62, 64, 65, 64, 62, 60, 58, 56, 53, 49, 46, 42, 39, +#' 37, 35, 34, 32, 31, 30, 29, 28, 27, 26, 25, 24, 22, 21, 20, 18, 15, 13, 11, 9, 7, 6, 4, 3, 3, 2, +#' 1, 1, 1, 0, 0, 0, 61, 56, 58, 53, 50, 48, 46, 46, 46, 48, 51, 55, 59, 63, 66, 66, 65, 64, 63, +#' 62, 60, 59, 58, 56, 55, 55, 55, 55, 56, 56, 57, 59, 60, 62, 63, 64, 65, 66, 67, 67, 67, 66, 65, +#' 65, 64, 63, 62, 61, 60, 59, 58, 58, 57, 57, 57, 58, 60, 62, 64, 65, 64, 62, 60, 57, 55, 52, 48, +#' 45, 41, 38, 36, 35, 33, 31, 30, 29, 28, 27, 26, 25, 23, 22, 21, 19, 18, 16, 14, 11, 9, 7, 6, 5, +#' 4, 3, 2, 2, 1, 1, 0, 0, 0, 60, 57, 54, 57, 53, 51, 49, 48, 47,47, 48, 51, 55, 59, 64, 67, 67, +#' 66, 65, 64, 62, 61, 60, 59, 57, 56, 56, 56, 56, 56, 57, 58, 60, 61, 62, 64, 65, 66, 66, 67, 68, +#' 67, 67, 66, 65, 64, 63, 62, 61, 60, 59, 58, 58, 57, 57, 57, 58, 60, 62, 64, 64, 63, 61, 59, 57, +#' 54, 51, 48, 44, 41, 37, 35, 34, 32, 31, 29, 28, 27, 25, 24, 23, 22, 20, 19, 18, 16, 14, 12, 10, +#' 8, 6) +#' +#' # Vector of population for females +#' pop_f <- +#' c(36,43,48,53,56,58,59,59,59,58,57,56,55,53,51,50,48,48,49,49,49,50,52,53,55,57,59,60,60,61,62, +#' 62,62,62,62,61,61,60,59,59,58,57,57,57,57,57,57,59,61,63,65,66,65,63,61,59,57,55,52,49,46,44,42, +#' 42,41,40,40,40,40,40,40,40,41,41,41,42,41,40,38,36,33,31,29,27,25,23,21,19,16,14,11,10,8,6,4,3, +#' 3,2,1,1,1, 34,41,46,50,54,56,58,59,59,59,58,57,56,55,53,51,50,48,48,49,49,50,50,52,54,55,57,59, +#' 60,61,61,62,62,62,62,62,61,61,60,59,59,58,57,57,57,57,56,57,59,61,63,65,66,65,63,61,59,57,54,51, +#' 49,46,43,42,41,41,40,40,40,39,40,40,40,40,40,41,41,40,39,36,34,32,29,27,25,23,21,19,17,14,11,9, +#' 8,6,4,3,2,2,1,1,1,36,36,41,46,50,53,56,58,59,60,59,59,58,56,55,53,52,50,49,49,49,50,50,51,52,54, +#' 56,58,59,60,61,62,62,63,63,62,62,62,61,60,60,59,58,57,57,57,57,57,57,59,61,63,65,66,65,63,61,59, +#' 57,54,51,48,45,43,42,41,40,40,39,39,39,39,39,39,39,39,39,39,39,37,35,32,30,27,25,23,21,19,17,15, +#' 12,10,8,7,5,3,2,2,1,1,1,41,43,38,42,46,50,53,56,58,60,60,60,59,58,57,55,54,52,50,49,49,50,50,51, +#' 52,53,55,56,58,60,61,61,62,63,63,63,63,62,62,61,60,60,59,58,57,57,57,57,56,57,58,61,63,65,65,65, +#' 63,61,59,56,54,51,48,45,43,41,41,40,39,39,38,38,38,38,38,38,38,38,38,37,35,33,30,28,25,23,21,19, +#' 17,15,13,10,8,7,6,4,3,2,1,1,1,47,45,44,39,42,46,49,52,55,58,60,60,60,59,58,57,55,54,52,51,50,50, +#' 50,51,51,52,53,55,57,58,60,61,61,62,63,63,63,63,62,62,61,60,60,59,58,57,57,57,57,56,57,58,60,62, +#' 64,65,64,62,60,58,56,53,51,48,45,42,41,40,39,39,38,38,38,37,37,37,37,37,37,37,36,34,31,29,26,23, +#' 21,19,17,15,13,11,8,6,5,4,3,2,1,1,1,53,48,45,43,41,43,46,49,52,55,58,61,61,60,59,58,57,56,54,53, +#' 51,50,50,51,51,52,53,54,55,57,59,60,61,62,62,63,63,63,63,62,62,61,61,60,59,58,57,57,57,57,56,57, +#' 58,60,62,64,65,64,62,60,58,56,53,50,47,44,42,40,40,39,38,38,37,37,37,37,36,36,36,36,35,34,32,29, +#' 27,24,21,19,17,14,13,11,9,6,5,4,3,2,1,1,1, 57,50,46,43,42,42,44,46,48,51,55,59,61,61,60,59,58, +#' 57,56,55,53,52,51,51,51,52,52,53,54,56,58,59,61,61,62,63,63,64,63,63,63,62,61,61,60,59,58,57, +#' 57,57,57,56,57,58,60,62,64,65,64,62,60,58,56,53,50,47,44,42,40,39,38,38,37,37,36,36,36,36,35, +#' 35,34,34,33,31,28,25,22,19,17,15,12,10,9,7,5,3,3,2,1,1,1,58,56,50,47,44,43,43,44,45,48,51,55, +#' 59,62,62,61,60,59,58,57,55,54,52,51,51,52,52,53,54,55,56,58,59,61,62,62,63,64,64,64,63,63,62, +#' 61,61,60,59,58,57,57,57,57,56,56,58,60,62,64,65,64,62,59,57,55,52,49,47,44,41,40,39,38,37,36, +#' 36,35,35,35,34,34,33,32,32,31,28,25,23,20,17,15,13,10,9,8,6,4,3,2,2,1,1, 58,53,55,50,47,45,44, +#' 44,44,45,48,52,56,60,63,63,62,61,60,59,57,56,55,53,52,52,53,53,53,54,55,57,58,60,61,62,63,64, +#' 64,64,64,64,63,62,61,60,60,59,58,58,57,57,56,56,56,58,60,62,64,65,64,61,59,57,54,52,49,46,43, +#' 41,39,38,37,36,36,35,35,34,34,33,32,32,31,30,28,26,23,20,17,15,13,11,9,7,6,5,3,2,2,1,1 57,54, +#' 51,54,51,48,46,45,45,44,45,48,52,56,60,63,64,63,62,61,60,58,57,56,54,53,53,54,54,54,55,56,57, +#' 59,60,62,63,63,64,65,65,65,64,63,62,61,60,60,59,58,58,57,57,56,56,56,57,60,62,64,64,63,61,59, +#' 56,54,51,48,46,43,40,39,38,37,36,35,34,34,33,33,32,31,30,29,28,26,24,21,18,15,13,11,9,7,6,5,4, +#' 2,2,1,1, 55,54,53,52,53,51,49,47,46,45,44,45,48,52,57,61,64,65,63,63,62,60,59,58,57,55,54,54, +#' 54,55,55,55,57,58,59,61,62,63,64,65,65,66,65,64,63,62,61,61,60,59,58,58,57,57,56,56,56,57,60, +#' 62,64,64,63,61,58,56,53,51,48,45,42,40,38,37,36,35,34,33,33,32,31,31,30,28,27,26,24,22,19,16, +#' 13,11,9,7,5,4,4,3,2,1,1,54,55,55,54,53,52,51,49,48,47,46,45,45,48,53,57,62,65,65,64,63,62,61, +#' 60,59,58,56,55,55,55,55,55,56,57,58,60,61,63,64,64,65,66,66,66,65,64,62,61,60,60,59,59,58,57, +#' 57,56,55,56,57,59,61,63,64,63,61,58,56,53,50,47,45,42,39,38,37,35,34,34,33,32,31,30,29,28,27, +#' 25,24,22,20,17,14,11,9,7,5,4,3,2,2,1,1,53,55,55,55,54,53,52,51,50,48,47,46,45,45,49,53,58,63, +#' 66,67,65,64,63,62,61,60,59,57,56,56,56,56,56,56,58,59,60,62,63,64,65,66,66,67,66,65,64,62,61, +#' 60,60,59,59,58,57,57,56,55,55,57,59,61,63,64,63,60,58,55,52,49,47,44,41,38,37,36,34,33,32,31, +#' 31,30,29,28,26,25,23,22,20,18,15,12,9,8,6,4,3,3,2,1,1,53,55,56,56,55,55,54,52,51,50,49,48,46, +#' 45,46,49,54,59,64,67,68,67,65,64,63,62,61,59,58,57,57,57,57,57,57,58,59,61,62,63,64,65,66,67, +#' 67,66,65,64,62,61,60,60,59,59,58,57,57,56,55,55,56,59,61,63,64,63,60,57,54,51,49,46,43,40,37,36, +#' 35,34,32,31,30,29,28,27,26,24,23,21,20,18,15,12,10,8,7,5,3,3,2,1,1,54,56,57,57,57,56,55,54,53, +#' 51,50,49,48,47,45,46,49,55,60,65,69,69,68,66,65,64,62,61,60,59,58,57,57,57,57,57,58,60,61,63, +#' 64,65,66,66,67,67,66,65,64,62,61,60,60,59,59,58,57,56,55,54,54,56,58,61,63,64,62,59,56,53,50, +#' 48,45,42,39,37,35,34,33,31,30,29,28,27,25,24,22,21,19,17,16,13,10,8,6,5,4,3,2,1,1,54,56,58,58, +#' 58,57,56,55,54,53,52,50,49,48,47,45,46,50,55,61,66,70,70,69,67,66,64,63,62,61,60,58,58,58,58,5 +#' 7,58,59,60,61,63,64,65,66,67,67,67,67,65,64,62,61,60,60,59,59,58,57,56,55,54,54,55,58,60,63,63, +#' 62,59,56,53,50,47,44,41,38,36,34,33,31,30,29,28,26,25,24,22,21,19,17,15,13,11,8,6,5,4,3,2,1,2, +#' 55,57,58,58,59,58,58,57,56,54,53,52,51,49,48,47,45,46,50,56,61,67,71,71,70,68,67,65,64,63,62, +#' 60,59,59,58,58,58,58,59,60,62,63,64,65,66,67,68,68,67,65,64,62,61,60,60,59,59,58,57,56,55,54, +#' 53,55,58,60,62,63,61,58,55,52,49,46,43,40,37,35,33,32,30,29,28,26,25,23,22,21,19,17,14,13,11,9, +#' 6,4,3,3,2,1,2,55,55,57,58,58,58,58,58,57,56,55,53,52,51,50,49,48,46,47,51,57,62,68,72,72,70,69, +#' 67,66,64,63,62,61,60,59,59,58,58,58,59,61,62,63,65,65,66,67,68,68,67,65,64,62,61,60,60,59,58,58, +#' 57,56,55,53,53,55,57,59,62,62,61,58,54,51,48,45,42,39,36,34,32,31,29,28,26,25,23,22,20,19,17,15, +#' 12,11,10,8,5,4,3,2,1,2,57,58,56,57,58,58,58,58,58,57,56,55,54,53,52,50,49,48,47,48,52,57,63,69, +#' 73,73,71,70,68,66,65,64,63,61,60,59,59,59,58,59,60,61,62,63,65,66,66,67,68,68,67,65,64,62,61,60, +#' 59,59,58,58,57,56,54,53,53,54,57,59,61,62,60,57,54,50,47,44,41,38,35,33,31,29,28,26,25,23,21,20, +#' 18,17,15,12,10,9,8,6,4,3,2,1,2,58,58,58,57,57,58,58,58,58,58,57,56,55,54,53,52,51,50,49,48,49, +#' 52,58,64,70,73,74,72,70,68,67,65,64,63,61,60,60,59,59,59,59,60,61,62,64,65,66,66,67,68,68,67,65, +#' 64,62,61,60,59,59,58,57,56,55,54,53,53,54,56,58,61,61,59,56,53,50,46,43,40,37,34,32,30,28,26,25, +#' 23,21,19,18,16,15,13,10,9,8,7,5,3,2,1,2,59,58,58,58,57,58,58,58,58,58,58,57,56,55,54,53,53,51, +#' 51,50,49,49,53,59,65,70,74,74,72,71,69,67,66,65,63,62,61,60,59,59,59,59,60,61,62,64,65,66,66,67, +#' 68,68,67,65,64,62,61,60,59,58,58,57,56,55,54,53,52,54,56,58,60,61,59,55,52,49,45,42,40,36,33,31, +#' 28,27,25,23,22,20,18,16,14,13,11,8,7,6,5,4,2,1,2,59,59,58,58,58,58,58,58,58,58,58,58,57,57,55, +#' 54,54,53,52,51,50,49,50,54,60,65,71,75,75,73,71,70,68,66,65,64,62,61,60,60,59,59,59,60,61,62, +#' 64,65,66,66,67,68,68,67,65,64,62,61,60,59,58,58,57,56,55,54,52,52,53,55,57,59,60,58,55,51,48, +#' 45,41,39,35,32,29,27,25,23,22,20,18,16,14,12,11,9,6,5,4,3,2,1,2) +#' +#' # Vector of age-specific fertility rates +#' asfr <- c(0.000415,0.00209,0.004145,0.010155,0.017665,0.027095, +#' 0.038225,0.046765,0.0582,0.07097,0.083335,0.09792,0.10819,0.11661, +#' 0.117465,0.11389,0.10584,0.095805,0.081925,0.07266,0.06205,0.05031, +#' 0.0402,0.029295,0.023435,0.015425,0.010325,0.006225,0.00378,0.001845, +#' 0.00083,0.00046,0.00005,0.000085,0.00003,0.00052,0.001915,0.005605, +#' 0.009435,0.01871,0.02803,0.03896,0.04524,0.057105,0.070205,0.084105, +#' 0.1004,0.10972,0.12058,0.121825,0.11956,0.109495,0.099345,0.090625, +#' 0.075065,0.064575,0.05104,0.0413,0.03231,0.02354,0.01639,0.009985, +#' 0.00634,0.004215,0.001875,0.00091,0.00048,0.00014,0.00012,0.000065, +#' 0.000685,0.00211,0.00459,0.009075,0.0181,0.026515,0.036495,0.04599, +#' 0.058185,0.070745,0.082965,0.097255,0.10583,0.116975,0.12034,0.121645, +#' 0.118705,0.105155,0.0935,0.078975,0.069225,0.055105,0.04294,0.032315, +#' 0.024895,0.01653,0.012175,0.007115,0.003845,0.002,0.00081,0.000385, +#' 0.000135,0.0001,0.00007,0.000395,0.002155,0.00538,0.01025,0.01744, +#' 0.02757,0.03798,0.047435,0.059845,0.070295,0.085905,0.097875,0.113365, +#' 0.12143,0.12913,0.13287,0.126885,0.11332,0.098785,0.08711,0.070315, +#' 0.05895,0.044535,0.034625,0.026315,0.018275,0.012505,0.007335,0.00418, +#' 0.002295,0.000985,0.000415,0.000175,0.000105,0.000035,0.00056, +#' 0.001925,0.00536,0.00899,0.01594,0.02764,0.0387,0.048325,0.05559, +#' 0.069995,0.085535,0.09787,0.11428,0.126135,0.135655,0.13816,0.132265, +#' 0.12517,0.106395,0.09231,0.07695,0.06148,0.05132,0.037605,0.0289, +#' 0.019855,0.013335,0.007535,0.00457,0.002155,0.00108,0.00065,0.00012, +#' 0.000105,0.000035,0.000515,0.00204,0.00449,0.008325,0.01641,0.027835, +#' 0.03772,0.046995,0.054845,0.071795,0.08601,0.09841,0.11213,0.129055, +#' 0.137675,0.138955,0.136445,0.128615,0.11401,0.09782,0.0793,0.06689, +#' 0.051755,0.04049,0.030265,0.02152,0.014165,0.00863,0.00531,0.00286, +#' 0.0009,0.000485,0.00024,0.00005,0.000035,0.00061,0.001715,0.004275, +#' 0.00819,0.017095,0.02619,0.03677,0.047475,0.05763,0.069865,0.081945, +#' 0.09929,0.110015,0.13017,0.13437,0.14298,0.13867,0.13124,0.114545, +#' 0.10012,0.0854,0.07069,0.05289,0.04139,0.0313,0.021265,0.01365, +#' 0.009055,0.005025,0.0026,0.001515,0.000605,0.00019,0.00014, +#' 0.00005,0.00043,0.001745,0.00483,0.00803,0.017205,0.026975,0.03812, +#' 0.0498,0.05848,0.0711,0.085385,0.099465,0.116595,0.132605,0.141035, +#' 0.145675,0.14637,0.13643,0.1226,0.109555,0.09091,0.07415,0.05954, +#' 0.044,0.03277,0.023015,0.015135,0.009085,0.00577,0.00288,0.000945, +#' 0.000925,0.000365,0.00016,0.000035,0.00058,0.00181,0.00414,0.007795, +#' 0.0171,0.02706,0.040175,0.0497,0.06138,0.0754,0.0849,0.101365, +#' 0.113765,0.12703,0.14095,0.145175,0.1454,0.13895,0.125435,0.109375, +#' 0.0931,0.07791,0.060535,0.046815,0.03495,0.02434,0.01647,0.010475, +#' 0.006015,0.003015,0.00146,0.000735,0.000505,0.000145,0.000085,0.0005, +#' 0.00131,0.00409,0.007815,0.016955,0.02869,0.041145,0.05194,0.062625, +#' 0.07733,0.089215,0.09915,0.114505,0.13087,0.14321,0.1474,0.14718, +#' 0.13722,0.125395,0.110985,0.09451,0.078285,0.060645,0.049175,0.036805, +#' 0.024725,0.01707,0.01021,0.00565,0.002975,0.001535,0.000875,0.000295, +#' 0.00017,0.00007,0.00059,0.00142,0.004095,0.007065,0.01605,0.028775, +#' 0.038975,0.05168,0.062965,0.07423,0.08839,0.102815,0.11722,0.128075, +#' 0.140695,0.14827,0.147145,0.139575,0.124925,0.115005,0.10046,0.07994, +#' 0.065455,0.05039,0.036865,0.02644,0.018245,0.01033,0.006675,0.003285, +#' 0.0018,0.00082,0.0003,0.000275,0.000155,0.000415,0.001565,0.00368, +#' 0.007465,0.015375,0.027185,0.039185,0.05004,0.06393,0.078245,0.091495, +#' 0.10549,0.119415,0.132825,0.14508,0.146535,0.152615,0.14506,0.129695, +#' 0.116805,0.100135,0.08581,0.06692,0.0517,0.04117,0.027675,0.01863, +#' 0.01183,0.006305,0.00375,0.00199,0.00091,0.000435,0.000115,0.000185, +#' 0.00039,0.00167,0.003365,0.00721,0.015025,0.02415,0.03536,0.0473, +#' 0.05979,0.07669,0.08609,0.099455,0.11409,0.127615,0.135055,0.139255, +#' 0.142215,0.13442,0.12758,0.11536,0.095805,0.084415,0.06851,0.050215, +#' 0.03904,0.028855,0.01871,0.011115,0.00661,0.00322,0.001785,0.000885, +#' 0.00032,0.00016,0.00017,0.00037,0.00139,0.00349,0.00648,0.013235, +#' 0.022885,0.03429,0.04627,0.06062,0.0747,0.08875,0.102265,0.113975, +#' 0.126025,0.133335,0.14266,0.145635,0.135565,0.125785,0.11608,0.099185, +#' 0.082475,0.064515,0.053475,0.03974,0.028015,0.01857,0.012445,0.006835, +#' 0.003715,0.00195,0.001035,0.000495,0.000385,0.000245,0.00055,0.00141, +#' 0.003325,0.0063,0.013195,0.02156,0.03351,0.044095,0.057585,0.07177, +#' 0.08555,0.10087,0.11176,0.12691,0.133945,0.14199,0.14091,0.140015, +#' 0.126205,0.11514,0.096115,0.082895,0.06829,0.05249,0.04038,0.0289, +#' 0.018745,0.0116,0.006765,0.00338,0.00179,0.000925,0.00052,0.000375, +#' 0.00023,0.00046,0.001105,0.00294,0.006765,0.01239,0.019805,0.029245, +#' 0.04243,0.056205,0.071675,0.086795,0.104835,0.113775,0.126065, +#' 0.136305,0.140305,0.139335,0.134685,0.12758,0.11418,0.0979,0.080865, +#' 0.066865,0.052935,0.04007,0.030485,0.01916,0.01159,0.0076,0.003765, +#' 0.00198,0.00097,0.0007,0.000265,0.000115,0.000295,0.00114,0.003045, +#' 0.0056,0.0115,0.02006,0.028345,0.042025,0.053665,0.0689,0.088195, +#' 0.102155,0.11291,0.126765,0.13238,0.139095,0.137405,0.13127,0.119895, +#' 0.11279,0.097485,0.08156,0.06475,0.05382,0.03895,0.029045,0.018885, +#' 0.01236,0.006625,0.003655,0.002055,0.00118,0.00053,0.000275,0.000295, +#' 0.0005,0.001235,0.002775,0.005245,0.01218,0.019915,0.029575,0.038195, +#' 0.052965,0.06899,0.084725,0.101895,0.11375,0.126235,0.135615,0.13995, +#' 0.13603,0.130845,0.119245,0.11024,0.09851,0.083725,0.067125,0.053155, +#' 0.041975,0.03034,0.020565,0.0128,0.0077,0.00427,0.00218,0.00107, +#' 0.000655,0.000375,0.000175,0.00033,0.00123,0.002695,0.00597,0.01165, +#' 0.01963,0.03009,0.03768,0.048195,0.063535,0.078305,0.09598,0.107535, +#' 0.119215,0.129095,0.131615,0.133445,0.128725,0.120115,0.10175,0.09485, +#' 0.081035,0.06597,0.05288,0.040885,0.030075,0.020595,0.01365,0.0073, +#' 0.00487,0.00216,0.001375,0.0006,0.000285,0.000465,0.00026,0.00117, +#' 0.00229,0.00592,0.011875,0.01965,0.027745,0.039155,0.04793,0.061335, +#' 0.0765,0.0926,0.10439,0.120235,0.12707,0.13096,0.13116,0.12526, +#' 0.116655,0.10556,0.092845,0.07854,0.063975,0.05414,0.04103,0.02982, +#' 0.0198,0.01193,0.00737,0.003905,0.002225,0.00128,0.000515,0.000455, +#' 0.0002,0.000125,0.000585,0.001745,0.00481,0.01018,0.017045,0.02656, +#' 0.03713,0.04708,0.05847,0.072555,0.08687,0.10064,0.11546,0.12387, +#' 0.126185,0.12862,0.12251,0.113105,0.10449,0.09449,0.07635,0.063905, +#' 0.053,0.040715,0.031045,0.0204,0.013075,0.00754,0.004455,0.002665, +#' 0.0017,0.00082,0.00038,0.000355) +#' +#' # Vector of survival rates for males +#' sr_m <- c(0.9966,0.9993,0.9998,0.9999,0.9999,0.9999,0.9999,0.9998, +#' 0.9999,0.9999,0.9999,0.9998,0.9998,0.9998,0.9998,0.9998,0.9998,0.9997, +#' 0.9996,0.9995,0.9994,0.9993,0.9993,0.9994,0.9994,0.9993,0.9993,0.9994, +#' 0.9993,0.9992,0.9993,0.9993,0.9993,0.9993,0.9992,0.9991,0.999,0.9989, +#' 0.9989,0.9987,0.9986,0.9985,0.9983,0.9981,0.9982,0.998,0.9979,0.9978, +#' 0.9973,0.9969,0.9967,0.9965,0.9963,0.9957,0.9951,0.9945,0.9941,0.9938, +#' 0.9931,0.9922,0.9913,0.9908,0.99,0.9882,0.9866,0.9856,0.9844,0.9823, +#' 0.9796,0.9775,0.9755,0.9718,0.9685,0.9664,0.9631,0.958,0.9541,0.9495, +#' 0.9423,0.9358,0.929,0.9193,0.9094,0.9001,0.8908,0.8804,0.8633,0.849, +#' 0.8363,0.8167,0.7994,0.7831,0.7606,0.74,0.7174,0.6948,0.6811,0.6598, +#' 0.6388,0.6174,0.7246,0.9965,0.9993,0.9998,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9998,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997, +#' 0.9997,0.9995,0.9993,0.9992,0.9992,0.9992,0.9992,0.9993,0.9993,0.9991, +#' 0.9993,0.9993,0.9993,0.9993,0.9993,0.9992,0.9992,0.9992,0.9991,0.9991, +#' 0.9991,0.9989,0.9989,0.9989,0.9987,0.9987,0.9986,0.9981,0.9979,0.9979, +#' 0.9977,0.9971,0.9968,0.997,0.9966,0.996,0.9959,0.9954,0.995,0.9946, +#' 0.9941,0.9934,0.9925,0.9918,0.9907,0.9896,0.9891,0.9875,0.9857,0.9845, +#' 0.983,0.9812,0.9785,0.9757,0.9736,0.9701,0.9668,0.9641,0.9599,0.9556, +#' 0.95,0.9447,0.9384,0.9315,0.925,0.9143,0.9031,0.8924,0.8799,0.8653, +#' 0.8488,0.8359,0.8257,0.8106,0.7911,0.7647,0.7396,0.7218,0.6989,0.6796, +#' 0.6577,0.6363,0.6142,0.5535,0.9966,0.9993,0.9998,0.9998,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998, +#' 0.9997,0.9997,0.9996,0.9995,0.9992,0.9991,0.9991,0.9992,0.9993,0.9993, +#' 0.9993,0.9993,0.9993,0.9994,0.9994,0.9993,0.9993,0.9992,0.9991,0.9992, +#' 0.9991,0.999,0.9989,0.9987,0.9986,0.9986,0.9985,0.9984,0.9982,0.9981, +#' 0.9978,0.9973,0.9971,0.9971,0.9969,0.9967,0.9965,0.9958,0.9953,0.9951, +#' 0.9945,0.9937,0.9929,0.9926,0.9923,0.9906,0.99,0.9892,0.9874,0.9864, +#' 0.9848,0.983,0.981,0.979,0.9775,0.9747,0.9715,0.969,0.9653,0.9612, +#' 0.9565,0.9513,0.9466,0.9398,0.932,0.924,0.9177,0.9076,0.8949,0.8828, +#' 0.8699,0.8589,0.8413,0.8234,0.8063,0.782,0.7602,0.7399,0.7241,0.7089, +#' 0.679,0.6563,0.6344,0.6134,0.5604,0.9969,0.9993,0.9996,0.9997,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9998,0.9997,0.9997,0.9996,0.9994,0.9993,0.9993,0.9992,0.999,0.9992, +#' 0.9993,0.9993,0.9993,0.9994,0.9995,0.9994,0.9992,0.9992,0.9993,0.9993, +#' 0.9993,0.9992,0.9991,0.9991,0.9989,0.9987,0.9987,0.9985,0.9984,0.9983, +#' 0.9981,0.998,0.9978,0.9976,0.9976,0.9971,0.9966,0.9962,0.996,0.9956, +#' 0.995,0.9947,0.9943,0.9931,0.9923,0.9916,0.991,0.9906,0.9893,0.9879, +#' 0.987,0.9851,0.9833,0.9817,0.9789,0.9767,0.9754,0.9719,0.9679,0.9651, +#' 0.9612,0.9577,0.9521,0.9454,0.94,0.9328,0.9256,0.9161,0.9066,0.8969, +#' 0.8831,0.87,0.8527,0.8364,0.8206,0.8016,0.7879,0.7665,0.7305,0.7086, +#' 0.7018,0.6734,0.6506,0.628,0.6056,0.587,0.9969,0.9993,0.9997,0.9997, +#' 0.9998,0.9999,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9998,0.9997,0.9996,0.9994,0.9993,0.9993,0.9993,0.9993, +#' 0.9993,0.9992,0.9994,0.9995,0.9994,0.9994,0.9994,0.9995,0.9995,0.9994, +#' 0.9992,0.9991,0.9992,0.9992,0.999,0.9989,0.9988,0.9987,0.9986,0.9985, +#' 0.9981,0.9981,0.998,0.9976,0.9974,0.9972,0.9969,0.9968,0.9966,0.9962, +#' 0.9955,0.995,0.9945,0.994,0.9938,0.9933,0.9924,0.9914,0.9902,0.9893, +#' 0.9885,0.9866,0.9846,0.9837,0.9819,0.9799,0.9778,0.9739,0.9718,0.9695, +#' 0.9655,0.9622,0.958,0.9527,0.9476,0.9424,0.9355,0.9248,0.9156,0.9069, +#' 0.8979,0.8869,0.8705,0.8563,0.8412,0.8249,0.8104,0.7927,0.7748,0.7577, +#' 0.7306,0.7084,0.6884,0.6664,0.6454,0.6234,0.5009,0.9972,0.9994,0.9998, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9998,0.9998,0.9997,0.9997,0.9995,0.9994,0.9992,0.9991,0.9992, +#' 0.9993,0.9992,0.9992,0.9993,0.9994,0.9993,0.9993,0.9994,0.9994,0.9993, +#' 0.9994,0.9993,0.9992,0.9993,0.9991,0.9991,0.9991,0.9989,0.9989,0.9989, +#' 0.9986,0.9983,0.9981,0.998,0.9979,0.9977,0.9972,0.9966,0.9965,0.9965, +#' 0.9963,0.9957,0.9953,0.9947,0.994,0.9936,0.9932,0.9925,0.9917,0.991, +#' 0.9903,0.9886,0.9869,0.9858,0.9843,0.9825,0.9805,0.9785,0.9756,0.9725, +#' 0.9705,0.9681,0.9653,0.9608,0.9554,0.9514,0.946,0.9386,0.9299,0.9223, +#' 0.9144,0.9018,0.8894,0.8776,0.8645,0.8453,0.8273,0.8171,0.8011,0.7761, +#' 0.749,0.7403,0.7271,0.6924,0.6703,0.6479,0.6255,0.5403,0.9979,0.9994, +#' 0.9997,0.9998,0.9998,0.9999,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9998,0.9998,0.9998,0.9997,0.9996,0.9995,0.9994,0.9993, +#' 0.9993,0.9993,0.9994,0.9993,0.9992,0.9993,0.9993,0.9992,0.9993,0.9994, +#' 0.9993,0.9994,0.9994,0.9992,0.9992,0.9993,0.9993,0.999,0.9989,0.9989, +#' 0.9986,0.9985,0.9984,0.9983,0.9981,0.9979,0.9978,0.9974,0.9972,0.9972, +#' 0.9967,0.9958,0.9954,0.9953,0.9946,0.9943,0.9941,0.9933,0.9922,0.9917, +#' 0.9908,0.9897,0.989,0.9875,0.9851,0.9841,0.983,0.981,0.9792,0.9772, +#' 0.9748,0.9708,0.967,0.9638,0.96,0.9559,0.9513,0.9442,0.9363,0.9294, +#' 0.9214,0.9121,0.9011,0.8887,0.8762,0.8614,0.8452,0.8306,0.8111, +#' 0.7966,0.7811,0.7447,0.7124,0.6993,0.6873,0.665,0.6426,0.6206,0.6098, +#' 0.9974,0.9994,0.9998,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9998,0.9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9996,0.9996,0.9995, +#' 0.9994,0.9994,0.9993,0.9992,0.9993,0.9994,0.9994,0.9994,0.9995,0.9994, +#' 0.9993,0.9995,0.9995,0.9993,0.9993,0.9994,0.9992,0.9991,0.9991,0.999, +#' 0.999,0.9989,0.9986,0.9986,0.9986,0.9984,0.9982,0.9979,0.9979,0.9978, +#' 0.9974,0.9969,0.9965,0.9959,0.9954,0.9953,0.9949,0.9943,0.994,0.9935, +#' 0.9926,0.9918,0.991,0.9902,0.9891,0.9872,0.9852,0.985,0.9844,0.9824, +#' 0.9797,0.9771,0.975,0.9725,0.9691,0.9658,0.9617,0.9568,0.9522,0.9466, +#' 0.9394,0.9306,0.9237,0.916,0.9036,0.8915,0.8787,0.8654,0.8498,0.8306, +#' 0.8147,0.7989,0.7774,0.7561,0.7387,0.7168,0.6941,0.672,0.6496,0.6273, +#' 0.5327,0.9977,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9996, +#' 0.9993,0.9992,0.9993,0.9993,0.9994,0.9993,0.9992,0.9992,0.9992,0.9993, +#' 0.9993,0.9993,0.9994,0.9994,0.9994,0.9993,0.9993,0.9993,0.9992,0.9992, +#' 0.9991,0.9989,0.9989,0.9988,0.9986,0.9985,0.9983,0.998,0.998,0.9979, +#' 0.9976,0.9971,0.9967,0.9963,0.9962,0.9961,0.9957,0.9952,0.9947,0.994, +#' 0.9933,0.993,0.9922,0.991,0.99,0.9888,0.9874,0.9866,0.9854,0.9839, +#' 0.9827,0.9807,0.9788,0.9765,0.9734,0.9711,0.9675,0.9634,0.9591, +#' 0.9524,0.9475,0.9414,0.9329,0.9248,0.916,0.9056,0.8949,0.8821,0.8679, +#' 0.8541,0.8379,0.8184,0.7978,0.7775,0.7522,0.7237,0.7016,0.6906,0.6677, +#' 0.6448,0.6226,0.5853,0.9979,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998, +#' 0.9997,0.9996,0.9995,0.9994,0.9993,0.9993,0.9993,0.9992,0.9993,0.9993, +#' 0.9993,0.9992,0.9993,0.9992,0.9992,0.9992,0.9993,0.9993,0.9993,0.9992, +#' 0.9992,0.9992,0.9992,0.9991,0.999,0.9988,0.9986,0.9985,0.9984,0.9982, +#' 0.9982,0.9981,0.9977,0.9973,0.9968,0.9967,0.9963,0.9957,0.9958,0.9955, +#' 0.9947,0.9939,0.9935,0.993,0.9923,0.9914,0.9903,0.9891,0.9879,0.9872, +#' 0.9862,0.9843,0.982,0.9807,0.9791,0.9766,0.9743,0.9704,0.9665,0.9646, +#' 0.9606,0.954,0.9489,0.9427,0.9326,0.9246,0.9172,0.9075,0.8967,0.8833, +#' 0.8673,0.8531,0.8359,0.817,0.8054,0.784,0.7543,0.7308,0.7135,0.6957, +#' 0.6731,0.6503,0.6278,0.5519,0.9978,0.9994,0.9997,0.9997,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998, +#' 0.9998,0.9997,0.9997,0.9996,0.9994,0.9994,0.9994,0.9994,0.9992,0.9993, +#' 0.9994,0.9993,0.9994,0.9993,0.9992,0.9993,0.9993,0.9993,0.9993,0.9992, +#' 0.9991,0.9992,0.9991,0.9991,0.9992,0.9991,0.999,0.9986,0.9984,0.9984, +#' 0.9983,0.9981,0.998,0.9977,0.9972,0.997,0.9968,0.9964,0.996,0.9958, +#' 0.9955,0.9946,0.994,0.9936,0.9934,0.9926,0.9914,0.9908,0.9901,0.9885, +#' 0.9874,0.9868,0.9857,0.9835,0.9818,0.9801,0.9777,0.9748,0.9712,0.968, +#' 0.9642,0.9599,0.9554,0.9506,0.9432,0.935,0.9293,0.9207,0.9097,0.8971, +#' 0.8852,0.8716,0.854,0.8404,0.8243,0.803,0.7838,0.7586,0.728,0.7077, +#' 0.693,0.6698,0.6468,0.6233,0.5746,0.9977,0.9995,0.9998,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9998,0.9997,0.9996,0.9995,0.9995,0.9994,0.9993,0.9993,0.9993, +#' 0.9992,0.9994,0.9994,0.9993,0.9992,0.9993,0.9993,0.9992,0.9993,0.9994, +#' 0.9994,0.9993,0.9994,0.9994,0.9992,0.999,0.9989,0.9989,0.9987,0.9988, +#' 0.9988,0.9984,0.9981,0.9978,0.9976,0.9974,0.9972,0.997,0.9966,0.9961, +#' 0.9957,0.9953,0.9949,0.9946,0.9938,0.993,0.9925,0.9918,0.9909,0.9895, +#' 0.9883,0.9876,0.9864,0.9857,0.9839,0.9812,0.9796,0.9779,0.9757,0.973, +#' 0.9686,0.9652,0.961,0.954,0.949,0.9435,0.9366,0.9294,0.9196,0.9108, +#' 0.9006,0.887,0.8732,0.8575,0.8421,0.8245,0.8028,0.7852,0.7671,0.741, +#' 0.7179,0.6987,0.6757,0.6526,0.6298,0.55,0.9981,0.9995,0.9998,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9998,0.9998,0.9997,0.9996,0.9995,0.9995,0.9994,0.9993,0.9993, +#' 0.9993,0.9993,0.9994,0.9993,0.9993,0.9993,0.9994,0.9992,0.9993,0.9994, +#' 0.9993,0.9993,0.9993,0.9993,0.9993,0.9992,0.9991,0.9991,0.9991,0.9989, +#' 0.9986,0.9985,0.9985,0.9982,0.9979,0.9976,0.9974,0.9972,0.9972,0.9969, +#' 0.9964,0.9959,0.9952,0.9952,0.9947,0.9934,0.9931,0.9928,0.9922,0.9915, +#' 0.9904,0.989,0.9876,0.9867,0.9852,0.9834,0.9819,0.9804,0.9788,0.9763, +#' 0.9734,0.9707,0.9659,0.9608,0.9562,0.9509,0.9461,0.9416,0.9336,0.9209, +#' 0.9098,0.9,0.8881,0.8748,0.8621,0.8474,0.8282,0.8065,0.7817,0.763, +#' 0.7445,0.7198,0.6988,0.6753,0.6519,0.6284,0.5699,0.9975,0.9995,0.9998, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9997,0.9996,0.9995,0.9993, +#' 0.9993,0.9993,0.9993,0.9992,0.9992,0.9993,0.9993,0.9994,0.9994,0.9994, +#' 0.9993,0.9993,0.9993,0.9994,0.9994,0.9992,0.9991,0.999,0.999,0.9991, +#' 0.999,0.9988,0.9986,0.9985,0.9983,0.9981,0.9978,0.9977,0.9976,0.9972, +#' 0.9967,0.9962,0.9958,0.9954,0.9952,0.995,0.9944,0.9936,0.9927,0.992, +#' 0.9915,0.9907,0.9897,0.9881,0.987,0.9865,0.9849,0.9826,0.9814,0.9796, +#' 0.976,0.9724,0.9698,0.9668,0.9622,0.9571,0.9525,0.9464,0.9377,0.93, +#' 0.9225,0.9122,0.9007,0.8877,0.8723,0.8573,0.8414,0.8204,0.8008,0.7855, +#' 0.7631,0.7423,0.7212,0.6924,0.6687,0.6449,0.6221,0.5931,0.9976,0.9995, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9998,0.9998,0.9999,0.9999,0.9998,0.9997,0.9995,0.9994,0.9994, +#' 0.9994,0.9994,0.9993,0.9993,0.9993,0.9992,0.9992,0.9992,0.9992,0.9992, +#' 0.9992,0.9993,0.9994,0.9994,0.9992,0.999,0.9991,0.9992,0.9992,0.999, +#' 0.999,0.999,0.9988,0.9986,0.9984,0.9983,0.9983,0.998,0.9975,0.9974, +#' 0.9974,0.9967,0.9962,0.9961,0.996,0.9956,0.995,0.9945,0.9937,0.9925, +#' 0.9919,0.9913,0.9904,0.9897,0.9885,0.9873,0.9861,0.9846,0.9831,0.9812, +#' 0.9794,0.9775,0.9742,0.9706,0.9669,0.9635,0.9607,0.9554,0.9482,0.9416, +#' 0.9347,0.9267,0.9148,0.9034,0.894,0.8806,0.8662,0.8452,0.8279,0.8102, +#' 0.7831,0.7623,0.7356,0.7147,0.6972,0.6729,0.649,0.6247,0.5506,0.9978, +#' 0.9995,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9997,0.9996,0.9994, +#' 0.9993,0.9994,0.9993,0.9993,0.9993,0.9993,0.9994,0.9993,0.9993,0.9992, +#' 0.9992,0.9992,0.9991,0.9991,0.9992,0.9993,0.9992,0.9993,0.9993,0.9992, +#' 0.9991,0.9989,0.9988,0.9987,0.9987,0.9986,0.9984,0.998,0.9978,0.9976, +#' 0.9972,0.9973,0.9972,0.9969,0.9965,0.996,0.9954,0.995,0.9946,0.9939, +#' 0.9929,0.9921,0.9914,0.9909,0.9904,0.9891,0.9874,0.9861,0.9848,0.9831, +#' 0.9815,0.9801,0.9787,0.9751,0.9712,0.9683,0.9641,0.9599,0.9562,0.9503, +#' 0.9433,0.9355,0.9263,0.9181,0.9065,0.8934,0.8813,0.8702,0.8525,0.8296, +#' 0.8156,0.7995,0.7766,0.7577,0.7371,0.7097,0.6864,0.6629,0.6394,0.5187, +#' 0.9976,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9995, +#' 0.9994,0.9994,0.9994,0.9994,0.9993,0.9991,0.9991,0.9992,0.9992,0.9993, +#' 0.9993,0.9994,0.9994,0.9992,0.9992,0.9992,0.9991,0.9991,0.9992,0.9993, +#' 0.9991,0.999,0.9989,0.9989,0.9989,0.9988,0.9988,0.9985,0.9982,0.9981, +#' 0.9978,0.9977,0.9973,0.9967,0.9964,0.9961,0.9958,0.9954,0.9948,0.9944, +#' 0.9939,0.9934,0.9928,0.9917,0.9908,0.9898,0.9885,0.9875,0.9868,0.9856, +#' 0.984,0.9813,0.9792,0.9781,0.9749,0.9713,0.9693,0.9664,0.9605,0.9552, +#' 0.949,0.9427,0.9372,0.9288,0.9191,0.9054,0.8918,0.8799,0.8657,0.8477, +#' 0.8314,0.814,0.7884,0.767,0.7501,0.7284,0.7013,0.6772,0.6533,0.6287, +#' 0.6158,0.9978,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997, +#' 0.9996,0.9996,0.9995,0.9995,0.9994,0.9995,0.9993,0.9992,0.9993,0.9993, +#' 0.9994,0.9993,0.9992,0.9991,0.9992,0.9992,0.9992,0.9992,0.9992,0.9992, +#' 0.999,0.9991,0.9991,0.9988,0.9988,0.9988,0.9988,0.9986,0.9984,0.9983, +#' 0.9979,0.9978,0.9977,0.9976,0.9974,0.9967,0.9962,0.9959,0.9958,0.9955, +#' 0.9949,0.9941,0.993,0.992,0.9918,0.991,0.99,0.9888,0.9874,0.9866, +#' 0.9855,0.9839,0.9821,0.9802,0.9775,0.9757,0.9738,0.9693,0.9656,0.9612, +#' 0.9563,0.9508,0.9438,0.9375,0.9309,0.9202,0.9081,0.8966,0.8827,0.8714, +#' 0.8598,0.8396,0.8147,0.7931,0.772,0.7499,0.7294,0.7059,0.6818,0.6574, +#' 0.6333,0.554,0.9979,0.9996,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9999,0.9998, +#' 0.9996,0.9995,0.9995,0.9995,0.9994,0.9993,0.9993,0.9992,0.9993,0.9993, +#' 0.9991,0.9992,0.9992,0.9993,0.9993,0.9992,0.9993,0.9994,0.9991,0.9991, +#' 0.9992,0.9991,0.9989,0.9989,0.999,0.9989,0.9988,0.9987,0.9986,0.9986, +#' 0.9985,0.9981,0.998,0.9979,0.9974,0.9972,0.997,0.9965,0.9961,0.9956, +#' 0.9955,0.9953,0.9946,0.994,0.9932,0.9917,0.9903,0.9901,0.9895,0.9883, +#' 0.9877,0.9857,0.9834,0.9828,0.9815,0.979,0.9768,0.9747,0.9716,0.9667, +#' 0.9611,0.9571,0.9539,0.9471,0.9387,0.9296,0.9189,0.9088,0.8982,0.8842, +#' 0.8669,0.847,0.8249,0.8068,0.7907,0.7732,0.7507,0.7199,0.6941,0.6689, +#' 0.6435,0.6187,0.6097,0.9981,0.9996,0.9998,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9999, +#' 0.9997,0.9996,0.9996,0.9996,0.9994,0.9993,0.9994,0.9993,0.9993,0.9994, +#' 0.9993,0.9992,0.9993,0.9993,0.9994,0.9994,0.9993,0.9992,0.9991,0.9992, +#' 0.9992,0.9992,0.9992,0.999,0.999,0.999,0.999,0.9988,0.9988,0.9987, +#' 0.9985,0.9985,0.9983,0.9979,0.9978,0.9975,0.997,0.9969,0.9968,0.9964, +#' 0.996,0.9956,0.9949,0.9941,0.9935,0.9928,0.9921,0.9912,0.99,0.9888, +#' 0.9877,0.9867,0.9856,0.9839,0.9826,0.9807,0.9793,0.9773,0.9739,0.9704, +#' 0.9663,0.9632,0.9589,0.953,0.9456,0.9376,0.9295,0.9208,0.9115,0.8987, +#' 0.8831,0.8685,0.8532,0.8322,0.8139,0.7997,0.7768,0.7487,0.7253,0.7054, +#' 0.681,0.6567,0.6329,0.5357,0.9981,0.9996,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9998,0.9998,0.9997,0.9996,0.9994,0.9993,0.9994,0.9995,0.9994,0.9992, +#' 0.9993,0.9995,0.9994,0.9993,0.9994,0.9993,0.9992,0.9994,0.9994,0.9992, +#' 0.9993,0.9992,0.9992,0.9992,0.9991,0.999,0.999,0.9989,0.9989,0.9988, +#' 0.9986,0.9987,0.9987,0.9985,0.9983,0.9981,0.9979,0.9975,0.9972,0.9968, +#' 0.9963,0.9959,0.9957,0.9954,0.9946,0.994,0.9931,0.9922,0.992,0.991, +#' 0.9892,0.9884,0.9875,0.9861,0.985,0.9838,0.9816,0.9795,0.9777,0.9746, +#' 0.9714,0.969,0.9657,0.9604,0.9547,0.9496,0.9425,0.9344,0.9265,0.916, +#' 0.9026,0.8901,0.8778,0.8623,0.842,0.8239,0.8066,0.7807,0.7581,0.7383, +#' 0.715,0.6906,0.6663,0.6416,0.5295) +#' +#' # Vector of survival rates for females +#' sr_f <- c(0.9966,0.9993,0.9998,0.9999,0.9999,0.9999,0.9999,0.9998, +#' 0.9999,0.9999,0.9999,0.9998,0.9998,0.9998,0.9998,0.9998,0.9998,0.9997, +#' 0.9996,0.9995,0.9994,0.9993,0.9993,0.9994,0.9994,0.9993,0.9993,0.9994, +#' 0.9993,0.9992,0.9993,0.9993,0.9993,0.9993,0.9992,0.9991,0.999,0.9989, +#' 0.9989,0.9987,0.9986,0.9985,0.9983,0.9981,0.9982,0.998,0.9979,0.9978, +#' 0.9973,0.9969,0.9967,0.9965,0.9963,0.9957,0.9951,0.9945,0.9941,0.9938, +#' 0.9931,0.9922,0.9913,0.9908,0.99,0.9882,0.9866,0.9856,0.9844,0.9823, +#' 0.9796,0.9775,0.9755,0.9718,0.9685,0.9664,0.9631,0.958,0.9541,0.9495, +#' 0.9423,0.9358,0.929,0.9193,0.9094,0.9001,0.8908,0.8804,0.8633,0.849, +#' 0.8363,0.8167,0.7994,0.7831,0.7606,0.74,0.7174,0.6948,0.6811,0.6598, +#' 0.6388,0.6174,0.5734, 0.9965,0.9993,0.9998,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9998,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997, +#' 0.9997,0.9995,0.9993,0.9992,0.9992,0.9992,0.9992,0.9993,0.9993,0.9991, +#' 0.9993,0.9993,0.9993,0.9993,0.9993,0.9992,0.9992,0.9992,0.9991,0.9991, +#' 0.9991,0.9989,0.9989,0.9989,0.9987,0.9987,0.9986,0.9981,0.9979,0.9979, +#' 0.9977,0.9971,0.9968,0.997,0.9966,0.996,0.9959,0.9954,0.995,0.9946, +#' 0.9941,0.9934,0.9925,0.9918,0.9907,0.9896,0.9891,0.9875,0.9857,0.9845, +#' 0.983,0.9812,0.9785,0.9757,0.9736,0.9701,0.9668,0.9641,0.9599,0.9556, +#' 0.95,0.9447,0.9384,0.9315,0.925,0.9143,0.9031,0.8924,0.8799,0.8653, +#' 0.8488,0.8359,0.8257,0.8106,0.7911,0.7647,0.7396,0.7218,0.6989,0.6796, +#' 0.6577,0.6363,0.6142,0.57,0.9966,0.9993,0.9998,0.9998,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998, +#' 0.9997,0.9997,0.9996,0.9995,0.9992,0.9991,0.9991,0.9992,0.9993,0.9993, +#' 0.9993,0.9993,0.9993,0.9994,0.9994,0.9993,0.9993,0.9992,0.9991,0.9992, +#' 0.9991,0.999,0.9989,0.9987,0.9986,0.9986,0.9985,0.9984,0.9982,0.9981, +#' 0.9978,0.9973,0.9971,0.9971,0.9969,0.9967,0.9965,0.9958,0.9953,0.9951, +#' 0.9945,0.9937,0.9929,0.9926,0.9923,0.9906,0.99,0.9892,0.9874,0.9864, +#' 0.9848,0.983,0.981,0.979,0.9775,0.9747,0.9715,0.969,0.9653,0.9612, +#' 0.9565,0.9513,0.9466,0.9398,0.932,0.924,0.9177,0.9076,0.8949,0.8828, +#' 0.8699,0.8589,0.8413,0.8234,0.8063,0.782,0.7602,0.7399,0.7241,0.7089, +#' 0.679,0.6563,0.6344,0.6134,0.5669,0.9969,0.9993,0.9996,0.9997,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9998,0.9997,0.9997,0.9996,0.9994,0.9993,0.9993,0.9992,0.999,0.9992, +#' 0.9993,0.9993,0.9993,0.9994,0.9995,0.9994,0.9992,0.9992,0.9993,0.9993, +#' 0.9993,0.9992,0.9991,0.9991,0.9989,0.9987,0.9987,0.9985,0.9984,0.9983, +#' 0.9981,0.998,0.9978,0.9976,0.9976,0.9971,0.9966,0.9962,0.996,0.9956, +#' 0.995,0.9947,0.9943,0.9931,0.9923,0.9916,0.991,0.9906,0.9893,0.9879, +#' 0.987,0.9851,0.9833,0.9817,0.9789,0.9767,0.9754,0.9719,0.9679,0.9651, +#' 0.9612,0.9577,0.9521,0.9454,0.94,0.9328,0.9256,0.9161,0.9066,0.8969, +#' 0.8831,0.87,0.8527,0.8364,0.8206,0.8016,0.7879,0.7665,0.7305,0.7086, +#' 0.7018,0.6734,0.6506,0.628,0.6056,0.5611,0.9969,0.9993,0.9997,0.9997, +#' 0.9998,0.9999,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9998,0.9997,0.9996,0.9994,0.9993,0.9993,0.9993,0.9993, +#' 0.9993,0.9992,0.9994,0.9995,0.9994,0.9994,0.9994,0.9995,0.9995,0.9994, +#' 0.9992,0.9991,0.9992,0.9992,0.999,0.9989,0.9988,0.9987,0.9986,0.9985, +#' 0.9981,0.9981,0.998,0.9976,0.9974,0.9972,0.9969,0.9968,0.9966,0.9962, +#' 0.9955,0.995,0.9945,0.994,0.9938,0.9933,0.9924,0.9914,0.9902,0.9893, +#' 0.9885,0.9866,0.9846,0.9837,0.9819,0.9799,0.9778,0.9739,0.9718,0.9695, +#' 0.9655,0.9622,0.958,0.9527,0.9476,0.9424,0.9355,0.9248,0.9156,0.9069, +#' 0.8979,0.8869,0.8705,0.8563,0.8412,0.8249,0.8104,0.7927,0.7748,0.7577, +#' 0.7306,0.7084,0.6884,0.6664,0.6454,0.6234,0.5784,0.9972,0.9994,0.9998, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9998,0.9998,0.9997,0.9997,0.9995,0.9994,0.9992,0.9991,0.9992, +#' 0.9993,0.9992,0.9992,0.9993,0.9994,0.9993,0.9993,0.9994,0.9994,0.9993, +#' 0.9994,0.9993,0.9992,0.9993,0.9991,0.9991,0.9991,0.9989,0.9989,0.9989, +#' 0.9986,0.9983,0.9981,0.998,0.9979,0.9977,0.9972,0.9966,0.9965,0.9965, +#' 0.9963,0.9957,0.9953,0.9947,0.994,0.9936,0.9932,0.9925,0.9917,0.991, +#' 0.9903,0.9886,0.9869,0.9858,0.9843,0.9825,0.9805,0.9785,0.9756,0.9725, +#' 0.9705,0.9681,0.9653,0.9608,0.9554,0.9514,0.946,0.9386,0.9299,0.9223, +#' 0.9144,0.9018,0.8894,0.8776,0.8645,0.8453,0.8273,0.8171,0.8011,0.7761, +#' 0.749,0.7403,0.7271,0.6924,0.6703,0.6479,0.6255,0.5791,0.9979,0.9994, +#' 0.9997,0.9998,0.9998,0.9999,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9998,0.9998,0.9998,0.9997,0.9996,0.9995,0.9994,0.9993, +#' 0.9993,0.9993,0.9994,0.9993,0.9992,0.9993,0.9993,0.9992,0.9993,0.9994, +#' 0.9993,0.9994,0.9994,0.9992,0.9992,0.9993,0.9993,0.999,0.9989,0.9989, +#' 0.9986,0.9985,0.9984,0.9983,0.9981,0.9979,0.9978,0.9974,0.9972,0.9972, +#' 0.9967,0.9958,0.9954,0.9953,0.9946,0.9943,0.9941,0.9933,0.9922,0.9917, +#' 0.9908,0.9897,0.989,0.9875,0.9851,0.9841,0.983,0.981,0.9792,0.9772, +#' 0.9748,0.9708,0.967,0.9638,0.96,0.9559,0.9513,0.9442,0.9363,0.9294, +#' 0.9214,0.9121,0.9011,0.8887,0.8762,0.8614,0.8452,0.8306,0.8111,0.7966, +#' 0.7811,0.7447,0.7124,0.6993,0.6873,0.665,0.6426,0.6206,0.5745,0.9974, +#' 0.9994,0.9998,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998, +#' 0.9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9996,0.9996,0.9995,0.9994, +#' 0.9994,0.9993,0.9992,0.9993,0.9994,0.9994,0.9994,0.9995,0.9994,0.9993, +#' 0.9995,0.9995,0.9993,0.9993,0.9994,0.9992,0.9991,0.9991,0.999,0.999, +#' 0.9989,0.9986,0.9986,0.9986,0.9984,0.9982,0.9979,0.9979,0.9978,0.9974, +#' 0.9969,0.9965,0.9959,0.9954,0.9953,0.9949,0.9943,0.994,0.9935,0.9926, +#' 0.9918,0.991,0.9902,0.9891,0.9872,0.9852,0.985,0.9844,0.9824,0.9797, +#' 0.9771,0.975,0.9725,0.9691,0.9658,0.9617,0.9568,0.9522,0.9466,0.9394, +#' 0.9306,0.9237,0.916,0.9036,0.8915,0.8787,0.8654,0.8498,0.8306,0.8147, +#' 0.7989,0.7774,0.7561,0.7387,0.7168,0.6941,0.672,0.6496,0.6273,0.5804, +#' 0.9977,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9996,0.9993, +#' 0.9992,0.9993,0.9993,0.9994,0.9993,0.9992,0.9992,0.9992,0.9993,0.9993, +#' 0.9993,0.9994,0.9994,0.9994,0.9993,0.9993,0.9993,0.9992,0.9992,0.9991, +#' 0.9989,0.9989,0.9988,0.9986,0.9985,0.9983,0.998,0.998,0.9979,0.9976, +#' 0.9971,0.9967,0.9963,0.9962,0.9961,0.9957,0.9952,0.9947,0.994,0.9933, +#' 0.993,0.9922,0.991,0.99,0.9888,0.9874,0.9866,0.9854,0.9839,0.9827, +#' 0.9807,0.9788,0.9765,0.9734,0.9711,0.9675,0.9634,0.9591,0.9524,0.9475, +#' 0.9414,0.9329,0.9248,0.916,0.9056,0.8949,0.8821,0.8679,0.8541,0.8379, +#' 0.8184,0.7978,0.7775,0.7522,0.7237,0.7016,0.6906,0.6677,0.6448,0.6226, +#' 0.5743,0.9979,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9996, +#' 0.9995,0.9994,0.9993,0.9993,0.9993,0.9992,0.9993,0.9993,0.9993,0.9992, +#' 0.9993,0.9992,0.9992,0.9992,0.9993,0.9993,0.9993,0.9992,0.9992,0.9992, +#' 0.9992,0.9991,0.999,0.9988,0.9986,0.9985,0.9984,0.9982,0.9982,0.9981, +#' 0.9977,0.9973,0.9968,0.9967,0.9963,0.9957,0.9958,0.9955,0.9947,0.9939, +#' 0.9935,0.993,0.9923,0.9914,0.9903,0.9891,0.9879,0.9872,0.9862,0.9843, +#' 0.982,0.9807,0.9791,0.9766,0.9743,0.9704,0.9665,0.9646,0.9606,0.954, +#' 0.9489,0.9427,0.9326,0.9246,0.9172,0.9075,0.8967,0.8833,0.8673,0.8531, +#' 0.8359,0.817,0.8054,0.784,0.7543,0.7308,0.7135,0.6957,0.6731,0.6503, +#' 0.6278,0.58,0.9978,0.9994,0.9997,0.9997,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9998,0.9997, +#' 0.9997,0.9996,0.9994,0.9994,0.9994,0.9994,0.9992,0.9993,0.9994,0.9993, +#' 0.9994,0.9993,0.9992,0.9993,0.9993,0.9993,0.9993,0.9992,0.9991,0.9992, +#' 0.9991,0.9991,0.9992,0.9991,0.999,0.9986,0.9984,0.9984,0.9983,0.9981, +#' 0.998,0.9977,0.9972,0.997,0.9968,0.9964,0.996,0.9958,0.9955,0.9946, +#' 0.994,0.9936,0.9934,0.9926,0.9914,0.9908,0.9901,0.9885,0.9874,0.9868, +#' 0.9857,0.9835,0.9818,0.9801,0.9777,0.9748,0.9712,0.968,0.9642,0.9599, +#' 0.9554,0.9506,0.9432,0.935,0.9293,0.9207,0.9097,0.8971,0.8852,0.8716, +#' 0.854,0.8404,0.8243,0.803,0.7838,0.7586,0.728,0.7077,0.693,0.6698, +#' 0.6468,0.6233,0.575,0.9977,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998, +#' 0.9997,0.9996,0.9995,0.9995,0.9994,0.9993,0.9993,0.9993,0.9992,0.9994, +#' 0.9994,0.9993,0.9992,0.9993,0.9993,0.9992,0.9993,0.9994,0.9994,0.9993, +#' 0.9994,0.9994,0.9992,0.999,0.9989,0.9989,0.9987,0.9988,0.9988,0.9984, +#' 0.9981,0.9978,0.9976,0.9974,0.9972,0.997,0.9966,0.9961,0.9957,0.9953, +#' 0.9949,0.9946,0.9938,0.993,0.9925,0.9918,0.9909,0.9895,0.9883,0.9876, +#' 0.9864,0.9857,0.9839,0.9812,0.9796,0.9779,0.9757,0.973,0.9686,0.9652, +#' 0.961,0.954,0.949,0.9435,0.9366,0.9294,0.9196,0.9108,0.9006,0.887, +#' 0.8732,0.8575,0.8421,0.8245,0.8028,0.7852,0.7671,0.741,0.7179,0.6987, +#' 0.6757,0.6526,0.6298,0.5808,0.9981,0.9995,0.9998,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998, +#' 0.9998,0.9997,0.9996,0.9995,0.9995,0.9994,0.9993,0.9993,0.9993,0.9993, +#' 0.9994,0.9993,0.9993,0.9993,0.9994,0.9992,0.9993,0.9994,0.9993,0.9993, +#' 0.9993,0.9993,0.9993,0.9992,0.9991,0.9991,0.9991,0.9989,0.9986,0.9985, +#' 0.9985,0.9982,0.9979,0.9976,0.9974,0.9972,0.9972,0.9969,0.9964,0.9959, +#' 0.9952,0.9952,0.9947,0.9934,0.9931,0.9928,0.9922,0.9915,0.9904,0.989, +#' 0.9876,0.9867,0.9852,0.9834,0.9819,0.9804,0.9788,0.9763,0.9734,0.9707, +#' 0.9659,0.9608,0.9562,0.9509,0.9461,0.9416,0.9336,0.9209,0.9098,0.9, +#' 0.8881,0.8748,0.8621,0.8474,0.8282,0.8065,0.7817,0.763,0.7445,0.7198, +#' 0.6988,0.6753,0.6519,0.6284,0.5786,0.9975,0.9995,0.9998,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9998,0.9998,0.9997,0.9997,0.9997,0.9996,0.9995,0.9993,0.9993,0.9993, +#' 0.9993,0.9992,0.9992,0.9993,0.9993,0.9994,0.9994,0.9994,0.9993,0.9993, +#' 0.9993,0.9994,0.9994,0.9992,0.9991,0.999,0.999,0.9991,0.999,0.9988, +#' 0.9986,0.9985,0.9983,0.9981,0.9978,0.9977,0.9976,0.9972,0.9967,0.9962, +#' 0.9958,0.9954,0.9952,0.995,0.9944,0.9936,0.9927,0.992,0.9915,0.9907, +#' 0.9897,0.9881,0.987,0.9865,0.9849,0.9826,0.9814,0.9796,0.976,0.9724, +#' 0.9698,0.9668,0.9622,0.9571,0.9525,0.9464,0.9377,0.93,0.9225,0.9122, +#' 0.9007,0.8877,0.8723,0.8573,0.8414,0.8204,0.8008,0.7855,0.7631,0.7423, +#' 0.7212,0.6924,0.6687,0.6449,0.6221,0.5723,0.9976,0.9995,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998, +#' 0.9998,0.9999,0.9999,0.9998,0.9997,0.9995,0.9994,0.9994,0.9994,0.9994, +#' 0.9993,0.9993,0.9993,0.9992,0.9992,0.9992,0.9992,0.9992,0.9992,0.9993, +#' 0.9994,0.9994,0.9992,0.999,0.9991,0.9992,0.9992,0.999,0.999,0.999, +#' 0.9988,0.9986,0.9984,0.9983,0.9983,0.998,0.9975,0.9974,0.9974,0.9967, +#' 0.9962,0.9961,0.996,0.9956,0.995,0.9945,0.9937,0.9925,0.9919,0.9913, +#' 0.9904,0.9897,0.9885,0.9873,0.9861,0.9846,0.9831,0.9812,0.9794,0.9775, +#' 0.9742,0.9706,0.9669,0.9635,0.9607,0.9554,0.9482,0.9416,0.9347,0.9267, +#' 0.9148,0.9034,0.894,0.8806,0.8662,0.8452,0.8279,0.8102,0.7831,0.7623, +#' 0.7356,0.7147,0.6972,0.6729,0.649,0.6247,0.5746,0.9978,0.9995,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9998,0.9997,0.9997,0.9996,0.9994,0.9993,0.9994, +#' 0.9993,0.9993,0.9993,0.9993,0.9994,0.9993,0.9993,0.9992,0.9992,0.9992, +#' 0.9991,0.9991,0.9992,0.9993,0.9992,0.9993,0.9993,0.9992,0.9991,0.9989, +#' 0.9988,0.9987,0.9987,0.9986,0.9984,0.998,0.9978,0.9976,0.9972,0.9973, +#' 0.9972,0.9969,0.9965,0.996,0.9954,0.995,0.9946,0.9939,0.9929,0.9921, +#' 0.9914,0.9909,0.9904,0.9891,0.9874,0.9861,0.9848,0.9831,0.9815,0.9801, +#' 0.9787,0.9751,0.9712,0.9683,0.9641,0.9599,0.9562,0.9503,0.9433,0.9355, +#' 0.9263,0.9181,0.9065,0.8934,0.8813,0.8702,0.8525,0.8296,0.8156,0.7995, +#' 0.7766,0.7577,0.7371,0.7097,0.6864,0.6629,0.6394,0.5885,0.9976,0.9995, +#' 0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9995,0.9994,0.9994, +#' 0.9994,0.9994,0.9993,0.9991,0.9991,0.9992,0.9992,0.9993,0.9993,0.9994, +#' 0.9994,0.9992,0.9992,0.9992,0.9991,0.9991,0.9992,0.9993,0.9991,0.999, +#' 0.9989,0.9989,0.9989,0.9988,0.9988,0.9985,0.9982,0.9981,0.9978,0.9977, +#' 0.9973,0.9967,0.9964,0.9961,0.9958,0.9954,0.9948,0.9944,0.9939,0.9934, +#' 0.9928,0.9917,0.9908,0.9898,0.9885,0.9875,0.9868,0.9856,0.984,0.9813, +#' 0.9792,0.9781,0.9749,0.9713,0.9693,0.9664,0.9605,0.9552,0.949,0.9427, +#' 0.9372,0.9288,0.9191,0.9054,0.8918,0.8799,0.8657,0.8477,0.8314,0.814, +#' 0.7884,0.767,0.7501,0.7284,0.7013,0.6772,0.6533,0.6287,0.5782,0.9978, +#' 0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9996,0.9996, +#' 0.9995,0.9995,0.9994,0.9995,0.9993,0.9992,0.9993,0.9993,0.9994,0.9993, +#' 0.9992,0.9991,0.9992,0.9992,0.9992,0.9992,0.9992,0.9992,0.999,0.9991, +#' 0.9991,0.9988,0.9988,0.9988,0.9988,0.9986,0.9984,0.9983,0.9979,0.9978, +#' 0.9977,0.9976,0.9974,0.9967,0.9962,0.9959,0.9958,0.9955,0.9949,0.9941, +#' 0.993,0.992,0.9918,0.991,0.99,0.9888,0.9874,0.9866,0.9855,0.9839,0.9821, +#' 0.9802,0.9775,0.9757,0.9738,0.9693,0.9656,0.9612,0.9563,0.9508,0.9438, +#' 0.9375,0.9309,0.9202,0.9081,0.8966,0.8827,0.8714,0.8598,0.8396,0.8147, +#' 0.7931,0.772,0.7499,0.7294,0.7059,0.6818,0.6574,0.6333,0.5815,0.9979, +#' 0.9996,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9998,0.9999,0.9998,0.9996,0.9995,0.9995, +#' 0.9995,0.9994,0.9993,0.9993,0.9992,0.9993,0.9993,0.9991,0.9992,0.9992, +#' 0.9993,0.9993,0.9992,0.9993,0.9994,0.9991,0.9991,0.9992,0.9991,0.9989, +#' 0.9989,0.999,0.9989,0.9988,0.9987,0.9986,0.9986,0.9985,0.9981,0.998, +#' 0.9979,0.9974,0.9972,0.997,0.9965,0.9961,0.9956,0.9955,0.9953,0.9946, +#' 0.994,0.9932,0.9917,0.9903,0.9901,0.9895,0.9883,0.9877,0.9857,0.9834, +#' 0.9828,0.9815,0.979,0.9768,0.9747,0.9716,0.9667,0.9611,0.9571,0.9539, +#' 0.9471,0.9387,0.9296,0.9189,0.9088,0.8982,0.8842,0.8669,0.847,0.8249, +#' 0.8068,0.7907,0.7732,0.7507,0.7199,0.6941,0.6689,0.6435,0.6187,0.5669, +#' 0.9981,0.9996,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9999,0.9997,0.9996,0.9996, +#' 0.9996,0.9994,0.9993,0.9994,0.9993,0.9993,0.9994,0.9993,0.9992,0.9993, +#' 0.9993,0.9994,0.9994,0.9993,0.9992,0.9991,0.9992,0.9992,0.9992,0.9992, +#' 0.999,0.999,0.999,0.999,0.9988,0.9988,0.9987,0.9985,0.9985,0.9983, +#' 0.9979,0.9978,0.9975,0.997,0.9969,0.9968,0.9964,0.996,0.9956,0.9949, +#' 0.9941,0.9935,0.9928,0.9921,0.9912,0.99,0.9888,0.9877,0.9867,0.9856, +#' 0.9839,0.9826,0.9807,0.9793,0.9773,0.9739,0.9704,0.9663,0.9632,0.9589, +#' 0.953,0.9456,0.9376,0.9295,0.9208,0.9115,0.8987,0.8831,0.8685,0.8532, +#' 0.8322,0.8139,0.7997,0.7768,0.7487,0.7253,0.7054,0.681,0.6567,0.6329, +#' 0.5804,0.9981,0.9996,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999, +#' 0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997, +#' 0.9996,0.9994,0.9993,0.9994,0.9995,0.9994,0.9992,0.9993,0.9995,0.9994, +#' 0.9993,0.9994,0.9993,0.9992,0.9994,0.9994,0.9992,0.9993,0.9992,0.9992, +#' 0.9992,0.9991,0.999,0.999,0.9989,0.9989,0.9988,0.9986,0.9987,0.9987, +#' 0.9985,0.9983,0.9981,0.9979,0.9975,0.9972,0.9968,0.9963,0.9959,0.9957, +#' 0.9954,0.9946,0.994,0.9931,0.9922,0.992,0.991,0.9892,0.9884,0.9875, +#' 0.9861,0.985,0.9838,0.9816,0.9795,0.9777,0.9746,0.9714,0.969,0.9657, +#' 0.9604,0.9547,0.9496,0.9425,0.9344,0.9265,0.916,0.9026,0.8901,0.8778, +#' 0.8623,0.842,0.8239,0.8066,0.7807,0.7581,0.7383,0.715,0.6906,0.6663, +#' 0.6416,0.5881) +#' +#' +#' all_years <- c("1999", "2000", "2001", "2002", "2003", "2004", +#' "2005", "2006", "2007", "2008", "2009", "2010", +#' "2011", "2012", "2013", "2014", "2015", "2016", +#' "2017", "2018", "2019") +#' +#' # Population for males as matrix +#' pop_m_mat <- matrix(pop_m, nrow = 101, ncol = 21) +#' colnames(pop_m_mat) <- all_years +#' +#' # Population for females as matrix +#' pop_f_mat <- matrix(pop_f, nrow = 101, ncol = 21) +#' colnames(pop_f_mat) <- all_years +#' +#' # Age-specific-fertility-rate for as matrix +#' asfr_mat <- matrix(asfr, nrow = 7, ncol = 20) +#' colnames(asfr_mat) <- all_years[-length(all_years)] +#' +#' # Sex ratio at birth as vector +#' srb_vec <- c(1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, +#' 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, +#' 1.06) +#' +#' +#' names(srb_vec) <- all_years[-length(all_years)] +#' +#' # Survival ratio for males as matrix +#' sr_m_mat <- matrix(sr_m, nrow = 21, ncol = 20) +#' colnames(sr_m_mat) <- all_years[-length(all_years)] +#' +#' # Survival ratio for females as matrix +#' sr_f_mat <- matrix(sr_f, nrow = 21, ncol = 20) +#' colnames(sr_f_mat) <- all_years[-length(all_years)] +#' +#' # Age/year sequence of all the data from above +#' interval <- 1 +#' ages <- seq(0, 100, by = interval) +#' years <- seq(1999, 2019, by = interval) +#' ages_asfr <- seq(15, 50, by = interval) +#' +#' mig_res <- +#' mig_resid_stock( +#' pop_m_mat = pop_m_mat, +#' pop_f_mat = pop_f_mat, +#' sr_m_mat = sr_m_mat, +#' sr_f_mat = sr_f_mat, +#' asfr_mat = asfr_mat, +#' srb_vec = srb_vec, +#' ages = ages, +#' ages_asfr = ages_asfr +#' ) +#' +#' # Net migration for males using stock change method +#' mig_res$mig_m +#' +#' # Net migration for females using stock change method +#' mig_res$mig_f +#' +#' +#' ################ cohort even flow method ##################### +#' +#' # We reuse the same data from before +#' +#' mig_res <- +#' mig_resid_cohort( +#' pop_m_mat = pop_m_mat, +#' pop_f_mat = pop_f_mat, +#' sr_m_mat = sr_m_mat, +#' sr_f_mat = sr_f_mat, +#' asfr_mat = asfr_mat, +#' srb_vec = srb_vec, +#' ages = ages, +#' ages_asfr = ages_asfr +#' ) +#' +#' # Net migration for males using the cohort even flow method +#' mig_res$mig_m +#' +#' # Net migration for females using the cohort even flow method +#' mig_res$mig_f +#' +#' ################ time even flow method ##################### +#' +#' # We reuse the same data from before +#' +#' mig_res <- +#' mig_resid_time( +#' pop_m_mat = pop_m_mat, +#' pop_f_mat = pop_f_mat, +#' sr_m_mat = sr_m_mat, +#' sr_f_mat = sr_f_mat, +#' asfr_mat = asfr_mat, +# ##' srb_vec = srb_vec, +# ##' ages = ages, +# ##' ages_asfr = ages_asfr +# ##' ) +# ##' +# ##' # Net migration for males using the time even flow method +# ##' mig_res$mig_m +# ##' +# ##' # Net migration for females using the time even flow method +# ##' mig_res$mig_f +# ##' +# ##' @export +# #mig_resid_stock <- function(pop_m_mat, +# # pop_f_mat, +# # sr_m_mat, +# # sr_f_mat, +# # asfr_mat, +# # srb_vec, +# # ages, +# # ages_asfr) { +# # +# # stopifnot( +# # is.matrix(pop_m_mat), +# # is.matrix(pop_f_mat), +# # is.matrix(sr_m_mat), +# # is.matrix(sr_f_mat), +# # is.matrix(asfr_mat), +# # is.numeric(srb_vec), +# # is.numeric(ages), +# # is.numeric(ages_asfr) +# # ) +# # +# # # Migration net of only survivors +# # net_mig_m <- migresid_net_surv(pop_m_mat, sr_m_mat) +# # net_mig_f <- migresid_net_surv(pop_f_mat, sr_f_mat) +# # +# # fertility_index <- which(ages %in% ages_asfr) +# # +# # # Returns all births for all years +# # age_interval <- unique(diff(ages)) +# # all_births <- migresid_births( +# # pop_f_mat, +# # asfr_mat, +# # fertility_index, +# # age_interval +# # ) +# # +# # # With all_births already calculated, separate between +# # # female/male births with the sex ratio at birth +# # births_m <- all_births[2:length(all_births)] * (srb_vec / (1 + srb_vec)) +# # births_f <- all_births[2:length(all_births)] * (1 / (1 + srb_vec)) +# # +# # net_mig_m <- migresid_net_surv_first_ageg( +# # net_mig_m, +# # pop_m_mat, +# # births_m, +# # sr_m_mat +# # ) +# # +# # net_mig_f <- migresid_net_surv_first_ageg( +# # net_mig_f, +# # pop_f_mat, +# # births_f, +# # sr_f_mat +# # ) +# # +# # # First year is empty, so we exclude +# # list( +# # mig_m = net_mig_m[, -1], +# # mig_f = net_mig_f[, -1] +# # ) +# #} +# # +# ##' @rdname mig_resid_stock +# ##' @export +# #mig_resid_cohort <- function(pop_m_mat, +# # pop_f_mat, +# # sr_m_mat, +# # sr_f_mat, +# # asfr_mat, +# # srb_vec, +# # ages, +# # ages_asfr) { +# # +# # # Estimate stock method +# # mig_res <- +# # mig_resid_stock( +# # pop_m_mat = pop_m_mat, +# # pop_f_mat = pop_f_mat, +# # sr_m_mat = sr_m_mat, +# # sr_f_mat = sr_f_mat, +# # asfr_mat = asfr_mat, +# # srb_vec = srb_vec, +# # ages = ages, +# # ages_asfr = ages_asfr +# # ) +# # +# # net_mig_m <- mig_res$mig_m +# # net_mig_f <- mig_res$mig_f +# # +# # # Estimate bounds for males +# # mig_m_bounds <- migresid_bounds(net_mig_m, sr_m_mat) +# # mig_upper_m <- mig_m_bounds$upper +# # mig_lower_m <- mig_m_bounds$lower +# # +# # # Estimate bounds for females +# # mig_f_bounds <- migresid_bounds(net_mig_f, sr_f_mat) +# # mig_upper_f <- mig_f_bounds$upper +# # mig_lower_f <- mig_f_bounds$lower +# # +# # # Adjust last age group in the bounds +# # mig_bounds <- migresid_bounds_last_ageg( +# # net_mig_m, +# # net_mig_f, +# # mig_upper_m, +# # mig_lower_m, +# # mig_upper_f, +# # mig_lower_f +# # ) +# # +# # mig_upper_m <- mig_bounds$mig_upper_m +# # mig_lower_m <- mig_bounds$mig_lower_m +# # mig_upper_f <- mig_bounds$mig_upper_f +# # mig_lower_f <- mig_bounds$mig_lower_f +# # +# # # Combine both upper/lower bound into a single rectangle +# # mig_rectangle_m <- mig_upper_m + mig_lower_m +# # mig_rectangle_f <- mig_upper_f + mig_lower_f +# # +# # list( +# # mig_m = mig_rectangle_m[, -1], +# # mig_f = mig_rectangle_f[, -1] +# # ) +# #} +# # +# ##' @rdname mig_resid_stock +# ##' @export +# #mig_resid_time <- function(pop_m_mat, +# # pop_f_mat, +# # sr_m_mat, +# # sr_f_mat, +# # asfr_mat, +# # srb_vec, +# # ages, +# # ages_asfr) { +# # +# # # Estimate stock method +# # mig_res <- +# # mig_resid_stock( +# # pop_m_mat = pop_m_mat, +# # pop_f_mat = pop_f_mat, +# # sr_m_mat = sr_m_mat, +# # sr_f_mat = sr_f_mat, +# # asfr_mat = asfr_mat, +# # srb_vec = srb_vec, +# # ages = ages, +# # ages_asfr = ages_asfr +# # ) +# # +# # # Separate male/female net migration +# # net_mig_m <- mig_res$mig_m +# # net_mig_f <- mig_res$mig_f +# # +# # # Adjust age group 0-4 +# # net_mig_m[1, ] <- 2 * net_mig_m[1, ] +# # net_mig_f[1, ] <- 2 * net_mig_f[1, ] +# # +# # # Adjust age groups 5-10 to 100+ (of whatever maximum age groups) +# # for (i in 2:nrow(net_mig_m)) { +# # double_pop_m <- (2 * net_mig_m[i, ]) +# # double_pop_f <- (2 * net_mig_f[i, ]) +# # +# # # Multiply net mig of i - 1 by survival rate of i +# # # to get number of survived +# # mig_sr_m <- net_mig_m[i - 1, ] * sr_m_mat[i, ] +# # mig_sr_f <- net_mig_f[i - 1, ] * sr_f_mat[i, ] +# # +# # net_mig_m[i, ] <- double_pop_m - mig_sr_m +# # net_mig_f[i, ] <- double_pop_f - mig_sr_f +# # } +# # +# # list( +# # mig_m = net_mig_m, +# # mig_f = net_mig_f +# # ) +# #} +# # +# # +# ## Net migration is pop minus the people that survived from the previous +# ## age/cohort +# #migresid_net_surv <- function(pop_mat, sr_mat) { +# # n <- nrow(pop_mat) +# # p <- ncol(pop_mat) +# # survived <- pop_mat[-n, -p] * sr_mat[-1, ] +# # res <- pop_mat[-1, -1] - survived +# # res[nrow(res), ] <- NA +# # res <- rbind(matrix(NA, nrow = 1, ncol = ncol(res)), res) +# # res <- cbind(matrix(NA, nrow = nrow(res), ncol = 1), res) +# # res <- migresid_net_surv_last_ageg(res, pop_mat, sr_mat) +# # res +# #} +# # +# ## Net migration for last age group is pop for that age group in +# ## year j, minus the people from the previous age group the survived +# #migresid_net_surv_last_ageg <- function(net_mig, pop_mat, sr_mat) { +# # n <- nrow(pop_mat) +# # p <- ncol(pop_mat) +# # previous_year <- 1:(p - 1) +# # survived <- +# # (pop_mat[n, previous_year] + pop_mat[n - 1, previous_year]) * +# # sr_mat[n, previous_year] +# # +# # net_mig[nrow(net_mig), 2:ncol(net_mig)] <- pop_mat[n, 2:p] - survived +# # net_mig +# #} +# # +# #migresid_births <- function(pop_f_mat, +# # asfr_mat, +# # fertility_index, +# # age_interval) { +# # p <- ncol(pop_f_mat) +# # +# # # Sum female pop from previous year and this year +# # f_pop <- pop_f_mat[fertility_index, -1] + pop_f_mat[fertility_index, -p] +# # +# # # Births that occurred for all age groups for all years +# # # based on the age-specific fertility rate (asfr) from +# # # previous years to the population +# # these_births <- age_interval * (0.5 * (f_pop) * asfr_mat[, -p]) / 1000 +# # +# # all_births <- c(NA, colSums(these_births)) +# # col_names <- attr(pop_f_mat, "dimnames")[[2]] +# # all_births <- stats::setNames(all_births, col_names) +# # all_births +# #} +# # +# #migresid_net_surv_first_ageg <- function(net_mig, pop_mat, births, sr_mat) { +# # p <- ncol(net_mig) +# # net_mig[1, 2:p] <- pop_mat[1, 2:p] - births * sr_mat[1, ] +# # net_mig +# #} +# # +# # +# ## Returns age/year matrices with upper/lower bounds +# ## for net migration based on the net migration and +# ## survival rates. These, I believe are the upper/lower +# ## bounds of a lexis surfave (which is why we do ^0.5). +# #migresid_bounds <- function(net_mig, sr_mat) { +# # n <- nrow(net_mig) +# # p <- ncol(net_mig) +# # +# # # Upper bound is net mig / 2 times the survival ratio ^ 0.5 +# # mig_upper <- net_mig / (2 * sr_mat^0.5) +# # mig_upper <- cbind(matrix(NA, ncol = 1, nrow = n), mig_upper) +# # mig_lower <- mig_upper +# # mig_upper[1, ] <- NA +# # mig_upper[n, ] <- NA +# # mig_lower[n, ] <- NA +# # mig_lower <- mig_lower[-1, ] +# # empty_matrix <- matrix(NA, ncol = ncol(mig_lower), nrow = 1) +# # mig_lower <- rbind(mig_lower, empty_matrix) +# # +# # # Estimate upper bounds for the first age group. Why +# # # no lower bound for the first age group? because we have +# # # no previous age group. +# # p_upper <- ncol(mig_upper) +# # mig_upper[1, 2:p_upper] <- net_mig[1, -p_upper] / (sr_mat[1, -p_upper]^0.5) +# # +# # list(upper = mig_upper, lower = mig_lower) +# #} +# # +# ## Updates last age group for all upper/lower bounds +# #migresid_bounds_last_ageg <- function(net_mig_m, +# # net_mig_f, +# # mig_upper_m, +# # mig_lower_m, +# # mig_upper_f, +# # mig_lower_f) { +# # +# # +# # # last age group +# # n <- nrow(mig_upper_m) +# # p <- ncol(mig_upper_m) +# # +# # mig_lower_m[n - 1, ] <- mig_upper_m[n - 1, ] +# # mig_lower_f[n - 1, ] <- mig_upper_f[n - 1, ] +# # mig_upper_m[n, 2:p] <- net_mig_m[n, -p] * 0.5 +# # mig_upper_f[n, 2:p] <- net_mig_f[n, -p] * 0.5 +# # mig_lower_m[n, 2:p] <- net_mig_m[n, -p] * 0.5 +# # mig_lower_f[n, 2:p] <- net_mig_f[n, -p] * 0.5 +# # +# # list( +# # mig_lower_m = mig_lower_m, +# # mig_upper_m = mig_upper_m, +# # mig_lower_f = mig_lower_f, +# # mig_upper_f = mig_upper_f +# # ) +# #} +# # \ No newline at end of file diff --git a/dev/mig_resid_singleTest.R b/dev/mig_resid_singleTest.R new file mode 100644 index 000000000..755178a01 --- /dev/null +++ b/dev/mig_resid_singleTest.R @@ -0,0 +1,573 @@ +# # #' Estimate net migration using residual methods: stock change, +# # #' time even flow and cohort even flow +# # #' +# # #' @details +# # #' +# # #' 1. The stock method (\code{mig_resid_stock}) is the difference in stocks that +# # #' survive between t and t+5, and the first age group is based on the difference +# # #' with the surviving births by sex. It provides net migrants by lexis cohort +# # #' parallelograms, and basically such info gets used as end-period migration +# # #' since the migrants don't get exposed to mortality within the period. +# # #' +# # #' 2. The time even flow (\code{mig_resid_time}) method uses the result from +# # #' the first option, but splits it back into lexis period squares and assumes +# # #' that half of the net migrants get exposed to the mortality risk during this +# # #' period. Such info can get used as evenly distributed migration by period, +# # #' but the assumptions lead to zig-zag age patterns that are highly implausible. +# # #' +# # #' 3. The cohort even flow (\code{mig_resid_cohort}) method provides the most +# # #' meaningful pattern of net migration by age consistent by cohort and assumes +# # #' an evenly distribution within the 5-year period, and half of the migrants +# # #' get exposed both fertility and mortality within this period. +# # #' +# # #' @param pop_m_mat A \code{numeric} matrix with population counts. Rows should +# # #' be ages and columns should be years. Only five year age groups are supported. +# # #' See examples. +# # #' +# # #' @param pop_f_mat A \code{numeric} matrix with population counts. Rows should +# # #' be ages and columns should be years. Only five year age groups are supported. +# # #' See examples. +# # #' +# # #' @param sr_m_mat A \code{numeric} matrix with survival rates for males. Rows +# # #' should be ages and columns should be years. ** This matrix should have +# # #' one column less than \code{pop_m_mat} and \code{pop_f_mat}. For example, +# # #' if the last year in these matrices is 2050, then the last year in +# # #' \code{sr_m_mat} should be 2045. ** +# # #' +# # #' @param sr_f_mat A \code{numeric} matrix with survival rates for females. Rows +# # #' should be ages and columns should be years. ** This matrix should have +# # #' one column less than \code{pop_m_mat} and \code{pop_f_mat}. For example, +# # #' if the last year in these matrices is 2050, then the last year in +# # #' \code{sr_f_mat} should be 2045. **. +# # #' +# # #' @param asfr_mat A \code{numeric} matrix with age specific fertility rates. +# # #' Rows should be ages and columns should be years. ** This matrix should have +# # #' one column less than \code{pop_m_mat} and \code{pop_f_mat}. For example, +# # #' if the last year in these matrices is 2050, then the last year in +# # #' \code{asfr_mat} should be 2045**. This row will usually have fewer age groups +# # #' (rows) than in the population matrices or survival matrices, so the user +# # #' needs to supply the specific ages in the \code{ages_asfr} argument. +# # #' +# # #' @param srb_vec A \code{numeric} vector of sex ratios at birth for every year. +# # #' The years should be the same as the years in \code{sr_m_mat}, +# # #' \code{sr_f_mat}, and \code{asfr_mat}. +# # #' +# # #' @param ages A \code{numeric} vector of ages used in the rows in +# # #' \code{pop_m_mat}, \code{pop_f_mat}, \code{sr_m_mat}, \code{sr_f_mat}. +# # #' +# # #' @param ages_asfr A \code{numeric} vector of ages used in the rows in +# # #' \code{asfr_mat}. +# # #' +# # #' @return A list with two matrices. One is for males (called `mig_m`) and the +# # #' other for females (called `mig_f`). Both matrices contain net migration +# # #' estimates by age/period using one of the three methods. +# # #' +# # #' @examples +# # #' +# # #' ################ Stock change method ##################### +# # #' +# # #' # Vector of population for males +# # #' pop_m <- +# # #' c(38,45,51,55,59,61,62,62,62,61,60,59,58,56,54,52,51,51,51,51,51,52,54,55,57,59,61,62,63,64,65# # ,65,65,65,65,65,64,63,62,61,60,60,59,59,59,58,59,60,62,64,66,67,67,65,63,61,59,56,53,49,46,43,41,40# # ,39,38,37,36,35,35,34,34,34,33,33,33,32,30,28,25,23,20,18,16,15,13,11,9,8,6,5,4,3,2,1,1,1,1,0,0,0, +# # #' 36,43,49,53,57,59,61,62,62,62,62,61,59,58,56,54,53,51,51,51,51,52,52,54,55,57,59,61,62,63,64# # ,65,65,65,65,65,65,64,63,62,61,60,59,59,59,59,58,58,60,62,64,66,67,66,64,63,61,59,56,52,49,45,42,41# # ,39,38,37,36,35,35,34,34,33,33,32,32,31,30,28,26,24,21,19,17,15,13,11,9,8,6,5,3,3,2,1,1,1,0,0,0,0, +# # #' 38,38,44,49,53,56,59,61,62,63,62,62,61,60,58,56,55,53,52,51,52,52,52,53,54,56,58,60,61,62,63# # ,64,65,66,66,65,65,65,64,63,62,61,60,59,59,59,58,58,58,60,62,64,66,67,66,64,62,61,58,55,52,49,45,42# # ,40,39,38,36,35,34,34,33,33,32,32,31,30,30,29,27,24,22,19,17,15,13,11,10,8,7,5,4,3,2,2,1,1,0,0,0,0, +# # #' 43,45,40,44,48,52,55,58,61,63,63,63,62,61,60,58,57,55,53,52,52,52,52,53,53,55,56,58,60,61,63# # ,64,64,65,66,66,65,65,65,64,63,62,61,60,59,59,59,58,58,58,60,62,64,65,66,66,64,62,60,58,55,51,48,44# # ,41,39,38,37,36,34,34,33,32,32,31,30,30,29,28,27,25,22,20,17,15,13,12,10,8,7,6,4,3,2,2,1,1,0,0,0,0, +# # #' 50,48,47,41,45,48,52,55,58,61,63,64,63,62,61,60,58,57,55,53,52,52,52,53,53,54,55,57,59,60,62# # ,63,64,65,65,66,66,65,65,65,64,63,62,61,60,59,59,58,58,58,58,59,61,63,65,66,65,63,62,60,57,54,51,47# # ,44,41,39,37,36,35,34,33,32,31,30,30,29,28,27,26,25,23,21,18,16,13,11,10,8,7,6,4,3,2,2,1,1,1,0,0,0, +# # #' 56,51,47,46,43,45,48,51,54,58,61,64,64,63,62,61,60,59,57,55,54,52,52,53,53,54,55,56,57,59,61# # ,62,63,64,65,66,66,66,66,65,65,64,63,62,61,60,59,59,58,58,58,58,59,61,63,65,66,65,63,61,59,57,54,50# # ,47,43,40,38,37,35,34,33,32,31,30,29,29,28,27,26,25,23,21,19,16,14,12,10,8,7,5,4,3,2,2,1,1,1,0,0,0, +# # #' 60,53,49,46,45,45,46,48,51,54,57,62,64,65,64,63,62,61,59,57,56,54,53,53,53,54,54,55,56,58,59# # ,61,62,64,64,65,66,66,66,66,65,65,64,63,62,61,60,59,59,58,58,58,58,59,61,63,65,65,65,63,61,59,57,53# # ,50,46,43,40,38,36,35,33,32,31,30,29,28,27,26,25,24,23,22,19,17,15,12,10,8,7,5,4,3,2,1,1,1,1,0,0,0, +# # #' 62,59,53,49,47,45,45,46,48,51,54,58,62,65,65,64,63,62,61,60,58,57,55,54,54,54,54,55,56,57,58# # ,60,61,63,64,65,65,66,67,66,66,65,65,64,63,62,61,60,59,58,58,58,57,57,59,61,62,64,65,64,62,60,58,56# # ,53,49,46,42,39,37,35,34,32,31,30,29,28,27,26,25,24,22,21,20,18,15,13,11,9,7,6,4,3,3,2,1,1,1,0,0,0, +# # #' 61,56,58,53,50,48,46,46,46,48,51,55,59,63,66,66,65,64,63,62,60,59,58,56,55,55,55,55,56,56,57# # ,59,60,62,63,64,65,66,67,67,67,66,65,65,64,63,62,61,60,59,58,58,57,57,57,58,60,62,64,65,64,62,60,57# # ,55,52,48,45,41,38,36,35,33,31,30,29,28,27,26,25,23,22,21,19,18,16,14,11,9,7,6,5,4,3,2,2,1,1,0,0,0, +# # #' 60,57,54,57,53,51,49,48,47,47,48,51,55,59,64,67,67,66,65,64,62,61,60,59,57,56,56,56,56,56,57# # ,58,60,61,62,64,65,66,66,67,68,67,67,66,65,64,63,62,61,60,59,58,58,57,57,57,58,60,62,64,64,63,61,59# # ,57,54,51,48,44,41,37,35,34,32,31,29,28,27,25,24,23,22,20,19,18,16,14,12,10,8,6,5,4,3,2,2,1,1,0,0,0# # , +# # #' 59,57,56,55,56,53,51,50,49,48,47,48,51,55,60,65,68,68,67,66,64,63,62,61,60,58,57,57,57,57,57# # ,58,59,60,61,63,64,65,66,67,68,68,68,67,66,65,64,63,62,61,60,59,58,58,57,56,56,58,60,62,63,64,63,61# # ,59,56,54,50,47,44,40,37,34,33,31,30,28,27,25,24,23,22,20,19,17,16,14,12,10,8,6,5,4,3,2,1,1,1,0,0,0# # , +# # #' 57,58,58,57,56,55,53,52,51,50,49,47,48,51,56,60,65,69,69,68,66,65,64,63,62,61,60,59,58,58,58# # ,58,58,59,61,62,63,64,66,67,68,68,69,68,67,66,65,63,62,62,61,60,59,58,58,57,56,56,57,59,61,63,64,63# # ,60,58,56,53,50,46,43,39,36,34,32,30,29,27,26,24,23,22,20,19,17,15,14,12,10,8,6,5,4,3,2,1,1,1,0,0,0# # , +# # #' 57,58,59,58,57,56,55,54,52,51,50,49,48,48,51,57,61,67,70,70,69,67,66,65,64,63,62,60,59,59,59# # ,59,59,59,60,61,62,64,65,66,67,68,69,69,69,67,66,65,63,62,62,61,60,59,58,57,57,56,56,57,59,61,63,63# # ,62,60,57,55,52,49,45,42,38,35,33,31,29,27,26,24,23,21,20,19,17,15,14,12,11,9,7,5,4,3,2,1,1,1,0,0,0# # , +# # #' 56,59,59,59,59,58,57,55,54,53,51,50,49,48,48,52,57,62,68,71,71,70,68,67,65,64,63,62,61,60,60# # ,59,59,59,59,60,62,63,64,65,66,67,68,69,69,69,67,66,65,63,62,62,61,60,59,58,57,56,55,55,56,58,60,62# # ,63,62,59,56,54,51,47,44,41,37,34,31,30,28,26,24,23,21,20,19,17,16,14,12,11,9,8,6,4,3,3,2,1,1,1,0,0# # , +# # #' 56,59,60,60,60,59,58,57,56,54,53,52,51,50,48,49,53,58,63,69,72,73,71,69,68,66,65,64,63,62,61# # ,60,60,60,60,60,61,62,63,64,66,67,68,69,69,70,69,68,66,65,63,62,61,61,60,59,58,57,56,55,54,56,58,60# # ,62,62,61,58,56,53,50,46,43,39,36,33,30,28,27,25,23,21,20,18,17,15,14,12,11,9,8,6,5,3,3,2,1,1,1,0,0# # , +# # #' 57,59,61,62,61,61,60,59,57,56,54,53,52,51,50,49,49,53,59,64,70,73,74,72,70,69,67,66,65,64,63# # ,62,61,61,60,60,60,61,62,63,65,66,67,68,69,70,70,69,68,66,65,63,62,61,60,60,59,58,57,55,54,54,55,57# # ,59,61,62,60,58,55,52,49,45,42,38,35,31,29,27,25,23,22,20,18,17,15,14,12,11,9,8,6,5,4,2,2,1,1,1,0,0# # , +# # #' 57,59,61,62,62,62,61,60,59,57,56,55,53,52,51,50,49,50,54,59,65,71,74,75,73,71,69,68,67,66,64# # ,63,62,61,61,61,60,60,61,62,64,65,66,67,68,69,70,70,69,68,66,64,63,62,61,60,59,58,57,56,55,54,53,55# # ,57,59,61,61,60,57,54,51,47,44,41,37,33,30,28,26,24,22,20,19,17,15,14,12,11,9,7,6,5,4,2,1,1,1,1,0,0# # , +# # #' 58,58,60,61,62,62,62,61,60,59,58,56,55,54,53,52,51,50,51,54,60,66,71,75,75,73,72,70,68,67,66# # ,65,64,63,62,61,61,61,61,62,63,64,65,66,67,68,69,70,70,69,68,66,64,63,62,61,60,59,58,57,56,55,53,53# # ,54,56,58,60,61,59,56,53,50,46,43,39,36,32,29,26,24,23,21,19,17,15,14,12,11,9,8,6,5,4,3,2,1,1,1,0,0# # , +# # #' 60,61,59,60,61,62,62,62,61,60,59,58,57,55,54,53,52,51,50,51,55,61,66,72,76,76,74,72,71,69,68# # ,67,65,64,63,62,62,61,61,61,62,63,64,65,66,67,68,69,70,70,69,68,66,64,63,62,61,60,59,58,57,55,54,53# # ,52,53,56,57,59,60,58,55,52,48,45,42,38,35,31,28,25,23,21,19,17,15,14,12,11,9,8,6,5,4,3,3,2,1,1,0,0# # , +# # #' 61,61,61,59,60,61,61,61,61,61,61,60,58,57,56,55,54,53,52,51,52,56,62,67,73,77,77,75,73,71,69# # ,68,67,66,64,63,62,62,62,61,61,62,63,64,65,66,67,68,69,70,70,69,68,66,64,63,61,60,59,59,58,56,55,54# # ,52,52,53,55,57,58,59,57,54,50,47,44,40,37,33,30,26,24,22,19,18,16,14,12,10,9,8,7,5,4,3,3,2,1,1,0,0# # , +# # #' 62,62,62,61,60,61,61,61,61,61,61,61,60,58,57,56,55,54,53,53,52,53,57,62,68,74,77,77,75,74,72# # ,70,68,67,66,65,64,63,62,62,61,61,62,63,64,65,66,67,68,69,70,70,69,67,66,64,62,61,60,59,58,57,56,55# # ,53,52,51,52,54,56,57,58,56,53,49,46,43,39,36,32,28,25,22,20,18,16,14,12,11,9,8,7,5,4,3,2,2,1,1,0,0# # ) +# # #' # Vector of population for females +# # #' pop_f <- +# # #' c(36,43,48,53,56,58,59,59,59,58,57,56,55,53,51,50,48,48,49,49,49,50,52,53,55,57,59,60,60,61,62# # ,62,62,62,62,61,61,60,59,59,58,57,57,57,57,57,57,59,61,63,65,66,65,63,61,59,57,55,52,49,46,44,42,42# # ,41,40,40,40,40,40,40,40,41,41,41,42,41,40,38,36,33,31,29,27,25,23,21,19,16,14,11,10,8,6,4,3,3,2,1# # ,1,1, +# # #' 34,41,46,50,54,56,58,59,59,59,58,57,56,55,53,51,50,48,48,49,49,50,50,52,54,55,57,59,60,61,61# # ,62,62,62,62,62,61,61,60,59,59,58,57,57,57,57,56,57,59,61,63,65,66,65,63,61,59,57,54,51,49,46,43,42# # ,41,41,40,40,40,39,40,40,40,40,40,41,41,40,39,36,34,32,29,27,25,23,21,19,17,14,11,9,8,6,4,3,2,2,1,1# # ,1, +# # #' 36,36,41,46,50,53,56,58,59,60,59,59,58,56,55,53,52,50,49,49,49,50,50,51,52,54,56,58,59,60,61# # ,62,62,63,63,62,62,62,61,60,60,59,58,57,57,57,57,57,57,59,61,63,65,66,65,63,61,59,57,54,51,48,45,43# # ,42,41,40,40,39,39,39,39,39,39,39,39,39,39,39,37,35,32,30,27,25,23,21,19,17,15,12,10,8,7,5,3,2,2,1# # ,1,1, +# # #' 41,43,38,42,46,50,53,56,58,60,60,60,59,58,57,55,54,52,50,49,49,50,50,51,52,53,55,56,58,60,61# # ,61,62,63,63,63,63,62,62,61,60,60,59,58,57,57,57,57,56,57,58,61,63,65,65,65,63,61,59,56,54,51,48,45# # ,43,41,41,40,39,39,38,38,38,38,38,38,38,38,38,37,35,33,30,28,25,23,21,19,17,15,13,10,8,7,6,4,3,2,1# # ,1,1, +# # #' 47,45,44,39,42,46,49,52,55,58,60,60,60,59,58,57,55,54,52,51,50,50,50,51,51,52,53,55,57,58,60# # ,61,61,62,63,63,63,63,62,62,61,60,60,59,58,57,57,57,57,56,57,58,60,62,64,65,64,62,60,58,56,53,51,48# # ,45,42,41,40,39,39,38,38,38,37,37,37,37,37,37,37,36,34,31,29,26,23,21,19,17,15,13,11,8,6,5,4,3,2,1# # ,1,1, +# # #' 53,48,45,43,41,43,46,49,52,55,58,61,61,60,59,58,57,56,54,53,51,50,50,51,51,52,53,54,55,57,59# # ,60,61,62,62,63,63,63,63,62,62,61,61,60,59,58,57,57,57,57,56,57,58,60,62,64,65,64,62,60,58,56,53,50# # ,47,44,42,40,40,39,38,38,37,37,37,37,36,36,36,36,35,34,32,29,27,24,21,19,17,14,13,11,9,6,5,4,3,2,1# # ,1,1, +# # #' 57,50,46,43,42,42,44,46,48,51,55,59,61,61,60,59,58,57,56,55,53,52,51,51,51,52,52,53,54,56,58# # ,59,61,61,62,63,63,64,63,63,63,62,61,61,60,59,58,57,57,57,57,56,57,58,60,62,64,65,64,62,60,58,56,53# # ,50,47,44,42,40,39,38,38,37,37,36,36,36,36,35,35,34,34,33,31,28,25,22,19,17,15,12,10,9,7,5,3,3,2,1# # ,1,1, +# # #' 58,56,50,47,44,43,43,44,45,48,51,55,59,62,62,61,60,59,58,57,55,54,52,51,51,52,52,53,54,55,56# # ,58,59,61,62,62,63,64,64,64,63,63,62,61,61,60,59,58,57,57,57,57,56,56,58,60,62,64,65,64,62,59,57,55# # ,52,49,47,44,41,40,39,38,37,36,36,35,35,35,34,34,33,32,32,31,28,25,23,20,17,15,13,10,9,8,6,4,3,2,2# # ,1,1, +# # #' 58,53,55,50,47,45,44,44,44,45,48,52,56,60,63,63,62,61,60,59,57,56,55,53,52,52,53,53,53,54,55# # ,57,58,60,61,62,63,64,64,64,64,64,63,62,61,60,60,59,58,58,57,57,56,56,56,58,60,62,64,65,64,61,59,57# # ,54,52,49,46,43,41,39,38,37,36,36,35,35,34,34,33,32,32,31,30,28,26,23,20,17,15,13,11,9,7,6,5,3,2,2# # ,1,1, +# # #' 57,54,51,54,51,48,46,45,45,44,45,48,52,56,60,63,64,63,62,61,60,58,57,56,54,53,53,54,54,54,55# # ,56,57,59,60,62,63,63,64,65,65,65,64,63,62,61,60,60,59,58,58,57,57,56,56,56,57,60,62,64,64,63,61,59# # ,56,54,51,48,46,43,40,39,38,37,36,35,34,34,33,33,32,31,30,29,28,26,24,21,18,15,13,11,9,7,6,5,4,2,2# # ,1,1, +# # #' 55,54,53,52,53,51,49,47,46,45,44,45,48,52,57,61,64,65,63,63,62,60,59,58,57,55,54,54,54,55,55# # ,55,57,58,59,61,62,63,64,65,65,66,65,64,63,62,61,61,60,59,58,58,57,57,56,56,56,57,60,62,64,64,63,61# # ,58,56,53,51,48,45,42,40,38,37,36,35,34,33,33,32,31,31,30,28,27,26,24,22,19,16,13,11,9,7,5,4,4,3,2# # ,1,1, +# # #' 54,55,55,54,53,52,51,49,48,47,46,45,45,48,53,57,62,65,65,64,63,62,61,60,59,58,56,55,55,55,55# # ,55,56,57,58,60,61,63,64,64,65,66,66,66,65,64,62,61,60,60,59,59,58,57,57,56,55,56,57,59,61,63,64,63# # ,61,58,56,53,50,47,45,42,39,38,37,35,34,34,33,32,31,30,29,28,27,25,24,22,20,17,14,11,9,7,5,4,3,2,2# # ,1,1, +# # #' 53,55,55,55,54,53,52,51,50,48,47,46,45,45,49,53,58,63,66,67,65,64,63,62,61,60,59,57,56,56,56# # ,56,56,56,58,59,60,62,63,64,65,66,66,67,66,65,64,62,61,60,60,59,59,58,57,57,56,55,55,57,59,61,63,64# # ,63,60,58,55,52,49,47,44,41,38,37,36,34,33,32,31,31,30,29,28,26,25,23,22,20,18,15,12,9,8,6,4,3,3,2# # ,1,1, +# # #' 53,55,56,56,55,55,54,52,51,50,49,48,46,45,46,49,54,59,64,67,68,67,65,64,63,62,61,59,58,57,57# # ,57,57,57,57,58,59,61,62,63,64,65,66,67,67,66,65,64,62,61,60,60,59,59,58,57,57,56,55,55,56,59,61,63# # ,64,63,60,57,54,51,49,46,43,40,37,36,35,34,32,31,30,29,28,27,26,24,23,21,20,18,15,12,10,8,7,5,3,3,2# # ,1,1, +# # #' 54,56,57,57,57,56,55,54,53,51,50,49,48,47,45,46,49,55,60,65,69,69,68,66,65,64,62,61,60,59,58# # ,57,57,57,57,57,58,60,61,63,64,65,66,66,67,67,66,65,64,62,61,60,60,59,59,58,57,56,55,54,54,56,58,61# # ,63,64,62,59,56,53,50,48,45,42,39,37,35,34,33,31,30,29,28,27,25,24,22,21,19,17,16,13,10,8,6,5,4,3,2# # ,1,1, +# # #' 54,56,58,58,58,57,56,55,54,53,52,50,49,48,47,45,46,50,55,61,66,70,70,69,67,66,64,63,62,61,60# # ,58,58,58,58,57,58,59,60,61,63,64,65,66,67,67,67,67,65,64,62,61,60,60,59,59,58,57,56,55,54,54,55,58# # ,60,63,63,62,59,56,53,50,47,44,41,38,36,34,33,31,30,29,28,26,25,24,22,21,19,17,15,13,11,8,6,5,4,3,2# # ,1,2, +# # #' 55,57,58,58,59,58,58,57,56,54,53,52,51,49,48,47,45,46,50,56,61,67,71,71,70,68,67,65,64,63,62# # ,60,59,59,58,58,58,58,59,60,62,63,64,65,66,67,68,68,67,65,64,62,61,60,60,59,59,58,57,56,55,54,53,55# # ,58,60,62,63,61,58,55,52,49,46,43,40,37,35,33,32,30,29,28,26,25,23,22,21,19,17,14,13,11,9,6,4,3,3,2# # ,1,2, +# # #' 55,55,57,58,58,58,58,58,57,56,55,53,52,51,50,49,48,46,47,51,57,62,68,72,72,70,69,67,66,64,63# # ,62,61,60,59,59,58,58,58,59,61,62,63,65,65,66,67,68,68,67,65,64,62,61,60,60,59,58,58,57,56,55,53,53# # ,55,57,59,62,62,61,58,54,51,48,45,42,39,36,34,32,31,29,28,26,25,23,22,20,19,17,15,12,11,10,8,5,4,3# # ,2,1,2, +# # #' 57,58,56,57,58,58,58,58,58,57,56,55,54,53,52,50,49,48,47,48,52,57,63,69,73,73,71,70,68,66,65# # ,64,63,61,60,59,59,59,58,59,60,61,62,63,65,66,66,67,68,68,67,65,64,62,61,60,59,59,58,58,57,56,54,53# # ,53,54,57,59,61,62,60,57,54,50,47,44,41,38,35,33,31,29,28,26,25,23,21,20,18,17,15,12,10,9,8,6,4,3,2# # ,1,2, +# # #' 58,58,58,57,57,58,58,58,58,58,57,56,55,54,53,52,51,50,49,48,49,52,58,64,70,73,74,72,70,68,67# # ,65,64,63,61,60,60,59,59,59,59,60,61,62,64,65,66,66,67,68,68,67,65,64,62,61,60,59,59,58,57,56,55,54# # ,53,53,54,56,58,61,61,59,56,53,50,46,43,40,37,34,32,30,28,26,25,23,21,19,18,16,15,13,10,9,8,7,5,3,2# # ,1,2, +# # #' 59,58,58,58,57,58,58,58,58,58,58,57,56,55,54,53,53,51,51,50,49,49,53,59,65,70,74,74,72,71,69# # ,67,66,65,63,62,61,60,59,59,59,59,60,61,62,64,65,66,66,67,68,68,67,65,64,62,61,60,59,58,58,57,56,55# # ,54,53,52,54,56,58,60,61,59,55,52,49,45,42,40,36,33,31,28,27,25,23,22,20,18,16,14,13,11,8,7,6,5,4,2# # ,1,2) +# # #' +# # #' # Vector of age-specific fertility rates +# # #' asfr <- c(0.000415,0.00209,0.004145,0.010155,0.017665,0.027095,0.038225,0.046765,0.0582,0.07097# # ,0.083335,0.09792,0.10819,0.11661,0.117465,0.11389,0.10584,0.095805,0.081925,0.07266,0.06205,0# # .05031,0.0402,0.029295,0.023435,0.015425,0.010325,0.006225,0.00378,0.001845,0.00083,0.00046,0.00005# # ,0.000085,0.00003, +# # #' 0.00052,0.001915,0.005605,0.009435,0.01871,0.02803,0.03896,0.04524,0.057105,0.070205,0# # .084105,0.1004,0.10972,0.12058,0.121825,0.11956,0.109495,0.099345,0.090625,0.075065,0.064575,0# # .05104,0.0413,0.03231,0.02354,0.01639,0.009985,0.00634,0.004215,0.001875,0.00091,0.00048,0.00014,0# # .00012,0.000065, +# # #' 0.000685,0.00211,0.00459,0.009075,0.0181,0.026515,0.036495,0.04599,0.058185,0.070745,0# # .082965,0.097255,0.10583,0.116975,0.12034,0.121645,0.118705,0.105155,0.0935,0.078975,0.069225,0# # .055105,0.04294,0.032315,0.024895,0.01653,0.012175,0.007115,0.003845,0.002,0.00081,0.000385,0# # .000135,0.0001,0.00007, +# # #' 0.000395,0.002155,0.00538,0.01025,0.01744,0.02757,0.03798,0.047435,0.059845,0.070295,0# # .085905,0.097875,0.113365,0.12143,0.12913,0.13287,0.126885,0.11332,0.098785,0.08711,0.070315,0# # .05895,0.044535,0.034625,0.026315,0.018275,0.012505,0.007335,0.00418,0.002295,0.000985,0.000415,0# # .000175,0.000105,0.000035, +# # #' 0.00056,0.001925,0.00536,0.00899,0.01594,0.02764,0.0387,0.048325,0.05559,0.069995,0# # .085535,0.09787,0.11428,0.126135,0.135655,0.13816,0.132265,0.12517,0.106395,0.09231,0.07695,0.06148# # ,0.05132,0.037605,0.0289,0.019855,0.013335,0.007535,0.00457,0.002155,0.00108,0.00065,0.00012,0# # .000105,0.000035, +# # #' 0.000515,0.00204,0.00449,0.008325,0.01641,0.027835,0.03772,0.046995,0.054845,0.071795# # ,0.08601,0.09841,0.11213,0.129055,0.137675,0.138955,0.136445,0.128615,0.11401,0.09782,0.0793,0# # .06689,0.051755,0.04049,0.030265,0.02152,0.014165,0.00863,0.00531,0.00286,0.0009,0.000485,0.00024,0# # .00005,0.000035, +# # #' 0.00061,0.001715,0.004275,0.00819,0.017095,0.02619,0.03677,0.047475,0.05763,0.069865,0# # .081945,0.09929,0.110015,0.13017,0.13437,0.14298,0.13867,0.13124,0.114545,0.10012,0.0854,0.07069,0# # .05289,0.04139,0.0313,0.021265,0.01365,0.009055,0.005025,0.0026,0.001515,0.000605,0.00019,0.00014,0# # .00005, +# # #' 0.00043,0.001745,0.00483,0.00803,0.017205,0.026975,0.03812,0.0498,0.05848,0.0711,0# # .085385,0.099465,0.116595,0.132605,0.141035,0.145675,0.14637,0.13643,0.1226,0.109555,0.09091,0# # .07415,0.05954,0.044,0.03277,0.023015,0.015135,0.009085,0.00577,0.00288,0.000945,0.000925,0.000365# # ,0.00016,0.000035, +# # #' 0.00058,0.00181,0.00414,0.007795,0.0171,0.02706,0.040175,0.0497,0.06138,0.0754,0.0849# # ,0.101365,0.113765,0.12703,0.14095,0.145175,0.1454,0.13895,0.125435,0.109375,0.0931,0.07791,0# # .060535,0.046815,0.03495,0.02434,0.01647,0.010475,0.006015,0.003015,0.00146,0.000735,0.000505,0# # .000145,0.000085, +# # #' 0.0005,0.00131,0.00409,0.007815,0.016955,0.02869,0.041145,0.05194,0.062625,0.07733,0# # .089215,0.09915,0.114505,0.13087,0.14321,0.1474,0.14718,0.13722,0.125395,0.110985,0.09451,0.078285# # ,0.060645,0.049175,0.036805,0.024725,0.01707,0.01021,0.00565,0.002975,0.001535,0.000875,0.000295,0# # .00017,0.00007, +# # #' 0.00059,0.00142,0.004095,0.007065,0.01605,0.028775,0.038975,0.05168,0.062965,0.07423,0# # .08839,0.102815,0.11722,0.128075,0.140695,0.14827,0.147145,0.139575,0.124925,0.115005,0.10046,0# # .07994,0.065455,0.05039,0.036865,0.02644,0.018245,0.01033,0.006675,0.003285,0.0018,0.00082,0.0003,0# # .000275,0.000155, +# # #' 0.000415,0.001565,0.00368,0.007465,0.015375,0.027185,0.039185,0.05004,0.06393,0.078245# # ,0.091495,0.10549,0.119415,0.132825,0.14508,0.146535,0.152615,0.14506,0.129695,0.116805,0.100135,0# # .08581,0.06692,0.0517,0.04117,0.027675,0.01863,0.01183,0.006305,0.00375,0.00199,0.00091,0.000435,0# # .000115,0.000185, +# # #' 0.00039,0.00167,0.003365,0.00721,0.015025,0.02415,0.03536,0.0473,0.05979,0.07669,0# # .08609,0.099455,0.11409,0.127615,0.135055,0.139255,0.142215,0.13442,0.12758,0.11536,0.095805,0# # .084415,0.06851,0.050215,0.03904,0.028855,0.01871,0.011115,0.00661,0.00322,0.001785,0.000885,0# # .00032,0.00016,0.00017, +# # #' 0.00037,0.00139,0.00349,0.00648,0.013235,0.022885,0.03429,0.04627,0.06062,0.0747,0# # .08875,0.102265,0.113975,0.126025,0.133335,0.14266,0.145635,0.135565,0.125785,0.11608,0.099185,0# # .082475,0.064515,0.053475,0.03974,0.028015,0.01857,0.012445,0.006835,0.003715,0.00195,0.001035,0# # .000495,0.000385,0.000245, +# # #' 0.00055,0.00141,0.003325,0.0063,0.013195,0.02156,0.03351,0.044095,0.057585,0.07177,0# # .08555,0.10087,0.11176,0.12691,0.133945,0.14199,0.14091,0.140015,0.126205,0.11514,0.096115,0.082895# # ,0.06829,0.05249,0.04038,0.0289,0.018745,0.0116,0.006765,0.00338,0.00179,0.000925,0.00052,0.000375# # ,0.00023, +# # #' 0.00046,0.001105,0.00294,0.006765,0.01239,0.019805,0.029245,0.04243,0.056205,0.071675# # ,0.086795,0.104835,0.113775,0.126065,0.136305,0.140305,0.139335,0.134685,0.12758,0.11418,0.0979,0# # .080865,0.066865,0.052935,0.04007,0.030485,0.01916,0.01159,0.0076,0.003765,0.00198,0.00097,0.0007,0# # .000265,0.000115, +# # #' 0.000295,0.00114,0.003045,0.0056,0.0115,0.02006,0.028345,0.042025,0.053665,0.0689,0# # .088195,0.102155,0.11291,0.126765,0.13238,0.139095,0.137405,0.13127,0.119895,0.11279,0.097485,0# # .08156,0.06475,0.05382,0.03895,0.029045,0.018885,0.01236,0.006625,0.003655,0.002055,0.00118,0.00053# # ,0.000275,0.000295, +# # #' 0.0005,0.001235,0.002775,0.005245,0.01218,0.019915,0.029575,0.038195,0.052965,0.06899# # ,0.084725,0.101895,0.11375,0.126235,0.135615,0.13995,0.13603,0.130845,0.119245,0.11024,0.09851,0# # .083725,0.067125,0.053155,0.041975,0.03034,0.020565,0.0128,0.0077,0.00427,0.00218,0.00107,0.000655# # ,0.000375,0.000175, +# # #' 0.00033,0.00123,0.002695,0.00597,0.01165,0.01963,0.03009,0.03768,0.048195,0.063535,0# # .078305,0.09598,0.107535,0.119215,0.129095,0.131615,0.133445,0.128725,0.120115,0.10175,0.09485,0# # .081035,0.06597,0.05288,0.040885,0.030075,0.020595,0.01365,0.0073,0.00487,0.00216,0.001375,0.0006,0# # .000285,0.000465, +# # #' 0.00026,0.00117,0.00229,0.00592,0.011875,0.01965,0.027745,0.039155,0.04793,0.061335,0# # .0765,0.0926,0.10439,0.120235,0.12707,0.13096,0.13116,0.12526,0.116655,0.10556,0.092845,0.07854,0# # .063975,0.05414,0.04103,0.02982,0.0198,0.01193,0.00737,0.003905,0.002225,0.00128,0.000515,0.000455# # ,0.0002) +# # #' +# # #' # Vector of survival rates for males +# # #' sr_m <- c(0.9966,0.9993,0.9998,0.9999,0.9999,0.9999,0.9999,0.9998,0.9999,0.9999,0.9999,0.9998,0# # .9998,0.9998,0.9998,0.9998,0.9998,0.9997,0.9996,0.9995,0.9994,0.9993,0.9993,0.9994,0.9994,0.9993,0# # .9993,0.9994,0.9993,0.9992,0.9993,0.9993,0.9993,0.9993,0.9992,0.9991,0.999,0.9989,0.9989,0.9987,0# # .9986,0.9985,0.9983,0.9981,0.9982,0.998,0.9979,0.9978,0.9973,0.9969,0.9967,0.9965,0.9963,0.9957,0# # .9951,0.9945,0.9941,0.9938,0.9931,0.9922,0.9913,0.9908,0.99,0.9882,0.9866,0.9856,0.9844,0.9823,0# # .9796,0.9775,0.9755,0.9718,0.9685,0.9664,0.9631,0.958,0.9541,0.9495,0.9423,0.9358,0.929,0.9193,0# # .9094,0.9001,0.8908,0.8804,0.8633,0.849,0.8363,0.8167,0.7994,0.7831,0.7606,0.74,0.7174,0.6948,0# # .6811,0.6598,0.6388,0.6174,0.7246, +# # #' 0.9965,0.9993,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9999,0# # .9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9995,0.9993,0.9992,0.9992,0.9992,0.9992,0.9993,0.9993,0# # .9991,0.9993,0.9993,0.9993,0.9993,0.9993,0.9992,0.9992,0.9992,0.9991,0.9991,0.9991,0.9989,0.9989,0# # .9989,0.9987,0.9987,0.9986,0.9981,0.9979,0.9979,0.9977,0.9971,0.9968,0.997,0.9966,0.996,0.9959,0# # .9954,0.995,0.9946,0.9941,0.9934,0.9925,0.9918,0.9907,0.9896,0.9891,0.9875,0.9857,0.9845,0.983,0# # .9812,0.9785,0.9757,0.9736,0.9701,0.9668,0.9641,0.9599,0.9556,0.95,0.9447,0.9384,0.9315,0.925,0# # .9143,0.9031,0.8924,0.8799,0.8653,0.8488,0.8359,0.8257,0.8106,0.7911,0.7647,0.7396,0.7218,0.6989,0# # .6796,0.6577,0.6363,0.6142,0.5535, +# # #' 0.9966,0.9993,0.9998,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9998,0.9997,0.9997,0.9996,0.9995,0.9992,0.9991,0.9991,0.9992,0.9993,0.9993,0# # .9993,0.9993,0.9993,0.9994,0.9994,0.9993,0.9993,0.9992,0.9991,0.9992,0.9991,0.999,0.9989,0.9987,0# # .9986,0.9986,0.9985,0.9984,0.9982,0.9981,0.9978,0.9973,0.9971,0.9971,0.9969,0.9967,0.9965,0.9958,0# # .9953,0.9951,0.9945,0.9937,0.9929,0.9926,0.9923,0.9906,0.99,0.9892,0.9874,0.9864,0.9848,0.983,0.981# # ,0.979,0.9775,0.9747,0.9715,0.969,0.9653,0.9612,0.9565,0.9513,0.9466,0.9398,0.932,0.924,0.9177,0# # .9076,0.8949,0.8828,0.8699,0.8589,0.8413,0.8234,0.8063,0.782,0.7602,0.7399,0.7241,0.7089,0.679,0# # .6563,0.6344,0.6134,0.5604, +# # #' 0.9969,0.9993,0.9996,0.9997,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9998,0.9997,0.9997,0.9996,0.9994,0.9993,0.9993,0.9992,0.999,0.9992,0.9993,0# # .9993,0.9993,0.9994,0.9995,0.9994,0.9992,0.9992,0.9993,0.9993,0.9993,0.9992,0.9991,0.9991,0.9989,0# # .9987,0.9987,0.9985,0.9984,0.9983,0.9981,0.998,0.9978,0.9976,0.9976,0.9971,0.9966,0.9962,0.996,0# # .9956,0.995,0.9947,0.9943,0.9931,0.9923,0.9916,0.991,0.9906,0.9893,0.9879,0.987,0.9851,0.9833,0# # .9817,0.9789,0.9767,0.9754,0.9719,0.9679,0.9651,0.9612,0.9577,0.9521,0.9454,0.94,0.9328,0.9256,0# # .9161,0.9066,0.8969,0.8831,0.87,0.8527,0.8364,0.8206,0.8016,0.7879,0.7665,0.7305,0.7086,0.7018,0# # .6734,0.6506,0.628,0.6056,0.587, +# # #' 0.9969,0.9993,0.9997,0.9997,0.9998,0.9999,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9996,0.9994,0.9993,0.9993,0.9993,0.9993,0.9993,0.9992,0# # .9994,0.9995,0.9994,0.9994,0.9994,0.9995,0.9995,0.9994,0.9992,0.9991,0.9992,0.9992,0.999,0.9989,0# # .9988,0.9987,0.9986,0.9985,0.9981,0.9981,0.998,0.9976,0.9974,0.9972,0.9969,0.9968,0.9966,0.9962,0# # .9955,0.995,0.9945,0.994,0.9938,0.9933,0.9924,0.9914,0.9902,0.9893,0.9885,0.9866,0.9846,0.9837,0# # .9819,0.9799,0.9778,0.9739,0.9718,0.9695,0.9655,0.9622,0.958,0.9527,0.9476,0.9424,0.9355,0.9248,0# # .9156,0.9069,0.8979,0.8869,0.8705,0.8563,0.8412,0.8249,0.8104,0.7927,0.7748,0.7577,0.7306,0.7084,0# # .6884,0.6664,0.6454,0.6234,0.5009, +# # #' 0.9972,0.9994,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9995,0.9994,0.9992,0.9991,0.9992,0.9993,0.9992,0.9992,0# # .9993,0.9994,0.9993,0.9993,0.9994,0.9994,0.9993,0.9994,0.9993,0.9992,0.9993,0.9991,0.9991,0.9991,0# # .9989,0.9989,0.9989,0.9986,0.9983,0.9981,0.998,0.9979,0.9977,0.9972,0.9966,0.9965,0.9965,0.9963,0# # .9957,0.9953,0.9947,0.994,0.9936,0.9932,0.9925,0.9917,0.991,0.9903,0.9886,0.9869,0.9858,0.9843,0# # .9825,0.9805,0.9785,0.9756,0.9725,0.9705,0.9681,0.9653,0.9608,0.9554,0.9514,0.946,0.9386,0.9299,0# # .9223,0.9144,0.9018,0.8894,0.8776,0.8645,0.8453,0.8273,0.8171,0.8011,0.7761,0.749,0.7403,0.7271,0# # .6924,0.6703,0.6479,0.6255,0.5403, +# # #' 0.9979,0.9994,0.9997,0.9998,0.9998,0.9999,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9998,0.9998,0.9998,0.9997,0.9996,0.9995,0.9994,0.9993,0.9993,0.9993,0.9994,0.9993,0# # .9992,0.9993,0.9993,0.9992,0.9993,0.9994,0.9993,0.9994,0.9994,0.9992,0.9992,0.9993,0.9993,0.999,0# # .9989,0.9989,0.9986,0.9985,0.9984,0.9983,0.9981,0.9979,0.9978,0.9974,0.9972,0.9972,0.9967,0.9958,0# # .9954,0.9953,0.9946,0.9943,0.9941,0.9933,0.9922,0.9917,0.9908,0.9897,0.989,0.9875,0.9851,0.9841,0# # .983,0.981,0.9792,0.9772,0.9748,0.9708,0.967,0.9638,0.96,0.9559,0.9513,0.9442,0.9363,0.9294,0.9214# # ,0.9121,0.9011,0.8887,0.8762,0.8614,0.8452,0.8306,0.8111,0.7966,0.7811,0.7447,0.7124,0.6993,0.6873# # ,0.665,0.6426,0.6206,0.6098, +# # #' 0.9974,0.9994,0.9998,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9999,0# # .9999,0.9999,0.9999,0.9998,0.9997,0.9996,0.9996,0.9995,0.9994,0.9994,0.9993,0.9992,0.9993,0.9994,0# # .9994,0.9994,0.9995,0.9994,0.9993,0.9995,0.9995,0.9993,0.9993,0.9994,0.9992,0.9991,0.9991,0.999,0# # .999,0.9989,0.9986,0.9986,0.9986,0.9984,0.9982,0.9979,0.9979,0.9978,0.9974,0.9969,0.9965,0.9959,0# # .9954,0.9953,0.9949,0.9943,0.994,0.9935,0.9926,0.9918,0.991,0.9902,0.9891,0.9872,0.9852,0.985,0# # .9844,0.9824,0.9797,0.9771,0.975,0.9725,0.9691,0.9658,0.9617,0.9568,0.9522,0.9466,0.9394,0.9306,0# # .9237,0.916,0.9036,0.8915,0.8787,0.8654,0.8498,0.8306,0.8147,0.7989,0.7774,0.7561,0.7387,0.7168,0# # .6941,0.672,0.6496,0.6273,0.5327, +# # #' 0.9977,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9996,0.9993,0.9992,0.9993,0.9993,0.9994,0.9993,0.9992,0# # .9992,0.9992,0.9993,0.9993,0.9993,0.9994,0.9994,0.9994,0.9993,0.9993,0.9993,0.9992,0.9992,0.9991,0# # .9989,0.9989,0.9988,0.9986,0.9985,0.9983,0.998,0.998,0.9979,0.9976,0.9971,0.9967,0.9963,0.9962,0# # .9961,0.9957,0.9952,0.9947,0.994,0.9933,0.993,0.9922,0.991,0.99,0.9888,0.9874,0.9866,0.9854,0.9839# # ,0.9827,0.9807,0.9788,0.9765,0.9734,0.9711,0.9675,0.9634,0.9591,0.9524,0.9475,0.9414,0.9329,0.9248# # ,0.916,0.9056,0.8949,0.8821,0.8679,0.8541,0.8379,0.8184,0.7978,0.7775,0.7522,0.7237,0.7016,0.6906,0# # .6677,0.6448,0.6226,0.5853, +# # #' 0.9979,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9996,0.9995,0.9994,0.9993,0.9993,0.9993,0.9992,0.9993,0# # .9993,0.9993,0.9992,0.9993,0.9992,0.9992,0.9992,0.9993,0.9993,0.9993,0.9992,0.9992,0.9992,0.9992,0# # .9991,0.999,0.9988,0.9986,0.9985,0.9984,0.9982,0.9982,0.9981,0.9977,0.9973,0.9968,0.9967,0.9963,0# # .9957,0.9958,0.9955,0.9947,0.9939,0.9935,0.993,0.9923,0.9914,0.9903,0.9891,0.9879,0.9872,0.9862,0# # .9843,0.982,0.9807,0.9791,0.9766,0.9743,0.9704,0.9665,0.9646,0.9606,0.954,0.9489,0.9427,0.9326,0# # .9246,0.9172,0.9075,0.8967,0.8833,0.8673,0.8531,0.8359,0.817,0.8054,0.784,0.7543,0.7308,0.7135,0# # .6957,0.6731,0.6503,0.6278,0.5519, +# # #' 0.9978,0.9994,0.9997,0.9997,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9998,0.9998,0.9998,0.9997,0.9997,0.9996,0.9994,0.9994,0.9994,0.9994,0.9992,0.9993,0# # .9994,0.9993,0.9994,0.9993,0.9992,0.9993,0.9993,0.9993,0.9993,0.9992,0.9991,0.9992,0.9991,0.9991,0# # .9992,0.9991,0.999,0.9986,0.9984,0.9984,0.9983,0.9981,0.998,0.9977,0.9972,0.997,0.9968,0.9964,0.996# # ,0.9958,0.9955,0.9946,0.994,0.9936,0.9934,0.9926,0.9914,0.9908,0.9901,0.9885,0.9874,0.9868,0.9857,0# # .9835,0.9818,0.9801,0.9777,0.9748,0.9712,0.968,0.9642,0.9599,0.9554,0.9506,0.9432,0.935,0.9293,0# # .9207,0.9097,0.8971,0.8852,0.8716,0.854,0.8404,0.8243,0.803,0.7838,0.7586,0.728,0.7077,0.693,0.6698# # ,0.6468,0.6233,0.5746, +# # #' 0.9977,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9996,0.9995,0.9995,0.9994,0.9993,0.9993,0.9993,0.9992,0# # .9994,0.9994,0.9993,0.9992,0.9993,0.9993,0.9992,0.9993,0.9994,0.9994,0.9993,0.9994,0.9994,0.9992,0# # .999,0.9989,0.9989,0.9987,0.9988,0.9988,0.9984,0.9981,0.9978,0.9976,0.9974,0.9972,0.997,0.9966,0# # .9961,0.9957,0.9953,0.9949,0.9946,0.9938,0.993,0.9925,0.9918,0.9909,0.9895,0.9883,0.9876,0.9864,0# # .9857,0.9839,0.9812,0.9796,0.9779,0.9757,0.973,0.9686,0.9652,0.961,0.954,0.949,0.9435,0.9366,0.9294# # ,0.9196,0.9108,0.9006,0.887,0.8732,0.8575,0.8421,0.8245,0.8028,0.7852,0.7671,0.741,0.7179,0.6987,0# # .6757,0.6526,0.6298,0.55, +# # #' 0.9981,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9996,0.9995,0.9995,0.9994,0.9993,0.9993,0.9993,0.9993,0# # .9994,0.9993,0.9993,0.9993,0.9994,0.9992,0.9993,0.9994,0.9993,0.9993,0.9993,0.9993,0.9993,0.9992,0# # .9991,0.9991,0.9991,0.9989,0.9986,0.9985,0.9985,0.9982,0.9979,0.9976,0.9974,0.9972,0.9972,0.9969,0# # .9964,0.9959,0.9952,0.9952,0.9947,0.9934,0.9931,0.9928,0.9922,0.9915,0.9904,0.989,0.9876,0.9867,0# # .9852,0.9834,0.9819,0.9804,0.9788,0.9763,0.9734,0.9707,0.9659,0.9608,0.9562,0.9509,0.9461,0.9416,0# # .9336,0.9209,0.9098,0.9,0.8881,0.8748,0.8621,0.8474,0.8282,0.8065,0.7817,0.763,0.7445,0.7198,0.6988# # ,0.6753,0.6519,0.6284,0.5699, +# # #' 0.9975,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9997,0.9996,0.9995,0.9993,0.9993,0.9993,0.9993,0# # .9992,0.9992,0.9993,0.9993,0.9994,0.9994,0.9994,0.9993,0.9993,0.9993,0.9994,0.9994,0.9992,0.9991,0# # .999,0.999,0.9991,0.999,0.9988,0.9986,0.9985,0.9983,0.9981,0.9978,0.9977,0.9976,0.9972,0.9967,0# # .9962,0.9958,0.9954,0.9952,0.995,0.9944,0.9936,0.9927,0.992,0.9915,0.9907,0.9897,0.9881,0.987,0# # .9865,0.9849,0.9826,0.9814,0.9796,0.976,0.9724,0.9698,0.9668,0.9622,0.9571,0.9525,0.9464,0.9377,0# # .93,0.9225,0.9122,0.9007,0.8877,0.8723,0.8573,0.8414,0.8204,0.8008,0.7855,0.7631,0.7423,0.7212,0# # .6924,0.6687,0.6449,0.6221,0.5931, +# # #' 0.9976,0.9995,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9998,0.9998,0.9999,0.9999,0.9998,0.9997,0.9995,0.9994,0.9994,0.9994,0.9994,0.9993,0.9993,0# # .9993,0.9992,0.9992,0.9992,0.9992,0.9992,0.9992,0.9993,0.9994,0.9994,0.9992,0.999,0.9991,0.9992,0# # .9992,0.999,0.999,0.999,0.9988,0.9986,0.9984,0.9983,0.9983,0.998,0.9975,0.9974,0.9974,0.9967,0.9962# # ,0.9961,0.996,0.9956,0.995,0.9945,0.9937,0.9925,0.9919,0.9913,0.9904,0.9897,0.9885,0.9873,0.9861,0# # .9846,0.9831,0.9812,0.9794,0.9775,0.9742,0.9706,0.9669,0.9635,0.9607,0.9554,0.9482,0.9416,0.9347,0# # .9267,0.9148,0.9034,0.894,0.8806,0.8662,0.8452,0.8279,0.8102,0.7831,0.7623,0.7356,0.7147,0.6972,0# # .6729,0.649,0.6247,0.5506, +# # #' 0.9978,0.9995,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9997,0.9996,0.9994,0.9993,0.9994,0.9993,0.9993,0.9993,0# # .9993,0.9994,0.9993,0.9993,0.9992,0.9992,0.9992,0.9991,0.9991,0.9992,0.9993,0.9992,0.9993,0.9993,0# # .9992,0.9991,0.9989,0.9988,0.9987,0.9987,0.9986,0.9984,0.998,0.9978,0.9976,0.9972,0.9973,0.9972,0# # .9969,0.9965,0.996,0.9954,0.995,0.9946,0.9939,0.9929,0.9921,0.9914,0.9909,0.9904,0.9891,0.9874,0# # .9861,0.9848,0.9831,0.9815,0.9801,0.9787,0.9751,0.9712,0.9683,0.9641,0.9599,0.9562,0.9503,0.9433,0# # .9355,0.9263,0.9181,0.9065,0.8934,0.8813,0.8702,0.8525,0.8296,0.8156,0.7995,0.7766,0.7577,0.7371,0# # .7097,0.6864,0.6629,0.6394,0.5187, +# # #' 0.9976,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9995,0.9994,0.9994,0.9994,0.9994,0.9993,0.9991,0# # .9991,0.9992,0.9992,0.9993,0.9993,0.9994,0.9994,0.9992,0.9992,0.9992,0.9991,0.9991,0.9992,0.9993,0# # .9991,0.999,0.9989,0.9989,0.9989,0.9988,0.9988,0.9985,0.9982,0.9981,0.9978,0.9977,0.9973,0.9967,0# # .9964,0.9961,0.9958,0.9954,0.9948,0.9944,0.9939,0.9934,0.9928,0.9917,0.9908,0.9898,0.9885,0.9875,0# # .9868,0.9856,0.984,0.9813,0.9792,0.9781,0.9749,0.9713,0.9693,0.9664,0.9605,0.9552,0.949,0.9427,0# # .9372,0.9288,0.9191,0.9054,0.8918,0.8799,0.8657,0.8477,0.8314,0.814,0.7884,0.767,0.7501,0.7284,0# # .7013,0.6772,0.6533,0.6287,0.6158, +# # #' 0.9978,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9996,0.9996,0.9995,0.9995,0.9994,0.9995,0.9993,0# # .9992,0.9993,0.9993,0.9994,0.9993,0.9992,0.9991,0.9992,0.9992,0.9992,0.9992,0.9992,0.9992,0.999,0# # .9991,0.9991,0.9988,0.9988,0.9988,0.9988,0.9986,0.9984,0.9983,0.9979,0.9978,0.9977,0.9976,0.9974,0# # .9967,0.9962,0.9959,0.9958,0.9955,0.9949,0.9941,0.993,0.992,0.9918,0.991,0.99,0.9888,0.9874,0.9866# # ,0.9855,0.9839,0.9821,0.9802,0.9775,0.9757,0.9738,0.9693,0.9656,0.9612,0.9563,0.9508,0.9438,0.9375# # ,0.9309,0.9202,0.9081,0.8966,0.8827,0.8714,0.8598,0.8396,0.8147,0.7931,0.772,0.7499,0.7294,0.7059,0# # .6818,0.6574,0.6333,0.554, +# # #' 0.9979,0.9996,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9998,0.9999,0.9998,0.9996,0.9995,0.9995,0.9995,0.9994,0.9993,0.9993,0.9992,0# # .9993,0.9993,0.9991,0.9992,0.9992,0.9993,0.9993,0.9992,0.9993,0.9994,0.9991,0.9991,0.9992,0.9991,0# # .9989,0.9989,0.999,0.9989,0.9988,0.9987,0.9986,0.9986,0.9985,0.9981,0.998,0.9979,0.9974,0.9972,0# # .997,0.9965,0.9961,0.9956,0.9955,0.9953,0.9946,0.994,0.9932,0.9917,0.9903,0.9901,0.9895,0.9883,0# # .9877,0.9857,0.9834,0.9828,0.9815,0.979,0.9768,0.9747,0.9716,0.9667,0.9611,0.9571,0.9539,0.9471,0# # .9387,0.9296,0.9189,0.9088,0.8982,0.8842,0.8669,0.847,0.8249,0.8068,0.7907,0.7732,0.7507,0.7199,0# # .6941,0.6689,0.6435,0.6187,0.6097, +# # #' 0.9981,0.9996,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9998,0.9998,0.9999,0.9997,0.9996,0.9996,0.9996,0.9994,0.9993,0.9994,0.9993,0.9993,0# # .9994,0.9993,0.9992,0.9993,0.9993,0.9994,0.9994,0.9993,0.9992,0.9991,0.9992,0.9992,0.9992,0.9992,0# # .999,0.999,0.999,0.999,0.9988,0.9988,0.9987,0.9985,0.9985,0.9983,0.9979,0.9978,0.9975,0.997,0.9969# # ,0.9968,0.9964,0.996,0.9956,0.9949,0.9941,0.9935,0.9928,0.9921,0.9912,0.99,0.9888,0.9877,0.9867,0# # .9856,0.9839,0.9826,0.9807,0.9793,0.9773,0.9739,0.9704,0.9663,0.9632,0.9589,0.953,0.9456,0.9376,0# # .9295,0.9208,0.9115,0.8987,0.8831,0.8685,0.8532,0.8322,0.8139,0.7997,0.7768,0.7487,0.7253,0.7054,0# # .681,0.6567,0.6329,0.5357) +# # #' +# # #' # Vector of survival rates for females +# # #' sr_f <- c(0.9966,0.9993,0.9998,0.9999,0.9999,0.9999,0.9999,0.9998,0.9999,0.9999,0.9999,0.9998,0# # .9998,0.9998,0.9998,0.9998,0.9998,0.9997,0.9996,0.9995,0.9994,0.9993,0.9993,0.9994,0.9994,0.9993,0# # .9993,0.9994,0.9993,0.9992,0.9993,0.9993,0.9993,0.9993,0.9992,0.9991,0.999,0.9989,0.9989,0.9987,0# # .9986,0.9985,0.9983,0.9981,0.9982,0.998,0.9979,0.9978,0.9973,0.9969,0.9967,0.9965,0.9963,0.9957,0# # .9951,0.9945,0.9941,0.9938,0.9931,0.9922,0.9913,0.9908,0.99,0.9882,0.9866,0.9856,0.9844,0.9823,0# # .9796,0.9775,0.9755,0.9718,0.9685,0.9664,0.9631,0.958,0.9541,0.9495,0.9423,0.9358,0.929,0.9193,0# # .9094,0.9001,0.8908,0.8804,0.8633,0.849,0.8363,0.8167,0.7994,0.7831,0.7606,0.74,0.7174,0.6948,0# # .6811,0.6598,0.6388,0.6174,0.5734, +# # #' 0.9965,0.9993,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9999,0# # .9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9995,0.9993,0.9992,0.9992,0.9992,0.9992,0.9993,0.9993,0# # .9991,0.9993,0.9993,0.9993,0.9993,0.9993,0.9992,0.9992,0.9992,0.9991,0.9991,0.9991,0.9989,0.9989,0# # .9989,0.9987,0.9987,0.9986,0.9981,0.9979,0.9979,0.9977,0.9971,0.9968,0.997,0.9966,0.996,0.9959,0# # .9954,0.995,0.9946,0.9941,0.9934,0.9925,0.9918,0.9907,0.9896,0.9891,0.9875,0.9857,0.9845,0.983,0# # .9812,0.9785,0.9757,0.9736,0.9701,0.9668,0.9641,0.9599,0.9556,0.95,0.9447,0.9384,0.9315,0.925,0# # .9143,0.9031,0.8924,0.8799,0.8653,0.8488,0.8359,0.8257,0.8106,0.7911,0.7647,0.7396,0.7218,0.6989,0# # .6796,0.6577,0.6363,0.6142,0.57, +# # #' 0.9966,0.9993,0.9998,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9998,0.9997,0.9997,0.9996,0.9995,0.9992,0.9991,0.9991,0.9992,0.9993,0.9993,0# # .9993,0.9993,0.9993,0.9994,0.9994,0.9993,0.9993,0.9992,0.9991,0.9992,0.9991,0.999,0.9989,0.9987,0# # .9986,0.9986,0.9985,0.9984,0.9982,0.9981,0.9978,0.9973,0.9971,0.9971,0.9969,0.9967,0.9965,0.9958,0# # .9953,0.9951,0.9945,0.9937,0.9929,0.9926,0.9923,0.9906,0.99,0.9892,0.9874,0.9864,0.9848,0.983,0.981# # ,0.979,0.9775,0.9747,0.9715,0.969,0.9653,0.9612,0.9565,0.9513,0.9466,0.9398,0.932,0.924,0.9177,0# # .9076,0.8949,0.8828,0.8699,0.8589,0.8413,0.8234,0.8063,0.782,0.7602,0.7399,0.7241,0.7089,0.679,0# # .6563,0.6344,0.6134,0.5669, +# # #' 0.9969,0.9993,0.9996,0.9997,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9998,0.9997,0.9997,0.9996,0.9994,0.9993,0.9993,0.9992,0.999,0.9992,0.9993,0# # .9993,0.9993,0.9994,0.9995,0.9994,0.9992,0.9992,0.9993,0.9993,0.9993,0.9992,0.9991,0.9991,0.9989,0# # .9987,0.9987,0.9985,0.9984,0.9983,0.9981,0.998,0.9978,0.9976,0.9976,0.9971,0.9966,0.9962,0.996,0# # .9956,0.995,0.9947,0.9943,0.9931,0.9923,0.9916,0.991,0.9906,0.9893,0.9879,0.987,0.9851,0.9833,0# # .9817,0.9789,0.9767,0.9754,0.9719,0.9679,0.9651,0.9612,0.9577,0.9521,0.9454,0.94,0.9328,0.9256,0# # .9161,0.9066,0.8969,0.8831,0.87,0.8527,0.8364,0.8206,0.8016,0.7879,0.7665,0.7305,0.7086,0.7018,0# # .6734,0.6506,0.628,0.6056,0.5611, +# # #' 0.9969,0.9993,0.9997,0.9997,0.9998,0.9999,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9996,0.9994,0.9993,0.9993,0.9993,0.9993,0.9993,0.9992,0# # .9994,0.9995,0.9994,0.9994,0.9994,0.9995,0.9995,0.9994,0.9992,0.9991,0.9992,0.9992,0.999,0.9989,0# # .9988,0.9987,0.9986,0.9985,0.9981,0.9981,0.998,0.9976,0.9974,0.9972,0.9969,0.9968,0.9966,0.9962,0# # .9955,0.995,0.9945,0.994,0.9938,0.9933,0.9924,0.9914,0.9902,0.9893,0.9885,0.9866,0.9846,0.9837,0# # .9819,0.9799,0.9778,0.9739,0.9718,0.9695,0.9655,0.9622,0.958,0.9527,0.9476,0.9424,0.9355,0.9248,0# # .9156,0.9069,0.8979,0.8869,0.8705,0.8563,0.8412,0.8249,0.8104,0.7927,0.7748,0.7577,0.7306,0.7084,0# # .6884,0.6664,0.6454,0.6234,0.5784, +# # #' 0.9972,0.9994,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9995,0.9994,0.9992,0.9991,0.9992,0.9993,0.9992,0.9992,0# # .9993,0.9994,0.9993,0.9993,0.9994,0.9994,0.9993,0.9994,0.9993,0.9992,0.9993,0.9991,0.9991,0.9991,0# # .9989,0.9989,0.9989,0.9986,0.9983,0.9981,0.998,0.9979,0.9977,0.9972,0.9966,0.9965,0.9965,0.9963,0# # .9957,0.9953,0.9947,0.994,0.9936,0.9932,0.9925,0.9917,0.991,0.9903,0.9886,0.9869,0.9858,0.9843,0# # .9825,0.9805,0.9785,0.9756,0.9725,0.9705,0.9681,0.9653,0.9608,0.9554,0.9514,0.946,0.9386,0.9299,0# # .9223,0.9144,0.9018,0.8894,0.8776,0.8645,0.8453,0.8273,0.8171,0.8011,0.7761,0.749,0.7403,0.7271,0# # .6924,0.6703,0.6479,0.6255,0.5791, +# # #' 0.9979,0.9994,0.9997,0.9998,0.9998,0.9999,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9998,0.9998,0.9998,0.9997,0.9996,0.9995,0.9994,0.9993,0.9993,0.9993,0.9994,0.9993,0# # .9992,0.9993,0.9993,0.9992,0.9993,0.9994,0.9993,0.9994,0.9994,0.9992,0.9992,0.9993,0.9993,0.999,0# # .9989,0.9989,0.9986,0.9985,0.9984,0.9983,0.9981,0.9979,0.9978,0.9974,0.9972,0.9972,0.9967,0.9958,0# # .9954,0.9953,0.9946,0.9943,0.9941,0.9933,0.9922,0.9917,0.9908,0.9897,0.989,0.9875,0.9851,0.9841,0# # .983,0.981,0.9792,0.9772,0.9748,0.9708,0.967,0.9638,0.96,0.9559,0.9513,0.9442,0.9363,0.9294,0.9214# # ,0.9121,0.9011,0.8887,0.8762,0.8614,0.8452,0.8306,0.8111,0.7966,0.7811,0.7447,0.7124,0.6993,0.6873# # ,0.665,0.6426,0.6206,0.5745, +# # #' 0.9974,0.9994,0.9998,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9998,0.9999,0# # .9999,0.9999,0.9999,0.9998,0.9997,0.9996,0.9996,0.9995,0.9994,0.9994,0.9993,0.9992,0.9993,0.9994,0# # .9994,0.9994,0.9995,0.9994,0.9993,0.9995,0.9995,0.9993,0.9993,0.9994,0.9992,0.9991,0.9991,0.999,0# # .999,0.9989,0.9986,0.9986,0.9986,0.9984,0.9982,0.9979,0.9979,0.9978,0.9974,0.9969,0.9965,0.9959,0# # .9954,0.9953,0.9949,0.9943,0.994,0.9935,0.9926,0.9918,0.991,0.9902,0.9891,0.9872,0.9852,0.985,0# # .9844,0.9824,0.9797,0.9771,0.975,0.9725,0.9691,0.9658,0.9617,0.9568,0.9522,0.9466,0.9394,0.9306,0# # .9237,0.916,0.9036,0.8915,0.8787,0.8654,0.8498,0.8306,0.8147,0.7989,0.7774,0.7561,0.7387,0.7168,0# # .6941,0.672,0.6496,0.6273,0.5804, +# # #' 0.9977,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9996,0.9993,0.9992,0.9993,0.9993,0.9994,0.9993,0.9992,0# # .9992,0.9992,0.9993,0.9993,0.9993,0.9994,0.9994,0.9994,0.9993,0.9993,0.9993,0.9992,0.9992,0.9991,0# # .9989,0.9989,0.9988,0.9986,0.9985,0.9983,0.998,0.998,0.9979,0.9976,0.9971,0.9967,0.9963,0.9962,0# # .9961,0.9957,0.9952,0.9947,0.994,0.9933,0.993,0.9922,0.991,0.99,0.9888,0.9874,0.9866,0.9854,0.9839# # ,0.9827,0.9807,0.9788,0.9765,0.9734,0.9711,0.9675,0.9634,0.9591,0.9524,0.9475,0.9414,0.9329,0.9248# # ,0.916,0.9056,0.8949,0.8821,0.8679,0.8541,0.8379,0.8184,0.7978,0.7775,0.7522,0.7237,0.7016,0.6906,0# # .6677,0.6448,0.6226,0.5743, +# # #' 0.9979,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9996,0.9995,0.9994,0.9993,0.9993,0.9993,0.9992,0.9993,0# # .9993,0.9993,0.9992,0.9993,0.9992,0.9992,0.9992,0.9993,0.9993,0.9993,0.9992,0.9992,0.9992,0.9992,0# # .9991,0.999,0.9988,0.9986,0.9985,0.9984,0.9982,0.9982,0.9981,0.9977,0.9973,0.9968,0.9967,0.9963,0# # .9957,0.9958,0.9955,0.9947,0.9939,0.9935,0.993,0.9923,0.9914,0.9903,0.9891,0.9879,0.9872,0.9862,0# # .9843,0.982,0.9807,0.9791,0.9766,0.9743,0.9704,0.9665,0.9646,0.9606,0.954,0.9489,0.9427,0.9326,0# # .9246,0.9172,0.9075,0.8967,0.8833,0.8673,0.8531,0.8359,0.817,0.8054,0.784,0.7543,0.7308,0.7135,0# # .6957,0.6731,0.6503,0.6278,0.58, +# # #' 0.9978,0.9994,0.9997,0.9997,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9998,0.9998,0.9998,0.9997,0.9997,0.9996,0.9994,0.9994,0.9994,0.9994,0.9992,0.9993,0# # .9994,0.9993,0.9994,0.9993,0.9992,0.9993,0.9993,0.9993,0.9993,0.9992,0.9991,0.9992,0.9991,0.9991,0# # .9992,0.9991,0.999,0.9986,0.9984,0.9984,0.9983,0.9981,0.998,0.9977,0.9972,0.997,0.9968,0.9964,0.996# # ,0.9958,0.9955,0.9946,0.994,0.9936,0.9934,0.9926,0.9914,0.9908,0.9901,0.9885,0.9874,0.9868,0.9857,0# # .9835,0.9818,0.9801,0.9777,0.9748,0.9712,0.968,0.9642,0.9599,0.9554,0.9506,0.9432,0.935,0.9293,0# # .9207,0.9097,0.8971,0.8852,0.8716,0.854,0.8404,0.8243,0.803,0.7838,0.7586,0.728,0.7077,0.693,0.6698# # ,0.6468,0.6233,0.575, +# # #' 0.9977,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9996,0.9995,0.9995,0.9994,0.9993,0.9993,0.9993,0.9992,0# # .9994,0.9994,0.9993,0.9992,0.9993,0.9993,0.9992,0.9993,0.9994,0.9994,0.9993,0.9994,0.9994,0.9992,0# # .999,0.9989,0.9989,0.9987,0.9988,0.9988,0.9984,0.9981,0.9978,0.9976,0.9974,0.9972,0.997,0.9966,0# # .9961,0.9957,0.9953,0.9949,0.9946,0.9938,0.993,0.9925,0.9918,0.9909,0.9895,0.9883,0.9876,0.9864,0# # .9857,0.9839,0.9812,0.9796,0.9779,0.9757,0.973,0.9686,0.9652,0.961,0.954,0.949,0.9435,0.9366,0.9294# # ,0.9196,0.9108,0.9006,0.887,0.8732,0.8575,0.8421,0.8245,0.8028,0.7852,0.7671,0.741,0.7179,0.6987,0# # .6757,0.6526,0.6298,0.5808, +# # #' 0.9981,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9996,0.9995,0.9995,0.9994,0.9993,0.9993,0.9993,0.9993,0# # .9994,0.9993,0.9993,0.9993,0.9994,0.9992,0.9993,0.9994,0.9993,0.9993,0.9993,0.9993,0.9993,0.9992,0# # .9991,0.9991,0.9991,0.9989,0.9986,0.9985,0.9985,0.9982,0.9979,0.9976,0.9974,0.9972,0.9972,0.9969,0# # .9964,0.9959,0.9952,0.9952,0.9947,0.9934,0.9931,0.9928,0.9922,0.9915,0.9904,0.989,0.9876,0.9867,0# # .9852,0.9834,0.9819,0.9804,0.9788,0.9763,0.9734,0.9707,0.9659,0.9608,0.9562,0.9509,0.9461,0.9416,0# # .9336,0.9209,0.9098,0.9,0.8881,0.8748,0.8621,0.8474,0.8282,0.8065,0.7817,0.763,0.7445,0.7198,0.6988# # ,0.6753,0.6519,0.6284,0.5786, +# # #' 0.9975,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9997,0.9997,0.9996,0.9995,0.9993,0.9993,0.9993,0.9993,0# # .9992,0.9992,0.9993,0.9993,0.9994,0.9994,0.9994,0.9993,0.9993,0.9993,0.9994,0.9994,0.9992,0.9991,0# # .999,0.999,0.9991,0.999,0.9988,0.9986,0.9985,0.9983,0.9981,0.9978,0.9977,0.9976,0.9972,0.9967,0# # .9962,0.9958,0.9954,0.9952,0.995,0.9944,0.9936,0.9927,0.992,0.9915,0.9907,0.9897,0.9881,0.987,0# # .9865,0.9849,0.9826,0.9814,0.9796,0.976,0.9724,0.9698,0.9668,0.9622,0.9571,0.9525,0.9464,0.9377,0# # .93,0.9225,0.9122,0.9007,0.8877,0.8723,0.8573,0.8414,0.8204,0.8008,0.7855,0.7631,0.7423,0.7212,0# # .6924,0.6687,0.6449,0.6221,0.5723, +# # #' 0.9976,0.9995,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9998,0.9998,0.9999,0.9999,0.9998,0.9997,0.9995,0.9994,0.9994,0.9994,0.9994,0.9993,0.9993,0# # .9993,0.9992,0.9992,0.9992,0.9992,0.9992,0.9992,0.9993,0.9994,0.9994,0.9992,0.999,0.9991,0.9992,0# # .9992,0.999,0.999,0.999,0.9988,0.9986,0.9984,0.9983,0.9983,0.998,0.9975,0.9974,0.9974,0.9967,0.9962# # ,0.9961,0.996,0.9956,0.995,0.9945,0.9937,0.9925,0.9919,0.9913,0.9904,0.9897,0.9885,0.9873,0.9861,0# # .9846,0.9831,0.9812,0.9794,0.9775,0.9742,0.9706,0.9669,0.9635,0.9607,0.9554,0.9482,0.9416,0.9347,0# # .9267,0.9148,0.9034,0.894,0.8806,0.8662,0.8452,0.8279,0.8102,0.7831,0.7623,0.7356,0.7147,0.6972,0# # .6729,0.649,0.6247,0.5746, +# # #' 0.9978,0.9995,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9999,0.9998,0.9997,0.9997,0.9996,0.9994,0.9993,0.9994,0.9993,0.9993,0.9993,0# # .9993,0.9994,0.9993,0.9993,0.9992,0.9992,0.9992,0.9991,0.9991,0.9992,0.9993,0.9992,0.9993,0.9993,0# # .9992,0.9991,0.9989,0.9988,0.9987,0.9987,0.9986,0.9984,0.998,0.9978,0.9976,0.9972,0.9973,0.9972,0# # .9969,0.9965,0.996,0.9954,0.995,0.9946,0.9939,0.9929,0.9921,0.9914,0.9909,0.9904,0.9891,0.9874,0# # .9861,0.9848,0.9831,0.9815,0.9801,0.9787,0.9751,0.9712,0.9683,0.9641,0.9599,0.9562,0.9503,0.9433,0# # .9355,0.9263,0.9181,0.9065,0.8934,0.8813,0.8702,0.8525,0.8296,0.8156,0.7995,0.7766,0.7577,0.7371,0# # .7097,0.6864,0.6629,0.6394,0.5885, +# # #' 0.9976,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9995,0.9994,0.9994,0.9994,0.9994,0.9993,0.9991,0# # .9991,0.9992,0.9992,0.9993,0.9993,0.9994,0.9994,0.9992,0.9992,0.9992,0.9991,0.9991,0.9992,0.9993,0# # .9991,0.999,0.9989,0.9989,0.9989,0.9988,0.9988,0.9985,0.9982,0.9981,0.9978,0.9977,0.9973,0.9967,0# # .9964,0.9961,0.9958,0.9954,0.9948,0.9944,0.9939,0.9934,0.9928,0.9917,0.9908,0.9898,0.9885,0.9875,0# # .9868,0.9856,0.984,0.9813,0.9792,0.9781,0.9749,0.9713,0.9693,0.9664,0.9605,0.9552,0.949,0.9427,0# # .9372,0.9288,0.9191,0.9054,0.8918,0.8799,0.8657,0.8477,0.8314,0.814,0.7884,0.767,0.7501,0.7284,0# # .7013,0.6772,0.6533,0.6287,0.5782, +# # #' 0.9978,0.9995,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9999,0.9998,0.9998,0.9997,0.9996,0.9996,0.9995,0.9995,0.9994,0.9995,0.9993,0# # .9992,0.9993,0.9993,0.9994,0.9993,0.9992,0.9991,0.9992,0.9992,0.9992,0.9992,0.9992,0.9992,0.999,0# # .9991,0.9991,0.9988,0.9988,0.9988,0.9988,0.9986,0.9984,0.9983,0.9979,0.9978,0.9977,0.9976,0.9974,0# # .9967,0.9962,0.9959,0.9958,0.9955,0.9949,0.9941,0.993,0.992,0.9918,0.991,0.99,0.9888,0.9874,0.9866# # ,0.9855,0.9839,0.9821,0.9802,0.9775,0.9757,0.9738,0.9693,0.9656,0.9612,0.9563,0.9508,0.9438,0.9375# # ,0.9309,0.9202,0.9081,0.8966,0.8827,0.8714,0.8598,0.8396,0.8147,0.7931,0.772,0.7499,0.7294,0.7059,0# # .6818,0.6574,0.6333,0.5815, +# # #' 0.9979,0.9996,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9999,0.9998,0.9999,0.9998,0.9996,0.9995,0.9995,0.9995,0.9994,0.9993,0.9993,0.9992,0# # .9993,0.9993,0.9991,0.9992,0.9992,0.9993,0.9993,0.9992,0.9993,0.9994,0.9991,0.9991,0.9992,0.9991,0# # .9989,0.9989,0.999,0.9989,0.9988,0.9987,0.9986,0.9986,0.9985,0.9981,0.998,0.9979,0.9974,0.9972,0# # .997,0.9965,0.9961,0.9956,0.9955,0.9953,0.9946,0.994,0.9932,0.9917,0.9903,0.9901,0.9895,0.9883,0# # .9877,0.9857,0.9834,0.9828,0.9815,0.979,0.9768,0.9747,0.9716,0.9667,0.9611,0.9571,0.9539,0.9471,0# # .9387,0.9296,0.9189,0.9088,0.8982,0.8842,0.8669,0.847,0.8249,0.8068,0.7907,0.7732,0.7507,0.7199,0# # .6941,0.6689,0.6435,0.6187,0.5669, +# # #' 0.9981,0.9996,0.9998,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0.9999,0# # .9999,0.9999,0.9998,0.9998,0.9999,0.9997,0.9996,0.9996,0.9996,0.9994,0.9993,0.9994,0.9993,0.9993,0# # .9994,0.9993,0.9992,0.9993,0.9993,0.9994,0.9994,0.9993,0.9992,0.9991,0.9992,0.9992,0.9992,0.9992,0# # .999,0.999,0.999,0.999,0.9988,0.9988,0.9987,0.9985,0.9985,0.9983,0.9979,0.9978,0.9975,0.997,0.9969# # ,0.9968,0.9964,0.996,0.9956,0.9949,0.9941,0.9935,0.9928,0.9921,0.9912,0.99,0.9888,0.9877,0.9867,0# # .9856,0.9839,0.9826,0.9807,0.9793,0.9773,0.9739,0.9704,0.9663,0.9632,0.9589,0.953,0.9456,0.9376,0# # .9295,0.9208,0.9115,0.8987,0.8831,0.8685,0.8532,0.8322,0.8139,0.7997,0.7768,0.7487,0.7253,0.7054,0# # .681,0.6567,0.6329,0.5804) +# # #' +# # #' +# # #' all_years <- c("1999", "2000", "2001", "2002", "2003", "2004", +# # #' "2005", "2006", "2007", "2008", "2009", "2010", +# # #' "2011", "2012", "2013", "2014", "2015", "2016", +# # #' "2017", "2018", "2019") +# # #' +# # #' # Population for males as matrix +# # #' pop_m_mat <- matrix(pop_m, nrow = 101, ncol = 21) +# # #' colnames(pop_m_mat) <- all_years +# # #' +# # #' # Population for females as matrix +# # #' pop_f_mat <- matrix(pop_f, nrow = 101, ncol = 21) +# # #' colnames(pop_f_mat) <- all_years +# # #' +# # #' # Age-specific-fertility-rate for as matrix +# # #' asfr_mat <- matrix(asfr, nrow = 35, ncol = 20) +# # #' colnames(asfr_mat) <- all_years[-length(all_years)] +# # #' +# # #' # Sex ratio at birth as vector +# # #' srb_vec <- c(1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, +# # #' 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06, 1.06) +# # #' +# # #' +# # #' names(srb_vec) <- all_years[-length(all_years)] +# # #' +# # #' # Survival ratio for males as matrix +# # #' sr_m_mat <- matrix(sr_m, nrow = 101, ncol = 20) +# # #' colnames(sr_m_mat) <- all_years[-length(all_years)] +# # #' +# # #' # Survival ratio for females as matrix +# # #' sr_f_mat <- matrix(sr_f, nrow = 101, ncol = 20) +# # #' colnames(sr_f_mat) <- all_years[-length(all_years)] +# # #' +# # #' # Age/year sequence of all the data from above +# # #' interval <- 1 +# # #' ages <- seq(0, 100, by = interval) +# # #' years <- seq(1999, 2019, by = interval) +# # #' ages_asfr <- seq(15, 50, by = interval) +# # #' #' +# # #' mig_res <- +# # #' mig_resid_stock( +# # #' pop_m_mat = pop_m_mat, +# # #' pop_f_mat = pop_f_mat, +# # #' sr_m_mat = sr_m_mat, +# # #' sr_f_mat = sr_f_mat, +# # #' asfr_mat = asfr_mat, +# # #' srb_vec = srb_vec, +# # #' ages = ages, +# # #' ages_asfr = ages_asfr +# # #' ) +# # #' +# # #' # Net migration for males using stock change method +# # #' mig_res$mig_m +# # #' +# # #' # Net migration for females using stock change method +# # #' mig_res$mig_f +# # #' +# # #' +# # #' ################ cohort even flow method ##################### +# # #' +# # #' # We reuse the same data from before +# # #' +# # # mig_res <- +# # # mig_resid_cohort( +# # # pop_m_mat = pop_m_mat, +# # # pop_f_mat = pop_f_mat, +# # # sr_m_mat = sr_m_mat, +# # # sr_f_mat = sr_f_mat, +# # # asfr_mat = asfr_mat, +# # # srb_vec = srb_vec, +# # # ages = ages, +# # # ages_asfr = ages_asfr +# # # ) +# # #' +# # #' # Net migration for males using the cohort even flow method +# # #' mig_res$mig_m +# # #' +# # #' # Net migration for females using the cohort even flow method +# # #' mig_res$mig_f +# # #' +# # #' ################ time even flow method ##################### +# # #' +# # #' # We reuse the same data from before +# # #' +# # #' mig_res <- +# # #' mig_resid_time( +# # #' pop_m_mat = pop_m_mat, +# # #' pop_f_mat = pop_f_mat, +# # #' sr_m_mat = sr_m_mat, +# # #' sr_f_mat = sr_f_mat, +# # #' asfr_mat = asfr_mat, +# # #' srb_vec = srb_vec, +# # #' ages = ages, +# # #' ages_asfr = ages_asfr +# # #' ) +# # #' +# # #' # Net migration for males using the time even flow method +# # #' mig_res$mig_m +# # #' +# # #' # Net migration for females using the time even flow method +# # #' mig_res$mig_f +# # #' +# # #' @export +# # mig_resid_stock <- function(pop_m_mat, +# # pop_f_mat, +# # sr_m_mat, +# # sr_f_mat, +# # asfr_mat, +# # srb_vec, +# # ages, +# # ages_asfr) { +# # +# # stopifnot( +# # is.matrix(pop_m_mat), # the function works just with this objects +# # is.matrix(pop_f_mat), +# # is.matrix(sr_m_mat), +# # is.matrix(sr_f_mat), +# # is.matrix(asfr_mat), +# # is.numeric(srb_vec), +# # is.numeric(ages), +# # is.numeric(ages_asfr) +# # ) +# # +# # # Migration net of only survivors +# # net_mig_m <- migresid_net_surv(pop_m_mat, sr_m_mat) +# # net_mig_f <- migresid_net_surv(pop_f_mat, sr_f_mat) +# # +# # fertility_index <- which(ages %in% ages_asfr) +# # +# # # Returns all births for all years +# # age_interval <- unique(diff(ages)) +# # all_births <- migresid_births( +# # pop_f_mat, +# # asfr_mat, +# # fertility_index, +# # age_interval +# # ) +# # +# # # With all_births already calculated, separate between +# # # female/male births with the sex ratio at birth +# # births_m <- all_births[2:length(all_births)] * (srb_vec / (1 + srb_vec)) +# # births_f <- all_births[2:length(all_births)] * (1 / (1 + srb_vec)) +# # +# # net_mig_m <- migresid_net_surv_first_ageg( +# # net_mig_m, +# # pop_m_mat, +# # births_m, +# # sr_m_mat +# # ) +# # +# # net_mig_f <- migresid_net_surv_first_ageg( +# # net_mig_f, +# # pop_f_mat, +# # births_f, +# # sr_f_mat +# # ) +# # +# # # First year is empty, so we exclude +# # list( +# # mig_m = net_mig_m[, -1], +# # mig_f = net_mig_f[, -1] +# # ) +# # } +# # +# # #' @rdname mig_resid_stock +# # #' @export +# # mig_resid_cohort <- function(pop_m_mat, +# # pop_f_mat, +# # sr_m_mat, +# # sr_f_mat, +# # asfr_mat, +# # srb_vec, +# # ages, +# # ages_asfr) { +# # +# # # Estimate stock method +# # mig_res <- +# # mig_resid_stock( +# # pop_m_mat = pop_m_mat, +# # pop_f_mat = pop_f_mat, +# # sr_m_mat = sr_m_mat, +# # sr_f_mat = sr_f_mat, +# # asfr_mat = asfr_mat, +# # srb_vec = srb_vec, +# # ages = ages, +# # ages_asfr = ages_asfr +# # ) +# # +# # net_mig_m <- mig_res$mig_m +# # net_mig_f <- mig_res$mig_f +# # +# # # Estimate bounds for males +# # mig_m_bounds <- migresid_bounds(net_mig_m, sr_m_mat) +# # mig_upper_m <- mig_m_bounds$upper +# # mig_lower_m <- mig_m_bounds$lower +# # +# # # Estimate bounds for females +# # mig_f_bounds <- migresid_bounds(net_mig_f, sr_f_mat) +# # mig_upper_f <- mig_f_bounds$upper +# # mig_lower_f <- mig_f_bounds$lower +# # +# # # Adjust last age group in the bounds +# # mig_bounds <- migresid_bounds_last_ageg( +# # net_mig_m, +# # net_mig_f, +# # mig_upper_m, +# # mig_lower_m, +# # mig_upper_f, +# # mig_lower_f +# # ) +# # +# # mig_upper_m <- mig_bounds$mig_upper_m +# # mig_lower_m <- mig_bounds$mig_lower_m +# # mig_upper_f <- mig_bounds$mig_upper_f +# # mig_lower_f <- mig_bounds$mig_lower_f +# # +# # # Combine both upper/lower bound into a single rectangle +# # mig_rectangle_m <- mig_upper_m + mig_lower_m +# # mig_rectangle_f <- mig_upper_f + mig_lower_f +# # +# # list( +# # mig_m = mig_rectangle_m[, -1], +# # mig_f = mig_rectangle_f[, -1] +# # ) +# # } +# # +# # #' @rdname mig_resid_stock +# # #' @export +# # mig_resid_time <- function(pop_m_mat, +# # pop_f_mat, +# # sr_m_mat, +# # sr_f_mat, +# # asfr_mat, +# # srb_vec, +# # ages, +# # ages_asfr) { +# # +# # # Estimate stock method +# # mig_res <- +# # mig_resid_stock( +# # pop_m_mat = pop_m_mat, +# # pop_f_mat = pop_f_mat, +# # sr_m_mat = sr_m_mat, +# # sr_f_mat = sr_f_mat, +# # asfr_mat = asfr_mat, +# # srb_vec = srb_vec, +# # ages = ages, +# # ages_asfr = ages_asfr +# # ) +# # +# # # Separate male/female net migration +# # net_mig_m <- mig_res$mig_m +# # net_mig_f <- mig_res$mig_f +# # +# # # Adjust age group 0-4 +# # net_mig_m[1, ] <- 2 * net_mig_m[1, ] +# # net_mig_f[1, ] <- 2 * net_mig_f[1, ] +# # +# # # Adjust age groups 5-10 to 100+ (of whatever maximum age groups) +# # for (i in 2:nrow(net_mig_m)) { +# # double_pop_m <- (2 * net_mig_m[i, ]) +# # double_pop_f <- (2 * net_mig_f[i, ]) +# # +# # # Multiply net mig of i - 1 by survival rate of i +# # # to get number of survived +# # mig_sr_m <- net_mig_m[i - 1, ] * sr_m_mat[i, ] +# # mig_sr_f <- net_mig_f[i - 1, ] * sr_f_mat[i, ] +# # +# # net_mig_m[i, ] <- double_pop_m - mig_sr_m +# # net_mig_f[i, ] <- double_pop_f - mig_sr_f +# # } +# # +# # list( +# # mig_m = net_mig_m, +# # mig_f = net_mig_f +# # ) +# # } +# # +# # +# # # Net migration is pop minus the people that survived from the previous +# # # age/cohort +# # migresid_net_surv <- function(pop_mat, sr_mat) { +# # n <- nrow(pop_mat) +# # p <- ncol(pop_mat) +# # survived <- +# # pop_mat[-n, -p] * #eliminate the last year and age-group and then its is multiplied by survival # # rates matrix +# # sr_mat[-1, ] #remove last age-group +# # res <- pop_mat[-1, -1] - survived #pop from the last year - survived = residual +# # res[nrow(res), ] <- NA # recode last row (last age group) as na +# # res <- rbind(matrix(NA, nrow = 1, ncol = ncol(res)), res) # add a first row as NA and push the # # original to the 2nd row +# # res <- cbind(matrix(NA, nrow = nrow(res), ncol = 1), res) # add a first col with NA values +# # res <- migresid_net_surv_last_ageg(res, pop_m_mat, sr_m_mat) #applying a special function to the # # last age-group +# # res +# # } +# # +# # # Net migration for last age group is pop for that age group in +# # # year j, minus the people from the previous age group the survived +# # migresid_net_surv_last_ageg <- function(net_mig, pop_mat, sr_mat) { +# # n <- nrow(pop_mat) +# # p <- ncol(pop_mat) +# # previous_year <- 1:(p - 1) +# # survived <- +# # (pop_mat[n, previous_year] + pop_mat[n - 1, previous_year]) * #pop in the last row (agegroup) # # in all years but the last column + +# # sr_mat[n, previous_year] +# # +# # net_mig[nrow(net_mig), 2:ncol(net_mig)] <- pop_mat[n, 2:p] - survived +# # net_mig +# # } +# # # Births from +# # migresid_births <- function(pop_f_mat, +# # asfr_mat, +# # fertility_index, +# # age_interval) { +# # p <- ncol(pop_f_mat) +# # +# # # Sum female pop from previous year and this year +# # f_pop <- pop_f_mat[fertility_index, -1] + pop_f_mat[fertility_index, -p] # f pop 1950+1955 / 1955# # -1960... +# # +# # # Births that occurred for all age groups for all years +# # # based on the age-specific fertility rate (asfr) from +# # # previous years to the population +# # these_births <- age_interval * (0.5 * (f_pop) * asfr_mat[, -p])/1000 +# # +# # all_births <- c(NA, colSums(these_births)) +# # col_names <- attr(pop_f_mat, "dimnames")[[2]] +# # all_births <- stats::setNames(all_births, col_names) +# # all_births +# # } +# # +# # migresid_net_surv_first_ageg <- function(net_mig, pop_mat, births, sr_mat) { +# # p <- ncol(net_mig) +# # net_mig[1, 2:p] <- pop_mat[1, 2:p] - births * sr_mat[1, ] +# # net_mig +# # } +# # +# # +# # # Returns age/year matrices with upper/lower bounds +# # # for net migration based on the net migration and +# # # survival rates. These, I believe are the upper/lower +# # # bounds of a lexis surfave (which is why we do ^0.5). +# # migresid_bounds <- function(net_mig, sr_mat) { +# # n <- nrow(net_mig) +# # p <- ncol(net_mig) +# # +# # # Upper bound is net mig / 2 times the survival ratio ^ 0.5 +# # mig_upper <- net_mig / (2 * sr_mat^0.5) +# # mig_upper <- cbind(matrix(NA, ncol = 1, nrow = n), mig_upper) +# # mig_lower <- mig_upper +# # mig_upper[1, ] <- NA +# # mig_upper[n, ] <- NA +# # mig_lower[n, ] <- NA +# # mig_lower <- mig_lower[-1, ] +# # empty_matrix <- matrix(NA, ncol = ncol(mig_lower), nrow = 1) +# # mig_lower <- rbind(mig_lower, empty_matrix) +# # +# # # Estimate upper bounds for the first age group. Why +# # # no lower bound for the first age group? because we have +# # # no previous age group. +# # p_upper <- ncol(mig_upper) +# # mig_upper[1, 2:p_upper] <- net_mig[1, -p_upper] / (sr_mat[1, -p_upper]^0.5) +# # +# # list(upper = mig_upper, lower = mig_lower) +# # } +# # +# # # Updates last age group for all upper/lower bounds +# # migresid_bounds_last_ageg <- function(net_mig_m, +# # net_mig_f, +# # mig_upper_m, +# # mig_lower_m, +# # mig_upper_f, +# # mig_lower_f) { +# # +# # +# # # last age group +# # n <- nrow(mig_upper_m) ## n is equal the number of rows in mig_upper_m +# # p <- ncol(mig_upper_m) ## p is equal the number of cols in mig_upper_m +# # +# # mig_lower_m[n - 1, ] <- mig_upper_m[n - 1, ] +# # mig_lower_f[n - 1, ] <- mig_upper_f[n - 1, ] +# # mig_upper_m[n, 2:p] <- net_mig_m[n, -p] * 0.5 +# # mig_upper_f[n, 2:p] <- net_mig_f[n, -p] * 0.5 +# # mig_lower_m[n, 2:p] <- net_mig_m[n, -p] * 0.5 +# # mig_lower_f[n, 2:p] <- net_mig_f[n, -p] * 0.5 +# # +# # list( +# # mig_lower_m = mig_lower_m, +# # mig_upper_m = mig_upper_m, +# # mig_lower_f = mig_lower_f, +# # mig_upper_f = mig_upper_f +# # ) +# # } +# # diff --git a/docs/404.html b/docs/404.html index b20b0c89a..35d4642fb 100644 --- a/docs/404.html +++ b/docs/404.html @@ -79,7 +79,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/CODE_OF_CONDUCT.html b/docs/CODE_OF_CONDUCT.html index cbe6ece48..eb99d3bfa 100644 --- a/docs/CODE_OF_CONDUCT.html +++ b/docs/CODE_OF_CONDUCT.html @@ -79,7 +79,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/CONTRIBUTING.html b/docs/CONTRIBUTING.html index 4fba54249..7ba65d67a 100644 --- a/docs/CONTRIBUTING.html +++ b/docs/CONTRIBUTING.html @@ -79,7 +79,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/LICENSE-text.html b/docs/LICENSE-text.html index 650c00960..c75e8f6c6 100644 --- a/docs/LICENSE-text.html +++ b/docs/LICENSE-text.html @@ -79,7 +79,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/articles/Age-heaping_quality_with_Demotools.html b/docs/articles/Age-heaping_quality_with_Demotools.html index a47cf5fe3..48a620558 100644 --- a/docs/articles/Age-heaping_quality_with_Demotools.html +++ b/docs/articles/Age-heaping_quality_with_Demotools.html @@ -38,7 +38,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -114,7 +114,7 @@

Age-heaping indices with DemoTools

Jose Manuel Aburto, Ilya Kashnitsky, Marius Pascariu, Tim Riffe

-

2021-01-12

+

2021-04-09

Source: vignettes/Age-heaping_quality_with_Demotools.Rmd diff --git a/docs/articles/case_study_1.html b/docs/articles/case_study_1.html index 32ed6afb2..461bf6dd9 100644 --- a/docs/articles/case_study_1.html +++ b/docs/articles/case_study_1.html @@ -38,7 +38,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -114,7 +114,7 @@

DemoTools: A case study

Jose Manuel Aburto, Ilya Kashnitsky, Monica Alexander, Jorge Cimentada, Tim Riffe

-

2021-01-12

+

2021-04-09

Source: vignettes/case_study_1.Rmd diff --git a/docs/articles/graduation_with_demotools.html b/docs/articles/graduation_with_demotools.html index 80d36c3bc..850edbea0 100644 --- a/docs/articles/graduation_with_demotools.html +++ b/docs/articles/graduation_with_demotools.html @@ -38,7 +38,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -114,7 +114,7 @@

Graduation with DemoTools

José Manuel Aburto, Ilya Kashnitsky, Monica Alexander, Jorge Cimentada, Tim Riffe

-

2021-01-12

+

2021-04-09

Source: vignettes/graduation_with_demotools.Rmd @@ -186,7 +186,7 @@

#check the totals sum(sprague) -#> [1] 395139.8 +#> [1] 395141.3 sum(Value) #> [1] 395138 @@ -338,10 +338,12 @@

splitfun = graduate_uniform, recursive = TRUE) pop1resc -#> 0 1 6 8 10 14 18 19 -#> 13.78861 369.55222 76.78674 27.15103 303.39771 178.86055 46.64916 179.93240 -#> 21 24 28 31 34 37 40 -#> 190.94577 247.00658 170.54058 294.41331 224.48613 116.79964 369.03465 +#> 0 1 6 8 10 14 18 +#> 8.453942 269.977069 139.427557 104.693482 247.733148 253.655700 142.416051 +#> 19 21 24 28 31 34 37 +#> 81.049696 226.922450 232.099197 144.869189 197.291577 62.315228 176.488376 +#> 40 +#> 128.821850
diff --git a/docs/articles/graduation_with_demotools_files/figure-html/unnamed-chunk-2-1.png b/docs/articles/graduation_with_demotools_files/figure-html/unnamed-chunk-2-1.png index 1c4fc9d02..2d9fde7be 100644 Binary files a/docs/articles/graduation_with_demotools_files/figure-html/unnamed-chunk-2-1.png and b/docs/articles/graduation_with_demotools_files/figure-html/unnamed-chunk-2-1.png differ diff --git a/docs/articles/graduation_with_demotools_files/figure-html/unnamed-chunk-4-1.png b/docs/articles/graduation_with_demotools_files/figure-html/unnamed-chunk-4-1.png index 9ddd4a2ce..e17ef521b 100644 Binary files a/docs/articles/graduation_with_demotools_files/figure-html/unnamed-chunk-4-1.png and b/docs/articles/graduation_with_demotools_files/figure-html/unnamed-chunk-4-1.png differ diff --git a/docs/articles/graduation_with_demotools_files/figure-html/unnamed-chunk-7-1.png b/docs/articles/graduation_with_demotools_files/figure-html/unnamed-chunk-7-1.png index 08fe01b01..53e932d44 100644 Binary files a/docs/articles/graduation_with_demotools_files/figure-html/unnamed-chunk-7-1.png and b/docs/articles/graduation_with_demotools_files/figure-html/unnamed-chunk-7-1.png differ diff --git a/docs/articles/index.html b/docs/articles/index.html index 874f89b05..bc311292b 100644 --- a/docs/articles/index.html +++ b/docs/articles/index.html @@ -79,7 +79,7 @@ DemoTools - 01.11.03 + 01.13.40
diff --git a/docs/articles/migration_with_demotools.html b/docs/articles/migration_with_demotools.html index ff78863fa..66e754b9e 100644 --- a/docs/articles/migration_with_demotools.html +++ b/docs/articles/migration_with_demotools.html @@ -38,7 +38,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -114,7 +114,7 @@

Migration models with DemoTools

José Manuel Aburto, Ilya Kashnitsky, Monica Alexander, Jorge Cimentada, Tim Riffe

-

2021-01-12

+

2021-04-09

Source: vignettes/migration_with_demotools.Rmd @@ -166,7 +166,7 @@

 library(DemoTools)
 library(tibble)
-library(ggplot2)
+library(ggplot2)
 
 pars <- c(a1= 0.09, alpha1= 0.1,
           a2= 0.2, alpha2= 0.1, mu2= 21, lambda2= 0.4,
@@ -247,164 +247,12 @@ 

chains = 4, iter = 2000, control = list(adapt_delta = 0.8, max_treedepth = 10) -) -#> Running /usr/lib/R/bin/R CMD SHLIB foo.c -#> gcc -std=gnu99 -I"/usr/share/R/include" -DNDEBUG -I"/home/tim/R/x86_64-pc-linux-gnu-library/4.0/Rcpp/include/" -I"/home/tim/R/x86_64-pc-linux-gnu-library/4.0/RcppEigen/include/" -I"/home/tim/R/x86_64-pc-linux-gnu-library/4.0/RcppEigen/include/unsupported" -I"/home/tim/R/x86_64-pc-linux-gnu-library/4.0/BH/include" -I"/home/tim/R/x86_64-pc-linux-gnu-library/4.0/StanHeaders/include/src/" -I"/home/tim/R/x86_64-pc-linux-gnu-library/4.0/StanHeaders/include/" -I"/home/tim/R/x86_64-pc-linux-gnu-library/4.0/RcppParallel/include/" -I"/home/tim/R/x86_64-pc-linux-gnu-library/4.0/rstan/include" -DEIGEN_NO_DEBUG -DBOOST_DISABLE_ASSERTS -DBOOST_PENDING_INTEGER_LOG2_HPP -DSTAN_THREADS -DBOOST_NO_AUTO_PTR -include '/home/tim/R/x86_64-pc-linux-gnu-library/4.0/StanHeaders/include/stan/math/prim/mat/fun/Eigen.hpp' -D_REENTRANT -DRCPP_PARALLEL_USE_TBB=1 -fpic -g -O2 -fdebug-prefix-map=/build/r-base-7BvS0x/r-base-4.0.3=. -fstack-protector-strong -Wformat -Werror=format-security -Wdate-time -D_FORTIFY_SOURCE=2 -g -c foo.c -o foo.o -#> In file included from /home/tim/R/x86_64-pc-linux-gnu-library/4.0/RcppEigen/include/Eigen/Core:88:0, -#> from /home/tim/R/x86_64-pc-linux-gnu-library/4.0/RcppEigen/include/Eigen/Dense:1, -#> from /home/tim/R/x86_64-pc-linux-gnu-library/4.0/StanHeaders/include/stan/math/prim/mat/fun/Eigen.hpp:13, -#> from <command-line>:0: -#> /home/tim/R/x86_64-pc-linux-gnu-library/4.0/RcppEigen/include/Eigen/src/Core/util/Macros.h:628:1: error: unknown type name ‘namespace’ -#> namespace Eigen { -#> ^~~~~~~~~ -#> /home/tim/R/x86_64-pc-linux-gnu-library/4.0/RcppEigen/include/Eigen/src/Core/util/Macros.h:628:17: error: expected ‘=’, ‘,’, ‘;’, ‘asm’ or ‘__attribute__’ before ‘{’ token -#> namespace Eigen { -#> ^ -#> In file included from /home/tim/R/x86_64-pc-linux-gnu-library/4.0/RcppEigen/include/Eigen/Dense:1:0, -#> from /home/tim/R/x86_64-pc-linux-gnu-library/4.0/StanHeaders/include/stan/math/prim/mat/fun/Eigen.hpp:13, -#> from <command-line>:0: -#> /home/tim/R/x86_64-pc-linux-gnu-library/4.0/RcppEigen/include/Eigen/Core:96:10: fatal error: complex: No such file or directory -#> #include <complex> -#> ^~~~~~~~~ -#> compilation terminated. -#> /usr/lib/R/etc/Makeconf:172: recipe for target 'foo.o' failed -#> make: *** [foo.o] Error 1 -#> -#> SAMPLING FOR MODEL '28c89f5948288d3bb37fc72d345573dc' NOW (CHAIN 1). -#> Chain 1: -#> Chain 1: Gradient evaluation took 0.000117 seconds -#> Chain 1: 1000 transitions using 10 leapfrog steps per transition would take 1.17 seconds. -#> Chain 1: Adjust your expectations accordingly! -#> Chain 1: -#> Chain 1: -#> Chain 1: Iteration: 1 / 2000 [ 0%] (Warmup) -#> Chain 1: Iteration: 200 / 2000 [ 10%] (Warmup) -#> Chain 1: Iteration: 400 / 2000 [ 20%] (Warmup) -#> Chain 1: Iteration: 600 / 2000 [ 30%] (Warmup) -#> Chain 1: Iteration: 800 / 2000 [ 40%] (Warmup) -#> Chain 1: Iteration: 1000 / 2000 [ 50%] (Warmup) -#> Chain 1: Iteration: 1001 / 2000 [ 50%] (Sampling) -#> Chain 1: Iteration: 1200 / 2000 [ 60%] (Sampling) -#> Chain 1: Iteration: 1400 / 2000 [ 70%] (Sampling) -#> Chain 1: Iteration: 1600 / 2000 [ 80%] (Sampling) -#> Chain 1: Iteration: 1800 / 2000 [ 90%] (Sampling) -#> Chain 1: Iteration: 2000 / 2000 [100%] (Sampling) -#> Chain 1: -#> Chain 1: Elapsed Time: 2.54778 seconds (Warm-up) -#> Chain 1: 2.29965 seconds (Sampling) -#> Chain 1: 4.84743 seconds (Total) -#> Chain 1: -#> -#> SAMPLING FOR MODEL '28c89f5948288d3bb37fc72d345573dc' NOW (CHAIN 2). -#> Chain 2: -#> Chain 2: Gradient evaluation took 5e-05 seconds -#> Chain 2: 1000 transitions using 10 leapfrog steps per transition would take 0.5 seconds. -#> Chain 2: Adjust your expectations accordingly! -#> Chain 2: -#> Chain 2: -#> Chain 2: Iteration: 1 / 2000 [ 0%] (Warmup) -#> Chain 2: Iteration: 200 / 2000 [ 10%] (Warmup) -#> Chain 2: Iteration: 400 / 2000 [ 20%] (Warmup) -#> Chain 2: Iteration: 600 / 2000 [ 30%] (Warmup) -#> Chain 2: Iteration: 800 / 2000 [ 40%] (Warmup) -#> Chain 2: Iteration: 1000 / 2000 [ 50%] (Warmup) -#> Chain 2: Iteration: 1001 / 2000 [ 50%] (Sampling) -#> Chain 2: Iteration: 1200 / 2000 [ 60%] (Sampling) -#> Chain 2: Iteration: 1400 / 2000 [ 70%] (Sampling) -#> Chain 2: Iteration: 1600 / 2000 [ 80%] (Sampling) -#> Chain 2: Iteration: 1800 / 2000 [ 90%] (Sampling) -#> Chain 2: Iteration: 2000 / 2000 [100%] (Sampling) -#> Chain 2: -#> Chain 2: Elapsed Time: 2.63571 seconds (Warm-up) -#> Chain 2: 1.91633 seconds (Sampling) -#> Chain 2: 4.55204 seconds (Total) -#> Chain 2: -#> -#> SAMPLING FOR MODEL '28c89f5948288d3bb37fc72d345573dc' NOW (CHAIN 3). -#> Chain 3: -#> Chain 3: Gradient evaluation took 5e-05 seconds -#> Chain 3: 1000 transitions using 10 leapfrog steps per transition would take 0.5 seconds. -#> Chain 3: Adjust your expectations accordingly! -#> Chain 3: -#> Chain 3: -#> Chain 3: Iteration: 1 / 2000 [ 0%] (Warmup) -#> Chain 3: Iteration: 200 / 2000 [ 10%] (Warmup) -#> Chain 3: Iteration: 400 / 2000 [ 20%] (Warmup) -#> Chain 3: Iteration: 600 / 2000 [ 30%] (Warmup) -#> Chain 3: Iteration: 800 / 2000 [ 40%] (Warmup) -#> Chain 3: Iteration: 1000 / 2000 [ 50%] (Warmup) -#> Chain 3: Iteration: 1001 / 2000 [ 50%] (Sampling) -#> Chain 3: Iteration: 1200 / 2000 [ 60%] (Sampling) -#> Chain 3: Iteration: 1400 / 2000 [ 70%] (Sampling) -#> Chain 3: Iteration: 1600 / 2000 [ 80%] (Sampling) -#> Chain 3: Iteration: 1800 / 2000 [ 90%] (Sampling) -#> Chain 3: Iteration: 2000 / 2000 [100%] (Sampling) -#> Chain 3: -#> Chain 3: Elapsed Time: 2.65226 seconds (Warm-up) -#> Chain 3: 2.34511 seconds (Sampling) -#> Chain 3: 4.99737 seconds (Total) -#> Chain 3: -#> -#> SAMPLING FOR MODEL '28c89f5948288d3bb37fc72d345573dc' NOW (CHAIN 4). -#> Chain 4: -#> Chain 4: Gradient evaluation took 8.3e-05 seconds -#> Chain 4: 1000 transitions using 10 leapfrog steps per transition would take 0.83 seconds. -#> Chain 4: Adjust your expectations accordingly! -#> Chain 4: -#> Chain 4: -#> Chain 4: Iteration: 1 / 2000 [ 0%] (Warmup) -#> Chain 4: Iteration: 200 / 2000 [ 10%] (Warmup) -#> Chain 4: Iteration: 400 / 2000 [ 20%] (Warmup) -#> Chain 4: Iteration: 600 / 2000 [ 30%] (Warmup) -#> Chain 4: Iteration: 800 / 2000 [ 40%] (Warmup) -#> Chain 4: Iteration: 1000 / 2000 [ 50%] (Warmup) -#> Chain 4: Iteration: 1001 / 2000 [ 50%] (Sampling) -#> Chain 4: Iteration: 1200 / 2000 [ 60%] (Sampling) -#> Chain 4: Iteration: 1400 / 2000 [ 70%] (Sampling) -#> Chain 4: Iteration: 1600 / 2000 [ 80%] (Sampling) -#> Chain 4: Iteration: 1800 / 2000 [ 90%] (Sampling) -#> Chain 4: Iteration: 2000 / 2000 [100%] (Sampling) -#> Chain 4: -#> Chain 4: Elapsed Time: 2.58846 seconds (Warm-up) -#> Chain 4: 1.98516 seconds (Sampling) -#> Chain 4: 4.57362 seconds (Total) -#> Chain 4:

+)

The mig_estimate_rc function also allows for addition arguments that are related to the Stan model. In the example above, the values listed for chains, iter, adapt_delta and max_treedepth are the default values, so need have not been specified. However, depending on the context, it may make sense to increase the value of each of these components to ensure convergence. More details about these arguments can be found in the R help files for rstan::stan, and also by referring to the Stan documentation.

The resulting rc_res object is shown below. The pars_df shows the median estimate and lower and upper bound of a 95% credible interval for the Rogers-Castro parameters. In this example, the working age peak was estimated to be at 25.3 years (95% CI: [23.5, 27.2]).

The fit_df object in rc_res shows the data and estimated median \(m(x)\) values at each age \(x\), along with the lower and upper bound of the 95% credible interval of the fits, and the squared difference between data and the median estimate.

-rc_res
-#> $pars_df
-#> # A tibble: 11 x 4
-#>    variable   median    lower    upper
-#>    <chr>       <dbl>    <dbl>    <dbl>
-#>  1 variable  0.00417  0.00222  0.00624
-#>  2 variable  0.0598   0.0527   0.0658 
-#>  3 variable  0.0220   0.0178   0.0265 
-#>  4 variable  0.308    0.114    1.09   
-#>  5 variable  0.181    0.156    0.204  
-#>  6 variable  0.169    0.135    0.208  
-#>  7 variable  0.0193   0.0177   0.0202 
-#>  8 variable  0.130    0.119    0.145  
-#>  9 variable  0.110    0.0936   0.129  
-#> 10 variable 25.4     23.6     27.1    
-#> 11 variable 65.1     63.1     67.0    
-#> 
-#> $fit_df
-#> # A tibble: 81 x 6
-#>      age   data median  lower  upper       diff_sq
-#>    <int>  <dbl>  <dbl>  <dbl>  <dbl>         <dbl>
-#>  1     0 0.0234 0.0234 0.0217 0.0252 0.00000000428
-#>  2     1 0.0220 0.0222 0.0210 0.0233 0.0000000624 
-#>  3     2 0.0212 0.0214 0.0203 0.0223 0.0000000479 
-#>  4     3 0.0218 0.0209 0.0199 0.0217 0.000000972  
-#>  5     4 0.0210 0.0205 0.0197 0.0213 0.000000235  
-#>  6     5 0.0208 0.0202 0.0195 0.0209 0.000000323  
-#>  7     6 0.0198 0.0200 0.0193 0.0207 0.0000000352 
-#>  8     7 0.0207 0.0199 0.0192 0.0205 0.000000622  
-#>  9     8 0.0182 0.0198 0.0191 0.0205 0.00000274   
-#> 10     9 0.0186 0.0199 0.0192 0.0205 0.00000149   
-#> # … with 71 more rows
+rc_res

We can plot the observed data and estimated fit using the fit_df object:

 rc_res[["fit_df"]] %>%
@@ -414,7 +262,6 @@ 

geom_ribbon(aes(ymin = lower, ymax = upper), alpha = 0.2) + scale_color_manual(name = "", values = c(data = "red", fit = "black")) + ylab("migration rate")

-

diff --git a/docs/articles/smoothing_with_demotools.html b/docs/articles/smoothing_with_demotools.html index 32bb9fc24..84a1ddd83 100644 --- a/docs/articles/smoothing_with_demotools.html +++ b/docs/articles/smoothing_with_demotools.html @@ -38,7 +38,7 @@ DemoTools - 01.11.03 + 01.13.40

@@ -114,7 +114,7 @@

Smoothing with DemoTools

Jose Manuel Aburto, Ilya Kashnitsky, Marius Pascariu, Tim Riffe

-

2021-01-12

+

2021-04-09

Source: vignettes/smoothing_with_demotools.Rmd diff --git a/docs/authors.html b/docs/authors.html index df79cd24e..6fcd99294 100644 --- a/docs/authors.html +++ b/docs/authors.html @@ -79,7 +79,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -184,6 +184,10 @@

Authors

Sean Fennell. Author.

+
  • +

    Peter Johnson. Contributor. +

    +
  • Jorge Cimentada. Contributor.

    diff --git a/docs/index.html b/docs/index.html index 6826bac71..67aaa9864 100644 --- a/docs/index.html +++ b/docs/index.html @@ -38,7 +38,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -114,12 +114,13 @@
    -

    R build status codecov issues lifecycle

    +

    R build status codecov

    +

    issues lifecycle

    Tools for aggregate demographic analysis

    -

    Date: 2021-01-12

    +

    Date: 2021-04-01

    DemoTools is an R package that contains simple functions often used in demographic analysis. It is in active development.

    This project is commissioned by the UN Population Division and financed by the Bill and Melinda Gates Foundation as part of the Making Family Planning Count project. Work is also done in collaboration with Sean Fennell, José Manuel Aburto, Ilya Kashnitsky, Marius Pascariu, Jorge Cimentada, Monica Alexander, and with minor contributions from several more (thank you!). This work is licensed under the Creative Commons Attribution-ShareAlike 3.0 IGO (CC BY-SA 3.0 IGO).

    The idea behind DemoTools is to provide a common set of functions that can be easily used by analysts and scientists working on demographic analysis and modelling.

    @@ -133,7 +134,8 @@

    # install.packages("devtools") library(devtools) - +# requires the development version of rstan, sorry! +install.packages("rstan", repos = c("https://mc-stan.org/r-packages/", getOption("repos"))) install_github("timriffe/DemoTools")

    diff --git a/docs/news/index.html b/docs/news/index.html index 496cdb3a3..8f46880c4 100644 --- a/docs/news/index.html +++ b/docs/news/index.html @@ -79,7 +79,7 @@ DemoTools - 01.11.03 + 01.13.40
    diff --git a/docs/pkgdown.yml b/docs/pkgdown.yml index a640001eb..331bf70d6 100644 --- a/docs/pkgdown.yml +++ b/docs/pkgdown.yml @@ -8,7 +8,7 @@ articles: lifetables_with_demotools: lifetables_with_demotools.html migration_with_demotools: migration_with_demotools.html smoothing_with_demotools: smoothing_with_demotools.html -last_built: 2021-01-12T14:22Z +last_built: 2021-04-09T19:48Z urls: reference: https://timriffe.github.io/DemoTools//reference article: https://timriffe.github.io/DemoTools//articles diff --git a/docs/reference/ADM.html b/docs/reference/ADM.html index 74e407b70..ac75b4470 100644 --- a/docs/reference/ADM.html +++ b/docs/reference/ADM.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/AGEN.html b/docs/reference/AGEN.html index f1c999a55..b2abd0983 100644 --- a/docs/reference/AGEN.html +++ b/docs/reference/AGEN.html @@ -81,7 +81,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/DemoTools-package.html b/docs/reference/DemoTools-package.html index e9b44b30c..e04dcf6d2 100644 --- a/docs/reference/DemoTools-package.html +++ b/docs/reference/DemoTools-package.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -184,6 +184,7 @@

    Author

    Other contributors:

      +
    • Peter Johnson [contributor]

    • Jorge Cimentada (ORCID) [contributor]

    • Juan Galeano (ORCID) [contributor]

    • Derek Burk [contributor]

    • diff --git a/docs/reference/ID.html b/docs/reference/ID.html index 6cdbf051c..2d9aef32d 100644 --- a/docs/reference/ID.html +++ b/docs/reference/ID.html @@ -83,7 +83,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/IRD.html b/docs/reference/IRD.html index ca78482ef..896681a79 100644 --- a/docs/reference/IRD.html +++ b/docs/reference/IRD.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/OPAG_simple.html b/docs/reference/OPAG_simple.html index 927b727be..72d459848 100644 --- a/docs/reference/OPAG_simple.html +++ b/docs/reference/OPAG_simple.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/RDM.html b/docs/reference/RDM.html index e85f9815c..992d93ad8 100644 --- a/docs/reference/RDM.html +++ b/docs/reference/RDM.html @@ -83,7 +83,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/age2ageN.html b/docs/reference/age2ageN.html index 520b50ae6..f134bc8d0 100644 --- a/docs/reference/age2ageN.html +++ b/docs/reference/age2ageN.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/age2int.html b/docs/reference/age2int.html index 900fc51d1..41becb8bf 100644 --- a/docs/reference/age2int.html +++ b/docs/reference/age2int.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/ageRatioScore.html b/docs/reference/ageRatioScore.html index 29a081c35..83949408b 100644 --- a/docs/reference/ageRatioScore.html +++ b/docs/reference/ageRatioScore.html @@ -82,7 +82,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/ageSexAccuracy.html b/docs/reference/ageSexAccuracy.html index b846eba89..9b11fe2ab 100644 --- a/docs/reference/ageSexAccuracy.html +++ b/docs/reference/ageSexAccuracy.html @@ -82,7 +82,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/ageSexAccuracyDasGupta.html b/docs/reference/ageSexAccuracyDasGupta.html index 4c06e79ee..37705685c 100644 --- a/docs/reference/ageSexAccuracyDasGupta.html +++ b/docs/reference/ageSexAccuracyDasGupta.html @@ -81,7 +81,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/age_abridge_force.html b/docs/reference/age_abridge_force.html index 2ec24df4a..5d75614c6 100644 --- a/docs/reference/age_abridge_force.html +++ b/docs/reference/age_abridge_force.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/agesmth1.html b/docs/reference/agesmth1.html index eecb13a7c..f951145bf 100644 --- a/docs/reference/agesmth1.html +++ b/docs/reference/agesmth1.html @@ -83,7 +83,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/avg_adj.html b/docs/reference/avg_adj.html index e126bde6d..70924780d 100644 --- a/docs/reference/avg_adj.html +++ b/docs/reference/avg_adj.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/birthCohorts.html b/docs/reference/birthCohorts.html index 72856580a..73e034a4d 100644 --- a/docs/reference/birthCohorts.html +++ b/docs/reference/birthCohorts.html @@ -82,7 +82,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/calcAgeAbr.html b/docs/reference/calcAgeAbr.html index 6b4c81c9a..32a6e537d 100644 --- a/docs/reference/calcAgeAbr.html +++ b/docs/reference/calcAgeAbr.html @@ -81,7 +81,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/calcAgeN.html b/docs/reference/calcAgeN.html index 2546a9bc9..df83ce34c 100644 --- a/docs/reference/calcAgeN.html +++ b/docs/reference/calcAgeN.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/check_heaping_bachi.html b/docs/reference/check_heaping_bachi.html index 1d3fddaa9..4ff529189 100644 --- a/docs/reference/check_heaping_bachi.html +++ b/docs/reference/check_heaping_bachi.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -166,9 +166,10 @@

      calculate Bachi's index of age heaping

      Value, Age, ageMin = 23, - ageMax = 77, + ageMax = NULL, method = "orig", - details = FALSE + details = FALSE, + OAG = TRUE )

      Arguments

      @@ -198,6 +199,10 @@

      Arg details

      logical. Should a list of output be given

      + + OAG +

      logical. Is the highest age group open?

      +

      Value

      @@ -206,7 +211,7 @@

      Value

      Details

      ageMax is an inclusive upper bound, treated as interval. If you want ages -23 to 77, then give ageMin = 23 and ageMax = 77, not 80. The ageMin is respected strictly, whereas ageMax could be higher than the actual maximum age used. You can see the age ranges actually used by specifying details = TRUE.

      +23 to 77, then give ageMin = 23 and ageMax = 77. The ageMin is respected strictly, whereas ageMax is calculated flexibly- if you specify something too high then it is reduced and we warn accordingly, and if it's missing then we pick something reasonable. You can see the age ranges actually used by specifying details = TRUE.

      References

      United States Census Bureau (2017). @@ -222,17 +227,22 @@

      R US Bureau of the Census.

      Examples

      -
      Age <- 0:99 - check_heaping_bachi(pop1m_pasex, Age, ageMin = 23, ageMax = 77, method = "orig") -
      #> [1] 28.93849
      check_heaping_bachi(pop1m_ind, Age, ageMin = 23, ageMax = 77, method = "orig") +
      check_heaping_bachi(pop1m_pasex, Age = 0:99, + ageMin = 23, ageMax = 77, method = "orig", OAG =FALSE) +
      #> [1] 28.93849
      check_heaping_bachi(pop1m_ind, Age = 0:100, + ageMin = 23, ageMax = 77, method = "orig")
      #> [1] 41.2661
      # default simpler - check_heaping_bachi(pop1m_pasex, Age, ageMin = 23, ageMax = 77, method = "pasex") + check_heaping_bachi(pop1m_pasex, Age = 0:99, + ageMin = 23, ageMax = 77, method = "pasex", OAG = FALSE)
      #> [1] 28.96891
      # linear population, should give 0 for pasex - check_heaping_bachi(seq(100000,1000,by=-1000),Age, ageMin = 23, ageMax = 77, method = "pasex") + check_heaping_bachi(seq(100000,1000,by=-1000),Age = 0:99, + ageMin = 23, ageMax = 77, method = "pasex", OAG = FALSE)
      #> [1] 0
      # fully concentrated, should give 90 pop_concetrated <- rep(c(100,rep(0,9)),10) - check_heaping_bachi(pop_concetrated,Age, ageMin = 23, ageMax = 77, method = "pasex") -
      #> [1] 90
      check_heaping_bachi(pop_concetrated,Age, ageMin = 23, ageMax = 77, method = "orig") + check_heaping_bachi(pop_concetrated, Age = 0:99, + ageMin = 23, ageMax = 77, method = "pasex") +
      #> [1] 90
      check_heaping_bachi(pop_concetrated, Age = 0:99, + ageMin = 23, ageMax = 77, method = "orig")
      #> [1] 90
      diff --git a/docs/reference/check_heaping_jdanov.html b/docs/reference/check_heaping_jdanov.html index 635eb860f..4ab4f03ae 100644 --- a/docs/reference/check_heaping_jdanov.html +++ b/docs/reference/check_heaping_jdanov.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/check_heaping_kannisto.html b/docs/reference/check_heaping_kannisto.html index c06f6c4c6..64c40eb67 100644 --- a/docs/reference/check_heaping_kannisto.html +++ b/docs/reference/check_heaping_kannisto.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/check_heaping_myers.html b/docs/reference/check_heaping_myers.html index 1a3cc7eb1..3fb2238c2 100644 --- a/docs/reference/check_heaping_myers.html +++ b/docs/reference/check_heaping_myers.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/check_heaping_noumbissi.html b/docs/reference/check_heaping_noumbissi.html index d640116a1..e43926434 100644 --- a/docs/reference/check_heaping_noumbissi.html +++ b/docs/reference/check_heaping_noumbissi.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/check_heaping_roughness.html b/docs/reference/check_heaping_roughness.html index 9481bb240..272ad2556 100644 --- a/docs/reference/check_heaping_roughness.html +++ b/docs/reference/check_heaping_roughness.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/check_heaping_sawtooth.html b/docs/reference/check_heaping_sawtooth.html index 4ef5e02a9..5a12a9dbf 100644 --- a/docs/reference/check_heaping_sawtooth.html +++ b/docs/reference/check_heaping_sawtooth.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/check_heaping_spoorenberg.html b/docs/reference/check_heaping_spoorenberg.html index cac6a3bc8..231b2a2a7 100644 --- a/docs/reference/check_heaping_spoorenberg.html +++ b/docs/reference/check_heaping_spoorenberg.html @@ -81,7 +81,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/check_heaping_whipple.html b/docs/reference/check_heaping_whipple.html index c990accc1..6fb0570b9 100644 --- a/docs/reference/check_heaping_whipple.html +++ b/docs/reference/check_heaping_whipple.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/dec.date.html b/docs/reference/dec.date.html index 272ce95d2..b353522df 100644 --- a/docs/reference/dec.date.html +++ b/docs/reference/dec.date.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/dth5_zigzag.html b/docs/reference/dth5_zigzag.html index 317aaed57..304e9e113 100644 --- a/docs/reference/dth5_zigzag.html +++ b/docs/reference/dth5_zigzag.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/fitted_logquad_b.html b/docs/reference/fitted_logquad_b.html index bcc6c1c65..9bb95a72c 100644 --- a/docs/reference/fitted_logquad_b.html +++ b/docs/reference/fitted_logquad_b.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/fitted_logquad_f.html b/docs/reference/fitted_logquad_f.html index 795554bb1..94401cfc6 100644 --- a/docs/reference/fitted_logquad_f.html +++ b/docs/reference/fitted_logquad_f.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/fitted_logquad_m.html b/docs/reference/fitted_logquad_m.html index 9fb4b38df..c7cbecfad 100644 --- a/docs/reference/fitted_logquad_m.html +++ b/docs/reference/fitted_logquad_m.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/getModelLifeTable.html b/docs/reference/getModelLifeTable.html index fe3822941..8dce53426 100644 --- a/docs/reference/getModelLifeTable.html +++ b/docs/reference/getModelLifeTable.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/graduate.html b/docs/reference/graduate.html index 415c59987..01092870c 100644 --- a/docs/reference/graduate.html +++ b/docs/reference/graduate.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -503,58 +503,74 @@

      Examp #> 98 99 100 #> 3.7144 6.4474 0.0000
      graduate(Value, Age, method = "mono") -
      #> 0 1 2 3 4 5 6 7 -#> 10000.000 10945.000 11401.250 11270.625 10553.125 9665.128 9122.756 8767.692 -#> 8 9 10 11 12 13 14 15 -#> 8599.936 8619.488 8655.760 8567.160 8453.480 8314.720 8150.880 7993.120 -#> 16 17 18 19 20 21 22 23 -#> 7852.080 7701.920 7542.640 7374.240 7205.232 7042.304 6880.288 6719.184 -#> 24 25 26 27 28 29 30 31 -#> 6558.992 6389.728 6219.856 6063.592 5920.936 5791.888 5662.824 5524.688 -#> 32 33 34 35 36 37 38 39 -#> 5386.576 5248.488 5110.424 4963.192 4815.944 4682.448 4562.704 4456.712 -#> 40 41 42 43 44 45 46 47 -#> 4370.464 4275.048 4150.016 3995.368 3811.104 3596.888 3402.416 3252.872 -#> 48 49 50 51 52 53 54 55 -#> 3148.256 3088.568 3062.144 3005.768 2899.496 2743.328 2537.264 2285.088 -#> 56 57 58 59 60 61 62 63 -#> 2066.176 1916.432 1835.856 1824.448 1849.056 1827.552 1752.024 1622.472 -#> 64 65 66 67 68 69 70 71 -#> 1438.896 1215.528 1028.176 900.512 832.536 824.248 821.544 779.048 -#> 72 73 74 75 76 77 78 79 -#> 728.176 668.928 601.304 526.576 457.432 398.944 351.112 313.936 -#> 80 81 82 83 84 85 86 87 -#> 268.888 216.736 176.392 147.856 131.128 108.496 77.992 56.344 -#> 88 89 90 91 92 93 94 95 -#> 43.552 39.616 32.752 19.984 11.608 7.624 8.032 7.432 -#> 96 97 98 99 100 -#> 3.904 1.888 1.384 2.392 0.000
      graduate(Value, Age, method = "mono", keep0=TRUE) -
      #> 0 1 2 3 4 5 6 7 -#> 10000.000 10945.000 11401.250 11270.625 10553.125 9665.128 9122.756 8767.692 -#> 8 9 10 11 12 13 14 15 -#> 8599.936 8619.488 8655.760 8567.160 8453.480 8314.720 8150.880 7993.120 -#> 16 17 18 19 20 21 22 23 -#> 7852.080 7701.920 7542.640 7374.240 7205.232 7042.304 6880.288 6719.184 -#> 24 25 26 27 28 29 30 31 -#> 6558.992 6389.728 6219.856 6063.592 5920.936 5791.888 5662.824 5524.688 -#> 32 33 34 35 36 37 38 39 -#> 5386.576 5248.488 5110.424 4963.192 4815.944 4682.448 4562.704 4456.712 -#> 40 41 42 43 44 45 46 47 -#> 4370.464 4275.048 4150.016 3995.368 3811.104 3596.888 3402.416 3252.872 -#> 48 49 50 51 52 53 54 55 -#> 3148.256 3088.568 3062.144 3005.768 2899.496 2743.328 2537.264 2285.088 -#> 56 57 58 59 60 61 62 63 -#> 2066.176 1916.432 1835.856 1824.448 1849.056 1827.552 1752.024 1622.472 -#> 64 65 66 67 68 69 70 71 -#> 1438.896 1215.528 1028.176 900.512 832.536 824.248 821.544 779.048 -#> 72 73 74 75 76 77 78 79 -#> 728.176 668.928 601.304 526.576 457.432 398.944 351.112 313.936 -#> 80 81 82 83 84 85 86 87 -#> 268.888 216.736 176.392 147.856 131.128 108.496 77.992 56.344 -#> 88 89 90 91 92 93 94 95 -#> 43.552 39.616 32.752 19.984 11.608 7.624 8.032 7.432 -#> 96 97 98 99 100 -#> 3.904 1.888 1.384 2.392 0.000
      +
      #> 0 1 2 3 4 5 +#> 10000.000000 10850.481727 11280.016176 11257.267224 10782.234872 9965.472958 +#> 6 7 8 9 10 11 +#> 9249.196842 8743.960363 8449.763521 8366.606317 8447.848263 8506.927414 +#> 12 13 14 15 16 17 +#> 8497.203282 8418.675868 8271.345172 8069.013989 7866.893502 7678.786508 +#> 18 19 20 21 22 23 +#> 7504.693006 7344.612996 7195.295781 7043.738577 6886.690686 6724.152109 +#> 24 25 26 27 28 29 +#> 6556.122846 6385.146886 6221.400190 6067.426747 5923.226557 5788.799621 +#> 30 31 32 33 34 35 +#> 5661.452674 5530.412664 5392.986327 5249.173663 5098.974671 4946.090416 +#> 36 37 38 39 40 41 +#> 4805.325153 4680.379945 4571.254792 4477.949695 4392.929661 4286.054725 +#> 42 43 44 45 46 47 +#> 4149.789895 3984.135169 3789.090550 3576.638938 3394.711946 3255.292477 +#> 48 49 50 51 52 53 +#> 3158.380531 3103.976107 3076.530586 3013.849489 2900.384196 2736.134707 +#> 54 55 56 57 58 59 +#> 2521.101022 2273.886718 2068.906098 1924.762739 1841.456641 1818.987804 +#> 60 61 62 63 64 65 +#> 1838.178543 1822.318119 1752.228848 1627.910728 1449.363761 1233.631109 +#> 66 67 68 69 70 71 +#> 1048.885424 912.169870 823.484446 782.829152 779.113021 767.972184 +#> 72 73 74 75 76 77 +#> 738.315673 690.143490 623.455633 542.884808 466.961841 400.319437 +#> 78 79 80 81 82 83 +#> 342.957596 294.876318 254.979747 218.884453 185.494579 154.810127 +#> 84 85 86 87 88 89 +#> 126.831094 101.692205 79.932348 61.686245 46.953897 35.735304 +#> 90 91 92 93 94 95 +#> 27.603433 20.850155 15.048439 10.198284 6.299690 3.438064 +#> 96 97 98 99 100 +#> 1.955032 1.936000 3.380968 6.289936 0.000000
      graduate(Value, Age, method = "mono", keep0=TRUE) +
      #> 0 1 2 3 4 5 +#> 10000.000000 10850.481727 11280.016176 11257.267224 10782.234872 9965.472958 +#> 6 7 8 9 10 11 +#> 9249.196842 8743.960363 8449.763521 8366.606317 8447.848263 8506.927414 +#> 12 13 14 15 16 17 +#> 8497.203282 8418.675868 8271.345172 8069.013989 7866.893502 7678.786508 +#> 18 19 20 21 22 23 +#> 7504.693006 7344.612996 7195.295781 7043.738577 6886.690686 6724.152109 +#> 24 25 26 27 28 29 +#> 6556.122846 6385.146886 6221.400190 6067.426747 5923.226557 5788.799621 +#> 30 31 32 33 34 35 +#> 5661.452674 5530.412664 5392.986327 5249.173663 5098.974671 4946.090416 +#> 36 37 38 39 40 41 +#> 4805.325153 4680.379945 4571.254792 4477.949695 4392.929661 4286.054725 +#> 42 43 44 45 46 47 +#> 4149.789895 3984.135169 3789.090550 3576.638938 3394.711946 3255.292477 +#> 48 49 50 51 52 53 +#> 3158.380531 3103.976107 3076.530586 3013.849489 2900.384196 2736.134707 +#> 54 55 56 57 58 59 +#> 2521.101022 2273.886718 2068.906098 1924.762739 1841.456641 1818.987804 +#> 60 61 62 63 64 65 +#> 1838.178543 1822.318119 1752.228848 1627.910728 1449.363761 1233.631109 +#> 66 67 68 69 70 71 +#> 1048.885424 912.169870 823.484446 782.829152 779.113021 767.972184 +#> 72 73 74 75 76 77 +#> 738.315673 690.143490 623.455633 542.884808 466.961841 400.319437 +#> 78 79 80 81 82 83 +#> 342.957596 294.876318 254.979747 218.884453 185.494579 154.810127 +#> 84 85 86 87 88 89 +#> 126.831094 101.692205 79.932348 61.686245 46.953897 35.735304 +#> 90 91 92 93 94 95 +#> 27.603433 20.850155 15.048439 10.198284 6.299690 3.438064 +#> 96 97 98 99 100 +#> 1.955032 1.936000 3.380968 6.289936 0.000000
      graduate(Value, Age, method = "uniform")
      #> 0 1 2 3 4 5 6 7 8 9 #> 10000.0 11042.5 11042.5 11042.5 11042.5 8955.0 8955.0 8955.0 8955.0 8955.0 @@ -579,74 +595,76 @@

      Examp #> 100 #> 0.0

      graduate(Value, Age, method = "pclm") -
      #> 0 1 2 3 4 5 -#> 10022.206163 10787.283969 11254.932560 11275.885640 10807.951426 10074.821803 +
      #> +#> 0s detected in Value, replacing with .01
      #> 0 1 2 3 4 5 +#> 10022.215011 10787.284952 11254.927496 11275.878143 10807.945739 10074.820067 #> 6 7 8 9 10 11 -#> 9328.988743 8736.949690 8394.290482 8273.419213 8318.185348 8432.064234 +#> 9328.990796 8736.954125 8394.295365 8273.422999 8318.186993 8432.063491 #> 12 13 14 15 16 17 -#> 8510.164398 8497.044473 8366.765820 8151.826916 7903.088275 7662.042020 +#> 8510.161956 8497.041471 8366.763508 8151.826000 7903.088751 7662.043415 #> 18 19 20 21 22 23 -#> 7459.547646 7296.414763 7161.468632 7035.158814 6896.995478 6740.484441 +#> 7459.549205 7296.415869 7161.468953 7035.158379 6896.994675 6740.483732 #> 24 25 26 27 28 29 -#> 6566.732479 6387.045673 6215.809170 6060.717420 5925.005956 5801.821192 +#> 6566.732244 6387.046021 6215.809887 6060.718142 5925.006272 5801.820878 #> 30 31 32 33 34 35 -#> 5679.678101 5548.089016 5398.665319 5234.736857 5066.280112 4908.164620 +#> 5679.677222 5548.087900 5398.664503 5234.736788 5066.280979 4908.166239 #> 36 37 38 39 40 41 -#> 4776.277248 4674.567053 4598.978778 4531.954680 4447.598716 4325.845343 +#> 4776.279042 4674.568328 4598.978894 4531.953370 4447.596302 4325.842634 #> 42 43 44 45 46 47 -#> 4153.831515 3942.404243 3717.818155 3511.254514 3353.612942 3254.021669 +#> 4153.829634 3942.404051 3717.819885 3511.257711 3353.616522 3254.024392 #> 48 49 50 51 52 53 -#> 3206.436723 3185.639207 3149.061722 3061.490650 2899.845842 2676.397236 +#> 3206.437472 3185.637396 3149.057773 3061.485893 2899.842199 2676.396203 #> 54 55 56 57 58 59 -#> 2430.916306 2205.094663 2036.287305 1935.376745 1895.248588 1894.350582 +#> 2430.918221 2205.098825 2036.292265 1935.380956 1895.250695 1894.349683 #> 60 61 62 63 64 65 -#> 1891.972240 1851.214010 1745.251332 1577.505631 1381.551282 1192.256351 +#> 1891.968480 1851.208656 1745.246503 1577.503189 1381.551771 1192.259169 #> 66 67 68 69 70 71 -#> 1038.626280 929.281152 859.265601 818.951293 792.503364 766.385429 +#> 1038.630146 929.284818 859.268151 818.952155 792.502498 766.383286 #> 72 73 74 75 76 77 -#> 729.252758 676.036519 610.318840 538.450939 468.333489 404.619331 +#> 729.250203 676.034501 610.317890 538.451097 468.334362 404.620404 #> 78 79 80 81 82 83 -#> 348.592064 299.924683 257.028970 218.668992 184.007104 152.690098 +#> 348.592969 299.925248 257.029245 218.669115 184.007169 152.690106 #> 84 85 86 87 88 89 -#> 124.764602 100.309353 79.377465 61.866165 47.547799 36.084595 +#> 124.764414 100.308814 79.376504 61.864847 47.546364 36.083333 #> 90 91 92 93 94 95 -#> 27.084347 20.136711 14.848708 10.871851 7.909705 5.722058 +#> 27.083527 20.136500 14.849153 10.872898 7.911233 5.723911 #> 96 97 98 99 100 -#> 4.118689 2.951838 2.108558 1.502782 1.069736
      graduate(Value, Age, method = "pclm", keep0=TRUE) -
      #> 0 1 2 3 4 5 -#> 10000.000000 10798.027335 11266.141671 11287.115619 10818.715375 10074.821803 +#> 4.120705 2.953872 2.110491 1.504532 1.071260
      graduate(Value, Age, method = "pclm", keep0=TRUE) +
      #> +#> 0s detected in Value, replacing with .01
      #> 0 1 2 3 4 5 +#> 10000.000000 10798.032544 11266.141010 11287.112530 10818.713916 10074.820067 #> 6 7 8 9 10 11 -#> 9328.988743 8736.949690 8394.290482 8273.419213 8318.185348 8432.064234 +#> 9328.990796 8736.954125 8394.295365 8273.422999 8318.186993 8432.063491 #> 12 13 14 15 16 17 -#> 8510.164398 8497.044473 8366.765820 8151.826916 7903.088275 7662.042020 +#> 8510.161956 8497.041471 8366.763508 8151.826000 7903.088751 7662.043415 #> 18 19 20 21 22 23 -#> 7459.547646 7296.414763 7161.468632 7035.158814 6896.995478 6740.484441 +#> 7459.549205 7296.415869 7161.468953 7035.158379 6896.994675 6740.483732 #> 24 25 26 27 28 29 -#> 6566.732479 6387.045673 6215.809170 6060.717420 5925.005956 5801.821192 +#> 6566.732244 6387.046021 6215.809887 6060.718142 5925.006272 5801.820878 #> 30 31 32 33 34 35 -#> 5679.678101 5548.089016 5398.665319 5234.736857 5066.280112 4908.164620 +#> 5679.677222 5548.087900 5398.664503 5234.736788 5066.280979 4908.166239 #> 36 37 38 39 40 41 -#> 4776.277248 4674.567053 4598.978778 4531.954680 4447.598716 4325.845343 +#> 4776.279042 4674.568328 4598.978894 4531.953370 4447.596302 4325.842634 #> 42 43 44 45 46 47 -#> 4153.831515 3942.404243 3717.818155 3511.254514 3353.612942 3254.021669 +#> 4153.829634 3942.404051 3717.819885 3511.257711 3353.616522 3254.024392 #> 48 49 50 51 52 53 -#> 3206.436723 3185.639207 3149.061722 3061.490650 2899.845842 2676.397236 +#> 3206.437472 3185.637396 3149.057773 3061.485893 2899.842199 2676.396203 #> 54 55 56 57 58 59 -#> 2430.916306 2205.094663 2036.287305 1935.376745 1895.248588 1894.350582 +#> 2430.918221 2205.098825 2036.292265 1935.380956 1895.250695 1894.349683 #> 60 61 62 63 64 65 -#> 1891.972240 1851.214010 1745.251332 1577.505631 1381.551282 1192.256351 +#> 1891.968480 1851.208656 1745.246503 1577.503189 1381.551771 1192.259169 #> 66 67 68 69 70 71 -#> 1038.626280 929.281152 859.265601 818.951293 792.503364 766.385429 +#> 1038.630146 929.284818 859.268151 818.952155 792.502498 766.383286 #> 72 73 74 75 76 77 -#> 729.252758 676.036519 610.318840 538.450939 468.333489 404.619331 +#> 729.250203 676.034501 610.317890 538.451097 468.334362 404.620404 #> 78 79 80 81 82 83 -#> 348.592064 299.924683 257.028970 218.668992 184.007104 152.690098 +#> 348.592969 299.925248 257.029245 218.669115 184.007169 152.690106 #> 84 85 86 87 88 89 -#> 124.764602 100.309353 79.377465 61.866165 47.547799 36.084595 +#> 124.764414 100.308814 79.376504 61.864847 47.546364 36.083333 #> 90 91 92 93 94 95 -#> 27.084347 20.136711 14.848708 10.871851 7.909705 5.722058 +#> 27.083527 20.136500 14.849153 10.872898 7.911233 5.723911 #> 96 97 98 99 100 -#> 4.118689 2.951838 2.108558 1.502782 1.069736
      # pclm can also graduate rates if both +#> 4.120705 2.953872 2.110491 1.504532 1.071260
      # pclm can also graduate rates if both # numerators and denominators are on hand: Exposures <- c(100958,466275,624134,559559,446736,370653,301862,249409, 247473,223014,172260,149338,127242,105715,79614,53660, diff --git a/docs/reference/graduate_beers.html b/docs/reference/graduate_beers.html index 1e41d287e..eccd5ce36 100644 --- a/docs/reference/graduate_beers.html +++ b/docs/reference/graduate_beers.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40
      @@ -162,7 +162,7 @@

      The ordinary modified Beers splitting methods

      This method offers both ordinary and modified Beers splitting, with an optional Demographic Analysis & Population Projection System Software adjustment johnson for ages under 10.

      -
      graduate_beers(Value, Age, AgeInt, OAG = TRUE, method = "mod", johnson = FALSE)
      +
      graduate_beers(Value, Age, AgeInt, OAG = TRUE, method = "ord", johnson = FALSE)

      Arguments

      @@ -185,11 +185,11 @@

      Arg

      - + - +
      method

      character. Valid values are "mod" or "ord". Default "mod".

      character. Valid values are "ord" or "mod". Default "ord".

      johnson

      logical. Whether or not to adjust young ages according to the Demographic Analysis & Population Projection System Software method. Default FALSE.

      logical. Whether or not to adjust young ages according to the Demographic Analysis & Population Projection System Software method. Default FALSE.

      @@ -199,7 +199,8 @@

      Value

      Details

      Ages should refer to lower age bounds. Value must be labelled with ages unless Age is given separately. There must be at least six 5-year age groups (including the open group, 5 otherwise). If you want the johnson adjustment then Value must contain a single-year estimate of the population count in age 0. That means Value must come either as standard abridged or single age data.

      -

      If the highest age does not end in a 0 or 5, and OAG == TRUE, then the open age will be grouped down to the next highest age ending in 0 or 5. If the highest age does not end in a 0 or 5, and OAG == FALSE, then results extend to single ages covering the entire 5-year age group.

      +

      method option "ord" conserves sums in 5-year age groups, whereas "mod" does some smoothing between 5-year age groups too, and is not constrained.

      +

      If the highest age does not end in a 0 or 5, and OAG == TRUE, then the open age will be grouped down to the next highest age ending in 0 or 5. If the highest age does not end in a 0 or 5, and OAG = FALSE, then results extend to single ages covering the entire 5-year age group.

      References

      Beers HS (1945). @@ -231,10 +232,10 @@

      Examp #> 25 30386 30605 30978 31439 31940
      p1 <- graduate_beers(p5[,1], Age = a5, OAG = FALSE) head(p1)
      #> 0 1 2 3 4 5 -#> 11952.235 11325.417 10766.300 10274.882 9851.165 9494.302
      # note some negatives in high ages +#> 11932.734 11342.324 10788.613 10280.289 9826.041 9435.405
      # note some negatives in high ages tail(p1)
      #> 99 100 101 102 103 104 -#> 0.3184 -0.0886 -0.2724 -0.2281 0.0443 0.5448
      sum(p1) - sum(p5[,1]) +#> 2.8740 2.8627 2.4001 1.1396 -1.2605 -5.1419
      sum(p1) - sum(p5[,1])
      #> [1] 0
      # another case, starting with single ages # note beers() groups ages. diff --git a/docs/reference/graduate_beers_expand.html b/docs/reference/graduate_beers_expand.html index f073f2bbf..5a435a9f0 100644 --- a/docs/reference/graduate_beers_expand.html +++ b/docs/reference/graduate_beers_expand.html @@ -82,7 +82,7 @@ DemoTools - 01.11.03 + 01.13.40
      diff --git a/docs/reference/graduate_beers_johnson.html b/docs/reference/graduate_beers_johnson.html index dea2a1ac4..ba7f5e32e 100644 --- a/docs/reference/graduate_beers_johnson.html +++ b/docs/reference/graduate_beers_johnson.html @@ -82,7 +82,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/graduate_grabill.html b/docs/reference/graduate_grabill.html index 2fd762ba1..54b71873f 100644 --- a/docs/reference/graduate_grabill.html +++ b/docs/reference/graduate_grabill.html @@ -81,7 +81,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -164,7 +164,7 @@

      The basic Grabill age-splitting method

      Sprague estimated single-age population counts for the first and final ten ages. Open age groups are preserved, as are annual totals.

      -
      graduate_grabill(Value, Age, OAG = TRUE)
      +
      graduate_grabill(Value, Age, AgeInt, OAG = TRUE)

      Arguments

      @@ -177,6 +177,10 @@

      Arg

      + + + + diff --git a/docs/reference/graduate_grabill_expand.html b/docs/reference/graduate_grabill_expand.html index 3c5b444b4..61a295325 100644 --- a/docs/reference/graduate_grabill_expand.html +++ b/docs/reference/graduate_grabill_expand.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/graduate_mono.html b/docs/reference/graduate_mono.html index 56a0cc382..b641c228b 100644 --- a/docs/reference/graduate_mono.html +++ b/docs/reference/graduate_mono.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -162,7 +162,7 @@

      Graduate age groups using a monotonic spline.

      Take the cumulative sum of Value and then run a monotonic spline through it. The first differences split back single-age estimates of Value. Optionally keep the open age group untouched.

      -
      graduate_mono(Value, AgeInt, Age, OAG = TRUE)
      +
      graduate_mono(Value, Age, AgeInt, OAG = TRUE)

      Arguments

      Age

      integer vector, lower bounds of age groups

      AgeInt

      integer vector, age interval widths

      OAG

      logical, default = TRUE is the final age group open?

      @@ -171,14 +171,14 @@

      Arg

      - - - - + + + + @@ -190,7 +190,7 @@

      Value

      Numeric. vector of single smoothed age counts.

      Details

      -

      The "monoH.FC" method of stats::splinefun() is used to fit the spline because 1) it passes exactly through the points, 2) it is monotonic and therefore guarantees positive counts, and 3) it seems to be a bit less wiggly (lower average first differences of split counts). Single-age data is returned as-is. If you want to use this function as a smoother you first need to group to non-single ages.

      +

      The "hyman" method of stats::splinefun() is used to fit the spline because 1) it passes exactly through the points, 2) it is monotonic and therefore guarantees positive counts, and 3) it seems to be a bit less wiggly (lower average first differences of split counts). Single-age data is returned as-is. If you want to use this function as a smoother you first need to group to non-single ages.

      References

      Fritsch FN, Carlson RE (1980). @@ -204,69 +204,80 @@

      Examp "10", "15", "20", "25", "30", "35", "40", "45", "50", "55", "60", "65", "70", "75", "80", "85", "90", "95", "100")) -# overwrite open age group with a single age estimate for that age -# (doesn't extrapolate) -graduate_mono(Value) -
      #> 0 1 2 3 4 5 6 7 -#> 17689.096 17653.592 17671.344 17742.352 17866.616 17984.832 18067.544 18159.328 -#> 8 9 10 11 12 13 14 15 -#> 18260.184 18370.112 18475.416 18574.672 18680.864 18793.992 18914.056 19033.000 -#> 16 17 18 19 20 21 22 23 -#> 19147.320 19263.320 19381.000 19500.360 19622.696 19743.912 19860.664 19972.952 -#> 24 25 26 27 28 29 30 31 -#> 20080.776 20196.120 20314.440 20421.480 20517.240 20601.720 20687.736 20781.272 -#> 32 33 34 35 36 37 38 39 -#> 20872.504 20961.432 21048.056 21128.104 21209.688 21301.136 21402.448 21513.624 -#> 40 41 42 43 44 45 46 47 -#> 21618.352 21716.504 21824.328 21941.824 22068.992 22222.144 22368.848 22476.576 -#> 48 49 50 51 52 53 54 55 -#> 22545.328 22575.104 22642.672 22736.224 22773.088 22753.264 22676.752 22644.112 -#> 56 57 58 59 60 61 62 63 -#> 22649.264 22588.608 22462.144 22269.872 22118.752 22011.504 21842.528 21611.824 -#> 64 65 66 67 68 69 70 71 -#> 21319.392 21034.528 20790.816 20535.752 20269.336 19991.568 19845.608 19707.216 -#> 72 73 74 75 76 77 78 79 -#> 19371.112 18837.296 18105.768 17465.200 16956.440 16311.240 15529.600 14611.520 -#> 80 81 82 83 84 85 86 87 -#> 13725.360 12930.160 12087.080 11196.120 10257.280 9269.208 8313.056 7430.752 -#> 88 89 90 91 92 93 94 95 -#> 6622.296 5887.688 5036.104 4135.288 3409.936 2860.048 2485.624 1914.640 -#> 96 97 98 99 100 -#> 1226.680 833.560 735.280 931.840 1110.000
      # or respect open age group +# if the last age group is closed, then it's best to use AgeInt, otherwise, +# one is assumed from the age siphoned from the names attribute of Value. +graduate_mono(Value, OAG = FALSE) +
      #> 0 1 2 3 4 5 6 +#> 17565.4135 17641.9827 17721.5760 17804.1933 17889.8345 17978.5187 18070.3217 +#> 7 8 9 10 11 12 13 +#> 18165.2623 18263.3406 18364.5567 18468.8156 18575.7386 18685.2308 18797.2922 +#> 14 15 16 17 18 19 20 +#> 18911.9229 19028.7708 19146.4281 19264.5427 19383.1146 19502.1439 19621.3811 +#> 21 22 23 24 25 26 27 +#> 19739.8291 19857.2386 19973.6094 20088.9417 20202.5367 20311.5993 20415.4310 +#> 28 29 30 31 32 33 34 +#> 20514.0317 20607.4013 20696.3123 20783.8535 20870.7974 20957.1439 21042.8930 +#> 35 36 37 38 39 40 41 +#> 21128.6463 21216.8106 21307.9874 21402.1768 21499.3788 21600.4704 21708.9601 +#> 42 43 44 45 46 47 48 +#> 21825.7249 21950.7648 22084.0798 22221.4960 22346.3171 22454.3691 22545.6520 +#> 49 50 51 52 53 54 55 +#> 22620.1659 22677.5137 22716.1076 22735.5508 22735.8432 22716.9847 22678.8334 +#> 56 57 58 59 60 61 62 +#> 22620.8204 22542.8037 22444.7833 22326.7592 22186.6569 22016.1788 21813.2503 +#> 63 64 65 66 67 68 69 +#> 21577.8715 21310.0425 21019.5630 20745.6326 20498.0511 20276.8185 20081.9348 +#> 70 71 72 73 74 75 76 +#> 19893.0670 19628.8829 19269.0494 18813.5665 18262.4342 17625.0648 16939.1078 +#> 77 78 79 80 81 82 83 +#> 16213.9754 15449.6676 14646.1844 13806.6336 12943.4459 12059.7291 11155.4832 +#> 84 85 86 87 88 89 90 +#> 10230.7082 9293.0808 8373.3085 7479.0681 6610.3596 5767.1829 4956.2991 +#> 91 92 93 94 95 96 97 +#> 4204.7519 3519.3024 2899.9505 2346.6962 1858.6909 1432.5399 1067.3944 +#> 98 99 100 101 102 103 104 +#> 763.2546 520.1203 338.1613 218.0567 159.9760 163.9193 229.8867
      # or leave open age group in tact graduate_mono(Value, OAG = TRUE) -
      #> 0 1 2 3 4 5 6 7 -#> 17689.096 17653.592 17671.344 17742.352 17866.616 17984.832 18067.544 18159.328 -#> 8 9 10 11 12 13 14 15 -#> 18260.184 18370.112 18475.416 18574.672 18680.864 18793.992 18914.056 19033.000 -#> 16 17 18 19 20 21 22 23 -#> 19147.320 19263.320 19381.000 19500.360 19622.696 19743.912 19860.664 19972.952 -#> 24 25 26 27 28 29 30 31 -#> 20080.776 20196.120 20314.440 20421.480 20517.240 20601.720 20687.736 20781.272 -#> 32 33 34 35 36 37 38 39 -#> 20872.504 20961.432 21048.056 21128.104 21209.688 21301.136 21402.448 21513.624 -#> 40 41 42 43 44 45 46 47 -#> 21618.352 21716.504 21824.328 21941.824 22068.992 22222.144 22368.848 22476.576 -#> 48 49 50 51 52 53 54 55 -#> 22545.328 22575.104 22642.672 22736.224 22773.088 22753.264 22676.752 22644.112 -#> 56 57 58 59 60 61 62 63 -#> 22649.264 22588.608 22462.144 22269.872 22118.752 22011.504 21842.528 21611.824 -#> 64 65 66 67 68 69 70 71 -#> 21319.392 21034.528 20790.816 20535.752 20269.336 19991.568 19845.608 19707.216 -#> 72 73 74 75 76 77 78 79 -#> 19371.112 18837.296 18105.768 17465.200 16956.440 16311.240 15529.600 14611.520 -#> 80 81 82 83 84 85 86 87 -#> 13725.360 12930.160 12087.080 11196.120 10257.280 9269.208 8313.056 7430.752 -#> 88 89 90 91 92 93 94 95 -#> 6622.296 5887.688 5036.104 4135.288 3409.936 2860.048 2485.624 1914.640 -#> 96 97 98 99 100 -#> 1226.680 833.560 735.280 931.840 1110.000
      -# Also accepts single ages: -Value <- structure(pop1m_ind, .Names = 0:100) - - if (FALSE) { - ages <- seq(0,100,5) - plot(graduate_mono(Value),xlab = 'Age', ylab = 'Counts', type = 'l',main = 'Ungrouped counts') - } +
      #> 0 1 2 3 4 5 6 +#> 17565.4135 17641.9827 17721.5760 17804.1933 17889.8345 17978.5187 18070.3217 +#> 7 8 9 10 11 12 13 +#> 18165.2623 18263.3406 18364.5567 18468.8156 18575.7386 18685.2308 18797.2922 +#> 14 15 16 17 18 19 20 +#> 18911.9229 19028.7708 19146.4281 19264.5427 19383.1146 19502.1439 19621.3811 +#> 21 22 23 24 25 26 27 +#> 19739.8291 19857.2386 19973.6094 20088.9417 20202.5367 20311.5993 20415.4310 +#> 28 29 30 31 32 33 34 +#> 20514.0317 20607.4013 20696.3123 20783.8535 20870.7974 20957.1439 21042.8930 +#> 35 36 37 38 39 40 41 +#> 21128.6463 21216.8106 21307.9874 21402.1768 21499.3788 21600.4704 21708.9601 +#> 42 43 44 45 46 47 48 +#> 21825.7249 21950.7648 22084.0798 22221.4960 22346.3171 22454.3691 22545.6520 +#> 49 50 51 52 53 54 55 +#> 22620.1658 22677.5136 22716.1076 22735.5508 22735.8432 22716.9848 22678.8335 +#> 56 57 58 59 60 61 62 +#> 22620.8205 22542.8038 22444.7833 22326.7589 22186.6564 22016.1783 21813.2500 +#> 63 64 65 66 67 68 69 +#> 21577.8718 21310.0435 21019.5648 20745.6344 20498.0520 20276.8176 20081.9312 +#> 70 71 72 73 74 75 76 +#> 19893.0605 19628.8761 19269.0459 18813.5698 18262.4477 17625.0893 16939.1330 +#> 77 78 79 80 81 82 83 +#> 16213.9883 15449.6553 14646.1340 13806.5422 12943.3518 12059.6807 11155.5289 +#> 84 85 86 87 88 89 90 +#> 10230.8964 9293.4219 8373.6598 7479.2489 6610.1891 5766.4804 4955.0263 +#> 91 92 93 94 95 96 97 +#> 4203.4409 3518.6278 2900.5869 2349.3182 1863.4410 1437.4325 1069.9120 +#> 98 99 100 +#> 760.8795 510.3350 1110.0000
      +data(pop1m_ind) +Value5 <- groupAges(pop1m_ind,Age=0:100,N=5) + +Value1 <- graduate_mono(Value = Value5, Age = names2age(Value5), OAG =TRUE) + +if (FALSE) { + + plot(seq(0,100,5),Value5 / 5, xlab = 'Age', ylab = 'Counts', type = 's') + lines(0:100,Value1) +}
      @@ -212,7 +212,7 @@

      Value

      Details

      The pivotAge must be at least 10 years below the maximum age detected from -rownames(popmat), but not lower than 75. In the exact pivotAge, we may either take the Sprague estimates or the spline estimates, depending on which is larger, then the single-age estimates for this 5-year age group are rescaled to sum to the original total in Value. Higher ages are taken from the spline-based age splits. The spline results are derive from the "monoH.FC" method of splinefun() on the cumulative sum of the original age grouped data. One could use this function to perform the same closeout to Grabill estimates, if these are given via the pops argument. See examples. Note that the Grabill split method mixed with this closeout will not necessarily preserve the annual totals, and this function performs to rescaling. The open age group is preserved (and must be included in Value).

      +rownames(popmat), but not lower than 75. In the exact pivotAge, we may either take the Sprague estimates or the spline estimates, depending on which is larger, then the single-age estimates for this 5-year age group are rescaled to sum to the original total in Value. Higher ages are taken from the spline-based age splits. The spline results are derive from the "hyman" method of splinefun() on the cumulative sum of the original age grouped data. One could use this function to perform the same closeout to Grabill estimates, if these are given via the pops argument. See examples. Note that the Grabill split method mixed with this closeout will not necessarily preserve the annual totals, and this function performs to rescaling. The open age group is preserved (and must be included in Value).

      Examples

      a5 <- as.integer(rownames(pop5_mat)) @@ -220,36 +220,40 @@

      Examp closed.out <- graduate_mono_closeout(Value = popvec, Age = a5, OAG = TRUE) sum(closed.out) - sum(popvec)

      #> [1] 0
      graduate_mono_closeout(Value = popvec, pivotAge = 85, Age = a5, OAG = TRUE) -
      #> 0 1 2 3 4 5 6 -#> 12172.4912 11380.4480 10717.4480 10171.0000 9728.6128 9377.7952 9106.0560 -#> 7 8 9 10 11 12 13 -#> 8900.9040 8749.8480 8640.3968 8573.6144 8550.5648 8490.9808 8355.2608 -#> 14 15 16 17 18 19 20 -#> 8171.5792 8008.3808 7852.7792 7694.2592 7534.6752 7373.9056 7210.8208 -#> 21 22 23 24 25 26 27 -#> 7046.6624 6881.6064 6715.9664 6550.9440 6386.5216 6221.6160 6065.6560 -#> 28 29 30 31 32 33 34 -#> 5922.9920 5789.2144 5656.4784 5527.4512 5393.8752 5251.2032 5103.9920 -#> 35 36 37 38 39 40 41 -#> 4958.4544 4809.8784 4676.3904 4566.5184 4469.7584 4372.0480 4282.1632 -#> 42 43 44 45 46 47 48 -#> 4161.7152 3992.0912 3793.9824 3600.3712 3397.0752 3237.6592 3149.6752 -#> 49 50 51 52 53 54 55 -#> 3104.2192 3052.7728 3014.5648 2923.2688 2744.0448 2513.3488 2294.2640 -#> 56 57 58 59 60 61 62 -#> 2064.3184 1897.9424 1835.3744 1836.1008 1826.9504 1831.6544 1779.1824 -#> 63 64 65 66 67 68 69 -#> 1629.7344 1422.4784 1231.8448 1037.5024 891.8304 826.6464 813.1760 -#> 70 71 72 73 74 75 76 -#> 792.0960 776.7936 745.8176 683.0176 601.2752 529.6992 462.5600 -#> 77 78 79 80 81 82 83 -#> 401.2800 349.5120 304.9488 261.4336 219.9616 183.1696 151.6816 -#> 84 85 86 87 88 89 90 -#> 124.7536 108.4960 77.9920 56.3440 43.5520 39.6160 32.7520 -#> 91 92 93 94 95 96 97 -#> 19.9840 11.6080 7.6240 8.0320 7.4320 3.9040 1.8880 -#> 98 99 100 -#> 1.3840 2.3920 0.0000
      # giving a different single-age split to close out this way: +
      #> 0 1 2 3 4 5 +#> 12172.491200 11380.448000 10717.448000 10171.000000 9728.612800 9377.795200 +#> 6 7 8 9 10 11 +#> 9106.056000 8900.904000 8749.848000 8640.396800 8573.614400 8550.564800 +#> 12 13 14 15 16 17 +#> 8490.980800 8355.260800 8171.579200 8008.380800 7852.779200 7694.259200 +#> 18 19 20 21 22 23 +#> 7534.675200 7373.905600 7210.820800 7046.662400 6881.606400 6715.966400 +#> 24 25 26 27 28 29 +#> 6550.944000 6386.521600 6221.616000 6065.656000 5922.992000 5789.214400 +#> 30 31 32 33 34 35 +#> 5656.478400 5527.451200 5393.875200 5251.203200 5103.992000 4958.454400 +#> 36 37 38 39 40 41 +#> 4809.878400 4676.390400 4566.518400 4469.758400 4372.048000 4282.163200 +#> 42 43 44 45 46 47 +#> 4161.715200 3992.091200 3793.982400 3600.371200 3397.075200 3237.659200 +#> 48 49 50 51 52 53 +#> 3149.675200 3104.219200 3052.772800 3014.564800 2923.268800 2744.044800 +#> 54 55 56 57 58 59 +#> 2513.348800 2294.264000 2064.318400 1897.942400 1835.374400 1836.100800 +#> 60 61 62 63 64 65 +#> 1826.950400 1831.654400 1779.182400 1629.734400 1422.478400 1231.844800 +#> 66 67 68 69 70 71 +#> 1037.502400 891.830400 826.646400 813.176000 792.096000 776.793600 +#> 72 73 74 75 76 77 +#> 745.817600 683.017600 601.275200 529.699200 462.560000 401.280000 +#> 78 79 80 81 82 83 +#> 349.512000 304.948800 261.433600 219.961600 183.169600 151.681600 +#> 84 85 86 87 88 89 +#> 124.753600 101.692205 79.932348 61.686246 46.953898 35.735304 +#> 90 91 92 93 94 95 +#> 27.603433 20.850155 15.048439 10.198284 6.299690 3.438064 +#> 96 97 98 99 100 +#> 1.955032 1.936000 3.380968 6.289936 0.000000
      # giving a different single-age split to close out this way: popg <- graduate_grabill(Value = popvec, Age = a5, OAG = TRUE) grabill.closed.out <- graduate_mono_closeout(Value = popvec, Age = a5, pops = popg) # totals not necessarily preserved if mixed w Grabill diff --git a/docs/reference/graduate_pclm.html b/docs/reference/graduate_pclm.html index 86f30334b..75c0e0c0d 100644 --- a/docs/reference/graduate_pclm.html +++ b/docs/reference/graduate_pclm.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40
      @@ -162,7 +162,7 @@

      wrapper for ungroup::pclm method of splitting binned counts

      This is exactly the function pclm() from the ungroup package, except with arguments using standard DemoTools argument names.

      -
      graduate_pclm(Value, Age, OAnew = max(Age), ...)
      +
      graduate_pclm(Value, Age, AgeInt, OAnew = max(Age), OAG = TRUE, ...)

      Arguments

      Value

      numeric vector, presumably counts in grouped ages

      AgeInt

      integer vector, age interval widths

      Age

      integer vector, lower bounds of age groups

      AgeInt

      integer vector, age interval widths

      OAG

      logical, default = TRUE is the final age group open?

      @@ -175,10 +175,18 @@

      Arg

      + + + + + + + + @@ -188,6 +196,7 @@

      Arg

      Details

      The PCLM method can also be used to graduate rates using an offset if both numerators and denominators are available. In this case Value is the event count and offset is person years of exposure. The denominator must match the length of Value or else the length of the final single age result length(min(Age):OAnew). This method can be used to redistribute counts in the open age group if OAnew gives sufficient space. Likewise, it can give a rate extrapolation beyond the open age.

      +

      If there are 0s in Value, these are replaced with a small value prior to fitting. If negatives result from the pclm fit, we retry after multiplying Value by 10, 100, or 1000, as sometimes a temporary rescale for fitting can help performance.

      References

      Pascariu MD, Dańko MJ, Schöley J, Rizzi S (2018). @@ -205,7 +214,8 @@

      Examp
      a5 <- seq(0,100,by=5) p5 <- pop5_mat[, 1] p1 <- graduate_pclm(Value = p5, Age = a5) -p1s <- graduate_sprague(Value = p5, Age = a5) +
      #> +#> 0s detected in Value, replacing with .01
      p1s <- graduate_sprague(Value = p5, Age = a5) if (FALSE) { plot(a5, p5/5, type = "s",xlim=c(40,60),ylim=c(2000,4000)) lines(0:100, p1, lwd = 2, col = "red") diff --git a/docs/reference/graduate_sprague.html b/docs/reference/graduate_sprague.html index f2a32cdcf..632b68e71 100644 --- a/docs/reference/graduate_sprague.html +++ b/docs/reference/graduate_sprague.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40
      @@ -162,7 +162,7 @@

      The basic Sprague age-splitting method.

      This method is used to interpolate counts based on the Sprague formula. It is based on the first stage of the Sprague R script prepared by Thomas Buettner and Patrick Gerland, itself based on the description in Siegel and Swanson, 2004, p. 727.

      -
      graduate_sprague(Value, Age, OAG = TRUE)
      +
      graduate_sprague(Value, Age, AgeInt, OAG = TRUE)

      Arguments

      Age

      integer vector, lower bounds of age groups

      AgeInt

      integer vector, age interval widths

      OAnew

      integer, optional new open age, higher than max(Age). See details.

      OAG

      logical, default = TRUE is the final age group open?

      ...

      further arguments passed to ungroup::pclm()

      @@ -175,6 +175,10 @@

      Arg

      + + + + diff --git a/docs/reference/graduate_sprague_expand.html b/docs/reference/graduate_sprague_expand.html index ec62d1a12..6085dc97e 100644 --- a/docs/reference/graduate_sprague_expand.html +++ b/docs/reference/graduate_sprague_expand.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/graduate_uniform.html b/docs/reference/graduate_uniform.html index 3e711f09d..fb992a4af 100644 --- a/docs/reference/graduate_uniform.html +++ b/docs/reference/graduate_uniform.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -162,7 +162,7 @@

      Convert arbitrary age groupings into single years of age.

      Uniformly splits aggregate counts in age groups into single year age groups.

      -
      graduate_uniform(Value, AgeInt, Age, OAG = TRUE, OAvalue = 1)
      +
      graduate_uniform(Value, Age, AgeInt, OAG = TRUE, OAvalue = 1)

      Arguments

      Age

      integer vector, lower bounds of age groups

      AgeInt

      integer vector, age interval widths

      OAG

      logical, default = TRUE is the final age group open?

      @@ -171,14 +171,14 @@

      Arg

      - - - - + + + + diff --git a/docs/reference/groupAges.html b/docs/reference/groupAges.html index 2ebe47aa7..fdb17a56c 100644 --- a/docs/reference/groupAges.html +++ b/docs/reference/groupAges.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/groupOAG.html b/docs/reference/groupOAG.html index f4febb1de..2cdfd5a74 100644 --- a/docs/reference/groupOAG.html +++ b/docs/reference/groupOAG.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/heapify.html b/docs/reference/heapify.html index fe0dbb769..6e46b2f72 100644 --- a/docs/reference/heapify.html +++ b/docs/reference/heapify.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/index.html b/docs/reference/index.html index 08362f9a1..b4872c946 100644 --- a/docs/reference/index.html +++ b/docs/reference/index.html @@ -79,7 +79,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -239,7 +239,7 @@

      -

      Evaluate consitenty of age structures

      +

      Evaluate consistency of age structures

      Methods to assess the consistency of age structures

      @@ -394,15 +394,24 @@

      interp_coh_bare()

      +

      interp_coh()

      -

      + + + + + + + @@ -412,6 +421,13 @@

      +

      + + + @@ -425,10 +441,28 @@

      + + + + + + + + + + + + @@ -693,6 +727,18 @@

      lt_abridged2single()

      + +

      + + + + + + @@ -705,12 +751,30 @@

      lt_id_d_l()

      + +

      + + + + + + + + + + @@ -831,6 +895,12 @@

      lt_smooth_ambiguous()

      + +

      + + @@ -905,6 +975,18 @@

      pop1m_rus2002

      + +

      + + + + + + @@ -927,6 +1009,30 @@

      popA_later

      + + + + + + + + + + + + + + + + @@ -955,7 +1061,7 @@

      @@ -1003,6 +1109,24 @@

      OPAG_fit_stable_standard()

      + +

      + + + + + + + + + + @@ -1010,9 +1134,15 @@

      interp()

      +

      downloadSRB()

      -

      + + + + + + + + + diff --git a/docs/reference/interpolatePop.html b/docs/reference/interpolatePop.html index c7858506b..a4f713a36 100644 --- a/docs/reference/interpolatePop.html +++ b/docs/reference/interpolatePop.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/is_abridged.html b/docs/reference/is_abridged.html index 10ea0f368..bbcac6e49 100644 --- a/docs/reference/is_abridged.html +++ b/docs/reference/is_abridged.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/is_age_coherent.html b/docs/reference/is_age_coherent.html index 1615e65cd..35203fe16 100644 --- a/docs/reference/is_age_coherent.html +++ b/docs/reference/is_age_coherent.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/is_age_redundant.html b/docs/reference/is_age_redundant.html index 760e6fdee..3f0b07c02 100644 --- a/docs/reference/is_age_redundant.html +++ b/docs/reference/is_age_redundant.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/is_age_sequential.html b/docs/reference/is_age_sequential.html index 536cb9672..471098eee 100644 --- a/docs/reference/is_age_sequential.html +++ b/docs/reference/is_age_sequential.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/is_single.html b/docs/reference/is_single.html index ebe051862..36dcc939b 100644 --- a/docs/reference/is_single.html +++ b/docs/reference/is_single.html @@ -81,7 +81,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/loess_smth1.html b/docs/reference/loess_smth1.html index b4572c125..2b7ad3312 100644 --- a/docs/reference/loess_smth1.html +++ b/docs/reference/loess_smth1.html @@ -81,7 +81,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/lt_a_closeout.html b/docs/reference/lt_a_closeout.html index 3c7a4db9a..fad9a541c 100644 --- a/docs/reference/lt_a_closeout.html +++ b/docs/reference/lt_a_closeout.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/lt_a_pas.html b/docs/reference/lt_a_pas.html index 9c387f2ff..8c3aa4760 100644 --- a/docs/reference/lt_a_pas.html +++ b/docs/reference/lt_a_pas.html @@ -81,7 +81,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/lt_a_un.html b/docs/reference/lt_a_un.html index 1e39426b0..e77e566a0 100644 --- a/docs/reference/lt_a_un.html +++ b/docs/reference/lt_a_un.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/lt_abridged.html b/docs/reference/lt_abridged.html index 3a8d6aaa8..9765dc58f 100644 --- a/docs/reference/lt_abridged.html +++ b/docs/reference/lt_abridged.html @@ -81,7 +81,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -182,9 +182,9 @@

      Calculate an abridged-age lifetable.

      SRB =1.05, OAG =TRUE, OAnew =max(Age), - extrapLaw ="kannisto", + extrapLaw =NULL, extrapFrom =max(Age), - extrapFit =Age[Age>=60&ifelse(OAG, Age<max(Age), TRUE)], + extrapFit =NULL, ...) @@ -262,7 +262,7 @@

      Arg

      +"Kannisto", "Kannisto_Makeham", "Makeham", "Gompertz", "GGompertz", "Beard", "Beard_Makeham", "Quadratic". Default "Kannisto" if the highest age is at least 90, otherwise "makeham". See details.

      diff --git a/docs/reference/lt_id_L_T.html b/docs/reference/lt_id_L_T.html index d38777f63..71856e531 100644 --- a/docs/reference/lt_id_L_T.html +++ b/docs/reference/lt_id_L_T.html @@ -81,7 +81,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/lt_id_Ll_S.html b/docs/reference/lt_id_Ll_S.html index 1c894af2d..870e8a4c8 100644 --- a/docs/reference/lt_id_Ll_S.html +++ b/docs/reference/lt_id_Ll_S.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/lt_id_l_d.html b/docs/reference/lt_id_l_d.html index 8c5c2c2c4..3f0ff627a 100644 --- a/docs/reference/lt_id_l_d.html +++ b/docs/reference/lt_id_l_d.html @@ -81,7 +81,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/lt_id_lda_L.html b/docs/reference/lt_id_lda_L.html index e4890189f..17f3f494a 100644 --- a/docs/reference/lt_id_lda_L.html +++ b/docs/reference/lt_id_lda_L.html @@ -82,7 +82,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/lt_id_ma_q.html b/docs/reference/lt_id_ma_q.html index b606f9319..fd0524277 100644 --- a/docs/reference/lt_id_ma_q.html +++ b/docs/reference/lt_id_ma_q.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/lt_id_morq_a.html b/docs/reference/lt_id_morq_a.html index 178f7f411..9701dae13 100644 --- a/docs/reference/lt_id_morq_a.html +++ b/docs/reference/lt_id_morq_a.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/lt_id_morq_a_greville.html b/docs/reference/lt_id_morq_a_greville.html index 3d5ba372b..c19c860f7 100644 --- a/docs/reference/lt_id_morq_a_greville.html +++ b/docs/reference/lt_id_morq_a_greville.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/lt_id_q_l.html b/docs/reference/lt_id_q_l.html index f3af96a7f..09a50a51c 100644 --- a/docs/reference/lt_id_q_l.html +++ b/docs/reference/lt_id_q_l.html @@ -81,7 +81,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/lt_id_qa_m.html b/docs/reference/lt_id_qa_m.html index 1b7149576..aee11a6b0 100644 --- a/docs/reference/lt_id_qa_m.html +++ b/docs/reference/lt_id_qa_m.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/lt_id_qm_a.html b/docs/reference/lt_id_qm_a.html index 762c9911e..42d4915cc 100644 --- a/docs/reference/lt_id_qm_a.html +++ b/docs/reference/lt_id_qm_a.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/lt_model_lq.html b/docs/reference/lt_model_lq.html index e39d481f4..a67c6bc09 100644 --- a/docs/reference/lt_model_lq.html +++ b/docs/reference/lt_model_lq.html @@ -83,7 +83,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -291,12 +291,68 @@

      Note

      Examples

      # Build life tables with various choices of 2 input parameters -if (FALSE) { # case 1: Using 5q0 and e0 L1 <- lt_model_lq(Sex = "b", q0_5 = 0.05, e0 = 65) L1 -ls(L1) - +
      #> $lt +#> Age AgeInt nMx nAx nqx lx ndx +#> 0 0 1 0.0410512359 0.1896953 0.039729668 1.000000e+05 3.972967e+03 +#> 1 1 4 0.0026918261 1.4972530 0.010695251 9.602703e+04 1.027033e+03 +#> 5 5 5 0.0011225901 2.5000000 0.005597242 9.500000e+04 5.317380e+02 +#> 10 10 5 0.0008954053 2.5000000 0.004467027 9.446826e+04 4.219923e+02 +#> 15 15 5 0.0017669921 2.5000000 0.008796104 9.404627e+04 8.272408e+02 +#> 20 20 5 0.0024186771 2.5000000 0.012020700 9.321903e+04 1.120558e+03 +#> 25 25 5 0.0025645864 2.5000000 0.012741242 9.209847e+04 1.173449e+03 +#> 30 30 5 0.0029684958 2.5000000 0.014733141 9.092502e+04 1.339611e+03 +#> 35 35 5 0.0038331499 2.5000000 0.018983830 8.958541e+04 1.700674e+03 +#> 40 40 5 0.0052139916 2.5000000 0.025734509 8.788474e+04 2.261671e+03 +#> 45 45 5 0.0074292174 2.5000000 0.036468751 8.562307e+04 3.122566e+03 +#> 50 50 5 0.0108459016 2.5000000 0.052797906 8.250050e+04 4.355854e+03 +#> 55 55 5 0.0159273998 2.5000000 0.076587404 7.814465e+04 5.984896e+03 +#> 60 60 5 0.0243032257 2.5000000 0.114555932 7.215975e+04 8.266327e+03 +#> 65 65 5 0.0373150554 2.5000000 0.170655252 6.389342e+04 1.090375e+04 +#> 70 70 5 0.0590143815 2.5000000 0.257135218 5.298968e+04 1.362551e+04 +#> 75 75 5 0.0932246607 2.5000000 0.378021085 3.936416e+04 1.488048e+04 +#> 80 80 5 0.1439135402 2.5000000 0.529178002 2.448368e+04 1.295622e+04 +#> 85 85 5 0.2168418692 2.5000000 0.703071176 1.152745e+04 8.104621e+03 +#> 90 90 5 0.3080565236 2.5000000 0.870146700 3.422834e+03 2.978367e+03 +#> 95 95 5 0.4244002008 2.5000000 0.880208315 4.444662e+02 3.912229e+02 +#> 100 100 5 0.5495844154 2.5000000 0.935939164 5.324336e+01 4.983255e+01 +#> 105 105 5 0.6700558318 2.5000000 0.964925439 3.410814e+00 3.291181e+00 +#> 110 110 NA 0.7610553490 2.6139387 1.000000000 1.196328e-01 1.196328e-01 +#> nLx Sx Tx ex +#> 0 9.678069e+04 0.95663683 6.500007e+06 65.000066 +#> 1 3.815377e+05 0.99028313 6.403226e+06 66.681493 +#> 5 4.736707e+05 0.99496628 6.021688e+06 63.386191 +#> 10 4.712863e+05 0.99337328 5.548018e+06 58.728904 +#> 15 4.681632e+05 0.98959872 5.076731e+06 53.981208 +#> 20 4.632938e+05 0.98762121 4.608568e+06 49.438060 +#> 25 4.575587e+05 0.98626919 4.145274e+06 45.009153 +#> 30 4.512761e+05 0.98315729 3.687715e+06 40.557763 +#> 35 4.436754e+05 0.97767318 3.236439e+06 36.126858 +#> 40 4.337695e+05 0.96896833 2.792764e+06 31.777577 +#> 45 4.203089e+05 0.95551831 2.358995e+06 27.550923 +#> 50 4.016129e+05 0.93562987 1.938686e+06 23.499077 +#> 55 3.757610e+05 0.90518426 1.537073e+06 19.669585 +#> 60 3.401329e+05 0.85909865 1.161312e+06 16.093622 +#> 65 2.922077e+05 0.79013852 8.211788e+05 12.852321 +#> 70 2.308846e+05 0.69133935 5.289711e+05 9.982531 +#> 75 1.596196e+05 0.56401490 2.980865e+05 7.572534 +#> 80 9.002784e+04 0.41515739 1.384669e+05 5.655476 +#> 85 3.737572e+04 0.25867727 4.843902e+04 4.202057 +#> 90 9.668250e+03 0.12869693 1.106330e+04 3.232204 +#> 95 1.244274e+03 0.11382978 1.395048e+03 3.138705 +#> 100 1.416354e+02 0.06231574 1.507743e+02 2.831795 +#> 105 8.826118e+00 0.03421804 9.138830e+00 2.679369 +#> 110 3.127128e-01 0.00000000 3.127128e-01 2.613939 +#> +#> $values +#> k q0_1 q0_5 q15_35 q15_45 e0 +#> 0.5545641 0.03972967 0.05 0.1227669 0.2327208 65.00007 +#> +#> attr(,"class") +#> [1] "lt_model_lq"
      ls(L1) +
      #> [1] "lt" "values"
      L1f <- lt_model_lq(Sex = "f", q0_5 = 0.05, e0 = 65) L1m <- lt_model_lq(Sex = "m", q0_5 = 0.05, e0 = 65) @@ -320,7 +376,7 @@

      Examp # case 8: Using 35q15 and e0 L8 <- lt_model_lq(Sex = "b", q15_35 = 0.15, e0 = 65) -} +

      diff --git a/docs/reference/lt_rule_4a1_cd.html b/docs/reference/lt_rule_4a1_cd.html index 0f0ab51e6..197b3fc78 100644 --- a/docs/reference/lt_rule_4a1_cd.html +++ b/docs/reference/lt_rule_4a1_cd.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/lt_rule_4m0_D0.html b/docs/reference/lt_rule_4m0_D0.html index 3d1e3d876..01e5277ef 100644 --- a/docs/reference/lt_rule_4m0_D0.html +++ b/docs/reference/lt_rule_4m0_D0.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/lt_rule_4m0_m0.html b/docs/reference/lt_rule_4m0_m0.html index 1b5d8250f..39a66df99 100644 --- a/docs/reference/lt_rule_4m0_m0.html +++ b/docs/reference/lt_rule_4m0_m0.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/lt_rule_m_extrapolate.html b/docs/reference/lt_rule_m_extrapolate.html index 328995f88..ee415c868 100644 --- a/docs/reference/lt_rule_m_extrapolate.html +++ b/docs/reference/lt_rule_m_extrapolate.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -167,9 +167,8 @@

      Extrapolate old-age human mortality curve using mortality laws

      x, x_fit =x, x_extr, - law =c("kannisto", "kannisto_makeham", "makeham", "gompertz", "ggompertz", "beard", - "beard_makeham", "quadratic"), - opt.method =c("LF2", "LF1", "LF3", "LF4", "LF5", "LF6", "poissonL", "binomialL"), + law ="kannisto", + opt.method ="LF2", ...) @@ -210,11 +209,7 @@

      Arg

      - + @@ -339,6 +334,14 @@

      Examp F1 <- lt_rule_m_extrapolate(mx_matrix, x = x1, x_fit, x_extr, law = "kannisto")
      #> Warning: the condition has length > 1 and only the first element will be used
      F1
      #> $input +#> $input$opt.choices +#> [1] "poissonL" "LF2" "LF1" "LF3" "LF4" "LF5" +#> [7] "LF6" "binomialL" +#> +#> $input$all_the_laws_we_care_about +#> [1] "kannisto" "kannisto_makeham" "makeham" "gompertz" +#> [5] "ggompertz" "beard" "beard_makeham" "quadratic" +#> #> $input$mx #> year #> age year1 year2 year3 @@ -396,8 +399,7 @@

      Examp #> [1] "kannisto" #> #> $input$opt.method -#> [1] "LF2" "LF1" "LF3" "LF4" "LF5" "LF6" -#> [7] "poissonL" "binomialL" +#> [1] "LF2" #> #> #> $call diff --git a/docs/reference/lt_single_mx.html b/docs/reference/lt_single_mx.html index 779f66110..a0cae5b8b 100644 --- a/docs/reference/lt_single_mx.html +++ b/docs/reference/lt_single_mx.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40

      @@ -174,9 +174,9 @@

      calculate a single age lifetable

      SRB =1.05, OAG =TRUE, OAnew =max(Age), - extrapLaw ="kannisto", + extrapLaw =NULL, extrapFrom =max(Age), - extrapFit =Age[Age>=60], + extrapFit =NULL, ...) @@ -230,7 +230,7 @@

      Arg

      +"Kannisto", "Kannisto_Makeham", "Makeham", "Gompertz", "GGompertz", "Beard", "Beard_Makeham", "Quadratic". Default "Kannisto" if the highest age is at least 90, otherwise "makeham". See details.

      diff --git a/docs/reference/lthat.logquad.html b/docs/reference/lthat.logquad.html index 0570c1e7b..0b6facbd7 100644 --- a/docs/reference/lthat.logquad.html +++ b/docs/reference/lthat.logquad.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/ma.html b/docs/reference/ma.html index 2c44ac391..e1164d199 100644 --- a/docs/reference/ma.html +++ b/docs/reference/ma.html @@ -81,7 +81,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/mav.html b/docs/reference/mav.html index fa17ab15d..0b5e77753 100644 --- a/docs/reference/mav.html +++ b/docs/reference/mav.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -162,7 +162,7 @@

      Calculate the moving average (mav) over 3 or 5 years.

      This arithmetic smoothing technique aims to eliminate irregularities of the population pyramid by averaging values in a moving window of user-defined width.

      -
      mav(Value, Age, n = 3, OAG = TRUE)
      +
      mav(Value, Age, n = 3, OAG = TRUE, tails = FALSE)

      Arguments

      Value

      numeric vector, presumably counts in grouped ages

      AgeInt

      integer vector, age interval widths

      Age

      integer vector, lower bounds of age groups

      AgeInt

      integer vector, age interval widths

      OAG

      logical, default = TRUE is the final age group open?

      component-free intercensalcohort interpolation

      component-free intercensal cohort interpolation

      +

      Extrapolation

      +

      Functions to interpolate/extrapolate rates or counts - ‘interp_lc_lim’ - ‘lt_rule_m_extrapolate’ - ‘OPAG

      +

      Migration

      -

      Functions for migration models

      +

      Functions for migration models or estimation

      +

      mig_beta()

      +

      Estimate intercensal migration by comparing census population, by age and +sex, to the results of a RUP projection.

      mig_calculate_rc()

      -

      mig_resid_stock() mig_resid_cohort() mig_resid_time()

      +

      mig_resid() mig_resid_stock() mig_resid_cohort() mig_resid_time()

      Estimate net migration using residual methods: stock change, time even flow and cohort even flow

      +

      mig_un_fam()

      +

      Net migration by age for an UN family

      +

      mig_un_families

      +

      Proportion of net migrants by age and sex for considered migration profiles

      +

      mig_un_params

      +

      Parameters for considered migration profiles

      create a life table by single year of age by graduating an abridged life table

      +

      lt_ambiguous()

      +

      calculate an abidged or single age lifetable from abridged or sinlge age data

      lt_id_L_T()

      Derive survivorship from lifetable deaths

      +

      lt_id_d_q()

      +

      Derive death probabilities from lifetable deaths

      lt_id_l_d()

      Derive lifetable deaths from survivorship.

      +

      lt_id_l_q()

      +

      Derive lifetable death probabilities from survivorship.

      lt_id_lda_L()

      Smooth and apply lt_ambiguous

      single2abridged()

      Russian census 2002 male population by 1 year age groups

      +

      pop1m_rus2010

      +

      Russian census 2010 male population by 1 year age groups

      pop5_mat

      Abridged population from PAS AGEINT -- later

      +

      pop_f_mat_five

      +

      Population matrix for females five year age groups between 1950 and 2050

      +

      pop_f_mat_single

      +

      Population matrix for females single ages between 1999 and 2019

      +

      pop_m_mat_five

      +

      Population matrix for males five year age groups between 1950 and 2050

      +

      pop_m_mat_single

      +

      Population matrix for males single ages between 1999 and 2019

      -

      census_cohort_adjust()

      +

      shift_census_ages_to_cohorts()

      shift census populations to match single year cohorts

      creates stable standard based on optimizing the growth rate

      +

      OPAG_nLx_warp_r()

      +

      Warps a given stationary population into a stable population

      +

      OPAG_r_min()

      +

      calculates residual for optimizing growth rate r for OPAG family

      OPAG_simple()

      Interpolate between two population age distributions.

      Extract SRB estimates from WPP2019

      +

      downloadnLx()

      +

      Extract Lx estimates from WPP2019. Mainly an util function for other ones.

      diff --git a/docs/reference/inferAgeIntAbr.html b/docs/reference/inferAgeIntAbr.html index 436f4fc7e..19ee87fc5 100644 --- a/docs/reference/inferAgeIntAbr.html +++ b/docs/reference/inferAgeIntAbr.html @@ -82,7 +82,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/int2age.html b/docs/reference/int2age.html index 18e9b36c5..97029fd27 100644 --- a/docs/reference/int2age.html +++ b/docs/reference/int2age.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/int2ageN.html b/docs/reference/int2ageN.html index d6c94b254..0f6eec302 100644 --- a/docs/reference/int2ageN.html +++ b/docs/reference/int2ageN.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/interp.html b/docs/reference/interp.html index 58883c580..9c3d07a37 100644 --- a/docs/reference/interp.html +++ b/docs/reference/interp.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -168,6 +168,7 @@

      Interpolate between two population age distributions.

      datesOut, method = c("linear", "exponential", "power"), power = 2, + extrap = FALSE, ... ) @@ -194,6 +195,10 @@

      Arg

      power

      numeric power to interpolate by, if method = "power". Default 2.

      extrap

      logical. In case datesOut is out of range of datesIn, do extrapolation using slope in extreme pairwise. Deafult FALSE.

      ...

      arguments passed to stats::approx. For example, rule, which controls extrapolation behavior.

      extrapLaw

      character. If extrapolating, which parametric mortality law should be invoked? Options include -"Kannisto", "Kannisto_Makeham", "Makeham", "Gompertz", "GGompertz", "Beard", "Beard_Makeham", "Quadratic". Default "Kannisto". See details.

      extrapFrom
      opt.method

      How would you like to find the parameters? Specify the -function to be optimize. Available options: the Poisson likelihood function -poissonL; the Binomial likelihood function -binomialL; and -6 other loss functions. For more details, check the availableLF -function.

      character. Default "LF2", see MortalityLaws::MortalityLaw for a description of choices.

      ...
      extrapLaw

      character. If extrapolating, which parametric mortality law should be invoked? Options include -"Kannisto", "Kannisto_Makeham", "Makeham", "Gompertz", "GGompertz", "Beard", "Beard_Makeham", "Quadratic". Default "Kannisto". See details.

      extrapFrom
      @@ -183,6 +183,12 @@

      Arg

      + + + +
      OAG

      logical. Whether or not the top age group is open. Default TRUE.

      tails

      logical. If set to TRUE, smaller-n moving averages are applied on both tails +such that all values are non-NA. If FALSE (default), tails are set to NA +due to the lag of moving averages.

      Value

      @@ -190,16 +196,13 @@

      Value

      Vector with the smoothed demographic counts.

      Details

      -

      The moving window is applied symmetrically. Data endpoints are imputed with NAs in output: the is nothing under 0 or over the highest closed age group to average with. The open age group is imputed with NA prior to calculations, since it cannot be averaged into the next lowest group. For example, for n=3, age 0 will be NA, as will the open age group and next lowest age. Age intervals are assumed uniform. This function could be used with either single or 5-year age groups.

      -

      Ages may be single or grouped, but all age intervals are assumed equal.

      +

      The moving window is applied symmetrically. By default (tails = FALSE) data endpoints are imputed with NAs in output: the is nothing under 0 or over the highest closed age group to average with. The open age group is not used in averaging, and it is returned as-is. Age intervals are assumed uniform. This function could be used with either single or 5-year age groups.

      +

      If tails is set to TRUE, then tails have been imputed using moving averages with successively smaller values of n, the cascade method.

      References

      Roger G, Waltisperger D, Corbille-Guitton C (1981). Les structures par sexe et âge en Afrique. GDA, Paris, France.

      -

      Author

      - -

      Juan Galeano

      Examples

      Pop <-c(303583,390782,523903,458546,517996,400630,485606,325423,471481,189710, @@ -233,8 +236,15 @@

      Examp #> 63 64 65 66 67 68 69 #> 10421.000 35938.667 36190.000 35550.667 8359.000 6344.333 NA #> 70 -#> NA

      if (FALSE) { -nwindows <- sapply(seq(3, 11, by = 2),mav, Value = Pop, Age = Age) +#> 160609.000
      +if (FALSE) { + odds <- seq(3, 11, by = 2) +nwindows <- sapply(odds, + mav, + Value = Pop, + Age = Age, + OAG = TRUE, + tails = FALSE) cols <- gray(seq(.8, 0, length = 5)) lwds <- seq(3, 1, length = 5) plot(Age,Pop, col = "red", xlab = "Age", ylab = "The counts", pch=16, @@ -246,6 +256,47 @@

      Examp lwd = lwds, legend = paste0("n=",seq(3,11,by=2))) } + +# For cascading smoothing on the tails: +mav(Pop, Age, tails = TRUE) +

      #> 0 1 2 3 4 5 6 7 +#> 303583.00 402262.50 457743.67 500148.33 459057.33 468077.33 403886.33 427503.33 +#> 8 9 10 11 12 13 14 15 +#> 328871.33 348877.67 239452.33 266512.33 186400.00 184691.00 146875.67 149519.00 +#> 16 17 18 19 20 21 22 23 +#> 134015.00 163920.33 137280.33 234832.33 180296.00 222109.33 131151.00 146584.33 +#> 24 25 26 27 28 29 30 31 +#> 239569.33 252211.00 242532.00 142850.33 109987.67 268772.00 226576.33 242277.67 +#> 32 33 34 35 36 37 38 39 +#> 68403.33 70447.67 168918.33 178753.00 176459.67 72171.67 54237.67 188760.00 +#> 40 41 42 43 44 45 46 47 +#> 173602.67 180457.33 39273.33 36524.67 95494.00 97946.67 96946.00 34318.67 +#> 48 49 50 51 52 53 54 55 +#> 26680.33 131861.00 125365.33 129168.00 21978.67 20700.00 51622.00 53326.67 +#> 56 57 58 59 60 61 62 63 +#> 51601.00 17558.33 12818.67 116461.00 113761.00 115568.00 10834.67 10421.00 +#> 64 65 66 67 68 69 70 +#> 35938.67 36190.00 35550.67 8359.00 6979.25 8884.00 160609.00
      +if (FALSE) { +# Compare +nwindows_tails <- sapply(odds, + mav, + Value = Pop, + Age = Age, + OAG = TRUE, + tails = TRUE) + +colnames(nwindows) <- odds +colnamaes(nwindows_tails) <- odds + +# NA triangles are completed with +# successively smaller ns. +head(nwindows) +head(nwindows_tails) + +tail(nwindows) +tail(nwindows_tails) +}
      diff --git a/docs/reference/mig_calculate_rc.html b/docs/reference/mig_calculate_rc.html index 333055936..5817169ed 100644 --- a/docs/reference/mig_calculate_rc.html +++ b/docs/reference/mig_calculate_rc.html @@ -81,7 +81,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -197,12 +197,12 @@

      R RR-81-030.

      Examples

      -
      pars <- c(a1= 0.09, alpha1= 0.1, a2= 0.2, -alpha2= 0.1, mu2= 21, lambda2= 0.39, a3= 0.001, +
      if (FALSE) { +pars <- c(a1= 0.09, alpha1= 0.1, a2= 0.2, +alpha2= 0.1, mu2= 21, lambda2= 0.39, a3= 0.001, alpha3= 1, mu3= 67, lambda3= 0.6, c= 0.01) ages <- 0:75 mx <- mig_calculate_rc(ages = ages, pars = pars) -if (FALSE) { plot(ages, mx, type = 'l') }
      diff --git a/docs/reference/mig_estimate_rc.html b/docs/reference/mig_estimate_rc.html index a625ba6c4..da751539e 100644 --- a/docs/reference/mig_estimate_rc.html +++ b/docs/reference/mig_estimate_rc.html @@ -81,7 +81,7 @@ DemoTools - 01.11.03 + 01.13.40
      @@ -209,7 +209,8 @@

      Arg

      Examples

      -
      # define ages and migration rates +
      if (FALSE) { +# define ages and migration rates ages <- 0:75 mig_rate <- c(0.1014,0.0984,0.0839,0.0759,0.0679,0.0616, 0.055,0.0518,0.0438,0.0399,0.0363,0.0342,0.0307,0.0289, @@ -223,111 +224,12 @@

      Examp 0.0093,0.0083,0.0078,0.0067,0.0069,0.0054) # fit the model -res <- mig_estimate_rc(ages, mig_rate, -pre_working_age = TRUE, -working_age = TRUE, -retirement = FALSE, +res <- mig_estimate_rc(ages, mig_rate, +pre_working_age = TRUE, +working_age = TRUE, +retirement = FALSE, post_retirement = FALSE) -

      #> -#> SAMPLING FOR MODEL '28c89f5948288d3bb37fc72d345573dc' NOW (CHAIN 1). -#> Chain 1: -#> Chain 1: Gradient evaluation took 7.7e-05 seconds -#> Chain 1: 1000 transitions using 10 leapfrog steps per transition would take 0.77 seconds. -#> Chain 1: Adjust your expectations accordingly! -#> Chain 1: -#> Chain 1: -#> Chain 1: Iteration: 1 / 2000 [ 0%] (Warmup) -#> Chain 1: Iteration: 200 / 2000 [ 10%] (Warmup) -#> Chain 1: Iteration: 400 / 2000 [ 20%] (Warmup) -#> Chain 1: Iteration: 600 / 2000 [ 30%] (Warmup) -#> Chain 1: Iteration: 800 / 2000 [ 40%] (Warmup) -#> Chain 1: Iteration: 1000 / 2000 [ 50%] (Warmup) -#> Chain 1: Iteration: 1001 / 2000 [ 50%] (Sampling) -#> Chain 1: Iteration: 1200 / 2000 [ 60%] (Sampling) -#> Chain 1: Iteration: 1400 / 2000 [ 70%] (Sampling) -#> Chain 1: Iteration: 1600 / 2000 [ 80%] (Sampling) -#> Chain 1: Iteration: 1800 / 2000 [ 90%] (Sampling) -#> Chain 1: Iteration: 2000 / 2000 [100%] (Sampling) -#> Chain 1: -#> Chain 1: Elapsed Time: 0.802851 seconds (Warm-up) -#> Chain 1: 0.729046 seconds (Sampling) -#> Chain 1: 1.5319 seconds (Total) -#> Chain 1: -#> -#> SAMPLING FOR MODEL '28c89f5948288d3bb37fc72d345573dc' NOW (CHAIN 2). -#> Chain 2: -#> Chain 2: Gradient evaluation took 3.8e-05 seconds -#> Chain 2: 1000 transitions using 10 leapfrog steps per transition would take 0.38 seconds. -#> Chain 2: Adjust your expectations accordingly! -#> Chain 2: -#> Chain 2: -#> Chain 2: Iteration: 1 / 2000 [ 0%] (Warmup) -#> Chain 2: Iteration: 200 / 2000 [ 10%] (Warmup) -#> Chain 2: Iteration: 400 / 2000 [ 20%] (Warmup) -#> Chain 2: Iteration: 600 / 2000 [ 30%] (Warmup) -#> Chain 2: Iteration: 800 / 2000 [ 40%] (Warmup) -#> Chain 2: Iteration: 1000 / 2000 [ 50%] (Warmup) -#> Chain 2: Iteration: 1001 / 2000 [ 50%] (Sampling) -#> Chain 2: Iteration: 1200 / 2000 [ 60%] (Sampling) -#> Chain 2: Iteration: 1400 / 2000 [ 70%] (Sampling) -#> Chain 2: Iteration: 1600 / 2000 [ 80%] (Sampling) -#> Chain 2: Iteration: 1800 / 2000 [ 90%] (Sampling) -#> Chain 2: Iteration: 2000 / 2000 [100%] (Sampling) -#> Chain 2: -#> Chain 2: Elapsed Time: 0.847845 seconds (Warm-up) -#> Chain 2: 0.809066 seconds (Sampling) -#> Chain 2: 1.65691 seconds (Total) -#> Chain 2: -#> -#> SAMPLING FOR MODEL '28c89f5948288d3bb37fc72d345573dc' NOW (CHAIN 3). -#> Chain 3: -#> Chain 3: Gradient evaluation took 4e-05 seconds -#> Chain 3: 1000 transitions using 10 leapfrog steps per transition would take 0.4 seconds. -#> Chain 3: Adjust your expectations accordingly! -#> Chain 3: -#> Chain 3: -#> Chain 3: Iteration: 1 / 2000 [ 0%] (Warmup) -#> Chain 3: Iteration: 200 / 2000 [ 10%] (Warmup) -#> Chain 3: Iteration: 400 / 2000 [ 20%] (Warmup) -#> Chain 3: Iteration: 600 / 2000 [ 30%] (Warmup) -#> Chain 3: Iteration: 800 / 2000 [ 40%] (Warmup) -#> Chain 3: Iteration: 1000 / 2000 [ 50%] (Warmup) -#> Chain 3: Iteration: 1001 / 2000 [ 50%] (Sampling) -#> Chain 3: Iteration: 1200 / 2000 [ 60%] (Sampling) -#> Chain 3: Iteration: 1400 / 2000 [ 70%] (Sampling) -#> Chain 3: Iteration: 1600 / 2000 [ 80%] (Sampling) -#> Chain 3: Iteration: 1800 / 2000 [ 90%] (Sampling) -#> Chain 3: Iteration: 2000 / 2000 [100%] (Sampling) -#> Chain 3: -#> Chain 3: Elapsed Time: 0.845299 seconds (Warm-up) -#> Chain 3: 0.707274 seconds (Sampling) -#> Chain 3: 1.55257 seconds (Total) -#> Chain 3: -#> -#> SAMPLING FOR MODEL '28c89f5948288d3bb37fc72d345573dc' NOW (CHAIN 4). -#> Chain 4: -#> Chain 4: Gradient evaluation took 4e-05 seconds -#> Chain 4: 1000 transitions using 10 leapfrog steps per transition would take 0.4 seconds. -#> Chain 4: Adjust your expectations accordingly! -#> Chain 4: -#> Chain 4: -#> Chain 4: Iteration: 1 / 2000 [ 0%] (Warmup) -#> Chain 4: Iteration: 200 / 2000 [ 10%] (Warmup) -#> Chain 4: Iteration: 400 / 2000 [ 20%] (Warmup) -#> Chain 4: Iteration: 600 / 2000 [ 30%] (Warmup) -#> Chain 4: Iteration: 800 / 2000 [ 40%] (Warmup) -#> Chain 4: Iteration: 1000 / 2000 [ 50%] (Warmup) -#> Chain 4: Iteration: 1001 / 2000 [ 50%] (Sampling) -#> Chain 4: Iteration: 1200 / 2000 [ 60%] (Sampling) -#> Chain 4: Iteration: 1400 / 2000 [ 70%] (Sampling) -#> Chain 4: Iteration: 1600 / 2000 [ 80%] (Sampling) -#> Chain 4: Iteration: 1800 / 2000 [ 90%] (Sampling) -#> Chain 4: Iteration: 2000 / 2000 [100%] (Sampling) -#> Chain 4: -#> Chain 4: Elapsed Time: 1.06673 seconds (Warm-up) -#> Chain 4: 1.06023 seconds (Sampling) -#> Chain 4: 2.12697 seconds (Total) -#> Chain 4:
      if (FALSE) { + # plot the results and data plot(ages, mig_rate, ylab = "migration rate", xlab = "age") lines(ages, res[["fit_df"]]$median, col = "red") diff --git a/docs/reference/names2age.html b/docs/reference/names2age.html index 71441a434..c1155e961 100644 --- a/docs/reference/names2age.html +++ b/docs/reference/names2age.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40
      diff --git a/docs/reference/pipe.html b/docs/reference/pipe.html index f9dc14745..c06513faf 100644 --- a/docs/reference/pipe.html +++ b/docs/reference/pipe.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40
      @@ -164,7 +164,22 @@

      Pipe operator

      lhs %>% rhs
      - +

      Arguments

      + + + + + + + + + + +
      lhs

      A value or the magrittr placeholder.

      rhs

      A function call using the magrittr semantics.

      + +

      Value

      + +

      The result of calling rhs(lhs).

      diff --git a/docs/reference/pop1m_ind.html b/docs/reference/pop1m_ind.html index a3739a06b..78b58ba55 100644 --- a/docs/reference/pop1m_ind.html +++ b/docs/reference/pop1m_ind.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/pop1m_pasex.html b/docs/reference/pop1m_pasex.html index 0892a01cb..1544fc5c6 100644 --- a/docs/reference/pop1m_pasex.html +++ b/docs/reference/pop1m_pasex.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/pop5_mat.html b/docs/reference/pop5_mat.html index c73b5ec97..89949e114 100644 --- a/docs/reference/pop5_mat.html +++ b/docs/reference/pop5_mat.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/pop5m_pasex.html b/docs/reference/pop5m_pasex.html index 2b95563ca..4e1e7c713 100644 --- a/docs/reference/pop5m_pasex.html +++ b/docs/reference/pop5m_pasex.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/popA_earlier.html b/docs/reference/popA_earlier.html index 0fa289db5..e571ecec9 100644 --- a/docs/reference/popA_earlier.html +++ b/docs/reference/popA_earlier.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/popA_later.html b/docs/reference/popA_later.html index e52d2db10..0b74d9e45 100644 --- a/docs/reference/popA_later.html +++ b/docs/reference/popA_later.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/ratx.html b/docs/reference/ratx.html index 47a99ae9a..e6ca7efb4 100644 --- a/docs/reference/ratx.html +++ b/docs/reference/ratx.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/rescaleAgeGroups.html b/docs/reference/rescaleAgeGroups.html index 7c60f1d21..4c3543dcd 100644 --- a/docs/reference/rescaleAgeGroups.html +++ b/docs/reference/rescaleAgeGroups.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -167,7 +167,7 @@

      rescale counts in age groups to match counts in different age groups

      AgeInt1, Value2, AgeInt2, - splitfun = c(graduate_uniform, graduate_mono), + splitfun = graduate_uniform, recursive = FALSE, tol = 0.001 )
      @@ -193,7 +193,7 @@

      Arg splitfun -

      function to use for splitting pop1. Presently on graduate_uniform() works.

      +

      function to use for splitting Value1. Reasonable (and tested) choices are either graduate_uniform or graduate_mono.

      recursive @@ -201,7 +201,7 @@

      Arg tol -

      numeric. Default 1e-3. The numerical tolerance for the residual. Used to detect stability if recursive = TRUE.

      +

      numeric. Default 1e-3. The numerical tolerance for the residual. Used to detect stability if recursive = TRUE.

      diff --git a/docs/reference/rescale_vector.html b/docs/reference/rescale_vector.html index 2d348cb42..dc8134367 100644 --- a/docs/reference/rescale_vector.html +++ b/docs/reference/rescale_vector.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/rlog.html b/docs/reference/rlog.html index 1184b4ca3..777f3d334 100644 --- a/docs/reference/rlog.html +++ b/docs/reference/rlog.html @@ -82,7 +82,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/sexRatioScore.html b/docs/reference/sexRatioScore.html index 817d19101..0b06de08b 100644 --- a/docs/reference/sexRatioScore.html +++ b/docs/reference/sexRatioScore.html @@ -83,7 +83,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/shift.vector.html b/docs/reference/shift.vector.html index 8a434172f..ed80240c8 100644 --- a/docs/reference/shift.vector.html +++ b/docs/reference/shift.vector.html @@ -82,7 +82,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/simplify.text.html b/docs/reference/simplify.text.html index 615014bea..62d83bbf3 100644 --- a/docs/reference/simplify.text.html +++ b/docs/reference/simplify.text.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/smooth_age_5.html b/docs/reference/smooth_age_5.html index 27c512d9d..d53cc5393 100644 --- a/docs/reference/smooth_age_5.html +++ b/docs/reference/smooth_age_5.html @@ -48,7 +48,7 @@ @@ -83,7 +83,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -163,7 +163,7 @@

      Smooth populations in 5-year age groups using various methods

      Smooth population counts in 5-year age groups using the Carrier-Farrag, -Karup-King-Newton, Arriaga, United Nations, Stong, or Zigzag methods. Allows for imputation +Karup-King-Newton, Arriaga, United Nations, Strong, MAV or Zigzag methods. Allows for imputation of values in the youngest and oldest age groups for the Carrier-Farrag, Karup-King-Newton, and United Nations methods.

      @@ -177,7 +177,7 @@

      Smooth populations in 5-year age groups using various methods

      ageMin = 10, ageMax = 65, n = 3, - young.tail = c("Original", "Arriaga", "Strong", NA), + young.tail = c("Original", "Arriaga", "Strong", "Cascade", NA), old.tail = young.tail )
      @@ -194,7 +194,7 @@

      Arg method -

      character string. Options include "Carrier-Farrag","Arriaga","KKN","United Nations", "Strong", and "Zigzag". See details. Default "Carrier-Farrag".

      +

      character string. Options include "Carrier-Farrag","Arriaga","KKN","United Nations", "Strong", MAV and "Zigzag". See details. Default "Carrier-Farrag".

      OAG @@ -234,8 +234,8 @@

      Details operate based on 10-year age group totals, excluding the open age group.

      The Carrier-Farrag, Karup-King-Newton, and United Nations methods do not produce estimates for the first and final 10-year age groups. By default, these are imputed with the original 5-year age group totals, but -you can also specify to impute with NA, or the results of the Arriaga or -Strong methods. If the terminal digit of the open age group is 5, then the terminal 10-year +you can also specify to impute with NA, or the results of the Arriaga, +Strong and Cascade methods. If the terminal digit of the open age group is 5, then the terminal 10-year age group shifts down, so imputations may affect more ages in this case. Imputation can follow different methods for young and old ages.

      Method names are simplified using simplify.text and checked against a set of plausible matches diff --git a/docs/reference/smooth_age_5_arriaga.html b/docs/reference/smooth_age_5_arriaga.html index bbcf16231..e753a8d09 100644 --- a/docs/reference/smooth_age_5_arriaga.html +++ b/docs/reference/smooth_age_5_arriaga.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/smooth_age_5_cf.html b/docs/reference/smooth_age_5_cf.html index 9e6b1b733..16f21701f 100644 --- a/docs/reference/smooth_age_5_cf.html +++ b/docs/reference/smooth_age_5_cf.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/smooth_age_5_feeney.html b/docs/reference/smooth_age_5_feeney.html index 1541759b8..d73252624 100644 --- a/docs/reference/smooth_age_5_feeney.html +++ b/docs/reference/smooth_age_5_feeney.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/smooth_age_5_kkn.html b/docs/reference/smooth_age_5_kkn.html index b9c33ac8c..759ea9ba5 100644 --- a/docs/reference/smooth_age_5_kkn.html +++ b/docs/reference/smooth_age_5_kkn.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/smooth_age_5_mav.html b/docs/reference/smooth_age_5_mav.html index 8c4ded7f5..053b936fd 100644 --- a/docs/reference/smooth_age_5_mav.html +++ b/docs/reference/smooth_age_5_mav.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 @@ -162,7 +162,7 @@

      Smooth in 5-year age groups using a moving average

      Smooth data in 5-year age groups.

      -
      smooth_age_5_mav(Value, Age, OAG = TRUE, n = 3)
      +
      smooth_age_5_mav(Value, Age, OAG = TRUE, n = 3, tails = FALSE)

      Arguments

      @@ -183,6 +183,11 @@

      Arg

      + + + +
      n

      integer. The width of the moving average. Default 3 intervals (x-5 to x+9).

      tails

      loglcal. If tails is FALSE, both tails are left untouched. +Otherwise, the tails are filled out using a cascade method.

      Value

      @@ -191,7 +196,9 @@

      Value

      Details

      This function calls smooth_age_5_zigzag_inner(), but prepares data in a way consistent with other methods called by smooth_age_5(). It is probably preferable to call zigzag() from the top level, or else call this method from agesmth() for more control over tail imputations.

      -

      This function calls mav(), which itself relies on the more general ma(). We lose the lowest and highest ages with this method, unless n=1, in which case data is returned in the original 5-year age groups. The total population count is not constrained to sum to the orignal total.

      +

      If tails is set to FALSE, this function calls mav(), which itself relies on the more general ma(). We lose the lowest and highest ages with this method, unless n=1, in which case data is returned in the original 5-year age groups. The total population count is not constrained to sum to the orignal total.

      +

      If tails is TRUE, the same results are expected but the tails are +filled in using a cascading method.

      Examples

      Age <- c(0,1,seq(5,90,by=5)) diff --git a/docs/reference/smooth_age_5_strong.html b/docs/reference/smooth_age_5_strong.html index a4ae92f3d..89837e03f 100644 --- a/docs/reference/smooth_age_5_strong.html +++ b/docs/reference/smooth_age_5_strong.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40
      diff --git a/docs/reference/smooth_age_5_un.html b/docs/reference/smooth_age_5_un.html index 6c23dcef9..060511159 100644 --- a/docs/reference/smooth_age_5_un.html +++ b/docs/reference/smooth_age_5_un.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/smooth_age_5_zigzag.html b/docs/reference/smooth_age_5_zigzag.html index b6ff4a53e..c76c505ea 100644 --- a/docs/reference/smooth_age_5_zigzag.html +++ b/docs/reference/smooth_age_5_zigzag.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/smooth_age_5_zigzag_inner.html b/docs/reference/smooth_age_5_zigzag_inner.html index b33ad613f..20c592774 100644 --- a/docs/reference/smooth_age_5_zigzag_inner.html +++ b/docs/reference/smooth_age_5_zigzag_inner.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/smooth_age_5_zigzag_min.html b/docs/reference/smooth_age_5_zigzag_min.html index b1224ff9a..2063a69a8 100644 --- a/docs/reference/smooth_age_5_zigzag_min.html +++ b/docs/reference/smooth_age_5_zigzag_min.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/smooth_age_5_zigzag_p.html b/docs/reference/smooth_age_5_zigzag_p.html index 8556ac239..e6f5c08c2 100644 --- a/docs/reference/smooth_age_5_zigzag_p.html +++ b/docs/reference/smooth_age_5_zigzag_p.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/spencer.html b/docs/reference/spencer.html index dd7ff689f..4fa4dec2b 100644 --- a/docs/reference/spencer.html +++ b/docs/reference/spencer.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/splitOscillate.html b/docs/reference/splitOscillate.html index 7062487ce..d381b62c4 100644 --- a/docs/reference/splitOscillate.html +++ b/docs/reference/splitOscillate.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/surv10.html b/docs/reference/surv10.html index a1c3be3f4..afbcb35b2 100644 --- a/docs/reference/surv10.html +++ b/docs/reference/surv10.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/surv5.html b/docs/reference/surv5.html index 666621d72..6d2320d6d 100644 --- a/docs/reference/surv5.html +++ b/docs/reference/surv5.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/survN.html b/docs/reference/survN.html index bcf5b72ad..8382c23a3 100644 --- a/docs/reference/survN.html +++ b/docs/reference/survN.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/survRatioError.html b/docs/reference/survRatioError.html index 10f1af91e..5d6a237d0 100644 --- a/docs/reference/survRatioError.html +++ b/docs/reference/survRatioError.html @@ -81,7 +81,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/reference/zelnik.html b/docs/reference/zelnik.html index 43c1cefef..40faf09dc 100644 --- a/docs/reference/zelnik.html +++ b/docs/reference/zelnik.html @@ -80,7 +80,7 @@ DemoTools - 01.11.03 + 01.13.40 diff --git a/docs/sitemap.xml b/docs/sitemap.xml index a3939bcd1..7e8fb85a5 100644 --- a/docs/sitemap.xml +++ b/docs/sitemap.xml @@ -54,9 +54,27 @@ https://timriffe.github.io/DemoTools//reference/age_abridge_force.html + + https://timriffe.github.io/DemoTools//reference/ages_asfr_five.html + + + https://timriffe.github.io/DemoTools//reference/ages_asfr_single.html + + + https://timriffe.github.io/DemoTools//reference/ages_five.html + + + https://timriffe.github.io/DemoTools//reference/ages_single.html + https://timriffe.github.io/DemoTools//reference/agesmth1.html + + https://timriffe.github.io/DemoTools//reference/asfr_mat_five.html + + + https://timriffe.github.io/DemoTools//reference/asfr_mat_single.html + https://timriffe.github.io/DemoTools//reference/avg_adj.html @@ -72,9 +90,6 @@ https://timriffe.github.io/DemoTools//reference/calcAgeN.html - - https://timriffe.github.io/DemoTools//reference/census_cohort_adjust.html - https://timriffe.github.io/DemoTools//reference/check_heaping_bachi.html @@ -108,6 +123,9 @@ https://timriffe.github.io/DemoTools//reference/dec.date.html + + https://timriffe.github.io/DemoTools//reference/downloadAsfr.html + https://timriffe.github.io/DemoTools//reference/downloadSRB.html @@ -118,7 +136,13 @@ https://timriffe.github.io/DemoTools//reference/dth5_zigzag.html - https://timriffe.github.io/DemoTools//reference/find.my.case.html + https://timriffe.github.io/DemoTools//reference/e0_swe.html + + + https://timriffe.github.io/DemoTools//reference/fetch_wpp_births.html + + + https://timriffe.github.io/DemoTools//reference/find_my_case.html https://timriffe.github.io/DemoTools//reference/fitted_logquad_b.html @@ -190,7 +214,22 @@ https://timriffe.github.io/DemoTools//reference/interp.html - https://timriffe.github.io/DemoTools//reference/interp_coh_bare.html + https://timriffe.github.io/DemoTools//reference/interp_coh.html + + + https://timriffe.github.io/DemoTools//reference/interp_lc_lim.html + + + https://timriffe.github.io/DemoTools//reference/interp_lc_lim_abk_m.html + + + https://timriffe.github.io/DemoTools//reference/interp_lc_lim_estimate.html + + + https://timriffe.github.io/DemoTools//reference/interp_lc_lim_group.html + + + https://timriffe.github.io/DemoTools//reference/interp_lc_lim_kt_min.html https://timriffe.github.io/DemoTools//reference/interpolatePop.html @@ -225,15 +264,30 @@ https://timriffe.github.io/DemoTools//reference/lt_abridged.html + + https://timriffe.github.io/DemoTools//reference/lt_abridged2single.html + + + https://timriffe.github.io/DemoTools//reference/lt_ambiguous.html + https://timriffe.github.io/DemoTools//reference/lt_id_L_T.html https://timriffe.github.io/DemoTools//reference/lt_id_Ll_S.html + + https://timriffe.github.io/DemoTools//reference/lt_id_d_l.html + + + https://timriffe.github.io/DemoTools//reference/lt_id_d_q.html + https://timriffe.github.io/DemoTools//reference/lt_id_l_d.html + + https://timriffe.github.io/DemoTools//reference/lt_id_l_q.html + https://timriffe.github.io/DemoTools//reference/lt_id_lda_L.html @@ -294,9 +348,15 @@ https://timriffe.github.io/DemoTools//reference/lt_single_qx.html + + https://timriffe.github.io/DemoTools//reference/lt_smooth_ambiguous.html + https://timriffe.github.io/DemoTools//reference/lthat.logquad.html + + https://timriffe.github.io/DemoTools//reference/mA_swe.html + https://timriffe.github.io/DemoTools//reference/ma.html @@ -306,6 +366,9 @@ https://timriffe.github.io/DemoTools//reference/maxA2abridged.html + + https://timriffe.github.io/DemoTools//reference/mig_beta.html + https://timriffe.github.io/DemoTools//reference/mig_calculate_rc.html @@ -313,7 +376,16 @@ https://timriffe.github.io/DemoTools//reference/mig_estimate_rc.html - https://timriffe.github.io/DemoTools//reference/mig_resid_stock.html + https://timriffe.github.io/DemoTools//reference/mig_resid.html + + + https://timriffe.github.io/DemoTools//reference/mig_un_fam.html + + + https://timriffe.github.io/DemoTools//reference/mig_un_families.html + + + https://timriffe.github.io/DemoTools//reference/mig_un_params.html https://timriffe.github.io/DemoTools//reference/names2age.html @@ -330,6 +402,12 @@ https://timriffe.github.io/DemoTools//reference/pop1m_pasex.html + + https://timriffe.github.io/DemoTools//reference/pop1m_rus2002.html + + + https://timriffe.github.io/DemoTools//reference/pop1m_rus2010.html + https://timriffe.github.io/DemoTools//reference/pop5_mat.html @@ -342,6 +420,18 @@ https://timriffe.github.io/DemoTools//reference/popA_later.html + + https://timriffe.github.io/DemoTools//reference/pop_f_mat_five.html + + + https://timriffe.github.io/DemoTools//reference/pop_f_mat_single.html + + + https://timriffe.github.io/DemoTools//reference/pop_m_mat_five.html + + + https://timriffe.github.io/DemoTools//reference/pop_m_mat_single.html + https://timriffe.github.io/DemoTools//reference/ratx.html @@ -360,6 +450,9 @@ https://timriffe.github.io/DemoTools//reference/shift.vector.html + + https://timriffe.github.io/DemoTools//reference/shift_census_ages_to_cohorts.html + https://timriffe.github.io/DemoTools//reference/simplify.text.html @@ -408,6 +501,24 @@ https://timriffe.github.io/DemoTools//reference/splitOscillate.html + + https://timriffe.github.io/DemoTools//reference/sr_f_mat_five.html + + + https://timriffe.github.io/DemoTools//reference/sr_f_mat_single.html + + + https://timriffe.github.io/DemoTools//reference/sr_m_mat_five.html + + + https://timriffe.github.io/DemoTools//reference/sr_m_mat_single.html + + + https://timriffe.github.io/DemoTools//reference/srb_vec_five.html + + + https://timriffe.github.io/DemoTools//reference/srb_vec_single.html + https://timriffe.github.io/DemoTools//reference/surv10.html diff --git a/inst/REFERENCES.bib b/inst/REFERENCES.bib index 0040f615e..9115fd856 100644 --- a/inst/REFERENCES.bib +++ b/inst/REFERENCES.bib @@ -315,3 +315,30 @@ @article{carrier1959reduction Title = {The reduction of errors in census populations for statistically underdeveloped countries}, Volume = {12}, Year = {1959}} + +@article{Li2005, + author = {Li, Nan and Lee, Ronald}, + title = {{Coherent mortality forecasts for a group of populations: An extension of the Lee-Carter method}}, + journal = {Demography}, + volume = {42}, + number = {3}, + pages = {575}, + year = {2005}, + month = {Aug}, + publisher = {NIH Public Access}, + doi = {10.1353/dem.2005.0021} +} + +@article{Li2004, + author = {Li, Nan and Lee, Ronald and Tuljapurkar, Shripad}, + title = {{Using the Lee-Carter Method to Forecast Mortality for Populations with Limited Data{$\ast$}}}, + journal = {Int. Stat. Rev.}, + volume = {72}, + number = {1}, + pages = {19--36}, + year = {2004}, + month = {Apr}, + issn = {0306-7734}, + publisher = {John Wiley {\&} Sons, Ltd}, + doi = {10.1111/j.1751-5823.2004.tb00221.x} +} diff --git a/man/DemoTools-package.Rd b/man/DemoTools-package.Rd index 3fa541f11..96d257720 100644 --- a/man/DemoTools-package.Rd +++ b/man/DemoTools-package.Rd @@ -30,6 +30,7 @@ Authors: Other contributors: \itemize{ + \item Peter Johnson [contributor] \item Jorge Cimentada (\href{https://orcid.org/0000-0001-5594-1156}{ORCID}) [contributor] \item Juan Galeano (\href{https://orcid.org/0000-0002-3682-1797}{ORCID}) [contributor] \item Derek Burk [contributor] diff --git a/man/OPAG_fit_stable_standard.Rd b/man/OPAG_fit_stable_standard.Rd index 26d3d606e..c3b2a4e07 100644 --- a/man/OPAG_fit_stable_standard.Rd +++ b/man/OPAG_fit_stable_standard.Rd @@ -41,7 +41,7 @@ redistribution in \code{OPAG()} } } \description{ -The stationary standard, \code{nLx} is transformed into a stable standard by optimizing a growth rate, \code{r} such that the stable standard matches observed population counts in selected age groups. Usually the ages used for fitting are wide age groups in older ages preceding the open age group. The standard output by this function is used by \code{OPAG} to creat the standard used to redistribute counts over older age groups up to a specified open age group, such as 100. +The stationary standard, \code{nLx} is transformed into a stable standard by optimizing a growth rate, \code{r} such that the stable standard matches observed population counts in selected age groups. Usually the ages used for fitting are wide age groups in older ages preceding the open age group. The standard output by this function is used by \code{OPAG} to create the standard used to redistribute counts over older age groups up to a specified open age group, such as 100. } \details{ The arguments \code{method} and \code{continous} don't have much leverage on the result. In short, the stable population transformation is done by ungrouping \code{nLx} to single ages (if it isn't already), and \code{method} controls which graduation method is used for this, where \code{"uniform"}, \code{"mono"}, \code{"pclm"} are the reasonable choices at this writing. In single ages, the difference between using a geometric \code{r} versus continuous \code{r} are quite small for this task. diff --git a/man/ages_asfr_five.Rd b/man/ages_asfr_five.Rd new file mode 100644 index 000000000..0ece98bd7 --- /dev/null +++ b/man/ages_asfr_five.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{ages_asfr_five} +\alias{ages_asfr_five} +\title{Ages between 15 and 45 in five year age groups} +\format{ +A vector of length 7 +} +\source{ +Migration residual PAS spreadhseet +} +\usage{ +ages_asfr_five +} +\description{ +Ages between 15 and 45 in five year age groups for unknown +country +} +\keyword{datasets} diff --git a/man/ages_asfr_single.Rd b/man/ages_asfr_single.Rd new file mode 100644 index 000000000..8e1eab99e --- /dev/null +++ b/man/ages_asfr_single.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{ages_asfr_single} +\alias{ages_asfr_single} +\title{Single ages between 15 and 49} +\format{ +A vector of length 36 +} +\source{ +Migration residual PAS spreadhseet +} +\usage{ +ages_asfr_single +} +\description{ +Single ages between 15 and 49 for Sweden +} +\keyword{datasets} diff --git a/man/ages_five.Rd b/man/ages_five.Rd new file mode 100644 index 000000000..4bb4a2642 --- /dev/null +++ b/man/ages_five.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{ages_five} +\alias{ages_five} +\title{Ages between 0 and 100 abridged in five year age groups} +\format{ +A vector of length 21 +} +\source{ +Migration residual PAS spreadhseet +} +\usage{ +ages_five +} +\description{ +Ages between 0 and 100 abridged in five year age groups for unknown +country +} +\keyword{datasets} diff --git a/man/ages_single.Rd b/man/ages_single.Rd new file mode 100644 index 000000000..773c95c27 --- /dev/null +++ b/man/ages_single.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{ages_single} +\alias{ages_single} +\title{Single ages between 0 and 100} +\format{ +A vector of length 101 +} +\source{ +Migration residual PAS spreadhseet +} +\usage{ +ages_single +} +\description{ +Single ages between 0 and 100 for Sweden, 1999-2019. +} +\keyword{datasets} diff --git a/man/asfr_mat_five.Rd b/man/asfr_mat_five.Rd new file mode 100644 index 000000000..7e60ea2f1 --- /dev/null +++ b/man/asfr_mat_five.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{asfr_mat_five} +\alias{asfr_mat_five} +\title{Age-specific fertility rates for age groups 15 to 45 between 1950 and 2045} +\format{ +A matrix of dimensions 7 x 20 +} +\source{ +Migration residual PAS spreadhseet +} +\usage{ +asfr_mat_five +} +\description{ +Age-specific fertility rates for age groups 15 to 45 between 1950 and 2045 +for unknown country +} +\keyword{datasets} diff --git a/man/asfr_mat_single.Rd b/man/asfr_mat_single.Rd new file mode 100644 index 000000000..7940b4dfc --- /dev/null +++ b/man/asfr_mat_single.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{asfr_mat_single} +\alias{asfr_mat_single} +\title{Age-specific fertility rates for single ages 15 to 49 between 1999 and 2018} +\format{ +A matrix of dimensions 35 x 20 +} +\source{ +Migration residual PAS spreadhseet +} +\usage{ +asfr_mat_single +} +\description{ +Age-specific fertility rates for single ages 15 to 49 between 1999 and 2018 +for Sweden +} +\keyword{datasets} diff --git a/man/basepop_five.Rd b/man/basepop_five.Rd index 15ed8d092..0a37bc585 100644 --- a/man/basepop_five.Rd +++ b/man/basepop_five.Rd @@ -5,7 +5,7 @@ \title{BPA and BPE methods for adjusting age groups under 10} \usage{ basepop_five( - country = NULL, + location = NULL, refDate, Age = NULL, Females_five, @@ -17,18 +17,22 @@ basepop_five( AsfrDatesIn = NULL, ..., SRB = NULL, + SRBDatesIn = NULL, radix = NULL, verbose = TRUE ) } \arguments{ -\item{country}{The country name or location code from which to download the n -Lx and asfr data. See \code{fertestr::locs_avail()} for all country -names/codes.} +\item{location}{UN Pop Division \code{LocName} or \code{LocID}} \item{refDate}{The reference year for which the reported population pertain (these are the population counts in \code{Females_five} and -\code{Males_five}). Can either be a decimal date, a \code{Date} class} +\code{Males_five}). Can either be a decimal date, a \code{Date} class. +If \code{nLxDatesIn} or \code{AsfrDatesIn} are not supplied and the +corresponding \code{nLxFemale/Male}/\code{AsfrMat} is not supplied, +\code{refDate} must be at a minimum 1962.5. This is because we can only +fetch WPP data from 1955 onwards, and these minimum date is assumed to be +7.5 years before \code{refDate}, meaning 1955.} \item{Age}{integer vector of lower bounds of abridged age groups given in \code{Females_five} and \code{Males_five}.} @@ -47,7 +51,7 @@ with ages in the rows and time in columns. The earlier date should be at least 7.5 years before the reference date of the "reported" population. The later date should be no earlier than one-half year before the reference date of the "reported" population. If not provided, it's automatically downloaded if -\code{country}, \code{refDate} and the equivalent population counts +\code{location}, \code{refDate} and the equivalent population counts \verb{*_five} are provided.} \item{nLxMale}{A numeric matrix. The male nLx function of two abridged life tables @@ -78,7 +82,13 @@ might be interested in changing the interpolation method for the \verb{nLx*} matrices and the \code{Asfr} matrix. By default, it's linearly interpolated.} \item{SRB}{A numeric. Sex ratio at birth (males / females). Default is set -to 1.05} +to 1.046. Only a maximum of three values permitted.} + +\item{SRBDatesIn}{A vector of numeric years (for example, 1986). Only a maximum +number of three dates allowed. These are +the dates which pertain to the values in \code{SRB}. If not provided, +the function automatically determines three dates which are 7.5 years, +2.5 and 0.5 years before \code{refDate}.} \item{radix}{starting point to use in the adjustment of the three first age groups. Default is NULL. If not provided, it is inferred based on the scale of age \verb{1L0}.} @@ -117,7 +127,7 @@ If \code{SmoothedFemales} is left empty, both \code{basepop_*} functions will adjust using the BPE method. For \code{basepop_five}, adjusting the female population counts is the -default. For this, only the \code{country}, \code{refDate} and +default. For this, only the \code{location}, \code{refDate} and \code{Females_five} are needed. All other arguments are downloaded or set to sensible defaults. For adjusting the male population counts, the user needs to specify the \code{Males_five} population @@ -242,23 +252,23 @@ underenumeration of persons in certain ages, nor by age misreporting. # Grab population counts for females refDate <- 1986 -country <- "Brazil" -pop_female_single <- fertestr::FetchPopWpp2019(country, - refDate, - ages = 0:100, +location <- "Brazil" +pop_female_single <- fertestr::FetchPopWpp2019(location, + refDate, + ages = 0:100, sex = "female") -pop_female_counts <- single2abridged(setNames(pop_female_single$pop, +pop_female_counts <- single2abridged(setNames(pop_female_single$pop, pop_female_single$ages)) -pop_male_single <- fertestr::FetchPopWpp2019(country, - refDate, - ages = 0:100, +pop_male_single <- fertestr::FetchPopWpp2019(location, + refDate, + ages = 0:100, sex = "male") -pop_male_counts <- single2abridged(setNames(pop_male_single$pop, +pop_male_counts <- single2abridged(setNames(pop_male_single$pop, pop_male_single$ages)) Age <- names2age(pop_male_counts) # Automatically downloads the nLx, ASFR, and SRB data bpe <- basepop_five( - country = country, + location = location, refDate = refDate, Females_five = pop_female_counts, Males_five = pop_male_counts, @@ -277,14 +287,14 @@ pop_male_counts[1:3] # blocked out for now, until single age function refactored as # TR: actually, it just needs to be rethought for single ages.. # pop_female_single <- setNames(pop_female_single$pop, pop_female_single$ages) -# +# # # Automatically downloads the nLx and ASFR data # bpe_female <- basepop_single( -# country = country, +# location = location, # refDate = refDate, # Females_single = pop_female_single # ) -# +# # # The counts for the first 10 age groups have been adjusted: # bpe_female[1:10] # pop_female_single[1:10] @@ -307,7 +317,7 @@ smoothed_males <- c(smoothed_males[1:2], smoothed_males[-1]) # Automatically downloads the nLx, ASFR, and SRB data bpa <- basepop_five( - country = country, + location = location, refDate = refDate, Females_five = smoothed_females, Males_five = smoothed_males, @@ -331,9 +341,9 @@ pop_male_counts[1:3] # (2) Reported population by 5-year age groups and sex in the base year # (Include unknowns). - pop_male_counts <- c(11684, 46738, 55639, 37514, 29398, 27187, 27770, 20920, 16973, + pop_male_counts <- c(11684, 46738, 55639, 37514, 29398, 27187, 27770, 20920, 16973, 14999, 11330, 10415, 6164, 7330, 3882, 3882, 1840, 4200) - + pop_female_counts <- c(11673, 46693, 55812, 35268, 33672, 31352, 33038, 24029, 16120, 14679, 8831, 9289, 4172, 6174, 2715, 3344, 1455, 4143) Age <- c(0,1, seq(5, 80, by = 5)) @@ -348,9 +358,9 @@ pop_male_counts[1:3] nLxMale <- matrix(c(87732, 304435, 361064, 88451, 310605, 370362), nrow = 3, ncol = 2) - nLxFemale <- matrix(c(89842, 314521, 372681, 353053, 340650, 326588, + nLxFemale <- matrix(c(89842, 314521, 372681, 353053, 340650, 326588, 311481, 295396, 278646, 261260, 241395,217419, - 90478, 320755, 382531, 364776, 353538, 340687, + 90478, 320755, 382531, 364776, 353538, 340687, 326701, 311573, 295501, 278494, 258748,234587), nrow = 12, ncol = 2) @@ -359,10 +369,10 @@ pop_male_counts[1:3] # date asfrmat <- structure( - c(0.2, 0.3, 0.3, 0.25, 0.2, 0.15, 0.05, 0.15, 0.2, - 0.275, 0.225, 0.175, 0.125, 0.05), .Dim = c(7L, 2L), + c(0.2, 0.3, 0.3, 0.25, 0.2, 0.15, 0.05, 0.15, 0.2, + 0.275, 0.225, 0.175, 0.125, 0.05), .Dim = c(7L, 2L), .Dimnames = list( - c("15-19", "20-24", "25-29", "30-34", "35-39", "40-44", "45-49"), + c("15-19", "20-24", "25-29", "30-34", "35-39", "40-44", "45-49"), c("1977.81", "1985.71"))) # for BPA, smooth counts in advance @@ -427,31 +437,31 @@ pop_male_counts[1:3] pop_female_counts[1:3] bpe$Females_adjusted[1:3] - + # basepop_single for single ages # Single ages for males and females # pop_male_counts <- -# c(11684, 11473, 11647, 11939, 11680, 10600, 11100, 11157, 11238, -# 11544, 7216, 7407, 7461, 7656, 7774, 5709, 5629, 5745, 6056, -# 6259, 5303, 5423, 5497, 5547, 5417, 5441, 5466, 5500, 5668, 5694, -# 4365, 4252, 4122, 4142, 4039, 3210, 3222, 3258, 3413, 3871, 2684, -# 2844, 3052, 3182, 3237, 2263, 2298, 2318, 2257, 2194, 2231, 2172, -# 2072, 2008, 1932, 1301, 1262, 1213, 1197, 1191, 1601, 1593, 1490, -# 1348, 1299, 568, 745, 843, 801, 925, 806, 883, 796, 725, 672, +# c(11684, 11473, 11647, 11939, 11680, 10600, 11100, 11157, 11238, +# 11544, 7216, 7407, 7461, 7656, 7774, 5709, 5629, 5745, 6056, +# 6259, 5303, 5423, 5497, 5547, 5417, 5441, 5466, 5500, 5668, 5694, +# 4365, 4252, 4122, 4142, 4039, 3210, 3222, 3258, 3413, 3871, 2684, +# 2844, 3052, 3182, 3237, 2263, 2298, 2318, 2257, 2194, 2231, 2172, +# 2072, 2008, 1932, 1301, 1262, 1213, 1197, 1191, 1601, 1593, 1490, +# 1348, 1299, 568, 745, 843, 801, 925, 806, 883, 796, 725, 672, # 470, 441, 340, 300, 289, 4200) -# +# # pop_female_counts <- -# c(11673, 11474, 11670, 11934, 11614, 10603, 11144, 11179, 11269, -# 11617, 6772, 6948, 7030, 7211, 7306, 6531, 6443, 6535, 6951, -# 7213, 6096, 6234, 6327, 6410, 6285, 6464, 6492, 6549, 6739, 6795, -# 5013, 4888, 4735, 4747, 4646, 3040, 3068, 3107, 3246, 3658, 2650, -# 2788, 2977, 3108, 3156, 1756, 1784, 1802, 1764, 1724, 1982, 1935, -# 1846, 1795, 1731, 863, 850, 825, 819, 816, 1348, 1342, 1246, -# 1138, 1101, 391, 520, 585, 560, 659, 670, 750, 686, 634, 604, +# c(11673, 11474, 11670, 11934, 11614, 10603, 11144, 11179, 11269, +# 11617, 6772, 6948, 7030, 7211, 7306, 6531, 6443, 6535, 6951, +# 7213, 6096, 6234, 6327, 6410, 6285, 6464, 6492, 6549, 6739, 6795, +# 5013, 4888, 4735, 4747, 4646, 3040, 3068, 3107, 3246, 3658, 2650, +# 2788, 2977, 3108, 3156, 1756, 1784, 1802, 1764, 1724, 1982, 1935, +# 1846, 1795, 1731, 863, 850, 825, 819, 816, 1348, 1342, 1246, +# 1138, 1101, 391, 520, 585, 560, 659, 670, 750, 686, 634, 604, # 353, 340, 270, 246, 247, 4143) # Age <- 0:80 -# +# # smoothed_females <- smooth_age_5(Value = pop_female_counts, # Age = Age, # method = "Arriaga", @@ -465,7 +475,7 @@ pop_male_counts[1:3] # For adjusting using BPA for males, we need to specify # female = FALSE with Males and nLxMale. - + # This needs work still # bpa_male <- # basepop_single( @@ -499,7 +509,7 @@ pop_male_counts[1:3] # pop_female_counts[1:10] # bpa_female[1:10] - # + # # # For adjustment using BPE, we use exactly the same definitions as above # # but remove SmoothedFemales. # bpe_male <- @@ -532,7 +542,7 @@ pop_male_counts[1:3] # AsfrMat = asfrmat, # AsfrDatesIn = AsfrDatesIn # ) - # + # # pop_female_counts[1:10] # bpa_female[1:10] # bpe_female[1:10] diff --git a/man/census_cohort_adjust.Rd b/man/census_cohort_adjust.Rd deleted file mode 100644 index 130c07623..000000000 --- a/man/census_cohort_adjust.Rd +++ /dev/null @@ -1,30 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interp_coh.R -\name{census_cohort_adjust} -\alias{census_cohort_adjust} -\title{shift census populations to match single year cohorts} -\usage{ -census_cohort_adjust(Pop, Age, date) -} -\arguments{ -\item{Pop}{numeric vector. Population counts in single ages} - -\item{Age}{integer. Lower bound of single age groups} - -\item{date}{Either a \code{Date} class object or an unambiguous character string in the format \code{"YYYY-MM-DD"}.} -} -\description{ -Matches the (single) ages of a census to single cohorts. For use in intercensal interpolations. Ages are potentially blended to match single cohort line assuming that the population in each age is uniformly distributed over the age group. -} -\examples{ -Pop <- seq(10000,100,length.out = 101) -Age <- 0:100 -d1 <- "2020-01-01" -d2 <- "2020-07-01" -d3 <- "2020-12-21" - -census_cohort_adjust(Pop,Age,d1) -census_cohort_adjust(Pop,Age,d2) -census_cohort_adjust(Pop,Age,d3) -census_cohort_adjust(Pop,Age,2020.5) -} diff --git a/man/check_heaping_bachi.Rd b/man/check_heaping_bachi.Rd index e28449caf..739baf8c6 100644 --- a/man/check_heaping_bachi.Rd +++ b/man/check_heaping_bachi.Rd @@ -8,9 +8,10 @@ check_heaping_bachi( Value, Age, ageMin = 23, - ageMax = 77, + ageMax = NULL, method = "orig", - details = FALSE + details = FALSE, + OAG = TRUE ) } \arguments{ @@ -25,6 +26,8 @@ check_heaping_bachi( \item{method}{either \code{"orig"} or \code{"pasex"}} \item{details}{logical. Should a list of output be given} + +\item{OAG}{logical. Is the highest age group open?} } \value{ The value of the index. @@ -34,20 +37,25 @@ Bachi's index involves applying the Whipple method repeatedly to determine the e } \details{ \code{ageMax} is an inclusive upper bound, treated as interval. If you want ages -23 to 77, then give \code{ageMin = 23} and \code{ageMax = 77}, not 80. The \code{ageMin} is respected strictly, whereas \code{ageMax} could be higher than the actual maximum age used. You can see the age ranges actually used by specifying \code{details = TRUE}. +23 to 77, then give \code{ageMin = 23} and \code{ageMax = 77}. The \code{ageMin} is respected strictly, whereas \code{ageMax} is calculated flexibly- if you specify something too high then it is reduced and we warn accordingly, and if it's missing then we pick something reasonable. You can see the age ranges actually used by specifying \code{details = TRUE}. } \examples{ - Age <- 0:99 - check_heaping_bachi(pop1m_pasex, Age, ageMin = 23, ageMax = 77, method = "orig") - check_heaping_bachi(pop1m_ind, Age, ageMin = 23, ageMax = 77, method = "orig") + check_heaping_bachi(pop1m_pasex, Age = 0:99, + ageMin = 23, ageMax = 77, method = "orig", OAG =FALSE) + check_heaping_bachi(pop1m_ind, Age = 0:100, + ageMin = 23, ageMax = 77, method = "orig") # default simpler - check_heaping_bachi(pop1m_pasex, Age, ageMin = 23, ageMax = 77, method = "pasex") + check_heaping_bachi(pop1m_pasex, Age = 0:99, + ageMin = 23, ageMax = 77, method = "pasex", OAG = FALSE) # linear population, should give 0 for pasex - check_heaping_bachi(seq(100000,1000,by=-1000),Age, ageMin = 23, ageMax = 77, method = "pasex") + check_heaping_bachi(seq(100000,1000,by=-1000),Age = 0:99, + ageMin = 23, ageMax = 77, method = "pasex", OAG = FALSE) # fully concentrated, should give 90 pop_concetrated <- rep(c(100,rep(0,9)),10) - check_heaping_bachi(pop_concetrated,Age, ageMin = 23, ageMax = 77, method = "pasex") - check_heaping_bachi(pop_concetrated,Age, ageMin = 23, ageMax = 77, method = "orig") + check_heaping_bachi(pop_concetrated, Age = 0:99, + ageMin = 23, ageMax = 77, method = "pasex") + check_heaping_bachi(pop_concetrated, Age = 0:99, + ageMin = 23, ageMax = 77, method = "orig") } \references{ \insertRef{PAS}{DemoTools} diff --git a/man/downloadAsfr.Rd b/man/downloadAsfr.Rd new file mode 100644 index 000000000..609808be2 --- /dev/null +++ b/man/downloadAsfr.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils_downloads.R +\name{downloadAsfr} +\alias{downloadAsfr} +\title{Extract ASFR estimates from WPP2019. Mainly an util function for other ones.} +\usage{ +downloadAsfr(Asfrmat, location = NULL, AsfrDatesIn, method = "linear") +} +\arguments{ +\item{Asfrmat}{numeric.} + +\item{location}{vector. UN Pop Div \code{LocName} or \code{LocID}} + +\item{AsfrDatesIn}{numeric. Vector of decimal dates.} + +\item{method}{character. Could be \code{"linear"}, \code{"exponential"}, or \code{"power"}} +} +\value{ +numeric matrix interpolated asfr +} +\description{ +We extract \code{ASFRx} from \code{wpp2019}, interpolated to exact dates. Different methods availables. +A vector of countries can handle, but with an unique sex. Row names are not indicative of countries. +} +\examples{ +# Total fertility ratio calculated from ASFRx downloaded from WPP19. +# See `downloadnLx` for analogous examples on multiple countries or using codes instead of names. +ASFR_Arg <- downloadAsfr(Asfrmat = NULL, location = "Argentina", AsfrDatesIn = 1950:2025) +\dontrun{ +plot(1950:2025, as.numeric(colSums(ASFR_Arg))*5, xlab = "Year", ylab="TFR", ylim=c(1.5,4), t="l") +} +} diff --git a/man/downloadSRB.Rd b/man/downloadSRB.Rd index e71fb0f24..5f28de7f8 100644 --- a/man/downloadSRB.Rd +++ b/man/downloadSRB.Rd @@ -1,17 +1,19 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/basepop.R +% Please edit documentation in R/utils_downloads.R \name{downloadSRB} \alias{downloadSRB} \title{Extract SRB estimates from WPP2019} \usage{ -downloadSRB(SRB, country, DatesOut) +downloadSRB(SRB, location, DatesOut, verbose = TRUE) } \arguments{ \item{SRB}{sex ratio at birth. Either \code{NULL}, a scalar to assume constant, or a vector of length 3, assumed.} -\item{country}{character country name available UN Pop Div \code{LocName} set} +\item{location}{UN Pop Div \code{LocName} or \code{LocID}} \item{DatesOut}{numeric vector of three decimal dates produced by \code{basepop_ive()}} + +\item{verbose}{logical, shall we send optional messages to the console?} } \value{ numeric vector with three SRB estimates diff --git a/man/downloadnLx.Rd b/man/downloadnLx.Rd index d1f455696..0b5f18d67 100644 --- a/man/downloadnLx.Rd +++ b/man/downloadnLx.Rd @@ -1,23 +1,47 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/basepop.R +% Please edit documentation in R/utils_downloads.R \name{downloadnLx} \alias{downloadnLx} -\title{Extract Lx estimates from WPP2019} +\title{Extract Lx estimates from WPP2019. Mainly an util function for other ones.} \usage{ -downloadnLx(nLx, country, gender, nLxDatesIn) +downloadnLx(nLx, location, gender, nLxDatesIn, method = "linear") } \arguments{ -\item{nLx}{either \code{NULL} or a numeric vector of lifetable exposure. If it's the second then we just pass it back.} +\item{nLx}{numeric. either \code{NULL} or a numeric vector of lifetable exposure. If it's the second then we just pass it back.} -\item{country}{character country name available UN Pop Div \code{LocName} set} +\item{location}{vector. UN Pop Div \code{LocName} or \code{LocID}} -\item{gender}{\code{"male"}, \code{"female"}, or \code{"both"}} +\item{gender}{character. \code{"male"}, \code{"female"}, or \code{"both"}} -\item{nLxDatesIn}{numeric vector of three decimal dates produced by (or passed through) \code{basepop_ive()}} +\item{nLxDatesIn}{numeric. Vector of three decimal dates produced by (or passed through) \code{basepop_five()}} + +\item{method}{character. Could be \code{"linear"}, \code{"exponential"}, or \code{"power"}} } \value{ numeric matrix of \code{nLx} with \code{length(nLxDatesIn)} and abrdiged ages in rows. } \description{ -We use the \code{FetchLifeTableWpp2019} function of the \code{fertestr} to extract \code{Lx} from \code{wpp2019}, interpolated to an exact date. +We extract \code{Lx} from \code{wpp2019}, interpolated to exact dates. Different methods availables. +A vector of countries can handle, but with an unique sex. Row names are not indicative of countries. +} +\examples{ +# life expectancy calculated from Lx downloaded from WPP19. Using names or codes. +Lxs_name <- downloadnLx(nLx=NULL, location = "Argentina", + gender = "both", nLxDatesIn = 1950:2030) +Lxs_code <- downloadnLx(nLx=NULL, location = "32", + gender = "both", nLxDatesIn = 1950:2030) +\dontrun{ +plot(1950:2030, as.numeric(colSums(Lxs_name)), xlab = "Year", ylab="e0") +lines(1950:2030, as.numeric(colSums(Lxs_code))) +} +# life expectancy for different countries +Lxs_countries <- downloadnLx(nLx=NULL, location = c("Argentina","Brazil","Uruguay"), +gender = "both", nLxDatesIn = 1950:2025) +\dontrun{ +plot(1950:2025, as.numeric(colSums(Lxs_countries[1:22,])), + t="l", xlab = "Year", ylab="e0", ylim = c(40,80)) +lines(1950:2025, as.numeric(colSums(Lxs_countries[23:44,])), col=2) +lines(1950:2025, as.numeric(colSums(Lxs_countries[45:64,])), col=3) +legend("bottomright",c("Argentina","Brazil","Uruguay"),lty=1,col=1:3) +} } diff --git a/man/e0_swe.Rd b/man/e0_swe.Rd new file mode 100644 index 000000000..2d9552465 --- /dev/null +++ b/man/e0_swe.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{e0_swe} +\alias{e0_swe} +\title{Swedish life expectancy at birth} +\format{ +A data frame with: +\describe{ +\item{Date}{Reference time.} +\item{Sex}{Male \code{m} and female \code{m}.} +\item{e0}{Life expectancy at birth.} +} +} +\source{ +Human Mortality Database. Retrieved 2021-20-01, from \url{https://mortality.org} +} +\usage{ +e0_swe +} +\description{ +Life expectancy at birth by sex in tidy format for dates from 1960-07-01 to 2015-07-01 by 5 calendar years. +} +\keyword{datasets} diff --git a/man/fetch_wpp_births.Rd b/man/fetch_wpp_births.Rd new file mode 100644 index 000000000..a0273b696 --- /dev/null +++ b/man/fetch_wpp_births.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils_downloads.R +\name{fetch_wpp_births} +\alias{fetch_wpp_births} +\title{extract births from wpp2019} +\usage{ +fetch_wpp_births(births, yrs_births, location, sex, verbose) +} +\arguments{ +\item{births}{\code{NULL} or else a vector of births to simply return} + +\item{yrs_births}{vector of years to extract} + +\item{location}{UN Pop Dov \code{LocName} or \code{LocID}} + +\item{sex}{\code{"male"}, \code{"female"}, or \code{"both"}} + +\item{verbose}{logical, shall we send optional messages to the console?} +} +\value{ +vector of births +} +\description{ +extract births from wpp2019 +} diff --git a/man/find.my.case.Rd b/man/find_my_case.Rd similarity index 90% rename from man/find.my.case.Rd rename to man/find_my_case.Rd index df4ffbd95..73557c6b6 100644 --- a/man/find.my.case.Rd +++ b/man/find_my_case.Rd @@ -1,11 +1,11 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/lt_model_lq.R -\name{find.my.case} -\alias{find.my.case} +\name{find_my_case} +\alias{find_my_case} \title{Function that determines the case/problem we have to solve It also performs some checks} \usage{ -find.my.case(par_ind) +find_my_case(par_ind) } \arguments{ \item{par_ind}{logical vector of length 5} diff --git a/man/graduate_beers.Rd b/man/graduate_beers.Rd index b9cdafd3f..2d4618773 100644 --- a/man/graduate_beers.Rd +++ b/man/graduate_beers.Rd @@ -4,7 +4,7 @@ \alias{graduate_beers} \title{The ordinary modified Beers splitting methods} \usage{ -graduate_beers(Value, Age, AgeInt, OAG = TRUE, method = "mod", johnson = FALSE) +graduate_beers(Value, Age, AgeInt, OAG = TRUE, method = "ord", johnson = FALSE) } \arguments{ \item{Value}{numeric vector, presumably counts in grouped ages} @@ -15,9 +15,9 @@ graduate_beers(Value, Age, AgeInt, OAG = TRUE, method = "mod", johnson = FALSE) \item{OAG}{logical, default = \code{TRUE} is the final age group open?} -\item{method}{character. Valid values are \code{"mod"} or \code{"ord"}. Default \code{"mod"}.} +\item{method}{character. Valid values are \code{"ord"} or \code{"mod"}. Default \code{"ord"}.} -\item{johnson}{logical. Whether or not to adjust young ages according to the \href{https://www.census.gov/data/software/dapps.html}{Demographic Analysis & Population Projection System Software} method. Default \code{FALSE}.} +\item{johnson}{logical. Whether or not to adjust young ages according to the \href{https://www.census.gov/data/software/dapps.html}{Demographic Analysis & Population Projection System Software} method. Default \code{FALSE.}} } \value{ A numeric vector of single age data. @@ -28,7 +28,9 @@ This method offers both ordinary and modified Beers splitting, with an optional \details{ Ages should refer to lower age bounds. \code{Value} must be labelled with ages unless \code{Age} is given separately. There must be at least six 5-year age groups (including the open group, 5 otherwise). If you want the \code{johnson} adjustment then \code{Value} must contain a single-year estimate of the population count in age 0. That means \code{Value} must come either as standard abridged or single age data. -If the highest age does not end in a 0 or 5, and \code{OAG == TRUE}, then the open age will be grouped down to the next highest age ending in 0 or 5. If the highest age does not end in a 0 or 5, and \code{OAG == FALSE}, then results extend to single ages covering the entire 5-year age group. +\code{method} option \code{"ord"} conserves sums in 5-year age groups, whereas \code{"mod"} does some smoothing between 5-year age groups too, and is not constrained. + +If the highest age does not end in a 0 or 5, and \code{OAG == TRUE}, then the open age will be grouped down to the next highest age ending in 0 or 5. If the highest age does not end in a 0 or 5, and \code{OAG = FALSE}, then results extend to single ages covering the entire 5-year age group. } \examples{ p5 <- pop5_mat diff --git a/man/graduate_grabill.Rd b/man/graduate_grabill.Rd index 0d8224988..beff7cb91 100644 --- a/man/graduate_grabill.Rd +++ b/man/graduate_grabill.Rd @@ -4,13 +4,15 @@ \alias{graduate_grabill} \title{The basic Grabill age-splitting method} \usage{ -graduate_grabill(Value, Age, OAG = TRUE) +graduate_grabill(Value, Age, AgeInt, OAG = TRUE) } \arguments{ \item{Value}{numeric vector, presumably counts in grouped ages} \item{Age}{integer vector, lower bounds of age groups} +\item{AgeInt}{integer vector, age interval widths} + \item{OAG}{logical, default = \code{TRUE} is the final age group open?} } \value{ diff --git a/man/graduate_mono.Rd b/man/graduate_mono.Rd index d6a1b1244..36637b510 100644 --- a/man/graduate_mono.Rd +++ b/man/graduate_mono.Rd @@ -4,15 +4,15 @@ \alias{graduate_mono} \title{Graduate age groups using a monotonic spline.} \usage{ -graduate_mono(Value, AgeInt, Age, OAG = TRUE) +graduate_mono(Value, Age, AgeInt, OAG = TRUE) } \arguments{ \item{Value}{numeric vector, presumably counts in grouped ages} -\item{AgeInt}{integer vector, age interval widths} - \item{Age}{integer vector, lower bounds of age groups} +\item{AgeInt}{integer vector, age interval widths} + \item{OAG}{logical, default = \code{TRUE} is the final age group open?} } \value{ @@ -22,7 +22,7 @@ Numeric. vector of single smoothed age counts. Take the cumulative sum of \code{Value} and then run a monotonic spline through it. The first differences split back single-age estimates of \code{Value}. Optionally keep the open age group untouched. } \details{ -The \code{"monoH.FC"} method of \code{stats::splinefun()} is used to fit the spline because 1) it passes exactly through the points, 2) it is monotonic and therefore guarantees positive counts, and 3) it seems to be a bit less wiggly (lower average first differences of split counts). Single-age data is returned as-is. If you want to use this function as a smoother you first need to group to non-single ages. +The \code{"hyman"} method of \code{stats::splinefun()} is used to fit the spline because 1) it passes exactly through the points, 2) it is monotonic and therefore guarantees positive counts, and 3) it seems to be a bit less wiggly (lower average first differences of split counts). Single-age data is returned as-is. If you want to use this function as a smoother you first need to group to non-single ages. \code{Age} be any age range, it does not need to start at 0. } \examples{ Value <- structure(c(88623, 90842, 93439, 96325, 99281, 102051, 104351, @@ -31,19 +31,22 @@ Value <- structure(c(88623, 90842, 93439, 96325, 99281, 102051, 1 "10", "15", "20", "25", "30", "35", "40", "45", "50", "55", "60", "65", "70", "75", "80", "85", "90", "95", "100")) -# overwrite open age group with a single age estimate for that age -# (doesn't extrapolate) -graduate_mono(Value) -# or respect open age group +# if the last age group is closed, then it's best to use AgeInt, otherwise, +# one is assumed from the age siphoned from the names attribute of Value. +graduate_mono(Value, OAG = FALSE) +# or leave open age group in tact graduate_mono(Value, OAG = TRUE) -# Also accepts single ages: -Value <- structure(pop1m_ind, .Names = 0:100) +data(pop1m_ind) +Value5 <- groupAges(pop1m_ind,Age=0:100,N=5) + +Value1 <- graduate_mono(Value = Value5, Age = names2age(Value5), OAG =TRUE) - \dontrun{ - ages <- seq(0,100,5) - plot(graduate_mono(Value),xlab = 'Age', ylab = 'Counts', type = 'l',main = 'Ungrouped counts') - } +\dontrun{ + + plot(seq(0,100,5),Value5 / 5, xlab = 'Age', ylab = 'Counts', type = 's') + lines(0:100,Value1) +} } \references{ \insertRef{fritsch1980monotone}{DemoTools} diff --git a/man/graduate_mono_closeout.Rd b/man/graduate_mono_closeout.Rd index c0dfa1ba7..90829643a 100644 --- a/man/graduate_mono_closeout.Rd +++ b/man/graduate_mono_closeout.Rd @@ -38,7 +38,7 @@ A simple monotonic spline on the cumulative sum of population counts may return } \details{ The \code{pivotAge} must be at least 10 years below the maximum age detected from -\code{rownames(popmat)}, but not lower than 75. In the exact \code{pivotAge}, we may either take the Sprague estimates or the spline estimates, depending on which is larger, then the single-age estimates for this 5-year age group are rescaled to sum to the original total in \code{Value}. Higher ages are taken from the spline-based age splits. The spline results are derive from the \code{"monoH.FC"} method of \code{splinefun()} on the cumulative sum of the original age grouped data. One could use this function to perform the same closeout to Grabill estimates, if these are given via the \code{pops} argument. See examples. Note that the Grabill split method mixed with this closeout will not necessarily preserve the annual totals, and this function performs to rescaling. The open age group is preserved (and must be included in \code{Value}). +\code{rownames(popmat)}, but not lower than 75. In the exact \code{pivotAge}, we may either take the Sprague estimates or the spline estimates, depending on which is larger, then the single-age estimates for this 5-year age group are rescaled to sum to the original total in \code{Value}. Higher ages are taken from the spline-based age splits. The spline results are derive from the \code{"hyman"} method of \code{splinefun()} on the cumulative sum of the original age grouped data. One could use this function to perform the same closeout to Grabill estimates, if these are given via the \code{pops} argument. See examples. Note that the Grabill split method mixed with this closeout will not necessarily preserve the annual totals, and this function performs to rescaling. The open age group is preserved (and must be included in \code{Value}). } \examples{ a5 <- as.integer(rownames(pop5_mat)) diff --git a/man/graduate_pclm.Rd b/man/graduate_pclm.Rd index c2b24cf58..5e0f8951e 100644 --- a/man/graduate_pclm.Rd +++ b/man/graduate_pclm.Rd @@ -4,15 +4,19 @@ \alias{graduate_pclm} \title{wrapper for \code{ungroup::pclm} method of splitting binned counts} \usage{ -graduate_pclm(Value, Age, OAnew = max(Age), ...) +graduate_pclm(Value, Age, AgeInt, OAnew = max(Age), OAG = TRUE, ...) } \arguments{ \item{Value}{numeric vector, presumably counts in grouped ages} \item{Age}{integer vector, lower bounds of age groups} +\item{AgeInt}{integer vector, age interval widths} + \item{OAnew}{integer, optional new open age, higher than \code{max(Age)}. See details.} +\item{OAG}{logical, default = \code{TRUE} is the final age group open?} + \item{...}{further arguments passed to \code{ungroup::pclm()}} } \description{ @@ -20,6 +24,10 @@ This is exactly the function \code{pclm()} from the \code{ungroup} package, exce } \details{ The PCLM method can also be used to graduate rates using an offset if both numerators and denominators are available. In this case \code{Value} is the event count and \code{offset} is person years of exposure. The denominator must match the length of \code{Value} or else the length of the final single age result \code{length(min(Age):OAnew)}. This method can be used to redistribute counts in the open age group if \code{OAnew} gives sufficient space. Likewise, it can give a rate extrapolation beyond the open age. + +If there are 0s in \code{Value}, these are replaced with a small value prior to fitting. If negatives result from the pclm fit, we retry after multiplying \code{Value} by 10, 100, or 1000, as sometimes a temporary rescale for fitting can help performance. + +\code{Age} be any age range, it does not need to start at 0. } \examples{ a5 <- seq(0,100,by=5) diff --git a/man/graduate_sprague.Rd b/man/graduate_sprague.Rd index badc400d9..45173f286 100644 --- a/man/graduate_sprague.Rd +++ b/man/graduate_sprague.Rd @@ -4,13 +4,15 @@ \alias{graduate_sprague} \title{The basic Sprague age-splitting method.} \usage{ -graduate_sprague(Value, Age, OAG = TRUE) +graduate_sprague(Value, Age, AgeInt, OAG = TRUE) } \arguments{ \item{Value}{numeric vector, presumably counts in grouped ages} \item{Age}{integer vector, lower bounds of age groups} +\item{AgeInt}{integer vector, age interval widths} + \item{OAG}{logical, default = \code{TRUE} is the final age group open?} } \value{ diff --git a/man/graduate_uniform.Rd b/man/graduate_uniform.Rd index 83909af45..48c7aacc0 100644 --- a/man/graduate_uniform.Rd +++ b/man/graduate_uniform.Rd @@ -4,15 +4,15 @@ \alias{graduate_uniform} \title{Convert arbitrary age groupings into single years of age.} \usage{ -graduate_uniform(Value, AgeInt, Age, OAG = TRUE, OAvalue = 1) +graduate_uniform(Value, Age, AgeInt, OAG = TRUE, OAvalue = 1) } \arguments{ \item{Value}{numeric vector, presumably counts in grouped ages} -\item{AgeInt}{integer vector, age interval widths} - \item{Age}{integer vector, lower bounds of age groups} +\item{AgeInt}{integer vector, age interval widths} + \item{OAG}{logical, default = \code{TRUE} is the final age group open?} \item{OAvalue}{Desired width of open age group. See details.} @@ -24,7 +24,7 @@ Numeric vector of counts for single year age groups. Uniformly splits aggregate counts in age groups into single year age groups. } \details{ -Assumes that the population is uniformly distributed across each age interval, and that initial age intervals are integers greater than or equal to 1. If \code{AgeInt} is given, its final value is used as the interval for the final age group. If \code{AgeInt} is missing, then \code{Age} must be given, and the open age group is by default preserved \code{OAvalue} rather than split. To instead split the final age group into, e.g., a 5-year age class, either give \code{AgeInt}, \emph{or} give \code{Age}, \code{OAG = TRUE}, and \code{OAvalue = 5}. +Assumes that the population is uniformly distributed across each age interval, and that initial age intervals are integers greater than or equal to 1. If \code{AgeInt} is given, its final value is used as the interval for the final age group. If \code{AgeInt} is missing, then \code{Age} must be given, and the open age group is by default preserved \code{OAvalue} rather than split. To instead split the final age group into, e.g., a 5-year age class, either give \code{AgeInt}, \emph{or} give \code{Age}, \code{OAG = TRUE}, and \code{OAvalue = 5}. \code{Age} be any age range, it does not need to start at 0. } \examples{ MalePop <- c(9544406,7471790,11590109,11881844,11872503,12968350, diff --git a/man/interp.Rd b/man/interp.Rd index 4164c60b3..727df227b 100644 --- a/man/interp.Rd +++ b/man/interp.Rd @@ -10,6 +10,7 @@ interp( datesOut, method = c("linear", "exponential", "power"), power = 2, + extrap = FALSE, ... ) } @@ -24,6 +25,8 @@ interp( \item{power}{numeric power to interpolate by, if \code{method = "power"}. Default 2.} +\item{extrap}{logical. In case \code{datesOut} is out of range of datesIn, do extrapolation using slope in extreme pairwise. Deafult \code{FALSE}.} + \item{...}{arguments passed to \code{stats::approx}. For example, \code{rule}, which controls extrapolation behavior.} } \value{ diff --git a/man/interp_coh.Rd b/man/interp_coh.Rd new file mode 100644 index 000000000..5c2aa5e2e --- /dev/null +++ b/man/interp_coh.Rd @@ -0,0 +1,85 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/interp_coh.R +\name{interp_coh} +\alias{interp_coh} +\title{Cohort component intercensal interpolation} +\usage{ +interp_coh( + c1, + c2, + date1, + date2, + age1 = 1:length(c1) - 1, + age2 = 1:length(c2) - 1, + dates_out = NULL, + lxMat = NULL, + age_lx = NULL, + dates_lx = NULL, + births = NULL, + years_births = NULL, + location = NULL, + sex = "both", + midyear = FALSE, + verbose = TRUE, + ... +) +} +\arguments{ +\item{c1}{numeric vector. The first (left) census in single age groups} + +\item{c2}{numeric vector. The second (right) census in single age groups} + +\item{date1}{reference date of c1`. Either a Date class object or an unambiguous character string in the format "YYYY-MM-DD".} + +\item{date2}{reference date of c2`. Either a Date class object or an unambiguous character string in the format "YYYY-MM-DD".} + +\item{age1}{integer vector. single ages of \code{c1}} + +\item{age2}{integer vector. single ages of \code{c2}} + +\item{dates_out}{vector of desired output dates coercible to numeric using \code{dec.date()}} + +\item{lxMat}{numeric matrix containing lifetable survivorship, \code{l(x)}. Each row is an age group and each column a time point. At least two intercensal time points needed.} + +\item{age_lx}{integer vector. Age classes in \code{lxMat}} + +\item{dates_lx}{date, character, or numeric vector of the column time points for \code{lxMat}. If these are calendar-year estimates, then you can choose mid-year time points} + +\item{births}{integer vector. Raw birth counts for the corresponding (sub)-population, one value per each year of the intercensal period including both census years. The first and last years should include all births in the given year; don't discount them in advance.} + +\item{years_births}{numeric vector of calendar years of births.} + +\item{location}{UN Pop Division \code{LocName} or \code{LocID}} + +\item{sex}{character string, either \code{"male"}, \code{"female"}, or \code{"both"}} + +\item{midyear}{logical. \code{FALSE} means all Jan 1 dates between \code{date1} and \code{date2} are returned. \code{TRUE} means all July 1 intercensal dates are returned.} + +\item{verbose}{logical. Shall we send informative messages to the console?} + +\item{...}{optional arguments passed to} +} +\description{ +Cohorts between two censuses are interpolated using a cohort component approach. +} +\details{ +The basic approach is to i) align the censuses to single-year cohorts by blending adjacent ages assuming that the birthdays in each age group are uniformly distributed through the year ii) decrement the first census forward within cohorts using period-cohort survival probabilities calculated from (supplied or downloaded) \code{l(x)} values, iii) redistribute the residual at the time of the second census uniformly over time within cohorts. These steps are always done on Jan 1 reference dates. If \code{midyear = TRUE}, then we do within-age band arithmetic interpolation to July 1 reference dates. +} +\examples{ + +\dontrun{ +interp_coh( +location = "Russian Federation", +sex = "male", +c1 = pop1m_rus2002, +c2 = pop1m_rus2010, +date1 = "2002-10-16", +date2 = "2010-10-25", +age1 = 0:100, +births = c(719511L, 760934L, 772973L, 749554L, 760831L, 828772L, 880543L, 905380L, 919639L) +) +} +} +\seealso{ +interp +} diff --git a/man/interp_coh_bare.Rd b/man/interp_coh_bare.Rd deleted file mode 100644 index 78519dd4b..000000000 --- a/man/interp_coh_bare.Rd +++ /dev/null @@ -1,29 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interp_coh.R -\name{interp_coh_bare} -\alias{interp_coh_bare} -\title{component-free intercensalcohort interpolation} -\usage{ -interp_coh_bare(c1, c2, date1, date2, age1, age2, ...) -} -\arguments{ -\item{c1}{numeric vector. The first (left) census in single age groups} - -\item{c2}{numeric vector. The second (right) census in single age groups} - -\item{date1}{reference date of c1`. Either a Date class object or an unambiguous character string in the format "YYYY-MM-DD".} - -\item{date2}{reference date of c2`. Either a Date class object or an unambiguous character string in the format "YYYY-MM-DD".} - -\item{age1}{integer vector. single ages of \code{c1}} - -\item{age2}{integer vector. single ages of \code{c2}} - -\item{...}{extra arguments passed to \code{interp()}. Not currently in use.} -} -\description{ -Cohorts between two censuses are interpolated flexibly using linear, exponential, or power rules. The lower and upper intercensal triangles are filled using within-age interpolation. This function is experimental and still in development. -} -\seealso{ -interp -} diff --git a/man/interp_lc_lim.Rd b/man/interp_lc_lim.Rd new file mode 100644 index 000000000..682133e8e --- /dev/null +++ b/man/interp_lc_lim.Rd @@ -0,0 +1,148 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/interp_lc_lim.R +\name{interp_lc_lim} +\alias{interp_lc_lim} +\title{Lee-Carter method with limited data.} +\usage{ +interp_lc_lim( + input = NULL, + dates_out = dates_in, + Single = FALSE, + dates_e0 = NULL, + e0_Males = NULL, + e0_Females = NULL, + prev_divergence = FALSE, + OAG = TRUE, + verbose = TRUE, + SVD = FALSE, + ... +) +} +\arguments{ +\item{input}{data.frame with cols: Date, Sex, Age, nMx (opt), nqx (opt), lx (opt)} + +\item{dates_out}{numeric. Vector of decimal years to interpolate or extrapolate.} + +\item{Single}{logical. Wheter or not the lifetable output is by single ages.} + +\item{dates_e0}{numeric. Vector of decimal years where \code{"e_0"} should be fitted when apply method.} + +\item{e0_Males}{numeric. Vector of life expectancy by year to be fitted. Same length than \code{"dates_e0"}.} + +\item{e0_Females}{numeric. Vector of life expectancy by year to be fitted. Same length than \code{"dates_e0"}.} + +\item{prev_divergence}{logical. Whether or not prevent divergence and sex crossover. Default \code{FALSE.}} + +\item{OAG}{logical. Whether or not the last element of \code{nMx} (or \code{nqx} or \code{lx}) is an open age group. Default \code{TRUE.}} + +\item{verbose}{logical. Default \code{FALSE}.} + +\item{SVD}{logical. Use Singular Value Decomposition for estimate b and k or Maximum Likelihood Estimation. Default \code{FALSE} for Maximum Likelihood Estimation.} + +\item{...}{Other arguments to be passed on to the \code{\link[DemoTools]{lt_abridged}} function.} +} +\value{ +List with: +\itemize{ +\item Interpolated/extrapolated lifetables in a data.frame with columns: +\itemize{ +\item \code{Date} numeric. Dates included in dates_out, +\item \code{Sex} character. Male \code{"m"} or female \code{"f"}, +\item \code{Age} integer. Lower bound of abridged age class, +\item `AgeInt`` integer. Age class widths. +\item \code{nMx} numeric. Age-specific central death rates. +\item \code{nAx} numeric. Average time spent in interval by those deceased in interval. +\item \code{nqx} numeric. Age-specific conditional death probabilities. +\item \code{lx} numeric. Lifetable survivorship +\item \code{ndx} numeric. Lifetable deaths distribution. +\item \code{nLx} numeric. Lifetable exposure. +\item \code{Sx} numeric. Survivor ratios in uniform 5-year age groups. +\item \code{Tx} numeric. Lifetable total years left to live above age x. +\item \code{ex} numeric. Age-specific remaining life expectancy. +\item List with estimated Lee-Carter parameters for each sex: +\item \code{kt} numeric time vector. Time trend in mortality level. +\item \code{ax} numeric age vector. Average time of \verb{log(m_\{x,t\})}. +\item \code{bx} numeric age vector. Pattern of change in response to \code{kt}. +} +} +} +\description{ +Given a data frame with dates, sex and mortality data by age (rates, conditionated probabilities of death +or survival function), this function interpolate/extrapolate life tables +using the method for limited data suggested by Li et. al (2004) (at least three observed years). +} +\details{ +Based on spreedsheet "Li_2018_Limited_Lee-Carter-v4.xlsm" from UN. +Useful for abridged or single ages, and allows output in both formats also. +One option is the use of non-divergent method for sex coherency (Li & Lee, 2005). +The other is the possibility of fitting \code{"k"} to replicate \code{"e_0"} at some given dates. +} +\note{ +Draft Version +} +\examples{ +# mortality rates from Sweden, for specific dates + +# needs mortality rates in this dates: +dates_out <- as.Date(paste0(seq(1948,2018,5),"-07-01")) + +# apply LC with limited data to extrap/interpolate +lc_lim_data <- interp_lc_lim(input = mA_swe, dates_out = dates_out, OAG = FALSE)$lt_hat + +\dontrun{ +lc_lim_data \%>\% ggplot(aes(Age,nMx,col=factor(round(Date,1)))) + + geom_step() + scale_color_viridis_d() + + scale_y_log10() + theme_classic() + facet_wrap(~Sex) +} + +# with simple ages as output +lc_lim_data_single <- interp_lc_lim(input = mA_swe, dates_out = dates_out, OAG = FALSE, + Single = TRUE)$lt_hat + +\dontrun{ +lc_lim_data_single \%>\% ggplot(aes(Age,nMx,col=factor(round(Date,1)))) + + geom_step() + scale_color_viridis_d() + + scale_y_log10() + theme_classic() + facet_wrap(~Sex) +} + +# Avoiding cross-over between sex. +lc_lim_nondiv <- interp_lc_lim(input = mA_swe, dates_out = dates_out, OAG = FALSE, + prev_divergence = TRUE)$lt_hat +\dontrun{ +lc_lim_nondiv \%>\% ggplot(aes(Age,nMx,col=factor(round(Date,1)))) + + geom_step() + scale_color_viridis_d() + + scale_y_log10() + theme_classic() + facet_wrap(~Sex) +} + +# Fitting information about e0 in Sweden for past years. +lc_lim_fite0 <- interp_lc_lim(input = mA_swe, dates_out = dates_out, OAG = FALSE, + dates_e0 = unique(e0_swe$Date), + e0_Males = e0_swe$e0[e0_swe$Sex=="m"], + e0_Females = e0_swe$e0[e0_swe$Sex=="f"])$lt_hat +\dontrun{ +ggplot() + + geom_point(data = e0_swe, aes(Date,e0,col=factor(Sex)))+ + geom_line(data = lc_lim_fite0[lc_lim_fite0$Age==0,], aes(Date,ex,col=factor(Sex)))+ + labs(color = "Sex")+ + theme_classic() +} + +# smooth and/or extend open age group, in this case input is for 80+, and chosen law is Makeham. +lc_lim_extOAg <- interp_lc_lim(input = mA_swe[mA_swe$Age<=80,], dates_out = dates_out, + OAG = FALSE, + OAnew=100, + extrapLaw = "makeham")$lt_hat +\dontrun{ +ggplot() + + geom_step(data = lc_lim_extOAg, aes(Age,nMx,col=factor(round(Date,1)))) + + scale_y_log10() + scale_color_viridis_d() + theme_classic() + facet_wrap(~Sex) + } +#End +} +\references{ +\insertRef{Li2005}{DemoTools} +\insertRef{Li2004}{DemoTools} +} +\seealso{ +\code{\link[DemoTools]{lt_abridged}} +} diff --git a/man/interp_lc_lim_abk_m.Rd b/man/interp_lc_lim_abk_m.Rd new file mode 100644 index 000000000..9b94ff9f6 --- /dev/null +++ b/man/interp_lc_lim_abk_m.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/interp_lc_lim.R +\name{interp_lc_lim_abk_m} +\alias{interp_lc_lim_abk_m} +\title{wrapper fun for \code{"interp_lc_lim_estimate"} function} +\usage{ +interp_lc_lim_abk_m(k, ax, bx) +} +\arguments{ +\item{k}{numeric. k parameter from LC model.} + +\item{ax}{numeric. Vector (same length of age) of parameters from LC model.} + +\item{bx}{numeric. Vector (same length of age) of parameters from LC model.} +} +\description{ +wrapper fun to estimate rates from LC parameters +} diff --git a/man/interp_lc_lim_estimate.Rd b/man/interp_lc_lim_estimate.Rd new file mode 100644 index 000000000..d05a2ec12 --- /dev/null +++ b/man/interp_lc_lim_estimate.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/interp_lc_lim.R +\name{interp_lc_lim_estimate} +\alias{interp_lc_lim_estimate} +\title{Estimate LC with limited data params} +\usage{ +interp_lc_lim_estimate(M, dates_in, dates_out, SVD = F) +} +\arguments{ +\item{M}{numeric. Matrix with many rows as ages and columns as dates_in.} + +\item{dates_in}{numeric. Vector of dates with input rates.} + +\item{dates_out}{numeric. Vector of dates for estimate a set of rates.} + +\item{SVD}{logical. Use Singular Value Decomposition for estimate b and k or Maximum Likelihood Estimation. Default \code{FALSE} for Maximum Likelihood Estimation.} +} +\description{ +Estimate LC with limited data from a matrix of rates (age by dates). +} +\details{ +SVD for ax and bx. Fit a simmple linear model for k and interp/extrapolate for objective dates. +} +\references{ +\insertRef{Li2004}{DemoTools} +} diff --git a/man/interp_lc_lim_group.Rd b/man/interp_lc_lim_group.Rd new file mode 100644 index 000000000..26c72120a --- /dev/null +++ b/man/interp_lc_lim_group.Rd @@ -0,0 +1,116 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/interp_lc_lim_group.R +\name{interp_lc_lim_group} +\alias{interp_lc_lim_group} +\title{Lee-Carter method with limited data for groups.} +\usage{ +interp_lc_lim_group( + input = NULL, + dates_out = NULL, + Single = FALSE, + input_e0 = NULL, + prev_divergence = FALSE, + weights = NULL, + OAG = TRUE, + verbose = TRUE, + SVD = FALSE, + ... +) +} +\arguments{ +\item{input}{data.frame. Columns: id, Date, Sex, Age, nMx (opt), nqx (opt), lx (opt). +The first column (id) cn be a numeric index or charcter vector identifying each group.} + +\item{dates_out}{numeric. Vector of decimal years to interpolate or extrapolate.} + +\item{Single}{logical. Wheter or not the lifetable output is by single ages.} + +\item{input_e0}{data.frame with cols: id, Date, Sex and \code{"e_0"}. This should be fitted when apply method.} + +\item{prev_divergence}{logical. Whether or not prevent divergence and sex crossover between groups. Default \code{FALSE.}} + +\item{weights}{list. For \code{prev_divergence} option. A double for each element of a list with names as \code{id} columns. Should sum up to 1. Default: same weight for each group.} + +\item{OAG}{logical. Whether or not the last element of \code{nMx} (or \code{nqx} or \code{lx}) is an open age group. Default \code{TRUE.}} + +\item{verbose}{logical. Default \code{FALSE}.} + +\item{SVD}{logical. Use Singular Value Decomposition for estimate b and k or Maximum Likelihood Estimation. Default \code{FALSE} for Maximum Likelihood Estimation.} + +\item{...}{Other arguments to be passed on to the \code{\link[DemoTools]{lt_abridged}} function.} +} +\value{ +List with: +\itemize{ +\item Lifetable in a data.frame with columns: +\itemize{ +\item \code{Date} numeric. Dates included in dates_out, +\item \code{Sex} character. Male \code{"m"} or female \code{"f"}, +\item \code{Age} integer. Lower bound of abridged age class, +\item `AgeInt`` integer. Age class widths. +\item \code{nMx} numeric. Age-specific central death rates. +\item \code{nAx} numeric. Average time spent in interval by those deceased in interval. +\item \code{nqx} numeric. Age-specific conditional death probabilities. +\item \code{lx} numeric. Lifetable survivorship +\item \code{ndx} numeric. Lifetable deaths distribution. +\item \code{nLx} numeric. Lifetable exposure. +\item \code{Sx} numeric. Survivor ratios in uniform 5-year age groups. +\item \code{Tx} numeric. Lifetable total years left to live above age x. +\item \code{ex} numeric. Age-specific remaining life expectancy. +\item List with parameters estimated for each group: +\item \code{kt} numeric time vector. Time trend in mortality level. +\item \code{ax} numeric age vector. Average time of \verb{log(m_\{x,t\})}. +\item \code{bx} numeric age vector. Pattern of change in response to \code{kt}. +} +} +} +\description{ +Given a data frame with groups (country, region, sex), dates, sex and mortality data by age (rates, conditionated probabilities of death +or survival function), this function interpolate/extrapolate life tables +using the method for limited data suggested by Li et. al (2004) (at least three observed years). +} +\details{ +Based on spreedsheet "Li_2018_Limited_Lee-Carter-v4.xlsm" from UN. +Useful for abridged or single ages, and allows output in both formats also. +One option is the use of non-divergent method for sex coherency (Li & Lee, 2005). +The other is the possibility of fitting \code{"k"} to replicate \code{"e_0"} at some given dates. +\code{id} column in \code{input} argument works for separate between groups. In case only one population/sex is given, +is recommended to give some group name to \code{id}, if not the function will try to infer the case. +} +\note{ +Draft Version +} +\examples{ +# mortality rates from Sweden, for specific dates. Each sex a group. +mA_swe$id = c(rep("A",nrow(mA_swe)/2), + rep("B",nrow(mA_swe)/2)) + +# needs mortality rates in this dates: +dates_out <- as.Date(paste0(seq(1948,2018,5),"-07-01")) + +# apply LC with limited data to extrap/interpolate +lc_lim_data <- interp_lc_lim_group(input = mA_swe, dates_out = dates_out) + +\dontrun{ +lc_lim_data[["lt_hat"]] \%>\% ggplot(aes(Age,nMx,col=factor(round(Date,1)))) + + geom_step() + scale_color_viridis_d() + + scale_y_log10() + theme_classic() + facet_wrap(~Sex) +} + +# avoid cross-over between groups +lc_lim_data <- interp_lc_lim_group(input = mA_swe, dates_out = dates_out, + prev_divergence = TRUE, weights=list(A=.4,B=.6)) + +\dontrun{ +lc_lim_data[["lt_hat"]] \%>\% ggplot(aes(Age,nMx,col=factor(round(Date,1)))) + + geom_step() + scale_color_viridis_d() + + scale_y_log10() + theme_classic() + facet_wrap(~id) +} +} +\references{ +\insertRef{Li2005}{DemoTools} +\insertRef{Li2004}{DemoTools} +} +\seealso{ +\code{\link[DemoTools]{lt_abridged}} +} diff --git a/man/interp_lc_lim_kt_min.Rd b/man/interp_lc_lim_kt_min.Rd new file mode 100644 index 000000000..02d6db3be --- /dev/null +++ b/man/interp_lc_lim_kt_min.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/interp_lc_lim.R +\name{interp_lc_lim_kt_min} +\alias{interp_lc_lim_kt_min} +\title{Optimize k} +\usage{ +interp_lc_lim_kt_min(k, ax, bx, age, sex, e0_target, ...) +} +\arguments{ +\item{k}{numeric. k parameter from LC model.} + +\item{ax}{numeric. Vector (same length of age) of parameters from LC model.} + +\item{bx}{numeric. Vector (same length of age) of parameters from LC model.} + +\item{age}{numeric.} + +\item{sex}{numeric.} + +\item{e0_target}{numeric.} + +\item{...}{Other arguments to be passed on to the \code{\link[DemoTools]{lt_abridged}} function.} +} +\description{ +Optimize estimated k from LC with limited data model, +for fitting given e_0 at same dates +} +\details{ +Given LC parameters at some date, change a bit k for replicate already know e_0 values. +This is useful to give some sort of flexibility, and not follow strictly linear model implied in LC model, +but taking advantage of estimated structure (ax) and change by age (bx) for some trustable period. +} diff --git a/man/lt_abridged.Rd b/man/lt_abridged.Rd index f5af0d624..99801cc57 100644 --- a/man/lt_abridged.Rd +++ b/man/lt_abridged.Rd @@ -22,9 +22,9 @@ lt_abridged( SRB = 1.05, OAG = TRUE, OAnew = max(Age), - extrapLaw = "kannisto", + extrapLaw = NULL, extrapFrom = max(Age), - extrapFit = Age[Age >= 60 & ifelse(OAG, Age < max(Age), TRUE)], + extrapFit = NULL, ... ) } @@ -64,7 +64,7 @@ lt_abridged( \item{OAnew}{integer. Desired open age group (5-year ages only). Default \code{max(Age)}. If higher then rates are extrapolated.} \item{extrapLaw}{character. If extrapolating, which parametric mortality law should be invoked? Options include -\code{"Kannisto", "Kannisto_Makeham", "Makeham", "Gompertz", "GGompertz", "Beard", "Beard_Makeham", "Quadratic"}. Default \code{"Kannisto"}. See details.} +\code{"Kannisto", "Kannisto_Makeham", "Makeham", "Gompertz", "GGompertz", "Beard", "Beard_Makeham", "Quadratic"}. Default \code{"Kannisto"} if the highest age is at least 90, otherwise \code{"makeham"}. See details.} \item{extrapFrom}{integer. Age from which to impute extrapolated mortality.} diff --git a/man/lt_abridged2single.Rd b/man/lt_abridged2single.Rd new file mode 100644 index 000000000..d9cbfb378 --- /dev/null +++ b/man/lt_abridged2single.Rd @@ -0,0 +1,120 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/lt_regroup_age.R +\name{lt_abridged2single} +\alias{lt_abridged2single} +\title{create a life table by single year of age by graduating an abridged life table} +\usage{ +lt_abridged2single( + Deaths = NULL, + Exposures = NULL, + nMx = NULL, + nqx = NULL, + lx = NULL, + Age, + radix = 1e+05, + axmethod = "un", + a0rule = "ak", + Sex = "m", + region = "w", + IMR = NA, + mod = TRUE, + SRB = 1.05, + OAG = TRUE, + OAnew = max(Age), + extrapLaw = NULL, + extrapFrom = max(Age), + extrapFit = NULL, + ... +) +} +\arguments{ +\item{Deaths}{numeric. Vector of death counts in abridged age classes.} + +\item{Exposures}{numeric. Vector of population exposures in abridged age classes.} + +\item{nMx}{numeric. Vector of mortality rates in abridged age classes.} + +\item{nqx}{numeric. Vector of conditional death probabilities in abridged age classes.} + +\item{lx}{numeric. Vector of lifetable survivorship at abridged ages.} + +\item{Age}{integer. A vector of ages of the lower integer bound of the age classes.} + +\item{radix}{numeric. Lifetable radix, \ifelse{html}{\out{l0}}{\eqn{l_0}}. Default 100000.} + +\item{axmethod}{character. Either \code{"pas"} or \code{"un"}.} + +\item{a0rule}{character. Either \code{"ak"} (default) or \code{"cd"}.} + +\item{Sex}{character. Either male \code{"m"}, female \code{"f"}, or both \code{"b"}.} + +\item{region}{character. North, East, South, or West: code{"n"}, code{"e"}, code{"s"}, code{"w"}. Default code{"w"}.} + +\item{IMR}{numeric. Infant mortality rate \ifelse{html}{\out{q0}}{\eqn{q_0}}, in case available and \code{nqx} is not specified. Default \code{NA}.} + +\item{mod}{logical. If \code{"un"} specified for \code{axmethod}, whether or not to use Nan Li's modification for ages 5-14. Default \code{TRUE}.} + +\item{SRB}{the sex ratio at birth (boys / girls), detault 1.05} + +\item{OAG}{logical. Whether or not the last element of \code{nMx} (or \code{nqx} or \code{lx}) is an open age group. Default \code{TRUE}.} + +\item{OAnew}{integer. Desired open age group (5-year ages only). Default \code{max(Age)}. If higher then rates are extrapolated.} + +\item{extrapLaw}{character. If extrapolating, which parametric mortality law should be invoked? Options include +\code{"Kannisto", "Kannisto_Makeham", "Makeham", "Gompertz", "GGompertz", "Beard", "Beard_Makeham", "Quadratic"}. Default \code{"Kannisto"} if the highest age is at least 90, otherwise \code{"makeham"}. See details.} + +\item{extrapFrom}{integer. Age from which to impute extrapolated mortality.} + +\item{extrapFit}{integer vector. Ages to include in model fitting. Defaults to all ages \code{> =60}.} + +\item{...}{optional arguments passed to \code{pclm()}. For example, if you pass an expicit \code{lambda} parameter via the \code{control} argument, you can speed up estimation} +} +\value{ +Single-year lifetable in data.frame with columns +\itemize{ +\item{Age}{integer. Lower bound of single year age class}, +\item{AgeInt}{integer. Age class widths.} +\item{nMx}{numeric. Age-specific central death rates.} +\item{nAx}{numeric. Average time spent in interval by those deceased in interval. } +\item{nqx}{numeric. Age-specific conditional death probabilities.} +\item{lx}{numeric. Lifetable survivorship} +\item{ndx}{numeric. Lifetable deaths distribution.} +\item{nLx}{numeric. Lifetable exposure.} +\item{Sx}{numeric. Survivor ratios.} +\item{Tx}{numeric. Lifetable total years left to live above age x.} +\item{ex}{numeric. Age-specific remaining life expectancy.} +} +} +\description{ +Computes single year of age life table by graduating the mortality schedule of an abridged life table, using the \code{ungroup::pclm()} to ungroup binned count data. Returns complete single-age lifetable. +} +\details{ +Similar to \code{lt_abridged()} details, forthcoming. +} +\examples{ + Mx <- c(.23669,.04672,.00982,.00511,.00697,.01036,.01169, + .01332,.01528,.01757,.02092,.02517,.03225,.04241,.06056, + .08574,.11840,.16226,.23745) + Age = c(0,1,seq(5,85,by=5)) + AgeInt <- inferAgeIntAbr(vec = Mx) + LTabr <- lt_abridged(nMx = Mx, + Age = Age, + axmethod = "un", + Sex = "m", + mod = TRUE) + + LT1 <- lt_abridged2single(nMx = Mx, + Age = Age, + axmethod = "un", + Sex = "m", + mod = TRUE) +LTabr$ex[1] +LT1$ex[1] +\dontrun{ +plot(Age, LTabr$nMx,type = 's', log = 'y') +lines(LT1$Age, LT1$nMx) + +plot(Age, LTabr$lx,type='S') +lines(LT1$Age, LT1$lx) +} +} diff --git a/man/lt_ambiguous.Rd b/man/lt_ambiguous.Rd new file mode 100644 index 000000000..532075238 --- /dev/null +++ b/man/lt_ambiguous.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/lt_regroup_age.R +\name{lt_ambiguous} +\alias{lt_ambiguous} +\title{calculate an abidged or single age lifetable from abridged or sinlge age data} +\usage{ +lt_ambiguous( + nMx_or_nqx_or_lx = NULL, + type = "m", + Age = NULL, + Sex = NULL, + Single = FALSE, + ... +) +} +\arguments{ +\item{nMx_or_nqx_or_lx}{numeric vector of either \code{nMx}, \code{nqx}, or \code{lx}} + +\item{type}{character, which variable is \code{x}?, either \code{"m"}, \code{"q"}, or \code{"l"}. Default \code{"m"}} + +\item{Age}{integer vector of the lower age bounds of \code{x}} + +\item{Sex}{character, \code{"m"}, \code{"f"}, or \code{"b"}.} + +\item{Single}{logical, do we want output in single ages?} + +\item{...}{optional arguments passed to \code{lt_abridged()} or \verb{lt_single*()}} +} +\description{ +This is a wrapper around the other lifetable utilities. We start with either \code{nMx}, \code{nqx}, or \code{lx} in single or abridged ages, and returns a full lifetable in either single or abridged ages. All optional arguments of \code{lt_abridged()} or \verb{lt_single*()} can be passed in, for instance the \code{nax} assumptions or the extrapolation arguments. +} diff --git a/man/lt_id_Ll_S.Rd b/man/lt_id_Ll_S.Rd index 6baabc54e..bfeb141f0 100644 --- a/man/lt_id_Ll_S.Rd +++ b/man/lt_id_Ll_S.Rd @@ -4,13 +4,15 @@ \alias{lt_id_Ll_S} \title{Calculate survivor ratios} \usage{ -lt_id_Ll_S(nLx, lx, AgeInt, N = c(5, 1)) +lt_id_Ll_S(nLx, lx, Age, AgeInt, N = c(5, 1)) } \arguments{ \item{nLx}{numeric vector of lifetable exposure.} \item{lx}{numeric. Vector of lifetable survivorship at abridged ages.} +\item{Age}{integer. A vector of ages of the lower integer bound of the age classes.} + \item{AgeInt}{integer. Vector of age class widths. Default \code{inferAgeIntAbr(Age = Age)}.} \item{N}{integer, the age width for survivor ratios, either 5 or 1. Default 5.} diff --git a/man/lt_id_d_l.Rd b/man/lt_id_d_l.Rd new file mode 100644 index 000000000..7f4f78cab --- /dev/null +++ b/man/lt_id_d_l.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/lt_id.R +\name{lt_id_d_l} +\alias{lt_id_d_l} +\title{Derive survivorship from lifetable deaths} +\usage{ +lt_id_d_l(ndx, radix = sum(ndx)) +} +\arguments{ +\item{ndx}{numeric. Vector of age-specific lifetable deaths.} + +\item{radix}{numeric.} +} +\value{ +lx vector of lifetable survivorship +} +\description{ +This lifetable identity is the same no matter what kind of lifetable is required. You can find it in any demography textbook. +} +\details{ +The vector returned is the same length as \code{dx} and it sums to the lifetable radix. If the radix is one then this is the discrete deaths distribution. +} +\references{ +\insertRef{preston2000demography}{DemoTools} +} diff --git a/man/lt_id_d_q.Rd b/man/lt_id_d_q.Rd new file mode 100644 index 000000000..8cc951082 --- /dev/null +++ b/man/lt_id_d_q.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/lt_id.R +\name{lt_id_d_q} +\alias{lt_id_d_q} +\title{Derive death probabilities from lifetable deaths} +\usage{ +lt_id_d_q(ndx) +} +\arguments{ +\item{ndx}{numeric. Vector of age-specific lifetable survivorship.} +} +\value{ +nqx vector of lifetable death probabilities. +} +\description{ +This lifetable identity is the same no matter what kind of lifetable is required. You can find it in any demography textbook. +} +\details{ +The vector returned is the same length as \code{dx}. +} +\references{ +\insertRef{preston2000demography}{DemoTools} +} diff --git a/man/lt_id_l_q.Rd b/man/lt_id_l_q.Rd new file mode 100644 index 000000000..93d6f8e3c --- /dev/null +++ b/man/lt_id_l_q.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/lt_id.R +\name{lt_id_l_q} +\alias{lt_id_l_q} +\title{Derive lifetable death probabilities from survivorship.} +\usage{ +lt_id_l_q(lx) +} +\arguments{ +\item{lx}{numeric. Vector of age-specific lifetable survivorship.} +} +\value{ +ndx vector of lifetable deaths. +} +\description{ +This lifetable identity is the same no matter what kind of lifetable is required. +You can find it in any demography textbook. +} +\details{ +The vector returned is the same length as \code{lx} and it sums to the lifetable radix. +If the radix is one then this is the discrete deaths distribution. +} +\references{ +\insertRef{preston2000demography}{DemoTools} +} diff --git a/man/lt_model_lq.Rd b/man/lt_model_lq.Rd index 7dddc8a0a..23919935d 100644 --- a/man/lt_model_lq.Rd +++ b/man/lt_model_lq.Rd @@ -95,7 +95,6 @@ This function is ported from \code{MortalityEstimate::wilmothLT} experimental pa \examples{ # Build life tables with various choices of 2 input parameters -\dontrun{ # case 1: Using 5q0 and e0 L1 <- lt_model_lq(Sex = "b", q0_5 = 0.05, e0 = 65) L1 @@ -124,5 +123,5 @@ L7 <- lt_model_lq(Sex = "b", q15_45 = 0.125, e0 = 65) # case 8: Using 35q15 and e0 L8 <- lt_model_lq(Sex = "b", q15_35 = 0.15, e0 = 65) -} + } diff --git a/man/lt_rule_1a0_ak.Rd b/man/lt_rule_1a0_ak.Rd index c036c0d5c..9f7539b4b 100644 --- a/man/lt_rule_1a0_ak.Rd +++ b/man/lt_rule_1a0_ak.Rd @@ -7,11 +7,11 @@ lt_rule_1a0_ak(M0 = NULL, q0 = NULL, Sex) } \arguments{ -\item{M0}{a value or vector of values of m0, the death probability in the first year of life.} +\item{M0}{a value or vector of values of `1m0``, the death risk in the first year of life.} -\item{q0}{a value or vector of values of m0, the death risk in the first year of life.} +\item{q0}{a value or vector of values of `1q0``, the death probability in the first year of life, sometimes approximated with IMR.} -\item{Sex}{either "m" or "f"} +\item{Sex}{either \code{"m"} or \code{"f"}} } \value{ a0, the estimated average age at death of those dying in the first year of life, either a single value or a vector of values. diff --git a/man/lt_rule_m_extrapolate.Rd b/man/lt_rule_m_extrapolate.Rd index d8483f2e9..129763202 100644 --- a/man/lt_rule_m_extrapolate.Rd +++ b/man/lt_rule_m_extrapolate.Rd @@ -9,9 +9,8 @@ lt_rule_m_extrapolate( x, x_fit = x, x_extr, - law = c("kannisto", "kannisto_makeham", "makeham", "gompertz", "ggompertz", "beard", - "beard_makeham", "quadratic"), - opt.method = c("LF2", "LF1", "LF3", "LF4", "LF5", "LF6", "poissonL", "binomialL"), + law = "kannisto", + opt.method = "LF2", ... ) } @@ -38,11 +37,7 @@ The following options are available: \itemize{ \item{\code{"quadratic"}} -- The Quadratic model. }} -\item{opt.method}{How would you like to find the parameters? Specify the -function to be optimize. Available options: the Poisson likelihood function -\code{poissonL}; the Binomial likelihood function -\code{binomialL}; and -6 other loss functions. For more details, check the \code{\link[MortalityLaws]{availableLF}} -function.} +\item{opt.method}{character. Default \code{"LF2"}, see \code{MortalityLaws::MortalityLaw} for a description of choices.} \item{...}{Other arguments to be passed on to the \code{\link[MortalityLaws]{MortalityLaw}} function.} diff --git a/man/lt_single2abridged.Rd b/man/lt_single2abridged.Rd index 5394e8c72..759404147 100644 --- a/man/lt_single2abridged.Rd +++ b/man/lt_single2abridged.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/lt_single2abridged.R +% Please edit documentation in R/lt_regroup_age.R \name{lt_single2abridged} \alias{lt_single2abridged} \title{calculate an abridged life table that is consistent with a life table by single year of age} \usage{ -lt_single2abridged(lx, nLx, ex, Age = 1:length(lx) - 1) +lt_single2abridged(lx, nLx, ex, Age = 1:length(lx) - 1, ...) } \arguments{ \item{lx}{numeric. Vector of lifetable survivorship at single ages.} @@ -14,6 +14,8 @@ lt_single2abridged(lx, nLx, ex, Age = 1:length(lx) - 1) \item{ex}{numeric. Vector of Age-specific remaining life expectancy at single ages.} \item{Age}{integer. Lower bounds of single ages.} + +\item{...}{optional args, not currently used.} } \value{ Abridged lifetable in data.frame with columns diff --git a/man/lt_single_mx.Rd b/man/lt_single_mx.Rd index 6588f4ca8..4f7ea4b7c 100644 --- a/man/lt_single_mx.Rd +++ b/man/lt_single_mx.Rd @@ -16,9 +16,9 @@ lt_single_mx( SRB = 1.05, OAG = TRUE, OAnew = max(Age), - extrapLaw = "kannisto", + extrapLaw = NULL, extrapFrom = max(Age), - extrapFit = Age[Age >= 60], + extrapFit = NULL, ... ) } @@ -46,7 +46,7 @@ lt_single_mx( \item{OAnew}{integer. Desired open age group (5-year ages only). Default \code{max(Age)}. If higher then rates are extrapolated.} \item{extrapLaw}{character. If extrapolating, which parametric mortality law should be invoked? Options include -\code{"Kannisto", "Kannisto_Makeham", "Makeham", "Gompertz", "GGompertz", "Beard", "Beard_Makeham", "Quadratic"}. Default \code{"Kannisto"}. See details.} +\code{"Kannisto", "Kannisto_Makeham", "Makeham", "Gompertz", "GGompertz", "Beard", "Beard_Makeham", "Quadratic"}. Default \code{"Kannisto"} if the highest age is at least 90, otherwise \code{"makeham"}. See details.} \item{extrapFrom}{integer. Age from which to impute extrapolated mortality.} diff --git a/man/lt_single_qx.Rd b/man/lt_single_qx.Rd index d9a133f8e..54d90efe5 100644 --- a/man/lt_single_qx.Rd +++ b/man/lt_single_qx.Rd @@ -16,9 +16,9 @@ lt_single_qx( SRB = 1.05, OAG = TRUE, OAnew = max(Age), - extrapLaw = "kannisto", + extrapLaw = NULL, extrapFrom = max(Age), - extrapFit = Age[Age >= 60], + extrapFit = NULL, ... ) } @@ -46,7 +46,7 @@ lt_single_qx( \item{OAnew}{integer. Desired open age group (5-year ages only). Default \code{max(Age)}. If higher then rates are extrapolated.} \item{extrapLaw}{character. If extrapolating, which parametric mortality law should be invoked? Options include -\code{"Kannisto", "Kannisto_Makeham", "Makeham", "Gompertz", "GGompertz", "Beard", "Beard_Makeham", "Quadratic"}. Default \code{"Kannisto"}. See details.} +\code{"Kannisto", "Kannisto_Makeham", "Makeham", "Gompertz", "GGompertz", "Beard", "Beard_Makeham", "Quadratic"}. Default \code{"Kannisto"} if the highest age is at least 90, otherwise \code{"makeham"}. See details.} \item{extrapFrom}{integer. Age from which to impute extrapolated mortality.} diff --git a/man/lt_smooth_ambiguous.Rd b/man/lt_smooth_ambiguous.Rd new file mode 100644 index 000000000..beff389bc --- /dev/null +++ b/man/lt_smooth_ambiguous.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/interp_lc_lim.R +\name{lt_smooth_ambiguous} +\alias{lt_smooth_ambiguous} +\title{Smooth and apply lt_ambiguous} +\usage{ +lt_smooth_ambiguous(input, ...) +} +\arguments{ +\item{input}{data.frame. with cols: Date, Sex, Age, nMx (opt), nqx (opt), lx (opt)} + +\item{...}{Other arguments to be passed on to the \code{\link[DemoTools]{lt_abridged}} function.} +} +\description{ +Considering different mortality input for each sex/year data, +smooth olders with makeham or kannisto in case no law was specified, +and return a data.frame with standard LT. +} +\details{ +Makeham is chosen if last age is less than 90. Else Kannisto. +} diff --git a/man/mA_swe.Rd b/man/mA_swe.Rd new file mode 100644 index 000000000..56b227515 --- /dev/null +++ b/man/mA_swe.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{mA_swe} +\alias{mA_swe} +\title{Swedish abridged mortality rates} +\format{ +A data frame with: +\describe{ +\item{Date}{Reference time for the rates estimate.} +\item{Age}{Inferior age for abridged groups. Carefull: last age 100 is not an OAG} +\item{Sex}{Male \code{m} and female \code{m}.} +\item{nMx}{Mortality rates.} +} +} +\source{ +Human Mortality Database. Retrieved 2021-20-01, from \url{https://mortality.org} +} +\usage{ +mA_swe +} +\description{ +Mortality rates in tidy format for each sex in dates 1990-07-01, 2000-07-01, 2010-07-01 +} +\keyword{datasets} diff --git a/man/mav.Rd b/man/mav.Rd index 10f785be1..78106f0c0 100644 --- a/man/mav.Rd +++ b/man/mav.Rd @@ -4,7 +4,7 @@ \alias{mav} \title{Calculate the moving average (mav) over 3 or 5 years.} \usage{ -mav(Value, Age, n = 3, OAG = TRUE) +mav(Value, Age, n = 3, OAG = TRUE, tails = FALSE) } \arguments{ \item{Value}{numeric. A vector of demographic counts in single age groups.} @@ -14,6 +14,10 @@ mav(Value, Age, n = 3, OAG = TRUE) \item{n}{integer. A single number, (often 3 or 5), indicating the number of years taken to smooth the population distribution by single ages.} \item{OAG}{logical. Whether or not the top age group is open. Default \code{TRUE}.} + +\item{tails}{logical. If set to \code{TRUE}, smaller-n moving averages are applied on both tails +such that all values are non-NA. If \code{FALSE} (default), tails are set to NA +due to the lag of moving averages.} } \value{ Vector with the smoothed demographic counts. @@ -22,9 +26,9 @@ Vector with the smoothed demographic counts. This arithmetic smoothing technique aims to eliminate irregularities of the population pyramid by averaging values in a moving window of user-defined width. } \details{ -The moving window is applied symmetrically. Data endpoints are imputed with \code{NA}s in output: the is nothing under 0 or over the highest closed age group to average with. The open age group is imputed with \code{NA} prior to calculations, since it cannot be averaged into the next lowest group. For example, for \code{n=3}, age 0 will be \code{NA}, as will the open age group and next lowest age. Age intervals are assumed uniform. This function could be used with either single or 5-year age groups. +The moving window is applied symmetrically. By default (\code{tails = FALSE}) data endpoints are imputed with \code{NA}s in output: the is nothing under 0 or over the highest closed age group to average with. The open age group is not used in averaging, and it is returned as-is. Age intervals are assumed uniform. This function could be used with either single or 5-year age groups. -Ages may be single or grouped, but all age intervals are assumed equal. +If \code{tails} is set to \code{TRUE}, then tails have been imputed using moving averages with successively smaller values of \code{n}, the cascade method. } \examples{ Pop <-c(303583,390782,523903,458546,517996,400630,485606,325423,471481,189710, @@ -37,8 +41,15 @@ Pop <-c(303583,390782,523903,458546,517996,400630,485606,325423,471481,189710, Age <- 0:70 # final age group assumed open mav(Pop, n = 3, Age = Age) + \dontrun{ -nwindows <- sapply(seq(3, 11, by = 2),mav, Value = Pop, Age = Age) + odds <- seq(3, 11, by = 2) +nwindows <- sapply(odds, + mav, + Value = Pop, + Age = Age, + OAG = TRUE, + tails = FALSE) cols <- gray(seq(.8, 0, length = 5)) lwds <- seq(3, 1, length = 5) plot(Age,Pop, col = "red", xlab = "Age", ylab = "The counts", pch=16, @@ -50,10 +61,31 @@ legend("topright", lwd = lwds, legend = paste0("n=",seq(3,11,by=2))) } + +# For cascading smoothing on the tails: +mav(Pop, Age, tails = TRUE) + +\dontrun{ +# Compare +nwindows_tails <- sapply(odds, + mav, + Value = Pop, + Age = Age, + OAG = TRUE, + tails = TRUE) + +colnames(nwindows) <- odds +colnamaes(nwindows_tails) <- odds + +# NA triangles are completed with +# successively smaller ns. +head(nwindows) +head(nwindows_tails) + +tail(nwindows) +tail(nwindows_tails) +} } \references{ \insertRef{GDA1981IREDA}{DemoTools} } -\author{ -Juan Galeano -} diff --git a/man/mig_beta.Rd b/man/mig_beta.Rd new file mode 100644 index 000000000..e7b8e7d91 --- /dev/null +++ b/man/mig_beta.Rd @@ -0,0 +1,122 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mig_beta.R +\name{mig_beta} +\alias{mig_beta} +\title{Estimate intercensal migration by comparing census population, by age and +sex, to the results of a RUP projection.} +\usage{ +mig_beta( + c1, + c2, + date1, + date2, + age1 = 1:length(c1) - 1, + age2 = 1:length(c2) - 1, + dates_out = NULL, + lxMat = NULL, + age_lx = NULL, + dates_lx = NULL, + births = NULL, + years_births = NULL, + location = NULL, + sex = "both", + midyear = FALSE, + verbose = TRUE, + child_adjust = c("none", "cwr", "constant"), + childage_max = NULL, + cwr_factor = 0.3, + oldage_adjust = c("none", "beers", "mav"), + oldage_min = 65, + ... +) +} +\arguments{ +\item{c1}{numeric vector. The first (left) census in single age groups} + +\item{c2}{numeric vector. The second (right) census in single age groups} + +\item{date1}{reference date of c1`. Either a Date class object or an unambiguous character string in the format "YYYY-MM-DD".} + +\item{date2}{reference date of c2`. Either a Date class object or an unambiguous character string in the format "YYYY-MM-DD".} + +\item{age1}{integer vector. single ages of \code{c1}} + +\item{age2}{integer vector. single ages of \code{c2}} + +\item{dates_out}{vector of desired output dates coercible to numeric using \code{dec.date()}} + +\item{lxMat}{numeric matrix containing lifetable survivorship, \code{l(x)}. Each row is an age group and each column a time point. At least two intercensal time points needed.} + +\item{age_lx}{integer vector. Age classes in \code{lxMat}} + +\item{dates_lx}{date, character, or numeric vector of the column time points for \code{lxMat}. If these are calendar-year estimates, then you can choose mid-year time points} + +\item{births}{integer vector. Raw birth counts for the corresponding (sub)-population, one value per each year of the intercensal period including both census years. The first and last years should include all births in the given year; don't discount them in advance.} + +\item{years_births}{numeric vector of calendar years of births.} + +\item{location}{country name or LocID} + +\item{sex}{character string, either \code{"male"}, \code{"female"}, or \code{"both"}} + +\item{midyear}{logical. \code{FALSE} means all Jan 1 dates between \code{date1} and \code{date2} are returned. \code{TRUE} means all July 1 intercensal dates are returned.} + +\item{verbose}{logical. Shall we send informative messages to the console?} + +\item{child_adjust}{The method with which to adjust the youngest age groups. +If \code{"none"}, no adjustment is applied (default). If +child-woman ratio (\code{"cwr"}) is chosen, the first cohorts reflecting the +difference between \code{date2 - date1} are adjusted (plus age 0). If +child constant ratio (\code{"constant"}) is chosen, the first 15 age groups +are adjusted.} + +\item{childage_max}{The maximum age from which to apply \code{child_adjust}. +By default, set to \code{NULL}, which gets translated into all the cohorts +between \code{date2} and \code{date1}. If \code{date2} is 2010 and +\code{date1} is 2002, the first 8 cohorts are adjusted. Otherwise, the user +can supply an integer.} + +\item{cwr_factor}{A numeric between 0 and 1 to which adjust the CWR method +for the young ages from \code{child_adjust}. \strong{This is only used +when \code{child_adjust} is \code{"cwr"}}.} + +\item{oldage_adjust}{The type of adjustment to apply to ages at and above +\code{oldage_min}. \code{'beers'} applies a beers graduation method +while \code{'mav'} applies a moving average with cascading on the tails. +For more information see \code{?mav} and \code{?graduation_beers}.} + +\item{oldage_min}{The minimum age from which to apply \code{oldage_adjust}. +By default, set to 65, so any adjustment from \code{oldage_adjust} will be +applied for 65+.} + +\item{...}{optional arguments passed to \code{lt_single_qx}} +} +\value{ +a numeric vector of the total migration in the intercensal period +for each age. Ages are set as names of each migration estimate. +} +\description{ +This methods projects population from the first starting point to next census +without migration and computes the "Net Census Error" (NCE) which is +Census - Estimate by age from projection. It then distributes the NCE over +the cohort parallelogram assuming uniform distribution assuming it is all +migration. It finalizes by summing the estimate by age groups across the entire +intercensal period to have a total migration during the entire period. +Alternatively, a child adjustment and an old age adjustment can be applied. +} +\examples{ + +\dontrun{ + +mig_beta( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + births = c(719511L, 760934L, 772973L, 749554L, 760831L, 828772L, 880543L, 905380L, 919639L) +) +} +} diff --git a/man/mig_calculate_rc.Rd b/man/mig_calculate_rc.Rd index 7c7b45311..1c60f91da 100644 --- a/man/mig_calculate_rc.Rd +++ b/man/mig_calculate_rc.Rd @@ -30,12 +30,12 @@ Models with less parameters gradually remove terms at the older ages. Parameters For a specific family to be included, values for all parameters in that family must be specified. } \examples{ -pars <- c(a1= 0.09, alpha1= 0.1, a2= 0.2, -alpha2= 0.1, mu2= 21, lambda2= 0.39, a3= 0.001, +\dontrun{ +pars <- c(a1= 0.09, alpha1= 0.1, a2= 0.2, +alpha2= 0.1, mu2= 21, lambda2= 0.39, a3= 0.001, alpha3= 1, mu3= 67, lambda3= 0.6, c= 0.01) ages <- 0:75 mx <- mig_calculate_rc(ages = ages, pars = pars) -\dontrun{ plot(ages, mx, type = 'l') } } diff --git a/man/mig_estimate_rc.Rd b/man/mig_estimate_rc.Rd index 386ca85fe..80d7624de 100644 --- a/man/mig_estimate_rc.Rd +++ b/man/mig_estimate_rc.Rd @@ -34,6 +34,7 @@ Given a set of ages and observed age-specific migration rates, estimate the para Choose between a 7,9,11 or 13 parameter model. } \examples{ +\dontrun{ # define ages and migration rates ages <- 0:75 mig_rate <- c(0.1014,0.0984,0.0839,0.0759,0.0679,0.0616, @@ -48,12 +49,12 @@ mig_rate <- c(0.1014,0.0984,0.0839,0.0759,0.0679,0.0616, 0.0093,0.0083,0.0078,0.0067,0.0069,0.0054) # fit the model -res <- mig_estimate_rc(ages, mig_rate, -pre_working_age = TRUE, -working_age = TRUE, -retirement = FALSE, +res <- mig_estimate_rc(ages, mig_rate, +pre_working_age = TRUE, +working_age = TRUE, +retirement = FALSE, post_retirement = FALSE) -\dontrun{ + # plot the results and data plot(ages, mig_rate, ylab = "migration rate", xlab = "age") lines(ages, res[["fit_df"]]$median, col = "red") diff --git a/man/mig_resid.Rd b/man/mig_resid.Rd new file mode 100644 index 000000000..e7139b542 --- /dev/null +++ b/man/mig_resid.Rd @@ -0,0 +1,343 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mig_resid.R +\name{mig_resid} +\alias{mig_resid} +\alias{mig_resid_stock} +\alias{mig_resid_cohort} +\alias{mig_resid_time} +\title{Estimate net migration using residual methods: stock change, +time even flow and cohort even flow} +\usage{ +mig_resid( + pop_m_mat, + pop_f_mat, + sr_m_mat, + sr_f_mat, + asfr_mat, + srb_vec, + ages = NULL, + ages_asfr = NULL, + years_pop = NULL, + years_sr = NULL, + years_asfr = NULL, + years_srb = NULL, + verbose = TRUE, + method = c("stock", "cohort", "time") +) + +mig_resid_stock( + pop_m_mat, + pop_f_mat, + sr_m_mat, + sr_f_mat, + asfr_mat, + srb_vec, + ages = NULL, + ages_asfr = NULL, + years_pop = NULL, + years_sr = NULL, + years_asfr = NULL, + years_srb = NULL, + verbose = TRUE +) + +mig_resid_cohort( + pop_m_mat, + pop_f_mat, + sr_m_mat, + sr_f_mat, + asfr_mat, + srb_vec, + ages = NULL, + ages_asfr = NULL, + years_pop = NULL, + years_sr = NULL, + years_asfr = NULL, + years_srb = NULL, + verbose = TRUE +) + +mig_resid_time( + pop_m_mat, + pop_f_mat, + sr_m_mat, + sr_f_mat, + asfr_mat, + srb_vec, + ages = NULL, + ages_asfr = NULL, + years_pop = NULL, + years_sr = NULL, + years_asfr = NULL, + years_srb = NULL, + verbose = TRUE +) +} +\arguments{ +\item{pop_m_mat}{A \code{numeric} matrix with population counts. Rows should +be ages and columns should be years. Only five year age groups are supported. +See examples.} + +\item{pop_f_mat}{A \code{numeric} matrix with population counts. Rows should +be ages and columns should be years. Only five year age groups are supported. +See examples.} + +\item{sr_m_mat}{A \code{numeric} matrix with survival rates for males. Rows +should be ages and columns should be years. ** This matrix should have +one column less than \code{pop_m_mat} and \code{pop_f_mat}. For example, +if the last year in these matrices is 2050, then the last year in +\code{sr_m_mat} should be 2045. **} + +\item{sr_f_mat}{A \code{numeric} matrix with survival rates for females. Rows +should be ages and columns should be years. ** This matrix should have +one column less than \code{pop_m_mat} and \code{pop_f_mat}. For example, +if the last year in these matrices is 2050, then the last year in +\code{sr_f_mat} should be 2045. **.} + +\item{asfr_mat}{A \code{numeric} matrix with age specific fertility rates. +Rows should be ages and columns should be years. ** This matrix should have +one column less than \code{pop_m_mat} and \code{pop_f_mat}. For example, +if the last year in these matrices is 2050, then the last year in +\code{asfr_mat} should be 2045**. This row will usually have fewer age groups +(rows) than in the population matrices or survival matrices, so the user +needs to supply the specific ages in the \code{ages_asfr} argument.} + +\item{srb_vec}{A \code{numeric} vector of sex ratios at birth for every year. +The years should be the same as the years in \code{sr_m_mat}, +\code{sr_f_mat}, and \code{asfr_mat}.} + +\item{ages}{A \code{numeric} vector of ages used in the rows in +\code{pop_m_mat}, \code{pop_f_mat}, \code{sr_m_mat}, \code{sr_f_mat}.} + +\item{ages_asfr}{A \code{numeric} vector of ages used in the rows in +\code{asfr_mat}.} + +\item{years_pop}{Years used in the column names of population. If +\code{pop_m_mat} or \code{pop_f_mat} doesn't have column names, these +names are used. Otherwise ignored.} + +\item{years_sr}{Years used in the column names of survival rates. If +\code{sr_r_mat} doesn't have column names, these names are used. Otherwise +ignored.} + +\item{years_asfr}{Years used in the column names of age-specific fertility +rate. If code{asfr_r_mat} doesn't have column names, these names are used. +Otherwise ignored.} + +\item{years_srb}{Years used in the column names of sex-ratio at birth. If +\code{srb_r_mat} is not named, these names are used. Otherwise ignored.} + +\item{verbose}{Default set to TRUE. If TRUE, the function prints important +operations carried out in the function like if years were trimmed from the +data.} + +\item{method}{which residual migration method to use. This only works when +using \code{mig_resid} and the possible options are 'stock', 'cohort' and +'time', with 'stock' being the default.} +} +\value{ +A list with two matrices. One is for males (called \code{mig_m}) and the +other for females (called \code{mig_f}). Both matrices contain net migration +estimates by age/period using one of the three methods. +} +\description{ +Estimate net migration using residual methods: stock change, +time even flow and cohort even flow +} +\details{ +\enumerate{ +\item The stock method (\code{mig_resid_stock}) is the difference in stocks that +survive between t and t+5, and the first age group is based on the difference +with the surviving births by sex. It provides net migrants by lexis cohort +parallelograms, and basically such info gets used as end-period migration +since the migrants don't get exposed to mortality within the period. +\item The time even flow (\code{mig_resid_time}) method uses the result from +the first option, but splits it back into lexis period squares and assumes +that half of the net migrants get exposed to the mortality risk during this +period. Such info can get used as evenly distributed migration by period, +but the assumptions lead to zig-zag age patterns that are highly implausible. +\item The cohort even flow (\code{mig_resid_cohort}) method provides the most +meaningful pattern of net migration by age consistent by cohort and assumes +an evenly distribution within the 5-year period, and half of the migrants +get exposed both fertility and mortality within this period. +} + +\code{mig_resid} is a general function able to call the three methods only by +specifying the \code{method} argument. By default it is set to the +\code{stock} method. See the examples section. +} +\examples{ + +library(DemoTools) + +# The data is loaded with DemoTools + +################ Stock change method ##################### + +# Generic mig_resid method which allows to choose either stock, +# cohort or time method for five year ages groups + +mig_res <- + mig_resid( + pop_m_mat = pop_m_mat_five, + pop_f_mat = pop_f_mat_five, + sr_m_mat = sr_m_mat_five, + sr_f_mat = sr_f_mat_five, + asfr_mat = asfr_mat_five, + srb_vec = srb_vec_five, + ages = ages_five, + ages_asfr = ages_asfr_five, + # With the stock method + method = "stock" + ) + +# For single ages + +mig_res <- + mig_resid( + pop_m_mat = pop_m_mat_single, + pop_f_mat = pop_f_mat_single, + sr_m_mat = sr_m_mat_single, + sr_f_mat = sr_f_mat_single, + asfr_mat = asfr_mat_single, + srb_vec = srb_vec_single, + ages = ages_single, + ages_asfr = ages_asfr_single, + # With the stock method + method = "stock" + ) + +# Or directly the mid_resid_stock function +# (works for both single and five year age groups) + +mig_res <- + mig_resid_stock( + pop_m_mat = pop_m_mat_five, + pop_f_mat = pop_f_mat_five, + sr_m_mat = sr_m_mat_five, + sr_f_mat = sr_f_mat_five, + asfr_mat = asfr_mat_five, + srb_vec = srb_vec_five, + ages = ages_five, + ages_asfr = ages_asfr_five + ) + +# Net migration for males using stock change method +mig_res$mig_m + +# Net migration for females using stock change method +mig_res$mig_f + + +################ cohort even flow method ##################### + +# We reuse the same data from before +# Either use the generic mig_resid choosing 'cohort' + +# Five year age groups +mig_res <- + mig_resid( + pop_m_mat = pop_m_mat_five, + pop_f_mat = pop_f_mat_five, + sr_m_mat = sr_m_mat_five, + sr_f_mat = sr_f_mat_five, + asfr_mat = asfr_mat_five, + srb_vec = srb_vec_five, + ages = ages_five, + ages_asfr = ages_asfr_five, + # With the cohort method + method = "cohort" + ) + +# Single ages +mig_res <- + mig_resid( + pop_m_mat = pop_m_mat_single, + pop_f_mat = pop_f_mat_single, + sr_m_mat = sr_m_mat_single, + sr_f_mat = sr_f_mat_single, + asfr_mat = asfr_mat_single, + srb_vec = srb_vec_single, + ages = ages_single, + ages_asfr = ages_asfr_single, + # With the stock method + method = "cohort" + ) + +# Or directly the mid_resid_cohort function + +mig_res <- + mig_resid_cohort( + pop_m_mat = pop_m_mat_five, + pop_f_mat = pop_f_mat_five, + sr_m_mat = sr_m_mat_five, + sr_f_mat = sr_f_mat_five, + asfr_mat = asfr_mat_five, + srb_vec = srb_vec_five, + ages = ages_five, + ages_asfr = ages_asfr_five + ) + +# Net migration for males using the cohort even flow method +mig_res$mig_m + +# Net migration for females using the cohort even flow method +mig_res$mig_f + +################ time even flow method ##################### + +# We reuse the same data from before +# Either use the generic mig_resid with the 'time' method + +# For five year age groups +mig_res <- + mig_resid( + pop_m_mat = pop_m_mat_five, + pop_f_mat = pop_f_mat_five, + sr_m_mat = sr_m_mat_five, + sr_f_mat = sr_f_mat_five, + asfr_mat = asfr_mat_five, + srb_vec = srb_vec_five, + ages = ages_five, + ages_asfr = ages_asfr_five, + # With the time method + method = "time" + ) + +# For single ages +mig_res <- + mig_resid( + pop_m_mat = pop_m_mat_single, + pop_f_mat = pop_f_mat_single, + sr_m_mat = sr_m_mat_single, + sr_f_mat = sr_f_mat_single, + asfr_mat = asfr_mat_single, + srb_vec = srb_vec_single, + ages = ages_single, + ages_asfr = ages_asfr_single, + # With the stock method + method = "stock" + ) + +# Or directly the mid_resid_time function +# (works for both five and single year ages) + +mig_res <- + mig_resid_time( + pop_m_mat = pop_m_mat_five, + pop_f_mat = pop_f_mat_five, + sr_m_mat = sr_m_mat_five, + sr_f_mat = sr_f_mat_five, + asfr_mat = asfr_mat_five, + srb_vec = srb_vec_five, + ages = ages_five, + ages_asfr = ages_asfr_five + ) + +# Net migration for males using the time even flow method +mig_res$mig_m + +# Net migration for females using the time even flow method +mig_res$mig_f + +} diff --git a/man/mig_resid_stock.Rd b/man/mig_resid_stock.Rd deleted file mode 100644 index dbb9b3c33..000000000 --- a/man/mig_resid_stock.Rd +++ /dev/null @@ -1,575 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mig_resid.R -\name{mig_resid_stock} -\alias{mig_resid_stock} -\alias{mig_resid_cohort} -\alias{mig_resid_time} -\title{Estimate net migration using residual methods: stock change, -time even flow and cohort even flow} -\usage{ -mig_resid_stock( - pop_m_mat, - pop_f_mat, - sr_m_mat, - sr_f_mat, - asfr_mat, - srb_vec, - ages, - ages_fertility -) - -mig_resid_cohort( - pop_m_mat, - pop_f_mat, - sr_m_mat, - sr_f_mat, - asfr_mat, - srb_vec, - ages, - ages_fertility -) - -mig_resid_time( - pop_m_mat, - pop_f_mat, - sr_m_mat, - sr_f_mat, - asfr_mat, - srb_vec, - ages, - ages_fertility -) -} -\arguments{ -\item{pop_m_mat}{A \code{numeric} matrix with population counts. Rows should -be ages and columns should be years. Only five year age groups are supported. -See examples.} - -\item{pop_f_mat}{A \code{numeric} matrix with population counts. Rows should -be ages and columns should be years. Only five year age groups are supported. -See examples.} - -\item{sr_m_mat}{A \code{numeric} matrix with survival rates for males. Rows -should be ages and columns should be years. ** This matrix should have -one column less than \code{pop_m_mat} and \code{pop_f_mat}. For example, -if the last year in these matrices is 2050, then the last year in -\code{sr_m_mat} should be 2045. **} - -\item{sr_f_mat}{A \code{numeric} matrix with survival rates for females. Rows -should be ages and columns should be years. ** This matrix should have -one column less than \code{pop_m_mat} and \code{pop_f_mat}. For example, -if the last year in these matrices is 2050, then the last year in -\code{sr_f_mat} should be 2045. **.} - -\item{asfr_mat}{A \code{numeric} matrix with age specific fertility rates. -Rows should be ages and columns should be years. ** This matrix should have -one column less than \code{pop_m_mat} and \code{pop_f_mat}. For example, -if the last year in these matrices is 2050, then the last year in -\code{asfr_mat} should be 2045**. This row will usually have fewer age groups -(rows) than in the population matrices or survival matrices, so the user -needs to supply the specific ages in the \code{ages_fertility} argument.} - -\item{srb_vec}{A \code{numeric} vector of sex ratios at birth for every year. -The years should be the same as the years in \code{sr_m_mat}, -\code{sr_f_mat}, and \code{asfr_mat}.} - -\item{ages}{A \code{numeric} vector of ages used in the rows in -\code{pop_m_mat}, \code{pop_f_mat}, \code{sr_m_mat}, \code{sr_f_mat}.} - -\item{ages_fertility}{A \code{numeric} vector of ages used in the rows in -\code{asfr_mat}.} -} -\value{ -A list with two matrices. One is for males (called \code{mig_m}) and the -other for females (called \code{mig_f}). Both matrices contain net migration -estimates by age/period using one of the three methods. -} -\description{ -Estimate net migration using residual methods: stock change, -time even flow and cohort even flow -} -\details{ -\enumerate{ -\item The stock method (\code{mig_resid_stock}) is the difference in stocks that -survive between t and t+5, and the first age group is based on the difference -with the surviving births by sex. It provides net migrants by lexis cohort -parallelograms, and basically such info gets used as end-period migration -since the migrants don't get exposed to mortality within the period. -\item The time even flow (\code{mig_resid_time}) method uses the result from -the first option, but splits it back into lexis period squares and assumes -that half of the net migrants get exposed to the mortality risk during this -period. Such info can get used as evenly distributed migration by period, -but the assumptions lead to zig-zag age patterns that are highly implausible. -\item The cohort even flow (\code{mig_resid_cohort}) method provides the most -meaningful pattern of net migration by age consistent by cohort and assumes -an evenly distribution within the 5-year period, and half of the migrants -get exposed both fertility and mortality within this period. -} -} -\examples{ - -################ Stock change method ##################### - -# Vector of population for males -pop_m <- - c(835, 671, 570.999, 544, 552, 550, 513, 487.998, 432.002, - 378.001, 338.001, 295.999, 263.001, 220.999, 156, 92.001, 42.204, - 18.001, 4.331, 0.639, 0.07, 989.592, 880.029, 697.435, 575.575, - 561.146, 595.087, 582.08, 544.567, 507.247, 440.909, 373.935, - 316.617, 265.548, 235.035, 182.951, 110.75, 57.555, 18.737, 5.459, - 0.807, 0.065, 1133.424, 1037.502, 905.664, 698.771, 586.798, - 616.9, 638.007, 615.889, 550.076, 504.215, 430.131, 353.696, - 286.403, 238.634, 194.496, 130.76, 69.399, 26.238, 5.809, 1.011, - 0.083, 1149.519, 1149.942, 1042.707, 897.087, 691.317, 605.519, - 628.132, 641.442, 608.262, 532.131, 486.313, 401.381, 321.04, - 251.388, 197.567, 138.127, 81.716, 32.255, 8.386, 1.152, 0.112, - 959.81, 1167.439, 1166.318, 1054.263, 929.596, 770.233, 655.408, - 649.175, 641.542, 602.148, 513.273, 463.968, 371.397, 286.345, - 203.426, 141.486, 87.742, 38.904, 10.533, 1.647, 0.131, 904.577, - 990.842, 1195.275, 1192.299, 1096.101, 1010.808, 817.203, 673.368, - 657.377, 631.756, 591.218, 483.434, 432.18, 330.595, 237.691, - 147.718, 86.849, 42.396, 13.172, 2.217, 0.2, 914.965, 926.002, - 1008.784, 1224.923, 1217.653, 1099.911, 1019.023, 813.755, 676.39, - 643.237, 614.691, 562.266, 449.355, 383.548, 273.038, 176.289, - 92.764, 43.563, 15.48, 3.067, 0.316, 943.289, 927.824, 937.572, - 1036.631, 1265.185, 1225.442, 1108.122, 1014.48, 806.487, 659.135, - 627.186, 594.356, 527.096, 404.537, 320.095, 205.116, 112.331, - 47.821, 16.391, 3.791, 0.466, 982.718, 980.995, 958.024, 988.65, - 1076.907, 1293.734, 1267.032, 1135.973, 1031.081, 804.56, 654.945, - 615.926, 567.992, 487.466, 348.485, 248.7, 133.025, 58.273, 17.722, - 3.888, 0.553, 1012.228, 1014.939, 1019.3, 1013.749, 1016.987, - 1100.959, 1315.154, 1281.21, 1143.215, 1026.976, 788.317, 641.579, - 592.945, 521.839, 418.599, 270.316, 163.215, 70.003, 21.874, - 4.186, 0.549, 914.063, 1038.649, 1049.297, 1073.621, 1055.672, - 1047.487, 1138.313, 1344.753, 1295.431, 1144.702, 1016.992, 771.165, - 615.065, 550.259, 457.748, 334.624, 185.735, 87.221, 26.085, - 4.898, 0.538, 879.05, 952.912, 1081.565, 1116.92, 1130.826, 1092.34, - 1097.179, 1186.645, 1381.02, 1305.446, 1143.75, 989.552, 751.696, - 577.344, 489.506, 377.661, 245.003, 105.627, 34.645, 6.138, 0.619, - 967.471, 930.238, 993.227, 1141.416, 1220.943, 1218.465, 1152.732, - 1154.005, 1219.105, 1404.229, 1303.056, 1126.891, 960.563, 712.717, - 522.094, 415.611, 295.598, 149.226, 44.788, 8.64, 0.793, 996.168, - 1002.283, 955.049, 1097.332, 1284.199, 1236.929, 1269.189, 1192.192, - 1174.32, 1216.076, 1400.008, 1311.348, 1099.315, 941.078, 652.11, - 452.242, 319.415, 186.665, 65.652, 11.458, 1.11, 1020.925, 1011.765, - 1014.23, 1017.281, 1208.233, 1389.541, 1315.956, 1321.892, 1224.232, - 1189.671, 1215.983, 1380.774, 1275.239, 1047.397, 867.426, 568.286, - 355.943, 205.33, 83.6, 17, 1.474, 1028.191, 1035.869, 1023.388, - 1074.814, 1125.935, 1311.078, 1465.662, 1367.022, 1352.787, 1239.604, - 1191.356, 1203.245, 1346.713, 1220.838, 973.366, 765.273, 455.163, - 235.912, 97.148, 22.528, 2.061, 1035.917, 1043.755, 1047.947, - 1086.086, 1187.203, 1232.794, 1390.453, 1518.531, 1399.596, 1369.011, - 1242.733, 1181.749, 1178.339, 1295.414, 1142.767, 869.016, 624.221, - 310.175, 115.614, 27.037, 2.784, 1045.967, 1052.236, 1056.4, - 1113.398, 1203.477, 1298.811, 1316.2, 1446.37, 1552.621, 1417.392, - 1372.669, 1234.502, 1160.392, 1138.346, 1219.39, 1029.28, 718.949, - 434.576, 156.257, 33.016, 3.417, 1068.682, 1062.337, 1064.906, - 1121.9, 1230.868, 1315.242, 1382.275, 1372.643, 1481.225, 1570.215, - 1421.698, 1364.113, 1214.291, 1124.645, 1077.332, 1107.059, 862.313, - 510.375, 224.598, 45.72, 4.224, 1102.822, 1085.121, 1075.057, - 1130.572, 1239.683, 1342.955, 1399.057, 1438.921, 1408.243, 1499.967, - 1574.252, 1414.059, 1343.384, 1179.959, 1069.144, 985.391, 938.14, - 623.089, 270.065, 67.236, 5.855, 1140.8, 1119.328, 1097.897, - 1140.924, 1248.743, 1352.213, 1427.121, 1456.061, 1474.768, 1428.008, - 1505.633, 1566.169, 1394.527, 1308.152, 1126.043, 984.266, 844, - 689.026, 337.068, 82.618, 8.662) - -# Vector of population for females -pop_f <- - c(801, 645, 554.001, 534, 557.999, 564, 521.001, 478.001, - 410.999, 352.999, 318, 276, 239, 196.998, 147, 92, 49.354, 23.001, - 6.5, 1.164, 0.135, 948.057, 844.618, 670.281, 562.978, 556.695, - 589.153, 595.677, 545.622, 488.336, 410.687, 346.698, 303.994, - 257.339, 222.218, 177.703, 111.516, 66.076, 25.155, 8.267, 1.423, - 0.145, 1082.85, 993.185, 866.81, 675.391, 590.032, 594.559, 626.777, - 624.823, 547.167, 485.337, 406.556, 337.02, 285.388, 243.185, - 202.252, 135.464, 80.488, 34.773, 9.379, 1.88, 0.182, 1091.999, - 1101.593, 998.637, 870.126, 696.038, 607.414, 608.372, 634.123, - 618.287, 534.182, 476.099, 390.902, 323.659, 270.819, 222.629, - 158.211, 99.985, 43.526, 13.425, 2.209, 0.243, 916.285, 1113.846, - 1116.448, 1022.769, 918.839, 752.674, 635.897, 619.411, 627.163, - 613.115, 524.316, 470.068, 384.21, 315.25, 247.486, 184.146, - 119.509, 56.879, 17.577, 3.347, 0.307, 858.616, 944.546, 1141.242, - 1148.666, 1080.544, 977.493, 784.947, 647.137, 627.282, 623.897, - 615.885, 510.514, 460.492, 370.614, 286.566, 207.64, 136.385, - 70.415, 24.027, 4.599, 0.483, 868.926, 877.749, 959.791, 1175.057, - 1195.136, 1093.776, 991.924, 782.722, 651.731, 622.015, 618.687, - 605.778, 500.641, 442.912, 341.607, 245.476, 158.844, 84.752, - 32.378, 7.171, 0.792, 895.173, 880.805, 893.824, 982.635, 1215.112, - 1205.436, 1108.77, 989.171, 783.703, 645.936, 620.163, 616.473, - 594.188, 483.99, 407.959, 294.664, 188.001, 102.344, 41.293, - 10.454, 1.36, 936.591, 930.873, 909.761, 937.09, 1040.314, 1261.087, - 1253.31, 1138.156, 1013.326, 789.43, 647.395, 618.625, 607.737, - 578.414, 450.459, 356.927, 227.408, 122.534, 50.048, 13.221, - 1.968, 962.734, 966.476, 967.107, 957.99, 982.293, 1078.452, - 1289.82, 1276.239, 1152.444, 1021.414, 790.697, 651.846, 612.561, - 584.997, 533.268, 389.96, 277.225, 150.795, 61.026, 16.175, 2.495, - 872.149, 989.229, 998.47, 1014.575, 1007.4, 1019.803, 1118.597, - 1322.793, 1295.408, 1160.933, 1017.656, 782.288, 640.445, 591.004, - 544.271, 468.132, 312.504, 184.648, 74.05, 18.888, 2.818, 831.614, - 907.289, 1032.916, 1054.491, 1087.81, 1064.803, 1079.765, 1163.223, - 1358.369, 1304.687, 1162.716, 1010.927, 777.628, 621.991, 554.866, - 485.032, 385.873, 214.234, 93.771, 23.583, 3.281, 918.838, 876.318, - 944.356, 1087.72, 1156.023, 1189.243, 1155.079, 1142.97, 1200.737, - 1385.864, 1307.092, 1157.85, 1000.01, 756.228, 585.003, 501.751, - 414.881, 275.154, 114.55, 31.799, 4.292, 950.252, 955.845, 901.601, - 1034.682, 1232.517, 1230.147, 1278.363, 1207.768, 1177.793, 1204.356, - 1388.633, 1309.444, 1137.271, 975.544, 718.972, 536.404, 423.543, - 303.137, 151.219, 39.364, 5.675, 972.207, 966.024, 968.771, 971.038, - 1155.236, 1343.606, 1310.409, 1330.404, 1239.077, 1193.687, 1207.497, - 1378.179, 1287.326, 1102.782, 925.427, 657.537, 458.654, 313.372, - 169.081, 52.593, 7.072, 976.405, 987.332, 978.581, 1036.217, - 1088.349, 1263.153, 1421.22, 1360.854, 1360.488, 1254.47, 1197.429, - 1200.365, 1355.979, 1250.443, 1049.613, 850.295, 565.065, 343.486, - 179.947, 59.846, 9.474, 983.61, 992.108, 1000.337, 1048.292, - 1157.406, 1200.03, 1343.652, 1473.399, 1392.3, 1376.507, 1258.974, - 1191.956, 1183.853, 1320.389, 1194.661, 970.4, 737.82, 429.619, - 201.231, 64.936, 11.111, 993.232, 1000.063, 1005.704, 1073.068, - 1174.732, 1273.909, 1284.275, 1398.562, 1506.421, 1409.749, 1381.642, - 1254.544, 1177.896, 1156.569, 1266.895, 1112.005, 851.243, 570.482, - 257.474, 74.251, 12.326, 1014.748, 1009.727, 1013.685, 1078.453, - 1199.539, 1291.299, 1358.178, 1339.471, 1432.104, 1523.907, 1415.474, - 1377.117, 1241.194, 1153.335, 1113.937, 1185.875, 984.267, 667.614, - 348.639, 96.877, 14.172, 1047.114, 1031.299, 1023.389, 1086.588, - 1205.189, 1316.366, 1375.813, 1413.531, 1373.503, 1450.422, 1529.735, - 1411.833, 1363.681, 1217.645, 1114.502, 1048.481, 1058.718, 782.58, - 415.883, 133.756, 18.362, 1083.119, 1063.736, 1045.012, 1096.489, - 1213.687, 1322.39, 1401.18, 1431.462, 1447.757, 1392.552, 1457.502, - 1526.287, 1399.672, 1340.065, 1180.192, 1054.342, 943.985, 853.051, - 496.821, 162.711, 25.414) - -# Vector of age-specific fertility rates -asfr <- c(50.369, 202.131, 206.141, 149.211, 87.253, 31.052, - 2.843, 57.919, 226.709, 222.516, 148.992, 87.888, 29.736, 2.64, - 54.096, 223.587, 211.46, 140.311, 76.881, 26.533, 2.132, 45.049, - 159.679, 156.131, 93.96, 50.059, 15.713, 1.409, 37.188, 119.39, - 132.748, 70.029, 28.02, 7.311, 0.514, 30.209, 101.658, 125.692, - 65.483, 19.804, 3.711, 0.243, 24.9, 88.815, 121.231, 68.621, - 20.031, 3.039, 0.163, 23.238, 78.247, 118.743, 75.403, 24.014, - 3.426, 0.129, 25.141, 75.764, 118.592, 85.555, 29.309, 4.303, - 0.136, 20.117, 64.41, 104.081, 85.589, 32.737, 5.247, 0.219, - 14.645, 53.484, 98.176, 92.658, 37.567, 6.397, 0.273, 13.677, - 51.37, 100.418, 104.868, 48.196, 8.278, 0.393, 11.494, 43.287, - 93.809, 106.904, 53.5, 10.662, 0.544, 8.387, 37.053, 86.307, - 106.038, 55.169, 11.345, 0.701, 6.625, 31.576, 80.064, 106.128, - 58.423, 13.087, 0.917, 5.468, 27.869, 76.196, 107.843, 62.296, - 15.036, 1.172, 4.686, 25.34, 73.943, 110.575, 66.487, 17.107, - 1.462, 4.134, 23.539, 72.551, 113.398, 70.423, 19.099, 1.756, - 3.732, 22.206, 71.53, 115.597, 73.588, 20.803, 2.024, 3.467, - 21.39, 71.244, 117.758, 76.268, 22.224, 2.249) - -# Vector of survival rates for males -sr_m <- c(0.95557549, 0.9921273, 0.99594764, 0.99510483, 0.99178483, - 0.99134461, 0.99100899, 0.98929784, 0.98473229, 0.97588706, - 0.96048519, 0.93812765, 0.90615821, 0.8622277, 0.8047363, - 0.71333856, 0.596832, 0.44396816, 0.30330032, 0.18642771, - 0.0911662462413327, 0.96275471, 0.99399428, 0.9968488, 0.99563281, - 0.99229006, 0.99196446, 0.99180061, 0.99013625, 0.98594365, - 0.97719516, 0.96239426, 0.93950426, 0.90620399, 0.86117682, - 0.80225284, 0.71307413, 0.60022645, 0.4558758, 0.31005161, - 0.18518342, 0.0956313878791117, 0.96951141, 0.99496609, 0.99727649, - 0.99607245, 0.99233725, 0.99205108, 0.99228027, 0.99056435, - 0.98605767, 0.97783685, 0.96314897, 0.9406932, 0.90642888, - 0.86286999, 0.80387894, 0.71498269, 0.6066814, 0.46479967, - 0.31958557, 0.19836001, 0.101989015830425, 0.97545992, 0.99563858, - 0.99741385, 0.99592654, 0.99152023, 0.99192115, 0.9924163, - 0.990644, 0.98617665, 0.97752991, 0.96353815, 0.94114166, - 0.90833701, 0.86170391, 0.80301014, 0.72151551, 0.6128495, - 0.47608317, 0.32653048, 0.19655555, 0.103730263806538, 0.98060776, - 0.99617149, 0.99761403, 0.99542383, 0.99054495, 0.99194397, - 0.99266261, 0.99089428, 0.98611279, 0.97789594, 0.96434779, - 0.94341044, 0.91191009, 0.86748795, 0.80686197, 0.72532159, - 0.61846149, 0.48319275, 0.33857582, 0.2104904, 0.112385162790671, - 0.98550309, 0.99688352, 0.99803301, 0.9959062, - 0.99126003, 0.99231634, 0.99301369, 0.99160392, 0.98761021, - 0.97986329, 0.96646197, 0.94623899, 0.91718051, 0.87584219, - 0.81662218, 0.73700918, 0.6303803, 0.50160307, 0.3651526, - 0.23288489, 0.130850768617506, 0.98931819, 0.99775357, 0.9984583, - 0.99673481, 0.99301824, 0.99346278, 0.99369545, 0.99294003, - 0.98994327, 0.98356936, 0.97206458, 0.95389895, 0.92644026, - 0.88661213, 0.82907732, 0.74960973, 0.64331764, 0.51551648, - 0.37629084, 0.24487989, 0.137677217644374, 0.99112504, 0.99814201, - 0.99879926, 0.99711429, 0.99389061, 0.99409107, 0.99396033, - 0.99290953, 0.99073493, 0.98586868, 0.97625645, 0.95984456, - 0.93401387, 0.89576747, 0.84146086, 0.76230416, 0.6528808, - 0.51875327, 0.37059318, 0.23716232, 0.129879589178461, 0.99268153, - 0.99853182, 0.99902021, 0.99755244, 0.99471893, 0.99453053, - 0.99383731, 0.99242559, 0.99039498, 0.98664094, 0.97888902, - 0.96514568, 0.94232807, 0.90695918, 0.85686765, 0.78068285, - 0.6693777, 0.52625072, 0.37539746, 0.23620331, 0.123653858706926, - 0.99378702, 0.99880557, 0.99916867, 0.99795758, 0.99537754, - 0.99534488, 0.99484455, 0.99357678, 0.99141921, 0.9878473, - 0.98134482, 0.96932265, 0.94941573, 0.91742454, 0.86776992, - 0.79533967, 0.68311452, 0.5343893, 0.37262307, 0.2239178, - 0.113720633638293, 0.99399248, 0.99897976, 0.99932852, 0.99822431, - 0.99601855, 0.99591387, 0.99569633, 0.99470259, 0.99268715, - 0.98892298, 0.98249955, 0.97238094, 0.9552462, 0.92844911, - 0.88653064, 0.82114141, 0.71875477, 0.56869525, 0.39721252, - 0.23529357, 0.113792166251756, 0.99425766, 0.99909623, 0.99940998, - 0.99846006, 0.99631257, 0.99603178, 0.99592291, 0.99518752, - 0.99322132, 0.98983274, 0.98368064, 0.9741733, 0.9602258, - 0.93745239, 0.9016288, 0.8444638, 0.75222073, 0.60907965, - 0.4240168, 0.24939352, 0.117336219766853, 0.99471736, 0.99933256, - 0.99947765, 0.99871556, 0.99694493, 0.99649396, 0.99655801, - 0.99589338, 0.99413263, 0.99084735, 0.98542046, 0.97725847, - 0.96497949, 0.9452114, 0.9134356, 0.8610204, 0.7737601, 0.63147622, - 0.43996206, 0.25585397, 0.117677375365884, 0.99489165, 0.99937715, - 0.99951763, 0.99880472, 0.99710652, 0.99665932, 0.99675852, - 0.99614922, 0.99444005, 0.99122406, 0.98598437, 0.97827319, - 0.96683874, 0.94835124, 0.91833471, 0.86821514, 0.78398104, - 0.64282533, 0.44786339, 0.25892654, 0.117310656081295, 0.99547488, - 0.99923281, 0.99957341, 0.99911343, 0.99802214, 0.99709297, - 0.99680896, 0.99635099, 0.99498899, 0.99222347, 0.9875931, - 0.98060053, 0.97014661, 0.9536392, 0.92634894, 0.87987019, - 0.79856151, 0.66278044, 0.47312791, 0.2694788, 0.111570323438865, - 0.99610316, 0.99933917, 0.9996362, 0.99923203, 0.99825186, - 0.99737383, 0.99710434, 0.99670571, 0.99548655, 0.99299216, - 0.9888173, 0.98253469, 0.97316181, 0.95828527, 0.93341992, - 0.89062075, 0.81386423, 0.68145805, 0.49006978, 0.27830681, - 0.113218864970809, 0.99653042, 0.99941146, 0.99967816, 0.99931356, - 0.99841616, 0.99758578, 0.9973301, 0.99697294, 0.99585907, - 0.99356834, 0.9897352, 0.98398011, 0.97540572, 0.96174959, - 0.93872789, 0.89876001, 0.8256409, 0.69618678, 0.50377247, - 0.28557404, 0.114591438080939, 0.99688677, 0.99947174, 0.99971275, - 0.99938206, 0.99855794, 0.99777511, 0.99753337, 0.99721139, - 0.99619015, 0.99408084, 0.99055187, 0.98526355, 0.97739317, - 0.9648224, 0.94346085, 0.90607063, 0.83636949, 0.70989474, - 0.51681708, 0.29260349, 0.115932510195963, 0.99718332, 0.99952193, - 0.9997412, 0.99943948, 0.99868001, 0.99794372, 0.99771578, - 0.99742349, 0.99648352, 0.99453532, 0.99127626, 0.98639967, - 0.97914803, 0.96753912, 0.94766613, 0.91261037, 0.84609618, - 0.7225789, 0.52915469, 0.29935668, 0.117233382382913, 0.99743526, - 0.99956461, 0.99976514, 0.9994886, 0.99878699, 0.99809597, - 0.99788161, 0.99761483, 0.99674727, 0.99494418, 0.99192807, - 0.98742013, 0.98072071, 0.96997658, 0.95145635, 0.91854221, - 0.85503156, 0.73446104, 0.54096047, 0.30591861, - 0.118509238191645) - -# Vector of survival rates for females -sr_f <- c(0.854489854276296, 0.935421167801612, 0.97813792986728, - 0.982021189677661, 0.976828336081795, 0.97244561985297, - 0.968812772150047, 0.96483427499772, 0.96010802339363, - 0.954056165687121, 0.943306039954761, 0.92448836548943, - 0.890690237758345, 0.835639114030282, 0.754796751406155, - 0.644175707707241, 0.510754359186887, 0.367690608641792, - 0.24038748937665, 0.145450728453873, 0.0826258994519641, - 0.872081445760557, 0.944846444000478, 0.981301676540409, - 0.98454923599414, 0.980025670920247, 0.976133157582757, - 0.972813894527646, 0.968976434023376, 0.964396307993652, - 0.958650557701456, 0.948256461919103, 0.930336619590153, - 0.898721683064412, 0.846943744756808, 0.7693050373115, - 0.660761281137989, 0.526356065457763, 0.380513624627523, - 0.249631099810745, 0.150641910916079, 0.0845984581684562, - 0.886848633625797, 0.952485090106336, 0.983750072193038, - 0.986500893000163, 0.982460467395807, 0.978978117640805, - 0.975938233552867, 0.972378413253193, 0.967941794833695, - 0.962223931611845, 0.952268831689409, 0.935291261627555, - 0.905449822961756, 0.856292233575997, 0.781888442354377, - 0.676068647825169, 0.542224475987347, 0.394762631381521, - 0.260252774164775, 0.156857215747202, 0.0874135544568921, - 0.900784558263659, 0.9596839642243, 0.986196123803518, - 0.988385232322206, 0.984769248387878, 0.981657532920333, - 0.978917213857464, 0.975642526638743, 0.971423457946261, - 0.965729507599766, 0.956020853088256, 0.939966236835617, - 0.912171280137383, 0.865872642393594, 0.794508147678775, - 0.691547047753295, 0.558414706244368, 0.408689574652693, - 0.269878505194327, 0.1624396495176, 0.0898671492416105, - 0.912633835108388, 0.965550681132028, 0.987920059015778, - 0.989848240747598, 0.986695608763104, 0.983981235542121, - 0.981570190639542, 0.97861812228183, 0.974635289736998, - 0.9691431860219, 0.959749667932423, 0.944374872196883, - 0.918112298204692, 0.874309263183862, 0.80582736469469, - 0.705435057343639, 0.573891155573389, 0.423123546270893, - 0.280818298136084, 0.169320472983824, 0.0930347806338448, - 0.922791200429312, 0.970414095250172, 0.989432301168788, - 0.990708732285749, 0.987862933459543, 0.98554556950358, - 0.983439950663867, 0.980726138018158, 0.976956585172812, - 0.971679032024458, 0.962795297767379, 0.948303265698793, - 0.923561621562827, 0.882274284142424, 0.817184362828982, - 0.720298723984997, 0.590336398050365, 0.439061608307152, - 0.293893306863672, 0.178752339638971, 0.0979770657163587, - 0.933750711567667, 0.975650023350237, 0.991430129981753, - 0.99247477931302, 0.989942622594004, 0.987846767986695, - 0.98591292962169, 0.983362542545618, 0.979767042495056, - 0.974726611965329, 0.96628359885727, 0.95251185213316, - 0.929005505885616, 0.889790085932051, 0.827762556372604, - 0.734212960407364, 0.606322257595734, 0.453895037584414, - 0.305625301261282, 0.186403154530675, 0.101364444633525, - 0.942022185331379, 0.979147123918558, 0.992515619501369, - 0.9933310350342, 0.990999245807151, 0.98905130373017, - 0.987257739978207, 0.984897031588263, 0.981492787306857, - 0.9766673141557, 0.968686240948038, 0.955634366723833, - 0.9333801029294, 0.895907358522987, 0.836661271636903, - 0.746801163214231, 0.621415950298903, 0.468910608066693, - 0.317915153427838, 0.195039481469627, 0.105384282613558, - 0.94718229582512, 0.980790142908247, 0.992803300931434, - 0.993541163348349, 0.991307476656705, 0.989225443921528, - 0.987176469101693, 0.98460623719428, 0.981246509709472, - 0.976718447241337, 0.969160984177711, 0.956833654346736, - 0.935783935128507, 0.900223655022325, 0.843512027545961, - 0.75698552882669, 0.634658767009268, 0.482935300037292, - 0.329848456620383, 0.20331169504299, 0.10978246168398, - 0.953756599857967, 0.984059901645376, 0.993955214747401, - 0.994268297381336, 0.991878910452198, 0.989316711233698, - 0.98661050317541, 0.983509725457937, 0.980068840413112, - 0.975865841537748, 0.96873162752321, 0.957191306973029, - 0.937336013374256, 0.903694171906013, 0.84952642553648, - 0.76536853834578, 0.645403389194791, 0.494479119379901, - 0.339863899010747, 0.210826549541289, 0.113471459046826, - 0.960713535654886, 0.987033073900882, 0.994716009106623, - 0.994894234746082, 0.992525302465177, 0.9895538842758, - 0.986152805334012, 0.982472321949589, 0.979073662581534, - 0.975395328209274, 0.968932259296626, 0.958359612326248, - 0.939967835580358, 0.908680780255339, 0.857541392392623, - 0.777353828146545, 0.661131513296524, 0.512711981039796, - 0.357346432815676, 0.224662101978509, 0.121638559000661, - 0.967668081909087, 0.990008068984907, 0.995560889886471, - 0.995641991716643, 0.993624470509278, 0.991059373658537, - 0.988040353436121, 0.984673329703723, 0.981470430737054, - 0.977934939728761, 0.971766487949973, 0.961780792273926, - 0.944588362056491, 0.915303175185752, 0.867175365253056, - 0.790635307536064, 0.677656963580601, 0.530729783448463, - 0.374404597176352, 0.237203123872316, 0.127388492872508, - 0.973550993968318, 0.99237559671888, 0.996334437474569, - 0.996302569319733, 0.994665042785698, 0.992854350176394, - 0.990804628097226, 0.988299827070781, 0.985427217612243, - 0.98180549401774, 0.975726794918091, 0.966103852460658, - 0.949838547130851, 0.92234926803937, 0.877071883537886, - 0.804140728455995, 0.694271895287286, 0.548487335263838, - 0.389191763586342, 0.24733085854494, 0.131770634512774, - 0.977644495019607, 0.993809059507753, 0.996921848401461, - 0.996813848508293, 0.995383460235151, 0.993952685083984, - 0.992408034278954, 0.990393195059418, 0.987756840918104, - 0.984187864274535, 0.978346485320431, 0.969132680765175, - 0.953701455005333, 0.92763044136048, 0.884677298385547, - 0.814988789377917, 0.708878868603095, 0.565946568832964, - 0.40677396957209, 0.26150417331884, 0.138468877454496, 0.99589669, - 0.99939439, 0.99968965, 0.99946356, 0.99900599, 0.99861604, - 0.99832041, 0.99779148, 0.99668581, 0.9946399, 0.9913872, - 0.98672374, 0.97979077, 0.96855904, 0.94971941, 0.9172498, - 0.85796829, 0.74889563, 0.57422822, 0.35395265, 0.158786622360056, - 0.9963443, 0.99946056, 0.99972569, 0.99951979, 0.99909662, - 0.99871978, 0.99844108, 0.9979583, 0.99694158, 0.99505178, - 0.99204825, 0.98775485, 0.98138426, 0.97102475, 0.95351064, - 0.92310744, 0.86661424, 0.76030246, 0.58585433, 0.36085561, - 0.160294341407215, 0.99679414, 0.99952694, 0.99976136, 0.99957681, - 0.99919131, 0.99883301, 0.99857404, 0.99814009, 0.99721897, - 0.99549888, 0.99276597, 0.98887133, 0.98310375, 0.97368874, - 0.95762803, 0.92951136, 0.87619312, 0.77320377, - 0.59930763, 0.36898278, 0.162083812814283, 0.9971375, 0.99957757, - 0.99978821, 0.99962071, 0.99926645, 0.99892672, 0.99868509, - 0.9982903, 0.99744714, 0.99586696, 0.99335694, 0.98978824, - 0.98451115, 0.97587178, 0.96101941, 0.93482131, 0.88424374, - 0.78427805, 0.61113191, 0.37625625, 0.163698785477625, 0.99744017, - 0.99962217, 0.9998116, 0.99965971, 0.99933486, 0.99901498, - 0.99879044, 0.99843159, 0.99766096, 0.99621214, 0.99391125, - 0.99064648, 0.985825, 0.97791169, 0.9642029, 0.93983665, - 0.89194494, 0.79508552, 0.62293587, 0.38364594, 0.165352911452495, - 0.99771115, 0.99966211, 0.99983233, 0.99969485, 0.99939794, - 0.99909887, 0.9988912, 0.99856572, 0.9978633, 0.996539, 0.9944362, - 0.99145779, 0.98706409, 0.97983722, 0.96722115, 0.94462117, - 0.89938678, 0.80574358, 0.63485152, 0.39124343, 0.167067858821075) - - -all_years <- c("1950", "1955", "1960", "1965", "1970", "1975", - "1980", "1985", "1990", "1995", "2000", "2005", - "2010", "2015", "2020", "2025", "2030", "2035", - "2040", "2045", "2050") - -# Population for males as matrix -pop_m_mat <- matrix(pop_m, nrow = 21, ncol = 21) -colnames(pop_m_mat) <- all_years - -# Population for females as matrix -pop_f_mat <- matrix(pop_f, nrow = 21, ncol = 21) -colnames(pop_f_mat) <- all_years - -# Age-specific-fertility-rate for as matrix -asfr_mat <- matrix(asfr, nrow = 7, ncol = 20) -colnames(asfr_mat) <- all_years[-length(all_years)] - -# Sex ratio at birth as vector -srb_vec <- c(1.058, 1.057, 1.055, 1.055, 1.06, 1.056, 1.056, 1.052, 1.056, - 1.054, 1.054, 1.053, 1.054, 1.053, 1.056, 1.056, 1.056, 1.056, - 1.056, 1.056) - -names(srb_vec) <- all_years[-length(all_years)] - -# Survival ratio for males as matrix -sr_m_mat <- matrix(sr_m, nrow = 21, ncol = 20) -colnames(sr_m_mat) <- all_years[-length(all_years)] - -# Survival ratio for females as matrix -sr_f_mat <- matrix(sr_f, nrow = 21, ncol = 20) -colnames(sr_f_mat) <- all_years[-length(all_years)] - -# Age/year sequence of all the data from above -interval <- 5 -ages <- seq(0, 100, by = interval) -years <- seq(1950, 2050, by = interval) -ages_fertility <- seq(15, 45, by = interval) - -mig_res <- - mig_resid_stock( - pop_m_mat = pop_m_mat, - pop_f_mat = pop_f_mat, - sr_m_mat = sr_m_mat, - sr_f_mat = sr_f_mat, - asfr_mat = asfr_mat, - srb_vec = srb_vec, - ages = ages, - ages_fertility = ages_fertility - ) - -# Net migration for males using stock change method -mig_res$mig_m - -# Net migration for females using stock change method -mig_res$mig_f - - -################ cohort even flow method ##################### - -# We reuse the same data from before - -mig_res <- - mig_resid_cohort( - pop_m_mat = pop_m_mat, - pop_f_mat = pop_f_mat, - sr_m_mat = sr_m_mat, - sr_f_mat = sr_f_mat, - asfr_mat = asfr_mat, - srb_vec = srb_vec, - ages = ages, - ages_fertility = ages_fertility - ) - -# Net migration for males using the cohort even flow method -mig_res$mig_m - -# Net migration for females using the cohort even flow method -mig_res$mig_f - -################ time even flow method ##################### - -# We reuse the same data from before - -mig_res <- - mig_resid_time( - pop_m_mat = pop_m_mat, - pop_f_mat = pop_f_mat, - sr_m_mat = sr_m_mat, - sr_f_mat = sr_f_mat, - asfr_mat = asfr_mat, - srb_vec = srb_vec, - ages = ages, - ages_fertility = ages_fertility - ) - -# Net migration for males using the time even flow method -mig_res$mig_m - -# Net migration for females using the time even flow method -mig_res$mig_f - -} diff --git a/man/mig_un_fam.Rd b/man/mig_un_fam.Rd new file mode 100644 index 000000000..72b2665d9 --- /dev/null +++ b/man/mig_un_fam.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mig_un_fam.R +\name{mig_un_fam} +\alias{mig_un_fam} +\title{Net migration by age for an UN family} +\usage{ +mig_un_fam(NM, family, Single = TRUE, OAnew = 100) +} +\arguments{ +\item{NM}{numeric. Total net migration to distribuite between ages and sex.} + +\item{family}{character. Could be "Family", "Female Labor", "Male Labor".} + +\item{Single}{logical. Results by simple age. Default \code{FALSE}. +Typically from pre-working age and working age parts of in Roger-Castro formula.} + +\item{OAnew}{The age from which to group all ages into an open ended age group. +By default it is set to 100, so it groups all ages up to 120, which is the +maximum age.} +} +\value{ +List with +\itemize{ +\item{params_RC} {data.frame. Roger-Castro parameters in a data.frame. Same as \code{mig_un_params} data.} +\item{net_migr} {data.frame. Net migrants by age and sex for the chosen family.} +} +} +\description{ +Given a total net migration, +calculate the net migration age schedule based on the Rogers and Castro formula for UN families. +} +\examples{ +# 10000 net migrants, comparing two possible families +nm1 <- mig_un_fam(NM = 10000, family = "Male Labor", OAnew = 100) +nm2 <- mig_un_fam(NM = 10000, family = "Family", OAnew = 100) +# See the female profile in for these models: +\dontrun{ +plot(nm1$net_migr$age[nm1$net_migr$sex=="Female"], + nm1$net_migr$nm[nm1$net_migr$sex=="Female"], + xlab="Age",ylab="nm",ylim=c(0,300)) +points(nm2$net_migr$age[nm2$net_migr$sex=="Female"], + nm2$net_migr$nm[nm2$net_migr$sex=="Female"], col=2) +} +} diff --git a/man/mig_un_families.Rd b/man/mig_un_families.Rd new file mode 100644 index 000000000..1ed8c0e31 --- /dev/null +++ b/man/mig_un_families.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{mig_un_families} +\alias{mig_un_families} +\title{Proportion of net migrants by age and sex for considered migration profiles} +\format{ +A data frame with: +\describe{ +\item{family}{Types Family, Male Labor or Female Labor.} +\item{sex}{Male and Female.} +\item{mig_sign}{Inmigration or Emigration.} +\item{age}{Simple ages from 0 to 80 (OAG).} +\item{prop}{Proportion of net migrants due to that sex and age.} +} +} +\source{ +UN spreadsheet "UNPD_Migration Age Profiles.xlsx" +} +\usage{ +mig_un_families +} +\description{ +Roger-Castro estimated proportion of total net migrants using parameters from \code{mig_un_params} data. +} +\keyword{datasets} diff --git a/man/mig_un_params.Rd b/man/mig_un_params.Rd new file mode 100644 index 000000000..81897966a --- /dev/null +++ b/man/mig_un_params.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{mig_un_params} +\alias{mig_un_params} +\title{Parameters for considered migration profiles} +\format{ +A data frame with: +\describe{ +\item{family}{Types Family, Male Labor or Female Labor.} +\item{sex}{Male and Female.} +\item{mig_sign}{Inmigration or Emigration.} +\item{param}{Parameters from Roger-Castro.} +\item{median}{median of posterior distribution using Monte Carlo Markov Chains in \code{mig_estimate_rc}.} +} +} +\source{ +UN spreadsheet "UNPD_Migration Age Profiles.xlsx" +} +\usage{ +mig_un_params +} +\description{ +Roger-Castro estimated parameters using \code{mig_estimate_rc} for Pre Working Age and Working Age profiles of migration. +} +\keyword{datasets} diff --git a/man/pipe.Rd b/man/pipe.Rd index 0eec75261..a648c2969 100644 --- a/man/pipe.Rd +++ b/man/pipe.Rd @@ -6,6 +6,14 @@ \usage{ lhs \%>\% rhs } +\arguments{ +\item{lhs}{A value or the magrittr placeholder.} + +\item{rhs}{A function call using the magrittr semantics.} +} +\value{ +The result of calling \code{rhs(lhs)}. +} \description{ See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details. } diff --git a/man/pop1m_rus2002.Rd b/man/pop1m_rus2002.Rd new file mode 100644 index 000000000..25e26c8b4 --- /dev/null +++ b/man/pop1m_rus2002.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{pop1m_rus2002} +\alias{pop1m_rus2002} +\title{Russian census 2002 male population by 1 year age groups} +\format{ +A numeric vector of length 101 +} +\source{ +The data comes from +\url{http://www.demoscope.ru/weekly/ssp/rus2002_01.php} +} +\usage{ +pop1m_rus2002 +} +\description{ +Male population by 1 year age groups from Russian census help on 2002-10-16 +} +\keyword{datasets} diff --git a/man/pop1m_rus2010.Rd b/man/pop1m_rus2010.Rd new file mode 100644 index 000000000..a3c56a6e1 --- /dev/null +++ b/man/pop1m_rus2010.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{pop1m_rus2010} +\alias{pop1m_rus2010} +\title{Russian census 2010 male population by 1 year age groups} +\format{ +A numeric vector of length 101 +} +\source{ +The data comes from +\url{http://www.demoscope.ru/weekly/ssp/rus_age1_10.php} +} +\usage{ +pop1m_rus2010 +} +\description{ +Male population by 1 year age groups from Russian census help on 2010-10-25 +} +\keyword{datasets} diff --git a/man/pop_f_mat_five.Rd b/man/pop_f_mat_five.Rd new file mode 100644 index 000000000..3780519ee --- /dev/null +++ b/man/pop_f_mat_five.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{pop_f_mat_five} +\alias{pop_f_mat_five} +\title{Population matrix for females five year age groups between 1950 and 2050} +\format{ +A matrix of dimensions 21 x 21 +} +\source{ +Migration residual PAS spreadhseet +} +\usage{ +pop_f_mat_five +} +\description{ +Population matrix for females five year age groups between 1950 and 2050 for +unknown country +} +\keyword{datasets} diff --git a/man/pop_f_mat_single.Rd b/man/pop_f_mat_single.Rd new file mode 100644 index 000000000..406f57146 --- /dev/null +++ b/man/pop_f_mat_single.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{pop_f_mat_single} +\alias{pop_f_mat_single} +\title{Population matrix for females single ages between 1999 and 2019} +\format{ +A matrix of dimensions 101 x 21 +} +\source{ +Migration residual PAS spreadhseet +} +\usage{ +pop_f_mat_single +} +\description{ +Population matrix for females single ages between 1999 and 2019 for +Sweden +} +\keyword{datasets} diff --git a/man/pop_m_mat_five.Rd b/man/pop_m_mat_five.Rd new file mode 100644 index 000000000..01b693491 --- /dev/null +++ b/man/pop_m_mat_five.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{pop_m_mat_five} +\alias{pop_m_mat_five} +\title{Population matrix for males five year age groups between 1950 and 2050} +\format{ +A matrix of dimensions 21 x 21 +} +\source{ +Migration residual PAS spreadhseet +} +\usage{ +pop_m_mat_five +} +\description{ +Population matrix for males five year age groups between 1950 and 2050 for +unknown country +} +\keyword{datasets} diff --git a/man/pop_m_mat_single.Rd b/man/pop_m_mat_single.Rd new file mode 100644 index 000000000..f9d0d9e4e --- /dev/null +++ b/man/pop_m_mat_single.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{pop_m_mat_single} +\alias{pop_m_mat_single} +\title{Population matrix for males single ages between 1999 and 2019} +\format{ +A matrix of dimensions 101 x 21 +} +\source{ +Migration residual PAS spreadhseet +} +\usage{ +pop_m_mat_single +} +\description{ +Population matrix for males single ages between 1999 and 2019 for +Sweden +} +\keyword{datasets} diff --git a/man/rescaleAgeGroups.Rd b/man/rescaleAgeGroups.Rd index 890a3185a..3bf3352c0 100644 --- a/man/rescaleAgeGroups.Rd +++ b/man/rescaleAgeGroups.Rd @@ -9,7 +9,7 @@ rescaleAgeGroups( AgeInt1, Value2, AgeInt2, - splitfun = c(graduate_uniform, graduate_mono), + splitfun = graduate_uniform, recursive = FALSE, tol = 0.001 ) @@ -23,11 +23,11 @@ rescaleAgeGroups( \item{AgeInt2}{integer vector. Age interval widths for population 2.} -\item{splitfun}{function to use for splitting \code{pop1}. Presently on \code{graduate_uniform()} works.} +\item{splitfun}{function to use for splitting \code{Value1}. Reasonable (and tested) choices are either \code{graduate_uniform} or \code{graduate_mono}.} \item{recursive}{logical. Shall we repeat the split/regroup/rescale process until stable? See details. Default \code{FALSE}.} -\item{tol}{numeric. Default 1e-3. The numerical tolerance for the residual. Used to detect stability if \code{recursive = TRUE}.} +\item{tol}{numeric. Default \code{1e-3}. The numerical tolerance for the residual. Used to detect stability if \code{recursive = TRUE}.} } \description{ This method rescales a vector of counts in arbitrary (integer) age groups to approximate a vector of counts in a potentially different age grouping. Common use cases will be to scale single ages (whose age pattern we wish to roughly maintain) to sum to abridged or 5-year age groups from another source. The counts to be rescaled could potentially be in any grouping (see example). diff --git a/man/shift_census_ages_to_cohorts.Rd b/man/shift_census_ages_to_cohorts.Rd new file mode 100644 index 000000000..75efbf1bf --- /dev/null +++ b/man/shift_census_ages_to_cohorts.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/interp_coh.R +\name{shift_census_ages_to_cohorts} +\alias{shift_census_ages_to_cohorts} +\title{shift census populations to match single year cohorts} +\usage{ +shift_census_ages_to_cohorts( + pop, + age, + date, + censusYearOpt = "frac", + OAG = TRUE +) +} +\arguments{ +\item{pop}{numeric vector. Population counts in age groups, presumably from a census with an exact reference date.} + +\item{age}{integer vector. Lower bound of single age groups} + +\item{date}{Either a \code{Date} class object or an unambiguous character string in the format \code{"YYYY-MM-DD"}.} + +\item{censusYearOpt}{character or \code{NA}. Options include: +\itemize{ +\item \code{"frac"} keep the partial cohort observed in the year of the census. +\item \code{"drop"} remove the partial cohort from the census year (and trim other outputs to match) +\item \code{"extrap"} inflate the partial cohort from the census year. Specifically we keep it the same as the input age 0. +\item \code{NA} return \code{NA} for the census year cohort size. +}} + +\item{OAG}{logical. Is the highest age group an open age? If \code{TRUE}} +} +\description{ +Matches the (single) ages of a census to single cohorts. For use in intercensal interpolations. Ages are potentially blended to match single cohort line assuming that the population in each age is uniformly distributed over the age group. +} +\examples{ +pop <- seq(10000,100,length.out = 101) +age <- 0:100 +d1 <- "2020-01-01" +d2 <- "2020-07-01" +d3 <- "2020-12-21" + +shift_census_ages_to_cohorts(pop, age, d1) +shift_census_ages_to_cohorts(pop, age, d2) +shift_census_ages_to_cohorts(pop, age, d3) +shift_census_ages_to_cohorts(pop, age, 2020.5) +} diff --git a/man/smooth_age_5.Rd b/man/smooth_age_5.Rd index 59e401326..a249b1e02 100644 --- a/man/smooth_age_5.Rd +++ b/man/smooth_age_5.Rd @@ -13,7 +13,7 @@ smooth_age_5( ageMin = 10, ageMax = 65, n = 3, - young.tail = c("Original", "Arriaga", "Strong", NA), + young.tail = c("Original", "Arriaga", "Strong", "Cascade", NA), old.tail = young.tail ) } @@ -22,7 +22,7 @@ smooth_age_5( \item{Age}{integer vector of ages corresponding to the lower integer bound of the counts.} -\item{method}{character string. Options include \code{"Carrier-Farrag"},\code{"Arriaga"},\code{"KKN"},\code{"United Nations"}, \code{"Strong"}, and \code{"Zigzag"}. See details. Default \code{"Carrier-Farrag"}.} +\item{method}{character string. Options include \code{"Carrier-Farrag"},\code{"Arriaga"},\code{"KKN"},\code{"United Nations"}, \code{"Strong"}, \code{MAV} and \code{"Zigzag"}. See details. Default \code{"Carrier-Farrag"}.} \item{OAG}{logical. Whether or not the top age group is open. Default \code{TRUE}.} @@ -41,7 +41,7 @@ numeric vector of smoothed counts in 5-year age groups. } \description{ Smooth population counts in 5-year age groups using the Carrier-Farrag, -Karup-King-Newton, Arriaga, United Nations, Stong, or Zigzag methods. Allows for imputation +Karup-King-Newton, Arriaga, United Nations, Strong, MAV or Zigzag methods. Allows for imputation of values in the youngest and oldest age groups for the Carrier-Farrag, Karup-King-Newton, and United Nations methods. } @@ -54,8 +54,8 @@ operate based on 10-year age group totals, excluding the open age group. The Carrier-Farrag, Karup-King-Newton, and United Nations methods do not produce estimates for the first and final 10-year age groups. By default, these are imputed with the original 5-year age group totals, but -you can also specify to impute with \code{NA}, or the results of the Arriaga or -Strong methods. If the terminal digit of the open age group is 5, then the terminal 10-year +you can also specify to impute with \code{NA}, or the results of the Arriaga, +Strong and Cascade methods. If the terminal digit of the open age group is 5, then the terminal 10-year age group shifts down, so imputations may affect more ages in this case. Imputation can follow different methods for young and old ages. diff --git a/man/smooth_age_5_mav.Rd b/man/smooth_age_5_mav.Rd index 42f1094f1..81017efc9 100644 --- a/man/smooth_age_5_mav.Rd +++ b/man/smooth_age_5_mav.Rd @@ -4,7 +4,7 @@ \alias{smooth_age_5_mav} \title{Smooth in 5-year age groups using a moving average} \usage{ -smooth_age_5_mav(Value, Age, OAG = TRUE, n = 3) +smooth_age_5_mav(Value, Age, OAG = TRUE, n = 3, tails = FALSE) } \arguments{ \item{Value}{numeric vector of (presumably) counts in 5-year age groups.} @@ -14,6 +14,9 @@ smooth_age_5_mav(Value, Age, OAG = TRUE, n = 3) \item{OAG}{logical. Whether or not the top age group is open. Default \code{TRUE}.} \item{n}{integer. The width of the moving average. Default 3 intervals (x-5 to x+9).} + +\item{tails}{loglcal. If tails is \code{FALSE}, both tails are left untouched. +Otherwise, the tails are filled out using a cascade method.} } \value{ numeric vector of smoothed counts in 5-year age groups. @@ -24,7 +27,10 @@ Smooth data in 5-year age groups. \details{ This function calls \code{smooth_age_5_zigzag_inner()}, but prepares data in a way consistent with other methods called by \code{smooth_age_5()}. It is probably preferable to call \code{zigzag()} from the top level, or else call this method from \code{agesmth()} for more control over tail imputations. -This function calls \code{mav()}, which itself relies on the more general \code{ma()}. We lose the lowest and highest ages with this method, unless \code{n=1}, in which case data is returned in the original 5-year age groups. The total population count is not constrained to sum to the orignal total. +If tails is set to \code{FALSE}, this function calls \code{mav()}, which itself relies on the more general \code{ma()}. We lose the lowest and highest ages with this method, unless \code{n=1}, in which case data is returned in the original 5-year age groups. The total population count is not constrained to sum to the orignal total. + +If tails is \code{TRUE}, the same results are expected but the tails are +filled in using a cascading method. } \examples{ Age <- c(0,1,seq(5,90,by=5)) diff --git a/man/sr_f_mat_five.Rd b/man/sr_f_mat_five.Rd new file mode 100644 index 000000000..1fe523133 --- /dev/null +++ b/man/sr_f_mat_five.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{sr_f_mat_five} +\alias{sr_f_mat_five} +\title{Survival rates matrix for females five year age groups between 1950 and 2045} +\format{ +A matrix of dimensions 21 x 20 +} +\source{ +Migration residual PAS spreadhseet +} +\usage{ +sr_f_mat_five +} +\description{ +Survival rates matrix for females five year age groups between 1950 and 2045 +for unknown country +} +\keyword{datasets} diff --git a/man/sr_f_mat_single.Rd b/man/sr_f_mat_single.Rd new file mode 100644 index 000000000..2b11cb431 --- /dev/null +++ b/man/sr_f_mat_single.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{sr_f_mat_single} +\alias{sr_f_mat_single} +\title{Survival rates matrix for females single ages between 1999 and 2019} +\format{ +A matrix of dimensions 101 x 20 +} +\source{ +Migration residual PAS spreadhseet +} +\usage{ +sr_f_mat_single +} +\description{ +Survival rates matrix for females single ages between 1999 and 2019 for +Sweden +} +\keyword{datasets} diff --git a/man/sr_m_mat_five.Rd b/man/sr_m_mat_five.Rd new file mode 100644 index 000000000..1d70cae7f --- /dev/null +++ b/man/sr_m_mat_five.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{sr_m_mat_five} +\alias{sr_m_mat_five} +\title{Survival rates matrix for males five year age groups between 1950 and 2045} +\format{ +A matrix of dimensions 21 x 20 +} +\source{ +Migration residual PAS spreadhseet +} +\usage{ +sr_m_mat_five +} +\description{ +Survival rates matrix for males five year age groups between 1950 and 2045 +for unknown country +} +\keyword{datasets} diff --git a/man/sr_m_mat_single.Rd b/man/sr_m_mat_single.Rd new file mode 100644 index 000000000..7ae3b16e7 --- /dev/null +++ b/man/sr_m_mat_single.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{sr_m_mat_single} +\alias{sr_m_mat_single} +\title{Survival rates matrix for males single ages between 1999 and 2019} +\format{ +A matrix of dimensions 101 x 20 +} +\source{ +Migration residual PAS spreadhseet +} +\usage{ +sr_m_mat_single +} +\description{ +Survival rates matrix for males single ages between 1999 and 2019 for +Sweden +} +\keyword{datasets} diff --git a/man/srb_vec_five.Rd b/man/srb_vec_five.Rd new file mode 100644 index 000000000..fb24db727 --- /dev/null +++ b/man/srb_vec_five.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{srb_vec_five} +\alias{srb_vec_five} +\title{Sex ratio at birth between 1950 and 2045} +\format{ +A vector of length 20 +} +\source{ +Migration residual PAS spreadhseet +} +\usage{ +srb_vec_five +} +\description{ +Sex ratio at birth between 1950 and 2045 for unknown country +} +\keyword{datasets} diff --git a/man/srb_vec_single.Rd b/man/srb_vec_single.Rd new file mode 100644 index 000000000..43d246020 --- /dev/null +++ b/man/srb_vec_single.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{srb_vec_single} +\alias{srb_vec_single} +\title{Sex ratio at birth between 1999 and 2019} +\format{ +A vector of length 20 +} +\source{ +Migration residual PAS spreadhseet +} +\usage{ +srb_vec_single +} +\description{ +Sex ratio at birth between 1999 and 2019 for Sweden +} +\keyword{datasets} diff --git a/tests/testthat.R b/tests/testthat.R index a53ba3800..2a8bb21d2 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -9,5 +9,4 @@ shhh(library(testthat)) shhh(library(DemoTools)) shhh(library(magrittr)) shhh(library(dplyr)) - test_check("DemoTools") diff --git a/tests/testthat/test-OPAG.R b/tests/testthat/test-OPAG.R new file mode 100644 index 000000000..c41a5ed47 --- /dev/null +++ b/tests/testthat/test-OPAG.R @@ -0,0 +1,348 @@ +# TODO +# -[x ] check for success in a few different input scenarios +# -[ x] check sums match between input and output +# -[ x] check output of proper length +# -[x ] check for console output when informative warnings should be generated +# - [ x] if age intervals are different, we should send a console message using cat("\n") +# - [ x] 1) the function should work fine still. +# - [x ] 2) capture console output and make sure as expected. (examples in test-basepop) +# - [ x] 3) if estimated r is on the boundary (-.05, .05) we should warn to console. +# -[x] expect error if OAnew > max(Age_nLx) +# -[ ] expect errors in other reasonable situations +# - [ x] if OA is 80+ and standard starts at age 40, it should still work! +# - [ x] if OAnew > max(Age_nLx) that's an error. +# +# -[x] canonical test: if the census is actually a stationary population, identical to nLx itself, then we hope to return something proportional to it. + +# -[ ] canonical test: if input census is an exact stable pop (use auxiliary function OPAG_nLx_warp_r) +# forget this one for time being +############################################################################### + + + +context("test-OPAG") +# pop sweden 2000 +pop_swe <- c(88367.00, 89890.00, 91008.00, 95773.00, 103678.00, +112627.00, 117695.00, 123777.00, 126366.00, 127545.00, +120657.00, 117454.00, 110691.00, 108696.00, 105477.00, +101220.00, 99075.00, 100090.00, 100684.00, 103623.00, +102193.00, 99242.00, 102375.00, 105360.00, 111201.00, +117816.00, 117423.00, 120121.00, 121586.00, 118213.00, +117669.00, 124087.00, 131642.00, 133692.00, 134292.00, +134758.00, 125367.00, 120009.00, 116535.00, 114949.00, +116379.00, 116192.00, 117963.00, 118680.00, 117149.00, +114963.00, 118060.00, 117424.00, 116446.00, 121530.00, +126177.00, 130623.00, 131833.00, 133485.00, 132313.00, +130098.00, 121803.00, 111254.00, 98568.00, 93645.00, +94070.00, 89995.00, 85443.00, 82849.00, 79006.00, +76534.00, 74682.00, 76992.00, 76164.00, 76840.00, +73736.00, 75105.00, 72258.00, 72409.00, 72466.00, +71159.00, 70307.00, 67816.00, 69750.00, 69855.00, +54218.00, 50316.00, 47688.00, 43035.00, 38938.00, +36031.21, 31859.38, 27876.99, 23447.49, 19537.57, +16325.19, 12829.43, 9890.83, 7421.46, 5308.28, +3849.87, 2690.06, 1762.22, 1119.00, 673.00, +386.00, 227.00, 127.00, 79.00, 43.00, +12.00, 10.00, 3.00, 4.00, 0.00, +2.00) + + +pop_swe50_110 <- pop_swe[51:111] +pop_85 <- c(pop_swe[1:85], sum(pop_swe[86:111])) +pop_check <- pop_swe +names_pop_check <- as.character(c(0:110)) +names(pop_check)<- names_pop_check + +# data -------------------------------------------------------------------- +Pop <- pop_85 +Age <- c(0:85) +OAnow <- max(Age) +StPop <- pop_swe50_110 +StAge <- c(50:110) +OAnew <- max(StAge) + + +# Insert data to be compared + +test_that("OPAG_simple works", { + OPAG_res <- OPAG_simple( + Pop = Pop, + Age = Age, + OAnow = max(Age), + StPop = StPop, + StAge = StAge, + OAnew = max(StAge) + ) + expect_equal(OPAG_res, + pop_check, # think about the type of data would return and make equal + tolerance = 0.00001 + )} + ) + + +# test sum + +test_that("OPAG_simple's sum of input and output are equal", { + OPAG_res <- OPAG_simple( + Pop = Pop, + Age = Age, + OAnow = max(Age), + StPop = StPop, + StAge = StAge, + OAnew = max(StAge) + ) + expect_equal(sum(OPAG_res), + sum(pop_check), # think about the type of data would return and make equal + tolerance = 0.00001 + )} +) + +#length + +test_that("OPAG_simple's output has a proper length", { + OPAG_res <- OPAG_simple( + Pop = Pop, + Age = Age, + OAnow = max(Age), + StPop = StPop, + StAge = StAge, + OAnew = max(StAge) + ) + expect_equal(length(OPAG_res), + length(pop_check), # think about the type of data would return and make equal + tolerance = 0.00001 + )} +) + +## testing warnings +# -[ ] check for console output when informative warnings should be generated + +test_that("OAnew > max(Age_nLx) error", { + expect_error(OPAG_simple( + Pop = Pop, + Age = Age, + OAnow = max(Age), + StPop = StPop, + StAge = StAge, + OAnew = max(StAge) + 5 + )) +}) + +test_that("length(Pop) == length(Age) error", { + expect_error(OPAG_simple( + Pop = pop_swe, + Age = Age, + OAnow = max(Age), + StPop = StPop, + StAge = StAge, + OAnew = max(StAge) + )) +}) + +## Stationary population --------------------------------------- +## Data + +Lx <- c(0.997206968803419, 3.98651416246245, 4.98081195476269, + 4.97832219202643, 4.97409262747162, 4.96800317067612, 4.96130094726659, + 4.95324568198643, 4.9414967090444, 4.92251152310738, 4.89050587164337, + 4.83787412607811, 4.75471527967275, 4.62736885461426, 4.43325496677287, + 4.13111130068528, 3.65288437783847, 2.9050982849507, 1.88475330956745, + 0.865610023545313, 0.237771057845129, 0.0331623958830273) + +r <-0 +age_Lx <- c(0,1,seq(5,100,by=5)) +names(Lx) <- age_Lx + +test_that("OPAG_nLx_warp_r works", { + res_stationary <- OPAG_nLx_warp_r( + nLx = c(Lx), + Age = age_Lx, + r = r, + continuous = TRUE, + method = "uniform" + ) + c_St <- res_stationary/sum(res_stationary) + c_Lx <- c(Lx/sum(Lx)) + + res <- (c_St - c_Lx) %>% abs() %>% max() + expect_true(res < 0.0001) + } +) + + +# Pop_fit was generated this way +# Pop_fit <- OPAG_nLx_warp_r( +# nLx = c(Lx), +# Age = age_Lx, +# r = 0.01, +# continuous = TRUE, +# method = "uniform" +# ) + + + + +# test_that("OPAG_fit_stable_standard works", { +# # OPAG_nLx_warp_r( +# # nLx = c(Lx), +# # Age = age_Lx, +# # r = 0.01, +# # continuous = TRUE, +# # method = "uniform" +# # ) +# +# PopCheckStable <- c(0.0178828625366182, 0.0697292229670445, +# 0.0832903513014252, 0.0791886290502868, 0.075262556870, +# 0.0715043132981018, 0.0679252465454812, 0.064507587072, +# 0.0612159669721477, 0.0580067082482588, 0.054818928190, +# 0.0515841876671949, 0.0482249540993725, 0.044644370355, +# 0.0406855853175052, 0.0360636791712615, 0.03033362662, +# 0.0229474544613544, 0.0141616376235189, 0.0061868062463, +# 0.00161654762698326, 0.000218777749686752) +# names(PopCheckStable) <- age_Lx +# Pop_in <- PopCheckStable[1:18] +# Pop_in[18] <- sum(PopCheckStable[18:22]) +# Pop_in <- Pop_in * 5e5 +# Age_Pop_in <- names2age(Pop_in) +# +# AgeInt_in <- inferAgeIntAbr(Age_Pop_in, OAG = TRUE, OAvalue = 1) +# AgeInt_nLx <- inferAgeIntAbr(age_Lx, OAG = TRUE, OAvalue = 1) +# +# +# Pop_fit <- OPAG(Pop_in, +# Age_Pop = Age_Pop_in, +# AgeInt_Pop = AgeInt_in, +# nLx = nLx, +# Age_nLx = age_Lx, +# AgeInt_nLx = AgeInt_nLx, +# Age_fit = c(50,60,70), +# AgeInt_fit = c(10,10,10), +# Redistribute_from = 80, +# continuous = TRUE, +# method = "uniform") +# PopSt_Out <- rescale_vector(Pop_fit$Pop_out) +# expect_equal( +# PopSt_Out, +# PopCheckStable, +# tolerance = 0.0001) +# }) + +# India Males, 1991 +Pop <- smooth_age_5(pop1m_ind, + Age = 0:100, + method = "Arriaga") +Age_Pop <- names2age(Pop) +AgeInt_Pop <- age2int(Age_Pop, OAvalue = 1) + +nLx <- downloadnLx(NULL, "India","male",1991) +Age_nLx <- names2age(nLx) +AgeInt_nLx <- age2int(Age_nLx, OAvalue = 1) + +test_that("OAnew checks enforced", { + +expect_error(Pop_fit <- OPAG(Pop, + Age_Pop = Age_Pop, + AgeInt_Pop = AgeInt_Pop, + nLx = nLx, + Age_nLx = Age_nLx, + AgeInt_nLx, + Age_fit = c(60,70), + AgeInt_fit = c(10,10), + Redistribute_from = 80, + OAnew = 120)) +}) + +## Checking warnings +test_that("Age intervals of standard population and population still works even if they are different", { + + + + + expect_output(OPAG(Pop, + Age_Pop = Age_Pop, + AgeInt_Pop = AgeInt_Pop, + nLx = nLx, + Age_nLx = Age_nLx, + AgeInt_nLx, + Age_fit = c(60,70), + AgeInt_fit = c(10,10), + Redistribute_from = 80, + OAnew = max(Age_nLx)), regexp = "\nAge_Pop and Age_nLx age intervals are different!") +}) + + +test_that("Check if r returned is between -0.5 and 0.5", { + + output <- + OPAG(Pop, + Age_Pop = Age_Pop, + AgeInt_Pop = AgeInt_Pop, + nLx = nLx, + Age_nLx = Age_nLx, + AgeInt_nLx, + Age_fit = c(60,70), + AgeInt_fit = c(10,10), + Redistribute_from = 80, + OAnew = max(Age_nLx)) + + + expect_true(output$r_opt$minimum >= -0.5 & output$r_opt$minimum <= 0.5) +}) + + + +# test_that("basepop raises error when downloads needed but no location is specified", { +# +# expect_error( +# basepop_five( +# refDate = refDate, +# Females_five = pop_female_counts, +# Males_five = pop_male_counts, +# verbose = FALSE +# ), +# "You need to provide a location to download the data for nLx" +# ) +# +# +# expect_error( +# basepop_five( +# refDate = refDate, +# AsfrMat = AsfrMat, +# Females_five = pop_female_counts, +# Males_five = pop_male_counts, +# radix = 1, +# verbose = FALSE +# ), +# "You need to provide a location to download the data for nLx" +# ) +# +# expect_error( +# basepop_five( +# refDate = refDate, +# nLxFemale = nLxFemale, +# nLxMale = nLxMale, +# Females_five = pop_female_counts, +# Males_five = pop_male_counts, +# radix = 1, +# verbose = FALSE +# ), +# "You need to provide a location to download the data for Asfrmat" +# ) +# # If provided all correct arguments, it download the data +# # successfully +# expect_success({ +# res <- +# basepop_five( +# location = "Spain", +# refDate = refDate, +# AsfrMat = AsfrMat, +# Females_five = pop_female_counts, +# Males_five = pop_male_counts, +# radix = 1, +# verbose = FALSE +# ) +# +# expect_type(res$Females_adjusted, "double") +# }) +# +# }) \ No newline at end of file diff --git a/tests/testthat/test-basepop.R b/tests/testthat/test-basepop.R index 19f88fb0b..fc3d7bc3e 100644 --- a/tests/testthat/test-basepop.R +++ b/tests/testthat/test-basepop.R @@ -33,7 +33,7 @@ nLxMale <- matrix(c(87732, # includes age 10 patch nLxFemale <- matrix(c(89842,314521,372681,666666,353053,340650,326588,311481, 295396,278646,261260,241395,217419,90478,320755, - 382531,666666,364776, 353538,340687, 326701, 311573, + 382531,666666,364776, 353538,340687, 326701, 311573, 295501, 278494, 258748,234587), nrow = 13, ncol = 2) @@ -41,8 +41,8 @@ rownames(nLxFemale) <- c(0,1,seq(5,55,by=5)) # (7) A set of age-specific fertility rates pertaining to an earlier and later # date -AsfrMat <- matrix(c(0.2000,0.3000,0.3000, 0.2500, 0.2000, - 0.1500, 0.0500,0.1500,0.2000,0.2750, +AsfrMat <- matrix(c(0.2000,0.3000,0.3000, 0.2500, 0.2000, + 0.1500, 0.0500,0.1500,0.2000,0.2750, 0.2250, 0.1750, 0.1250, 0.0500), nrow = 7, ncol = 2) @@ -118,7 +118,7 @@ test_that("basepop_five - bpe matches the expected result from PASS", { # test_that("basepop_single fails if provided five year age groups", { -# +# # female_single <- # c( # `0` = 11673, @@ -203,7 +203,7 @@ test_that("basepop_five - bpe matches the expected result from PASS", { # `79` = 247, # `80` = 4143 # ) -# +# # # Correction for males # # To test that males are checked for single ages, we first # # correctly define the female pop counts as single ages @@ -224,7 +224,7 @@ test_that("basepop_five - bpe matches the expected result from PASS", { # "is_single(as.numeric(names(Males_single))) is not TRUE", # fixed = TRUE # ) -# +# # # check that pop male counts are named # expect_error( # basepop_single( @@ -243,7 +243,7 @@ test_that("basepop_five - bpe matches the expected result from PASS", { # "!is.null(names(Males_single)) is not TRUE", # fixed = TRUE # ) -# +# # # Check female counts are single ages # expect_error( # basepop_single( @@ -260,7 +260,7 @@ test_that("basepop_five - bpe matches the expected result from PASS", { # "is_single(as.numeric(names(Females_single))) is not TRUE", # fixed = TRUE # ) -# +# # # Check that pop female counts are named # expect_error( # basepop_single( @@ -277,7 +277,7 @@ test_that("basepop_five - bpe matches the expected result from PASS", { # "!is.null(names(Females_single)) is not TRUE", # fixed = TRUE # ) -# +# # # Works as well for smoothing # expect_error( # basepop_single( @@ -344,7 +344,7 @@ smoothed_females <- smooth_age_5(Value = pop_female_counts, young.tail = "Original") # test_that("basepop_single does calculation for males when providing Males_single", { -# +# # # Since the default is for females, I saved the correct calculations for males # # and just check that the current implementation matches it # res <- @@ -362,7 +362,7 @@ smoothed_females <- smooth_age_5(Value = pop_female_counts, # method = "linear", # radix = 100000 # ) -# +# # correct_res_males <- # c( # `0` = 13315, @@ -376,17 +376,17 @@ smoothed_females <- smooth_age_5(Value = pop_female_counts, # `8` = 11019, # `9` = 11319 # ) -# +# # expect_equivalent(round(res[1:10], 0), correct_res_males) # }) refDate <- 1986 -country <- "Spain" -res <- fertestr::FetchPopWpp2019(country, refDate, ages = 0:100, sex = "female") +location <- "Spain" +res <- fertestr::FetchPopWpp2019(location, refDate, ages = 0:100, sex = "female") pop_female_counts <- single2abridged(setNames(res$pop, res$ages)) -res <- fertestr::FetchPopWpp2019(country, refDate, ages = 0:100, sex = "male") +res <- fertestr::FetchPopWpp2019(location, refDate, ages = 0:100, sex = "male") pop_male_counts <- single2abridged(setNames(res$pop, res$ages)) # Download asfr matrix to test that it can download the nLx only @@ -395,7 +395,7 @@ invisible( nLxFemale <- downloadnLx( NULL, - country, + location, gender = "female", c(1978, 1985.5) ) @@ -403,7 +403,7 @@ invisible( ) # Download asfr matrix to test that it can download the nLx only -invisible(capture.output(AsfrMat <- downloadAsfr(NULL, country, c(1978, 1985.5)))) +invisible(capture.output(AsfrMat <- downloadAsfr(NULL, location, c(1978, 1985.5)))) test_that("basepop_five can download data for nLx", { @@ -411,7 +411,7 @@ test_that("basepop_five can download data for nLx", { output <- capture.output( basepop_five( - country = country, + location = location, refDate = refDate, Females_five = pop_female_counts, Males_five = pop_male_counts, @@ -433,7 +433,7 @@ test_that("basepop_five can download data for asfr", { output <- capture.output( basepop_five( - country = country, + location = location, refDate = refDate, nLxFemale = nLxFemale, nLxMale = nLxMale, @@ -454,7 +454,7 @@ test_that("basepop_five can download data for asfr", { # output <- # capture.output( # basepop_five( - # country = country, + # location = location, # refDate = refDate, # nLxFemale = nLxFemale, # Females_five = pop_female_counts, @@ -462,7 +462,7 @@ test_that("basepop_five can download data for asfr", { # female = TRUE # ) # ) - # + # # expect_false(any(grepl("^Downloading nLx", output))) }) @@ -471,7 +471,7 @@ test_that("basepop_five infers radix if not provided", { output <- capture.output( basepop_five( - country = country, + location = location, refDate = refDate, nLxFemale = nLxFemale, nLxMale = nLxMale, @@ -483,7 +483,7 @@ test_that("basepop_five infers radix if not provided", { expect_true(sum(grepl("^Setting radix", output)) == 1) }) -test_that("basepop raises error when downloads needed but no country is specified", { +test_that("basepop raises error when downloads needed but no location is specified", { expect_error( basepop_five( @@ -492,7 +492,7 @@ test_that("basepop raises error when downloads needed but no country is specifie Males_five = pop_male_counts, verbose = FALSE ), - "You need to provide a country to download the data for nLx" + "You need to provide a location to download the data for nLx" ) @@ -505,7 +505,7 @@ test_that("basepop raises error when downloads needed but no country is specifie radix = 1, verbose = FALSE ), - "You need to provide a country to download the data for nLx" + "You need to provide a location to download the data for nLx" ) expect_error( @@ -518,7 +518,7 @@ test_that("basepop raises error when downloads needed but no country is specifie radix = 1, verbose = FALSE ), - "You need to provide a country to download the data for Asfrmat" + "You need to provide a location to download the data for Asfrmat" ) # If provided all correct arguments, it download the data @@ -526,7 +526,7 @@ test_that("basepop raises error when downloads needed but no country is specifie expect_success({ res <- basepop_five( - country = "Spain", + location = "Spain", refDate = refDate, AsfrMat = AsfrMat, Females_five = pop_female_counts, @@ -545,7 +545,7 @@ test_that("basepop_five can download from dates provided", { output <- capture.output( basepop_five( - country = country, + location = location, refDate = refDate, nLxDatesIn = c(1978, 1986.5), AsfrDatesIn = c(1978, 1985.5), @@ -561,7 +561,7 @@ test_that("basepop_five can download from dates provided", { output <- capture.output( basepop_five( - country = country, + location = location, refDate = refDate, nLxDatesIn = c(1978, 1986.5), Females_five = pop_female_counts, @@ -575,7 +575,7 @@ test_that("basepop_five can download from dates provided", { output <- capture.output( basepop_five( - country = country, + location = location, refDate = refDate, Females_five = pop_female_counts, Males_five = pop_male_counts @@ -586,40 +586,288 @@ test_that("basepop_five can download from dates provided", { expect_true(sum(grepl("^Assuming the two", output)) == 2) }) +test_that("basepop works with up to year 1955", { + + # This is where the test actually happens since + # internally we subtract 7.5 from the refDate to download + # the nLx and Asfr data. So the minimum year will be 1955. + res <- + basepop_five( + location = "Spain", + refDate= 1962.5, + Males_five = smoothed_males, + Females_five = smoothed_females, + SRB = sex_ratio, + method = "linear", + radix = 100000 + ) + + expect_true("1955" %in% colnames(res$Asfr)) + expect_true("1955" %in% colnames(res$nLxm)) + expect_true("1955" %in% colnames(res$nLxf)) + +}) + +test_that("basepop works well with SRBDatesIn", { + # Most of the tests for SRBDatesIn are actually done when + # testing downloadSRB. These tests just make sure that + # basepop can handle NULL/Non-NULL SRBDatesIn dates. Everything + # else is forward to downloadSRB. + + # Works when SRBDatesIn is NULL, meaning that it convert them + # to refDate - c(0.5, 2.5, 7.5) + + expect_success({ + res <- + basepop_five( + location = "Spain", + refDate= 1962.5, + Males_five = smoothed_males, + Females_five = smoothed_females, + SRB = sex_ratio, + SRBDatesIn = NULL, + method = "linear", + radix = 100000 + ) + + expect_type(res, "list") + }) + + # Works when SRBDatesIn is an actual date. + expect_success({ + res <- + basepop_five( + location = "Spain", + refDate= 1962.5, + Males_five = smoothed_males, + Females_five = smoothed_females, + SRB = sex_ratio, + SRBDatesIn = 1960, + method = "linear", + radix = 100000 + ) + + expect_type(res, "list") + }) + +}) -# TR: deprecated. now always for both sexes -# test_that("basepop_five only estimates male counts when female = FALSE", { +# IW: no need capping at 1955 +# test_that("basepop caps nLxDatesIn to 1955 when provided a date below that", { # -# female <- +# tmp_nlx <- c(1954, 1960) +# expect_output( +# tmp <- # basepop_five( -# country = country, -# refDate = refDate, -# Females_five = pop_female_counts, -# verbose = FALSE -# ) -# -# male1 <- -# basepop_five( -# country = country, -# refDate = refDate, -# Females_five = pop_female_counts, -# Males_five = pop_male_counts, -# verbose = FALSE -# ) -# -# # Even if male1 specifies the male vector, `female = FALSE` -# # hasn't been set -# expect_true(all(female == male1)) +# location = "Spain", +# refDate = 1960, +# Males_five = smoothed_males, +# Females_five = smoothed_females, +# SRB = sex_ratio, +# nLxDatesIn = tmp_nlx, +# AsfrDatesIn = c(1955, 1960), +# method = "linear", +# radix = 100000 +# ), +# regexp = "nLxDate\\(s\\) 1954 is/are below 1955\\. Capping at 1955", +# all = FALSE +# ) # -# male2 <- -# basepop_five( -# country = country, -# refDate = refDate, -# Females_five = pop_female_counts, -# Males_five = pop_male_counts, -# female = FALSE, -# verbose = FALSE -# ) +# tmp_asfr <- c(1954, 1960) +# expect_output( +# tmp <- +# basepop_five( +# location = "Spain", +# refDate = 1960, +# Males_five = smoothed_males, +# Females_five = smoothed_females, +# SRB = sex_ratio, +# nLxDatesIn = c(1955, 1960), +# AsfrDatesIn = tmp_asfr, +# method = "linear", +# radix = 100000 +# ), +# regexp = "AsfrDate\\(s\\) 1954 is/are below 1955\\. Capping at 1955", +# all = FALSE +# ) # -# expect_true(all(female != male2)) # }) + +test_that("basepop fails when it implies an extrapolation of > 5 years", { + + ## For nLxDatesIn ## + + ## By setting refDate to 1974, the difference between 1974 - 7.5 and the + ## minimum of nLxDatesIn is greater than five. + + expect_error( + basepop_five( + refDate = 1974, + Males_five = smoothed_males, + Females_five = smoothed_females, + SRB = sex_ratio, + nLxFemale = nLxFemale, + nLxMale = nLxMale, + nLxDatesIn = nLxDatesIn, + AsfrMat = AsfrMat, + AsfrDatesIn = AsfrDatesIn, + radix = 100000 + ), + regexp = "nLxDatesIn implies an extrapolation of > 5 years to achieve the needed reference dates", + fixed = TRUE + ) + + ## By setting refDate to 1995, the difference between 1995 - 0.5 and the + ## maximum of nLxDatesIn is greater than five. + + expect_error( + basepop_five( + refDate = 1995, + Males_five = smoothed_males, + Females_five = smoothed_females, + SRB = sex_ratio, + nLxFemale = nLxFemale, + nLxMale = nLxMale, + nLxDatesIn = nLxDatesIn, + AsfrMat = AsfrMat, + AsfrDatesIn = AsfrDatesIn, + radix = 100000 + ), + regexp = "nLxDatesIn implies an extrapolation of > 5 years to achieve the needed reference dates", + fixed = TRUE + ) + + ## For AsfrDatesIn + ## Here we just provide AsfrDatesIn which we are much higher than refDate - 7.5 + expect_error( + basepop_five( + refDate = 1986, + Males_five = smoothed_males, + Females_five = smoothed_females, + SRB = sex_ratio, + nLxFemale = nLxFemale, + nLxMale = nLxMale, + nLxDatesIn = nLxDatesIn, + AsfrMat = AsfrMat, + AsfrDatesIn = c(1925, 1930), + radix = 100000 + ), + regexp = "AsfrDatesIn implies an extrapolation of > 5 years to achieve the needed reference dates", + fixed = TRUE + ) + + ## Here we just provide AsfrDatesIn which we are much higher than refDate - 0.5 + expect_error( + basepop_five( + refDate = 1986, + Males_five = smoothed_males, + Females_five = smoothed_females, + SRB = sex_ratio, + nLxFemale = nLxFemale, + nLxMale = nLxMale, + nLxDatesIn = nLxDatesIn, + AsfrMat = AsfrMat, + AsfrDatesIn = c(2020, 2025), + radix = 100000 + ), + regexp = "AsfrDatesIn implies an extrapolation of > 5 years to achieve the needed reference dates", + fixed = TRUE + ) + +}) + +srb_checker <- function(x, ordered_name = FALSE) { + expect_length(x, 3) + expect_named(x) + expect_type(x, "double") + + # Check the names of x are returned ordered + # This only makes sense when we download the data from WPP because + # otherwise we respect the order provided by the user. + if (ordered_name) { + expect_true(all(names(x) == as.character(sort(as.numeric(names(x)))))) + } +} + +test_that("downloadSRB works as expected", { + # Should return same estimate three times + srb_checker(downloadSRB(c(1.05), DatesOut = c(1999, 1920, 1930))) + + # Should return three values with the last being 1.05 + srb_checker(downloadSRB(c(1.05, 1.07), DatesOut = c(1999, 1920, 1930))) + + # Should return the same thing + srb_checker(downloadSRB(c(1.05, 1.07, 1.08), DatesOut = c(1999, 1920, 1930))) + + # Should error + expect_error( + downloadSRB(1:4), + regexp = "SRB can only accept three dates at maximum", + fixed = TRUE + ) + + # Should return three SRBs + srb_checker(downloadSRB(SRB = NULL, location = "Spain", DatesOut = 1955:1957)) + + # Assumes SRB + outp <- capture_output_lines( + downloadSRB(SRB = NULL, + location = "Whatever", + DatesOut = 1955:1957) + ) + + expect_true(all( + c("Whatever not available in DemoToolsData::WPP2019_births", + "Assuming SRB to be 1.047 ") %in% outp) ) + + # Should fail because of number of years + expect_error( + downloadSRB(SRB = NULL, location = "Whatever", DatesOut = 1955:1958), + regexp = "SRB can only accept three dates at maximum", + fixed = TRUE + ) + + # Should impute the first two years with the last + srb_checker( + downloadSRB(SRB = NULL, location = "Germany", DatesOut = 1948:1950), + ordered_name = TRUE + ) + + # Should impute all values + srb_checker( + downloadSRB(SRB = NULL, location = "Germany", DatesOut = 1947:1949), + ordered_name = TRUE + ) +}) + +# Interpolation between pivot wpp years, also into the period 1950-1955 +tfr_pj <- data.frame( + year = c(1950.0,1950.5,1951.5,1952.5,1953.0, + 1953.5,1954.5,1955.0,1955.5, + 1956.5,1957.5,1958.0,1958.5, + 1959.5,1960.0,1960.5,1961.5, + 1962.5,1963.0,1963.5,1964.5, + 1965.0,1965.5,1966.5,1967.5, + 1968.0,1968.5,1969.5,1970.0, + 1970.5,1971.5,1972.5,1973.0), + tfr = c(7.2986,7.3290,7.3898,7.4506,7.4810,7.5114,7.5722,7.6026,7.6330, + 7.6938,7.7546,7.7850,7.8130,7.8690,7.8970,7.9250,7.9810,8.0370, + 8.0650,8.0695,8.0785,8.0830,8.0875,8.0965,8.1055,8.1100,8.0980, + 8.0740,8.0620,8.0500,8.0260,8.0020,7.9900)) + +test_that("Replicate Peter Johnson´s excel for extrapolatebeyond 1955",{ + expect_equal(tfr_pj$tfr, + downloadAsfr(Asfrmat = NULL, location = "Kenya", + AsfrDatesIn = tfr_pj$year) %>% colSums() %>% + as.numeric() * 5 + ) +}) + +test_that("Receive a message if asked dates are not in 1950-2025 interval",{ + expect_output(downloadAsfr(Asfrmat = NULL, location = "Kenya", + AsfrDatesIn = 1900), + regexp = "Careful, extrapolating beyond range 1950-2025") + expect_output(downloadnLx(nLx = NULL, location = "Kenya", + nLxDatesIn = 1900, gender="both"), + regexp = "Careful, extrapolating beyond range 1950-2025") +}) diff --git a/tests/testthat/test-graduate.R b/tests/testthat/test-graduate.R index 99c941a73..8e018edc6 100644 --- a/tests/testthat/test-graduate.R +++ b/tests/testthat/test-graduate.R @@ -54,5 +54,36 @@ test_that("beers works", { ) }) +test_that("age ranges flexible for uniform, mono, and pclm", { + Pop5 <- c(88962, 73756, 51990, 55395, 48562) + Age5 <- seq(0,20,5) + Age5alt <- seq(45,65,5) + + m0 <- graduate_mono( Pop5, Age5 ) + m45 <- graduate_mono( Pop5, Age5alt ) + p0 <- graduate_pclm( Pop5, Age5 ) + p45 <- graduate_pclm( Pop5, Age5alt ) + u0 <- graduate_uniform( Pop5, Age5 ) + u45 <- graduate_uniform( Pop5, Age5alt ) + + expect_true(all(abs(m0 - m45) < 1e-9)) + expect_true(all(abs(p0 - p45) < 1e-4)) + expect_true(all(abs(u0 - u45) < 1e-9)) + + ma0 <- names2age(m0) + ma45 <- names2age(m45) + pa0 <- names2age(p0) + pa45 <- names2age(p45) + ua0 <- names2age(u0) + ua45 <- names2age(u45) + + expect_equal(ma0, 0:20, tolerance = 0) + expect_equal(pa0, 0:20, tolerance = 0) + expect_equal(ua0, 0:20, tolerance = 0) + expect_equal(ma45, 45:65, tolerance = 0) + expect_equal(pa45, 45:65, tolerance = 0) + expect_equal(ua45, 45:65, tolerance = 0) + +}) diff --git a/tests/testthat/test-interp_coh.R b/tests/testthat/test-interp_coh.R new file mode 100644 index 000000000..cc59948e5 --- /dev/null +++ b/tests/testthat/test-interp_coh.R @@ -0,0 +1,656 @@ +check_form <- function(x) { + expect_is(x, "matrix") + expect_true(nrow(x) == 101) + expect_true(all(!is.na(x))) + #expect_true(ncol(x) == 8) + expect_true(length(colnames(x)) != 0) +} + +births <- c(719511L, 760934L, 772973L, 749554L, 760831L, + 828772L, 880543L, 905380L, 919639L) + +test_that("interp_coh works without midyear", { + + res <- + interp_coh( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + births = births + ) + + check_form(res) + expect_true(ncol(res) == 8) +}) + +test_that("interp_coh works with midyear", { + + res <- + interp_coh( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + births = births, + midyear = TRUE + ) + + check_form(res) + expect_true(ncol(res) == 8) +}) + + +# Examples for interpolating between two Russian censuses + + +test_that("interp_coh works well with age1", { + + # 1) births given as vector + # mortality pulled from WPP2019 (graduated as needed) + res1 <- interp_coh( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L) + ) + + # Same, but age args totally inferred. + res2 <- interp_coh( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L)) + + expect_equal(res1, res2) +}) + + +test_that("Births are pulled from post-processed WPP2019", { + # 2) births pulled from post-processing of WPP2019; + # mortality from WPP2019 (graduated as needed) +outp <- capture_output_lines(interp_coh( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100 +)) + expect_true( + "births not provided. Downloading births for Russian Federation (LocID = 643), gender: `male`, years: 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010" == + as.character(outp[4])) + +}) + +test_that("interp_coh works well with different time points", { + # 3) mortality (abridged, 2 and 3 time points) and fertility given: + mortdate1 <- 2003 + mortdate2 <- 2006 + mortdate3 <- 2010 + age_lx <- c(0,1,seq(5,100,by=5)) + lx1 <- fertestr::FetchLifeTableWpp2019( + locations = "Russian Federation", + year = mortdate1, + sex = "male")$lx + + lx2 <- fertestr::FetchLifeTableWpp2019( + locations = "Russian Federation", + year = mortdate2, sex = "male")$lx + + lx3 <- fertestr::FetchLifeTableWpp2019( + locations = "Russian Federation", + year = mortdate3, sex = "male")$lx + + lxmat2 <- cbind(lx1,lx3) + lxmat3 <- cbind(lx1,lx2,lx3) + + # with 2 mort timepoints + res1 <- interp_coh( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + lxMat = lxmat2, + dates_lx = c(mortdate1,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010) + + check_form(res1) + + # with 3 mort timepoints + res2 <- interp_coh( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + lxMat = lxmat3, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010) + + check_form(res2) + + # Same as previous but with extra birth year specified (engage birth year filtering) + res3 <- interp_coh( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + lxMat = lxmat3, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L,1e6), + years_births = 2002:2011) + + check_form(res3) + +}) + +test_that("Test for stationary population using interp_coh", { + # Test for a stationary population: Success = each year basically the same. + LT <- fertestr::FetchLifeTableWpp2019( + locations = "Russian Federation", + year = 2003, sex = "male" + ) + + LT1 <- lt_abridged2single(nMx = LT$mx, Age = LT$x, OAnew = 110) + + # We could get close by just taking lx from LT1, + # But we can get even closer by converting this + # lifetable to a PC one using the same approximations + # used inside interp_coh. + + px <- 1 - LT1$nqx + pxsq <- px ^ .5 + N <- length(pxsq) + # That is, the first element is just a lower tri surv prob, + # which wrongly assumes that the survival probs in the upper + # and lower infant triangles are equal. + pxcp <- c(pxsq,1) * c(1, pxsq) + qxcp <- 1 - pxcp + + # left and right-side stationary populalations, where radix + # 1e5 is the horizontal birth line. Woot. + c1 <- lt_single_qx(qxcp, OAnew = 110)$lx[-1][1:101] + c2 <- c1 + + lxMat <- cbind(LT1$lx,LT1$lx,LT1$lx) + + Pxt <- interp_coh( + c1 = c1, + c2 = c2, + date1 = "2002-01-01", + date2 = "2010-01-01", + lxMat = lxMat, + # linear interp, would be same w 2 or 10 lx columns. + dates_lx = c(2002,2005,2008), + age_lx = 0:110, + births = rep(1e5,9), # stationary birth series + years_births = 2002:2010) + + # here's the test: + # now that's what I call a deterministic stationary population. + # :-) + expect_true(all(abs(diff(t(Pxt))) < 1e9)) +}) + + +test_that("interp_coh errors if not given correctly", { + # 1) births given (no years_birth), but not right length + expect_error( + interp_coh( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + # Here we provide births with one year less + births = births[-length(births)] + ) + ) + + # 2) births given, correct length, but not right years + expect_error( + interp_coh( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + # Correct births + births = births, + # Incorrect years of birth (should be 2010) + years_births = 2002:2009 + ) + ) +}) + +# Downloads data used below +mortdate1 <- 2003 +mortdate2 <- 2006 +mortdate3 <- 2010 +age_lx <- c(0,1,seq(5,100,by=5)) +lx1 <- fertestr::FetchLifeTableWpp2019( + locations = "Russian Federation", + year = mortdate1, + sex = "male")$lx + +lx2 <- fertestr::FetchLifeTableWpp2019( + locations = "Russian Federation", + year = mortdate2, sex = "male")$lx + +lx3 <- fertestr::FetchLifeTableWpp2019( + locations = "Russian Federation", + year = mortdate3, sex = "male")$lx + +lxmat <- cbind(lx1,lx2,lx3) + +# We should error if +test_that("interp_coh fails when lxmat is not correct", { + + # 3.1) lxMat given, but only one column + expect_error( + interp_coh( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + lxMat = lxmat[, 1, drop = FALSE], + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010), + regexp = "lxMat should have at least two or more dates as columns. lxMat contains only one column" #nolintr + ) + + ## 3.2) lxMat give, but the date range in it doesn't overlap + ## with the date range of date1 to date2 (i.e. 100% extrapolation implied) + outp <- capture_output_lines( + interp_coh( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2000-10-16", + date2 = "2014-10-25", + # Make up some very dates that are above 6 years within date1 and date2 + lxMat = lxmat[, 1:2], + dates_lx = c(2007, 2008), + age_lx = age_lx, + # Make up some births to fit the dates from above. + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, + 919639L, 719511L, 760934L, 772973L, + 749554L, 760831L, 828772L), + years_births = 2000:2014)) + +expect_true(any(outp == "Range between `date1` and `date2` must overlap with `lx_dates` for at least 25% of the range or 6 years." #nolintr + )) + + # Full error when dates_lx are now within the date1 and date2 threshold. + expect_error( + interp_coh( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2000-10-16", + date2 = "2014-10-25", + # Make up some very long dates + lxMat = lxmat[, 1:2], + dates_lx = c(2020, 2021), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, + 919639L, 719511L, 760934L, 772973L, + 749554L, 760831L, 828772L), + years_births = 2000:2014), + regexp = "All `dates_lx` must be within the range of `date1` and `date2`" + ) + +}) + + +# 4) age1 or age2 not single +test_that("Ages must be single in interp_coh", { + + # The error tests that they are the same length. + # If ages are of anything other than single ages, + # this will fail, capturing that the ages should + # be single ages. + expect_error( + interp_coh( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + # Supply ages in five year age groups + age1 = seq(0, 100, by = 5), + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010), + regexp = "length(age1) == length(c1) is not TRUE", + fixed = TRUE + ) + + expect_error( + interp_coh( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + # Supply ages for second age group in five year age groups + age2 = seq(0, 100, by = 5), + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010), + regexp = "length(age2) == length(c2) is not TRUE", + fixed = TRUE + ) + + expect_error( + interp_coh( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + # Both ages supplied + age1 = seq(0, 100, by = 5), + age2 = seq(0, 100, by = 5), + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010), + regexp = "length(age1) == length(c1) is not TRUE", + fixed = TRUE + ) +}) + +test_that("interp_coh fails if arguments not supplied to download data ", { + + # 5) no births given, and no location/sex given + expect_error( + interp_coh( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + years_births = 2002:2010), + regexp = "births not specified, please specify location and sex", + fixed = TRUE + ) + + # 6) no lxMat given, and no location/sex given + expect_error( + interp_coh( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010), + regexp = "lxMat not specified, please specify location and sex", + fixed = TRUE + ) +}) + +test_that("c1, c2 and lxmat should not have negatives", { + + # 7) c1, c2, lxMat, or births have negatives + + c1_neg <- pop1m_rus2002 + c1_neg[1] <- -c1_neg[1] + + expect_error( + interp_coh( + c1 = c1_neg, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, 760831L, + 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010 + ), + regexp = "No negative values allowed in `c1`" + ) + + c2_neg <- pop1m_rus2010 + c2_neg[1] <- -c2_neg[1] + + expect_error( + interp_coh( + c1 = pop1m_rus2002, + c2 = c2_neg, + date1 = "2002-10-16", + date2 = "2010-10-25", + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, 760831L, + 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010 + ), + regexp = "No negative values allowed in `c2`" + ) + + lxmat_neg <- lxmat + lxmat_neg[2, 1] <- -lxmat_neg[2, 1] + + expect_error( + interp_coh( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + lxMat = lxmat_neg, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, 760831L, + 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010 + ), + regexp = "No negative values allowed in `lxMat`" + ) + +}) + + +test_that("interp_coh shows appropriate warnings when verbose = TRUE", { + + # 1) age1 and age2 not same range + outp <- capture_output_lines( + interp_coh( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010[-length(pop1m_rus2010)], + date1 = "2002-10-16", + date2 = "2010-10-25", + # Both ages supplied + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010)) + expect_true( + all(c("FYI: age ranges are different for c1 and c2", "We'll still get intercensal estimates,","but returned data will be chopped off after age 100 ") %in% outp) + ) + + # 2) date2 - date1 > 15 + outp <- capture_output_lines( + interp_coh( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + # Here I set the year to 2020 + date2 = "2017-10-25", + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + # Add fake births/years_births so that they exceed more + # than 15 years + births = c(719511L, 760934L, 772973L, 749554L, 760831L, + 828772L, 880543L, 905380L, 919639L, 919639L, + 760831L, 880543L, 719511L, 760934L, 772973L, + 749554L), + years_births = 2002:2017, + verbose = TRUE + )) + + expect_true(all(c("FYI, there are 15.02466 years between c1 and c2","Be wary.") %in% outp)) + + + + # 3) if the shortest distance from dates_lx to date1 or date2 is greater than 7 +outp <- capture_output_lines( + interp_coh( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2000-10-16", + date2 = "2017-10-25", + lxMat = lxmat[, 1:2], + dates_lx = c(2008, 2009), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, 760831L, + 828772L, 880543L, 905380L, 919639L, 719511L, + 760934L, 772973L, 749554L, 760831L, 828772L, + 749554L, 760831L, 828772L), + years_births = 2000:2017, + verbose = TRUE + )) + + +expect_true(any(outp == "The shortest distance from `dates_lx` ( 2008 ) to `date1/date2`( 2000.79 ) is greater than 7 years. Be wary.")) + + + + # 4) any negatives detected in output (to be imputed with 0s) + # TODO: I couldn't come up with an example where the resulting + # interpolated values ended up being negative. Tim said these + # would happen for very small cells. The idea would be to test + # that the message is produced saying that negatives are being + # replace by negatives and check that there are no negatives + # in the output + # c1 <- pop1m_rus2002 + # c1[100] <- 1 + # c1[101] <- 1 + # c2 <- pop1m_rus2002 + # c2[100] <- 1 + # c2[101] <- 1 + # set.seed(23151) + # births <- sample(1:2, size = 10, replace = TRUE) + # lxmat_dummy <- lxmat[, 1:2] + # lxmat_dummy[22, ] <- c(0.000000000000001, 0.000000000000001) + + # interp_coh( + # c1 = c1, + # c2 = c2, + # date1 = "2000-10-16", + # date2 = "2009-10-25", + # lxMat = lxmat[, 1:2], + # dates_lx = c(2004, 2005), + # age_lx = age_lx, + # births = births, + # years_births = 2000:2009, + # verbose = TRUE + # ) +}) + +test_that("interp_coh throws download messages when verbose = TRUE", { + + # 1) lx is downloaded + outp <- capture_output_lines( + interp_coh( + location = "Russian Federation", + sex = "both", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, 760831L, + 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010, + verbose = TRUE + )) + + expect_true(any(outp == "lxMat not provided. Downloading lxMat for Russian Federation (LocID = 643), gender: `both`, for years between 2002.8 and 2010.8" + )) + + # 2) births are downloaded + outp <- capture_output_lines( + interp_coh( + location = "Russian Federation", + sex = "both", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + date1 = "2002-10-16", + date2 = "2010-10-25", + age_lx = age_lx, + verbose = TRUE + )) + expect_true(any(outp == "births not provided. Downloading births for Russian Federation (LocID = 643), gender: `both`, years: 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010" + )) + + # 3) dates_lx or years_births are being assumed anything + outp <- capture_output_lines( + interp_coh( + location = "Russian Federation", + sex = "both", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + lxMat = lxmat, + date1 = "2002-10-16", + date2 = "2010-10-25", + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, 760831L, + 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010, + verbose = TRUE + )) + expect_true(all( + c("lxMat specified, but not dates_lx", + "Assuming: 2002.78904109589, 2006.80136986301, 2010.81369863014 ") %in% outp)) + +}) diff --git a/tests/testthat/test-ltpopdth.R b/tests/testthat/test-lt_abridged.R similarity index 97% rename from tests/testthat/test-ltpopdth.R rename to tests/testthat/test-lt_abridged.R index 609da1606..2b2c9e939 100644 --- a/tests/testthat/test-ltpopdth.R +++ b/tests/testthat/test-lt_abridged.R @@ -4,19 +4,20 @@ # 2) also qx in range 0-1 # IK: done ############################################################################### -context("test-ltpopdth") +context("test-lt_abridged") # testing function -------------------------------------------------------- lt_test_all_positive_plus_qx_lt_1 <- function(LT) { # check positive values + expect_equal( LT %>% # TR: open age AgeInt is NA, not handled well with logicals - select(-c(Age,AgeInt)) %>% + '['(,c("nMx", "nAx", "nqx", "lx", "ndx", "nLx", "Sx", "Tx", "ex" )) %>% # TR: rm is_weakly_less_than() since final 0 is valid sometimes. - is_less_than(0) %>% # + '<'(0) %>% # sum(), 0 ) @@ -24,8 +25,8 @@ lt_test_all_positive_plus_qx_lt_1 <- function(LT) { # check qx less than 1 expect_equal( LT %>% - select(nqx) %>% - is_greater_than(1) %>% + '['("nqx") %>% + '>'(1) %>% sum(), 0 ) @@ -228,3 +229,4 @@ test_that("lt_abridged works on Mortpak example (United Nations 1988, p. 82)", { MP_UNLT80 %>% lt_test_all_positive_plus_qx_lt_1() MP_UNLT60 %>% lt_test_all_positive_plus_qx_lt_1() }) + diff --git a/tests/testthat/test-lt_model_lq.R b/tests/testthat/test-lt_model_lq.R new file mode 100644 index 000000000..20fbebe21 --- /dev/null +++ b/tests/testthat/test-lt_model_lq.R @@ -0,0 +1,75 @@ +# This just tests that the output is a success +check_normal_output <- function(res) { + expect_true(class(res) == "lt_model_lq") +} + +# Generate combination of arguments to test +combn_args <- t(combn(c("q0_5", "q15_45", "e0", "q0_1", "q15_35"), 2)) + +# Generate combination of values to test +combn_value_lookup <- t(combn(c(0.05, 0.2, 65, 0.05, 0.15), 2)) + +# Exclude the combinations that will generate an error +error_tests1 <- combn_args[, 1] %in% c("q0_5") & combn_args[, 2] %in% c("q0_1") +error_tests2 <- combn_args[, 1] %in% c("q15_45") & combn_args[, 2] %in% c("q15_35") + +# Only test the non-error rows +passing_tests <- !error_tests1 & !error_tests2 +rows <- which(passing_tests) +for (i in rows) { + # Grab the arguments with their respective values + first_arg <- setNames(combn_value_lookup[i, 1], combn_args[i, 1]) + second_arg <- setNames(combn_value_lookup[i, 2], combn_args[i, 2]) + + # Collapse all arguments into a list. b for both, + # m for males and f for females. + all_args_b <- c("Sex" = "b", as.list(c(first_arg, second_arg))) + all_args_m <- c("Sex" = "m", as.list(c(first_arg, second_arg))) + all_args_f <- c("Sex" = "f", as.list(c(first_arg, second_arg))) + + # just the test name for test_that (easier for debugging) + test_both <- + paste0("lt_model_lq with ", names(first_arg), " and ", names(second_arg), + "works for Sex = 'b'") + + # Same as above but for males + test_males <- + paste0("lt_model_lq with ", names(first_arg), " and ", names(second_arg), + "works for Sex = 'm'") + + # Same as above but for female + test_females <- + paste0("lt_model_lq with ", names(first_arg), " and ", names(second_arg), + "works for Sex = 'f'") + + test_that(test_both, { + # Run the lt_model_lq with the arguments in a list + # THIS is where the test happens + check_normal_output(do.call(lt_model_lq, all_args_b)) + }) + + test_that(test_males, { + check_normal_output(do.call(lt_model_lq, all_args_m)) + }) + + test_that(test_females, { + check_normal_output(do.call(lt_model_lq, all_args_f)) + }) +} + +# Some combination of arguments need to return an error +rows_error <- which(!passing_tests) +for (i in rows_error) { + # Grab the arguments with their respective values + first_arg <- setNames(combn_value_lookup[i, 1], combn_args[i, 1]) + second_arg <- setNames(combn_value_lookup[i, 2], combn_args[i, 2]) + all_args <- c(Sex = "m", as.list(c(first_arg, second_arg))) + + test_name <- paste0("Checking error in lt_model_lq with ", + names(first_arg), + " and ", + names(second_arg)) + + test_that(test_name, expect_error(do.call(lt_model_lq, all_args))) +} + diff --git a/tests/testthat/test-mig_beta.R b/tests/testthat/test-mig_beta.R new file mode 100644 index 000000000..98715a30a --- /dev/null +++ b/tests/testthat/test-mig_beta.R @@ -0,0 +1,831 @@ +check_form <- function(x) { + expect_is(x, "numeric") + expect_true(length(x) == 103) + expect_true(all(!is.na(x))) + expect_named(x) +} + +births <- c(719511L, 760934L, 772973L, 749554L, 760831L, + 828772L, 880543L, 905380L, 919639L) + +test_that("mig_beta works without midyear", { + + res <- + mig_beta( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + births = births + ) + + check_form(res) +}) + +test_that("mig_beta works with midyear", { + + res <- + mig_beta( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + births = births, + midyear = TRUE + ) + + check_form(res) +}) + + +test_that("mig_beta works well with age1", { + + res1 <- mig_beta( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L) + ) + + # Same, but age args totally inferred. + res2 <- mig_beta( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L)) + + expect_equal(res1, res2) +}) + + +test_that("Births are pulled from post-processed WPP2019", { + # 2) births pulled from post-processing of WPP2019; + # mortality from WPP2019 (graduated as needed) + + outp <- capture_output_lines( + mig_beta( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100 + )) + + expect_true(any(outp == "births not provided. Downloading births for Russian Federation (LocID = 643), gender: `male`, years: 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010" #nolintr + )) +}) + +test_that("mig_beta works well with different time points", { + # 3) mortality (abridged, 2 and 3 time points) and fertility given: + mortdate1 <- 2003 + mortdate2 <- 2006 + mortdate3 <- 2010 + age_lx <- c(0,1,seq(5,100,by=5)) + lx1 <- fertestr::FetchLifeTableWpp2019( + locations = "Russian Federation", + year = mortdate1, + sex = "male")$lx + + lx2 <- fertestr::FetchLifeTableWpp2019( + locations = "Russian Federation", + year = mortdate2, sex = "male")$lx + + lx3 <- fertestr::FetchLifeTableWpp2019( + locations = "Russian Federation", + year = mortdate3, sex = "male")$lx + + lxmat2 <- cbind(lx1,lx3) + lxmat3 <- cbind(lx1,lx2,lx3) + + # with 2 mort timepoints + res1 <- mig_beta( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + lxMat = lxmat2, + dates_lx = c(mortdate1,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010) + + check_form(res1) + + # with 3 mort timepoints + res2 <- mig_beta( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + lxMat = lxmat3, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010) + + check_form(res2) + + # Same as previous but with extra birth year specified (engage birth year filtering) + res3 <- mig_beta( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + lxMat = lxmat3, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L,1e6), + years_births = 2002:2011) + + check_form(res3) + +}) + +test_that("mig_beta errors if not given correctly", { + # 1) births given (no years_birth), but not right length + expect_error( + mig_beta( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + # Here we provide births with one year less + births = births[-length(births)] + ) + ) + + # 2) births given, correct length, but not right years + expect_error( + mig_beta( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + # Correct births + births = births, + # Incorrect years of birth (should be 2010) + years_births = 2002:2009 + ) + ) +}) + +# Downloads data used below +mortdate1 <- 2003 +mortdate2 <- 2006 +mortdate3 <- 2010 +age_lx <- c(0,1,seq(5,100,by=5)) +lx1 <- fertestr::FetchLifeTableWpp2019( + locations = "Russian Federation", + year = mortdate1, + sex = "male")$lx + +lx2 <- fertestr::FetchLifeTableWpp2019( + locations = "Russian Federation", + year = mortdate2, sex = "male")$lx + +lx3 <- fertestr::FetchLifeTableWpp2019( + locations = "Russian Federation", + year = mortdate3, sex = "male")$lx + +lxmat <- cbind(lx1,lx2,lx3) + +# We should error if +test_that("mig_beta fails when lxmat is not correct", { + + # 3.1) lxMat given, but only one column + expect_error( + mig_beta( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + lxMat = lxmat[, 1, drop = FALSE], + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010), + regexp = "lxMat should have at least two or more dates as columns. lxMat contains only one column" #nolintr + ) + + ## 3.2) lxMat give, but the date range in it doesn't overlap + ## with the date range of date1 to date2 (i.e. 100% extrapolation implied) + expect_output( + mig_beta( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2000-10-16", + date2 = "2014-10-25", + # Make up some very dates that are above 6 years within date1 and date2 + lxMat = lxmat[, 1:2], + dates_lx = c(2007, 2008), + age_lx = age_lx, + # Make up some births to fit the dates from above. + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, + 919639L, 719511L, 760934L, 772973L, + 749554L, 760831L, 828772L), + years_births = 2000:2014), + regexp = "Range between `date1` and `date2` must overlap with `lx_dates` for at least 25% of the range or 6 years." #nolintr + ) + + # Full error when dates_lx are now within the date1 and date2 threshold. + expect_error( + mig_beta( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2000-10-16", + date2 = "2014-10-25", + # Make up some very long dates + lxMat = lxmat[, 1:2], + dates_lx = c(2020, 2021), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, + 919639L, 719511L, 760934L, 772973L, + 749554L, 760831L, 828772L), + years_births = 2000:2014), + regexp = "All `dates_lx` must be within the range of `date1` and `date2`" + ) + +}) + + +# 4) age1 or age2 not single +test_that("Ages must be single in mig_beta", { + + # The error tests that they are the same length. + # If ages are of anything other than single ages, + # this will fail, capturing that the ages should + # be single ages. + expect_error( + mig_beta( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + # Supply ages in five year age groups + age1 = seq(0, 100, by = 5), + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010), + regexp = "length(age1) == length(c1) is not TRUE", + fixed = TRUE + ) + + expect_error( + mig_beta( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + # Supply ages for second age group in five year age groups + age2 = seq(0, 100, by = 5), + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010), + regexp = "length(age2) == length(c2) is not TRUE", + fixed = TRUE + ) + + expect_error( + mig_beta( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + # Both ages supplied + age1 = seq(0, 100, by = 5), + age2 = seq(0, 100, by = 5), + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010), + regexp = "length(age1) == length(c1) is not TRUE", + fixed = TRUE + ) +}) + +test_that("mig_beta fails if arguments not supplied to download data ", { + + # 5) no births given, and no location/sex given + expect_error( + mig_beta( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + years_births = 2002:2010), + regexp = "births not specified, please specify location and sex", + fixed = TRUE + ) + + # 6) no lxMat given, and no location/sex given + expect_error( + mig_beta( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010), + regexp = "lxMat not specified, please specify location and sex", + fixed = TRUE + ) +}) + +test_that("c1, c2 and lxmat should not have negatives", { + + # 7) c1, c2, lxMat, or births have negatives + + c1_neg <- pop1m_rus2002 + c1_neg[1] <- -c1_neg[1] + + expect_error( + mig_beta( + c1 = c1_neg, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, 760831L, + 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010 + ), + regexp = "No negative values allowed in `c1`" + ) + + c2_neg <- pop1m_rus2010 + c2_neg[1] <- -c2_neg[1] + + expect_error( + mig_beta( + c1 = pop1m_rus2002, + c2 = c2_neg, + date1 = "2002-10-16", + date2 = "2010-10-25", + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, 760831L, + 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010 + ), + regexp = "No negative values allowed in `c2`" + ) + + lxmat_neg <- lxmat + lxmat_neg[2, 1] <- -lxmat_neg[2, 1] + + expect_error( + mig_beta( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + lxMat = lxmat_neg, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, 760831L, + 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010 + ), + regexp = "No negative values allowed in `lxMat`" + ) + +}) + + +test_that("mig_beta shows appropriate warnings when verbose = TRUE", { + + # 1) age1 and age2 not same range + expect_output( + mig_beta( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010[-length(pop1m_rus2010)], + date1 = "2002-10-16", + date2 = "2010-10-25", + # Both ages supplied + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, + 760831L, 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010), + regexp = "\nFYI: age ranges are different for c1 and c2\nWe'll still get intercensal estimates,\nbut returned data will be chopped off after age 100 ", + fixed = TRUE + ) + + # 2) date2 - date1 > 15 + expect_output( + mig_beta( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + # Here I set the year to 2020 + date2 = "2017-10-25", + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + age_lx = age_lx, + # Add fake births/years_births so that they exceed more + # than 15 years + births = c(719511L, 760934L, 772973L, 749554L, 760831L, + 828772L, 880543L, 905380L, 919639L, 919639L, + 760831L, 880543L, 719511L, 760934L, 772973L, + 749554L), + years_births = 2002:2017, + verbose = TRUE + ), + regexp = "FYI, there are 15.02466 years between c1 and c2\nBe wary.", + fixed = TRUE + ) + + # 3) if the shortest distance from dates_lx to date1 or date2 is greater than 7 + expect_output( + mig_beta( + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2000-10-16", + date2 = "2017-10-25", + lxMat = lxmat[, 1:2], + dates_lx = c(2008, 2009), + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, 760831L, + 828772L, 880543L, 905380L, 919639L, 719511L, + 760934L, 772973L, 749554L, 760831L, 828772L, + 749554L, 760831L, 828772L), + years_births = 2000:2017, + verbose = TRUE + ), + regexp = "The shortest distance from `dates_lx` ( 2008 ) to `date1/date2`( 2000.79 ) is greater than 7 years. Be wary.", + fixed = TRUE + ) + + # 4) any negatives detected in output (to be imputed with 0s) + # TODO: I couldn't come up with an example where the resulting + # interpolated values ended up being negative. Tim said these + # would happen for very small cells. The idea would be to test + # that the message is produced saying that negatives are being + # replace by negatives and check that there are no negatives + # in the output + # c1 <- pop1m_rus2002 + # c1[100] <- 1 + # c1[101] <- 1 + # c2 <- pop1m_rus2002 + # c2[100] <- 1 + # c2[101] <- 1 + # set.seed(23151) + # births <- sample(1:2, size = 10, replace = TRUE) + # lxmat_dummy <- lxmat[, 1:2] + # lxmat_dummy[22, ] <- c(0.000000000000001, 0.000000000000001) + + # mig_beta( + # c1 = c1, + # c2 = c2, + # date1 = "2000-10-16", + # date2 = "2009-10-25", + # lxMat = lxmat[, 1:2], + # dates_lx = c(2004, 2005), + # age_lx = age_lx, + # births = births, + # years_births = 2000:2009, + # verbose = TRUE + # ) +}) + +test_that("mig_beta throws download messages when verbose = TRUE", { + + # 1) lx is downloaded + outp <- capture_output_lines( + mig_beta( + location = "Russian Federation", + sex = "both", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, 760831L, + 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010, + verbose = TRUE + )) + expect_true(any(outp == "lxMat not provided. Downloading lxMat for Russian Federation (LocID = 643), gender: `both`, for years between 2002.8 and 2010.8")) + + # 2) births are downloaded + outp <- capture_output_lines( + mig_beta( + location = "Russian Federation", + sex = "both", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + date1 = "2002-10-16", + date2 = "2010-10-25", + age_lx = age_lx, + verbose = TRUE + )) + expect_true(any(outp == "births not provided. Downloading births for Russian Federation (LocID = 643), gender: `both`, years: 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010")) + + # 3) dates_lx or years_births are being assumed anything + expect_output( + mig_beta( + location = "Russian Federation", + sex = "both", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + lxMat = lxmat, + date1 = "2002-10-16", + date2 = "2010-10-25", + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, 760831L, + 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010, + verbose = TRUE + ), + regexp = "lxMat specified, but not dates_lx\nAssuming: 2002.78904109589, 2006.80136986301, 2010.81369863014", + fixed = TRUE + ) +}) + + + +test_that("mig_beta throws download messages when verbose = TRUE and LocID used", { + + # 1) lx is downloaded + outp <- capture_output_lines( + mig_beta( + location = 643, + sex = "both", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, 760831L, + 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010, + verbose = TRUE + )) + expect_true(any(outp == "lxMat not provided. Downloading lxMat for Russian Federation (LocID = 643), gender: `both`, for years between 2002.8 and 2010.8")) + + # 2) births are downloaded + outp <- capture_output_lines( + mig_beta( + location = 643, + sex = "both", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + lxMat = lxmat, + dates_lx = c(mortdate1,mortdate2,mortdate3), + date1 = "2002-10-16", + date2 = "2010-10-25", + age_lx = age_lx, + verbose = TRUE + )) + expect_true(any(outp == "births not provided. Downloading births for Russian Federation (LocID = 643), gender: `both`, years: 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010")) + + # 3) dates_lx or years_births are being assumed anything + expect_output( + mig_beta( + location = 643, + sex = "both", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + lxMat = lxmat, + date1 = "2002-10-16", + date2 = "2010-10-25", + age_lx = age_lx, + births = c(719511L, 760934L, 772973L, 749554L, 760831L, + 828772L, 880543L, 905380L, 919639L), + years_births = 2002:2010, + verbose = TRUE + ), + regexp = "lxMat specified, but not dates_lx\nAssuming: 2002.78904109589, 2006.80136986301, 2010.81369863014", + fixed = TRUE + ) +}) + + +test_that("mig_beta applies child_adjustment correctly", { + res_none <- + mig_beta( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + births = births, + child_adjust = "none" + ) + + + res_cwr <- + mig_beta( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + births = births, + child_adjust = "cwr" + ) + + res_cwr_high <- + mig_beta( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + births = births, + child_adjust = "cwr", + cwr_factor = 0.9 + ) + + res_constant <- + mig_beta( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + births = births, + child_adjust = "constant" + ) + + # Check we don't mess up the format of migs (length, type, etc..) + for (i in list(res_none, res_cwr, res_constant)) check_form(i) + + # Since cwr and constant can change, we only test that they adjust a certain + # number of ages rather than test the exact equality of results. + + # CWR: + # Why 9? Because date1 and date2 differ by 9 years, so only the first 9 + # cohorts are adjusted. + # Test that the first 9 are adjusted: + expect_true(all((res_none - res_cwr)[1:9] != 0)) + + + # Constant: + # Testhat that the first 9 are adjusted. + expect_true(all((res_none - res_constant)[1:9] != 0)) + + + # Test that CWR with high cwr_factor returns higher younger ages than with 0.3, + # the default: + expect_true(all(res_cwr_high[1:9] > res_cwr[1:9])) + +}) + + + +test_that("mig_beta applies oldage_adjustment correctly", { + res_none <- + mig_beta( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + births = births, + oldage_adjust = "none" + ) + + res_beers <- + mig_beta( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + births = births, + oldage_adjust = "beers" + ) + + + res_mav <- + mig_beta( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + births = births, + oldage_adjust = "mav" + ) + + # Check we don't mess up the format of migs (length, type, etc..) + for (i in list(res_none, res_beers, res_mav)) check_form(i) + + # beers: + # expect that the 65+ are different because they're adjusted + # Why 66? Because first age is 0 and total length is 101 + expect_true(all((res_none - res_beers)[66:(length(res_beers) - 2)] != 0)) + + + # mav: + # expect that the 65+ are different because they're adjusted + # Why 66? Because first age is 0 and total length is 101 + expect_true(all((res_none - res_mav)[66:(length(res_mav) - 2)] != 0)) + + + # Test that oldage_min controls the age from which to adjust + # old ages + res_beers <- + mig_beta( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + births = births, + oldage_adjust = "beers", + oldage_min = 70 + ) + + + res_mav <- + mig_beta( + location = "Russian Federation", + sex = "male", + c1 = pop1m_rus2002, + c2 = pop1m_rus2010, + date1 = "2002-10-16", + date2 = "2010-10-25", + age1 = 0:100, + births = births, + oldage_adjust = "mav", + oldage_min = 70 + ) + + # beers: + # expect that the 65+ are different because they're adjusted + # Why 71? Because first age is 0 and total length is 101 + expect_true(all((res_none - res_beers)[71:(length(res_beers) - 2)] != 0)) + + + # mav: + # expect that the 65+ are different because they're adjusted + # Why 71? Because first age is 0 and total length is 101 + expect_true(all((res_none - res_mav)[71:(length(res_mav) - 2)] != 0)) +}) diff --git a/tests/testthat/test-mig_resid.R b/tests/testthat/test-mig_resid.R index d7002d059..ea0709f90 100644 --- a/tests/testthat/test-mig_resid.R +++ b/tests/testthat/test-mig_resid.R @@ -1,3 +1,9 @@ +# Age/year sequence of all the data from above +interval <- 5 +ages <- seq(0, 100, by = interval) +years <- seq(1950, 2050, by = interval) +ages_asfr <- seq(15, 45, by = interval) + # Vector of population for males pop_m <- c(835, 671, 570.999, 544, 552, 550, 513, 487.998, 432.002, @@ -144,7 +150,7 @@ asfr <- c(50.369, 202.131, 206.141, 149.211, 87.253, 31.052, 15.036, 1.172, 4.686, 25.34, 73.943, 110.575, 66.487, 17.107, 1.462, 4.134, 23.539, 72.551, 113.398, 70.423, 19.099, 1.756, 3.732, 22.206, 71.53, 115.597, 73.588, 20.803, 2.024, 3.467, - 21.39, 71.244, 117.758, 76.268, 22.224, 2.249) + 21.39, 71.244, 117.758, 76.268, 22.224, 2.249) / 1000 # Vector of survival rates for males sr_m <- c(0.95557549, 0.9921273, 0.99594764, 0.99510483, 0.99178483, @@ -329,15 +335,15 @@ all_years <- c("1950", "1955", "1960", "1965", "1970", "1975", # Population for males as matrix pop_m_mat <- matrix(pop_m, nrow = 21, ncol = 21) colnames(pop_m_mat) <- all_years - +rownames(pop_m_mat) <- ages # Population for females as matrix pop_f_mat <- matrix(pop_f, nrow = 21, ncol = 21) colnames(pop_f_mat) <- all_years - +rownames(pop_f_mat) <- ages # Age-specific-fertility-rate for as matrix asfr_mat <- matrix(asfr, nrow = 7, ncol = 20) colnames(asfr_mat) <- all_years[-length(all_years)] - +rownames(asfr_mat) <- ages_asfr # Sex ratio at birth as vector srb_vec <- c(1.058, 1.057, 1.055, 1.055, 1.06, 1.056, 1.056, 1.052, 1.056, 1.054, 1.054, 1.053, 1.054, 1.053, 1.056, 1.056, 1.056, 1.056, @@ -353,12 +359,6 @@ colnames(sr_m_mat) <- all_years[-length(all_years)] sr_f_mat <- matrix(sr_f, nrow = 21, ncol = 20) colnames(sr_f_mat) <- all_years[-length(all_years)] -# Age/year sequence of all the data from above -interval <- 5 -ages <- seq(0, 100, by = interval) -years <- seq(1950, 2050, by = interval) -ages_fertility <- seq(15, 45, by = interval) - test_that("mig_resid_stock returns correct result", { mig_m_correct <- c(1.78993, 51.6027, 29.15413, 7.37114, 21.61505, 47.86478, 37.02506, 37.05721, 26.69961, 19.32384, 10.87064, -0.47108, -2.67392, @@ -424,7 +424,7 @@ test_that("mig_resid_stock returns correct result", { mig_m_correct <- matrix(mig_m_correct, nrow = 21, ncol = 20) colnames(mig_m_correct) <- all_years[-length(all_years)] - + rownames(mig_m_correct) <- ages mig_f_correct <- c(113.17294, 95.34564, 39.38204, 18.93728, 35.06867, 46.52932, 49.2666, 42.94238, 29.4034, 18.57087, 13.71191, 10.0067, 11.50849, 22.50025, 29.00955, 16.82217, 19.0866, 7.008, 2.73785, @@ -489,6 +489,7 @@ test_that("mig_resid_stock returns correct result", { mig_f_correct <- matrix(mig_f_correct, nrow = 21, ncol = 20) colnames(mig_f_correct) <- all_years[-length(all_years)] + rownames(mig_f_correct) <- ages mig_res <- mig_resid_stock( @@ -499,30 +500,51 @@ test_that("mig_resid_stock returns correct result", { asfr_mat = asfr_mat, srb_vec = srb_vec, ages = ages, - ages_fertility = ages_fertility + ages_asfr = ages_asfr ) + mig_resid_cohortet_mig_m <- mig_res$mig_m net_mig_m <- mig_res$mig_m net_mig_f <- mig_res$mig_f - colnames(mig_m_correct) <- NULL - colnames(net_mig_m) <- NULL - expect_equal( mig_m_correct, net_mig_m, tolerance = 0.00001 ) - colnames(mig_f_correct) <- NULL - colnames(net_mig_f) <- NULL - expect_equal( mig_f_correct, net_mig_f, tolerance = 0.00001 ) + # Test that mig_resid, the generic method maker, dispatches + # correctly + mig_res <- + mig_resid( + pop_m_mat = pop_m_mat, + pop_f_mat = pop_f_mat, + sr_m_mat = sr_m_mat, + sr_f_mat = sr_f_mat, + asfr_mat = asfr_mat, + srb_vec = srb_vec, + ages = ages, + ages_asfr = ages_asfr, + method = "stock" + ) + + expect_equal( + mig_m_correct, + mig_res$mig_m, + tolerance = 0.00001 + ) + + expect_equal( + mig_f_correct, + mig_res$mig_f, + tolerance = 0.00001 + ) }) test_that("mig_resid_cohort returns correct result", { @@ -590,7 +612,7 @@ test_that("mig_resid_cohort returns correct result", { mig_m_correct <- matrix(mig_m_correct, nrow = 21, ncol = 20) colnames(mig_m_correct) <- all_years[-length(all_years)] - + rownames(mig_m_correct) <- ages mig_f_correct <- c(171.72132, 69.20081, 29.46478, 27.29601, 41.33304, 48.61861, 46.88562, 36.86299, 24.5104, 16.56536, 12.26265, 11.3008, 18.40401, 29.00225, 27.17509, 23.83314, 19.13202, 8.57065, 3.41816, @@ -656,7 +678,7 @@ test_that("mig_resid_cohort returns correct result", { mig_f_correct <- matrix(mig_f_correct, nrow = 21, ncol = 20) colnames(mig_f_correct) <- all_years[-length(all_years)] - + rownames(mig_f_correct) <- ages mig_res <- mig_resid_cohort( pop_m_mat = pop_m_mat, @@ -666,29 +688,51 @@ test_that("mig_resid_cohort returns correct result", { asfr_mat = asfr_mat, srb_vec = srb_vec, ages = ages, - ages_fertility = ages_fertility + ages_asfr = ages_asfr ) net_mig_m <- mig_res$mig_m net_mig_f <- mig_res$mig_f - colnames(mig_m_correct) <- NULL - colnames(net_mig_m) <- NULL - expect_equal( mig_m_correct, net_mig_m, tolerance = 0.00001 ) - colnames(mig_f_correct) <- NULL - colnames(net_mig_f) <- NULL - expect_equal( mig_f_correct, net_mig_f, tolerance = 0.00001 ) + + # Test that mig_resid, the generic method maker, dispatches + # correctly + mig_res <- + mig_resid( + pop_m_mat = pop_m_mat, + pop_f_mat = pop_f_mat, + sr_m_mat = sr_m_mat, + sr_f_mat = sr_f_mat, + asfr_mat = asfr_mat, + srb_vec = srb_vec, + ages = ages, + ages_asfr = ages_asfr, + method = "cohort" + ) + + expect_equal( + mig_m_correct, + mig_res$mig_m, + tolerance = 0.00001 + ) + + expect_equal( + mig_f_correct, + mig_res$mig_f, + tolerance = 0.00001 + ) + }) test_that("mig_resid_time returns correct result", { @@ -761,7 +805,7 @@ test_that("mig_resid_time returns correct result", { mig_m_correct <- matrix(mig_m_correct, nrow = 21, ncol = 20) colnames(mig_m_correct) <- all_years[-length(all_years)] - + rownames(mig_m_correct) <- ages mig_f_correct <- c(226.34587, -21.03743, 99.34158, -59.68098, 128.43541, -31.83782, 129.37808, -38.94365, 96.19692, -54.63552, 78.96184, -52.98591, 70.21102, -13.67057, 68.3376, -10.37708, 43.47334, @@ -832,7 +876,7 @@ test_that("mig_resid_time returns correct result", { mig_f_correct <- matrix(mig_f_correct, nrow = 21, ncol = 20) colnames(mig_f_correct) <- all_years[-length(all_years)] - + rownames(mig_f_correct) <- ages mig_res <- mig_resid_time( pop_m_mat = pop_m_mat, @@ -842,27 +886,98 @@ test_that("mig_resid_time returns correct result", { asfr_mat = asfr_mat, srb_vec = srb_vec, ages = ages, - ages_fertility = ages_fertility + ages_asfr = ages_asfr ) net_mig_m <- mig_res$mig_m net_mig_f <- mig_res$mig_f - colnames(mig_m_correct) <- NULL - colnames(net_mig_m) <- NULL - expect_equal( mig_m_correct, net_mig_m, tolerance = 0.00001 ) - colnames(mig_f_correct) <- NULL - colnames(net_mig_f) <- NULL - expect_equal( mig_f_correct, net_mig_f, tolerance = 0.00001 ) + + # Test that mig_resid, the generic method maker, dispatches + # correctly + mig_res <- + mig_resid( + pop_m_mat = pop_m_mat, + pop_f_mat = pop_f_mat, + sr_m_mat = sr_m_mat, + sr_f_mat = sr_f_mat, + asfr_mat = asfr_mat, + srb_vec = srb_vec, + ages = ages, + ages_asfr = ages_asfr, + method = "time" + ) + + expect_equal( + mig_m_correct, + mig_res$mig_m, + tolerance = 0.00001 + ) + + expect_equal( + mig_f_correct, + mig_res$mig_f, + tolerance = 0.00001 + ) +}) + +test_that("all mig_resid methods throw warnings when data is trimmed", { + + all_funs <- list(mig_resid_stock, mig_resid_cohort, mig_resid_time) + + for (fun in all_funs) { + expect_output( + fun( + pop_m_mat = pop_m_mat, + pop_f_mat = pop_f_mat, + sr_m_mat = sr_m_mat, + sr_f_mat = sr_f_mat, + asfr_mat = asfr_mat, + srb_vec = srb_vec[1:16], + ages = ages, + ages_asfr = ages_asfr, + verbose = TRUE + ), + regexp = "Years 2035, 2040, 2045, 2050 have been trimmed from all the data" + ) + } + +}) + +test_that("all mig_resid methods throw errors when ages do not begin at zero ", { + + all_funs <- list(mig_resid_stock, mig_resid_cohort, mig_resid_time) + ages[1] <- 1 + + for (fun in all_funs) { + # when age is supplied + expect_error( + fun( + pop_m_mat = pop_m_mat, + pop_f_mat = pop_f_mat, + sr_m_mat = sr_m_mat, + sr_f_mat = sr_f_mat, + asfr_mat = asfr_mat, + srb_vec = srb_vec, + ages = ages, + ages_asfr = ages_asfr, + verbose = TRUE + ), + regexp = "Ages must begin at zero. Ages currently begin at 1" + ) + } + + # TODO we should add a test checking that this passes alright when ages + # is not provided but inferred from the matrices }) diff --git a/tests/testthat/test-smooth_age_5.R b/tests/testthat/test-smooth_age_5.R index 3984ae87b..4a72c39c4 100644 --- a/tests/testthat/test-smooth_age_5.R +++ b/tests/testthat/test-smooth_age_5.R @@ -5,108 +5,151 @@ context("test-agesmth") # smooth_age_5_cf ----------------------------------------------------- -test_that("smooth_age_5_cf works",{ - - Ages <- seq(0, 80, by = 5) - - CFmales <- smooth_age_5_cf(pop5m_pasex, Ages, OAG = TRUE) - - CFtest <- c(NA, NA, 346290, 287083, 285855, 261082, 237937, - 202809, 162973, 125720, 88730, 67352, 55187, 40657, NA, NA, NA) - - # test - expect_equivalent(CFmales, CFtest, tolerance = 1) - expect_equal(CFmales %>% sum, CFtest %>% sum, tolerance = 1) - expect_true(all(CFmales > 0, na.rm = T)) +test_that("smooth_age_5_cf works", { + Ages <- seq(0, 80, by = 5) + CFmales <- smooth_age_5_cf(pop5m_pasex, Ages, OAG = TRUE) + + CFtest <- c( + NA, NA, 346290, 287083, 285855, 261082, 237937, + 202809, 162973, 125720, 88730, 67352, 55187, 40657, NA, NA, NA + ) + + # test + expect_equivalent(CFmales, CFtest, tolerance = 1) + expect_equal(CFmales %>% sum(), CFtest %>% sum(), tolerance = 1) + expect_true(all(CFmales > 0, na.rm = T)) }) # smooth_age_5_kkn ---------------------------------------------------------------- -test_that("smooth_age_5_kkn works",{ - - Ages <- seq(0, 80, by = 5) - - KKNtest <- c(NA, NA, 354871, 278502, 285508, 261429, 236513 , - 204233, 162138, 126555, 90094, 65988, 54803, 41041, NA, NA, NA) - - KKNmales <- smooth_age_5_kkn(pop5m_pasex, Ages, OAG = TRUE) - - # test - expect_equivalent(KKNmales, KKNtest, tolerance = 1) - expect_equal(KKNmales %>% sum, KKNtest %>% sum, tolerance = 1) - expect_true(all(KKNmales > 0, na.rm = T)) - +test_that("smooth_age_5_kkn works", { + Ages <- seq(0, 80, by = 5) + + KKNtest <- c( + NA, NA, 354871, 278502, 285508, 261429, 236513, + 204233, 162138, 126555, 90094, 65988, 54803, 41041, NA, NA, NA + ) + + KKNmales <- smooth_age_5_kkn(pop5m_pasex, Ages, OAG = TRUE) + + # test + expect_equivalent(KKNmales, KKNtest, tolerance = 1) + expect_equal(KKNmales %>% sum(), KKNtest %>% sum(), tolerance = 1) + expect_true(all(KKNmales > 0, na.rm = T)) }) # smooth_age_5_arriaga ---------------------------------------------------------------- -test_that("smooth_age_5_arriaga works",{ - - Ages <- seq(0, 80, by = 5) - - Amales <- smooth_age_5_arriaga(Value = pop5m_pasex, Age = Ages, OAG = TRUE) - - #' # PAS spreadsheet result: - Atest <- c(662761, 495126, 345744, 287629, 285919, 261018, 237469, 203277, - 161733, 126960, 88586, 67496, 54587, 41257, 28790, 17189, 34729) - - # test - expect_equivalent(Amales, Atest, tolerance = 1) - expect_equal(Amales %>% sum, Atest %>% sum, tolerance = 1) - expect_true(all(Amales > 0, na.rm = T)) - +test_that("smooth_age_5_arriaga works", { + Ages <- seq(0, 80, by = 5) + + Amales <- smooth_age_5_arriaga(Value = pop5m_pasex, Age = Ages, OAG = TRUE) + + #' # PAS spreadsheet result: + Atest <- c( + 662761, 495126, 345744, 287629, 285919, 261018, 237469, 203277, + 161733, 126960, 88586, 67496, 54587, 41257, 28790, 17189, 34729 + ) + + # test + expect_equivalent(Amales, Atest, tolerance = 1) + expect_equal(Amales %>% sum(), Atest %>% sum(), tolerance = 1) + expect_true(all(Amales > 0, na.rm = T)) }) # smooth_age_5_strong ---------------------------------------------------------------- -test_that("smooth_age_5_strong works",{ - - Ages <- seq(0, 80, by = 5) - - Stest <- c(646617, 511270, 386889, 317345, 273736, 240058, 218645, 188297, - 153931, 124347, 93254, 71858, 53594, 39721, 27887, 18092, 34729) - - Smales <- smooth_age_5_strong(pop5m_pasex, Ages, OAG = TRUE) - - # test - expect_equivalent(Smales, Stest, tolerance = 1) - expect_equal(Smales %>% sum, Stest %>% sum, tolerance = 1) - expect_true(all(Smales > 0, na.rm = T)) - +test_that("smooth_age_5_strong works", { + Ages <- seq(0, 80, by = 5) + + Stest <- c( + 646617, 511270, 386889, 317345, 273736, 240058, 218645, 188297, + 153931, 124347, 93254, 71858, 53594, 39721, 27887, 18092, 34729 + ) + + Smales <- smooth_age_5_strong(pop5m_pasex, Ages, OAG = TRUE) + + # test + expect_equivalent(Smales, Stest, tolerance = 1) + expect_equal(Smales %>% sum(), Stest %>% sum(), tolerance = 1) + expect_true(all(Smales > 0, na.rm = T)) }) +test_that("smooth_age_5_mav works", { + + # Without tails + Ages <- seq(0, 80, by = 5) + + Mtest <- c( + NA, 505239, 382964, 300570, 274160, 263151, 239782, 202228, + 162308, 128489, 92946, 73183, 51717, 41880, 26119, NA, 34729 + ) + + Mmales <- smooth_age_5_mav(pop5m_pasex, Ages, OAG = TRUE, tail = FALSE) + + # test + expect_equivalent(Mmales, Mtest, tolerance = 1) + expect_equal(Mmales %>% sum(), Mtest %>% sum(), tolerance = 1) + expect_true(all(Mmales > 0, na.rm = T)) + + # With tails + Mtest_tail <- c( + 642367, 507810, 382964, 300570, 274160, 263151, 239782, 202228, + 162308, 128489, 92946, 73183, 51717, 41880, 27038, 29796, 34729 + ) + + Mmales_tail <- smooth_age_5_mav(pop5m_pasex, Ages, OAG = TRUE, tail = TRUE) + + # test + expect_equivalent(Mmales_tail, Mtest_tail, tolerance = 1) + expect_equal(Mmales_tail %>% sum(), Mtest_tail %>% sum(), tolerance = 1) + expect_true(all(Mmales_tail > 0, na.rm = T)) + + # Check tail/no_tail are the same except + # for the tails: + expect_equivalent(Mmales[3:15], Mmales_tail[3:15], tolerance = 1) + # Exclue first/last pair of values because cascading alters both + # numbers. + +}) + + test_that("smooth_age_5_feeney works", { - - Pop <- c(2337, 3873, 3882, 3952, 4056, 3685, 3687, 3683, 3611, 3175, - 3457, 2379, 3023, 2375, 2316, 2586, 2014, 2123, 2584, 1475, - 3006, 1299, 1236, 1052, 992, 3550, 1334, 1314, 1337, 942, - 3951, 1128, 1108, 727, 610, 3919, 1221, 868, 979, 637, - 3409, 887, 687, 533, 313, 2488, 677, 426, 524, 333, - 2259, 551, 363, 290, 226, 1153, 379, 217, 223, 152, - 1500, 319, 175, 143, 89, 670, 149, 96, 97, 69, - 696, 170, 60, 38, 23, 745) - - Ages <- c(0:75) - - result <- smooth_age_5_feeney(Pop, Ages, maxit = 200, OAG = TRUE) - # inlcude original unstated age (15) - result <- rescale_vector(result,sum(result)+15) - tab2_answer <- c(18004, 17351, 14018, 10927, 8837, 8145, 7823, 7029, - 5748, 4326, 3289, 2415, 1794, 1197, 982, 741) - names(tab2_answer) <- seq(0,75,5) - - - testthat:::expect_equal( - result, - tab2_answer, - tolerance = .001) # TR: this on relative scale?? + Pop <- c( + 2337, 3873, 3882, 3952, 4056, 3685, 3687, 3683, 3611, 3175, + 3457, 2379, 3023, 2375, 2316, 2586, 2014, 2123, 2584, 1475, + 3006, 1299, 1236, 1052, 992, 3550, 1334, 1314, 1337, 942, + 3951, 1128, 1108, 727, 610, 3919, 1221, 868, 979, 637, + 3409, 887, 687, 533, 313, 2488, 677, 426, 524, 333, + 2259, 551, 363, 290, 226, 1153, 379, 217, 223, 152, + 1500, 319, 175, 143, 89, 670, 149, 96, 97, 69, + 696, 170, 60, 38, 23, 745 + ) + + Ages <- c(0:75) + + result <- smooth_age_5_feeney(Pop, Ages, maxit = 200, OAG = TRUE) + # inlcude original unstated age (15) + result <- rescale_vector(result, sum(result) + 15) + tab2_answer <- c( + 18004, 17351, 14018, 10927, 8837, 8145, 7823, 7029, + 5748, 4326, 3289, 2415, 1794, 1197, 982, 741 + ) + names(tab2_answer) <- seq(0, 75, 5) + + + testthat:::expect_equal( + result, + tab2_answer, + tolerance = .001 + ) # TR: this on relative scale?? }) #' Age <- c(0,1,seq(5,90,by=5)) #' # defaults -#' zz <- zigzag_smth(dth5_zigzag, Age, OAG = TRUE, ageMin = 40, ageMax = 90) \ No newline at end of file +#' zz <- zigzag_smth(dth5_zigzag, Age, OAG = TRUE, ageMin = 40, ageMax = 90) diff --git a/tests/testthat/test_AGEINT.R b/tests/testthat/test_AGEINT.R new file mode 100644 index 000000000..a3b50e0af --- /dev/null +++ b/tests/testthat/test_AGEINT.R @@ -0,0 +1,66 @@ +# test for basic interpolation function `interp` + +context("test-AGEINT") + +test_that("basic interpolation function",{ + + # Toy example: two ages, two dates, expected result by eye + popmatr <- matrix(1:2,2,2,byrow = T) + dates <- dec.date(c(2000.5,2010.5)) + + # interp + expect_true( + all( 1.5 == + interp(popmat = popmatr, + datesIn = dates, + datesOut = dec.date(2005.5)) + ) + ) + # extrap + expect_true( + all( 2.5 == + interp(popmat = popmatr, + datesIn = dates, + datesOut = dec.date(2015.5), extrap = T) + ) + ) + # constant inputs + expect_true( + all( 1 == + interp(popmat = matrix(1,2,2,byrow = T), + datesIn = dates, + datesOut = dec.date(2005.5)), + 1 == + interp(popmat = matrix(1,2,2,byrow = T), + datesIn = dates, + datesOut = dec.date(2015.5), extrap = T) + ) + ) + + # you set an output date beyond observed range, but without extrap=T, receive NA + # this is an interp function by default, so the argument to change the deafult behaviour + # must be explicit + expect_true( + all( + is.na( + interp(popmat = popmatr, + datesIn = dates, + datesOut = dec.date(2015.5)) + ) + ) + ) + + # no negative values + expect_true( + all(interp(popmat = popmatr, + datesIn = dates, + datesOut = dec.date(1900.5), + extrap = T)>=0 + ) + ) + expect_output(interp(popmat = popmatr, + datesIn = dates, + datesOut = dec.date(1900.5), + extrap = T), + regexp = "Negative values were turned 0. No accepted in population counts, fertility rates or life table functions.") +}) diff --git a/tests/testthat/test_interp_lc_lim.R b/tests/testthat/test_interp_lc_lim.R new file mode 100644 index 000000000..e90ec46d3 --- /dev/null +++ b/tests/testthat/test_interp_lc_lim.R @@ -0,0 +1,437 @@ +# tests against spreadsheet "Li_2018_Limited_Lee-Carter-v4.xlsm" ------------------------------------------------------------- + +context("test-interp_lc_lim") + +# summary +# A to E tests againts spreadsheet +# F testing args from main fun +# G mixing input: single/abr with output single/abr, and mixing input nMx and lx +# H passing lt arguments +# I text/messages/warnings + +# tolerance: .05% difference in e_0 +tolerance_admited <- .005 + +# data included in spredsheet ------------------------------------------------------------- + +Age <- c(0,1,seq(5,100,5)) +dates_in <- c(1980.671, 1991.668, 1996.586, 2000.586, 2010.71) +input <- data.frame(Date= c(rep(sort(rep(dates_in, length(Age))),2)), + Age = rep(Age, 2 * length(dates_in)), + Sex = c(rep("m", length(Age) * length(dates_in)), + rep("f", length(Age) * length(dates_in))), + nMx = c(0.058872, 0.002992, 0.000697, 0.000703, 0.001424, # males + 0.002102, 0.002519, 0.003109, 0.004072, 0.005968, 0.00739, 0.010927, + 0.013366, 0.018798, 0.028653, 0.037304, 0.052714, 0.059629, 0.070922, + 0.093256, 0.135563, 0.217859, 0.030825, 0.001351, 0.000517, 0.000528, + 0.001434, 0.002436, 0.002954, 0.003341, 0.003971, 0.004966, 0.006267, + 0.009662, 0.012983, 0.019135, 0.024503, 0.032664, 0.047827, 0.057952, + 0.073104, 0.099948, 0.148105, 0.237862, 0.026198, 0.001109, 0.000457, + 0.000555, 0.001571, 0.002404, 0.003012, 0.003674, 0.004129, 0.005016, + 0.006223, 0.008328, 0.012217, 0.017762, 0.025149, 0.032561, 0.042365, + 0.057642, 0.080202, 0.116701, 0.177582, 0.282593, 0.018484, 0.000883, + 0.000382, 0.000455, 0.001646, 0.002304, 0.002467, 0.003097, 0.003724, + 0.004507, 0.005908, 0.00794, 0.010738, 0.016865, 0.022493, 0.032624, + 0.040211, 0.051478, 0.068234, 0.09696, 0.147703, 0.241212, 0.01295, + 0.00063, 0.000332, 0.000433, 0.001641, 0.002581, 0.002578, 0.002547, + 0.00289, 0.004012, 0.005381, 0.007316, 0.009889, 0.013273, 0.018334, + 0.028212, 0.03749, 0.052073, 0.073922, 0.109615, 0.169785, 0.274699, + 0.045269, 0.002704, 0.000507, 0.00046, 0.000734, # females + 0.000895, 0.001126, 0.001495, 0.002197, 0.003143, 0.003983, 0.005939, + 0.007469, 0.01166, 0.018486, 0.026548, 0.042649, 0.050858, 0.063509, + 0.086965, 0.130587, 0.215029, 0.023838, 0.001154, 0.000358, 0.000318, + 0.000502, 0.000698, 0.000918, 0.001144, 0.001572, 0.002207, 0.003151, + 0.005038, 0.007183, 0.011023, 0.014718, 0.022267, 0.035953, 0.048153, + 0.066424, 0.097196, 0.150869, 0.248412, 0.020248, 0.000933, 0.00031, + 0.000339, 0.000525, 0.000652, 0.000901, 0.001251, 0.001599, 0.00223, + 0.00313, 0.004514, 0.007125, 0.01058, 0.015764, 0.021294, 0.032344, + 0.049166, 0.07543, 0.117877, 0.18764, 0.304247, 0.014603, 0.000768, + 0.000271, 0.000287, 0.000487, 0.000565, 0.000715, 0.001059, 0.001481, + 0.002049, 0.002936, 0.004201, 0.006039, 0.009984, 0.013853, 0.021179, + 0.02809, 0.042159, 0.064247, 0.100939, 0.163497, 0.273028, 0.010488, + 0.000521, 0.00025, 0.00029, 0.000453, 0.000581, 0.000725, 0.000901, + 0.001171, 0.001816, 0.002734, 0.003782, 0.005293, 0.007575, 0.011174, + 0.018559, 0.026524, 0.041711, 0.066135, 0.106604, 0.174691, 0.291021) + ) + +# A to E tests againts spreadsheet ------------------------------------------------------------- + +# utils +. <- NULL +e_dagger <- function(lx){-sum(lx/lx[1]*log(lx/lx[1]))} +e_dagger_list <- function(y){ + y %>% + split(list(y$Sex, y$Date)) %>% + lapply(FUN = function(X) { + + e_dagger(X$lx)}) %>% + do.call("rbind", .) + } + +# A - test with input nMx, allowing cross-over, and NOT reproducing e0 at given years +outputA <- data.frame( + Sex = rep(c(rep("m",22),rep("f",22)),14), + Age = rep(c(0,1,seq(5,100,5)),14*2), + Date = sort(rep(seq(1953,2018,5), 22 * 2)), + lx=c(100000,83150,80337,79837,79431,78942,78185,77029,75385,73199,70275,67106,62278,56789,49566,40140,32042,22605,15933,10927,6875,3588, + 100000,84678,81152,80771,80499,80075,79548,78850,77919,76488,74641,72644,69464,65742,60130,51912,43443,30927,22427,16100,10816,6196, + 100000,86377,84053,83588,83196,82669,81857,80661,79004,76832,73942,70757,65968,60442,53142,43642,35132,25249,17958,12328,7704,3957, + 100000,87704,84885,84531,84268,83857,83346,82671,81771,80408,78627,76647,73528,69806,64206,56054,47360,34637,25405,18223,12098,6756, + 100000,89036,87134,86706,86329,85768,84906,83679,82023,79886,77057,73887,69183,63676,56374,46904,38065,27842,19978,13727,8521,4306, + 100000,90178,87943,87617,87366,86972,86481,85835,84974,83687,81988,80045,77016,73334,67806,59811,50993,38231,28353,20321,13326,7247, + 100000,91237,89690,89298,88939,88346,87436,86188,84545,82456,79707,76577,71991,66545,59302,49945,40851,30380,21988,15122,9322,4632, + 100000,92217,90457,90159,89920,89545,89077,88463,87645,86440,84832,82939,80022,76408,70997,63226,54368,41703,31260,22386,14496,7666, + 100000,93019,91767,91410,91070,90447,89493,88230,86611,84582,81928,78855,74415,69066,61931,52757,43475,32845,23973,16502,10102,4934, + 100000,93832,92454,92185,91959,91604,91161,90581,89808,88688,87175,85344,82554,79033,73776,66281,57459,45010,34089,24391,15590,8007, + 100000,94441,93433,93110,92790,92139,91143,89872,88283,86323,83773,80773,76496,71272,64285,55347,45940,35228,25925,17862,10857,5210, + 100000,95116,94042,93798,93586,93252,92834,92289,91564,90527,89112,87350,84696,81285,76206,69024,60296,48156,36837,26335,16607,8272, + 100000,95577,94769,94478,94177,93499,92464,91190,89637,87750,85311,82393,78291,73213,66402,57740,48261,37534,27844,19202,11587,5461, + 100000,96136,95302,95083,94885,94571,94178,93668,92990,92033,90716,89027,86514,83223,78340,71492,62907,51144,39501,28216,17548,8464, + 100000,96485,95839,95577,95296,94591,93519,92245,90732,88922,86596,83768,79847,74928,68315,59956,50450,39764,29729,20521,12292,5686, + 100000,96946,96300,96104,95919,95625,95258,94782,94149,93270,92046,90434,88061,84899,80221,73719,65312,53978,42079,30032,18411,8587, + 100000,97210,96694,96459,96197,95467,94358,93088,91618,89885,87672,84939,81201,76449,70049,62012,52518,41920,31581,21819,12973,5888, + 100000,97589,97090,96914,96742,96468,96125,95682,95093,94287,93153,91617,89384,86353,81885,75733,67534,56663,44570,31783,19198,8642, + 100000,97787,97376,97166,96921,96167,95023,93759,92332,90678,88576,85940,82385,77807,71628,63924,54474,44006,33398,23096,13628,6065, + 100000,98099,97713,97556,97396,97141,96821,96409,95862,95125,94077,92617,90520,87622,83365,77560,69589,59205,46975,33469,19910,8636, + 100000,98246,97920,97732,97504,96725,95547,94291,92909,91331,89339,86800,83426,79023,73072,65706,56328,46022,35182,24352,14259,6220, + 100000,98502,98205,98065,97916,97678,97380,96998,96492,95818,94851,93465,91499,88733,84687,79223,71494,61610,49293,35091,20547,8572, + 100000,98611,98352,98184,97973,97169,95957,94710,93373,91870,89985,87544,84345,80118,74397,67370,58088,47972,36932,25587,14865,6351, + 100000,98820,98591,98466,98328,98108,97831,97477,97007,96392,95501,94188,92348,89713,85872,80739,73264,63883,51526,36649,21112,8454, + 100000,98901,98695,98546,98349,97522,96276,95039,93747,92317,90534,88189,85161,81109,75617,68926,59760,49857,38648,26800,15446,6461, + 100000,99071,98895,98784,98656,98451,98194,97866,97432,96871,96051,94808,93087,90580,86940,82127,74912,66032,53676,38145,21606,8288, + 100000,99131,98967,98834,98652,97800,96520,95295,94048,92688,91003,88753,85890,82010,76744,70385,61350,51679,40330,27992,16003,6550, + 100000,99269,99134,99035,98917,98727,98488,98184,97783,97272,96517,95342,93734,91351,87907,83399,76448,68062,55743,39580,22032,8077) + ) + +outputA_test <- interp_lc_lim(input = input, dates_out = seq(1953,2018,5)) + +test_that("lc w lim data works", { + expect_equal( + e_dagger_list(outputA), + e_dagger_list(outputA_test$lt_hat %>% dplyr::arrange(Date,Sex,Age)), + tolerance = tolerance_admited) +}) + +# B - test with input nMx, NOT allowing cross-over, and NOT reproducing e0 at given years +outputB <- data.frame( + Sex = rep(c(rep("m",22),rep("f",22)),14), + Age = rep(c(0,1,seq(5,100,5)),14*2), + Date = sort(rep(seq(1953,2018,5), 22 * 2)), + lx=c(100000,80086,76290,75769,75352,74763,73899,72737,71195,69042,65995,62776,57914,52835,46292,37220,29207,19847,13903,9721,6388,3588, + 100000,84151,80533,80133,79844,79522,79130,78571,77766,76489,74692,72707,69593,66116,60917,52929,44541,32573,24034,17440,11786,6760, + 100000,83964,80855,80367,79959,79345,78445,77260,75715,73586,70567,67303,62431,57246,50552,41293,32762,22837,16174,11310,7366,4057, + 100000,87323,84394,84023,83744,83412,83007,82445,81648,80402,78648,76667,73601,70122,64922,56987,48334,36084,26875,19505,13072,7356, + 100000,87161,84645,84192,83799,83167,82239,81048,79517,77439,74486,71220,66400,61180,54425,45113,36172,25821,18482,12927,8341,4501, + 100000,89907,87557,87216,86949,86610,86198,85638,84856,83653,81958,80002,77015,73572,68428,60633,51813,39435,29641,21515,14296,7889, + 100000,89769,87752,87337,86960,86315,85370,84184,82682,80674,77815,74580,69863,64663,57925,48671,39418,28770,20807,14555,9304,4916, + 100000,92033,90160,89849,89596,89253,88835,88281,87521,86368,84743,82826,79939,76559,71512,63924,55017,42634,32330,23471,15460,8359, + 100000,91915,90309,89930,89572,88919,87963,86790,85328,83402,80656,77477,72899,67763,61098,51989,42511,31678,23140,16189,10250,5299, + 100000,93713,92231,91949,91710,91364,90945,90401,89665,88568,87020,85156,82385,79090,74176,66845,57925,45650,34916,25352,16549,8761, + 100000,93618,92345,92002,91665,91009,90048,88895,87481,85647,83026,79924,75511,70477,63936,55044,45422,34510,25455,17812,11166,5643, + 100000,95043,93874,93620,93396,93050,92631,92099,91392,90353,88887,87082,84436,81244,76485,69447,60573,48492,37400,27161,17568,9100, + 100000,95577,94769,94478,94177,93499,92464,91190,89637,87750,85311,82393,78291,73213,66402,57740,48261,37534,27844,19202,11587,5461, + 100000,96136,95302,95083,94885,94571,94178,93668,92990,92033,90716,89027,86514,83223,78340,71492,62907,51144,39501,28216,17548,8464, + 100000,96485,95839,95577,95296,94591,93519,92245,90732,88922,86596,83768,79847,74928,68315,59956,50450,39764,29729,20521,12292,5686, + 100000,96946,96300,96104,95919,95625,95258,94782,94149,93270,92046,90434,88061,84899,80221,73719,65312,53978,42079,30032,18411,8587, + 100000,97210,96694,96459,96197,95467,94358,93088,91618,89885,87672,84939,81201,76449,70049,62012,52518,41920,31581,21819,12973,5888, + 100000,97589,97090,96914,96742,96468,96125,95682,95093,94287,93153,91617,89384,86353,81885,75733,67534,56663,44570,31783,19198,8642, + 100000,97787,97376,97166,96921,96167,95023,93759,92332,90678,88576,85940,82385,77807,71628,63924,54474,44006,33398,23096,13628,6065, + 100000,98099,97713,97556,97396,97141,96821,96409,95862,95125,94077,92617,90520,87622,83365,77560,69589,59205,46975,33469,19910,8636, + 100000,98246,97920,97732,97504,96725,95547,94291,92909,91331,89339,86800,83426,79023,73072,65706,56328,46022,35182,24352,14259,6220, + 100000,98502,98205,98065,97916,97678,97380,96998,96492,95818,94851,93465,91499,88733,84687,79223,71494,61610,49293,35091,20547,8572, + 100000,98611,98352,98184,97973,97169,95957,94710,93373,91870,89985,87544,84345,80118,74397,67370,58088,47972,36932,25587,14865,6351, + 100000,98820,98591,98466,98328,98108,97831,97477,97007,96392,95501,94188,92348,89713,85872,80739,73264,63883,51526,36649,21112,8454, + 100000,98901,98695,98546,98349,97522,96276,95039,93747,92317,90534,88189,85161,81109,75617,68926,59760,49857,38648,26800,15446,6461, + 100000,99071,98895,98784,98656,98451,98194,97866,97432,96871,96051,94808,93087,90580,86940,82127,74912,66032,53676,38145,21606,8288, + 100000,99131,98967,98834,98652,97800,96520,95295,94048,92688,91003,88753,85890,82010,76744,70385,61350,51679,40330,27992,16003,6550, + 100000,99269,99134,99035,98917,98727,98488,98184,97783,97272,96517,95342,93734,91351,87907,83399,76448,68062,55743,39580,22032,8077) +) +outputB_test <- interp_lc_lim(input = input, dates_out = seq(1953,2018,5), + prev_divergence = TRUE) + +test_that("lc w lim data and prev divergence works", { + # allow for rounding differences, so maximum absolute difference of 1 + expect_equal( + e_dagger_list(outputB), + e_dagger_list(outputB_test$lt_hat %>% dplyr::arrange(Date,Sex,Age)), + tolerance = tolerance_admited + ) +}) + +# C - test input nMx, allowing cross-over, and reproducing e0 at given years (e0_swe) +data("e0_swe") +outputC <- data.frame( + Sex = rep(c(rep("m",22),rep("f",22)),14), + Age = rep(c(0,1,seq(5,100,5)),14*2), + Date = sort(rep(seq(1953,2018,5), 22 * 2)), + lx=c(100000,96509,95867,95606,95325,94620,93546,92272,90761,88953,86630,83805,79889,74974,68368,60018,50512,39828,29783,20559,12312,5692, + 100000,94600,93404,93149,92931,92588,92159,91599,90854,89780,88324,86531,83818,80358,75200,67880,59105,46823,35666,25507,16179,8168, + 100000,96811,96223,95973,95700,94985,93897,92624,91129,89352,87073,84285,80441,75592,69067,60842,51337,40683,30515,21072,12582,5774, + 100000,95354,94336,94098,93889,93559,93147,92610,91894,90874,89481,87734,85110,81724,76686,69574,60873,48809,37414,26743,16815,8320, + 100000,97096,96559,96320,96054,95329,94227,92955,91477,89732,87499,84749,80980,76198,69761,61667,52168,41552,31262,21596,12857,5854, + 100000,96071,95221,95001,94801,94486,94092,93580,92898,91936,90611,88917,86394,83094,78196,71324,62727,50936,39314,28084,17483,8453, + 100000,97369,96882,96654,96396,95659,94542,93273,91813,90101,87916,85207,81516,76808,70463,62510,53024,42456,32044,22145,13141,5935, + 100000,96730,96035,95832,95643,95344,94969,94483,93838,92936,91686,90051,87638,84438,79699,73097,64635,53173,41341,29513,18169,8558, + 100000,97494,97030,96807,96553,95812,94687,93419,91969,90273,88112,85423,81771,77099,70801,62918,53440,42898,32429,22415,13280,5973, + 100000,97218,96634,96446,96266,95980,95623,95160,94545,93695,92507,90925,88608,85497,80901,74537,66209,55055,43072,30730,18731,8616, + 100000,97637,97199,96982,96733,95985,94851,93585,92146,90470,88337,85673,82067,77439,71197,63398,53933,43424,32889,22738,13446,6017, + 100000,97611,97117,96942,96770,96496,96154,95712,95125,94322,93192,91659,89431,86405,81945,75806,67615,56763,44664,31849,19227,8643, + 100000,98033,97667,97469,97233,96466,95304,94044,92640,91024,88979,86392,82929,78439,72376,64842,55426,45036,34307,23735,13951,6146, + 100000,98005,97599,97438,97275,97016,96692,96274,95719,94967,93903,92427,90303,87378,83079,77203,69184,58700,46493,33132,19771,8642, + 100000,98474,98189,98013,97795,97002,95803,94552,93198,91664,89736,87256,83987,79689,73874,66710,57386,47191,36228,25090,14622,6301, + 100000,98335,98002,97855,97701,97456,97148,96753,96229,95527,94525,93107,91084,88260,84121,78507,70670,60564,48279,34382,20275,8607, + 100000,98927,98726,98578,98384,97554,96304,95068,93781,92359,90586,88251,85240,81206,75737,69081,59927,50048,38823,26924,15505,6472, + 100000,98668,98407,98274,98131,97902,97614,97246,96758,96114,95185,93835,91932,89231,85286,79986,72382,62745,50403,35866,20834,8520, + 100000,99306,99174,99055,98886,98011,96698,95484,94279,92984,91389,89228,86515,82795,77744,71693,62798,53361,41902,29109,16511,6616, + 100000,98943,98741,98623,98489,98276,98008,97667,97214,96624,95766,94486,92702,90126,86379,81395,74040,64891,52530,37348,21349,8383, + 100000,99550,99465,99368,99221,98300,96924,95734,94606,93429,91997,90000,87560,84140,79488,74010,65411,56455,44849,31208,17430,6691, + 100000,99142,98981,98874,98749,98549,98298,97978,97555,97011,96213,94993,93310,90844,87270,82559,75431,66715,54367,38625,21754,8223, + 100000,99723,99671,99595,99469,98496,97047,95884,94839,93783,92516,90691,88530,85425,81197,76317,68083,59690,48009,33470,18360,6701, + 100000,99334,99212,99118,99003,98818,98586,98292,97902,97410,96679,95530,93964,91628,88257,83865,77016,68820,56525,40121,22179,7985, + 100000,99833,99801,99742,99635,98604,97079,95944,94978,94035,92919,91260,89356,86552,82731,78415,70579,62776,51104,35696,19211,6636, + 100000,99477,99384,99300,99194,99023,98807,98535,98176,97728,97057,95971,94511,92294,89109,85005,78423,70708,58494,41483,22514,7719, + 100000,99896,99876,99829,99738,98651,97050,95942,95047,94200,93211,91695,90008,87465,84000,80168,72717,65469,53874,37700,19913,6509, + 100000,99592,99520,99446,99348,99190,98990,98740,98408,98002,97387,96364,95005,92904,89901,86075,79762,72522,60421,42811,22788,7413) +) + +outputC_test <- interp_lc_lim(input = input, dates_out = seq(1953,2018,5), + dates_e0 = unique(e0_swe$Date), + e0_Males = e0_swe$e0[e0_swe$Sex=="m"], + e0_Females = e0_swe$e0[e0_swe$Sex=="f"]) +test_that("lc w lim data and fitting e0 works", { + expect_equal( + e_dagger_list(outputC), + e_dagger_list(outputC_test$lt_hat %>% dplyr::arrange(Date,Sex,Age)), + tolerance = tolerance_admited + ) +}) + +# D - test with input nqx, allowing cross-over, and NOT reproducing e0 at given years +input_nqx <- split(input, list(input$Date, input$Sex), drop = F) %>% + lapply(function(X){ + LT = lt_abridged(nMx = X[["nMx"]], + Age = X[["Age"]], + Sex = unique(X[["Sex"]])) + LT$Date = X$Date + LT$Sex = X$Sex + LT}) %>% + do.call("rbind", .) %>% + dplyr::select(Date, Sex, Age, nqx) +# paste in spreadsheet: input_nqx %>% tidyr::spread(Date,nqx) %>% write.csv("testD.csv") +outputD <- data.frame( + Sex = rep(c(rep("m",22),rep("f",22)),14), + Age = rep(c(0,1,seq(5,100,5)),14*2), + Date = sort(rep(seq(1953,2018,5), 22 * 2)), + lx=c(100000,83165,80358,79858,79453,78963,78206,77050,75407,73222,70301,67135,62313,56831,49626,40209,32109,22643,15918,10885,6821,3630, + 100000,84657,81137,80757,80485,80061,79534,78837,77906,76476,74632,72637,69462,65746,60148,51952,43509,30997,22436,16071,10770,6294, + 100000,86387,84068,83603,83210,82684,81872,80676,79019,76849,73961,70780,65998,60479,53196,43707,35197,25288,17946,12286,7648,4005, + 100000,87688,84873,84520,84257,83846,83335,82661,81762,80399,78621,76642,73527,69811,64225,56093,47425,34709,25421,18200,12053,6868, + 100000,89043,87144,86716,86339,85778,84916,83689,82034,79898,77071,73905,69207,63707,56423,46965,38128,27881,19969,13688,8463,4360, + 100000,90165,87934,87609,87357,86963,86473,85827,84966,83680,81984,80041,77017,73340,67824,59849,51057,38305,28376,20305,13284,7371, + 100000,91241,89696,89304,88945,88352,87442,86194,84552,82465,79718,76590,72011,66573,59346,50002,40911,30420,21983,15086,9265,4694, + 100000,92208,90450,90153,89914,89539,89071,88457,87640,86435,84829,82937,80024,76415,71015,63262,54430,41778,31290,22378,14458,7801, + 100000,93021,91770,91414,91074,90451,89497,88234,86615,84588,81936,78866,74431,69090,61970,52809,43533,32886,23972,16471,10045,5002, + 100000,93826,92449,92180,91955,91599,91156,90577,89805,88684,87174,85343,82557,79041,73794,66316,57518,45084,34126,24394,15557,8152, + 100000,94441,93435,93112,92792,92140,91145,89874,88286,86327,83779,80781,76509,71293,64320,55395,45996,35270,25929,17837,10802,5284, + 100000,95111,94038,93795,93583,93249,92831,92287,91562,90524,89111,87350,84699,81292,76223,69056,60352,48229,36882,26350,16581,8425, + 100000,95577,94769,94478,94178,93499,92465,91191,89638,87753,85315,82399,78302,73230,66433,57784,48314,37577,27854,19184,11535,5541, + 100000,96133,95300,95081,94882,94569,94176,93667,92988,92032,90715,89028,86517,83230,78355,71522,62958,51215,39554,28244,17529,8624, + 100000,96484,95838,95577,95295,94591,93519,92245,90733,88924,86598,83773,79856,74942,68342,59996,50500,39807,29746,20511,12244,5773, + 100000,96944,96299,96103,95917,95624,95257,94781,94148,93269,92046,90435,88064,84905,80235,73746,65360,54046,42140,30074,18401,8751, + 100000,97209,96693,96458,96196,95466,94358,93088,91618,89886,87673,84942,81208,76462,70073,62048,52565,41965,31605,21819,12928,5980, + 100000,97588,97089,96913,96741,96467,96124,95681,95092,94287,93153,91618,89387,86359,81898,75757,67577,56728,44639,31841,19198,8810, + 100000,97786,97375,97165,96920,96166,95023,93758,92332,90678,88577,85942,82391,77818,71649,63957,54519,44051,33431,23106,13589,6163, + 100000,98098,97713,97556,97396,97140,96820,96409,95862,95125,94077,92618,90522,87627,83377,77582,69629,59267,47051,33544,19920,8805, + 100000,98245,97918,97730,97503,96724,95546,94290,92909,91331,89339,86802,83430,79032,73090,65735,56370,46068,35223,24374,14225,6322, + 100000,98501,98204,98064,97915,97678,97380,96998,96491,95818,94851,93466,91501,88738,84697,79242,71530,61668,49378,35184,20569,8740, + 100000,98610,98350,98183,97971,97168,95956,94709,93373,91870,89985,87545,84348,80126,74412,67396,58127,48018,36981,25620,14838,6459, + 100000,98820,98591,98466,98328,98108,97831,97477,97007,96392,95501,94189,92349,89717,85881,80756,73296,63938,51619,36761,21145,8620, + 100000,98900,98694,98544,98348,97521,96275,95038,93747,92317,90534,88190,85164,81116,75629,68949,59797,49903,38705,26846,15426,6573, + 100000,99071,98895,98784,98656,98451,98194,97866,97432,96871,96051,94809,93088,90583,86948,82141,74940,66083,53776,38277,21652,8450, + 100000,99130,98966,98833,98651,97799,96520,95295,94047,92687,91003,88754,85891,82015,76755,70404,61385,51725,40395,28052,15990,6665, + 100000,99269,99134,99035,98917,98727,98488,98184,97783,97272,96517,95343,93736,91354,87913,83411,76472,68109,55851,39732,22090,8234) +) + +outputD_test <- interp_lc_lim(input = input_nqx, dates_out = seq(1953,2018,5)) + +test_that("lc w lim data and nqx as input works", { + expect_equal( + e_dagger_list(outputD), + e_dagger_list(outputD_test$lt_hat %>% dplyr::arrange(Date,Sex,Age)), + tolerance = tolerance_admited + ) +}) + +# E - test with input lx, allowing cross-over, and NOT reproducing e0 at given years + +input_lx <- split(input, list(input$Date, input$Sex), drop = F) %>% + lapply(function(X){ + LT = lt_abridged(nMx = X[["nMx"]], + Age = X[["Age"]], + Sex = unique(X[["Sex"]])) + LT$Date = X$Date + LT$Sex = X$Sex + LT}) %>% + do.call("rbind", .) %>% + dplyr::select(Date, Sex, Age, lx) +# paste in spreadsheet: input_lx %>% tidyr::spread(Date,lx) %>% xlsx::write.xlsx("testD.xlsx") +outputE <- data.frame( + Sex = rep(c(rep("m",22),rep("f",22)),14), + Age = rep(c(0,1,seq(5,100,5)),14*2), + Date = sort(rep(seq(1953,2018,5), 22 * 2)), + lx=c(100000,83165,80358,79858,79453,78963,78206,77050,75407,73222,70301,67135,62313,56831,49626,40209,32109,22643,15918,10885,6821,3630, + 100000,84657,81137,80757,80485,80061,79534,78837,77906,76476,74632,72637,69462,65746,60148,51952,43509,30997,22436,16071,10770,6294, + 100000,86387,84068,83603,83210,82684,81872,80676,79019,76849,73961,70780,65998,60479,53196,43707,35197,25288,17946,12286,7648,4005, + 100000,87688,84873,84520,84257,83846,83335,82661,81762,80399,78621,76642,73527,69811,64225,56093,47425,34709,25421,18200,12053,6868, + 100000,89043,87144,86716,86339,85778,84916,83689,82034,79898,77071,73905,69207,63707,56423,46965,38128,27881,19969,13688,8463,4360, + 100000,90165,87934,87609,87357,86963,86473,85827,84966,83680,81984,80041,77017,73340,67824,59849,51057,38305,28376,20305,13284,7371, + 100000,91241,89696,89304,88945,88352,87442,86194,84552,82465,79718,76590,72011,66573,59346,50002,40911,30420,21983,15086,9265,4694, + 100000,92208,90450,90153,89914,89539,89071,88457,87640,86435,84829,82937,80024,76415,71015,63262,54430,41778,31290,22378,14458,7801, + 100000,93021,91770,91414,91074,90451,89497,88234,86615,84588,81936,78866,74431,69090,61970,52809,43533,32886,23972,16471,10045,5002, + 100000,93826,92449,92180,91955,91599,91156,90577,89805,88684,87174,85343,82557,79041,73794,66316,57518,45084,34126,24394,15557,8152, + 100000,94441,93435,93112,92792,92140,91145,89874,88286,86327,83779,80781,76509,71293,64320,55395,45996,35270,25929,17837,10802,5284, + 100000,95111,94038,93795,93583,93249,92831,92287,91562,90524,89111,87350,84699,81292,76223,69056,60352,48229,36882,26350,16581,8425, + 100000,95577,94769,94478,94178,93499,92465,91191,89638,87753,85315,82399,78302,73230,66433,57784,48314,37577,27854,19184,11535,5541, + 100000,96133,95300,95081,94882,94569,94176,93667,92988,92032,90715,89028,86517,83230,78355,71522,62958,51215,39554,28244,17529,8624, + 100000,96484,95838,95577,95295,94591,93519,92245,90733,88924,86598,83773,79856,74942,68342,59996,50500,39807,29746,20511,12244,5773, + 100000,96944,96299,96103,95917,95624,95257,94781,94148,93269,92046,90435,88064,84905,80235,73746,65360,54046,42140,30074,18401,8751, + 100000,97209,96693,96458,96196,95466,94358,93088,91618,89886,87673,84942,81208,76462,70073,62048,52565,41965,31605,21819,12928,5980, + 100000,97588,97089,96913,96741,96467,96124,95681,95092,94287,93153,91618,89387,86359,81898,75757,67577,56728,44639,31841,19198,8810, + 100000,97786,97375,97165,96920,96166,95023,93758,92332,90678,88577,85942,82391,77818,71649,63957,54519,44051,33431,23106,13589,6163, + 100000,98098,97713,97556,97396,97140,96820,96409,95862,95125,94077,92618,90522,87627,83377,77582,69629,59267,47051,33544,19920,8805, + 100000,98245,97918,97730,97503,96724,95546,94290,92909,91331,89339,86802,83430,79032,73090,65735,56370,46068,35223,24374,14225,6322, + 100000,98501,98204,98064,97915,97678,97380,96998,96491,95818,94851,93466,91501,88738,84697,79242,71530,61668,49378,35184,20569,8740, + 100000,98610,98350,98183,97971,97168,95956,94709,93373,91870,89985,87545,84348,80126,74412,67396,58127,48018,36981,25620,14838,6459, + 100000,98820,98591,98466,98328,98108,97831,97477,97007,96392,95501,94189,92349,89717,85881,80756,73296,63938,51619,36761,21145,8620, + 100000,98900,98694,98544,98348,97521,96275,95038,93747,92317,90534,88190,85164,81116,75629,68949,59797,49903,38705,26846,15426,6573, + 100000,99071,98895,98784,98656,98451,98194,97866,97432,96871,96051,94809,93088,90583,86948,82141,74940,66083,53776,38277,21652,8450, + 100000,99130,98966,98833,98651,97799,96520,95295,94047,92687,91003,88754,85891,82015,76755,70404,61385,51725,40395,28052,15990,6665, + 100000,99269,99134,99035,98917,98727,98488,98184,97783,97272,96517,95343,93736,91354,87913,83411,76472,68109,55851,39732,22090,8234) +) +outputE_test <- interp_lc_lim(input = input_lx, dates_out = seq(1953,2018,5)) +test_that("lc w lim data and nqx as input works", { + expect_equal( + e_dagger_list(outputE), + e_dagger_list(outputE_test$lt_hat %>% dplyr::arrange(Date,Sex,Age)), + tolerance = tolerance_admited + ) +}) + + +# F - testing args ------------------------------------------------------------ + +# single ages out +outputF1_test <- interp_lc_lim(input = input, dates_out = seq(1953,2018,5), + Single = T) + +# single out diff OAG +outputF2_test <- interp_lc_lim(input = input, dates_out = seq(1953,2018,5), + Single = T, extrapLaw = "makeham", OAnew = 100) + +# bunch of args +outputF3_test <- interp_lc_lim(input = input, dates_out = seq(1953,2018,5), + prev_divergence = T, + dates_e0 = unique(e0_swe$Date), + e0_Males = e0_swe$e0[e0_swe$Sex=="m"], + e0_Females = e0_swe$e0[e0_swe$Sex=="f"], + Single = T, verbose = F, SVD = T, + extrapLaw = "ggompertz", OAnew = 100) + +test_that("lc w lim data and nqx as input works", { + expect_length(unique(outputF1_test$lt_hat$Age), 101) + expect_s3_class(outputF3_test$lt_hat, "data.frame") + expect_length(unique(outputF2_test$lt_hat$Age), 101) + expect_length(outputF3_test$lt_hat$ex, 101 * 2 * length(seq(1953,2018,5))) +}) + +# G - mixing input -------------------------------------------------------- + +# some dates gives rates and some lx +input_mix1 <- rbind(input %>% + dplyr::filter(Date %in% dates_in[1:2]) %>% + mutate(lx = NA), + input_lx %>% + dplyr::filter(Date %in% dates_in[3:5]) %>% + mutate(nMx = NA) + ) +outputG1_test <- interp_lc_lim(input = input_mix1, dates_out = seq(1953,2018,5)) + +# some single and abr ages +input_single <- split(input, list(input$Date, input$Sex), drop = F) %>% + lapply(function(X){ + LT = lt_abridged2single(nMx = X[["nMx"]], + Age = X[["Age"]], + Sex = unique(X[["Sex"]]), + OAnew = 100) + LT$Date = unique(X$Date) + LT$Sex = unique(X$Sex) + LT}) %>% + do.call("rbind", .) %>% + dplyr::select(Date, Sex, Age, nMx) +input_mix2 <- rbind(input %>% + dplyr::filter(Date %in% dates_in[1:2]), + input_single %>% + dplyr::filter(Date %in% dates_in[3:5]) + ) +outputG2_test <- interp_lc_lim(input = input_mix2, dates_out = seq(1953,2018,5)) +outputG3_test <- interp_lc_lim(input = input_mix2, dates_out = seq(1953,2018,5), + Single = T) + +test_that("mixing inputs works", { + expect_s3_class(outputG1_test$lt_hat, "data.frame") + expect_true(all(outputG1_test$lt_hat$nMx > 0)) + expect_length(unique(outputG2_test$lt_hat$Age), 22) + expect_length(unique(outputG3_test$lt_hat$Age), 101) +}) + +# H - lt args ------------------------------------------------------------- + +# various comb args from lt functions +outputH1_test <- interp_lc_lim(input = input, dates_out = seq(1953,2018,5), + a0rule = "cd") +outputH2_test <- interp_lc_lim(input = input, dates_out = seq(1953,2018,5), + axmethod = "un") +outputH3_test <- interp_lc_lim(input = input, dates_out = seq(1953,2018,5), + region = "n") +outputH4_test <- interp_lc_lim(input = input, dates_out = seq(1953,2018,5), + extrapLaw = "makeham") +outputH5_test <- interp_lc_lim(input = input, dates_out = seq(1953,2018,5), + extrapLaw = "makeham", OAnew = 95) +outputH6_test <- interp_lc_lim(input = input, dates_out = seq(1953,2018,5), + extrapLaw = "gompertz", OAnew = 100, + extrapFrom = 60, extrapFit = seq(50,95,5), radix = 1) + +test_that("pass all lt args works", { +expect_s3_class(outputH1_test$lt_hat, "data.frame") +expect_s3_class(outputH2_test$lt_hat, "data.frame") +expect_s3_class(outputH3_test$lt_hat, "data.frame") +expect_s3_class(outputH4_test$lt_hat, "data.frame") +expect_s3_class(outputH5_test$lt_hat, "data.frame") +expect_s3_class(outputH6_test$lt_hat, "data.frame") + } +) + +# I - messages/warnings ------------------------------------------------------- + +test_that("mess and warns works", { + # need n(dates)>2 + expect_error(interp_lc_lim(input = input %>% dplyr::filter(Date %in% dates_in[1:2]), + dates_out = seq(1953,2018,5))) + # choose e0_dates for you + expect_error(interp_lc_lim(input = input, dates_out = seq(1953,2018,5), + # dates_e0 = unique(e0_swe$Date), + e0_Males = e0_swe$e0[e0_swe$Sex=="m"], + e0_Females = e0_swe$e0[e0_swe$Sex=="f"])) + + # need to rethink these: messages shifted elsewhere + # # tell me you´ll fit with gompertz in case max(Age) is <90 + # expect_output(interp_lc_lim(input = input %>% dplyr::filter(Age < 85), + # dates_out = seq(1953,2018,5)), + # regexp = "A Makeham function was fitted for older ages for sex ") + # # tell me you´ll fit with kannisto in case max(Age) is >=90 + # expect_output(interp_lc_lim(input = input, dates_out = seq(1953,2018,5)), + # regexp = "A Kannisto function was fitted for older ages for sex ") + + }) + + diff --git a/tests/testthat/test_mig_un_fam.R b/tests/testthat/test_mig_un_fam.R new file mode 100644 index 000000000..3f775e2d5 --- /dev/null +++ b/tests/testthat/test_mig_un_fam.R @@ -0,0 +1,275 @@ +context("test-mig_un_fam") + +# get data spreadsheet---------------------------------------------------------------- +UN_fam <- + data.frame( + Age = rep(seq(0,80,5),6), + Type = c(rep("Family Immigration",17), + rep("Male Labor Immigration",17), + rep("Female Labor Immigration",17), + rep("Family Emigration",17), + rep("Male Labor Emigration",17), + rep("Female Labor Emigration",17)), + Male = c(3082.9, +1339.8, +1027.1, +5237.0, +9426.2, +9059.2, +6861.3, +4758.8, +3195.5, +2120.5, +1401.2, +924.4, +609.6, +401.9, +264.9, +174.6, +115.1, +2136.3, +928.4, +1020.0, +7082.7, +12987.6, +12522.1, +9494.8, +6589.0, +4425.9, +2937.7, +1941.4, +1280.9, +844.7, +556.9, +367.1, +242.0, +159.6, +3945.5, +1714.7, +1029.8, +3513.1, +6102.1, +5827.5, +4403.8, +3050.9, +2047.3, +1358.0, +897.1, +591.7, +390.1, +257.2, +169.5, +111.8, +73.7, +-3082.9, +-1339.8, +-1027.1, +-5237.0, +-9426.2, +-9059.2, +-6861.3, +-4758.8, +-3195.5, +-2120.5, +-1401.2, +-924.4, +-609.6, +-401.9, +-264.9, +-174.6, +-115.1, +-2136.3, +-928.4, +-1020.0, +-7082.7, +-12987.6, +-12522.1, +-9494.8, +-6589.0, +-4425.9, +-2937.7, +-1941.4, +-1280.9, +-844.7, +-556.9, +-367.1, +-242.0, +-159.6, +-3945.5, +-1714.7, +-1029.8, +-3513.1, +-6102.1, +-5827.5, +-4403.8, +-3050.9, +-2047.3, +-1358.0, +-897.1, +-591.7, +-390.1, +-257.2, +-169.5, +-111.8, +-73.7), +Female = c( + 3080.3, + 1338.7, + 1095.0, + 5789.1, + 10073.8, + 9327.4, + 6803.1, + 4543.3, + 2937.5, + 1876.8, + 1194.0, + 758.5, + 481.5, + 305.7, + 194.0, + 123.1, + 78.2, + 2124.3, + 923.2, + 755.2, + 3992.5, + 6947.4, + 6432.7, + 4691.8, + 3133.3, + 2025.8, + 1294.4, + 823.5, + 523.1, + 332.1, + 210.8, + 133.8, + 84.9, + 53.9, + 3974.5, + 1727.3, + 1412.9, + 7469.8, + 12998.4, + 12035.4, + 8778.2, + 5862.3, + 3790.3, + 2421.7, + 1540.7, + 978.7, + 621.3, + 394.4, + 250.3, + 158.9, + 100.9, + -3080.3, + -1338.7, + -1095.0, + -5789.1, + -10073.8, + -9327.4, + -6803.1, + -4543.3, + -2937.5, + -1876.8, + -1194.0, + -758.5, + -481.5, + -305.7, + -194.0, + -123.1, + -78.2, + -2124.3, + -923.2, + -755.2, + -3992.5, + -6947.4, + -6432.7, + -4691.8, + -3133.3, + -2025.8, + -1294.4, + -823.5, + -523.1, + -332.1, + -210.8, + -133.8, + -84.9, + -53.9, + -3974.5, + -1727.3, + -1412.9, + -7469.8, + -12998.4, + -12035.4, + -8778.2, + -5862.3, + -3790.3, + -2421.7, + -1540.7, + -978.7, + -621.3, + -394.4, + -250.3, + -158.9, + -100.9) +) %>% + rename(Type=2, Age=1) %>% + as.data.table() %>% + data.table::melt(id.vars = c("Age","Type"), + measure.vars = c("Female","Male"), + variable.name = "Sex", + value.name = "Prop") %>% + .[, Prop := Prop / 1e5] + + +# test -------------------------------------------------------------------- + +tolerance_admited <- .005 +test_that("mig fam works", { + UN_fam <- UN_fam[Age < 80, ] + res1 <- mig_un_fam(NM = 1000, family = "Family", Single = FALSE)$net_migr + res1 <- res1[res1$age < 80, ] + + expect_equal( + res1$nm / 1000, + setDT(UN_fam)[Type == "Family Immigration", .(Prop)][[1]], + tolerance = tolerance_admited * 1000 + ) + + res2 <- mig_un_fam(NM = -1, family = "Female Labor", Single = FALSE)$net_migr + res2 <- res2[res2$age < 80, ] + + expect_equal( + res2$nm, + setDT(UN_fam)[Type == "Female Labor Emigration", .(Prop)][[1]], + tolerance = tolerance_admited + ) + + res3 <- mig_un_fam(NM = -100000, family = "Male Labor", Single = FALSE)$net_migr + res3 <- res3[res3$age < 80, ] + + expect_equal( + res3$nm, + setDT(UN_fam)[Type == "Male Labor Emigration", .(Prop)][[1]] * 100000, + tolerance = tolerance_admited * 100000 + ) + +}) + +test_that("mig_fam works with OAnew", { + + # Run mig_un_fam with all single ages + unconstrained <- mig_un_fam(NM = 1000, family = "Family", OAnew = 120)$net_migr + # Run with open age group at 100 + constrained <- mig_un_fam(NM = 1000, family = "Family", OAnew = 100)$net_migr + + # Make sure both calculates sum up to the same when comparing + # all values above 99 + total_above_100 <- round(sum(unconstrained[age > 99, nm]), 4) + summed_above_100 <- round(sum(constrained[age == 100, nm]), 4) + expect_true(total_above_100 == summed_above_100) + +}) diff --git a/tic.R b/tic.R deleted file mode 100644 index 492701dc3..000000000 --- a/tic.R +++ /dev/null @@ -1,8 +0,0 @@ -# installs dependencies, runs R CMD check, runs covr::codecov() -do_package_checks() - -if (ci_on_ghactions() && ci_has_env("BUILD_PKGDOWN")) { - # creates pkgdown site and pushes to gh-pages branch - # only for the runner with the "BUILD_PKGDOWN" env var set - do_pkgdown() -} diff --git a/vignettes/REFERENCES.bib b/vignettes/REFERENCES.bib index 2145f3788..d7b71a7b7 100644 --- a/vignettes/REFERENCES.bib +++ b/vignettes/REFERENCES.bib @@ -201,6 +201,232 @@ @article{bachi1951tendency Year = {1951}} @article{spoorenberg2007quality, + title={Quality of age reporting: extension and application of the modified Whipple's index}, + author={Spoorenberg, Thomas and Dutreuilh, Catriona}, + journal={Population}, + volume={62}, + number={4}, + pages={729--741}, + year={2007}, + publisher={INED} +} + +@Book{arriaga1994population, + Title = {Population analysis with microcomputers}, + Author = {Arriaga, Eduardo E and Johnson, Peter D and Jamison, Ellen}, + Publisher = {Bureau of the Census}, + Year = {1994}, + Volume = {1} +} + +@Article{beers1945modified, + Title = {Modified-interpolation formulas that minimize fourth differences}, + Author = {Beers, HS}, + Journal = {Record of the American Institute of Actuaries}, + Year = {1945}, + Number = {69}, + Pages = {14--20}, + Volume = {34} +} + +@InCollection{booth2015demographic, + Title = {Demographic techniques, data adjustment and correction}, + Author = {Booth, Heather and others}, + Booktitle = {International Encyclopedia of the Social and Behavioral Sciences (2015)}, + Publisher = {Elsevier}, + Year = {2015}, + + Address = {Oxford}, + Edition = {2}, + Editor = {James E. Wright}, + Volume = {6} +} + +@Article{feeney1979, + Title = {A technique for correcting age distributions for heaping on multiples of five}, + Author = {Feeney, G}, + Journal = {Asian and Pacific Census Forum}, + Year = {1979}, + Number = {3}, + Pages = {12--15}, + Volume = {5} +} + +@Article{fritsch1980monotone, + Title = {Monotone piecewise cubic interpolation}, + Author = {Fritsch, Frederick N and Carlson, Ralph E}, + Journal = {SIAM Journal on Numerical Analysis}, + Year = {1980}, + Number = {2}, + Pages = {238--246}, + Volume = {17}, + + Publisher = {SIAM} +} + +@Article{gray1987missingages, + Title = {The Missing Ages: Adjusting for Digit Preferences}, + Author = {Gray, A}, + Journal = {Asian and Pacific Population Forum}, + Year = {1987}, + Number = {2}, + Pages = {11--22}, + Volume = {1} +} + +@InCollection{greville1977short, + Title = {Short methods of constructing abridged life tables}, + Author = {Greville, Thomas NE}, + Booktitle = {Mathematical Demography}, + Publisher = {Springer}, + Year = {1977}, + Pages = {53--60} +} + +@InProceedings{dasgupta1955, + Title = {Accuracy index of census age distributions}, + Author = {Ajit Das Gupta}, + Booktitle = {United Nations proceedings of the World Population Conference 1954 (Rome)}, + Year = {1955}, + + Address = {New York}, + Pages = {63--74}, + Volume = {IV} +} + +@InProceedings{ramachandran1967, + Title = {An Index to Measure Digit Preference Error in Age Data}, + Author = {K. V. Ramachandran}, + Booktitle = {United Nations, Proceedings of the World Population Conference, 1965 (Belgrade)}, + Year = {1967}, + + Address = {New York}, + Pages = {202--203}, + Volume = {III} +} + + +@Book{GDA1981IREDA, + Title = {Les structures par sexe et {\^a}ge en Afrique}, + Author = {Roger, G and Waltisperger, D and Corbille-Guitton, Ch}, + Publisher = {GDA}, + Year = {1981}, + + Address = {Paris, France} +} + +@Article{sprague1880explanation, + Title = {Explanation of a new formula for interpolation}, + Author = {Sprague, Thomas Bond}, + Journal = {Journal of the Institute of Actuaries}, + Year = {1880}, + Number = {4}, + Pages = {270--285}, + Volume = {22}, + + Publisher = {Cambridge University Press} +} + +@Article{stover2008spectrum, + Title = {The Spectrum projection package: improvements in estimating mortality, ART needs, PMTCT impact and uncertainty bounds}, + Author = {Stover, J and Johnson, P and Zaba, B and Zwahlen, M and Dabis, F and Ekpini, RE}, + Journal = {Sexually Transmitted Infections}, + Year = {2008}, + Number = {Suppl 1}, + Pages = {i24--i30}, + Volume = {84}, + + Publisher = {The Medical Society for the Study of Venereal Disease} +} + +@Book{mortpak1988, + Title = {Mortpak- The United Nations Software Package for Mortality Measurement}, + Author = {{United Nations}}, + Publisher = {United Nations Department of International Economic and Social Affairs}, + Year = {1988}, + + Owner = {tim}, + Timestamp = {2017.08.16} +} + +@Book{united1955manual, + Title = {Manual II: Methods of Appraisal of Quality of Basic Data for Population Estimates}, + Author = {{United Nations}}, + Publisher = {United Nations Department of International Economic and Social Affairs}, + Year = {1955}, + + Address = {New York}, + Number = {23} +} + + +@Book{united1983manual, + Title = {Manual X: Indirect Techniques for Demographic Estimation}, + Author = {{United Nations}}, + Publisher = {United Nations Department of International Economic and Social Affairs}, + Year = {1983}, + + Address = {New York}, + Number = {81} +} + +@Book{un1982model, + Title = {Model Life Tables for Developing Countries}, + Author = {{United Nations}}, + Publisher = {United Nations Department of International Economic and Social Affairs}, + Year = {1982}, + + Owner = {tim}, + Timestamp = {2017.08.15} +} + +@Article{accuracyun1952, + Title = {Accuracy tests for census age distributions tabulated in five-year and ten-year groups}, + Author = {{United Nations}}, + Journal = {Population Bulletin}, + Year = {1952}, + Number = {2}, + Pages = {59--79} +} + +@Book{Shryock1973, + title = {The methods and materials of demography}, + publisher = {US Bureau of the Census}, + year = {1973}, + editor = {Shryock, Henry S and Siegel, Jacob S and Larmon, Elizabeth A}, +} + +@Book{siegel2004methods, + Title = {The Methods and Materials of Demography}, + Editor = {Siegel Jacob, S and Swanson David, A}, + Publisher = {Elsevier Academic Press, California, USA}, + Year = {2004}, + + Address = {San Diego, USA}, + Edition = {2} +} + +@Misc{PAS, + author = {{United States Census Bureau}}, + title = {Population Analysis System (PAS) Software}, + month = nov, + year = {2017}, + url = {https://www.census.gov/data/software/pas.html}, +} + +@Article{Vito2008, + title = {segmented: an R Package to Fit Regression Models with Broken-Line Relationships.}, + author = {Vito M.R. Muggeo}, + journal = {R News}, + year = {2008}, + volume = {8}, + number = {1}, + pages = {20--25}, + url = {https://cran.r-project.org/doc/Rnews/}, + } + +@Comment{jabref-meta: databaseType:bibtex;} +======= Author = {Spoorenberg, Thomas and Dutreuilh, Catriona}, Journal = {Population}, Number = {4}, diff --git a/vignettes/migration_with_demotools.Rmd b/vignettes/migration_with_demotools.Rmd index 331d04a2a..6ee13469f 100644 --- a/vignettes/migration_with_demotools.Rmd +++ b/vignettes/migration_with_demotools.Rmd @@ -166,7 +166,7 @@ df %>% Let's fit a Rogers-Castro migration age schedule to these data. Below, we choose to estimate parameters associated with the pre-working age, working and retirement components (but not post retirement). -```{r, eval = TRUE} +```{r, eval = FALSE} rc_res <- mig_estimate_rc( ages, mx_FL_sim, @@ -188,12 +188,12 @@ The resulting `rc_res` object is shown below. The `pars_df` shows the median est The `fit_df` object in `rc_res` shows the data and estimated median $m(x)$ values at each age $x$, along with the lower and upper bound of the 95% credible interval of the fits, and the squared difference between data and the median estimate. -```{r} +```{r, eval = FALSE} rc_res ``` We can plot the observed data and estimated fit using the `fit_df` object: -```{r} +```{r, eval = FALSE} rc_res[["fit_df"]] %>% ggplot(aes(ages, data)) + geom_point(aes(color = "data")) +