├── .github ├── .gitignore └── workflows │ ├── recheck.yml │ ├── pkgdown.yaml │ └── R-CMD-check.yaml ├── .gitignore ├── data ├── datalist ├── france.rda ├── frsm.rda └── ausfert.rda ├── R ├── attach.R ├── demography.R ├── as.data.frame.demogdata.R ├── fertility.R ├── hmd.R ├── simulate.R ├── update.R ├── monotonic.R ├── robust.R ├── coherent.R ├── netmigration.R ├── smooth.R └── lca.R ├── .Rbuildignore ├── pkgdown └── extra.css ├── demography.Rproj ├── _pkgdown.yml ├── cran-comments.md ├── man ├── as.data.frame.demogdata.Rd ├── extract.years.Rd ├── sex.ratio.Rd ├── set.upperage.Rd ├── demography-package.Rd ├── extract.ages.Rd ├── plot.errorfdm.Rd ├── summary.fdm.Rd ├── ausfert.Rd ├── models.Rd ├── plot.lifetable.Rd ├── fr.mort.Rd ├── tfr.Rd ├── residuals.fdm.Rd ├── migration.Rd ├── combine.demogdata.Rd ├── forecast.fdmpr.Rd ├── mean.demogdata.Rd ├── coherentfdm.Rd ├── demogdata.Rd ├── plot.fmforecast.Rd ├── update.Rd ├── pop.sim.Rd ├── forecast.lca.Rd ├── simulate.fmforecast.Rd ├── isfe.Rd ├── cm.spline.Rd ├── hmd.Rd ├── forecast.fdm.Rd ├── plot.demogdata.Rd ├── life.expectancy.Rd ├── read.demogdata.Rd ├── compare.demogdata.Rd ├── fdm.Rd ├── smooth.demogdata.Rd ├── lifetable.Rd └── lca.Rd ├── Makefile ├── DESCRIPTION ├── README.md ├── README.Rmd ├── NAMESPACE └── NEWS.md /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | revdep 5 | -------------------------------------------------------------------------------- /data/datalist: -------------------------------------------------------------------------------- 1 | ausfert: aus.fert 2 | france: fr.mort 3 | frsm: fr.sm 4 | -------------------------------------------------------------------------------- /data/france.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/robjhyndman/demography/HEAD/data/france.rda -------------------------------------------------------------------------------- /data/frsm.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/robjhyndman/demography/HEAD/data/frsm.rda -------------------------------------------------------------------------------- /data/ausfert.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/robjhyndman/demography/HEAD/data/ausfert.rda -------------------------------------------------------------------------------- /R/attach.R: -------------------------------------------------------------------------------- 1 | .onAttach <- function(...) { 2 | msg <- paste("This is demography", utils::packageVersion("demography"), "\n") 3 | packageStartupMessage(msg) 4 | } 5 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^cran-comments\.md$ 2 | ^.*\.Rproj$ 3 | ^\.Rproj\.user$ 4 | ^revdep$ 5 | ^\.github$ 6 | ^LICENSE\.md$ 7 | README.Rmd 8 | rstudio 9 | Makefile 10 | ^pkgdown$ 11 | _pkgdown.yml 12 | ^CRAN-SUBMISSION$ 13 | -------------------------------------------------------------------------------- /pkgdown/extra.css: -------------------------------------------------------------------------------- 1 | h1, .h1 { 2 | font-size: 2rem; 3 | font-weight: 700; 4 | } 5 | 6 | h2, .h2 { 7 | font-size: 1.5rem; 8 | font-weight: 700; 9 | } 10 | 11 | .bg-primary .navbar-nav .show>.nav-link, .bg-primary .navbar-nav .nav-link.active, .bg-primary .navbar-nav .nav-link:hover, .bg-primary .navbar-nav .nav-link:focus { 12 | color: #ffb81c !important; 13 | } 14 | -------------------------------------------------------------------------------- /demography.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | BuildType: Package 16 | PackageUseDevtools: Yes 17 | PackageInstallArgs: --no-multiarch --with-keep.source 18 | PackageRoxygenize: rd,collate,namespace 19 | -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | template: 2 | bootstrap: 5 3 | theme: tango 4 | bootswatch: flatly 5 | bslib: 6 | base_font: {google: "Fira Sans"} 7 | heading_font: {google: "Fira Sans"} 8 | code_font: "Hack, mono" 9 | primary: "#234460" 10 | link-color: "#234460" 11 | includes: 12 | in_header: 13 | 14 | navbar: 15 | type: light 16 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | ## Test environments 2 | 3 | * Pop!_OS 24.04 LTS based on Ubuntu 24.04 (local): R 4.5.1 4 | * macOS (on GitHub Actions): release 5 | * windows (on GitHub Actions): release 6 | * ubuntu 24.04.3 (on GitHub Actions): devel, release, oldrel 7 | * win-builder: devel, release, oldrelease 8 | 9 | ## R CMD check results 10 | 11 | 0 errors | 0 warnings | 0 notes 12 | 13 | ## revdep checks 14 | 15 | All reverse dependencies have been checked with no new errors detected. 16 | -------------------------------------------------------------------------------- /man/as.data.frame.demogdata.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/as.data.frame.demogdata.R 3 | \name{as.data.frame.demogdata} 4 | \alias{as.data.frame.demogdata} 5 | \title{Coerce a demogdata object to a data.frame object} 6 | \usage{ 7 | \method{as.data.frame}{demogdata}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{Object to be coerced to a data frame.} 11 | 12 | \item{...}{Other arguments not used} 13 | } 14 | \value{ 15 | A data.frame object. 16 | } 17 | \description{ 18 | Coerce a demogdata object to a data.frame object 19 | } 20 | \examples{ 21 | # coerce demogdata object to data.frame ---- 22 | as.data.frame(fr.mort) 23 | } 24 | -------------------------------------------------------------------------------- /.github/workflows/recheck.yml: -------------------------------------------------------------------------------- 1 | on: 2 | workflow_dispatch: 3 | inputs: 4 | which: 5 | type: choice 6 | description: Which dependents to check 7 | options: 8 | - strong 9 | - most 10 | 11 | name: Reverse dependency check 12 | 13 | jobs: 14 | revdep_check: 15 | name: Reverse check ${{ inputs.which }} dependents 16 | uses: r-devel/recheck/.github/workflows/recheck.yml@v1 17 | with: 18 | which: ${{ inputs.which }} 19 | subdirectory: '' # set if your R package is in a subdir of the git repo 20 | repository: '' # set to recheck an R package from another git repo 21 | ref: '' # set to recheck a custom tag/branch from another repo -------------------------------------------------------------------------------- /man/extract.years.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/demogdata.R 3 | \name{extract.years} 4 | \alias{extract.years} 5 | \title{Extract some years from a demogdata object} 6 | \usage{ 7 | extract.years(data, years) 8 | } 9 | \arguments{ 10 | \item{data}{Demogdata object such as created using \code{\link{read.demogdata}} or \code{\link{smooth.demogdata}}.} 11 | 12 | \item{years}{Vector of years to extract from data.} 13 | } 14 | \value{ 15 | Demogdata object with same components as \code{data} but with a subset of years. 16 | } 17 | \description{ 18 | Creates subset of demogdata object. 19 | } 20 | \examples{ 21 | france.1918 <- extract.years(fr.mort, 1918) 22 | } 23 | \author{ 24 | Rob J Hyndman 25 | } 26 | \keyword{manip} 27 | -------------------------------------------------------------------------------- /man/sex.ratio.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/demogdata.R 3 | \name{sex.ratio} 4 | \alias{sex.ratio} 5 | \title{Compute sex ratios from mortality rates} 6 | \usage{ 7 | sex.ratio(data) 8 | } 9 | \arguments{ 10 | \item{data}{Demogdata object of type \dQuote{mortality} such as obtained from \code{\link{read.demogdata}}, 11 | or an object of class \code{fmforecast} such as the output from \code{\link{forecast.fdm}} or \code{\link{forecast.lca}}.} 12 | } 13 | \value{ 14 | Functional time series of sex ratios. 15 | } 16 | \description{ 17 | Calculates the Male/Female ratios from historical or forecasted mortality rates. 18 | } 19 | \examples{ 20 | plot(sex.ratio(fr.mort), ylab = "Sex ratios (M/F)") 21 | } 22 | \author{ 23 | Rob J Hyndman 24 | } 25 | \keyword{models} 26 | -------------------------------------------------------------------------------- /man/set.upperage.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/demogdata.R 3 | \name{set.upperage} 4 | \alias{set.upperage} 5 | \title{Combine the upperages of a demogdata object.} 6 | \usage{ 7 | set.upperage(data, max.age) 8 | } 9 | \arguments{ 10 | \item{data}{Demogdata object such as created using \code{\link{read.demogdata}} or \code{\link{smooth.demogdata}}.} 11 | 12 | \item{max.age}{Upper age group. Ages beyond this are combined into the upper age group.} 13 | } 14 | \value{ 15 | Demogdata object with same components as \code{data} but with a subset of ages. 16 | } 17 | \description{ 18 | Computes demographic rates by combining age groups. 19 | } 20 | \examples{ 21 | france.short <- set.upperage(fr.mort, 85) 22 | } 23 | \author{ 24 | Rob J Hyndman 25 | } 26 | \keyword{manip} 27 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for generating R packages. 2 | # 2017 Rob J Hyndman 3 | # 4 | # Assumes Makefile is in top folder of package 5 | 6 | PKG_NAME=$(shell grep -i ^package DESCRIPTION | cut -d : -d \ -f 2) 7 | 8 | default: build 9 | 10 | check: 11 | Rscript -e "rcmdcheck::rcmdcheck()" 12 | 13 | build: 14 | -rm -f rstudio 15 | -Rscript -e "devtools::build(args = c('--compact-vignettes=both'))" 16 | 17 | install: 18 | R CMD INSTALL . 19 | 20 | clean: 21 | -rm -f ../$(PKG_NAME)_*.tar.gz 22 | -rm -r -f man/*.Rd 23 | -rm -r -f NAMESPACE 24 | 25 | docs: 26 | Rscript -e "roxygen2::roxygenize()" 27 | 28 | pkgdown: 29 | Rscript -e "pkgdown::build_site()" 30 | 31 | revdep: 32 | Rscript -e "revdepcheck::revdep_check(num_workers=3)" 33 | 34 | release: 35 | -rm -f rstudio 36 | -Rscript -e "devtools::submit_cran(args = c('--compact-vignettes=both'))" 37 | -------------------------------------------------------------------------------- /man/demography-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/demography.R 3 | \docType{package} 4 | \name{demography-package} 5 | \alias{demography-package} 6 | \alias{demography} 7 | \title{Forecasting mortality and fertility data} 8 | \description{ 9 | Functions for demographic analysis including lifetable calculations, 10 | Lee-Carter modelling and functional data analysis of mortality rates. 11 | } 12 | \seealso{ 13 | Useful links: 14 | \itemize{ 15 | \item \url{https://pkg.robjhyndman.com/demography/} 16 | \item \url{https://github.com/robjhyndman/demography} 17 | \item Report bugs at \url{https://github.com/robjhyndman/demography/issues} 18 | } 19 | 20 | } 21 | \author{ 22 | Rob J Hyndman with contributions from Heather Booth, Leonie Tickle, John Maindonald, Simon Wood and the R Core Team. 23 | 24 | Maintainer: 25 | } 26 | \keyword{internal} 27 | -------------------------------------------------------------------------------- /man/extract.ages.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/demogdata.R 3 | \name{extract.ages} 4 | \alias{extract.ages} 5 | \title{Extract some ages from a demogdata object} 6 | \usage{ 7 | extract.ages(data, ages, combine.upper = TRUE) 8 | } 9 | \arguments{ 10 | \item{data}{Demogdata object such as created using \code{\link{read.demogdata}} or \code{\link{smooth.demogdata}}.} 11 | 12 | \item{ages}{Vector of ages to extract from data.} 13 | 14 | \item{combine.upper}{If TRUE, ages beyond the maximum of \code{ages} are combined into the upper age group.} 15 | } 16 | \value{ 17 | Demogdata object with same components as \code{data} but with a subset of ages. 18 | } 19 | \description{ 20 | Creates subset of demogdata object. 21 | } 22 | \examples{ 23 | france.teens <- extract.ages(fr.mort, 13:19, FALSE) 24 | plot(france.teens) 25 | } 26 | \author{ 27 | Rob J Hyndman 28 | } 29 | \keyword{manip} 30 | -------------------------------------------------------------------------------- /man/plot.errorfdm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fdm.R 3 | \name{plot.errorfdm} 4 | \alias{plot.errorfdm} 5 | \title{Plot differences between actuals and estimates from fitted demographic model} 6 | \usage{ 7 | \method{plot}{errorfdm}(x, transform = TRUE, ...) 8 | } 9 | \arguments{ 10 | \item{x}{Object of class \code{"errorfdm"} generated by \code{\link{compare.demogdata}}.} 11 | 12 | \item{transform}{Plot errors on transformed scale or original scale?} 13 | 14 | \item{...}{Plotting parameters.} 15 | } 16 | \description{ 17 | Function produces a plot of errors from a fitted demographic model. 18 | } 19 | \examples{ 20 | fr.fit <- lca(extract.years(fr.mort, years = 1921:1980)) 21 | fr.error <- compare.demogdata(fr.mort, forecast(fr.fit, 20)) 22 | plot(fr.error) 23 | 24 | } 25 | \seealso{ 26 | \link{compare.demogdata} 27 | } 28 | \author{ 29 | Rob J Hyndman 30 | } 31 | \keyword{hplot} 32 | -------------------------------------------------------------------------------- /R/demography.R: -------------------------------------------------------------------------------- 1 | #' Forecasting mortality and fertility data 2 | #' 3 | #' Functions for demographic analysis including lifetable calculations, 4 | #' Lee-Carter modelling and functional data analysis of mortality rates. 5 | #' 6 | #' 7 | #' @author Rob J Hyndman with contributions from Heather Booth, Leonie Tickle, John Maindonald, Simon Wood and the R Core Team. 8 | #' @author Maintainer: 9 | #' 10 | #' @import forecast 11 | #' @import ftsa 12 | #' @import rainbow 13 | #' @import mgcv 14 | #' @import cobs 15 | #' @importFrom graphics abline lines plot 16 | #' @importFrom stats simulate update approx frequency glm lm loess na.omit nlm 17 | #' @importFrom stats poisson predict qnorm rbinom rpois spline splinefun start time 18 | #' @importFrom stats ts tsp tsp<- uniroot window median 19 | #' @importFrom utils read.table 20 | #' 21 | 22 | 23 | #' 24 | #' @name demography-package 25 | #' @aliases demography 26 | #' @keywords internal 27 | "_PACKAGE" 28 | -------------------------------------------------------------------------------- /man/summary.fdm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fdm.R, R/lca.R 3 | \name{summary.fdm} 4 | \alias{summary.fdm} 5 | \alias{summary.lca} 6 | \title{Summary for functional demographic model or Lee-Carter model} 7 | \usage{ 8 | \method{summary}{fdm}(object, ...) 9 | 10 | \method{summary}{lca}(object, ...) 11 | } 12 | \arguments{ 13 | \item{object}{Output from \code{\link{fdm}} or \code{\link{lca}}.} 14 | 15 | \item{...}{Other arguments.} 16 | } 17 | \description{ 18 | Summarizes a basis function model fitted to age-specific demographic rate 19 | data. It returns various measures of goodness-of-fit. 20 | } 21 | \examples{ 22 | fit1 <- lca(fr.mort) 23 | fit2 <- bms(fr.mort, breakmethod = "bai") 24 | fit3 <- fdm(fr.mort) 25 | summary(fit1) 26 | summary(fit2) 27 | summary(fit3) 28 | } 29 | \seealso{ 30 | \code{\link{fdm}}, \code{\link{lca}}, \code{\link{bms}}, 31 | \code{\link{compare.demogdata}} 32 | } 33 | \author{ 34 | Rob J Hyndman 35 | } 36 | \keyword{models} 37 | -------------------------------------------------------------------------------- /man/ausfert.Rd: -------------------------------------------------------------------------------- 1 | \name{aus.fert} 2 | \alias{aus.fert} 3 | 4 | \docType{data} 5 | 6 | \title{Australian fertility data} 7 | 8 | \description{Age-specific fertility rates and female child-bearing population for Australia.} 9 | 10 | \details{Australian fertility rates and populations (1921-2002) for age groups (<20, 20-24, 25-29, 30-34, 35-39, 40-44, 45+). 11 | Data taken from v3.2b of the Australian Demographic Data Bank released 10 February 2005. 12 | } 13 | 14 | \format{Object of class \code{demogdata} containing the following components: 15 | \describe{\item{year}{Vector of years} 16 | \item{age}{Vector of ages} 17 | \item{rate}{List containing one matrix with one age group per row and one column per year.} 18 | \item{pop}{Population data in same form as \code{rate}.} 19 | \item{type}{Type of object. In this case, \dQuote{fertility}.} 20 | \item{label}{Character string giving area from which data are taken. In this case, \dQuote{Australia}.} 21 | }} 22 | 23 | \source{The Australian Demographic Data Bank (courtesy of Len Smith).} 24 | 25 | \author{Rob J Hyndman} 26 | 27 | \examples{ 28 | plot(aus.fert) 29 | } 30 | \keyword{data} 31 | -------------------------------------------------------------------------------- /man/models.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fdm.R 3 | \name{models} 4 | \alias{models} 5 | \alias{models.fmforecast} 6 | \alias{models.fmforecast2} 7 | \title{Show model information for the forecast coefficients in FDM models.} 8 | \usage{ 9 | models(object, ...) 10 | 11 | \method{models}{fmforecast}(object, select = 0, ...) 12 | 13 | \method{models}{fmforecast2}(object, ...) 14 | } 15 | \arguments{ 16 | \item{object}{Output from \code{\link{forecast.fdm}} or \code{\link{forecast.fdmpr}}.} 17 | 18 | \item{...}{Other arguments.} 19 | 20 | \item{select}{Indexes of coefficients to display. If select=0, all coefficients are displayed.} 21 | } 22 | \description{ 23 | The models for the time series coefficients used in forecasting fdm models are shown. 24 | } 25 | \examples{ 26 | \dontrun{ 27 | fr.short <- extract.years(fr.sm, 1950:2006) 28 | fr.fit <- fdm(fr.short, series = "male") 29 | fr.fcast <- forecast(fr.fit) 30 | models(fr.fcast) 31 | 32 | fr.fit <- coherentfdm(fr.short) 33 | fr.fcast <- forecast(fr.fit) 34 | models(fr.fcast, select = 1:3) 35 | } 36 | } 37 | \seealso{ 38 | \code{\link{forecast.fdm}}, \code{\link{forecast.fdmpr}}. 39 | } 40 | \author{ 41 | Rob J Hyndman 42 | } 43 | \keyword{models} 44 | -------------------------------------------------------------------------------- /man/plot.lifetable.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/lifetable.R 3 | \name{plot.lifetable} 4 | \alias{plot.lifetable} 5 | \alias{lines.lifetable} 6 | \title{Plot life expectancy from lifetable} 7 | \usage{ 8 | \method{plot}{lifetable}( 9 | x, 10 | years = x$year, 11 | main, 12 | xlab = "Age", 13 | ylab = "Expected number of years left", 14 | ... 15 | ) 16 | 17 | \method{lines}{lifetable}(x, years = x$year, ...) 18 | } 19 | \arguments{ 20 | \item{x}{Output from \code{\link{lifetable}}.} 21 | 22 | \item{years}{Years to plot. Default: all available years.} 23 | 24 | \item{main}{Main title.} 25 | 26 | \item{xlab}{Label for x-axis.} 27 | 28 | \item{ylab}{Label for y-axis.} 29 | 30 | \item{...}{Additional arguments passed to \code{\link[rainbow]{plot.fds}}.} 31 | } 32 | \description{ 33 | plots life expectancy for each age and each year as functional time series. 34 | } 35 | \examples{ 36 | france.lt <- lifetable(fr.mort) 37 | plot(france.lt) 38 | 39 | france.LC <- lca(fr.mort) 40 | france.fcast <- forecast(france.LC) 41 | france.lt.f <- lifetable(france.fcast) 42 | plot(france.lt.f, years = 2010) 43 | } 44 | \seealso{ 45 | \code{\link{life.expectancy}}, \code{\link{lifetable}}. 46 | } 47 | \author{ 48 | Rob J Hyndman 49 | } 50 | \keyword{models} 51 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: demography 2 | Version: 2.0.1.9000 3 | Title: Forecasting Mortality, Fertility, Migration and Population Data 4 | Description: Functions for demographic analysis including lifetable 5 | calculations; Lee-Carter modelling; functional data analysis of 6 | mortality rates, fertility rates, net migration numbers; and 7 | stochastic population forecasting. 8 | Depends: 9 | R (>= 3.4), 10 | forecast (>= 8.5) 11 | Imports: 12 | ftsa (>= 4.8), 13 | rainbow, 14 | cobs, 15 | mgcv, 16 | strucchange, 17 | HMDHFDplus (>= 2.0.8) 18 | LazyData: yes 19 | ByteCompile: TRUE 20 | Authors@R: c( 21 | person("Rob", "Hyndman", email = "Rob.Hyndman@monash.edu", role = c("aut", "cre", "cph"), comment = c(ORCID = "0000-0002-2140-5352")), 22 | person("Heather", "Booth", role = "ctb", comment = c(ORCID = "0000-0002-8356-0534")), 23 | person("Leonie", "Tickle", role = "ctb", comment = c(ORCID = "0000-0002-6612-2401")), 24 | person("John", "Maindonald", role = "ctb"), 25 | person("Simon", "Wood", role = "ctb"), 26 | person("R Core Team", role = "ctb") 27 | ) 28 | URL: https://pkg.robjhyndman.com/demography/, https://github.com/robjhyndman/demography 29 | BugReports: https://github.com/robjhyndman/demography/issues 30 | License: GPL (>= 3) 31 | Encoding: UTF-8 32 | RoxygenNote: 7.3.3 33 | -------------------------------------------------------------------------------- /man/fr.mort.Rd: -------------------------------------------------------------------------------- 1 | \name{fr.mort} 2 | \alias{fr.mort} 3 | \alias{fr.sm} 4 | 5 | \docType{data} 6 | 7 | \title{French mortality data} 8 | 9 | \description{Age-specific mortality rates and population for France.} 10 | 11 | \details{\code{fr.mort} contains French mortality rates and populations (1899-2005) for ages 0-110. Data taken from the Human Mortality Database 12 | on 20 February 2008. \code{fr.sm} contains a smoothed version of \code{fr.mort} obtained using the \code{\link{smooth.demogdata}} function. 13 | } 14 | 15 | \format{Object of class \code{demogdata} containing the following components: 16 | \describe{ 17 | \item{year}{Vector of years} 18 | \item{age}{Vector of ages} 19 | \item{rate}{List of matrices containing rates with with one age group per row and one column per year. 20 | Matrices: \code{total}, \code{female}, \code{male}.} 21 | \item{pop}{Population data in same form as \code{rate}.} 22 | \item{type}{Type of object. In this case, \dQuote{mortality}.} 23 | \item{label}{Character string giving area from which data are taken. In this case, \dQuote{France}.} 24 | }} 25 | 26 | \source{The Human Mortality Database (\url{http://www.mortality.org}).} 27 | 28 | \author{Rob J Hyndman} 29 | 30 | \examples{ 31 | plot(fr.mort,years=1950:1997) 32 | 33 | plot(fr.mort,years=1990,type='p',pch=1) 34 | lines(fr.sm,years=1990) 35 | } 36 | \keyword{data} 37 | -------------------------------------------------------------------------------- /man/tfr.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fertility.R 3 | \name{tfr} 4 | \alias{tfr} 5 | \title{Compute total fertility rate from fertility rates} 6 | \usage{ 7 | tfr(data, PI = FALSE, nsim = 500, ...) 8 | } 9 | \arguments{ 10 | \item{data}{Demogdata object of type \code{"fertility"} such as obtained from 11 | \code{\link{read.demogdata}}, \code{\link{forecast.fdm}}.} 12 | 13 | \item{PI}{If TRUE, produce a prediction interval.} 14 | 15 | \item{nsim}{Number of simulations to use when computing a prediction 16 | interval.} 17 | 18 | \item{...}{Other arguments passed to \code{simulate} when producing 19 | prediction intervals.} 20 | } 21 | \value{ 22 | If data are of class \code{demogdata}, the function returns a time 23 | series of fertility rates. If data are from \code{\link{forecast.fdm}}, the 24 | function returns an object of class \code{forecast} containing point 25 | forecasts and (optionally) prediction intervals. 26 | } 27 | \description{ 28 | Compute total fertility rates from age-specific fertility rates contained in 29 | a \code{demogdata} object. 30 | } 31 | \examples{ 32 | plot(tfr(aus.fert)) 33 | ausfert.fcast <- forecast(fdm(aus.fert)) 34 | plot(tfr(ausfert.fcast, PI = TRUE, nsim = 400)) 35 | 36 | } 37 | \seealso{ 38 | \code{\link{fdm}} 39 | } 40 | \author{ 41 | Rob J Hyndman 42 | } 43 | \keyword{models} 44 | -------------------------------------------------------------------------------- /man/residuals.fdm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fdm.R, R/lca.R 3 | \name{residuals.fdm} 4 | \alias{residuals.fdm} 5 | \alias{fitted.fdm} 6 | \alias{fitted.lca} 7 | \alias{residuals.lca} 8 | \title{Compute residuals and fitted values from functional demographic model or 9 | Lee-Carter model} 10 | \usage{ 11 | \method{residuals}{fdm}(object, ...) 12 | 13 | \method{fitted}{fdm}(object, ...) 14 | 15 | \method{fitted}{lca}(object, ...) 16 | 17 | \method{residuals}{lca}(object, ...) 18 | } 19 | \arguments{ 20 | \item{object}{Output from \code{\link{fdm}} or \code{\link{lca}}.} 21 | 22 | \item{...}{Other arguments.} 23 | } 24 | \value{ 25 | \code{residuals.fdm} and \code{residuals.lca} produce an object of 26 | class \dQuote{fmres} containing the residuals from the model. 27 | \code{fitted.fdm} and \code{fitted.lca} produce an object of class 28 | \dQuote{fts} containing the fitted values from the model. 29 | } 30 | \description{ 31 | After fitting a Lee-Carter model or functional demographic model, it is 32 | useful to inspect the residuals or plot the fitted values. These functions 33 | extract the relevant information from the fit object. 34 | } 35 | \examples{ 36 | fit1 <- lca(fr.mort) 37 | plot(residuals(fit1)) 38 | plot(fitted(fit1)) 39 | 40 | } 41 | \seealso{ 42 | \code{\link{fdm}}, \code{\link{lca}}, \code{\link{bms}} 43 | } 44 | \author{ 45 | Rob J Hyndman. 46 | } 47 | \keyword{models} 48 | -------------------------------------------------------------------------------- /man/migration.Rd: -------------------------------------------------------------------------------- 1 | \name{netmigration} 2 | \alias{netmigration} 3 | \title{Calculate net migration from mortality and fertility data} 4 | \usage{netmigration(mort, fert, startyearpop=mort, mfratio = 1.05) 5 | } 6 | 7 | \arguments{ 8 | \item{mort}{Demogdata object of type \code{"mortality"}} 9 | \item{fert}{Demogdata object of type \code{"fertility"}} 10 | \item{startyearpop}{Demogdata object containing population data for first year of calculation.} 11 | \item{mfratio}{Male-female ratio to be used in simulating births.} 12 | } 13 | 14 | \description{Function to compute the net number of migrants in each year and for each age, 15 | based on the total population numbers, deaths and births in each year.} 16 | 17 | \value{Object of class \dQuote{demogdata} with the following components: 18 | \item{year}{Vector of years} 19 | \item{age}{Vector of ages} 20 | \item{rate}{List containing matrices of net migration numbers (not "rates") with with one age group per 21 | row and one column per year. Names of matrices are the same as for \code{mort$rate}.} 22 | \item{pop}{List containing matrices of populations in same form as \code{rate} and containing population numbers.} 23 | \item{type}{Type of object. In this case, \dQuote{migration}.} 24 | \item{label}{label from \code{mort$label}} 25 | } 26 | 27 | \seealso{\code{\link{demogdata}}} 28 | 29 | \author{Rob J Hyndman} 30 | 31 | \examples{ 32 | \dontrun{ 33 | require(addb) 34 | aus.mig <- netmigration(australia,aus.fertility) 35 | plot(aus.mig)} 36 | } 37 | 38 | \keyword{manip} 39 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | release: 9 | types: [published] 10 | workflow_dispatch: 11 | 12 | name: pkgdown 13 | 14 | jobs: 15 | pkgdown: 16 | runs-on: ubuntu-latest 17 | # Only restrict concurrency for non-PR jobs 18 | concurrency: 19 | group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} 20 | env: 21 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 22 | permissions: 23 | contents: write 24 | steps: 25 | - uses: actions/checkout@v3 26 | 27 | - uses: r-lib/actions/setup-pandoc@v2 28 | 29 | - uses: r-lib/actions/setup-r@v2 30 | with: 31 | use-public-rspm: true 32 | 33 | - uses: r-lib/actions/setup-r-dependencies@v2 34 | with: 35 | extra-packages: any::pkgdown, local::. 36 | needs: website 37 | 38 | - name: Build site 39 | run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) 40 | shell: Rscript {0} 41 | 42 | - name: Deploy to GitHub pages 🚀 43 | if: github.event_name != 'pull_request' 44 | uses: JamesIves/github-pages-deploy-action@v4.4.1 45 | with: 46 | clean: false 47 | branch: gh-pages 48 | folder: docs 49 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | 9 | name: R-CMD-check 10 | 11 | jobs: 12 | R-CMD-check: 13 | runs-on: ${{ matrix.config.os }} 14 | 15 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 16 | 17 | strategy: 18 | fail-fast: false 19 | matrix: 20 | config: 21 | - {os: macos-latest, r: 'release'} 22 | - {os: windows-latest, r: 'release'} 23 | - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} 24 | - {os: ubuntu-latest, r: 'release'} 25 | - {os: ubuntu-latest, r: 'oldrel-1'} 26 | 27 | env: 28 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 29 | R_KEEP_PKG_SOURCE: yes 30 | 31 | steps: 32 | - uses: actions/checkout@v3 33 | 34 | - uses: r-lib/actions/setup-pandoc@v2 35 | 36 | - uses: r-lib/actions/setup-r@v2 37 | with: 38 | r-version: ${{ matrix.config.r }} 39 | http-user-agent: ${{ matrix.config.http-user-agent }} 40 | use-public-rspm: true 41 | 42 | - uses: r-lib/actions/setup-r-dependencies@v2 43 | with: 44 | extra-packages: any::rcmdcheck 45 | needs: check 46 | 47 | - uses: r-lib/actions/check-r-package@v2 48 | with: 49 | upload-snapshots: true 50 | -------------------------------------------------------------------------------- /man/combine.demogdata.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/demogdata.R 3 | \name{combine.demogdata} 4 | \alias{combine.demogdata} 5 | \title{Combine two demogdata objects into one demogdata object} 6 | \usage{ 7 | combine.demogdata(obj1, obj2) 8 | } 9 | \arguments{ 10 | \item{obj1}{First demogdata object (e.g., historical data).} 11 | 12 | \item{obj2}{Second demogdata object (e.g., forecasts).} 13 | } 14 | \value{ 15 | Object of class \dQuote{demogdata} with the following components: 16 | \item{year}{Vector of years} 17 | \item{age}{Vector of ages} 18 | \item{rate}{Matrix of rates with with one age group per row and one column per year.} 19 | \item{pop}{Matrix of populations in same form as \code{rate} and containing population numbers. This is only 20 | produced when both objects contain a \code{pop} component.} 21 | \item{type}{Type of object: \dQuote{mortality}, \dQuote{fertility} or \dQuote{migration}.} 22 | \item{label}{Name of area from which the data are taken.} 23 | } 24 | \description{ 25 | Function to combine demogdata objects containing 26 | different years but the same age structure into one demogdata 27 | object. The standard use for this function will be combining 28 | historical data with forecasts. The objects must be of the same type. 29 | } 30 | \examples{ 31 | fit <- fdm(fr.mort) 32 | fcast <- forecast(fit, h = 50) 33 | france2 <- combine.demogdata(fr.mort, fcast) 34 | plot(france2) 35 | plot(life.expectancy(france2)) 36 | lines(rep(max(fr.mort$year) + 0.5, 2), c(0, 100), lty = 3) 37 | } 38 | \seealso{ 39 | \code{\link{demogdata}} 40 | } 41 | \author{ 42 | Rob J Hyndman 43 | } 44 | \keyword{manip} 45 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | # demography 5 | 6 | 7 | 8 | [![CRAN 9 | status](https://www.r-pkg.org/badges/version/demography)](https://cran.r-project.org/package=demography) 10 | [![cran 11 | checks](https://badges.cranchecks.info/worst/demography.svg)](https://cran.r-project.org/web/checks/check_results_demography.html) 12 | [![R-CMD-check](https://github.com/robjhyndman/demography/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/robjhyndman/demography/actions/workflows/R-CMD-check.yaml) 13 | [![Downloads](https://cranlogs.r-pkg.org/badges/demography)](https://cran.r-project.org/package=demography) 14 | [![Licence](https://img.shields.io/badge/licence-GPL--3-blue.svg)](https://www.gnu.org/licenses/gpl-3.0.en.html) 15 | 16 | 17 | The R package `demography` provides functions for demographic analysis 18 | including: lifetable calculations; Lee-Carter modelling; functional data 19 | analysis of mortality rates, fertility rates, net migration numbers; and 20 | stochastic population forecasting. 21 | 22 | ## Installation 23 | 24 | You can install the **stable** version on [R 25 | CRAN](https://CRAN.R-project.org/package=demography). 26 | 27 | ``` r 28 | install.packages('demography', dependencies = TRUE) 29 | ``` 30 | 31 | You can also install the **development** version from 32 | [Github](https://github.com/robjhyndman/demography) 33 | 34 | ``` r 35 | # install.packages("devtools") 36 | library(devtools) 37 | install_github("robjhyndman/demography") 38 | ``` 39 | 40 | ## License 41 | 42 | This package is free and open source software, licensed under GPL (\>= 43 | 3). 44 | -------------------------------------------------------------------------------- /man/forecast.fdmpr.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/coherent.R 3 | \name{forecast.fdmpr} 4 | \alias{forecast.fdmpr} 5 | \title{Forecast coherent functional demographic model.} 6 | \usage{ 7 | \method{forecast}{fdmpr}(object, h = 50, level = 80, K = 100, drange = c(0, 0.5), ...) 8 | } 9 | \arguments{ 10 | \item{object}{Output from \code{\link{coherentfdm}}.} 11 | 12 | \item{h}{Forecast horizon.} 13 | 14 | \item{level}{Confidence level for prediction intervals.} 15 | 16 | \item{K}{Maximum number of years to use in forecasting coefficients for ratio 17 | components.} 18 | 19 | \item{drange}{Range of fractional differencing parameter for the ratio 20 | coefficients.} 21 | 22 | \item{...}{Other arguments as for \code{\link{forecast.fdm}}.} 23 | } 24 | \value{ 25 | Object of class \code{fmforecast2} containing a list of objects each 26 | of class \code{fmforecast}. The forecasts for each group in the original 27 | data are given first. Then the forecasts from the product model, and 28 | finally a list of forecasts from each of the ratio models. 29 | } 30 | \description{ 31 | The product and ratio models from \code{\link{coherentfdm}} are forecast, and 32 | the results combined to give forecasts for each group in the original data. 33 | } 34 | \examples{ 35 | fr.short <- extract.years(fr.sm, 1950:2006) 36 | fr.fit <- coherentfdm(fr.short) 37 | fr.fcast <- forecast(fr.fit) 38 | plot(fr.fcast$male) 39 | plot(fr.fcast$ratio$male, plot.type = "component", components = 3) 40 | models(fr.fcast) 41 | 42 | } 43 | \seealso{ 44 | \code{\link{coherentfdm}}, \code{\link{forecast.fdm}}. 45 | } 46 | \author{ 47 | Rob J Hyndman 48 | } 49 | \keyword{models} 50 | -------------------------------------------------------------------------------- /man/mean.demogdata.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/demogdata.R 3 | \name{mean.demogdata} 4 | \alias{mean.demogdata} 5 | \alias{median.demogdata} 6 | \title{Mean and median functions for data of class demogdata} 7 | \usage{ 8 | \method{mean}{demogdata}(x, series = names(x$rate)[1], transform = TRUE, na.rm = TRUE, ...) 9 | 10 | \method{median}{demogdata}( 11 | x, 12 | na.rm = FALSE, 13 | series = names(x$rate)[1], 14 | transform = TRUE, 15 | method = c("hossjercroux", "coordinate"), 16 | ... 17 | ) 18 | } 19 | \arguments{ 20 | \item{x}{Demogdata object such as created using \code{\link{read.demogdata}} or \code{\link{smooth.demogdata}}.} 21 | 22 | \item{series}{Name of demogdata series to plot..} 23 | 24 | \item{transform}{Should transform of data be taken first?} 25 | 26 | \item{na.rm}{a logical value indicating whether NA values should be stripped before the computation proceeds.} 27 | 28 | \item{...}{Other arguments.} 29 | 30 | \item{method}{Method for computing the median. Either "coordinate" for a coordinate-wise median, or "hossjercroux" for the 31 | L1-median using the Hossjer-Croux algorithm.} 32 | } 33 | \value{ 34 | A list containing \code{x}=ages and \code{y}=mean or median rates. 35 | } 36 | \description{ 37 | Computes mean or median of demographic rates for each age level. 38 | } 39 | \examples{ 40 | plot(fr.mort) 41 | lines(mean(fr.mort), lwd = 2) 42 | lines(median(fr.mort), lwd = 2, col = 2) 43 | } 44 | \references{ 45 | Hossjer, O., and Croux, C. (1995) Generalized univariate signed rank statistics for testing 46 | and estimating a multivariate location parameter. \emph{Nonparametric Statistics}, \bold{4}, 293-308. 47 | } 48 | \author{ 49 | Rob J Hyndman 50 | } 51 | \keyword{models} 52 | -------------------------------------------------------------------------------- /man/coherentfdm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/coherent.R 3 | \name{coherentfdm} 4 | \alias{coherentfdm} 5 | \title{Coherent functional demographic model for grouped data} 6 | \usage{ 7 | coherentfdm(data, order1 = 6, order2 = 6, ...) 8 | } 9 | \arguments{ 10 | \item{data}{demogdata object containing at least two groups.} 11 | 12 | \item{order1}{Number of basis functions to fit to the model for the geometric 13 | mean.} 14 | 15 | \item{order2}{Number of basis functions to fit to the models for each ratio.} 16 | 17 | \item{...}{Extra arguments passed to \code{\link{fdm}}.} 18 | } 19 | \value{ 20 | A list (of class \code{fdmpr}) consisting of two objects: 21 | \code{product} (an \code{\link{fdm}} object containing a del for the 22 | geometric mean of the data) and \code{ratio} (a list of \code{\link{fdm}} 23 | objects, being the models for the ratio of each series with the geometric 24 | mean). 25 | } 26 | \description{ 27 | Fits a coherent functional model to demographic data as described in Hyndman, 28 | Booth & Yasmeen (2012). If two of the series in \code{data} are named 29 | \code{male} and \code{female}, then it will use these two groups. Otherwise 30 | it will use all available groups. 31 | } 32 | \examples{ 33 | fr.short <- extract.years(fr.sm, 1950:2006) 34 | fr.fit <- coherentfdm(fr.short) 35 | summary(fr.fit) 36 | plot(fr.fit$product, components = 3) 37 | } 38 | \references{ 39 | Hyndman, R.J., Booth, H., and Yasmeen, F. (2012) Coherent 40 | mortality forecasting: the product-ratio method with functional time series 41 | models. \emph{Demography}, to appear. 42 | \url{https://robjhyndman.com/publications/coherentfdm/} 43 | } 44 | \seealso{ 45 | \code{\link{fdm}}, \code{\link{forecast.fdmpr}} 46 | } 47 | \author{ 48 | Rob J Hyndman 49 | } 50 | \keyword{models} 51 | -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: github_document 3 | editor_options: 4 | chunk_output_type: console 5 | --- 6 | 7 | 8 | 9 | ```{r, echo = FALSE} 10 | knitr::opts_chunk$set( 11 | collapse = TRUE, 12 | comment = "#>", 13 | fig.path = "man/figures/README-" 14 | ) 15 | ``` 16 | 17 | 18 | # demography 19 | 20 | 21 | [![CRAN status](https://www.r-pkg.org/badges/version/demography)](https://cran.r-project.org/package=demography) 22 | [![cran checks](https://badges.cranchecks.info/worst/demography.svg)](https://cran.r-project.org/web/checks/check_results_demography.html) 23 | [![R-CMD-check](https://github.com/robjhyndman/demography/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/robjhyndman/demography/actions/workflows/R-CMD-check.yaml) 24 | [![Downloads](https://cranlogs.r-pkg.org/badges/demography)](https://cran.r-project.org/package=demography) 25 | [![Licence](https://img.shields.io/badge/licence-GPL--3-blue.svg)](https://www.gnu.org/licenses/gpl-3.0.en.html) 26 | 27 | 28 | The R package `demography` provides functions for demographic analysis including: lifetable calculations; Lee-Carter modelling; functional data analysis of mortality rates, fertility rates, net migration numbers; and stochastic population forecasting. 29 | 30 | ## Installation 31 | You can install the **stable** version on 32 | [R CRAN](https://CRAN.R-project.org/package=demography). 33 | 34 | ```r 35 | install.packages('demography', dependencies = TRUE) 36 | ``` 37 | 38 | You can also install the **development** version from 39 | [Github](https://github.com/robjhyndman/demography) 40 | 41 | ```r 42 | # install.packages("devtools") 43 | library(devtools) 44 | install_github("robjhyndman/demography") 45 | ``` 46 | 47 | 48 | ## License 49 | 50 | This package is free and open source software, licensed under GPL (>= 3). 51 | -------------------------------------------------------------------------------- /man/demogdata.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/demogdata.R 3 | \name{demogdata} 4 | \alias{demogdata} 5 | \title{Create demogdata object from raw data matrices} 6 | \usage{ 7 | demogdata(data, pop, ages, years, type, label, name, lambda) 8 | } 9 | \arguments{ 10 | \item{data}{Matrix of data: either mortality rates or fertility rates} 11 | 12 | \item{pop}{Matrix of population values of same dimension as data. 13 | These are population numbers as at 30 June of each year (i.e., the "exposures"). 14 | So, for example, the number of deaths is data*pop if data contains mortality rates.} 15 | 16 | \item{ages}{Vector of ages corresponding to rows of \code{data}.} 17 | 18 | \item{years}{Vector of years corresponding to columns of \code{data}.} 19 | 20 | \item{type}{Character string showing type of demographic series: 21 | either \dQuote{mortality}, \dQuote{fertility} or \dQuote{migration}.} 22 | 23 | \item{label}{Character string of the name of area from which the data are taken.} 24 | 25 | \item{name}{Name of series: usually male, female or total.} 26 | 27 | \item{lambda}{Box-Cox transformation parameter.} 28 | } 29 | \value{ 30 | Object of class \dQuote{demogdata} with the following components: 31 | \item{year}{Vector of years} 32 | \item{age}{Vector of ages} 33 | \item{rate}{A list containing one or more rate matrices with one age group per row and one column per year.} 34 | \item{pop}{A list of the same form as \code{rate} but containing population numbers instead of demographic rates.} 35 | \item{type}{Type of object: \dQuote{mortality}, \dQuote{fertility} or \dQuote{migration}.} 36 | \item{label}{label} 37 | \item{lambda}{lambda} 38 | } 39 | \description{ 40 | Create demogdata object suitable for plotting using \code{\link{plot.demogdata}} and 41 | fitting an LC or BMS model using \code{\link{lca}} or an FDA model using \code{\link{fdm}}. 42 | } 43 | \seealso{ 44 | \code{\link{read.demogdata}} 45 | } 46 | \author{ 47 | Rob J Hyndman 48 | } 49 | \keyword{manip} 50 | -------------------------------------------------------------------------------- /man/plot.fmforecast.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fdm.R, R/lca.R 3 | \name{plot.fmforecast} 4 | \alias{plot.fmforecast} 5 | \alias{plot.lca} 6 | \title{Plot forecasts from a functional demographic modell} 7 | \usage{ 8 | \method{plot}{fmforecast}( 9 | x, 10 | plot.type = c("function", "component", "variance"), 11 | vcol = 1:4, 12 | mean.lab = "Mean", 13 | xlab2 = "Year", 14 | h = 1, 15 | ... 16 | ) 17 | 18 | \method{plot}{lca}(x, ...) 19 | } 20 | \arguments{ 21 | \item{x}{Output from \code{\link[ftsa]{forecast.ftsm}}, 22 | \code{\link{forecast.fdm}} or \code{\link{lca}}.} 23 | 24 | \item{plot.type}{Type of plot. See details.} 25 | 26 | \item{vcol}{Colors to use if \code{plot.type="variance"}.} 27 | 28 | \item{mean.lab}{Label for mean component.} 29 | 30 | \item{xlab2}{x-axis label for coefficient time series.} 31 | 32 | \item{h}{If \code{plot.type="variance"}, h gives the forecast horizon for 33 | which the variance is plotted.} 34 | 35 | \item{...}{Other arguments are passed to \code{\link{plot.demogdata}} (if 36 | \code{plot.type=="function"}), \code{\link[base]{plot}} (if 37 | \code{plot.type=="variance"}) or \code{\link[ftsa]{plot.ftsf}} (if 38 | \code{plot.type=="component"}).} 39 | } 40 | \value{ 41 | None. Function produces a plot 42 | } 43 | \description{ 44 | Type of plot depends on value of \code{plot.type}: \describe{ 45 | \item{\code{plot.type="function"}}{produces a plot of the forecast 46 | functions;} \item{\code{plot.type="components"}}{produces a plot of the basis 47 | functions and coefficients with forecasts and prediction intervals for each 48 | coefficient;} \item{\code{plot.type="variance"}}{produces a plot of the 49 | variance components.} } 50 | } 51 | \examples{ 52 | france.fcast <- forecast(fdm(fr.mort)) 53 | plot(france.fcast) 54 | plot(france.fcast, "c") 55 | plot(france.fcast, "v") 56 | } 57 | \seealso{ 58 | \link{fdm}, \link{lca}, \link{forecast.fdm} 59 | } 60 | \author{ 61 | Rob J Hyndman 62 | } 63 | \keyword{hplot} 64 | -------------------------------------------------------------------------------- /man/update.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/update.R 3 | \name{update} 4 | \alias{update} 5 | \alias{update.fmforecast} 6 | \alias{update.fmforecast2} 7 | \title{Updating functional demographic models and coherent functional demographic models.} 8 | \usage{ 9 | \method{update}{fmforecast}(object, ...) 10 | 11 | \method{update}{fmforecast2}(object, ...) 12 | } 13 | \arguments{ 14 | \item{object}{Output from either \code{\link{fdm}} or \code{\link{coherentfdm}}.} 15 | 16 | \item{...}{Extra arguments currently ignored.} 17 | } 18 | \value{ 19 | A list of the same class as \code{object}. 20 | } 21 | \description{ 22 | \code{update.fmforecast()} updates \code{fdm} forecasts. The argument \code{object} is the output from \code{\link{forecast.fdm}} which has been subsequently modified with new coefficient forecasts. These new forecasts are used when re-calculating the forecast of the mortality or fertility rates, or net migration numbers. 23 | \code{update.fmforecast2()} updates \code{fdmpr} forecasts. The argument \code{object} is the output from \code{\link{forecast.fdmpr}} which has been subsequently modified with new coefficient forecasts. 24 | } 25 | \examples{ 26 | \dontrun{ 27 | france.fit <- fdm(fr.mort, order = 2) 28 | france.fcast <- forecast(france.fit, 50) 29 | # Replace first coefficient model with ARIMA(0,1,2)+drift 30 | france.fcast$coeff[[2]] <- forecast(Arima(france.fit$coeff[, 2], 31 | order = c(0, 1, 2), include.drift = TRUE 32 | ), h = 50, level = 80) 33 | france.fcast <- update(france.fcast) 34 | 35 | fr.short <- extract.years(fr.sm, 1950:2006) 36 | fr.fit <- coherentfdm(fr.short) 37 | fr.fcast <- forecast(fr.fit) 38 | par(mfrow = c(1, 2)) 39 | plot(fr.fcast$male) 40 | # Replace first coefficient model in product component with a damped ETS model: 41 | fr.fcast$product$coeff[[2]] <- forecast(ets(fr.fit$product$coeff[, 2], damped = TRUE), 42 | h = 50, level = 80 43 | ) 44 | fr.fcast <- update(fr.fcast) 45 | plot(fr.fcast$male) 46 | } 47 | } 48 | \seealso{ 49 | \code{\link{forecast.fdm}}, \code{\link{forecast.fdmpr}} 50 | } 51 | \author{ 52 | Rob J Hyndman. 53 | } 54 | \keyword{models} 55 | -------------------------------------------------------------------------------- /man/pop.sim.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/netmigration.R 3 | \name{pop.sim} 4 | \alias{pop.sim} 5 | \title{Population simulation} 6 | \usage{ 7 | pop.sim( 8 | mort, 9 | fert = NULL, 10 | mig = NULL, 11 | firstyearpop, 12 | N = 100, 13 | mfratio = 1.05, 14 | bootstrap = FALSE 15 | ) 16 | } 17 | \arguments{ 18 | \item{mort}{Forecasts of class \code{fmforecast2} for mortality.} 19 | 20 | \item{fert}{Forecasts of class \code{fmforecast} for female fertility.} 21 | 22 | \item{mig}{Forecasts of class \code{fmforecast2} for net migration.} 23 | 24 | \item{firstyearpop}{Population for first year of simulation.} 25 | 26 | \item{N}{Number of sample paths to simulate.} 27 | 28 | \item{mfratio}{Male-female ratio used in distributing births.} 29 | 30 | \item{bootstrap}{If TRUE, simulation uses resampled errors rather than normally distributed errors.} 31 | } 32 | \value{ 33 | A list of two arrays containing male and female future simulated population values. 34 | The arrays are of dimension (p,h,N) where p is the number of age groups, h is the forecast horizon 35 | and N is the number of simulated sample paths. 36 | } 37 | \description{ 38 | Simulate future sample paths of a population using functional models for mortality, fertility and migration. 39 | } 40 | \examples{ 41 | \dontrun{ 42 | require(addb) 43 | # Construct data objects 44 | mort.sm <- smooth.demogdata(set.upperage(extract.years(australia, 1950:2002), 100)) 45 | fert.sm <- smooth.demogdata(extract.years(aus.fertility, 1950:2002)) 46 | aus.mig <- netmigration(set.upperage(australia, 100), aus.fertility, mfratio = 1.0545) 47 | # Fit models 48 | mort.fit <- coherentfdm(mort.sm) 49 | fert.fit <- fdm(fert.sm) 50 | mig.fit <- coherentfdm(aus.mig) 51 | # Produce forecasts 52 | mort.fcast <- forecast(mort.fit) 53 | fert.fcast <- forecast(fert.fit) 54 | mig.fcast <- forecast(mig.fit) 55 | # Simulate 56 | aus.sim <- pop.sim(mort.fcast, fert.fcast, mig.fcast, australia) 57 | } 58 | 59 | } 60 | \seealso{ 61 | \code{\link{simulate.fmforecast}}, \code{\link{simulate.fmforecast2}}. 62 | } 63 | \author{ 64 | Rob J Hyndman 65 | } 66 | \keyword{models} 67 | -------------------------------------------------------------------------------- /man/forecast.lca.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/lca.R 3 | \name{forecast.lca} 4 | \alias{forecast.lca} 5 | \title{Forecast demogdata data using Lee-Carter method.} 6 | \usage{ 7 | \method{forecast}{lca}( 8 | object, 9 | h = 50, 10 | se = c("innovdrift", "innovonly"), 11 | jumpchoice = c("fit", "actual"), 12 | level = 80, 13 | ... 14 | ) 15 | } 16 | \arguments{ 17 | \item{object}{Output from \code{\link{lca}}.} 18 | 19 | \item{h}{Number of years ahead to forecast.} 20 | 21 | \item{se}{Method used for computation of standard error. Possibilities: \dQuote{innovdrift} (innovations and drift) and \dQuote{innovonly} (innovations only).} 22 | 23 | \item{jumpchoice}{Method used for computation of jumpchoice. Possibilities: \dQuote{actual} (use actual rates from final year) and \dQuote{fit} (use fitted rates).} 24 | 25 | \item{level}{Confidence level for prediction intervals.} 26 | 27 | \item{...}{Other arguments.} 28 | } 29 | \value{ 30 | Object of class \code{fmforecast} with the following components: 31 | \item{label}{Region from which the data are taken.} 32 | \item{age}{Ages from \code{object}.} 33 | \item{year}{Years from \code{object}.} 34 | \item{rate}{List of matrices containing forecasts, lower bound and upper bound of prediction intervals. 35 | Point forecast matrix takes the same name as the series that has been forecast.} 36 | \item{fitted}{Matrix of one-step forecasts for historical data} 37 | Other components included are 38 | \item{e0}{Forecasts of life expectancies (including lower and upper bounds)} 39 | \item{kt.f}{Forecasts of coefficients from the model.} 40 | \item{type}{Data type.} 41 | \item{model}{Details about the fitted model} 42 | } 43 | \description{ 44 | The kt coefficients are forecast using a random walk with drift. 45 | The forecast coefficients are then multiplied by bx to 46 | obtain a forecast demographic rate curve. 47 | } 48 | \examples{ 49 | france.lca <- lca(fr.mort, adjust = "e0") 50 | france.fcast <- forecast(france.lca, 50) 51 | plot(france.fcast) 52 | plot(france.fcast, "c") 53 | } 54 | \seealso{ 55 | \code{\link{lca}}, \code{\link{plot.fmforecast}} 56 | } 57 | \author{ 58 | Rob J Hyndman 59 | } 60 | \keyword{models} 61 | -------------------------------------------------------------------------------- /man/simulate.fmforecast.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/simulate.R 3 | \name{simulate.fmforecast} 4 | \alias{simulate.fmforecast} 5 | \alias{simulate.fmforecast2} 6 | \title{Simulate future sample paths from functional demographic model forecasts.} 7 | \usage{ 8 | \method{simulate}{fmforecast}( 9 | object, 10 | nsim = 100, 11 | seed = NULL, 12 | bootstrap = FALSE, 13 | adjust.modelvar = TRUE, 14 | ... 15 | ) 16 | 17 | \method{simulate}{fmforecast2}(object, ...) 18 | } 19 | \arguments{ 20 | \item{object}{Object of class \code{fmforecast}. Typically, this is output from \code{\link{forecast.fdm}}.} 21 | 22 | \item{nsim}{Number of sample paths to simulate.} 23 | 24 | \item{seed}{Either NULL or an integer that will be used in a call to set.seed before simulating the time seriers. 25 | The default, NULL will not change the random generator state.} 26 | 27 | \item{bootstrap}{If TRUE, simulation uses resampled errors rather than normally distributed errors.} 28 | 29 | \item{adjust.modelvar}{If TRUE, will adjust the model variance by the ratio of the empirical and theoretical variances for one-step forecasts.} 30 | 31 | \item{...}{Other arguments passed to \code{simulate.fmforecast}.} 32 | } 33 | \value{ 34 | An array containing the future simulated values (in the case of a \code{fmforecast} object), 35 | or a list of arrays containing the future simulated values (in the case of a \code{fmforecast2} object). 36 | } 37 | \description{ 38 | This function will simulate future sample paths given forecasting models 39 | from a functional demographic model such as those obtained using \code{\link{forecast.fdm}} or \code{\link{forecast.fdmpr}}. 40 | } 41 | \examples{ 42 | \dontrun{ 43 | france.fit <- fdm(fr.mort, order = 2) 44 | france.fcast <- forecast(france.fit, 50, method = "ets") 45 | france.sim <- simulate(france.fcast, nsim = 100) 46 | 47 | france.fit2 <- coherentfdm(fr.sm) 48 | france.fcast2 <- forecast(france.fit2, 50) 49 | france.sim2 <- simulate(france.fcast2, nsim = 100) 50 | } 51 | } 52 | \seealso{ 53 | \code{\link{forecast.fdm}}, \code{\link{forecast.lca}}, \code{\link[ftsa]{forecast.ftsm}}. 54 | } 55 | \author{ 56 | Rob J Hyndman 57 | } 58 | \keyword{models} 59 | -------------------------------------------------------------------------------- /man/isfe.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fdm.R 3 | \name{isfe} 4 | \alias{isfe} 5 | \alias{isfe.demogdata} 6 | \title{Integrated Squared Forecast Error for models of various orders} 7 | \usage{ 8 | isfe(...) 9 | 10 | \method{isfe}{demogdata}( 11 | data, 12 | series = names(data$rate)[1], 13 | max.order = N - 3, 14 | N = 10, 15 | h = 5:10, 16 | ages = data$age, 17 | max.age = max(ages), 18 | method = c("classical", "M", "rapca"), 19 | fmethod = c("arima", "ar", "arfima", "ets", "ets.na", "struct", "rwdrift", "rw"), 20 | lambda = 3, 21 | ... 22 | ) 23 | } 24 | \arguments{ 25 | \item{...}{Additional arguments control the fitting procedure.} 26 | 27 | \item{data}{demogdata object.} 28 | 29 | \item{series}{name of series within data holding rates (1x1)} 30 | 31 | \item{max.order}{Maximum number of basis functions to fit.} 32 | 33 | \item{N}{Minimum number of functional observations to be used in fitting a 34 | model.} 35 | 36 | \item{h}{Forecast horizons over which to average.} 37 | 38 | \item{ages}{Ages to include in fit.} 39 | 40 | \item{max.age}{Maximum age to fit.} 41 | 42 | \item{method}{Method to use for principal components decomposition. 43 | Possibilities are \dQuote{M}, \dQuote{rapca} and \dQuote{classical}.} 44 | 45 | \item{fmethod}{Method used for forecasting. Current possibilities are 46 | \dQuote{ets}, \dQuote{arima}, \dQuote{ets.na}, \dQuote{struct}, 47 | \dQuote{rwdrift} and \dQuote{rw}.} 48 | 49 | \item{lambda}{Tuning parameter for robustness when \code{method="M"}.} 50 | } 51 | \value{ 52 | Numeric matrix with \code{(max.order+1)} rows and \code{length(h)} columns 53 | containing ISFE values for models of orders 0:max.order. 54 | } 55 | \description{ 56 | Computes ISFE values for functional time series models of various orders. 57 | } 58 | \references{ 59 | Hyndman, R.J., and Ullah, S. (2007) Robust forecasting of mortality and 60 | fertility rates: a functional data approach. \emph{Computational Statistics & Data Analysis}, 61 | \bold{51}, 4942-4956. \url{https://robjhyndman.com/publications/funcfor/} 62 | } 63 | \seealso{ 64 | \code{\link{fdm}}, \code{\link{forecast.fdm}}. 65 | } 66 | \author{ 67 | Rob J Hyndman 68 | } 69 | \keyword{models} 70 | -------------------------------------------------------------------------------- /man/cm.spline.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/monotonic.R 3 | \name{cm.spline} 4 | \alias{cm.spline} 5 | \alias{monotonic} 6 | \alias{cm.splinefun} 7 | \title{Monotonic interpolating splines} 8 | \usage{ 9 | cm.spline(x, y = NULL, n = 3 * length(x), xmin = min(x), xmax = max(x), ...) 10 | 11 | cm.splinefun(x, y = NULL, ...) 12 | } 13 | \arguments{ 14 | \item{x, y}{vectors giving the coordinates of the points to be interpolated. Alternatively a single plotting structure can be specified: see \code{\link[grDevices]{xy.coords}}.} 15 | 16 | \item{n}{interpolation takes place at n equally spaced points spanning the interval [\code{xmin}, \code{xmax}].} 17 | 18 | \item{xmin}{left-hand endpoint of the interpolation interval.} 19 | 20 | \item{xmax}{right-hand endpoint of the interpolation interval.} 21 | 22 | \item{...}{Other arguments are ignored.} 23 | } 24 | \value{ 25 | \item{cm.spline}{returns a list containing components \code{x} and \code{y} which give the ordinates where interpolation took place and the interpolated values.} 26 | \item{cm.splinefun}{returns a function which will perform cubic spline interpolation of the given data points. This is often more useful than \code{spline}.} 27 | } 28 | \description{ 29 | Perform cubic spline monotonic interpolation of given data points, returning either a list of points obtained by the interpolation or a function performing the interpolation. The splines are constrained to be monotonically increasing (i.e., the slope is never negative). 30 | } 31 | \details{ 32 | These are simply wrappers to the \code{\link[stats]{splinefun}} function family from the stats package. 33 | } 34 | \examples{ 35 | x <- seq(0, 4, l = 20) 36 | y <- sort(rnorm(20)) 37 | plot(x, y) 38 | lines(spline(x, y, n = 201), col = 2) # Not necessarily monotonic 39 | lines(cm.spline(x, y, n = 201), col = 3) # Monotonic 40 | } 41 | \references{ 42 | Forsythe, G. E., Malcolm, M. A. and Moler, C. B. (1977) \emph{Computer Methods for Mathematical Computations}. 43 | Hyman (1983) \emph{SIAM J. Sci. Stat. Comput.} \bold{4}(4):645-654. 44 | Dougherty, Edelman and Hyman 1989 \emph{Mathematics of Computation}, \bold{52}: 471-494. 45 | } 46 | \author{ 47 | Rob J Hyndman 48 | } 49 | \keyword{smooth} 50 | -------------------------------------------------------------------------------- /R/as.data.frame.demogdata.R: -------------------------------------------------------------------------------- 1 | #' Coerce a demogdata object to a data.frame object 2 | #' 3 | #' @param x Object to be coerced to a data frame. 4 | #' @param ... Other arguments not used 5 | #' 6 | #' @return A data.frame object. 7 | #' 8 | #' @examples 9 | #' # coerce demogdata object to data.frame ---- 10 | #' as.data.frame(fr.mort) 11 | #' @export 12 | as.data.frame.demogdata <- function(x, ...) { 13 | rates_included <- ("rate" %in% names(x)) 14 | pop_included <- ("pop" %in% names(x)) 15 | # Size of matrices 16 | nyears <- length(x$year) 17 | nages <- length(x$age) 18 | if (rates_included) { 19 | groups <- names(x$rate) 20 | } else if (pop_included) { 21 | groups <- names(x$pop) 22 | } else { 23 | groups <- NULL 24 | } 25 | outlist <- vector(length = nyears, mode = "list") 26 | # Create data frame for rates 27 | for (i in seq_along(groups)) { 28 | outlist[[i]] <- data.frame( 29 | Year = rep(x$year, rep(nages, nyears)), 30 | Age = rep(x$age, nyears), 31 | Group = groups[i] 32 | ) 33 | if (rates_included) { 34 | outlist[[i]]$Rates <- c(x$rate[[i]]) 35 | } 36 | if (pop_included) { 37 | outlist[[i]]$Exposure <- c(x$pop[[i]]) 38 | } 39 | } 40 | out <- do.call("rbind", outlist) 41 | out$Age <- as.integer(out$Age) 42 | out$Year <- as.integer(out$Year) 43 | # Assume Inf rates are due to 0/0 44 | out$Rates[out$Rates == Inf] <- NA_real_ 45 | # Rename rates column 46 | if (x$type == "mortality") { 47 | colnames(out)[4] <- "Mortality" 48 | } else if (x$type == "fertility") { 49 | colnames(out)[4] <- "Fertility" 50 | } else if (x$type == "migration") { 51 | colnames(out)[4] <- "NetMigration" 52 | } else { 53 | stop("Unknown type") 54 | } 55 | # Add counts if available 56 | if (rates_included & pop_included) { 57 | if ("Mortality" %in% colnames(out) & "Exposure" %in% colnames(out)) { 58 | out$Deaths <- out$Exposure * out$Mortality 59 | out$Deaths[is.na(out$Mortality) & out$Exposure > 0] <- 0 60 | } else if ("Fertility" %in% colnames(out) & "Exposure" %in% colnames(out)) { 61 | out$Births <- out$Exposure * out$Fertility / 1000 62 | out$Births[is.na(out$Fertility) & out$Exposure > 0] <- 0 63 | } 64 | } 65 | # Reorganize 66 | out <- out[order(out$Group, out$Year, out$Age), ] 67 | rownames(out) <- NULL 68 | return(out) 69 | } 70 | 71 | utils::globalVariables(c("Deaths", "Births", "Year", "Age", "Exposure", "Group", "Mortality", "Fertility")) 72 | -------------------------------------------------------------------------------- /man/hmd.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/hmd.R 3 | \name{hmd} 4 | \alias{hmd} 5 | \alias{hmd.mx} 6 | \alias{hmd.e0} 7 | \alias{hmd.pop} 8 | \title{Read data from HMD and construct a mortality demogdata object} 9 | \usage{ 10 | hmd.mx(country, username, password, label = country) 11 | 12 | hmd.e0(country, username, password) 13 | 14 | hmd.pop(country, username, password, label = country) 15 | } 16 | \arguments{ 17 | \item{country}{Directory abbreviation from the HMD. For instance, Australia = 18 | "AUS".} 19 | 20 | \item{username}{HMD username (case-sensitive)} 21 | 22 | \item{password}{HMD password (case-sensitive)} 23 | 24 | \item{label}{Character string giving name of country from which the data are 25 | taken.} 26 | } 27 | \value{ 28 | \code{hmd.mx} returns an object of class \code{demogdata} with the following components: 29 | \item{year}{Vector of years} 30 | \item{age}{Vector of ages} 31 | \item{rate}{A list containing one or more rate matrices with one age group per row and one column per year.} 32 | \item{pop}{A list of the same form as \code{rate} but containing population numbers instead of demographic rates.} 33 | \item{type}{Type of object: \dQuote{mortality}, \dQuote{fertility} or \dQuote{migration}.} 34 | \item{label}{label} 35 | \code{hmd.pop} returns a similar object but without the \code{rate} component. 36 | \code{hmd.e0} returns an object of class \code{ts} with columns \code{male}, \code{female} and \code{total}. 37 | } 38 | \description{ 39 | \code{hmd.mx} reads "Mx" (1x1) data from the Human Mortality Database (HMD 40 | \url{https://www.mortality.org}) and constructs a demogdata object suitable 41 | for plotting using \code{\link{plot.demogdata}} and fitting an LC or BMS 42 | model using \code{\link{lca}} or an FDA model using \code{\link{fdm}}. 43 | \code{hmd.pop} reads "Population" (1x1) data from the HMD and constructs a 44 | demogdata object suitable for plotting using \code{\link{plot.demogdata}}. 45 | \code{hmd.e0} reads life expectancy at birth from the HMD and returns the 46 | result as a \code{ts} object. 47 | } 48 | \details{ 49 | In order to read the data, users are required to create their account via the HMD website (\url{https://www.mortality.org}), 50 | and obtain a valid username and password. 51 | } 52 | \examples{ 53 | \dontrun{ 54 | norway <- hmd.mx("NOR", username, password, "Norway") 55 | summary(norway) 56 | } 57 | } 58 | \seealso{ 59 | \code{\link{demogdata}},\code{\link{read.demogdata}},\code{\link{plot.demogdata}}, \code{\link{life.expectancy}} 60 | } 61 | \author{ 62 | Rob J Hyndman 63 | } 64 | \keyword{manip} 65 | -------------------------------------------------------------------------------- /man/forecast.fdm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fdm.R 3 | \name{forecast.fdm} 4 | \alias{forecast.fdm} 5 | \title{Forecast functional demographic model.} 6 | \usage{ 7 | \method{forecast}{fdm}( 8 | object, 9 | h = 50, 10 | level = 80, 11 | jumpchoice = c("fit", "actual"), 12 | method = "arima", 13 | warnings = FALSE, 14 | ... 15 | ) 16 | } 17 | \arguments{ 18 | \item{object}{Output from \code{\link{fdm}}.} 19 | 20 | \item{h}{Forecast horizon.} 21 | 22 | \item{level}{Confidence level for prediction intervals.} 23 | 24 | \item{jumpchoice}{If "actual", the forecasts are bias-adjusted by the 25 | difference between the fit and the last year of observed data. Otherwise, 26 | no adjustment is used.} 27 | 28 | \item{method}{Forecasting method to be used.} 29 | 30 | \item{warnings}{If TRUE, warnings arising from the forecast models for 31 | coefficients will be shown. Most of these can be ignored, so the default is 32 | \code{warnings=FALSE}.} 33 | 34 | \item{...}{Other arguments as for \code{\link[ftsa]{forecast.ftsm}}.} 35 | } 36 | \value{ 37 | Object of class \code{fmforecast} with the following components: 38 | \item{label}{Name of region from which the data are taken.} \item{age}{Ages 39 | from \code{lcaout} object.} \item{year}{Years from \code{lcaout} object.} 40 | \item{rate}{List of matrices containing forecasts, lower bound and upper 41 | bound of prediction intervals. Point forecast matrix takes the same name as 42 | the series that has been forecast.} \item{error}{Matrix of one-step errors 43 | for historical data} \item{fitted}{Matrix of one-step forecasts for 44 | historical data} \item{coeff}{List of objects of type \code{forecast} 45 | containing the coefficients and their forecasts.} 46 | \item{coeff.error}{One-step errors for each of the coefficients.} 47 | \item{var}{List containing the various components of variance: model, 48 | error, mean, total and coeff.} \item{model}{Fitted model in \code{obj}.} 49 | \item{type}{Type of data: \dQuote{mortality}, \dQuote{fertility} or 50 | \dQuote{migration}.} 51 | } 52 | \description{ 53 | The coefficients from the fitted object are forecast using a univariate time 54 | series model. The forecast coefficients are then multiplied by the basis 55 | functions to obtain a forecast demographic rate curve. 56 | } 57 | \examples{ 58 | france.fit <- fdm(fr.mort, order = 2) 59 | france.fcast <- forecast(france.fit, 50) 60 | plot(france.fcast) 61 | models(france.fcast) 62 | } 63 | \seealso{ 64 | \code{\link{fdm}}, \code{\link{forecast.lca}}, \code{\link[ftsa]{forecast.ftsm}}. 65 | } 66 | \author{ 67 | Rob J Hyndman 68 | } 69 | \keyword{models} 70 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(as.data.frame,demogdata) 4 | S3method(as.data.frame,lifetable) 5 | S3method(fitted,fdm) 6 | S3method(fitted,lca) 7 | S3method(forecast,fdm) 8 | S3method(forecast,fdmpr) 9 | S3method(forecast,lca) 10 | S3method(isfe,demogdata) 11 | S3method(lines,demogdata) 12 | S3method(lines,lifetable) 13 | S3method(mean,demogdata) 14 | S3method(median,demogdata) 15 | S3method(models,fmforecast) 16 | S3method(models,fmforecast2) 17 | S3method(plot,demogdata) 18 | S3method(plot,errorfdm) 19 | S3method(plot,fmforecast) 20 | S3method(plot,lca) 21 | S3method(plot,lifetable) 22 | S3method(points,demogdata) 23 | S3method(print,demogdata) 24 | S3method(print,errorfdm) 25 | S3method(print,fdm) 26 | S3method(print,fmforecast) 27 | S3method(print,lca) 28 | S3method(print,lifetable) 29 | S3method(residuals,fdm) 30 | S3method(residuals,lca) 31 | S3method(simulate,fmforecast) 32 | S3method(simulate,fmforecast2) 33 | S3method(summary,demogdata) 34 | S3method(summary,fdm) 35 | S3method(summary,fdmpr) 36 | S3method(summary,fmforecast) 37 | S3method(summary,fmforecast2) 38 | S3method(summary,lca) 39 | S3method(update,fmforecast) 40 | S3method(update,fmforecast2) 41 | export(bms) 42 | export(cm.spline) 43 | export(cm.splinefun) 44 | export(coherentfdm) 45 | export(combine.demogdata) 46 | export(compare.demogdata) 47 | export(demogdata) 48 | export(e0) 49 | export(extract.ages) 50 | export(extract.years) 51 | export(fdm) 52 | export(flife.expectancy) 53 | export(hmd.e0) 54 | export(hmd.mx) 55 | export(hmd.pop) 56 | export(isfe) 57 | export(lca) 58 | export(life.expectancy) 59 | export(lifetable) 60 | export(models) 61 | export(netmigration) 62 | export(pop.sim) 63 | export(read.demogdata) 64 | export(set.upperage) 65 | export(sex.ratio) 66 | export(smooth.demogdata) 67 | export(tfr) 68 | import(cobs) 69 | import(forecast) 70 | import(ftsa) 71 | import(mgcv) 72 | import(rainbow) 73 | importFrom(graphics,abline) 74 | importFrom(graphics,lines) 75 | importFrom(graphics,plot) 76 | importFrom(stats,"tsp<-") 77 | importFrom(stats,approx) 78 | importFrom(stats,frequency) 79 | importFrom(stats,glm) 80 | importFrom(stats,lm) 81 | importFrom(stats,loess) 82 | importFrom(stats,median) 83 | importFrom(stats,na.omit) 84 | importFrom(stats,nlm) 85 | importFrom(stats,poisson) 86 | importFrom(stats,predict) 87 | importFrom(stats,qnorm) 88 | importFrom(stats,rbinom) 89 | importFrom(stats,rpois) 90 | importFrom(stats,simulate) 91 | importFrom(stats,spline) 92 | importFrom(stats,splinefun) 93 | importFrom(stats,start) 94 | importFrom(stats,time) 95 | importFrom(stats,ts) 96 | importFrom(stats,tsp) 97 | importFrom(stats,uniroot) 98 | importFrom(stats,update) 99 | importFrom(stats,window) 100 | importFrom(utils,read.table) 101 | -------------------------------------------------------------------------------- /R/fertility.R: -------------------------------------------------------------------------------- 1 | #' Compute total fertility rate from fertility rates 2 | #' 3 | #' Compute total fertility rates from age-specific fertility rates contained in 4 | #' a \code{demogdata} object. 5 | #' 6 | #' @param data Demogdata object of type \code{"fertility"} such as obtained from 7 | #' \code{\link{read.demogdata}}, \code{\link{forecast.fdm}}. 8 | #' @param PI If TRUE, produce a prediction interval. 9 | #' @param nsim Number of simulations to use when computing a prediction 10 | #' interval. 11 | #' @param ... Other arguments passed to \code{simulate} when producing 12 | #' prediction intervals. 13 | #' 14 | #' @return If data are of class \code{demogdata}, the function returns a time 15 | #' series of fertility rates. If data are from \code{\link{forecast.fdm}}, the 16 | #' function returns an object of class \code{forecast} containing point 17 | #' forecasts and (optionally) prediction intervals. 18 | #' 19 | #' @author Rob J Hyndman 20 | #' @seealso \code{\link{fdm}} 21 | #' @examples 22 | #' plot(tfr(aus.fert)) 23 | #' ausfert.fcast <- forecast(fdm(aus.fert)) 24 | #' plot(tfr(ausfert.fcast, PI = TRUE, nsim = 400)) 25 | #' 26 | #' @keywords models 27 | #' @export 28 | tfr <- function(data, PI = FALSE, nsim = 500, ...) { 29 | if (!is.element("demogdata", class(data))) { 30 | stop("data must be a demogdata object") 31 | } 32 | if (data$type != "fertility") { 33 | stop("data must be a fertility object") 34 | } 35 | 36 | agegroup <- data$age[3] - data$age[2] 37 | n <- length(data$rate) 38 | tfr.mat <- matrix(NA, ncol = n, nrow = length(data$year)) 39 | for (j in 1:n) { 40 | tfr.mat[, j] <- colSums(data$rate[[j]], na.rm = TRUE) * agegroup 41 | } 42 | out <- ts(tfr.mat, start = data$year[1], frequency = 1) 43 | if (is.element("fmforecast", class(data))) { 44 | hdata <- data$model 45 | hdata$rate <- list(InvBoxCox(hdata[[4]], data$lambda)) 46 | names(hdata$rate) <- names(hdata)[4] 47 | if (!is.null(data$model$pop)) { 48 | hdata$pop <- list(data$model$pop) 49 | names(hdata$pop) <- names(hdata$rate) 50 | } 51 | class(hdata) <- "demogdata" 52 | out <- structure(list(x = tfr(hdata), mean = out[, 1], method = "FDM model"), class = "forecast") 53 | if (PI) # Compute prediction intervals 54 | { 55 | sim <- simulate(data, nsim, ...) 56 | tfrsim <- matrix(NA, dim(sim)[2], dim(sim)[3]) 57 | simdata <- data 58 | for (i in 1:dim(sim)[3]) 59 | { 60 | simdata$rate[[1]] <- as.matrix(sim[, , i]) 61 | tfrsim[, i] <- tfr(simdata, PI = FALSE)$mean 62 | } 63 | 64 | out$level <- data$coeff[[1]]$level 65 | out$lower <- apply(tfrsim, 1, quantile, prob = 0.5 - out$level / 200) 66 | out$upper <- apply(tfrsim, 1, quantile, prob = 0.5 + out$level / 200) 67 | out$sim <- sim 68 | } 69 | } 70 | return(out) 71 | } 72 | -------------------------------------------------------------------------------- /man/plot.demogdata.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/demogdata.R 3 | \name{plot.demogdata} 4 | \alias{plot.demogdata} 5 | \alias{lines.demogdata} 6 | \alias{points.demogdata} 7 | \title{Plot age-specific demographic functions} 8 | \usage{ 9 | \method{plot}{demogdata}( 10 | x, 11 | series = ifelse(!is.null(x$rate), names(x$rate)[1], names(x$pop)[1]), 12 | datatype = ifelse(!is.null(x$rate), "rate", "pop"), 13 | years = x$year, 14 | ages = x$age, 15 | max.age = max(x$age), 16 | transform = (x$type == "mortality"), 17 | plot.type = c("functions", "time", "depth", "density"), 18 | type = "l", 19 | main = NULL, 20 | xlab, 21 | ylab, 22 | ... 23 | ) 24 | 25 | \method{lines}{demogdata}( 26 | x, 27 | series = ifelse(!is.null(x$rate), names(x$rate)[1], names(x$pop)[1]), 28 | datatype = ifelse(!is.null(x$rate), "rate", ""), 29 | years = x$year, 30 | ages = x$age, 31 | max.age = max(x$age), 32 | transform = (x$type == "mortality"), 33 | plot.type = c("functions", "time", "depth", "density"), 34 | ... 35 | ) 36 | 37 | \method{points}{demogdata}(..., pch = 1) 38 | } 39 | \arguments{ 40 | \item{x}{Demogdata object such as created using \code{\link{read.demogdata}} or \code{\link{smooth.demogdata}}.} 41 | 42 | \item{series}{Name of series to plot. Default: the first matrix within \code{datatype}.} 43 | 44 | \item{datatype}{Name of demogdata object which contains series. Default \dQuote{rate}. Alternative: \dQuote{pop}.} 45 | 46 | \item{years}{Vector indicating which years to plot. Default: all available years.} 47 | 48 | \item{ages}{Vector indicating which ages to plot. Default: all available ages.} 49 | 50 | \item{max.age}{Maximum age to plot. Default: all available ages.} 51 | 52 | \item{transform}{Should a transformation of the data be plotted? Default is TRUE if the object contains mortality data and datatype="rate", and FALSE otherwise.} 53 | 54 | \item{plot.type}{Type of plot: either \dQuote{functions} or \dQuote{time}.} 55 | 56 | \item{type}{What type of plot should be drawn. See \code{\link[base]{plot}} for possible types.} 57 | 58 | \item{main}{Main title for the plot.} 59 | 60 | \item{xlab}{Label for x-axis.} 61 | 62 | \item{ylab}{Label for y-axis.} 63 | 64 | \item{...}{Other plotting parameters. In \code{points.demogdata}, all arguments are passed to \code{lines.demogdata}.} 65 | 66 | \item{pch}{Plotting character.} 67 | } 68 | \value{ 69 | None. Function produces a plot 70 | } 71 | \description{ 72 | If \code{plot.type="functions"}, then years are plotted using a rainbow palette so the 73 | earliest years are red, followed by orange, yellow, green, blue 74 | and indigo with the most recent years plotted in violet. 75 | If \code{plot.type="time"}, then each age is shown as a separate time series in a time plot. 76 | } 77 | \examples{ 78 | plot(fr.mort) 79 | par(mfrow=c(1,2)) 80 | plot(aus.fert,plot.type="time") 81 | plot(aus.fert,plot.type="functions") 82 | } 83 | \author{ 84 | Rob J Hyndman 85 | } 86 | \keyword{hplot} 87 | -------------------------------------------------------------------------------- /man/life.expectancy.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/lifetable.R 3 | \name{life.expectancy} 4 | \alias{life.expectancy} 5 | \alias{flife.expectancy} 6 | \alias{e0} 7 | \title{Estimate life expectancy from mortality rates} 8 | \usage{ 9 | life.expectancy( 10 | data, 11 | series = names(data$rate)[1], 12 | years = data$year, 13 | type = c("period", "cohort"), 14 | age = min(data$age), 15 | max.age = min(100, max(data$age)) 16 | ) 17 | 18 | flife.expectancy( 19 | data, 20 | series = NULL, 21 | years = data$year, 22 | type = c("period", "cohort"), 23 | age, 24 | max.age = NULL, 25 | PI = FALSE, 26 | nsim = 500, 27 | ... 28 | ) 29 | 30 | e0( 31 | data, 32 | series = NULL, 33 | years = data$year, 34 | type = c("period", "cohort"), 35 | max.age = NULL, 36 | PI = FALSE, 37 | nsim = 500, 38 | ... 39 | ) 40 | } 41 | \arguments{ 42 | \item{data}{Demogdata object of type \dQuote{mortality} such as obtained from \code{\link{read.demogdata}}, 43 | or an object of class \code{fmforecast} such as the output from \code{\link{forecast.fdm}} or \code{\link{forecast.lca}}, 44 | or an object of class \code{fmforecast2} such as the output from \code{\link{forecast.fdmpr}}.} 45 | 46 | \item{series}{Name of mortality series to use. Default is the first demogdata series in data.} 47 | 48 | \item{years}{Vector indicating which years to use.} 49 | 50 | \item{type}{Either \code{period} or \code{cohort}.} 51 | 52 | \item{age}{Age at which life expectancy is to be calculated.} 53 | 54 | \item{max.age}{Maximum age for life table calculation.} 55 | 56 | \item{PI}{If TRUE, produce a prediction interval.} 57 | 58 | \item{nsim}{Number of simulations to use when computing a prediction interval.} 59 | 60 | \item{...}{Other arguments passed to \code{simulate} when producing prediction intervals.} 61 | } 62 | \value{ 63 | Time series of life expectancies (one per year), or a forecast object of life expectancies (one per year). 64 | } 65 | \description{ 66 | All three functions estimate life expectancy from \code{lifetable}. 67 | The function \code{flife.expectancy} is primarily designed for forecast life expectancies and will optionally 68 | produce prediction intervals. Where appropriate, it will package the results as a forecast object 69 | which makes it much easier to product nice plots of forecast life expectancies. 70 | The \code{e0} function is a shorthand wrapper for \code{flife.expectancy} with \code{age=0}. 71 | } 72 | \examples{ 73 | plot(life.expectancy(fr.mort), ylab = "Life expectancy") 74 | 75 | france.LC <- lca(fr.mort, adjust = "e0", years = 1950:1997) 76 | france.fcast <- forecast(france.LC, jumpchoice = "actual") 77 | france.e0.f <- life.expectancy(france.fcast) 78 | 79 | france.fdm <- fdm(extract.years(fr.mort, years = 1950:2006)) 80 | france.fcast <- forecast(france.fdm) 81 | \dontrun{ 82 | e0.fcast <- e0(france.fcast, PI = TRUE, nsim = 200) 83 | plot(e0.fcast) 84 | } 85 | 86 | life.expectancy(fr.mort, type = "cohort", age = 50) 87 | 88 | } 89 | \seealso{ 90 | \code{\link{lifetable}} 91 | } 92 | \author{ 93 | Rob J Hyndman 94 | } 95 | \keyword{models} 96 | -------------------------------------------------------------------------------- /man/read.demogdata.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/demogdata.R 3 | \name{read.demogdata} 4 | \alias{read.demogdata} 5 | \title{Read demographic data and construct demogdata object} 6 | \usage{ 7 | read.demogdata( 8 | file, 9 | popfile, 10 | type, 11 | label, 12 | max.mx = 10, 13 | skip = 2, 14 | popskip = skip, 15 | lambda, 16 | scale = 1 17 | ) 18 | } 19 | \arguments{ 20 | \item{file}{Filename containing demographic rates.} 21 | 22 | \item{popfile}{Filename containing population numbers.} 23 | 24 | \item{type}{Character string showing type of demographic series: 25 | either \dQuote{mortality}, \dQuote{fertility} or \dQuote{migration}.} 26 | 27 | \item{label}{Name of area from which the data are taken.} 28 | 29 | \item{max.mx}{Maximum allowable value for demographic rate. All values greater than max.mx will be set to max.mx.} 30 | 31 | \item{skip}{Number of lines to skip at the start of \code{file}.} 32 | 33 | \item{popskip}{Number of lines to skip at the start of \code{popfile}.} 34 | 35 | \item{lambda}{Box-Cox transformation parameter to be used in modelling and plotting. If missing, default values are 0 (for mortality), 0.4 (for fertility) and 1 (for migration).} 36 | 37 | \item{scale}{Number of people in the rate definition. \code{scale=1} indicates the rates are per person; \code{scale=1000} indicates the rates are per 1000 people.} 38 | } 39 | \value{ 40 | Object of class \dQuote{demogdata} with the following components: 41 | \item{year}{Vector of years} \item{age}{Vector of ages} \item{rate}{A list 42 | containing one or more rate matrices with one age group per row and one 43 | column per year.} \item{pop}{A list of the same form as \code{rate} but 44 | containing population numbers instead of demographic rates.} 45 | \item{type}{Type of object: \dQuote{mortality}, \dQuote{fertility} or 46 | \dQuote{migration}.} \item{label}{label} 47 | } 48 | \description{ 49 | Read data from text files and construct a demogdata object suitable for 50 | plotting using \code{\link{plot.demogdata}} and fitting an LC or BMS model 51 | using \code{\link{lca}} or an FDA model using \code{\link{fdm}}. 52 | } 53 | \details{ 54 | All data are assumed to be tab-delimited text files with the first column 55 | containing the year of observation and the second column containing the age 56 | level. All remaining columns are assumed to be demographic rates for sections 57 | of the population. The first row of the text file is assumed to contain the 58 | names of each column. Population data are assumed to have the same format but 59 | with population numbers in place of rates. The columns names in the two 60 | files should be identical. Note that this format is what is used by the Human 61 | Mortality Database \url{http://www.mortality.org}. If \code{popfile} contains 62 | the Exposures and \code{file} contains the Mx rates from the HMD, then 63 | everything will work seamlessly. 64 | } 65 | \examples{ 66 | 67 | \dontrun{norway <- read.demogdata("Mx_1x1.txt", 68 | "Exposures_1x1.txt", type="mortality", label="Norway")} 69 | } 70 | \seealso{ 71 | \code{\link{demogdata}} 72 | } 73 | \author{ 74 | Rob J Hyndman 75 | } 76 | \keyword{manip} 77 | -------------------------------------------------------------------------------- /man/compare.demogdata.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fdm.R 3 | \name{compare.demogdata} 4 | \alias{compare.demogdata} 5 | \title{Evaluation of demographic forecast accuracy} 6 | \usage{ 7 | compare.demogdata( 8 | data, 9 | forecast, 10 | series = names(forecast$rate)[1], 11 | ages = data$age, 12 | max.age = min(max(data$age), max(forecast$age)), 13 | years = data$year, 14 | interpolate = FALSE 15 | ) 16 | } 17 | \arguments{ 18 | \item{data}{Demogdata object such as created using 19 | \code{\link{read.demogdata}} containing actual demographic rates.} 20 | 21 | \item{forecast}{Demogdata object such as created using 22 | \code{\link{forecast.fdm}} or \code{\link{forecast.lca}}.} 23 | 24 | \item{series}{Name of series to use. Default: the first matrix within 25 | \code{forecast$rate}.} 26 | 27 | \item{ages}{Ages to use for comparison. Default: all available ages.} 28 | 29 | \item{max.age}{Upper age to use for comparison.} 30 | 31 | \item{years}{Years to use in comparison. Default is to use all available 32 | years that are common between data and forecast.} 33 | 34 | \item{interpolate}{If TRUE, all zeros in data are replaced by interpolated 35 | estimates when computing the error measures on the log scale. Error 36 | measures on the original (rate) scale are unchanged.} 37 | } 38 | \value{ 39 | Object of class "errorfdm" with the following components: 40 | \item{label}{Name of region from which data taken.} 41 | \item{age}{Ages from \code{data} object.} 42 | \item{year}{Years from \code{data} object.} 43 | \item{}{Matrix of forecast errors on rates.} 44 | \item{}{Matrix of forecast errors on log rates.} 45 | \item{mean.error}{Various measures of forecast accuracy averaged across 46 | years. Specifically ME=mean error, MSE=mean squared error, MPE=mean 47 | percentage error and MAPE=mean absolute percentage error.} 48 | \item{int.error}{Various measures of forecast accuracy integrated across 49 | ages. Specifically IE=integrated error, ISE=integrated squared error, 50 | IPE=integrated percentage error and IAPE=integrated absolute percentage 51 | error.} 52 | \item{life.expectancy}{If \code{data$type="mortality"}, function 53 | returns this component which is a matrix containing actual, forecast and 54 | actual-forecast for life expectancies.} Note that the error matrices have 55 | different names indicating if the series forecast was male, female or 56 | total. 57 | } 58 | \description{ 59 | Computes mean forecast errors and mean square forecast errors for each age 60 | level. Computes integrated squared forecast errors and integrated absolute 61 | percentage forecast errors for each year. 62 | } 63 | \examples{ 64 | fr.test <- extract.years(fr.sm, years = 1921:1980) 65 | fr.fit <- fdm(fr.test, order = 2) 66 | fr.error <- compare.demogdata(fr.mort, forecast(fr.fit, 20)) 67 | plot(fr.error) 68 | par(mfrow = c(2, 1)) 69 | plot(fr.error$age, fr.error$mean.error[, "ME"], 70 | type = "l", xlab = "Age", ylab = "Mean Forecast Error" 71 | ) 72 | plot(fr.error$int.error[, "ISE"], 73 | xlab = "Year", ylab = "Integrated Square Error" 74 | ) 75 | 76 | } 77 | \seealso{ 78 | \link{forecast.fdm},\link{plot.errorfdm} 79 | } 80 | \author{ 81 | Rob J Hyndman 82 | } 83 | \keyword{models} 84 | -------------------------------------------------------------------------------- /man/fdm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fdm.R 3 | \name{fdm} 4 | \alias{fdm} 5 | \title{Functional demographic model} 6 | \usage{ 7 | fdm( 8 | data, 9 | series = names(data$rate)[1], 10 | order = 6, 11 | ages = data$age, 12 | max.age = max(ages), 13 | method = c("classical", "M", "rapca"), 14 | lambda = 3, 15 | mean = TRUE, 16 | level = FALSE, 17 | transform = TRUE, 18 | ... 19 | ) 20 | } 21 | \arguments{ 22 | \item{data}{demogdata object. Output from read.demogdata.} 23 | 24 | \item{series}{name of series within data holding rates (1x1).} 25 | 26 | \item{order}{Number of basis functions to fit.} 27 | 28 | \item{ages}{Ages to include in fit.} 29 | 30 | \item{max.age}{Maximum age to fit. Ages beyond this are collapsed into the 31 | upper age group.} 32 | 33 | \item{method}{Method to use for principal components decomposition. 34 | Possibilities are \dQuote{M}, \dQuote{rapca} and \dQuote{classical}. See 35 | \code{\link[ftsa]{ftsm}} for details.} 36 | 37 | \item{lambda}{Tuning parameter for robustness when \code{method="M"}.} 38 | 39 | \item{mean}{If TRUE, will estimate mean term in the model before computing 40 | basis terms. If FALSE, the mean term is assumed to be zero.} 41 | 42 | \item{level}{If TRUE, will include an additional (intercept) term that 43 | depends on the year but not on ages.} 44 | 45 | \item{transform}{If TRUE, the data are transformed with a Box-Cox 46 | transformation before the model is fitted.} 47 | 48 | \item{...}{Extra arguments passed to \code{\link[ftsa]{ftsm}}.} 49 | } 50 | \value{ 51 | Object of class \dQuote{fdm} with the following components: 52 | \item{label}{Name of country} \item{age}{Ages from \code{data} object.} 53 | \item{year}{Years from \code{data} object.} \item{}{Matrix of 54 | demographic data as contained in \code{data}. It takes the name given by 55 | the series argument.} \item{fitted}{Matrix of fitted values.} 56 | \item{residuals}{Residuals (difference between observed and fitted).} 57 | \item{basis}{Matrix of basis functions evaluated at each age level (one 58 | column for each basis function). The first column is the fitted mean.} 59 | \item{coeffs}{Matrix of coefficients (one column for each coefficient 60 | series). The first column are all ones.} \item{mean.se}{Standard errors for 61 | the estimated mean function.} \item{varprop}{Proportion of variation 62 | explained by each basis function.} \item{weights}{Weight associated with 63 | each time period.} \item{v}{Measure of variation for each time period.} 64 | \item{type}{Data type (mortality, fertility, etc.)} \item{y}{The data 65 | stored as a functional time series object.} 66 | } 67 | \description{ 68 | Fits a basis function model to demographic data. The function uses optimal 69 | orthonormal basis functions obtained from a principal components 70 | decomposition. 71 | } 72 | \examples{ 73 | france.fit <- fdm(fr.mort) 74 | summary(france.fit) 75 | plot(france.fit) 76 | plot(residuals(france.fit)) 77 | 78 | } 79 | \references{ 80 | Hyndman, R.J., and Ullah, S. (2007) Robust forecasting of 81 | mortality and fertility rates: a functional data approach. 82 | \emph{Computational Statistics & Data Analysis}, \bold{51}, 4942-4956. 83 | \url{https://robjhyndman.com/publications/funcfor/} 84 | } 85 | \seealso{ 86 | \code{\link[ftsa]{ftsm}}, \code{\link{forecast.fdm}} 87 | } 88 | \author{ 89 | Rob J Hyndman 90 | } 91 | \keyword{models} 92 | -------------------------------------------------------------------------------- /man/smooth.demogdata.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/smooth.R 3 | \name{smooth.demogdata} 4 | \alias{smooth.demogdata} 5 | \title{Create smooth demogdata functions} 6 | \usage{ 7 | smooth.demogdata( 8 | data, 9 | method = switch(data$type, mortality = "mspline", fertility = "cspline", migration = 10 | "loess"), 11 | age.grid, 12 | power = switch(data$type, mortality = 0.4, fertility = 1, migration = 1), 13 | b = 65, 14 | k = 30, 15 | span = 0.2, 16 | lambda = 1e-10, 17 | interpolate = FALSE, 18 | weight = data$type != "migration", 19 | obs.var = "empirical" 20 | ) 21 | } 22 | \arguments{ 23 | \item{data}{Demogdata object such as created using \code{\link{read.demogdata}}.} 24 | 25 | \item{method}{Method of smoothing. Possibilities: \code{"mspline"} (monotonic regression splines), 26 | \code{"cspline"} (concave regression splines), 27 | \code{"spline"} (unconstrained regression splines), 28 | \code{"loess"} (local quadratic using \code{\link{loess}}).} 29 | 30 | \item{age.grid}{Ages to use for smoothed curves. Default is single years over a slightly greater range than the unsmoothed data.} 31 | 32 | \item{power}{Power transformation for age variable before smoothing. Default is 0.4 for mortality data and 1 (no transformation) for fertility or migration data.} 33 | 34 | \item{b}{Lower age for monotonicity if \code{method=="mspline"}. Above this, the smooth curve 35 | is assumed to be monotonically increasing.} 36 | 37 | \item{k}{Number of knots to use for penalized regression spline estimate. Ignored if \code{method=="loess"}.} 38 | 39 | \item{span}{Span for loess smooth if \code{method=="loess"}.} 40 | 41 | \item{lambda}{Penalty for constrained regression spline if \code{method=="cspline"}.} 42 | 43 | \item{interpolate}{If \code{interpolate==TRUE}, a linear interpolation is used instead of smoothing.} 44 | 45 | \item{weight}{If TRUE, uses weighted smoothing.} 46 | 47 | \item{obs.var}{Method for computing observational variance. Possible values: \dQuote{empirical} or \dQuote{theoretical}.} 48 | } 49 | \value{ 50 | Demogdata object identical to \code{data} except all 51 | rate matrices are replaced with smooth versions and pop matrices are replaced with disaggregated population estimates obtained 52 | using monotonic spline interpolation applied to the cumulative population data. 53 | Weight 54 | matrices are also added to the object showing the inverse 55 | variances of the estimated smooth curves. 56 | } 57 | \description{ 58 | Smooth demogdata data using one of four methods depending on the value of \code{method} 59 | } 60 | \details{ 61 | The value of \code{method} determines the type of smoothing used. 62 | \describe{ 63 | \item{method="mspline"}{Weighted penalized regression splines with a monotonicity constraint. The curves are monotonically 64 | increasing for age greater than b. Smoothness controlled by \code{k}. Methodology based on Wood (1994). Code calls \code{\link[mgcv]{gam}} for the basic 65 | computations.} 66 | \item{method="cspline"}{Weighted regression B-splines with a concavity constraint. Smoothness controlled by \code{lambda}. 67 | Methodology based on He and Ng (1999). Code calls \code{\link[cobs]{cobs}} for the basic computations.} 68 | \item{method="spline"}{Unconstrained weighted penalized regression splines. Equivalent to "mspline" but with \code{b=Inf}.} 69 | \item{method="loess"}{Weighted locally quadratic regression. Smoothness controlled by span. Code calls 70 | \code{\link{loess}} for the basic computations.} 71 | } 72 | } 73 | \examples{ 74 | france.sm <- smooth.demogdata(extract.years(fr.mort, 1980:1997)) 75 | plot(france.sm) 76 | plot(fr.mort, years = 1980, type = "p", pch = 1) 77 | lines(france.sm, years = 1980, col = 2) 78 | 79 | } 80 | \author{ 81 | Rob J Hyndman 82 | } 83 | \keyword{smooth} 84 | -------------------------------------------------------------------------------- /man/lifetable.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/lifetable.R 3 | \name{lifetable} 4 | \alias{lifetable} 5 | \title{Construct lifetables from mortality rates} 6 | \usage{ 7 | lifetable( 8 | data, 9 | series = names(data$rate)[1], 10 | years = data$year, 11 | ages = data$age, 12 | max.age = min(100, max(data$age)), 13 | type = c("period", "cohort") 14 | ) 15 | } 16 | \arguments{ 17 | \item{data}{Demogdata object such as obtained from \code{\link{read.demogdata}}, 18 | \code{\link{forecast.fdm}} or \code{\link{forecast.lca}}.} 19 | 20 | \item{series}{Name of series to use. Default is the first series in \code{data[["rate"]]}.} 21 | 22 | \item{years}{Vector indicating which years to include in the tables.} 23 | 24 | \item{ages}{Vector indicating which ages to include in table.} 25 | 26 | \item{max.age}{Age for last row. Ages beyond this are combined.} 27 | 28 | \item{type}{Type of lifetable: \code{period} or \code{cohort}.} 29 | } 30 | \value{ 31 | Object of class \dQuote{lifetable} containing the following components: 32 | \item{label}{Name of region from which data are taken.} 33 | \item{series}{Name of series} 34 | \item{age}{Ages for lifetable} 35 | \item{year}{Period years or cohort years} 36 | \item{mx}{Death rate at age x.} 37 | \item{qx}{The probability that an individual of exact age x will die before exact age x+1.} 38 | \item{lx}{Number of survivors to exact age x. The radix is 1.} 39 | \item{dx}{The number of deaths between exact ages x and x+1.} 40 | \item{Lx}{Number of years lived between exact age x and exact age x+1.} 41 | \item{Tx}{Number of years lived after exact age x.} 42 | \item{ex}{Remaining life expectancy at exact age x.} 43 | Note that the lifetables themselves are not returned, only their components. However, there is a print method that constructs (and returns) 44 | the lifetables from the above components. 45 | } 46 | \description{ 47 | Computes period and cohort lifetables from mortality rates for multiple years. 48 | } 49 | \details{ 50 | For period lifetables, all years and all ages specified are included in the tables. For cohort lifetables, 51 | if \code{ages} takes a scalar value, then the cohorts are taken to be of that age in each year contained in \code{years}. 52 | But if \code{ages} is a vector of values, then the cohorts are taken to be of those ages in the first year contained in \code{years}. 53 | 54 | For example, if \code{ages=0} then lifetables of the birth cohorts for all years in \code{years} are computed. On the other hand, 55 | if \code{ages=0:100} and \code{years=1950:2010}, then lifetables of each age cohort in 1950 are computed. 56 | 57 | In all cases, \eqn{q_x = m_x/(1+[(1-a_x)m_x])}{qx = mx/(1 + ((1-ax) * mx))} as per Chiang (1984). 58 | 59 | Warning: the code has only been tested for data based on single-year age groups. 60 | } 61 | \examples{ 62 | france.lt <- lifetable(fr.mort) 63 | plot(france.lt) 64 | lt1990 <- print(lifetable(fr.mort, year = 1990)) 65 | 66 | france.LC <- lca(fr.mort) 67 | france.fcast <- forecast(france.LC) 68 | france.lt.f <- lifetable(france.fcast) 69 | plot(france.lt.f) 70 | 71 | # Birth cohort lifetables, 1900-1910 72 | france.clt <- lifetable(fr.mort, type = "cohort", age = 0, years = 1900:1910) 73 | 74 | # Partial cohort lifetables for 1950 75 | lifetable(fr.mort, years = 1950) 76 | } 77 | \references{ 78 | Chiang CL. (1984) \emph{The life table and its applications}. Robert E Krieger Publishing Company: Malabar. 79 | 80 | Keyfitz, N, and Caswell, H. (2005) \emph{Applied mathematical demography}, Springer-Verlag: New York. 81 | 82 | Preston, S.H., Heuveline, P., and Guillot, M. (2001) \emph{Demography: measuring and modeling population processes}. Blackwell 83 | } 84 | \seealso{ 85 | \code{\link{life.expectancy}} 86 | } 87 | \author{ 88 | Heather Booth, Leonie Tickle, Rob J Hyndman, John Maindonald and Timothy Miller 89 | } 90 | \keyword{models} 91 | -------------------------------------------------------------------------------- /R/hmd.R: -------------------------------------------------------------------------------- 1 | #' Read data from HMD and construct a mortality demogdata object 2 | #' 3 | #' \code{hmd.mx} reads "Mx" (1x1) data from the Human Mortality Database (HMD 4 | #' \url{https://www.mortality.org}) and constructs a demogdata object suitable 5 | #' for plotting using \code{\link{plot.demogdata}} and fitting an LC or BMS 6 | #' model using \code{\link{lca}} or an FDA model using \code{\link{fdm}}. 7 | #' \code{hmd.pop} reads "Population" (1x1) data from the HMD and constructs a 8 | #' demogdata object suitable for plotting using \code{\link{plot.demogdata}}. 9 | #' \code{hmd.e0} reads life expectancy at birth from the HMD and returns the 10 | #' result as a \code{ts} object. 11 | #' 12 | #' In order to read the data, users are required to create their account via the HMD website (\url{https://www.mortality.org}), 13 | #' and obtain a valid username and password. 14 | #' 15 | #' @param country Directory abbreviation from the HMD. For instance, Australia = 16 | #' "AUS". 17 | #' @param username HMD username (case-sensitive) 18 | #' @param password HMD password (case-sensitive) 19 | #' @param label Character string giving name of country from which the data are 20 | #' taken. 21 | #' 22 | #' @return \code{hmd.mx} returns an object of class \code{demogdata} with the following components: 23 | #' \item{year}{Vector of years} 24 | #' \item{age}{Vector of ages} 25 | #' \item{rate}{A list containing one or more rate matrices with one age group per row and one column per year.} 26 | #' \item{pop}{A list of the same form as \code{rate} but containing population numbers instead of demographic rates.} 27 | #' \item{type}{Type of object: \dQuote{mortality}, \dQuote{fertility} or \dQuote{migration}.} 28 | #' \item{label}{label} 29 | #' \code{hmd.pop} returns a similar object but without the \code{rate} component. 30 | #' \code{hmd.e0} returns an object of class \code{ts} with columns \code{male}, \code{female} and \code{total}. 31 | #' 32 | #' @seealso \code{\link{demogdata}},\code{\link{read.demogdata}},\code{\link{plot.demogdata}}, \code{\link{life.expectancy}} 33 | #' @author Rob J Hyndman 34 | #' @examples 35 | #' \dontrun{ 36 | #' norway <- hmd.mx("NOR", username, password, "Norway") 37 | #' summary(norway) 38 | #' } 39 | #' @keywords manip 40 | #' @name hmd 41 | #' @export 42 | hmd.mx <- function(country, username, password, label = country) { 43 | # Read raw MX and Exposure data 44 | mx <- HMDHFDplus::readHMDweb(country, 45 | item = "Mx_1x1", 46 | username = username, password = password, fixup = TRUE 47 | ) 48 | pop <- HMDHFDplus::readHMDweb(country, 49 | item = "Exposures_1x1", 50 | username = username, password = password, fixup = TRUE 51 | ) 52 | 53 | # Construct output 54 | obj <- list(type = "mortality", label = label, lambda = 0) 55 | obj$year <- sort(unique(mx[, "Year"])) 56 | n <- length(obj$year) 57 | m <- length(unique(mx[, "Age"])) 58 | obj$age <- mx[seq(m), "Age"] 59 | mnames <- names(mx)[-c(1:2, NCOL(mx))] 60 | n.mort <- length(mnames) 61 | obj$rate <- obj$pop <- list() 62 | for (i in seq(n.mort)) { 63 | obj$rate[[i]] <- matrix(mx[, i + 2], nrow = m, ncol = n) 64 | obj$rate[[i]][obj$rate[[i]] < 0] <- NA 65 | obj$pop[[i]] <- matrix(pop[, i + 2], nrow = m, ncol = n) 66 | obj$pop[[i]][obj$pop[[i]] < 0] <- NA 67 | dimnames(obj$rate[[i]]) <- dimnames(obj$pop[[i]]) <- list(obj$age, obj$year) 68 | } 69 | names(obj$pop) <- names(obj$rate) <- tolower(mnames) 70 | 71 | return(structure(obj, class = "demogdata")) 72 | } 73 | 74 | #' @rdname hmd 75 | #' @export 76 | hmd.e0 <- function(country, username, password) { 77 | # Read raw e0 data 78 | lt <- HMDHFDplus::readHMDweb(country, 79 | item = "E0per", 80 | username = username, password = password, fixup = TRUE 81 | ) 82 | # Convert to a ts object 83 | ts(lt[, -1], start = lt[1, 1], frequency = 1) 84 | } 85 | 86 | 87 | #' @rdname hmd 88 | #' @export 89 | hmd.pop <- function(country, username, password, label = country) { 90 | # Read raw data 91 | pop <- HMDHFDplus::readHMDweb(country, 92 | item = "Population", 93 | username = username, password = password, fixup = FALSE 94 | ) 95 | 96 | # Only keep 1 January populations 97 | pop <- pop[, !grepl("2$", colnames(pop))] 98 | mnames <- names(pop) 99 | mnames <- sub("1$", "", mnames) 100 | names(pop) <- mnames 101 | 102 | # Construct output 103 | obj <- list(type = "population", label = label, lambda = 0) 104 | obj$year <- sort(unique(pop[, "Year"])) 105 | n <- length(obj$year) 106 | m <- length(unique(pop[, "Age"])) 107 | obj$age <- pop[seq(m), "Age"] 108 | pop <- pop[, !(mnames %in% c("Year", "Age", "OpenInterval"))] 109 | n.pop <- NCOL(pop) 110 | obj$pop <- list() 111 | for (i in seq(n.pop)) { 112 | obj$pop[[i]] <- matrix(pop[, i], nrow = m, ncol = n) 113 | obj$pop[[i]][obj$pop[[i]] < 0] <- NA 114 | dimnames(obj$pop[[i]]) <- list(obj$age, obj$year) 115 | } 116 | names(obj$pop) <- tolower(colnames(pop)) 117 | 118 | return(structure(obj, class = "demogdata")) 119 | } 120 | -------------------------------------------------------------------------------- /R/simulate.R: -------------------------------------------------------------------------------- 1 | # Function to simulate future sample paths of functional data 2 | # given output from forecast.fdm 3 | #' Simulate future sample paths from functional demographic model forecasts. 4 | #' 5 | #' This function will simulate future sample paths given forecasting models 6 | #' from a functional demographic model such as those obtained using \code{\link{forecast.fdm}} or \code{\link{forecast.fdmpr}}. 7 | #' 8 | #' @param object Object of class \code{fmforecast}. Typically, this is output from \code{\link{forecast.fdm}}. 9 | #' @param nsim Number of sample paths to simulate. 10 | #' @param seed Either NULL or an integer that will be used in a call to set.seed before simulating the time seriers. 11 | #' The default, NULL will not change the random generator state. 12 | #' @param bootstrap If TRUE, simulation uses resampled errors rather than normally distributed errors. 13 | #' @param adjust.modelvar If TRUE, will adjust the model variance by the ratio of the empirical and theoretical variances for one-step forecasts. 14 | #' @param ... Other arguments passed to \code{simulate.fmforecast}. 15 | #' 16 | #' @return An array containing the future simulated values (in the case of a \code{fmforecast} object), 17 | #' or a list of arrays containing the future simulated values (in the case of a \code{fmforecast2} object). 18 | #' 19 | #' @author Rob J Hyndman 20 | #' @seealso \code{\link{forecast.fdm}}, \code{\link{forecast.lca}}, \code{\link[ftsa]{forecast.ftsm}}. 21 | #' @examples 22 | #' \dontrun{ 23 | #' france.fit <- fdm(fr.mort, order = 2) 24 | #' france.fcast <- forecast(france.fit, 50, method = "ets") 25 | #' france.sim <- simulate(france.fcast, nsim = 100) 26 | #' 27 | #' france.fit2 <- coherentfdm(fr.sm) 28 | #' france.fcast2 <- forecast(france.fit2, 50) 29 | #' france.sim2 <- simulate(france.fcast2, nsim = 100) 30 | #' } 31 | #' @keywords models 32 | #' @export 33 | simulate.fmforecast <- function(object, nsim = 100, seed = NULL, bootstrap = FALSE, adjust.modelvar = TRUE, ...) { 34 | n <- length(object$model$year) 35 | p <- length(object$age) 36 | h <- length(object$year) 37 | 38 | # Fix lca objects to be able to use this function. 39 | if (is.element("lca", class(object$model))) { 40 | object$model$basis <- cbind(log(object$model$jumprates), object$model$bx) 41 | object$model$coeff <- ts(cbind(rep(1, n), object$model$kt)) 42 | stats::tsp(object$model$coeff) <- stats::tsp(object$model$kt) 43 | zval <- stats::qnorm(0.5 + 0.005 * object$kt.f$level) 44 | # refit model using Arima so it can be simulated more easily. 45 | ktmod <- Arima(object$model$kt, order = c(0, 1, 0), include.drift = TRUE) 46 | # Find stdev of kt from kt.f (to include coefficient error) 47 | ktmod$sigma2 <- ((object$kt.f$upper[1] - object$kt.f$lower[1]) / zval / 2)^2 48 | object$coeff <- list(rwf(rep(1, n), level = object$kt.f$level), forecast(ktmod, level = object$kt.f$level)) 49 | colnames(object$model$basis) <- c("mean", "bx") 50 | rownames(object$model$basis) <- names(object$model$bx) 51 | adjust.modelvar <- FALSE 52 | } 53 | 54 | nb <- length(object$coeff) 55 | 56 | ridx <- (1:n) # [!is.na(colSums(object$model$residuals$y))] 57 | # Set residuals to zero for the simulations 58 | resids <- object$model$residuals$y 59 | resids[is.na(resids)] <- 0 60 | 61 | fmean <- BoxCox(object$rate[[1]], object$lambda) 62 | 63 | fcoeff <- matrix(1, nrow = h, ncol = nb) 64 | output <- array(0, c(p, h, nsim)) 65 | for (i in 1:nsim) 66 | { 67 | output[, , i] <- object$model$basis[, 1] 68 | if (nb > 1) { 69 | for (j in 2:nb) 70 | { 71 | mod <- object$coeff[[j]]$model 72 | if (inherits(mod, "forecast")) { 73 | mod <- mod$model 74 | } 75 | output[, , i] <- output[, , i] + object$model$basis[, j] %*% matrix(simulate(mod, nsim = h, bootstrap = bootstrap, future = TRUE), nrow = 1) 76 | } 77 | } 78 | output[, , i] <- output[, , i] + resids[, sample(ridx, h, replace = TRUE)] 79 | if (adjust.modelvar) { 80 | output[, , i] <- fmean + sweep(output[, , i] - fmean, 1, sqrt(object$var$adj.factor), "*") 81 | } 82 | } 83 | dimnames(output) <- list(object$age, object$year, 1:nsim) 84 | output <- InvBoxCox(output, object$lambda) 85 | output[is.na(output)] <- 0 86 | if (object$type != "migration") { 87 | output[output < 0] <- 0 88 | } 89 | return(output) 90 | } 91 | 92 | #' @rdname simulate.fmforecast 93 | #' @export 94 | simulate.fmforecast2 <- function(object, ...) { 95 | is.mortality <- (object$ratio[[1]]$type == "mortality") 96 | output <- unclass(object) # Just to retain same list structure 97 | if (is.element("product", names(object))) # Assume coherent model 98 | { 99 | output$product <- simulate(object$product, ...) 100 | for (i in 1:length(object$ratio)) 101 | { 102 | output$ratio[[i]] <- simulate(object$ratio[[i]], ...) 103 | if (is.mortality) { 104 | output[[i]] <- output$product * output$ratio[[i]] 105 | } else { 106 | output[[i]] <- output$product + output$ratio[[i]] 107 | } 108 | } 109 | } else { 110 | for (i in 1:length(object)) { 111 | output[[i]] <- simulate(object[[i]], ...) 112 | } 113 | } 114 | return(output) 115 | } 116 | -------------------------------------------------------------------------------- /man/lca.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/lca.R 3 | \name{lca} 4 | \alias{lca} 5 | \alias{bms} 6 | \title{Model mortality or fertility data using Lee-Carter approach} 7 | \usage{ 8 | lca( 9 | data, 10 | series = names(data$rate)[1], 11 | years = data$year, 12 | ages = data$age, 13 | max.age = 100, 14 | adjust = c("dt", "dxt", "e0", "none"), 15 | chooseperiod = FALSE, 16 | minperiod = 20, 17 | breakmethod = c("bai", "bms"), 18 | scale = FALSE, 19 | restype = c("logrates", "rates", "deaths"), 20 | interpolate = FALSE 21 | ) 22 | 23 | bms( 24 | data, 25 | series = names(data$rate)[1], 26 | years = data$year, 27 | ages = data$age, 28 | max.age = 100, 29 | minperiod = 20, 30 | breakmethod = c("bms", "bai"), 31 | scale = FALSE, 32 | restype = c("logrates", "rates", "deaths"), 33 | interpolate = FALSE 34 | ) 35 | } 36 | \arguments{ 37 | \item{data}{demogdata object of type \dQuote{mortality} or 38 | \dQuote{fertility}. Output from read.demogdata.} 39 | 40 | \item{series}{name of series within data containing mortality or fertility 41 | values (1x1)} 42 | 43 | \item{years}{years to include in fit. Default: all available years.} 44 | 45 | \item{ages}{ages to include in fit. Default: all available ages up to 46 | \code{max.age}.} 47 | 48 | \item{max.age}{upper age to include in fit. Ages beyond this are collapsed 49 | into the upper age group.} 50 | 51 | \item{adjust}{method to use for adjustment of coefficients \eqn{k_t kt}. 52 | Possibilities are \dQuote{dxt} (BMS method), \dQuote{dt} (Lee-Carter 53 | method), \dQuote{e0} (method based on life expectancy) and \dQuote{none}. 54 | Defaults are \dQuote{dxt} for \code{bms()} and \dQuote{dt} for 55 | \code{lca()}.} 56 | 57 | \item{chooseperiod}{If TRUE, it will choose the best fitting period.} 58 | 59 | \item{minperiod}{Minimum number of years to include in fitting period if 60 | chooseperiod=TRUE.} 61 | 62 | \item{breakmethod}{method to use for identifying breakpoints if 63 | chooseperiod=TRUE. Possibilities are \dQuote{bai} (Bai's method computed 64 | using \code{\link[strucchange]{breakpoints}} in the strucchange package) 65 | and \dQuote{bms} (method based on mean deviance ratios described in BMS).} 66 | 67 | \item{scale}{If TRUE, it will rescale bx and kt so that kt has drift 68 | parameter = 1.} 69 | 70 | \item{restype}{method to use for calculating residuals. Possibilities are 71 | \dQuote{logrates}, \dQuote{rates} and \dQuote{deaths}.} 72 | 73 | \item{interpolate}{If TRUE, it will estimate any zero mortality or fertility 74 | rates using the same age group from nearby years.} 75 | } 76 | \value{ 77 | Object of class \dQuote{lca} with the following components: 78 | \item{label}{Name of region} 79 | \item{age}{Ages from \code{data} object.} 80 | \item{year}{Years from \code{data} object.} 81 | \item{}{Matrix of mortality or fertility data as contained in \code{data}. It takes the name given by the series argument.} 82 | \item{ax}{Average deathrates across fitting period} 83 | \item{bx}{First principal component in Lee-Carter model} 84 | \item{kt}{Coefficient of first principal component} 85 | \item{residuals}{Functional time series of residuals.} 86 | \item{fitted}{Functional time series containing estimated mortality or fertility rates from model} 87 | \item{varprop}{Proportion of variance explained by model.} 88 | \item{y}{The data stored as a functional time series object.} 89 | \item{mdev}{Mean deviance of total and base lack of fit, as described in Booth, Maindonald and Smith.} 90 | } 91 | \description{ 92 | Lee-Carter model of mortality or fertility rates. \code{lca} produces a 93 | standard Lee-Carter model by default, although many other options are 94 | available. \code{bms} is a wrapper for \code{lca} and returns a model based 95 | on the Booth-Maindonald-Smith methodology. 96 | } 97 | \details{ 98 | All mortality or fertility data are assumed to be in matrices of 99 | mortality or fertility rates within \code{data$rate}. Each row is one age group 100 | (assumed to be single years). Each column is one year. The 101 | function produces a model for the \code{series} mortality or fertility rate matrix 102 | within \code{data$rate}. Forecasts from this model can be obtained using \code{\link{forecast.lca}}. 103 | } 104 | \examples{ 105 | \dontrun{ 106 | france.LC1 <- lca(fr.mort, adjust = "e0") 107 | plot(france.LC1) 108 | par(mfrow = c(1, 2)) 109 | plot(fr.mort, years = 1953:2002, ylim = c(-11, 1)) 110 | plot(forecast(france.LC1, jumpchoice = "actual"), ylim = c(-11, 1)) 111 | 112 | france.bms <- bms(fr.mort, breakmethod = "bai") 113 | fcast.bms <- forecast(france.bms) 114 | par(mfrow = c(1, 1)) 115 | plot(fcast.bms$kt) 116 | } 117 | } 118 | \references{ 119 | Booth, H., Maindonald, J., and Smith, L. (2002) Applying Lee-Carter 120 | under conditions of variable mortality decline. \emph{Population Studies}, \bold{56}, 325-336. 121 | 122 | Lee, R.D., and Carter, L.R. (1992) Modeling and forecasting US mortality. \emph{Journal of 123 | the American Statistical Association}, \bold{87}, 659-671. 124 | } 125 | \seealso{ 126 | \code{\link{forecast.lca}}, \code{\link{plot.lca}}, \code{\link{summary.lca}}, \code{\link{fdm}} 127 | } 128 | \author{ 129 | Heather Booth, Leonie Tickle, John Maindonald and Rob J Hyndman. 130 | } 131 | \keyword{models} 132 | -------------------------------------------------------------------------------- /R/update.R: -------------------------------------------------------------------------------- 1 | #' Updating functional demographic models and coherent functional demographic models. 2 | #' 3 | #' \code{update.fmforecast()} updates \code{fdm} forecasts. The argument \code{object} is the output from \code{\link{forecast.fdm}} which has been subsequently modified with new coefficient forecasts. These new forecasts are used when re-calculating the forecast of the mortality or fertility rates, or net migration numbers. 4 | #' \code{update.fmforecast2()} updates \code{fdmpr} forecasts. The argument \code{object} is the output from \code{\link{forecast.fdmpr}} which has been subsequently modified with new coefficient forecasts. 5 | #' 6 | #' @param object Output from either \code{\link{fdm}} or \code{\link{coherentfdm}}. 7 | #' @param ... Extra arguments currently ignored. 8 | #' 9 | #' @return A list of the same class as \code{object}. 10 | #' @author Rob J Hyndman. 11 | #' @seealso \code{\link{forecast.fdm}}, \code{\link{forecast.fdmpr}} 12 | #' @examples 13 | #' \dontrun{ 14 | #' france.fit <- fdm(fr.mort, order = 2) 15 | #' france.fcast <- forecast(france.fit, 50) 16 | #' # Replace first coefficient model with ARIMA(0,1,2)+drift 17 | #' france.fcast$coeff[[2]] <- forecast(Arima(france.fit$coeff[, 2], 18 | #' order = c(0, 1, 2), include.drift = TRUE 19 | #' ), h = 50, level = 80) 20 | #' france.fcast <- update(france.fcast) 21 | #' 22 | #' fr.short <- extract.years(fr.sm, 1950:2006) 23 | #' fr.fit <- coherentfdm(fr.short) 24 | #' fr.fcast <- forecast(fr.fit) 25 | #' par(mfrow = c(1, 2)) 26 | #' plot(fr.fcast$male) 27 | #' # Replace first coefficient model in product component with a damped ETS model: 28 | #' fr.fcast$product$coeff[[2]] <- forecast(ets(fr.fit$product$coeff[, 2], damped = TRUE), 29 | #' h = 50, level = 80 30 | #' ) 31 | #' fr.fcast <- update(fr.fcast) 32 | #' plot(fr.fcast$male) 33 | #' } 34 | #' @keywords models 35 | #' @name update 36 | NULL 37 | 38 | # Update fmforecast object 39 | # Original object from forecast.fdm 40 | # Assumed that the coefficient forecasts have been subsequently changed 41 | # Object needs to be updated to reflect those changes. 42 | #' @rdname update 43 | #' @export 44 | update.fmforecast <- function(object, ...) { 45 | if (!is.element("fmforecast", class(object))) { 46 | stop("object must be of class fmforecast") 47 | } 48 | h <- length(object$year) 49 | nb <- ncol(object$model$basis) 50 | adjust <- length(object$var$adj.factor) > 1 51 | objnames <- dimnames(object$rate[[1]]) 52 | 53 | # Update in-sample fitted values and errors. 54 | fitted <- matrix(NA, length(object$model$year), nb) 55 | meanfcast <- varfcast <- matrix(NA, nrow = h, ncol = nb) 56 | qconf <- stats::qnorm(0.5 + object$coeff[[2]]$level[1] / 200) 57 | fitted[, 1] <- 1 58 | meanfcast[, 1] <- 1 59 | varfcast[, 1] <- 0 60 | for (i in 2:nb) 61 | { 62 | fitted[, i] <- fitted(object$coeff[[i]]$model) 63 | meanfcast[, i] <- object$coeff[[i]]$mean 64 | varfcast[, i] <- ((object$coeff[[i]]$upper - object$coeff[[i]]$lower) / (2 * qconf))^2 65 | } 66 | object$fitted$y <- object$model$basis %*% t(fitted) 67 | object$error$y <- object$model$y$y - object$fitted$y 68 | object$coeff.error <- object$model$coeff - fitted 69 | 70 | # Update point forecasts 71 | object$rate[[1]] <- object$model$basis %*% t(meanfcast) 72 | dimnames(object$rate[[1]]) <- objnames 73 | 74 | # Update forecast variances 75 | # Only model variance should have changed 76 | modelvar <- object$model$basis^2 %*% t(varfcast) 77 | totalvar <- sweep(modelvar, 1, object$var$error + object$var$mean, "+") 78 | if (adjust & nb > 1) { 79 | object$var$adj.factor <- rowMeans(object$error$y^2, na.rm = TRUE) / totalvar[, 1] 80 | totalvar <- sweep(totalvar, 1, object$var$adj.factor, "*") 81 | } 82 | # Add observational variance to total variance 83 | object$var$total <- sweep(totalvar, 1, object$var$observ, "+") 84 | 85 | # Update forecast intervals 86 | # Only parametric intervals computed here. 87 | tmp <- qconf * sqrt(object$var$total) 88 | object$rate$lower <- InvBoxCox(object$rate[[1]] - tmp, object$lambda) 89 | object$rate$upper <- InvBoxCox(object$rate[[1]] + tmp, object$lambda) 90 | object$rate[[1]] <- InvBoxCox(object$rate[[1]], object$lambda) 91 | if (object$type != "migration") { 92 | object$rate[[1]] <- pmax(object$rate[[1]], 0.000000001) 93 | object$rate$lower <- pmax(object$rate$lower, 0.000000001) 94 | object$rate$lower[is.na(object$rate$lower)] <- 0 95 | object$rate$upper <- pmax(object$rate$upper, 0.000000001) 96 | } 97 | 98 | # Return updated object 99 | return(object) 100 | } 101 | 102 | 103 | # Function to combine product and ratio forecasts 104 | # object is output from forecast.fdmpr, but with modified forecasts 105 | # This function simply recombines them again. 106 | #' @rdname update 107 | #' @export 108 | update.fmforecast2 <- function(object, ...) { 109 | if (!is.element("fmforecast2", class(object))) { 110 | stop("object must be of class fmforecast2") 111 | } 112 | 113 | J <- length(object$ratio) 114 | ny <- length(object$ratio[[1]]$year) 115 | 116 | # GM model 117 | object$product <- update(object$product) 118 | 119 | # Obtain forecasts for each group 120 | is.mortality <- (object$product$type == "mortality") 121 | y <- as.numeric(is.mortality) # =1 for mortality and 0 for migration 122 | for (j in 1:J) 123 | { 124 | object$ratio[[j]] <- update(object$ratio[[j]]) 125 | if (is.mortality) { 126 | object[[j]]$rate[[1]] <- object$product$rate$product * object$ratio[[j]]$rate[[1]] 127 | } else { 128 | object[[j]]$rate[[1]] <- object$product$rate$product + object$ratio[[j]]$rate[[1]] 129 | } 130 | if (is.mortality) { 131 | y <- y * object[[j]]$rate[[1]] 132 | } else { 133 | y <- y + object[[j]]$rate[[1]] 134 | } 135 | } 136 | 137 | # Adjust forecasts so they multiply appropriately. 138 | if (is.mortality) { 139 | y <- y^(1 / J) / object$product$rate$product 140 | for (j in 1:J) { 141 | object[[j]]$rate[[1]] <- object[[j]]$rate[[1]] / y 142 | } 143 | } else { 144 | y <- y / J - object$product$rate$product 145 | for (j in 1:J) { 146 | object[[j]]$rate[[1]] <- object[[j]]$rate[[1]] - y 147 | } 148 | } 149 | # Variance of forecasts 150 | qconf <- 2 * stats::qnorm(0.5 + object$product$coeff[[1]]$level / 200) 151 | for (j in 1:J) 152 | { 153 | vartotal <- object$product$var$total + object$ratio[[j]]$var$total 154 | tmp <- qconf * sqrt(vartotal) 155 | object[[j]]$rate$lower <- InvBoxCox(BoxCox(object[[j]]$rate[[1]], object$product$lambda) - tmp, object$product$lambda) 156 | object[[j]]$rate$upper <- InvBoxCox(BoxCox(object[[j]]$rate[[1]], object$product$lambda) + tmp, object$product$lambda) 157 | } 158 | 159 | return(object) 160 | } 161 | -------------------------------------------------------------------------------- /R/monotonic.R: -------------------------------------------------------------------------------- 1 | #' Monotonic interpolating splines 2 | #' 3 | #' Perform cubic spline monotonic interpolation of given data points, returning either a list of points obtained by the interpolation or a function performing the interpolation. The splines are constrained to be monotonically increasing (i.e., the slope is never negative). 4 | #' 5 | #' These are simply wrappers to the \code{\link[stats]{splinefun}} function family from the stats package. 6 | #' 7 | #' @param x,y vectors giving the coordinates of the points to be interpolated. Alternatively a single plotting structure can be specified: see \code{\link[grDevices]{xy.coords}}. 8 | #' @param n interpolation takes place at n equally spaced points spanning the interval [\code{xmin}, \code{xmax}]. 9 | #' @param xmin left-hand endpoint of the interpolation interval. 10 | #' @param xmax right-hand endpoint of the interpolation interval. 11 | #' @param ... Other arguments are ignored. 12 | #' 13 | #' @return \item{cm.spline}{returns a list containing components \code{x} and \code{y} which give the ordinates where interpolation took place and the interpolated values.} 14 | #' \item{cm.splinefun}{returns a function which will perform cubic spline interpolation of the given data points. This is often more useful than \code{spline}.} 15 | #' 16 | #' @references Forsythe, G. E., Malcolm, M. A. and Moler, C. B. (1977) \emph{Computer Methods for Mathematical Computations}. 17 | #' Hyman (1983) \emph{SIAM J. Sci. Stat. Comput.} \bold{4}(4):645-654. 18 | #' Dougherty, Edelman and Hyman 1989 \emph{Mathematics of Computation}, \bold{52}: 471-494. 19 | #' 20 | #' @author Rob J Hyndman 21 | #' 22 | #' @examples 23 | #' x <- seq(0, 4, l = 20) 24 | #' y <- sort(rnorm(20)) 25 | #' plot(x, y) 26 | #' lines(spline(x, y, n = 201), col = 2) # Not necessarily monotonic 27 | #' lines(cm.spline(x, y, n = 201), col = 3) # Monotonic 28 | #' @keywords smooth 29 | #' @aliases monotonic 30 | #' @export 31 | cm.spline <- function(x, y = NULL, n = 3 * length(x), xmin = min(x), xmax = max(x), ...) 32 | # wrapper for spline() 33 | # Function retained for backwards compatibility 34 | { 35 | stats::spline(x, y, n = n, xmin = xmin, xmax = xmax, method = "hyman") 36 | } 37 | 38 | 39 | #' @rdname cm.spline 40 | #' @export 41 | cm.splinefun <- function(x, y = NULL, ...) 42 | # wrapper for splinefun() 43 | # Function retained for backwards compatibility 44 | { 45 | stats::splinefun(x, y, method = "hyman") 46 | } 47 | 48 | 49 | # Function to do cubic smoothing spline fit to y ~ x 50 | # with constraint of monotonic increasing for x>b. 51 | # Based on code provided by Simon Wood 52 | # Last updated: 1 February 2014 53 | 54 | smooth.monotonic <- function(x, y, b, k = -1, w = NULL, newx = x) { 55 | weight <- !is.null(w) 56 | if (k < 3 & k != -1) { 57 | stop("Inappropriate value of k") 58 | } 59 | # Unconstrained smooth. 60 | miss <- is.na(y) 61 | if (weight) { 62 | miss <- miss | w < 1e-9 63 | } 64 | yy <- y[!miss] 65 | xx <- x[!miss] 66 | if (weight) { 67 | w <- w[!miss] 68 | w <- w / sum(w) * length(w) 69 | f.ug <- mgcv::gam(yy ~ s(xx, k = k), weights = w) 70 | # assign("w",w,pos=1) 71 | } else { 72 | f.ug <- mgcv::gam(yy ~ s(xx, k = k)) 73 | } 74 | 75 | if (max(xx) <= b) { 76 | return(mgcv::predict.gam(f.ug, newdata = data.frame(xx = newx), se.fit = TRUE)) 77 | } 78 | 79 | # Create Design matrix, constraints etc. for monotonic spline.... 80 | mgcv::gam(yy ~ s(xx, k = k), data = data.frame(xx = xx, yy = yy), fit = FALSE) -> G 81 | if (weight) { 82 | G$w <- w 83 | } 84 | nc <- 200 # number of constraints 85 | xc <- seq(b, max(xx), l = nc + 1) # points at which to impose constraints 86 | A0 <- mgcv::predict.gam(f.ug, data.frame(xx = xc), type = "lpmatrix") 87 | # A0%*%p will evaluate spline at the xc points 88 | A1 <- mgcv::predict.gam(f.ug, data.frame(xx = xc + 1e-6), type = "lpmatrix") 89 | A <- (A1 - A0) / 1e-6 # approximate constraint matrix 90 | # (A%%p is -ve gradient of spline at points xc) 91 | 92 | G$Ain <- A # constraint matrix 93 | G$bin <- rep(0, nc + 1) # constraint vector 94 | G$sp <- f.ug$sp # use smoothing parameters from un-constrained fit 95 | k <- G$smooth[[1]]$df + 1 96 | G$p <- rep(0, k) 97 | G$p[k] <- 0.1 # get monotonic starting parameters, by 98 | # setting coefficiants of polynomial part of term 99 | G$p[k - 1] <- -mean(0.1 * xx) # must ensure that gam side conditions are 100 | # met so that sum of smooth over x's is zero 101 | # G$p <- rep(0,k+1) 102 | # G$p[k+1] <- 0.1 103 | # G$p[k] <- -mean(0.1*xx) 104 | G$y <- yy 105 | G$off <- G$off - 1 # indexing inconsistency between pcls and internal gam 106 | G$C <- matrix(0, 0, 0) # fixed constraint matrix (there are none) 107 | p <- mgcv::pcls(G) # fit spline (using s.p. from unconstrained fit) 108 | 109 | # now modify the gam object from unconstrained fit a little, to use it 110 | # for predicting and plotting constrained fit. 111 | f.ug$coefficients <- p 112 | return(mgcv::predict.gam(f.ug, newdata = data.frame(xx = newx), se.fit = TRUE)) 113 | } 114 | 115 | smooth.monotonic.cobs <- function(x, y, b, lambda = 0, w = NULL, newx = x, nknots = 50) { 116 | oldwarn <- options(warn = -1) 117 | 118 | weight <- !is.null(w) 119 | 120 | miss <- is.na(y) 121 | if (weight) { 122 | miss <- miss | w < 1e-9 123 | } 124 | yy <- y[!miss] 125 | xx <- x[!miss] 126 | if (weight) { 127 | w <- w[!miss] 128 | w <- w / sum(w) * length(w) 129 | f.ug <- cobs::cobs(xx, yy, w = w, print.warn = FALSE, print.mesg = FALSE, lambda = lambda, nknots = nknots) 130 | } else { 131 | f.ug <- cobs::cobs(xx, yy, print.warn = FALSE, print.mesg = FALSE, lambda = lambda, nknots = nknots) 132 | } 133 | 134 | fred <- stats::predict(f.ug, interval = "conf", nz = 200) 135 | fit <- stats::approx(fred[, 1], fred[, 2], xout = newx)$y 136 | se <- stats::approx(fred[, 1], (fred[, 4] - fred[, 3]) / 2 / 1.96, xout = newx)$y 137 | 138 | if (max(xx) > b) { 139 | delta <- (max(xx) - min(xx)) / 10 140 | xxx <- xx[xx > (b - delta)] 141 | yyy <- yy[xx > (b - delta)] 142 | if (weight) { 143 | f.mono <- cobs::cobs(xxx, yyy, constraint = "increase", w = w[xx > (b - delta)], print.warn = FALSE, print.mesg = FALSE, lambda = lambda, nknots = nknots) 144 | } else { 145 | f.mono <- cobs::cobs(xxx, yyy, constraint = "increase", print.warn = FALSE, print.mesg = FALSE, lambda = lambda, nknots = nknots) 146 | } 147 | fred <- stats::predict(f.mono, interval = "conf", nz = 200) 148 | newfit <- stats::approx(fred[, 1], fred[, 2], xout = newx[newx > (b - delta)])$y 149 | newse <- stats::approx(fred[, 1], (fred[, 4] - fred[, 3]) / 2 / 1.96, xout = newx[newx > (b - delta)])$y 150 | preb <- sum(newx <= (b - delta)) 151 | newfit <- c(rep(0, preb), newfit) 152 | newse <- c(rep(0, preb), newse) 153 | postb <- sum(newx > b) 154 | n <- length(newx) 155 | cc <- c(rep(0, preb), seq(0, 1, length = n - preb - postb), rep(1, postb)) 156 | fit <- (1 - cc) * fit + cc * newfit 157 | se <- (1 - cc) * se + cc * newse 158 | } 159 | options(warn = oldwarn$warn) 160 | return(list(fit = fit, se = se)) 161 | } 162 | -------------------------------------------------------------------------------- /R/robust.R: -------------------------------------------------------------------------------- 1 | # median <- function(...) UseMethod("median") 2 | 3 | # median.default <- function (x, na.rm = FALSE) 4 | # { 5 | # if (is.factor(x) || mode(x) != "numeric") 6 | # stop("need numeric data") 7 | # if (na.rm) 8 | # x <- x[!is.na(x)] 9 | # else if (any(is.na(x))) 10 | # return(NA) 11 | # n <- length(x) 12 | # if (n == 0) 13 | # return(NA) 14 | # half <- (n + 1)/2 15 | # if (n%%2 == 1) { 16 | # sort(x, partial = half)[half] 17 | # } 18 | # else { 19 | # sum(sort(x, partial = c(half, half + 1))[c(half, half + 20 | # 1)])/2 21 | # } 22 | # } 23 | 24 | 25 | # L1MEDIAN calculates the multivariate L1 median 26 | # X is the data matrix 27 | # tol is the convergence criterium; the iterative proces stops when ||m_k - m_{k+1}|| < tol. 28 | # 29 | # Ref: Hossjer and Croux (1995) "Generalizing Univariate Signed Rank Statistics for Testing 30 | # and Estimating a Multivariate Location Parameter", Non-parametric Statistics, 4, 293-308. 31 | # Assume columnwise location wanted. 32 | 33 | L1median <- function(X, tol = 1e-6, maxstep = 200, na.rm = TRUE, method = c("hossjercroux", "coordinate")) { 34 | method <- match.arg(method) 35 | # Coordinatewise median 36 | if (method == "coordinate") { 37 | return(apply(X, 2, stats::median.default, na.rm = na.rm)) 38 | } # Gower's algorithm 39 | # else if(method=="gower") 40 | # return(gower(X,tol=tol,maxstep=maxstep,na.rm=na.rm)) 41 | # Otherwise use Hossjer and Croux. 42 | else { 43 | return(hossjercroux(X, tol = tol, maxstep = maxstep, na.rm = na.rm)) 44 | } 45 | } 46 | 47 | hossjercroux <- function(X, tol = 1e-6, maxstep = 100, na.rm = TRUE) { 48 | n <- nrow(X) 49 | p <- ncol(X) 50 | m <- apply(X, 2, stats::median.default, na.rm = na.rm) 51 | hctol <- max(1, min(abs(m), na.rm = na.rm)) * tol 52 | for (k in 1:maxstep) 53 | { 54 | mold <- m 55 | XX <- sweep(X, 2, m) 56 | dx <- norme(XX) 57 | if (min(abs(dx)) > tol) { 58 | w <- 1 / dx 59 | } else { 60 | w <- rep(0, n) 61 | w[dx > tol] <- 1 / dx[dx > tol] 62 | } 63 | delta <- colSums(XX * repmat(w / sum(w), 1, p), na.rm = na.rm) 64 | nd <- sqrt(sum(delta^2)) 65 | maxhalf <- ifelse(nd < hctol, 0, log2(nd / hctol)) 66 | m <- mold + delta 67 | nstep <- 0 68 | oldmobj <- mrobj(X, mold) 69 | while ((mrobj(X, m) > oldmobj) & (nstep <= maxhalf)) { 70 | nstep <- nstep + 1 71 | m <- mold + delta / (2^nstep) 72 | } 73 | if (nstep > maxhalf) { 74 | return(mold) 75 | } 76 | } 77 | # warning("Iteration failed") 78 | return(mold) 79 | } 80 | 81 | # NORME calculates the euclidian norm of matrix X 82 | # the output is a columnvector containing the norm of each row 83 | 84 | norme <- function(X) { 85 | return(sqrt(rowSums(X^2, na.rm = TRUE))) 86 | } 87 | 88 | # MROBJ computes objective function in m based on X 89 | 90 | mrobj <- function(X, m) { 91 | return(sum(norme(sweep(X, 2, m)))) 92 | } 93 | 94 | # repmat replicates the matrix A in an mxn block matrix. 95 | repmat <- function(A, m, n = m) { 96 | A <- as.matrix(A) 97 | tmp <- matrix(rep(t(A), m), nrow = m * nrow(A), byrow = TRUE) 98 | return(matrix(rep(tmp, n), ncol = n * ncol(tmp))) 99 | } 100 | 101 | 102 | Qn <- function(x) { 103 | n <- length(x) 104 | diffs <- outer(x, x, "-") 105 | diffs <- diffs[!lower.tri(diffs, diag = TRUE)] 106 | qn <- 2.2219 * quantile(abs(diffs), 0.25) 107 | if (n == 2) { 108 | dn <- 0.399 109 | } else if (n == 3) { 110 | dn <- 0.994 111 | } else if (n == 4) { 112 | dn <- 0.512 113 | } else if (n == 5) { 114 | dn <- 0.844 115 | } else if (n == 6) { 116 | dn <- 0.611 117 | } else if (n == 7) { 118 | dn <- 0.857 119 | } else if (n == 8) { 120 | dn <- 0.669 121 | } else if (n == 9) { 122 | dn <- 0.872 123 | } else if (n %% 2 == 1) { 124 | dn <- n / (n + 1.4) 125 | } else { 126 | dn <- n / (n + 3.8) 127 | } 128 | return(dn * qn) 129 | } 130 | 131 | 132 | MAD <- function(x) { 133 | med.x <- median(x) 134 | return(1.486 * median(abs(x - med.x))) 135 | } 136 | 137 | 138 | 139 | # ROBUST PCA USING REFLECTION 140 | # BASED ON HUBERT, ROUSSEEUW AND VERBOVEN 141 | 142 | rstep <- function(x, FUN = Qn, order = 4, r = matrix.rank(x), mean = TRUE) { 143 | if (order < 1) { 144 | stop("Order must be positive") 145 | } 146 | 147 | # transpose to be consistent with Hubert et al. 148 | X <- t(x) 149 | p <- ncol(X) 150 | n <- nrow(X) 151 | 152 | p1 <- min(order, r, floor(n / 2)) 153 | S <- numeric(p1) 154 | Bnorm <- numeric(n) 155 | V <- eig <- matrix(0, p, p1) 156 | Transfo <- diag(p) 157 | 158 | if (mean) { 159 | med <- L1median(X, method = "hoss") 160 | xxx <- xx <- sweep(X, 2, med) 161 | } else { 162 | xxx <- xx <- X 163 | } 164 | for (l in 1:p1) 165 | { 166 | B <- xxx 167 | for (i in 1:n) { 168 | Bnorm[i] <- norm(B[i, ], 2) 169 | } 170 | # Eliminate constant rows 171 | Bnormr <- Bnorm[Bnorm > 1e-12] 172 | B <- B[Bnorm > 1e-12, ] 173 | A <- diag(1 / Bnormr) %*% B 174 | Y <- xxx %*% t(A) # projected points in columns 175 | s <- colQn(Y) 176 | j <- order(s, decreasing = TRUE)[1] 177 | S[l] <- s[j] 178 | V[l:p, l] <- A[j, ] 179 | 180 | # EigenVectors = columns of V 181 | # Constructing Transformation 182 | Base <- diag(p - l + 1) 183 | ndiff <- norm(Base[, 1] - V[l:p, l], Inf) # max norm of the normal vector 184 | if (ndiff > 1e-12) { 185 | if (sum(V[l:p, l] * Base[, 1]) < 0) { 186 | V[l:p, l] <- -V[l:p, l] 187 | } 188 | u <- matrix(Base[, 1] - V[l:p, l], ncol = 1) / c(norm(Base[, 1] - V[l:p, l])) 189 | U <- Base - 2 * repmat(t(u) %*% Base, p - l + 1, 1) * repmat(u, 1, p - l + 1) 190 | } else { 191 | U <- Base 192 | } 193 | 194 | # Transforming eigenvectors to the original pxp dimensional space 195 | eig[, l] <- Transfo %*% V[, l] 196 | if (l < p1) { 197 | Edge <- diag(p) 198 | Edge[l:p, l:p] <- U 199 | Transfo <- Transfo %*% Edge 200 | xxx <- xxx %*% U # Reflection of data 201 | xxx <- as.matrix(xxx[, -1]) 202 | } 203 | } 204 | coef <- xx %*% eig 205 | if (mean) { 206 | basis <- cbind(med, eig) 207 | coef <- cbind(rep(1, n), coef) 208 | } else { 209 | basis <- eig 210 | } 211 | 212 | return(list(basis = basis, coeff = coef, X = xx)) 213 | } 214 | 215 | # RAPCA ALGORITHM for ROBUST PCA 216 | # BASED ON HUBERT, ROUSSEEUW AND VERBOVEN 217 | 218 | rapca <- function(x, FUN = Qn, order = 4, mean = TRUE) { 219 | if (order < 1) { 220 | stop("Order must be positive") 221 | } 222 | 223 | X <- t(x) 224 | n <- nrow(X) 225 | p <- ncol(X) 226 | 227 | # First Step: classical SVD on the data 228 | # This step reduces the data space to the affine subspace 229 | # spanned by r=min(n-1,p) observations. 230 | if (mean) { 231 | med <- colMeans(X) 232 | xx <- sweep(X, 2, med) 233 | } else { 234 | xx <- X 235 | } 236 | tmp <- La.svd(xx) 237 | r <- sum(tmp$d > (max(n, p) * max(tmp$d) * 1e-12)) # Approx rank 238 | P <- t(tmp$vt)[, 1:r] 239 | 240 | # Second Step: Rstep on X 241 | # computes the robust eigenvectors and eigenvalues 242 | tmp2 <- rstep(t(xx %*% P), order = order, r = tmp$r, mean = mean) 243 | tmp <- P %*% tmp2$basis 244 | 245 | # Retransforming the robust location to the original space 246 | if (mean) { 247 | med <- c(med + tmp[, 1]) 248 | xx <- sweep(X, 2, med) 249 | basis <- cbind(med, tmp[, (1:order) + 1]) 250 | coef <- cbind(rep(1, n), xx %*% basis[, -1]) 251 | } else { 252 | basis <- tmp 253 | coef <- xx %*% basis 254 | } 255 | 256 | return(list(basis = basis, coeff = coef, X = xx)) 257 | } 258 | 259 | matrix.rank <- function(X) { 260 | X.sv <- abs(La.svd(X)$d) 261 | return(sum((X.sv / max(X.sv)) > 1e-9)) 262 | } 263 | 264 | norm <- function(A, p = 2) { 265 | A <- as.matrix(A) 266 | if (min(dim(A)) == 1) { 267 | A <- t(A) 268 | } 269 | if (p == 1) { 270 | return(as.matrix(max(colSums(abs(A))))) 271 | } else if (p == 2) { 272 | A.sv <- La.svd(A)$d 273 | return(as.matrix(max(A.sv))) 274 | } else if (p > 1e9) { 275 | return(as.matrix(max(rowSums(abs(A))))) 276 | } else { 277 | stop("Unknown norm") 278 | } 279 | } 280 | 281 | # Qn along columns of Z 282 | 283 | colQn <- function(Z) { 284 | return(apply(Z, 2, Qn)) 285 | } 286 | -------------------------------------------------------------------------------- /R/coherent.R: -------------------------------------------------------------------------------- 1 | # COHERENT FORECASTING FOR MULTIPLE GROUPS 2 | 3 | #' Coherent functional demographic model for grouped data 4 | #' 5 | #' Fits a coherent functional model to demographic data as described in Hyndman, 6 | #' Booth & Yasmeen (2012). If two of the series in \code{data} are named 7 | #' \code{male} and \code{female}, then it will use these two groups. Otherwise 8 | #' it will use all available groups. 9 | #' 10 | #' @param data demogdata object containing at least two groups. 11 | #' @param order1 Number of basis functions to fit to the model for the geometric 12 | #' mean. 13 | #' @param order2 Number of basis functions to fit to the models for each ratio. 14 | #' @param ... Extra arguments passed to \code{\link{fdm}}. 15 | #' 16 | #' @return A list (of class \code{fdmpr}) consisting of two objects: 17 | #' \code{product} (an \code{\link{fdm}} object containing a del for the 18 | #' geometric mean of the data) and \code{ratio} (a list of \code{\link{fdm}} 19 | #' objects, being the models for the ratio of each series with the geometric 20 | #' mean). 21 | #' 22 | #' @author Rob J Hyndman 23 | #' 24 | #' @references Hyndman, R.J., Booth, H., and Yasmeen, F. (2012) Coherent 25 | #' mortality forecasting: the product-ratio method with functional time series 26 | #' models. \emph{Demography}, to appear. 27 | #' \url{https://robjhyndman.com/publications/coherentfdm/} 28 | #' 29 | #' @seealso \code{\link{fdm}}, \code{\link{forecast.fdmpr}} 30 | #' 31 | #' @examples 32 | #' fr.short <- extract.years(fr.sm, 1950:2006) 33 | #' fr.fit <- coherentfdm(fr.short) 34 | #' summary(fr.fit) 35 | #' plot(fr.fit$product, components = 3) 36 | #' @keywords models 37 | #' 38 | #' 39 | #' @export 40 | coherentfdm <- function(data, order1 = 6, order2 = 6, ...) { 41 | # Check if missing data 42 | 43 | # Use male and female if available 44 | gps <- names(data$rate) 45 | if (is.element("male", gps) & is.element("female", gps)) { 46 | notneeded <- (1:length(gps))[-match(c("male", "female"), gps)] 47 | for (i in notneeded) { 48 | data$rate[[i]] <- data$pop[[i]] <- NULL 49 | } 50 | } 51 | 52 | J <- length(data$rate) 53 | rate.ratio <- fdm.ratio <- list() 54 | 55 | # Construct ratio and product objects 56 | is.mortality <- (data$type == "mortality") 57 | y <- as.numeric(is.mortality) 58 | pop.total <- 0 59 | for (j in 1:J) 60 | { 61 | if (is.mortality) { 62 | y <- y * data$rate[[j]]^(1 / J) 63 | } else { 64 | y <- y + data$rate[[j]] / J 65 | } 66 | pop.total <- pop.total + data$pop[[j]] 67 | } 68 | rate.product <- demogdata(y, 69 | pop = pop.total, data$age, data$year, type = data$type, lambda = data$lambda, 70 | label = data$label, name = "product" 71 | ) 72 | for (j in 1:J) 73 | { 74 | if (is.mortality) { 75 | rate.ratio[[j]] <- demogdata(data$rate[[j]] / rate.product$rate[[1]], 76 | pop = pop.total, data$age, 77 | data$year, type = data$type, label = data$label, name = names(data$rate)[[j]], lambda = data$lambda 78 | ) 79 | } else { 80 | rate.ratio[[j]] <- demogdata(data$rate[[j]] - rate.product$rate[[1]], 81 | pop = pop.total, data$age, 82 | data$year, type = data$type, label = data$label, name = names(data$rate)[[j]], lambda = data$lambda 83 | ) 84 | } 85 | # Set infinite rates to missing 86 | infrates <- rate.ratio[[j]]$rate[[1]] > 1e9 87 | rate.ratio[[j]]$rate[[1]][infrates] <- NA 88 | } 89 | 90 | # GM model 91 | fdm.mean <- fdm(rate.product, series = "product", order = order1, ...) 92 | 93 | # Ratio model 94 | for (j in 1:J) { 95 | fdm.ratio[[j]] <- fdm(rate.ratio[[j]], series = names(data$rate)[j], order = order2, ...) 96 | } 97 | names(fdm.ratio) <- names(data$rate) 98 | 99 | return(structure(list(product = fdm.mean, ratio = fdm.ratio), class = "fdmpr")) 100 | } 101 | 102 | 103 | 104 | #' Forecast coherent functional demographic model. 105 | #' 106 | #' The product and ratio models from \code{\link{coherentfdm}} are forecast, and 107 | #' the results combined to give forecasts for each group in the original data. 108 | #' 109 | #' @param object Output from \code{\link{coherentfdm}}. 110 | #' @param h Forecast horizon. 111 | #' @param level Confidence level for prediction intervals. 112 | #' @param K Maximum number of years to use in forecasting coefficients for ratio 113 | #' components. 114 | #' @param drange Range of fractional differencing parameter for the ratio 115 | #' coefficients. 116 | #' @param ... Other arguments as for \code{\link{forecast.fdm}}. 117 | #' 118 | #' @return Object of class \code{fmforecast2} containing a list of objects each 119 | #' of class \code{fmforecast}. The forecasts for each group in the original 120 | #' data are given first. Then the forecasts from the product model, and 121 | #' finally a list of forecasts from each of the ratio models. 122 | #' @author Rob J Hyndman 123 | #' @seealso \code{\link{coherentfdm}}, \code{\link{forecast.fdm}}. 124 | #' @examples fr.short <- extract.years(fr.sm, 1950:2006) 125 | #' fr.fit <- coherentfdm(fr.short) 126 | #' fr.fcast <- forecast(fr.fit) 127 | #' plot(fr.fcast$male) 128 | #' plot(fr.fcast$ratio$male, plot.type = "component", components = 3) 129 | #' models(fr.fcast) 130 | #' 131 | #' @keywords models 132 | #' @export 133 | forecast.fdmpr <- function(object, h = 50, level = 80, K = 100, drange = c(0.0, 0.5), ...) { 134 | fcast.ratio <- fc <- totalvar.r <- list() 135 | J <- length(object$ratio) 136 | ny <- length(object$ratio[[1]]$year) 137 | K <- min(K, ny) 138 | 139 | # GM model 140 | fcast.mean <- forecast(object$product, method = "arima", h = h, level = level, ...) 141 | # Make sure first coefficient is not I(1) with drift. 142 | # mod <- auto.arima(object$product$coeff[,2],d=2) 143 | # fcast.mean$coeff[[2]] <- forecast(mod, h=h, level=level, ...) 144 | # fcast.mean <- update(fcast.mean) 145 | 146 | # Obtain forecasts for each group 147 | is.mortality <- (object$product$type == "mortality") 148 | y <- as.numeric(is.mortality) # =1 for mortality and 0 for migration 149 | for (j in 1:J) 150 | { 151 | # Use all available data other than last K years 152 | # As ARFIMA can't handle missing values 153 | object$ratio[[j]]$weights <- 0 * object$ratio[[j]]$weights + 1 154 | if (K < ny) { 155 | object$ratio[[j]]$weights[1:(ny - K)] <- 0 156 | } 157 | fcast.ratio[[j]] <- forecast(object$ratio[[j]], h = h, level = level, method = "arfima", estim = "mle", drange = drange, ...) 158 | fc[[j]] <- fcast.mean 159 | if (is.mortality) { 160 | fc[[j]]$rate[[1]] <- fcast.mean$rate$product * fcast.ratio[[j]]$rate[[1]] 161 | } else { 162 | fc[[j]]$rate[[1]] <- fcast.mean$rate$product + fcast.ratio[[j]]$rate[[1]] 163 | } 164 | names(fc[[j]]$rate)[1] <- names(object$ratio)[j] 165 | fc[[j]]$coeff <- fc[[j]]$coeff.error <- fc[[j]]$call <- fc[[j]]$var <- NULL 166 | if (is.mortality) { 167 | y <- y * fc[[j]]$rate[[1]] 168 | } else { 169 | y <- y + fc[[j]]$rate[[1]] 170 | } 171 | } 172 | 173 | # Adjust forecasts so they multiply appropriately. 174 | if (is.mortality) { 175 | y <- y^(1 / J) / fcast.mean$rate$product 176 | for (j in 1:J) { 177 | fc[[j]]$rate[[1]] <- fc[[j]]$rate[[1]] / y 178 | } 179 | } else { 180 | y <- y / J - fcast.mean$rate$product 181 | for (j in 1:J) { 182 | fc[[j]]$rate[[1]] <- fc[[j]]$rate[[1]] - y 183 | } 184 | } 185 | # Variance of forecasts 186 | qconf <- 2 * stats::qnorm(0.5 + fcast.mean$coeff[[1]]$level / 200) 187 | for (j in 1:J) 188 | { 189 | vartotal <- fcast.mean$var$total + fcast.ratio[[j]]$var$total 190 | tmp <- qconf * sqrt(vartotal) 191 | fc[[j]]$rate$lower <- InvBoxCox(BoxCox(fc[[j]]$rate[[1]], object$product$lambda) - tmp, object$product$lambda) 192 | fc[[j]]$rate$upper <- InvBoxCox(BoxCox(fc[[j]]$rate[[1]], object$product$lambda) + tmp, object$product$lambda) 193 | if (is.mortality) { 194 | fc[[j]]$model[[4]] <- BoxCox(InvBoxCox(object$product[[4]], object$product$lambda) * 195 | InvBoxCox(object$ratio[[j]][[4]], object$product$lambda), object$product$lambda) 196 | } else { 197 | fc[[j]]$model[[4]] <- BoxCox(InvBoxCox(object$product[[4]], object$product$lambda) + 198 | InvBoxCox(object$ratio[[j]][[4]], object$product$lambda), object$product$lambda) 199 | } 200 | names(fc[[j]]$model)[4] <- names(object$ratio)[j] 201 | fc[[j]]$coeff <- list(list(level = fcast.mean$coeff[[1]]$level)) 202 | } 203 | 204 | names(fc) <- names(fcast.ratio) <- names(object$ratio) 205 | fc$product <- fcast.mean 206 | fc$ratio <- fcast.ratio 207 | 208 | return(structure(fc, class = "fmforecast2")) 209 | } 210 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # demography (development version) 2 | 3 | # demography 2.0.1 4 | 5 | - Updated HMDHFDplus dependency to v2.08+ 6 | 7 | # demography 2.0 8 | 9 | - Updated hmd functions due to changes at mortality.org. Now using HMDHFDplus for downloads. 10 | - Added functions to convert lifetable and demogdata objects to data frames. 11 | - Added pkgdown site 12 | 13 | # demography 1.22 14 | 15 | - Made compatible with latest rainbow and ftsa packages 16 | 17 | # demography 1.21 18 | 19 | - Using https for HMD 20 | - roxygenized all documentation 21 | - made compatible with latest forecast package 22 | 23 | # demography 1.20 24 | 25 | - Removed dependency on ftsa now that we no longer need a special median function. 26 | 27 | # demography 1.19 28 | 29 | - Lots of clean up to conform to CRAN policy 30 | - Fixed conflicts with some packages 31 | - total life expectancy for coherentfdm added 32 | - Added PI for coherent total life expectancy 33 | 34 | # demography 1.18 35 | 36 | - Updated lca() with "fertility" data 37 | - Modified handling of warnings in forecast.fdm() 38 | - Fixed problem in simulate() when there are too many missing values in residuals. Now all missing residuals are set to 0 39 | - Better handling of weights in forecast.fdm() 40 | - Allowed lca() to handle data that is observed less frequently than annually. 41 | 42 | # demography 1.17 43 | 44 | - fix for smooth.demogdata caused by changes in mgcv package 45 | 46 | # demography 1.16 47 | 48 | - Fixed bug in pop.sim when no migration data was used 49 | - Added hmd.pop() to read population data from www.mortality.org. 50 | - Fixed a bug in forecast.fdm() when the time series frequency is greater than 1. 51 | - Added scale argument to read.demogdata() 52 | - Fixed problems in forecasting cohort life expectancy 53 | - Improved documentation for read.demogdata() 54 | - Corrected a bug in smooth.demogdata in the default definition of age.grid 55 | 56 | # demography 1.15 57 | 58 | - smooth.demogdata will no longer return NAs for fertility data. Instead, the fertility rate for the nearest age with positive rate is used. 59 | - Fixed occasional bug in computing life expectancy prediction intervals from coherent fdm model. 60 | - Changed the way missing values are handled at the ends of the age range when smoothing. 61 | - Allowed missing values when using fdm(). 62 | 63 | # demography 1.14 64 | 65 | - minor changes to lifetable calculation. 66 | - replaced cm.spline and cm.splinefun with wrappers to spline and splinefun, now that these include hyman filtering. 67 | 68 | # demography 1.13 69 | 70 | - Generalized lca with e0 adjustment to allow starting ages other than 0. 71 | - Modified forecast.fdmpr() to allow better control of fractional differencing parameter. 72 | - Modified tfr to be more robust to series names other than "female". 73 | - Fixed bug in production prediction intervals in flife.expectancy from an lca object. 74 | - Added Simon Wood and R Core Team as contributing authors. 75 | 76 | # demography 1.12 77 | 78 | - Removed partial arg matching throughout. 79 | - Added updating methods for fmforecast and fmforecast2 classes. 80 | 81 | # demography 1.11 82 | 83 | - added warnings option to forecast.fdm(). 84 | - fixed rare error in forecast.fdm() 85 | - fixed incorrect label returned by sex.ratio() 86 | 87 | # demography 1.10 88 | 89 | - show.labels argument dropped from plot.demogdata() as the facility has been dropped by plot.fds() in the rainbow package. 90 | - Fixed a bug in lifetable() when dealing with age groups of more than 1 year. 91 | - Fixed bug in plot.demogdata() when logarithms of zero rates are calculated. 92 | 93 | # demography 1.09-1 94 | 95 | - Extended flife.expectancy() for use when there is insufficient historical data to compute cohort life expectancy. 96 | - Fixed a bug in flife.expectancy() when type="cohort". 97 | 98 | # demography 1.08 99 | 100 | - Fixed bug in plot.fmforecast() when plotting coefficients from lca object. 101 | - Fixed several bugs in flife.expectancy() for forecasting cohort life expectancy. 102 | - Fixed bug in lifetable() when type="cohort" and ages of length 1 to give one additional year. 103 | 104 | # demography 1.07 105 | 106 | - Modified signs of basis functions and coefficients in fdm() to make interpretation easier. This does not affect final forecasts as the signs cancel. 107 | - Fixed bug in forecast.fdm after fitting with weight=TRUE. 108 | - In forecast.fdmpr(): restricted ARFIMA forecasts for coherent models to use data only from the last K years where K can be specified. 109 | 110 | # demography 1.06 111 | 112 | - Fixed errors in help file for hmd.e0() 113 | - Fixed bug in forecast.fdm after fitting with weight=TRUE. 114 | 115 | # demography 1.05 116 | 117 | - Modified lifetable for type="cohort" to prevent partial lifetables being produced unless explicitly requested. 118 | - Added hmd.e0() function. 119 | 120 | # demography 1.04 121 | 122 | - Fixed bugs in the use of weights in fdm() and smooth.demogdata() 123 | - Lifetable functions rewritten to remove bugs and add additional functionality for cohort lifetables. 124 | - Improved speed of PI calculations in e0 125 | - Added flife.expectancy(). 126 | 127 | # demography 1.03 128 | 129 | - improved documentation for hmd.mx() 130 | 131 | # demography 1.02 132 | 133 | - changed some examples in the help file for bms() to enable the CRAN checks to run faster. 134 | 135 | # demography 1.0 136 | 137 | - First version on CRAN 138 | - Added summary() functions for fmforecast, fmforecast2, fdmpr and demogdata objects. 139 | - Added e0 prediction intervals for lca objects 140 | - Added model() functions 141 | - Fixed coherentfdm() to allow use with migration data 142 | - Fixed forecast.fmforecast2 to allow use with migration data 143 | - Fixed simulate.fmforecast2 to allow use with migration data 144 | - Updated pop.sim() to take coherent inputs for mortality and migration 145 | - Added simulation of lca objects 146 | - Fixed lots of bugs 147 | - Changed name of hmd() to hmd.mx() to anticipate other hmd.xx functions in the future. 148 | 149 | # demography v0.999 (30 July 2010) 150 | 151 | - e0 rewritten to allow calculation from coherentfdm results, and to correct the computation of prediction intervals. These are now done using simulations which are much slower than what was done previously, but they are correct (unlike in previous versions). Set the argument PI=TRUE to compute prediction intervals. 152 | - tfr rewritten to correct the computation of prediction intervals. These are now done using simulations which are much slower than what was done previously, but they are correct (unlike in previous versions). Set the argument PI=TRUE to compute prediction intervals. 153 | 154 | # demography v0.998 (21 May 2010) 155 | 156 | - Bug fixes in coherentfdm and to make hmd visible. 157 | 158 | # demography v0.997 (12 May 2010) 159 | 160 | - The package now depends on the ftsa and rainbow packages. All duplicate functions have been omitted. 161 | - A new function hmd allows data to be downloaded directly from the Human Mortality Database. 162 | - A new function coherentfdm and an associated forecast method allows coherent forecasting for groups of functional data. 163 | - Some minor bug fixes. 164 | 165 | # demography v0.996 (29 March 2010) 166 | 167 | - Fixed bug in lca and added warning to lifetable when there are 168 | 169 | # demography v0.995 (4 March 2009) 170 | 171 | - Fixed bug in pop.sim. 172 | 173 | # demography v0.994 (26 February 2009) 174 | 175 | - Corrected lifetable calculations to work when the sex is unknown. 176 | 177 | # demography v0.993 (4 August 2008) 178 | 179 | - Corrected combine.demogdata to produce a ?pop? object when possible, and modified associated help file accordingly. 180 | - Updated the lifetable function to allow five-??year age groups. 181 | 182 | # demography v0.992 (3 July 2008) 183 | 184 | - Allowed greater flexibility in fitting stationary coefficients to only some components, and using ar for stationary models. 185 | - Changed the default number of terms in an fdm or ftsm model to 6 rather than 3. 186 | - Bug in smooth.demogdata fixed and made compatible with latest version of mgcv package. 187 | - Added color control in plot.ftsm and plot.fdm 188 | 189 | # demography v0.991 (12 May 2008) 190 | 191 | - Prediction intervals for fdm objects now allowed using structural time series and random walks with drift. 192 | - Changed default forecasting method to ?arima? in forecast.fdm and forecast.ftsm 193 | - Corrected time component of coefficients from forecast.fdm 194 | 195 | # demography v0.99 196 | 197 | - Bug fixes in smooth.demogdata 198 | - Bug fix in forecast.fdm to allow method=?ets.na? to work again. 199 | 200 | # demography v0.98 201 | 202 | - Updated documentation to conform to new CRAN rules. 203 | - Added population forecasting functions as described in Hyndman and Booth (2007). 204 | - Modified the internals of smooth.demogdata to take account of changes in the R base and stats packages. 205 | - A few bug fixes. 206 | 207 | # demography v0.97 208 | 209 | - Many changes to documentation and functions to satisfy CRAN checks. 210 | - Updated all forecasting functions to work with v1.0 of the forecast package. Check help files as some syntax has changed. 211 | - Various bug fixes. 212 | 213 | # demography v0.96 214 | 215 | - smooth.demogdata slightly modified to give better results. 216 | - Bug fixes in various functions. 217 | - Smooth.demogdata handles age-??grouping better. 218 | - Smooth.demogdata no longer crashes if all age groups have zero population in a year. 219 | 220 | # demography v0.95 221 | 222 | - Most data have now been taken out of the package (as it is now publicly available). The only data sets in the demography package are fr.mort (French mortality) and aus.fert (Australian fertility). 223 | - The package now handles fertility, mortality and migration data. The basic data class is ?demogdata? and demogdata$type indicates the type of demographic data. 224 | - Many functions have been revised to handle the new data structures. However, I?ve tried to keep the calling syntax the same. If existing code no longer works, check the help files first. 225 | - fmm has been renamed as fdm as it now fits functional demographic models (and not only functional mortality models). 226 | - read.mortality has been renamed as read.demogdata. Similarly, other functions of the form xxx.mortality are now called xxx.demogdata. 227 | - smooth.demogdata now handles various types of smoothing and smoothing constraints. See the help file for details. It tries to do something appropriate depending on the type of data passed. At the moment, it only handles mortality and fertility data. 228 | - I?ve added tfr to compute total fertility rates, and isfe to compute the Integrated Squared Forecast Error for different model orders. 229 | - The documentation has been revised in many places, and several references added. 230 | - All these changes have almost certainly introduced new errors 231 | -------------------------------------------------------------------------------- /R/netmigration.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | netmigration <- function(mort, fert, startyearpop = mort, mfratio = 1.05) { 3 | # Basic checks on inputs 4 | if (!inherits(mort, "demogdata") | !inherits(fert, "demogdata")) { 5 | stop("Inputs not demogdata objects") 6 | } 7 | if (mort$type != "mortality") { 8 | stop("mort not mortality data") 9 | } 10 | if (fert$type != "fertility") { 11 | stop("fert not fertility data") 12 | } 13 | 14 | # Find years with both mortality and fertility data and startpop data 15 | yrs <- mort$year[sort(match(fert$year, mort$year))] 16 | yrs <- yrs[sort(match(startyearpop$year, yrs))] 17 | if (max(startyearpop$year) > max(yrs)) { 18 | startyearpop <- extract.years(startyearpop, c(yrs, max(yrs) + 1)) 19 | } else { 20 | startyearpop <- extract.years(startyearpop, yrs) 21 | yrs <- sort(unique(pmin(yrs, max(yrs) - 1))) 22 | } 23 | mort <- extract.years(mort, yrs) 24 | fert <- extract.years(fert, yrs) 25 | n <- length(yrs) 26 | p <- length(mort$age) 27 | 28 | # Splits births by male and female 29 | B <- colSums(fert$pop$female * fert$rate$female / 1000) 30 | Bf <- B * 1 / (1 + mfratio) 31 | Bm <- B * mfratio / (1 + mfratio) 32 | 33 | # Compute non-survival ratios from mortality rates 34 | nsr.f <- 1 - lifetable(mort, "female", max.age = max(mort$age))$rx 35 | nsr.m <- 1 - lifetable(mort, "male", max.age = max(mort$age))$rx 36 | 37 | # Estimate deaths 38 | oldest.f <- colSums(as.matrix(startyearpop$pop$female[(p - 1):p, ])) 39 | oldest.m <- colSums(as.matrix(startyearpop$pop$male[(p - 1):p, ])) 40 | if (n > 1) { 41 | Df <- nsr.f * rbind(Bf, startyearpop$pop$female[1:(p - 2), -n - 1], oldest.f[-n - 1]) 42 | Dm <- nsr.m * rbind(Bm, startyearpop$pop$male[1:(p - 2), -n - 1], oldest.m[-n - 1]) 43 | } else { 44 | Df <- nsr.f * c(Bf, startyearpop$pop$female[1:(p - 2), -n - 1], oldest.f[-n - 1]) 45 | Dm <- nsr.m * c(Bm, startyearpop$pop$male[1:(p - 2), -n - 1], oldest.m[-n - 1]) 46 | } 47 | Dm[is.na(Dm) | Dm < 0] <- 0 48 | Df[is.na(Df) | Df < 0] <- 0 49 | 50 | # Compute net migration 51 | Mf <- Mm <- matrix(NA, nrow = p, ncol = n) 52 | for (j in 1:n) 53 | { 54 | current <- extract.years(startyearpop, years = yrs[j] + 1) 55 | prev <- extract.years(startyearpop, years = yrs[j]) 56 | Mf[, j] <- current$pop$female - c(Bf[j], prev$pop$female[1:(p - 2), ], oldest.f[j]) + Df[, j] 57 | Mm[, j] <- current$pop$male - c(Bm[j], prev$pop$male[1:(p - 2), ], oldest.m[j]) + Dm[, j] 58 | } 59 | 60 | # Store migration figures in a demogdata object with same population figures as startyearpop 61 | mig <- extract.years(startyearpop, years = yrs) 62 | mig$rate$female <- Mf 63 | mig$rate$male <- Mm 64 | mig$rate$total <- Mm + Mf 65 | mig$pop$total <- mig$pop$male + mig$pop$female 66 | mig$lambda <- 1 67 | dimnames(mig$rate$male) <- dimnames(mig$rate$female) <- dimnames(mig$rate$total) <- dimnames(mig$pop$male) 68 | mig$type <- "migration" 69 | 70 | # Return result. Note: rows are actually (B,0), (0,1), etc. 71 | return(mig) 72 | } 73 | 74 | # data must be a demogdata object containing population values for the last year of observation mort 75 | # and mig are fmforecast2 objects and fert is a fmforecast object. If they are NULL, it is assumed 76 | # all values are zero. 77 | #' Population simulation 78 | #' 79 | #' Simulate future sample paths of a population using functional models for mortality, fertility and migration. 80 | #' 81 | #' @param mort Forecasts of class \code{fmforecast2} for mortality. 82 | #' @param fert Forecasts of class \code{fmforecast} for female fertility. 83 | #' @param mig Forecasts of class \code{fmforecast2} for net migration. 84 | #' @param firstyearpop Population for first year of simulation. 85 | #' @param N Number of sample paths to simulate. 86 | #' @param mfratio Male-female ratio used in distributing births. 87 | #' @param bootstrap If TRUE, simulation uses resampled errors rather than normally distributed errors. 88 | #' 89 | #' @return A list of two arrays containing male and female future simulated population values. 90 | #' The arrays are of dimension (p,h,N) where p is the number of age groups, h is the forecast horizon 91 | #' and N is the number of simulated sample paths. 92 | #' @author Rob J Hyndman 93 | #' @seealso \code{\link{simulate.fmforecast}}, \code{\link{simulate.fmforecast2}}. 94 | #' @examples 95 | #' \dontrun{ 96 | #' require(addb) 97 | #' # Construct data objects 98 | #' mort.sm <- smooth.demogdata(set.upperage(extract.years(australia, 1950:2002), 100)) 99 | #' fert.sm <- smooth.demogdata(extract.years(aus.fertility, 1950:2002)) 100 | #' aus.mig <- netmigration(set.upperage(australia, 100), aus.fertility, mfratio = 1.0545) 101 | #' # Fit models 102 | #' mort.fit <- coherentfdm(mort.sm) 103 | #' fert.fit <- fdm(fert.sm) 104 | #' mig.fit <- coherentfdm(aus.mig) 105 | #' # Produce forecasts 106 | #' mort.fcast <- forecast(mort.fit) 107 | #' fert.fcast <- forecast(fert.fit) 108 | #' mig.fcast <- forecast(mig.fit) 109 | #' # Simulate 110 | #' aus.sim <- pop.sim(mort.fcast, fert.fcast, mig.fcast, australia) 111 | #' } 112 | #' 113 | #' @keywords models 114 | #' @export 115 | pop.sim <- function(mort, fert = NULL, mig = NULL, firstyearpop, N = 100, mfratio = 1.05, bootstrap = FALSE) { 116 | no.mortality <- FALSE # Not possible to proceed without mort object 117 | no.fertility <- is.null(fert) 118 | no.migration <- is.null(mig) 119 | 120 | # Basic checks on inputs 121 | if (!no.mortality) { 122 | if (!inherits(mort, "fmforecast2")) { 123 | stop("Inputs not fmforecast2 objects") 124 | } 125 | if (mort$female$type != "mortality" | mort$male$type != "mortality") { 126 | stop("mort not based on mortality data") 127 | } 128 | } 129 | if (!no.fertility) { 130 | if (!inherits(fert, "fmforecast")) { 131 | stop("Inputs not fmforecast objects") 132 | } 133 | if (fert$type != "fertility") { 134 | stop("fert not based on fertility data") 135 | } 136 | } 137 | if (!no.migration) { 138 | if (!inherits(mig, "fmforecast2")) { 139 | stop("Inputs not fmforecast2 objects") 140 | } 141 | if (mig$male$type != "migration" | mig$female$type != "migration") { 142 | stop("mig not based on migration data") 143 | } 144 | } 145 | 146 | firstyr <- mort$male$year 147 | if (!no.fertility) { 148 | firstyr <- intersect(firstyr, fert$year) 149 | } 150 | if (!no.migration) { 151 | firstyr <- intersect(firstyr, mig$male$year) 152 | } 153 | firstyr <- min(firstyr) 154 | pop <- extract.years(firstyearpop, firstyr)$pop 155 | 156 | # Check ages match. First make them all integers to prevent integer/numeric clashes 157 | firstyearpop$age <- as.integer(firstyearpop$age) 158 | mort$male$age <- as.integer(mort$male$age) 159 | mig$male$age <- as.integer(mig$male$age) 160 | if (!no.migration) { 161 | if (!identical(firstyearpop$age, mig$male$age)) { 162 | stop("Please ensure that migration and population data have the same age dimension") 163 | } 164 | } 165 | if (!no.mortality) { 166 | if (!identical(firstyearpop$age, mort$male$age)) { 167 | stop("Please ensure that mortality and population data have the same age dimension") 168 | } 169 | } 170 | p <- length(firstyearpop$age) 171 | 172 | # Simulate all components 173 | hm <- hf <- h <- Inf 174 | if (!no.mortality) { 175 | mort.sim <- simulate(mort, nsim = N, bootstrap = bootstrap) 176 | hm <- length(mort$male$year) 177 | } 178 | if (!no.fertility) { 179 | fert.sim <- simulate(fert, nsim = N, bootstrap = bootstrap) 180 | hf <- length(fert$year) 181 | } 182 | if (!no.migration) { 183 | mig.sim <- simulate(mig, nsim = N, bootstrap = bootstrap) 184 | h <- length(mig$male$year) 185 | nm <- length(mig$male$model$year) 186 | } 187 | h <- min(hm, hf, h) 188 | 189 | # Set up storage space 190 | if (!no.fertility) { 191 | fage <- is.element(rownames(pop$female), fert$age) 192 | } 193 | pop.f <- pop.m <- array(0, c(p, h, N)) 194 | dimnames(pop.f) <- dimnames(pop.m) <- list(mort$female$age, 1:h, 1:N) 195 | 196 | advance <- function(x0, x) { 197 | n <- length(x) 198 | newx <- c(x0, x[1:(n - 2)], x[n - 1] + x[n]) 199 | } 200 | 201 | # Simulate N future sample paths of population numbers 202 | for (i in 1:N) 203 | { 204 | # Start with final observed populations 205 | popf <- round(c(pop$female)) 206 | popm <- round(c(pop$male)) 207 | 208 | for (j in 1:h) 209 | { 210 | # Compute net migration 211 | if (no.migration) { 212 | netf <- netm <- 0 213 | Rf <- popf 214 | Rm <- popm 215 | } else { 216 | # Simulate net migration 217 | netf <- round(mig.sim$female[, j, i] + mig$female$model$res$y[, sample(1:nm, 1)]) 218 | netm <- round(mig.sim$male[, j, i] + mig$male$model$res$y[, sample(1:nm, 1)]) 219 | # Add half migrants to current population 220 | Rf <- pmax(popf + 0.5 * c(netf[2:(p - 1)], 0.5 * netf[p], 0.5 * netf[p]), 0) 221 | Rm <- pmax(popm + 0.5 * c(netm[2:(p - 1)], 0.5 * netm[p], 0.5 * netm[p]), 0) 222 | } 223 | # Survivorship ratios 224 | # firstyear pop used only to get structure. Data replaced. 225 | Rt <- firstyearpop 226 | Rt$type <- "mortality" 227 | Rt$lambda <- 0 228 | Rt$year <- 1 229 | Rt$rate$female <- matrix(mort.sim$female[, j, i], ncol = 1) 230 | Rt$rate$male <- matrix(mort.sim$male[, j, i], ncol = 1) 231 | Rt$pop$female <- matrix(Rf, ncol = 1) 232 | Rt$pop$male <- matrix(Rm, ncol = 1) 233 | Rt$rate$total <- Rt$pop$total <- NULL 234 | colnames(Rt$pop$male) <- colnames(Rt$pop$female) <- colnames(Rt$rate$male) <- colnames(Rt$rate$female) <- "1" 235 | rownames(Rt$pop$male) <- rownames(Rt$pop$female) <- rownames(Rt$rate$male) <- rownames(Rt$rate$female) <- Rt$age 236 | nsr.f <- 1 - lifetable(Rt, "female", max.age = max(Rt$age))$rx 237 | nsr.m <- 1 - lifetable(Rt, "male", max.age = max(Rt$age))$rx 238 | 239 | # Simulate deaths 240 | cohDf <- pmax(nsr.f[c(2:p, p)] * Rf, 0) 241 | cohDm <- pmax(nsr.m[c(2:p, p)] * Rm, 0) 242 | Rf2 <- advance(0, Rf - cohDf) # Ignore deaths to births for now 243 | Rm2 <- advance(0, Rm - cohDm) 244 | Ef <- 0.5 * (Rf + Rf2) 245 | Em <- 0.5 * (Rm + Rm2) 246 | Df <- rpois(rep(1, p), Ef * mort.sim$female[, j, i]) 247 | Dm <- rpois(rep(1, p), Em * mort.sim$male[, j, i]) 248 | 249 | # Compute adjusted population ignoring births 250 | cohDf[2:(p - 2)] <- 0.5 * (Df[2:(p - 2)] + Df[3:(p - 1)]) 251 | cohDm[2:(p - 2)] <- 0.5 * (Dm[2:(p - 2)] + Dm[3:(p - 1)]) 252 | cohDf[p - 1] <- 0.5 * Df[p - 1] + Df[p] 253 | cohDm[p - 1] <- 0.5 * Dm[p - 1] + Dm[p] 254 | cohDf[p] <- cohDm[p] <- 0 255 | 256 | Rf2 <- advance(0, Rf - cohDf) # Fix problem with deaths to births later 257 | Rm2 <- advance(0, Rm - cohDm) 258 | 259 | # Simulate births from Poisson distribution 260 | if (no.fertility) { 261 | B <- 0 262 | } else { 263 | lambda <- 0.5 * (Rf[fage] + Rf2[fage]) * fert.sim[, j, i] / 1000 264 | B <- sum(rpois(rep(1, length(fert$age)), lambda)) 265 | } 266 | # Randomly split births into two sexes 267 | Bm <- rbinom(1, B, mfratio / (1 + mfratio)) 268 | Bf <- B - Bm 269 | 270 | # Infant mortality 271 | RfB <- pmax(Bf + 0.5 * netf[1], 0) 272 | RmB <- pmax(Bm + 0.5 * netm[1], 0) 273 | cohDfB <- pmax(nsr.f[1] * RfB, 0) 274 | cohDmB <- pmax(nsr.m[1] * RmB, 0) 275 | Rf20 <- RfB - cohDfB 276 | Rm20 <- RmB - cohDmB 277 | Ef0 <- 0.5 * (Rf[1] + Rf20) 278 | Em0 <- 0.5 * (Rm[1] + Rm20) 279 | Df0 <- rpois(1, Ef0 * mort.sim$female[1, j, i]) 280 | Dm0 <- rpois(1, Em0 * mort.sim$male[1, j, i]) 281 | f0f <- cohDfB / (Ef0 * mort.sim$female[1, j, i]) 282 | f0m <- cohDmB / (Em0 * mort.sim$male[1, j, i]) 283 | cohDfB <- f0f * Df0 284 | cohDmB <- f0m * Dm0 285 | 286 | # Now we can fix infant deaths 287 | cohDf[1] <- (1 - f0f) * Df0 + 0.5 * Df[1] 288 | cohDm[1] <- (1 - f0m) * Dm0 + 0.5 * Dm[1] 289 | Rf2 <- advance(RfB - cohDfB, Rf - cohDf) 290 | Rm2 <- advance(RmB - cohDmB, Rm - cohDm) 291 | 292 | # Add remaining migrants 293 | popf <- round(pmax(Rf2 + 0.5 * netf, 0)) 294 | popm <- round(pmax(Rm2 + 0.5 * netm, 0)) 295 | 296 | # Store final population numbers 297 | pop.f[, j, i] <- popf 298 | pop.m[, j, i] <- popm 299 | } 300 | } 301 | # Set up names of years 302 | dimnames(pop.m)[[2]] <- dimnames(pop.m)[[2]] <- firstyr + (1:h) - 1 303 | 304 | # Return all sample paths 305 | return(list(male = pop.m, female = pop.f)) 306 | } 307 | 308 | 309 | deaths <- function(x) { 310 | if (!inherits(x, "demogdata") | x$type != "mortality") { 311 | stop("Not a mortality object") 312 | } 313 | npop <- length(x$rate) 314 | out <- list() 315 | for (i in 1:npop) 316 | { 317 | out[[i]] <- round(x$rate[[i]] * x$pop[[i]]) 318 | out[[i]][is.na(out[[i]])] <- 0 319 | } 320 | names(out) <- names(x$rate) 321 | return(out) 322 | } 323 | 324 | births <- function(x) { 325 | if (!inherits(x, "demogdata") | x$type != "fertility") { 326 | stop("Not a fertility object") 327 | } 328 | out <- round(x$rate[[1]] * x$pop[[1]] / 1000) 329 | out[is.na(out)] <- 0 330 | return(out) 331 | } 332 | -------------------------------------------------------------------------------- /R/smooth.R: -------------------------------------------------------------------------------- 1 | ## SMOOTH FTS 2 | smooth.fts <- function(data, k = -1, xgrid = data$x, se.fit = FALSE, w = rep(1, nrow(data$y))) { 3 | result <- seresult <- data 4 | x <- data$x 5 | result$x <- seresult$x <- xgrid 6 | ny <- ncol(data$y) 7 | result$y <- seresult$y <- matrix(NA, ncol = ny, nrow = length(xgrid)) 8 | kvec <- numeric(ny) 9 | meany <- mean(data)$y 10 | data$y <- sweep(data$y, 1, meany) 11 | if (is.null(dim(w))) { 12 | w <- matrix(rep(w, ny), ncol = ny) 13 | } 14 | 15 | # Find optimal k 16 | if (k < 0) { 17 | for (j in 1:ny) 18 | { 19 | fit <- mgcv::gam(data$y[, j] ~ s(x, k = k), weights = w[, j]) 20 | kvec[j] <- sum(fit$edf) 21 | } 22 | k <- round(median(kvec) + .5) 23 | } 24 | # Smooth using chosen k 25 | for (j in 1:ny) 26 | { 27 | fit <- mgcv::gam(data$y[, j] ~ s(x, k = k), weights = w[, j]) 28 | smooth.fit <- mgcv::predict.gam(fit, newdata = data.frame(x = xgrid), se.fit = se.fit) 29 | if (se.fit) { 30 | result$y[, j] <- smooth.fit$fit 31 | seresults$y[, j] <- smooth.fit$se.fit 32 | } else { 33 | result$y[, j] <- smooth.fit 34 | } 35 | } 36 | interp <- stats::spline(x, meany, n = 500) 37 | interp <- stats::approx(interp$x, interp$y, xout = xgrid)$y 38 | result$y <- sweep(result$y, 1, interp, "+") 39 | if (se.fit) { 40 | return(list(result, seresult)) 41 | } else { 42 | return(result) 43 | } 44 | } 45 | 46 | ## Function to smooth mortality curves 47 | ## Divides age into three sections: 0-a, a-b and b+ 48 | ## Will interpolate first period (0-a) 49 | ## Will smooth second period (a-b) 50 | ## For third period (b+) it uses montonically increasing smooths if monotonic TRUE 51 | ## Number of knots for smoothing set by k 52 | #' Create smooth demogdata functions 53 | #' 54 | #' Smooth demogdata data using one of four methods depending on the value of \code{method} 55 | #' 56 | #' 57 | #' 58 | #' The value of \code{method} determines the type of smoothing used. 59 | #' \describe{ 60 | #' \item{method="mspline"}{Weighted penalized regression splines with a monotonicity constraint. The curves are monotonically 61 | #' increasing for age greater than b. Smoothness controlled by \code{k}. Methodology based on Wood (1994). Code calls \code{\link[mgcv]{gam}} for the basic 62 | #' computations.} 63 | #' \item{method="cspline"}{Weighted regression B-splines with a concavity constraint. Smoothness controlled by \code{lambda}. 64 | #' Methodology based on He and Ng (1999). Code calls \code{\link[cobs]{cobs}} for the basic computations.} 65 | #' \item{method="spline"}{Unconstrained weighted penalized regression splines. Equivalent to "mspline" but with \code{b=Inf}.} 66 | #' \item{method="loess"}{Weighted locally quadratic regression. Smoothness controlled by span. Code calls 67 | #' \code{\link{loess}} for the basic computations.} 68 | #' } 69 | #' @param data Demogdata object such as created using \code{\link{read.demogdata}}. 70 | #' @param method Method of smoothing. Possibilities: \code{"mspline"} (monotonic regression splines), 71 | #' \code{"cspline"} (concave regression splines), 72 | #' \code{"spline"} (unconstrained regression splines), 73 | #' \code{"loess"} (local quadratic using \code{\link{loess}}). 74 | #' @param age.grid Ages to use for smoothed curves. Default is single years over a slightly greater range than the unsmoothed data. 75 | #' @param power Power transformation for age variable before smoothing. Default is 0.4 for mortality data and 1 (no transformation) for fertility or migration data. 76 | #' @param b Lower age for monotonicity if \code{method=="mspline"}. Above this, the smooth curve 77 | #' is assumed to be monotonically increasing. 78 | #' @param k Number of knots to use for penalized regression spline estimate. Ignored if \code{method=="loess"}. 79 | #' @param span Span for loess smooth if \code{method=="loess"}. 80 | #' @param lambda Penalty for constrained regression spline if \code{method=="cspline"}. 81 | #' @param interpolate If \code{interpolate==TRUE}, a linear interpolation is used instead of smoothing. 82 | #' @param weight If TRUE, uses weighted smoothing. 83 | #' @param obs.var Method for computing observational variance. Possible values: \dQuote{empirical} or \dQuote{theoretical}. 84 | #' 85 | 86 | #' 87 | #' @return Demogdata object identical to \code{data} except all 88 | #' rate matrices are replaced with smooth versions and pop matrices are replaced with disaggregated population estimates obtained 89 | #' using monotonic spline interpolation applied to the cumulative population data. 90 | #' Weight 91 | #' matrices are also added to the object showing the inverse 92 | #' variances of the estimated smooth curves. 93 | #' 94 | #' @keywords smooth 95 | #' @author Rob J Hyndman 96 | #' @examples 97 | #' france.sm <- smooth.demogdata(extract.years(fr.mort, 1980:1997)) 98 | #' plot(france.sm) 99 | #' plot(fr.mort, years = 1980, type = "p", pch = 1) 100 | #' lines(france.sm, years = 1980, col = 2) 101 | #' 102 | #' @export 103 | smooth.demogdata <- function( 104 | data, method = switch(data$type, 105 | mortality = "mspline", 106 | fertility = "cspline", 107 | migration = "loess" 108 | ), age.grid, 109 | power = switch(data$type, 110 | mortality = 0.4, 111 | fertility = 1, 112 | migration = 1 113 | ), 114 | b = 65, k = 30, span = 0.2, lambda = 1e-10, interpolate = FALSE, weight = data$type != "migration", 115 | obs.var = "empirical") { 116 | method <- c("mspline", "msplinecobs", "cspline", "spline", "loess")[pmatch(method, c("mspline", "msplinecobs", "cspline", "spline", "loess"))] 117 | if (is.na(method)) { 118 | stop("Unknown smoothing method") 119 | } 120 | obs.var <- c("empirical", "theoretical")[pmatch(obs.var, c("empirical", "theoretical"))] 121 | if (is.na(obs.var)) { 122 | stop("Unknown method for observational variance") 123 | } 124 | 125 | # Smooth logged fertility and mortality data 126 | dlambda <- data$lambda 127 | if (data$type != "migration") { 128 | data$lambda <- 0 129 | } # Ensure smooth curves are positive. 130 | 131 | minx <- min(data$age) 132 | maxx <- max(data$age) 133 | nx <- length(data$age) 134 | delta1 <- data$age[2] - data$age[1] 135 | delta2 <- data$age[nx] - data$age[nx - 1] 136 | 137 | ## Construct upper ages for each group 138 | xmin <- minx + 0.5 - 0.5 * delta1 139 | xmax <- maxx + 0.5 + 0.5 * delta2 140 | upperage <- c(xmin, 0.5 * (data$age[1:(nx - 1)] + data$age[2:nx] + 1), xmax) - 1 141 | 142 | # Construct age.grid if missing 143 | if (missing(age.grid)) { 144 | xmin <- minx - 0.5 * delta1 + 0.5 145 | xmax <- maxx + 0.5 * delta2 - 0.5 146 | } else { 147 | xmin <- min(age.grid) 148 | xmax <- max(age.grid) 149 | } 150 | xmin <- floor(xmin) 151 | xmax <- ceiling(xmax) 152 | age.grid <- seq(xmin, xmax, by = 1) 153 | 154 | if (method == "spline") { 155 | method <- "mspline" 156 | b <- 1000 157 | a <- -1000 158 | } 159 | 160 | n <- length(data$rate) 161 | 162 | if (data$type == "migration" | interpolate) { 163 | weight <- FALSE 164 | } 165 | if (weight) { 166 | data$wt <- use.weight(data) 167 | } 168 | if (obs.var == "theoretical") { 169 | datawt <- use.weight(data, FALSE) 170 | } 171 | fred <- matrix(1, nrow = length(age.grid), ncol = ncol(data$rate[[1]])) 172 | data$serate <- data$rate 173 | x <- data$age^power 174 | data$obs.var <- list() 175 | for (i in 1:n) 176 | { 177 | y <- BoxCox(as.matrix(data$rate[[i]]), data$lambda) 178 | if (weight) { 179 | y[y < -1e20] <- -10 180 | } 181 | data$obs.var[[i]] <- y * NA 182 | 183 | ny <- ncol(y) 184 | p <- nrow(y) 185 | newpop <- newy <- se.y <- matrix(NA, ncol = ny, nrow = length(age.grid)) 186 | err <- y * NA 187 | for (j in 1:ny) 188 | { 189 | if (weight) { 190 | w <- as.matrix(data$wt[[i]])[, j] 191 | } else { 192 | w <- ww <- rep(1, p) 193 | } 194 | w[y[, j] < -1e20] <- 0 195 | xx <- x[w > 0] 196 | yy <- y[w > 0, j] 197 | ww <- w[w > 0] 198 | if (sum(is.na(y[, j]) | y[, j] == 0) == p) { 199 | smooth.fit <- list(fit = rep(NA, p), se = rep(NA, p)) 200 | } else if (interpolate) { 201 | smooth.fit <- list(fit = stats::approx(xx, yy, xout = age.grid^power, rule = 1)$y, se = rep(0, length(age.grid))) 202 | } else if (method == "loess") { 203 | fit <- loess(yy ~ xx, span = span, degree = 2, weights = ww, surface = "direct") 204 | smooth.fit <- stats::predict(fit, newdata = data.frame(xx = age.grid^power), se = TRUE) 205 | } else if (method == "mspline") { 206 | smooth.fit <- smooth.monotonic(xx, yy, b^power, max(min(round(length(xx) * .8), k), 4), ww, age.grid^power) 207 | } else if (method == "msplinecobs") { 208 | smooth.fit <- smooth.monotonic.cobs(xx, yy, b^power, lambda = lambda, w = ww, newx = age.grid^power, nknots = k) 209 | } else if (method == "cspline") { 210 | smooth.fit <- fert.curve(xx, yy, ww, age.grid^power, lambda = lambda, interpolate = interpolate, tlambda = data$lambda) 211 | } 212 | newy[, j] <- smooth.fit$fit 213 | se.y[, j] <- smooth.fit$se 214 | newpop[, j] <- diff(cm.spline(upperage, cumsum(c(0, data$pop[[i]][, j])), xmin = xmin - 1, xmax = xmax, n = xmax - xmin + 2)$y) 215 | if (sum(!is.na(newy[, j])) > 2) { 216 | err[, j] <- y[, j] - stats::approx(age.grid, newy[, j], xout = data$age)$y 217 | } 218 | if (obs.var == "theoretical") { 219 | fred[, j] <- stats::approx(data$age, datawt[[i]][, j], xout = age.grid, rule = 2)$y 220 | } 221 | } 222 | dimnames(newy) <- dimnames(newpop) <- dimnames(se.y) <- list(age.grid, data$year) 223 | data$rate[[i]] <- InvBoxCox(newy, data$lambda) 224 | if (interpolate) { 225 | data$serate[[i]] <- data$obs.var[[i]] <- matrix(0, ncol = ny, nrow = length(age.grid)) 226 | } else if (obs.var == "theoretical") { 227 | data$serate[[i]] <- se.y / data$rate[[i]] # Needs fixing if lambda != 0 228 | data$obs.var[[i]] <- 1 / fred 229 | data$obs.var[[i]][abs(data$obs.var[[i]]) > 1e9] <- max(data$obs.var[[i]][data$obs.var[[i]] < 1e9]) 230 | } else { 231 | data$serate[[i]] <- se.y 232 | y <- InvBoxCox(y, data$lambda) 233 | yy <- y 234 | for (j in 1:ny) { 235 | yy[, j] <- stats::approx(age.grid, newy[, j], xout = data$age)$y 236 | } 237 | yy <- InvBoxCox(yy, data$lambda) 238 | xx <- data$age 239 | ov <- exp(stats::predict(loess(log(rowMeans((y - yy)^2)) ~ xx, span = 2 / sqrt(length(data$age)), degree = 2, surface = "direct"), newdata = data.frame(xx = age.grid))) 240 | data$obs.var[[i]] <- matrix(ov, length(age.grid), ny) 241 | } 242 | dimnames(data$obs.var[[i]]) <- list(age.grid, data$year) 243 | data$pop[[i]] <- newpop 244 | data$err[[i]] <- err 245 | } 246 | names(data$obs.var) <- names(data$rate) 247 | data$age <- age.grid 248 | data$lambda <- dlambda 249 | return(data) 250 | } 251 | 252 | 253 | # Smooth interpolation of data 254 | 255 | fert.curve <- function(x, y, w, age.grid, lambda = 1, interpolate = TRUE, tlambda, ...) { 256 | # if(min(age.grid) < min(x)) 257 | # { 258 | # x <- c(13,x) 259 | # y <- c(BoxCox(0.001,tlambda),y) 260 | # w <- c(max(w),w) 261 | # } 262 | # if(max(age.grid) > max(x)) 263 | # { 264 | # x <- c(x,52) 265 | # y <- c(y,BoxCox(0.001,tlambda)) 266 | # w <- c(w,max(w)) 267 | # } 268 | w <- w / sum(w) 269 | # Transformation 270 | xx <- x # sign(x-30)*abs(x-30)^1.8 271 | 272 | oldwarn <- options(warn = -1) 273 | # Unweighted smoothing as there seems to be a problem with the cobs function when weights specified 274 | if (interpolate) { 275 | fred <- stats::predict(cobs(xx, y, 276 | constraint = "concave", pointwise = cbind(rep(0, length(xx)), xx, y), 277 | lambda = lambda, print.warn = FALSE, print.mesg = FALSE, maxiter = 1e4 278 | ), interval = "conf", nz = 200) 279 | } else { 280 | fred <- stats::predict(cobs(xx, y, 281 | constraint = "concave", 282 | lambda = lambda, print.warn = FALSE, print.mesg = FALSE, maxiter = 1e4 283 | ), interval = "conf", nz = 200) 284 | } 285 | options(warn = oldwarn$warn) 286 | 287 | # fred[,1] <- abs(fred[,1])^(5/9)*sign(fred[,1])+30 288 | 289 | fit <- stats::approx(fred[, 1], fred[, 2], xout = age.grid, rule = 1)$y 290 | se <- stats::approx(fred[, 1], (fred[, 4] - fred[, 3]) / 2 / 1.96, xout = age.grid, rule = 1)$y 291 | return(list(fit = fit, se = se)) 292 | } 293 | 294 | ## Function to calculate the weight 295 | 296 | standardize <- function(x, sumx = 1) { 297 | return(x / sum(x, na.rm = TRUE) * sumx) 298 | } 299 | 300 | use.weight <- function(data, standardize = TRUE) { 301 | w <- list() 302 | n <- length(data$rate) 303 | for (i in 1:n) 304 | { 305 | # Extract rate and population matrices 306 | rate.dim <- dim(data$rate[[i]]) 307 | rate <- data$rate[[i]] 308 | pop <- data$pop[[i]] 309 | if (standardize) { 310 | pop <- pop / max(pop, na.rm = TRUE) 311 | } 312 | if (data$type == "fertility") { 313 | rate <- rate / 1000 314 | w[[i]] <- pop * rate^(1 - 2 * data$lambda) 315 | } else if (data$type == "mortality") { 316 | w[[i]] <- pop * rate^(1 - 2 * data$lambda) 317 | } else { 318 | stop("I shouldn't be here!") 319 | } 320 | # if(mean(w[[i]],na.rm=TRUE) > 1) 321 | # stop("There's a problem. It looks like your rates are all too large.") 322 | # else 323 | if (mean(w[[i]], na.rm = TRUE) < 0) { 324 | stop("There's a problem. Do you have negative rates?") 325 | } 326 | w[[i]][w[[i]] > 1e9] <- 0 327 | w[[i]][w[[i]] < 0] <- 0 328 | # w[[i]][rate < 1e-9] <- 0 329 | # w[[i]][BoxCox(rate,data$lambda) < -1e9] <- 0 330 | if (data$type == "mortality") { 331 | w[[i]][log(rate) > -1e-9] <- 0 332 | } 333 | if (standardize) { 334 | w[[i]] <- apply(w[[i]], 2, standardize, sumx = rate.dim[1]) 335 | } 336 | w[[i]][is.na(w[[i]])] <- 0 337 | colnames(w[[i]]) <- colnames(pop) 338 | rownames(w[[i]]) <- rownames(pop) 339 | } 340 | names(w) <- names(data$rate) 341 | return(w) 342 | } 343 | -------------------------------------------------------------------------------- /R/lca.R: -------------------------------------------------------------------------------- 1 | ## Last updated 29 May 2003 by RJH 2 | ## Added plot.lca and print.lca 3 | ## Changed way of limiting ages in lca 4 | ## Fixed bug which arose occasionally when using method "dt" 5 | ## Made "dt" the default as in original LC paper. 6 | 7 | #' Model mortality or fertility data using Lee-Carter approach 8 | #' 9 | #' Lee-Carter model of mortality or fertility rates. \code{lca} produces a 10 | #' standard Lee-Carter model by default, although many other options are 11 | #' available. \code{bms} is a wrapper for \code{lca} and returns a model based 12 | #' on the Booth-Maindonald-Smith methodology. 13 | #' 14 | #' 15 | #' All mortality or fertility data are assumed to be in matrices of 16 | #' mortality or fertility rates within \code{data$rate}. Each row is one age group 17 | #' (assumed to be single years). Each column is one year. The 18 | #' function produces a model for the \code{series} mortality or fertility rate matrix 19 | #' within \code{data$rate}. Forecasts from this model can be obtained using \code{\link{forecast.lca}}. 20 | #' 21 | #' @param data demogdata object of type \dQuote{mortality} or 22 | #' \dQuote{fertility}. Output from read.demogdata. 23 | #' @param series name of series within data containing mortality or fertility 24 | #' values (1x1) 25 | #' @param years years to include in fit. Default: all available years. 26 | #' @param ages ages to include in fit. Default: all available ages up to 27 | #' \code{max.age}. 28 | #' @param max.age upper age to include in fit. Ages beyond this are collapsed 29 | #' into the upper age group. 30 | #' @param adjust method to use for adjustment of coefficients \eqn{k_t kt}. 31 | #' Possibilities are \dQuote{dxt} (BMS method), \dQuote{dt} (Lee-Carter 32 | #' method), \dQuote{e0} (method based on life expectancy) and \dQuote{none}. 33 | #' Defaults are \dQuote{dxt} for \code{bms()} and \dQuote{dt} for 34 | #' \code{lca()}. 35 | #' @param chooseperiod If TRUE, it will choose the best fitting period. 36 | #' @param minperiod Minimum number of years to include in fitting period if 37 | #' chooseperiod=TRUE. 38 | #' @param breakmethod method to use for identifying breakpoints if 39 | #' chooseperiod=TRUE. Possibilities are \dQuote{bai} (Bai's method computed 40 | #' using \code{\link[strucchange]{breakpoints}} in the strucchange package) 41 | #' and \dQuote{bms} (method based on mean deviance ratios described in BMS). 42 | #' @param scale If TRUE, it will rescale bx and kt so that kt has drift 43 | #' parameter = 1. 44 | #' @param restype method to use for calculating residuals. Possibilities are 45 | #' \dQuote{logrates}, \dQuote{rates} and \dQuote{deaths}. 46 | #' @param interpolate If TRUE, it will estimate any zero mortality or fertility 47 | #' rates using the same age group from nearby years. 48 | #' 49 | #' @return Object of class \dQuote{lca} with the following components: 50 | #' \item{label}{Name of region} 51 | #' \item{age}{Ages from \code{data} object.} 52 | #' \item{year}{Years from \code{data} object.} 53 | #' \item{}{Matrix of mortality or fertility data as contained in \code{data}. It takes the name given by the series argument.} 54 | #' \item{ax}{Average deathrates across fitting period} 55 | #' \item{bx}{First principal component in Lee-Carter model} 56 | #' \item{kt}{Coefficient of first principal component} 57 | #' \item{residuals}{Functional time series of residuals.} 58 | #' \item{fitted}{Functional time series containing estimated mortality or fertility rates from model} 59 | #' \item{varprop}{Proportion of variance explained by model.} 60 | #' \item{y}{The data stored as a functional time series object.} 61 | #' \item{mdev}{Mean deviance of total and base lack of fit, as described in Booth, Maindonald and Smith.} 62 | #' 63 | #' @references Booth, H., Maindonald, J., and Smith, L. (2002) Applying Lee-Carter 64 | #' under conditions of variable mortality decline. \emph{Population Studies}, \bold{56}, 325-336. 65 | #' 66 | #' Lee, R.D., and Carter, L.R. (1992) Modeling and forecasting US mortality. \emph{Journal of 67 | #' the American Statistical Association}, \bold{87}, 659-671. 68 | #' 69 | #' @author Heather Booth, Leonie Tickle, John Maindonald and Rob J Hyndman. 70 | #' 71 | #' @seealso \code{\link{forecast.lca}}, \code{\link{plot.lca}}, \code{\link{summary.lca}}, \code{\link{fdm}} 72 | #' @examples 73 | #' \dontrun{ 74 | #' france.LC1 <- lca(fr.mort, adjust = "e0") 75 | #' plot(france.LC1) 76 | #' par(mfrow = c(1, 2)) 77 | #' plot(fr.mort, years = 1953:2002, ylim = c(-11, 1)) 78 | #' plot(forecast(france.LC1, jumpchoice = "actual"), ylim = c(-11, 1)) 79 | #' 80 | #' france.bms <- bms(fr.mort, breakmethod = "bai") 81 | #' fcast.bms <- forecast(france.bms) 82 | #' par(mfrow = c(1, 1)) 83 | #' plot(fcast.bms$kt) 84 | #' } 85 | #' @keywords models 86 | #' @export 87 | lca <- function( 88 | data, series = names(data$rate)[1], years = data$year, ages = data$age, 89 | max.age = 100, adjust = c("dt", "dxt", "e0", "none"), 90 | chooseperiod = FALSE, minperiod = 20, breakmethod = c("bai", "bms"), 91 | scale = FALSE, restype = c("logrates", "rates", "deaths"), interpolate = FALSE) { 92 | if (!inherits(data, "demogdata")) { 93 | stop("Not demography data") 94 | } 95 | if (!any(data$type == c("mortality", "fertility"))) { 96 | stop("Neither mortality nor fertility data") 97 | } 98 | 99 | adjust <- match.arg(adjust) 100 | restype <- match.arg(restype) 101 | breakmethod <- match.arg(breakmethod) 102 | 103 | data <- extract.ages(data, ages, combine.upper = FALSE) 104 | if (max.age < max(ages)) { 105 | data <- extract.ages(data, min(ages):max.age, combine.upper = TRUE) 106 | } 107 | startage <- min(data$age) 108 | 109 | # Extract mortality rates and population numbers 110 | mx <- get.series(data$rate, series) 111 | pop <- get.series(data$pop, series) 112 | 113 | # Truncate years 114 | startyear <- min(years) 115 | stopyear <- max(years) 116 | if (startyear > max(data$year) | stopyear < min(data$year)) { 117 | stop("Year not found") 118 | } 119 | startyear <- max(startyear, min(data$year)) 120 | if (!is.null(stopyear)) { 121 | stopyear <- min(stopyear, max(data$year)) 122 | } else { 123 | stopyear <- max(data$year) 124 | } 125 | id2 <- stats::na.omit(match(startyear:stopyear, data$year)) 126 | 127 | mx <- mx[, id2] 128 | pop <- pop[, id2] 129 | year <- data$year[id2] 130 | deltat <- year[2] - year[1] 131 | ages <- data$age 132 | n <- length(ages) 133 | m <- length(year) 134 | mx <- matrix(mx, nrow = n, ncol = m) 135 | colnames(mx) <- year 136 | rownames(mx) <- ages 137 | 138 | # Interpolate where rates are zero 139 | if (interpolate) { 140 | # Remove missing values 141 | mx[is.na(mx)] <- 0 142 | if (sum(abs(mx) < 1e-9, na.rm = TRUE) > 0) { 143 | warning("Replacing zero values with estimates") 144 | for (i in 1:n) { 145 | mx[i, ] <- fill.zero(mx[i, ]) 146 | } 147 | } 148 | } 149 | 150 | # Transpose data and get deaths and logrates 151 | mx <- t(mx) 152 | mx[mx == 0] <- NA 153 | logrates <- log(mx) 154 | 155 | pop <- t(pop) 156 | deaths <- pop * mx 157 | 158 | # Do SVD 159 | ax <- apply(logrates, 2, mean, na.rm = TRUE) # ax is mean of logrates by column 160 | if (sum(ax < -1e9) > 0) { 161 | stop(sprintf("Some %s rates are zero.\n Try reducing the maximum age or setting interpolate=TRUE.", data$type)) 162 | } 163 | clogrates <- sweep(logrates, 2, ax) # central log rates (with ax subtracted) (dimensions m*n) 164 | svd.mx <- svd(clogrates) 165 | 166 | # Extract first principal component 167 | sumv <- sum(svd.mx$v[, 1]) 168 | bx <- svd.mx$v[, 1] / sumv 169 | kt <- svd.mx$d[1] * svd.mx$u[, 1] * sumv 170 | 171 | # Adjust kt 172 | ktadj <- rep(0, m) 173 | logdeathsadj <- matrix(NA, n, m) 174 | z <- log(t(pop)) + ax 175 | 176 | # Use regression to guess suitable range for root finding method 177 | x <- 1:m 178 | ktse <- stats::predict(stats::lm(kt ~ x), se.fit = TRUE)$se.fit 179 | ktse[is.na(ktse)] <- 1 180 | agegroup <- ages[4] - ages[3] 181 | 182 | if (adjust == "dxt") { 183 | options(warn = -1) # Prevent warnings on non-integer population values 184 | for (i in 1:m) 185 | { 186 | y <- as.numeric(deaths[i, ]) 187 | zi <- as.numeric(z[, i]) 188 | weight <- as.numeric(zi > -1e-8) # Avoid -infinity due to zero population 189 | yearglm <- stats::glm(y ~ offset(zi) - 1 + bx, family = stats::poisson, weights = weight) 190 | ktadj[i] <- yearglm$coef[1] 191 | logdeathsadj[, i] <- z[, i] + bx * ktadj[i] 192 | } 193 | options(warn = 0) 194 | } else if (adjust == "dt") { 195 | FUN <- function(p, Dt, bx, ax, popi) { 196 | Dt - sum(exp(p * bx + ax) * popi) 197 | } 198 | for (i in 1:m) 199 | { 200 | if (i == 1) { 201 | guess <- kt[1] 202 | } else { 203 | guess <- mean(c(ktadj[i - 1], kt[i])) 204 | } 205 | ktadj[i] <- findroot(FUN, guess = guess, margin = 3 * ktse[i], ax = ax, bx = bx, popi = pop[i, ], Dt = sum(as.numeric(deaths[i, ]))) 206 | logdeathsadj[, i] <- z[, i] + bx * ktadj[i] 207 | } 208 | } else if (adjust == "e0") { 209 | e0 <- apply(mx, 1, get.e0, agegroup = agegroup, sex = series, startage = startage) 210 | FUN2 <- function(p, e0i, ax, bx, agegroup, series, startage) { 211 | e0i - estimate.e0(p, ax, bx, agegroup, series, startage) 212 | } 213 | for (i in 1:m) 214 | { 215 | if (i == 1) { 216 | guess <- kt[1] 217 | } else { 218 | guess <- mean(c(ktadj[i - 1], kt[i])) 219 | } 220 | ktadj[i] <- findroot(FUN2, guess = guess, margin = 3 * ktse[i], e0i = e0[i], ax = ax, bx = bx, agegroup = agegroup, series = series, startage = startage) 221 | } 222 | } else if (adjust == "none") { 223 | ktadj <- kt 224 | } else { 225 | stop("Unknown adjustment method") 226 | } 227 | 228 | kt <- ktadj 229 | 230 | # Find linear section of kt and refit 231 | if (chooseperiod) { 232 | if (breakmethod == "bai") { 233 | x <- 1:m 234 | # Find breakpoints 235 | bp <- strucchange::breakpoints(kt ~ x)$breakpoints 236 | # Omit breakpoints less than minperiod from end 237 | bp <- bp[bp <= (m - minperiod)] 238 | bestbreak <- max(bp) 239 | return(lca(data, series, year[(bestbreak + 1):m], 240 | ages = ages, max.age = max.age, 241 | adjust = adjust, interpolate = interpolate, chooseperiod = FALSE, scale = scale 242 | )) 243 | } else { 244 | RS <- devlin <- devadd <- numeric(m - 2) 245 | for (i in 1:(m - 2)) 246 | { 247 | tmp <- lca(data, series, year[i:m], ages = ages, max.age = max.age, adjust = adjust, chooseperiod = FALSE, interpolate = interpolate, scale = scale) 248 | devlin[i] <- tmp$mdev[2] 249 | devadd[i] <- tmp$mdev[1] 250 | RS[i] <- (tmp$mdev[2] / tmp$mdev[1]) 251 | } 252 | bestbreak <- order(RS[1:(m - minperiod)])[1] - 1 253 | out <- lca(data, series, year[(bestbreak + 1):m], 254 | ages = ages, max.age = max.age, 255 | adjust = adjust, chooseperiod = FALSE, interpolate = interpolate, scale = scale 256 | ) 257 | out$mdevs <- ts(cbind(devlin, devadd, RS), start = startyear, deltat = deltat) 258 | dimnames(out$mdevs)[[2]] <- c("Mean deviance total", "Mean deviance base", "Mean deviance ratio") 259 | return(out) 260 | } 261 | } 262 | 263 | # Estimate rates from fitted values and get residuals 264 | logfit <- fitmx(kt, ax, bx, transform = TRUE) 265 | colnames(logfit) <- ages 266 | rownames(logfit) <- year 267 | if (restype == "logrates") { 268 | fit <- logfit 269 | res <- logrates - fit 270 | } else if (restype == "rates") { 271 | fit <- exp(logfit) 272 | res <- exp(logrates) - fit 273 | } else if (restype == "deaths") { 274 | fit <- exp(logfit) * pop 275 | res <- deaths - fit 276 | } 277 | residuals <- fts(ages, t(res), 278 | frequency = 1 / deltat, start = years[1], xname = "Age", 279 | yname = paste("Residuals", data$type, "rate") 280 | ) 281 | fitted <- fts(ages, t(fit), 282 | frequency = 1 / deltat, start = years[1], xname = "Age", 283 | yname = paste("Fitted", data$type, "rate") 284 | ) 285 | 286 | names(ax) <- names(bx) <- ages 287 | 288 | # Rescaling bx, kt 289 | if (scale) { 290 | avdiffk <- -mean(diff(kt)) 291 | bx <- bx * avdiffk 292 | kt <- kt / avdiffk 293 | } 294 | 295 | # Compute deviances 296 | deathsadjfit <- exp(logfit) * pop 297 | drift <- mean(diff(kt)) 298 | ktlinfit <- mean(kt) + drift * (1:m - (m + 1) / 2) 299 | deathslinfit <- fitmx(ktlinfit, ax, bx, transform = FALSE) * pop 300 | dflogadd <- (m - 2) * (n - 1) 301 | mdevlogadd <- 2 / dflogadd * sum(deaths * log(deaths / deathsadjfit) - (deaths - deathsadjfit)) 302 | dfloglin <- (m - 2) * n 303 | mdevloglin <- 2 / dfloglin * sum(deaths * log(deaths / deathslinfit) - (deaths - deathslinfit)) 304 | mdev <- c(mdevlogadd, mdevloglin) 305 | 306 | # Return 307 | output <- list( 308 | label = data$label, age = ages, year = year, mx = t(mx), 309 | ax = ax, bx = bx, kt = ts(kt, start = startyear, deltat = deltat), residuals = residuals, fitted = fitted, 310 | varprop = svd.mx$d[1]^2 / sum(svd.mx$d^2), 311 | y = fts(ages, t(mx), 312 | start = years[1], frequency = 1 / deltat, xname = "Age", 313 | yname = ifelse(data$type == "mortality", "Mortality", "Fertility") 314 | ), 315 | mdev = mdev 316 | ) 317 | names(output)[4] <- series 318 | output$call <- match.call() 319 | names(output$mdev) <- c("Mean deviance base", "Mean deviance total") 320 | output$adjust <- adjust 321 | output$type <- data$type 322 | return(structure(output, class = "lca")) 323 | } 324 | 325 | #' @rdname lca 326 | #' @export 327 | bms <- function( 328 | data, series = names(data$rate)[1], years = data$year, ages = data$age, 329 | max.age = 100, minperiod = 20, breakmethod = c("bms", "bai"), scale = FALSE, restype = c("logrates", "rates", "deaths"), 330 | interpolate = FALSE) { 331 | restype <- match.arg(restype) 332 | breakmethod <- match.arg(breakmethod) 333 | out <- lca(data, 334 | series = series, years = years, ages = ages, max.age = max.age, adjust = "dxt", 335 | chooseperiod = TRUE, minperiod = minperiod, scale = scale, restype = restype, breakmethod = breakmethod, 336 | interpolate = interpolate 337 | ) 338 | out$call <- match.call() 339 | return(out) 340 | } 341 | 342 | 343 | estimate.e0 <- function(kt, ax, bx, agegroup, series, startage = 0) { 344 | if (length(kt) > 1) { 345 | stop("Length of kt greater than 1") 346 | } 347 | mx <- c(fitmx(kt, ax, bx)) 348 | return(get.e0(mx, agegroup, series, startage = startage)) 349 | } 350 | 351 | fitmx <- function(kt, ax, bx, transform = FALSE) { 352 | # Derives mortality rates from kt mortality index, 353 | # per Lee-Carter method 354 | clogratesfit <- outer(kt, bx) 355 | logratesfit <- sweep(clogratesfit, 2, ax, "+") 356 | if (transform) { 357 | return(logratesfit) 358 | } else { 359 | return(exp(logratesfit)) 360 | } 361 | } 362 | 363 | #' @rdname plot.fmforecast 364 | #' @export 365 | plot.lca <- function(x, ...) { 366 | x$basis <- cbind(x$ax, x$bx) 367 | x$coeff <- cbind(rep(1, length(x$kt)), x$kt) 368 | colnames(x$basis) <- c("mean", "bx") 369 | if (x$adjust != "none") { 370 | xlab <- "kt (adjusted)" 371 | } else { 372 | xlab <- "kt" 373 | } 374 | ftsa::plot.ftsm(x, 1, xlab1 = "Age", ylab1 = "bx", xlab2 = "Year", ylab2 = xlab, mean.lab = "ax", ...) 375 | } 376 | 377 | #' @export 378 | print.lca <- function(x, ...) { 379 | cat("Lee-Carter analysis\n") 380 | cat(paste("\nCall:", deparse(x$call), "\n")) 381 | cat(paste("\nAdjustment method:", x$adjust)) 382 | cat(paste("\nRegion:"), x$label) 383 | cat(paste("\nYears in fit:", min(x$year), "-", max(x$year))) 384 | cat(paste("\nAges in fit:", min(x$age), "-", max(x$age), "\n")) 385 | cat(paste("\nPercentage variation explained: ", round(x$varprop * 100, 1), "%\n", sep = "")) 386 | } 387 | 388 | #' @rdname summary.fdm 389 | #' @export 390 | summary.lca <- function(object, ...) { 391 | print(object) 392 | 393 | cat(sprintf("\nERROR MEASURES BASED ON %s RATES\n", toupper(object$type))) 394 | printout(fdmMISE(object[[4]], exp(object$fitted$y), age = object$y$x, years = object$year)) 395 | 396 | cat(sprintf("\nERROR MEASURES BASED ON LOG %s RATES\n", toupper(object$type))) 397 | printout(fdmMISE(log(object[[4]]), object$fitted$y, age = object$y$x, years = object$year)) 398 | } 399 | 400 | 401 | printout <- function(output) { 402 | junk1 <- cbind(output$ME, output$MSE, output$MPE, output$MAPE) 403 | rownames(junk1) <- output$age 404 | colnames(junk1) <- c("ME", "MSE", "MPE", "MAPE") 405 | junk2 <- cbind(output$MIE, output$MISE, output$MIPE, output$MIAPE) 406 | rownames(junk2) <- output$year 407 | colnames(junk2) <- c("IE", "ISE", "IPE", "IAPE") 408 | cat(paste("\nAverages across ages:\n")) 409 | print(round(apply(junk1, 2, mean), 5)) 410 | cat(paste("\nAverages across years:\n")) 411 | print(round(apply(junk2, 2, mean), 5)) 412 | cat("\n") 413 | } 414 | 415 | # Function performs predictions of k and life expectancy based on leecarter results (in lcaout) 416 | 417 | #' Forecast demogdata data using Lee-Carter method. 418 | #' 419 | #' The kt coefficients are forecast using a random walk with drift. 420 | #' The forecast coefficients are then multiplied by bx to 421 | #' obtain a forecast demographic rate curve. 422 | #' 423 | #' @param object Output from \code{\link{lca}}. 424 | #' @param h Number of years ahead to forecast. 425 | #' @param se Method used for computation of standard error. Possibilities: \dQuote{innovdrift} (innovations and drift) and \dQuote{innovonly} (innovations only). 426 | #' @param jumpchoice Method used for computation of jumpchoice. Possibilities: \dQuote{actual} (use actual rates from final year) and \dQuote{fit} (use fitted rates). 427 | #' @param level Confidence level for prediction intervals. 428 | #' @param ... Other arguments. 429 | #' 430 | #' @return Object of class \code{fmforecast} with the following components: 431 | #' \item{label}{Region from which the data are taken.} 432 | #' \item{age}{Ages from \code{object}.} 433 | #' \item{year}{Years from \code{object}.} 434 | #' \item{rate}{List of matrices containing forecasts, lower bound and upper bound of prediction intervals. 435 | #' Point forecast matrix takes the same name as the series that has been forecast.} 436 | #' \item{fitted}{Matrix of one-step forecasts for historical data} 437 | #' Other components included are 438 | #' \item{e0}{Forecasts of life expectancies (including lower and upper bounds)} 439 | #' \item{kt.f}{Forecasts of coefficients from the model.} 440 | #' \item{type}{Data type.} 441 | #' \item{model}{Details about the fitted model} 442 | #' 443 | #' @author Rob J Hyndman 444 | #' @seealso \code{\link{lca}}, \code{\link{plot.fmforecast}} 445 | #' @examples 446 | #' france.lca <- lca(fr.mort, adjust = "e0") 447 | #' france.fcast <- forecast(france.lca, 50) 448 | #' plot(france.fcast) 449 | #' plot(france.fcast, "c") 450 | #' @keywords models 451 | #' @export 452 | forecast.lca <- function(object, h = 50, se = c("innovdrift", "innovonly"), jumpchoice = c("fit", "actual"), level = 80, ...) { 453 | se <- match.arg(se) 454 | jumpchoice <- match.arg(jumpchoice) 455 | 456 | # Section 1 Read in data from object 457 | jumpyear <- max(object$year) 458 | nyears <- length(object$year) 459 | nages <- length(object$age) 460 | 461 | # Find jumprates 462 | if (jumpchoice == "actual") { 463 | jumprates <- object[[4]][, nyears] 464 | } else if (jumpchoice == "fit") { 465 | jumprates <- exp(object$ax + object$bx * object$kt[nyears]) 466 | } else { 467 | stop(paste("Unknown jump choice:", jumpchoice)) 468 | } 469 | object$kt <- object$kt - object$kt[nyears] 470 | 471 | # Time series estimation of kt as Random walk with drift 472 | fit <- forecast::rwf(object$kt, drift = TRUE) 473 | kt.drift <- fit$model$par$drift 474 | sec <- fit$model$par$drift.se 475 | see <- sqrt(fit$model$sigma2) 476 | 477 | # Project kt 478 | x <- 1:h 479 | zval <- stats::qnorm(0.5 + 0.005 * level) 480 | kt.forecast <- object$kt[nyears] + (x * kt.drift) 481 | 482 | # Calculate standard errors of forecast kt 483 | if (se == "innovdrift") { 484 | kt.stderr <- sqrt(x * (see^2) + (x * sec)^2) 485 | } else if (se == "innovonly") { 486 | kt.stderr <- sqrt(x * (see^2)) 487 | } 488 | kt.lo.forecast <- kt.forecast - (zval * kt.stderr) 489 | kt.hi.forecast <- kt.forecast + (zval * kt.stderr) 490 | kt.f <- data.frame(kt.forecast, kt.lo.forecast, kt.hi.forecast) 491 | names(kt.f) <- c("kt forecast", "kt lower", "kt upper") 492 | deltat <- object$year[2] - object$year[1] 493 | kt.f <- ts(kt.f, start = object$year[nyears] + deltat, deltat = deltat) 494 | 495 | # Calculate expected life and mx forecasts 496 | e0.forecast <- rep(0, h) 497 | mx.forecast <- matrix(0, nrow = nages, ncol = h) 498 | colnames(mx.forecast) <- seq(h) 499 | rownames(mx.forecast) <- object$age 500 | mx.lo.forecast <- mx.hi.forecast <- mx.forecast 501 | logjumprates <- log(jumprates) 502 | series <- names(object)[4] 503 | agegroup <- object$age[4] - object$age[3] 504 | for (cnt in 1:h) 505 | { 506 | mx.forecast[, cnt] <- fitmx(kt.f[cnt, 1], logjumprates, object$bx) 507 | mx.lo.forecast[, cnt] <- fitmx(kt.f[cnt, 2], logjumprates, object$bx) 508 | mx.hi.forecast[, cnt] <- fitmx(kt.f[cnt, 3], logjumprates, object$bx) 509 | e0.forecast[cnt] <- get.e0(mx.forecast[, cnt], agegroup, series, startage = min(object$age)) 510 | } 511 | kt.f <- data.frame(kt.forecast, kt.lo.forecast, kt.hi.forecast) 512 | names(kt.f) <- c("kt forecast", "kt lower", "kt upper") 513 | kt.f <- ts(kt.f, start = object$year[nyears] + deltat, deltat = deltat) 514 | 515 | output <- list( 516 | label = object$label, age = object$age, year = object$year[nyears] + x * deltat, 517 | rate = list(forecast = mx.forecast, lower = mx.lo.forecast, upper = mx.hi.forecast), 518 | fitted = object$fitted, 519 | e0 = ts(e0.forecast, start = object$year[nyears] + deltat, deltat = deltat), 520 | kt.f = structure(list( 521 | mean = kt.f[, 1], lower = kt.f[, 2], upper = kt.f[, 3], level = level, x = object$kt, 522 | method = "Random walk with drift" 523 | ), class = "forecast"), 524 | type = object$type, lambda = 0 525 | ) 526 | names(output$rate)[1] <- names(object)[4] 527 | output$model <- object 528 | output$model$jumpchoice <- jumpchoice 529 | output$model$jumprates <- jumprates 530 | output$call <- match.call() 531 | output$name <- names(object)[4] 532 | return(structure(output, class = c("fmforecast", "demogdata"))) 533 | } 534 | 535 | #' @rdname residuals.fdm 536 | #' @export 537 | fitted.lca <- function(object, ...) { 538 | object$fitted 539 | } 540 | 541 | #' @rdname residuals.fdm 542 | #' @export 543 | residuals.lca <- function(object, ...) { 544 | return(structure(list(x = object$year, y = object$age, z = t(object$residuals$y)), class = "fmres")) 545 | } 546 | 547 | 548 | findroot <- function(FUN, guess, margin, try = 1, ...) { 549 | # First try in successively larger intervals around best guess 550 | for (i in 1:5) 551 | { 552 | rooti <- try(stats::uniroot(FUN, interval = guess + i * margin / 3 * c(-1, 1), ...), silent = TRUE) 553 | if (!inherits(rooti, "try-error")) { 554 | return(rooti$root) 555 | } 556 | } 557 | # No luck. Try really big intervals 558 | rooti <- try(stats::uniroot(FUN, interval = guess + 10 * margin * c(-1, 1), ...), silent = TRUE) 559 | if (!inherits(rooti, "try-error")) { 560 | return(rooti$root) 561 | } 562 | 563 | # Still no luck. Try guessing root using quadratic approximation 564 | if (try < 3) { 565 | root <- try(quadroot(FUN, guess, 10 * margin, ...), silent = TRUE) 566 | if (!inherits(root, "try-error")) { 567 | return(findroot(FUN, root, margin, try + 1, ...)) 568 | } 569 | root <- try(quadroot(FUN, guess, 20 * margin, ...), silent = TRUE) 570 | if (!inherits(root, "try-error")) { 571 | return(findroot(FUN, root, margin, try + 1, ...)) 572 | } 573 | } 574 | 575 | # Finally try optimization 576 | root <- try(newroot(FUN, guess, ...), silent = TRUE) 577 | if (!inherits(root, "try-error")) { 578 | return(root) 579 | } else { 580 | root <- try(newroot(FUN, guess - margin, ...), silent = TRUE) 581 | } 582 | if (!inherits(root, "try-error")) { 583 | return(root) 584 | } else { 585 | root <- try(newroot(FUN, guess + margin, ...), silent = TRUE) 586 | } 587 | if (!inherits(root, "try-error")) { 588 | return(root) 589 | } else { 590 | stop("Unable to find root") 591 | } 592 | } 593 | 594 | quadroot <- function(FUN, guess, margin, ...) { 595 | x1 <- guess - margin 596 | x2 <- guess + margin 597 | y1 <- FUN(x1, ...) 598 | y2 <- FUN(x2, ...) 599 | y0 <- FUN(guess, ...) 600 | if (is.na(y1) | is.na(y2) | is.na(y0)) { 601 | stop("Function not defined on interval") 602 | } 603 | b <- 0.5 * (y2 - y1) / margin 604 | a <- (0.5 * (y1 + y2) - y0) / (margin^2) 605 | tmp <- b^2 - 4 * a * y0 606 | if (tmp < 0) { 607 | stop("No real root") 608 | } 609 | tmp <- sqrt(tmp) 610 | r1 <- 0.5 * (tmp - b) / a 611 | r2 <- 0.5 * (-tmp - b) / a 612 | if (abs(r1) < abs(r2)) { 613 | root <- guess + r1 614 | } else { 615 | root <- guess + r2 616 | } 617 | return(root) 618 | } 619 | 620 | # Try finding root using minimization 621 | newroot <- function(FUN, guess, ...) { 622 | fred <- function(x, ...) { 623 | (FUN(x, ...)^2) 624 | } 625 | junk <- stats::nlm(fred, guess, ...) 626 | if (abs(junk$minimum) / fred(guess, ...) > 1e-6) { 627 | warning("No root exists. Returning closest") 628 | } 629 | return(junk$estimate) 630 | } 631 | 632 | 633 | # Replace zeros with interpolated values 634 | fill.zero <- function(x, method = "constant") { 635 | tt <- 1:length(x) 636 | zeros <- abs(x) < 1e-9 637 | xx <- x[!zeros] 638 | tt <- tt[!zeros] 639 | x <- stats::approx(tt, xx, 1:length(x), method = method, f = 0.5, rule = 2) 640 | return(x$y) 641 | } 642 | --------------------------------------------------------------------------------