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/.gitignore b/.github/.gitignore new file mode 100644 index 000000000..2d19fc766 --- /dev/null +++ b/.github/.gitignore @@ -0,0 +1 @@ +*.html diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml new file mode 100644 index 000000000..ff26be5c5 --- /dev/null +++ b/.github/workflows/R-CMD-check.yaml @@ -0,0 +1,135 @@ +# For help debugging build failures open an issue on the RStudio community with the 'github-actions' tag. +# https://community.rstudio.com/new-topic?category=Package%20development&tags=github-actions +on: + push: + branches: + - main + - master + pull_request: + branches: + - main + - master + schedule: + - cron: "0 0 * * *" + + +name: R-CMD-check + +jobs: + R-CMD-check: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - {os: windows-latest, r: 'release'} + - {os: macOS-latest, r: 'release'} + - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} + + env: + R_REMOTES_NO_ERRORS_FROM_WARNINGS: true + RSPM: ${{ matrix.config.rspm }} + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + # prevent rgl issues because no X11 display is available + RGL_USE_NULL: true + + steps: + - uses: actions/checkout@v2 + - uses: r-lib/actions/setup-r@v1 + with: + r-version: ${{ matrix.config.r }} + - uses: r-lib/actions/setup-pandoc@v1 + + - name: Query dependencies + run: | + install.packages('remotes') + saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) + writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") + shell: Rscript {0} + + - name: Cache R packages + if: runner.os != 'Windows' + uses: actions/cache@v2 + with: + path: ${{ env.R_LIBS_USER }} + # 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 install xquartz + + # Adds manual deps to rgl in first line + - name: Linux dependencies + if: runner.os == 'Linux' + run: | + sudo apt-get install libglu1-mesa-dev libv8-dev + while read -r cmd + do + eval sudo $cmd + done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "20.04"))') + + # To install rgl successfully in non-windows OS we need to export DISPLAY + - name: Install packages not windows + if: runner.os != 'Windows' + run: | + export DISPLAY=:99 + Rscript -e 'remotes::install_deps(dependencies = TRUE); remotes::install_cran("rcmdcheck")' + + - name: Install packages windows + if: runner.os == 'Windows' + 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 + # in the check as well (this is also present for installing) + - name: Check in macOS/Linux + if: runner.os != 'Windows' + env: + _R_CHECK_CRAN_INCOMING_REMOTE_: false + run: | + export DISPLAY=:99 + Rscript -e 'rcmdcheck::rcmdcheck(args = c("--no-manual"), error_on = "warning", check_dir = "check")' + + - name: Check in Windows + if: runner.os == 'Windows' + env: + _R_CHECK_CRAN_INCOMING_REMOTE_: false + run: rcmdcheck::rcmdcheck(args = c("--no-manual"), error_on = "warning", check_dir = "check") + shell: Rscript {0} + + # To make things simple we only run code coverage on linux + # because rstan generates problems installing + - name: Test coverage + if: runner.os == 'Linux' + run: covr::codecov() + shell: Rscript {0} + + # To make things simpler, limit pkgdown deploy only to one OS + # Why export DISPLAY? Search for this term throughout this file + # for thorough explanation. + - name: Deploy package website to pkgdown + if: runner.os == 'Linux' + run: | + export DISPLAY=:99 + R CMD INSTALL . + git config --local user.email "actions@github.com" + git config --local user.name "GitHub Actions" + Rscript -e 'install.packages("pkgdown"); pkgdown::deploy_to_branch(new_process = FALSE)' + + - name: Upload check results + if: failure() + uses: actions/upload-artifact@main + with: + name: ${{ runner.os }}-r${{ matrix.config.r }}-results + path: check diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml deleted file mode 100644 index 19df81d4e..000000000 --- a/.github/workflows/main.yml +++ /dev/null @@ -1,211 +0,0 @@ -## tic GitHub Actions template: linux-macos-windows-deploy -## revision date: 2020-05-21 -on: - push: - pull_request: - # for now, CRON jobs only run on the default branch of the repo (i.e. usually on master) - schedule: - # * is a special character in YAML so you have to quote this string - - cron: "0 4 * * *" - -name: R CMD Check via {tic} - -jobs: - R-CMD-check: - runs-on: ${{ matrix.config.os }} - - name: ${{ matrix.config.os }} (${{ matrix.config.r }}) - - strategy: - fail-fast: false - matrix: - config: - # use a different tic template type if you do not want to build on all listed platforms - - { os: windows-latest, r: "release" } - - { os: macOS-latest, r: "release", pkgdown: "true" } - # - { os: macOS-latest, r: "devel" } - - { os: ubuntu-latest, r: "release" } - - env: - # otherwise remotes::fun() errors cause the build to fail. Example: Unavailability of binaries - R_REMOTES_NO_ERRORS_FROM_WARNINGS: true - CRAN: ${{ matrix.config.cran }} - # we are not allowed to write to ~/.ccache on GH Actions - # setting some ccache options - CCACHE_BASEDIR: ${{ GITHUB.WORKSPACE }} - CCACHE_DIR: ${{ GITHUB.WORKSPACE }}/.ccache - CCACHE_NOHASHDIR: true - CCACHE_SLOPPINESS: include_file_ctime - # make sure to run `tic::use_ghactions_deploy()` to set up deployment - TIC_DEPLOY_KEY: ${{ secrets.TIC_DEPLOY_KEY }} - # prevent rgl issues because no X11 display is available - RGL_USE_NULL: true - # if you use bookdown or blogdown, replace "PKGDOWN" by the respective - # capitalized term. This also might need to be done in tic.R - BUILD_PKGDOWN: ${{ matrix.config.pkgdown }} - # macOS >= 10.15.4 linking - SDKROOT: /Library/Developer/CommandLineTools/SDKs/MacOSX.sdk - # use GITHUB_TOKEN from GitHub to workaround rate limits in {remotes} - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - - steps: - - uses: actions/checkout@v2.1.1 - - - uses: r-lib/actions/setup-r@master - with: - r-version: ${{ matrix.config.r }} - Ncpus: 4 - - # LaTeX. Installation time: - # Linux: ~ 1 min - # macOS: ~ 1 min 30s - # Windows: never finishes - - uses: r-lib/actions/setup-tinytex@v1 - if: runner.os != 'Windows' - - - uses: r-lib/actions/setup-pandoc@master - - # set date/week for use in cache creation - # https://github.community/t5/GitHub-Actions/How-to-set-and-access-a-Workflow-variable/m-p/42970 - # - cache R packages daily - # - cache ccache weekly -> 'ccache' helps rebuilding the package cache faster - - name: "[Cache] Prepare daily timestamp for cache" - if: runner.os != 'Windows' - id: date - run: echo "::set-output name=date::$(date '+%d-%m')" - - - name: "Set CRAN repo in .Rprofile" - run: echo "options(repos = c(CRAN = 'https://cran.rstudio.com'))" >.Rprofile - - - name: "Install XQuartz on macOS" - if: runner.os == 'macOS' - run: brew cask install xquartz - - - name: "[Cache] Prepare weekly timestamp for cache" - if: runner.os != 'Windows' - id: datew - run: echo "::set-output name=datew::$(date '+%Y-%V')" - - - name: "[Cache] Cache R packages" - if: runner.os != 'Windows' - uses: pat-s/always-upload-cache@v1.2.0 - with: - path: ${{ env.R_LIBS_USER }} - key: ${{ runner.os }}-r-${{ matrix.config.r }}-${{steps.date.outputs.date}} - restore-keys: ${{ runner.os }}-r-${{ matrix.config.r }}-${{steps.date.outputs.date}} - - - name: "[Cache] Cache ccache" - if: runner.os != 'Windows' - uses: pat-s/always-upload-cache@v1.2.0 - with: - path: ${{ env.CCACHE_DIR}} - key: ${{ runner.os }}-r-${{ matrix.config.r }}-ccache-${{steps.datew.outputs.datew}} - restore-keys: ${{ runner.os }}-r-${{ matrix.config.r }}-ccache-${{steps.datew.outputs.datew}} - - # install ccache and write config file - - name: "[Linux] ccache" - if: runner.os == 'Linux' - run: | - sudo apt install ccache libcurl4-openssl-dev - mkdir -p ~/.R && echo -e 'CC=ccache gcc -std=gnu99\nCXX=ccache g++\nFC=ccache gfortran\nF77=ccache gfortran' > $HOME/.R/Makevars - - # This is for rgl and x8 - - name: "[Linux] external software" - if: runner.os == 'Linux' - run: | - sudo apt-get install libglu1-mesa-dev libv8-dev - - # install ccache and write config file - # mirror the setup described in https://github.com/rmacoslib/r-macos-rtools - - name: "[macOS] ccache" - if: runner.os == 'macOS' && matrix.config.r == 'devel' - run: | - brew install ccache - # install SDK 10.13 (High Sierra, used by CRAN) - wget -nv https://github.com/phracker/MacOSX-SDKs/releases/download/10.15/MacOSX10.13.sdk.tar.xz - tar fxz MacOSX10.13.sdk.tar.xz - sudo mv MacOSX10.13.sdk /Library/Developer/CommandLineTools/SDKs/ - rm -rf MacOSX10.13* - # install gfortran 8.2 (used by CRAN) - wget -nv https://github.com/fxcoudert/gfortran-for-macOS/releases/download/8.2/gfortran-8.2-Mojave.dmg - sudo hdiutil attach gfortran*.dmg - sudo installer -package /Volumes/gfortran*/gfortran*/gfortran*.pkg -target / - sudo hdiutil detach /Volumes/gfortran-8.2-Mojave - rm gfortran-8* - # set compiler flags - mkdir -p ~/.R && echo -e 'CC=ccache clang\nCPP=ccache clang\nCXX=ccache clang++\nCXX11=ccache clang++\nCXX14=ccache clang++\nCXX17=ccache clang++\nCFLAGS=-isysroot /Library/Developer/CommandLineTools/SDKs/MacOSX10.13.sdk\nCCFLAGS=-isysroot /Library/Developer/CommandLineTools/SDKs/MacOSX10.13.sdk\nCXXFLAGS=-isysroot /Library/Developer/CommandLineTools/SDKs/MacOSX10.13.sdk\nCPPFLAGS=-isysroot /Library/Developer/CommandLineTools/SDKs/MacOSX10.13.sdk -I/usr/local/include\nF77=ccache /usr/local/gfortran/bin/gfortran\nFC=ccache /usr/local/gfortran/bin/gfortran' > $HOME/.R/Makevars - - # for some strange Windows reason this step and the next one need to be decoupled - - name: "[Stage] Prepare" - run: | - Rscript -e "if (!requireNamespace('gert')) install.packages('gert', type = 'source')" - Rscript -e "if (!requireNamespace('remotes')) install.packages('remotes', type = 'source')" - Rscript -e "if (!requireNamespace('usethis')) install.packages('usethis', type = 'source')" - Rscript -e "if (getRversion() < '3.2' && !requireNamespace('curl')) install.packages('curl', type = 'source')" - # Rscript -e "remove.packages('rstan'); if (file.exists('.RData')) file.remove('.RData'); install.packages('rstan', repos = 'https://cloud.r-project.org/', dependencies = TRUE)" - - - # Windows cannot have export DISPLAY=:99 - - name: "[Stage] Install - Windows" - if: runner.os == 'Windows' - run: | - Rscript -e "remotes::install_github('ropensci/tic')" -e "print(tic::dsl_load())" -e "tic::prepare_all_stages()" -e "tic::before_install()" -e "tic::install()" - - - name: "[Stage] Install - other OS" - if: runner.os != 'Windows' - run: | - export DISPLAY=:99 - Rscript -e "remotes::install_github('ropensci/tic')" -e "print(tic::dsl_load())" -e "tic::prepare_all_stages()" -e "tic::before_install()" -e "tic::install()" - - # macOS devel needs its own stage because we need to work with an option to suppress the usage of binaries - - name: "[Stage] Prepare & Install (macOS-devel)" - if: matrix.config.os == 'macOS-latest' && matrix.config.r == 'devel' - run: | - export DISPLAY=:99 - echo -e 'options(Ncpus = 4, pkgType = "source", repos = structure(c(CRAN = "https://cloud.r-project.org/")))' > $HOME/.Rprofile - Rscript -e "remotes::install_github('ropensci/tic')" -e "print(tic::dsl_load())" -e "tic::prepare_all_stages()" -e "tic::before_install()" -e "tic::install()" - - # macOS needs DISPLAY=:99 to fix rgl installation - - name: "[Stage] Script - macOS" - if: runner.os == 'macOS' - run: | - export DISPLAY=:99 - Rscript -e 'tic::script()' - - - name: "[Stage] Script - other OS" - if: runner.os != 'macOS' - run: Rscript -e 'tic::script()' - - - name: "[Stage] After Success - other OS" - if: matrix.config.os != 'macOS-latest' && matrix.config.r != 'release' - run: | - Rscript -e "tic::after_success()" - - - name: "[Stage] After Success - macOS devel" - if: matrix.config.os == 'macOS-latest' && matrix.config.r == 'release' - run: | - export DISPLAY=:99 - Rscript -e "tic::after_success()" - - - name: "[Stage] Upload R CMD check artifacts" - if: failure() - uses: actions/upload-artifact@master - with: - name: ${{ runner.os }}-r${{ matrix.config.r }}-results - path: check - - name: "[Stage] Before Deploy" - run: | - Rscript -e "tic::before_deploy()" - - - name: "[Stage] Deploy - other OS" - if: matrix.config.os != 'macOS-latest' && matrix.config.r != 'release' - run: Rscript -e "tic::deploy()" - - - name: "[Stage] Deploy - macOS devel" - if: matrix.config.os == 'macOS-latest' && matrix.config.r == 'release' - run: | - export DISPLAY=:99 - Rscript -e "tic::deploy()" - - - name: "[Stage] After Deploy" - run: Rscript -e "tic::after_deploy()" diff --git a/.gitignore b/.gitignore index 17e013469..6580fc6a8 100644 --- a/.gitignore +++ b/.gitignore @@ -20,3 +20,4 @@ Spreadsheets *.o *.so docs/ +.RData diff --git a/DESCRIPTION b/DESCRIPTION index 0cb6491bd..331e09950 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: DemoTools Type: Package Title: Standardize, Evaluate, and Adjust Demographic Data -Version: 01.11.000 -Date: 2021-01-03 +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 1d1afb151..d74f2cdc8 100644 --- a/R/OPAG.R +++ b/R/OPAG.R @@ -1,17 +1,27 @@ # TODO / wish-list # [ ] All choice of Age_fit / AgeInt_fit based on criteria (see PJ Drive folder) -# [ ] ensure age groups are flexible as required. +# [ ] 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 +# The PAS implementation uses stable populations, and it will be added +# 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 @@ -69,16 +79,19 @@ OPAG_simple <- StPop, StAge, OAnew = max(StAge)) { - # assume single - stopifnot(is_single(Age)) - stopifnot(is_single(StAge)) + # # 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 stopifnot(OAnow %in% Age) + 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) @@ -91,7 +104,7 @@ OPAG_simple <- 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 @@ -108,19 +121,17 @@ 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 -#' assuming it's stationary and can be warped into stable. For the oldest ages, this is probably +#' @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 `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`. +#' @return numeric vector of the transformed `nLx`. Note, this vector sums to `1`. #' @export #' @examples #' Lx <- downloadnLx(NULL, "Spain","female",1971) @@ -132,49 +143,42 @@ OPAG_simple <- #' lines(Age,OPAG_nLx_warp_r(Lx,Age,0.005)/ai,type='s',col = "red") #' lines(Age,OPAG_nLx_warp_r(Lx,Age,-0.005)/ai,type='s',col = "blue") #' } -#' +#' -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 + 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 } - wLx <- wLx / sum(wLx) - if (is.null(AgeInt)){ - AgeInt <- age2int(Age, OAvalue = 1) - } - 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 @@ -186,24 +190,24 @@ OPAG_nLx_warp_r <- function(nLx, #' nLx <- downloadnLx(NULL, "Spain","female",1971) #' Age_nLx <- names2age(nLx) #' r <- .01 -#' -#' OPAG_r_min(r, -#' Pop_fit, -#' Age_fit, +#' +#' OPAG_r_min(r, +#' Pop_fit, +#' Age_fit, #' AgeInt_fit, -#' nLx, +#' nLx, #' Age_nLx) -#' -#' (r_opt <- optimize(OPAG_r_min, +#' +#' (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))$min) -#' +#' #' ai <- age2int(Age_nLx) -#' +#' #' # Note the whole age range is being scaled to 1 here, but in practice #' # you'd only be doing this in the highest ages. If only two fitting #' # ages are given, then we can get an r that matches them perfectly, @@ -213,55 +217,36 @@ OPAG_nLx_warp_r <- function(nLx, #' lines(Age,OPAG_nLx_warp_r(Lx,Age,r=r_opt)/ai,type='s',col = "red") #' } -OPAG_r_min <- function(r, - Pop_fit, - Age_fit, +OPAG_r_min <- function(r, + 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) - - # now need to get it to the same age groups as Pop + 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 @@ -270,53 +255,51 @@ OPAG_r_min <- function(r, #' 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 +#' @return #' list constaining -#' 1. `Standard` numeric vector, the transformed `nLx` to be used for +#' 1. `Standard` numeric vector, the transformed `nLx` to be used for #' redistribution in `OPAG()` #' 2. r_opt the output of `optimize()`, where `min` is the growth parameter, `r` #' @export #' @importFrom stats optimize -#' -#' @examples +#' +#' @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) -#' +#' #' # India Males, 1991 #' Pop <- smooth_age_5(pop1m_ind, #' Age = 0:100, #' method = "Arriaga") #' Pop80 <- groupOAG(Pop, names2age(Pop), 80) #' Age <- names2age(Pop80) -#' AgeInt <- age2int(Age, OAvalue = 1) -#' +#' #' nLx <- downloadnLx(NULL, "India","male",1991) #' 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) #' AgeInt_fit <- c(10,10) -#' +#' #' Standard <- OPAG_fit_stable_standard( #' 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]) +#' nL60 <- rescale_vector(nLx[Age_nLx >= 60]) #' St60p <- rescale_vector( Standard$Standard[Age_nLx >= 60] ) #' ages_plot <- seq(60,100,by=5) #' \dontrun{ @@ -327,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, + 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)) + Lx1 = Lx1, + Age_Lx1 = Age_Lx1, + interval = c(-0.02, .05)) # changed interval - - standard <- OPAG_nLx_warp_r(nLx = nLx, - Age = Age_nLx, - r = r_opt$min, - AgeInt = AgeInt_nLx, - continuous = continuous, - method = method) + + 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, @@ -358,30 +337,24 @@ OPAG_fit_stable_standard <- function(Pop_fit, } #' Redistribute population over a specified age based on a stable standard fit to the data -#' @description This can be used as an external check of population counts -#' in older ages, assuming the stable population standard is representative enough, or it can be used to redistribute population in ages above a -#' specified ages `Redistribute_from`. This is handy, for instance, for -#' ensuring all censuses extend to a specified maximum age (e.g. 100+) +#' @description This can be used as an external check of population counts +#' in older ages, assuming the stable population standard is representative enough, or it can be used to redistribute population in ages above a +#' specified ages `Redistribute_from`. This is handy, for instance, for +#' ensuring all censuses extend to a specified maximum age (e.g. 100+) #' prior to intercensal interpolations. The assumption is that, at least in -#' ages including `Age_fit` and higher ages, the population should follow -#' a stable pattern proportional to a given survival curve subject to +#' ages including `Age_fit` and higher ages, the population should follow +#' a stable pattern proportional to a given survival curve subject to #' constant growth, `r`. -#' @details It may be helpful to try more than one fitting possibility, +#' @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 -#' it ahead of time. For this, you'd want the `nMx` the underly it, and you -#' can use `lt_abridged()`, specifying a higher open age, and then -#' extracting `nLx` again from it. -#' +#' +#' `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 +#' it ahead of time. For this, you'd want the `nMx` the underly it, and you +#' can use `lt_abridged()`, specifying a higher open age, and then +#' extracting `nLx` again from it. +#' #' @inheritParams OPAG_r_min #' @param Pop numeric vector of population counts #' @param Age_Pop integer vector of the lower bounds of the population age groups @@ -395,14 +368,14 @@ OPAG_fit_stable_standard <- function(Pop_fit, #' Age = 0:100, #' method = "Arriaga") #' Age_Pop <- names2age(Pop) -#' AgeInt_Pop <- age2int(Age_Pop, OAvalue = 1) -#' +#' AgeInt_Pop <- age2int(Age_Pop, OAvalue = 1) +#' #' nLx <- downloadnLx(NULL, "India","male",1991) #' Age_nLx <- names2age(nLx) #' AgeInt_nLx <- age2int(Age_nLx, OAvalue = 1) -#' -#' Pop_fit <- OPAG(Pop, -#' Age_Pop = Age_Pop, +#' +#' Pop_fit <- OPAG(Pop, +#' Age_Pop = Age_Pop, #' AgeInt_Pop = AgeInt_Pop, #' nLx = nLx, #' Age_nLx = Age_nLx, @@ -410,39 +383,68 @@ OPAG_fit_stable_standard <- function(Pop_fit, #' Age_fit = c(60,70), #' AgeInt_fit = c(10,10), #' Redistribute_from = 80) -#' +#' #' \dontrun{ #' # look at 75+ #' ind <- Age_Pop >= 75 #' plot(Age_Pop[ind], Pop[ind]) #' lines(Age_Pop[ind], Pop_fit$Pop_out[ind], col = "blue") -#' +#' #' # relative differences in ages 80+ #' ind <- Age_Pop >= 80 #' plot(Age_Pop[ind], (Pop_fit$Pop_out[ind] - Pop[ind]) / Pop[ind]) #'} -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){ +OPAG <- function(Pop, + 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 @@ -454,48 +456,53 @@ OPAG <- function(Pop, 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_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, + 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 83c78d401..6717eb73e 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 cf2bd46d1..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,33 +179,48 @@ 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 # model overwriting of rates. stopifnot(extrapFrom <= max(Age)) - # TR: should we really be this strict? - stopifnot(OAnew <= 110) # need to make it possible to start w (D,E), M, q or l... # TR: make sure IMR propagates @@ -215,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 } @@ -250,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, @@ -263,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... @@ -296,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, @@ -394,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 423850840..81d31490f 100644 --- a/R/smooth_age_5.R +++ b/R/smooth_age_5.R @@ -1,10 +1,13 @@ +# TODO: add start_on arg to Arriaga and Strong methods, and make sure it's handled in smooth_age_5() + #' The Carrier-Farrag method of population count smoothing #' @description Smooth population counts in 5-year age groups. #' @details This method does not account for ages < 10 nor for the 10 year age interval prior to the open age group. These are returned imputed with \code{NA}. Age classes must be cleanly groupable to 5-year age groups. Smoothed counts are constrained to sum to original totals in 10-year age groups. #' @param Value numeric vector of counts in single, abridged, or 5-year age groups. #' @param Age numeric 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}. +#' @param start_on integer. Either 0 or 5. Do we constrain decades starting on the 0s or 5s? #' @return numeric vector of smoothed counts in 5-year age groups. #' @export #' @examples @@ -27,7 +30,8 @@ smooth_age_5_cf <- function(Value, Age, - OAG = TRUE) { + OAG = TRUE, + start_on = 0) { # these values are not used, it's just for lengths, and to make sure we # end on an even 10. Technically we could even provide data in 10-year @@ -40,13 +44,16 @@ smooth_age_5_cf <- function(Value, # would need to move this up to ensure? # or in case of 85+ would we want to keep 80-84, 85+ as-is? - Value10 <- groupAges(Value, Age = Age, N = 10) + Value10 <- groupAges(Value, Age = Age, N = 10, shiftdown = start_on) # what OAG is a strange digit? Then take OAG after grouping. if (OAG) { - OAGvalue <- Value10[length(Value10)] + #OAGvalue <- Value10[length(Value10)] Value10[length(Value10)] <- NA } + if (start_on == 5){ + Value10[1] <- NA + } v10R <- shift.vector(Value10, 1, fill = NA) v10L <- shift.vector(Value10,-1, fill = NA) @@ -56,6 +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] @@ -69,6 +81,7 @@ smooth_age_5_cf <- function(Value, #' @param Value numeric vector of counts in single, abridged, or 5-year age groups. #' @param Age numeric 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}. +#' @param start_on integer. Either 0 or 5. Do we constrain decades starting on the 0s or 5s? #' @return numeric vector of smoothed counts in 5-year age groups. #' @export #' @examples @@ -88,7 +101,8 @@ smooth_age_5_cf <- function(Value, smooth_age_5_kkn <- function(Value, Age, - OAG = TRUE) { + OAG = TRUE, + start_on = 0) { # these values are not used, it's just for lengths, and to make sure we # end on an even 10. Technically we could even provide data in 10-year @@ -101,12 +115,15 @@ smooth_age_5_kkn <- function(Value, # would need to move this up to ensure? # or in case of 85+ would we want to keep 80-84, 85+ as-is? - Value10 <- groupAges(Value, Age = Age, N = 10) + Value10 <- groupAges(Value5, Age = Age, N = 10, shiftdown = start_on) # what OAG is a strange digit? Then take OAG after grouping. if (OAG) { - OAGvalue <- Value10[length(Value10)] - Value10[length(Value10)] <- NA + #OAGvalue <- Value10[length(Value10)] + Value10[length(Value10)] <- NA + } + if (start_on == 5){ + Value10[1] <- NA } v10R <- shift.vector(Value10, 1, fill = NA) @@ -116,8 +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)) @@ -412,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 @@ -436,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)) @@ -449,7 +489,8 @@ smooth_age_5_mav <- function(Value, Value = Value, Age = Age, OAG = OAG, - n = n + n = n, + tails = tails ) Smoothed @@ -585,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 @@ -597,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. #' @@ -610,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. @@ -726,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", @@ -736,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) @@ -828,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 @@ -847,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 @@ -870,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 808bb0681..df768eb4f 100644 --- a/README.md +++ b/README.md @@ -2,14 +2,16 @@ # DemoTools -![R CMD Check via {tic}](https://github.com/timriffe/DemoTools/workflows/R%20CMD%20Check%20via%20%7Btic%7D/badge.svg) +[![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.000-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-03 +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 2fd50382e..cafb6c2a1 100644 --- a/dev/.gitignore +++ b/dev/.gitignore @@ -3,3 +3,5 @@ /Deprecated/ transitivitytests.R scratch.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 027025245..35d4642fb 100644 --- a/docs/404.html +++ b/docs/404.html @@ -79,7 +79,7 @@ DemoTools - 01.10.01 + 01.13.40 @@ -171,7 +171,7 @@

Contents