dev/LIFIT.R

# Author: tim
###############################################################################

# function design based on Computer programs for demographic analysis 
# Eduardo Arriaga, Patricia Anderson, Larry Heligman.
# Washington : U.S. Dept. of Commerce, Bureau of the Census, International Statistical Programs
# Center, 1976.

#' mean absolute difference in survival rates
#' 
#' @description Take two survival curves, use them to calculate 5-year survival 
#' ratios, then take the mean absolute difference between these, with optional age trimming. 
#' Based on LIFIT program from the MPCDA code base.
#' 
#' @param lx1 numeric vector. The first survival function, any radix size
#' @param lx2 numeric vector. The second survival function, any radix size
#' @param Age1 integer vector. The age groups (lower bound) corresponding to \code{lx1}
#' @param Age2 integer vector. The age groups (lower bound) corresponding to \code{lx2}
#' @param ageMin integer. Optional lower age bound for calcs
#' @param ageMax integer. Optional upper age bound for calcs
#' @return the mean absolute difference in survival ratios
#' @export
#' @details \code{lx1} and \code{lx2} can be of different lengths, and needn't have identically 
#' grouped data. For example, either or both input vectors could be in single or five-year age groups
#' for this function. Results are selected internally for 5-year age groups, and vector lengths are matched.
#' The input vectors can also be of different lifetable radices. As with the original Fortran code, 
#' the open age group must be included in input vectors, even though it is not included in calcs. 
#' If your final age group is not open, then tack an extra element to it to simulate an open element,
#' and just make sure to match ages.
#' @references
#' Eduardo Arriaga, Patricia Anderson, Larry Heligman (1976). Computer programs for demographic analysis
#' Washington : U.S. Dept. of Commerce, Bureau of the Census, International Statistical Programs
#' Center.
#' 
#' @examples 
#' lx1 <-c(1, 0.94265, 0.93344, 0.92708, 0.923, 0.92023, 0.91796, 0.91601, 
#'		0.91431, 0.9128, 0.91145, 0.91025, 0.90914, 0.90805, 0.90692, 
#'		0.90566, 0.90419, 0.90251, 0.90063, 0.89858, 0.89642, 0.89417, 
#'		0.8918, 0.88923, 0.88647, 0.88356, 0.88046, 0.87721, 0.87386, 
#'		0.87047, 0.86706, 0.8636, 0.86008, 0.85649, 0.85276, 0.84882, 
#'		0.84465, 0.84027, 0.8357, 0.83102, 0.8264, 0.82193, 0.8175, 0.81296, 
#'		0.80827, 0.80343, 0.79845, 0.79329, 0.78788, 0.78218, 0.77617, 
#'		0.76982, 0.76309, 0.75596, 0.74837, 0.74029, 0.73182, 0.72307, 
#'		0.71396, 0.70434, 0.69402, 0.68295, 0.67102, 0.6581, 0.64442, 
#'		0.63012, 0.61486, 0.59811, 0.57943, 0.55896, 0.53739, 0.51528, 
#'		0.49248, 0.46826, 0.44272, 0.41631, 0.38876, 0.36037, 0.33157, 
#'		0.30217, 0.27334, 0.24599, 0.21948, 0.19412, 0.17029, 0.14826, 
#'		0.12771, 0.10909, 0.09241, 0.07763, 0.0647, 0.05363, 0.04403, 
#'		0.03578, 0.02877, 0.02289, 0.018, 0.01399, 0.01075, 0.00815, 
#'		0.0061, 0.00451, 0.00329, 0.00236, 0.00168, 0.00117, 0.00081, 
#'		0.00055, 0.00036, 0.00024, 0.00015)
#'lx2 <- c(1, 0.99361, 0.99315, 0.99284, 0.99264, 0.99246, 0.9923, 0.99216, 
#'		0.99201, 0.99189, 0.99176, 0.99164, 0.99149, 0.99135, 0.99118, 
#'		0.99096, 0.99069, 0.99033, 0.98993, 0.98946, 0.98902, 0.98857, 
#'		0.98809, 0.98763, 0.98717, 0.98672, 0.98623, 0.98574, 0.98521, 
#'		0.98468, 0.9841, 0.98351, 0.98285, 0.98213, 0.98134, 0.9805, 
#'		0.97959, 0.9786, 0.97748, 0.97628, 0.97495, 0.97353, 0.97197, 
#'		0.97032, 0.96847, 0.96655, 0.96443, 0.96225, 0.95984, 0.95724, 
#'		0.95446, 0.95142, 0.94822, 0.94469, 0.94058, 0.93651, 0.93187, 
#'		0.92678, 0.92112, 0.91508, 0.90846, 0.90128, 0.89336, 0.88466, 
#'		0.87543, 0.86532, 0.85442, 0.84265, 0.82993, 0.81641, 0.80212, 
#'		0.78656, 0.77024, 0.75237, 0.73333, 0.71304, 0.69102, 0.66797, 
#'		0.64371, 0.61749, 0.58998, 0.55953, 0.52836, 0.49505, 0.46051, 
#'		0.42472, 0.38756, 0.34995, 0.31203, 0.27485, 0.23825, 0.20292, 
#'		0.16979, 0.13867, 0.11131, 0.08713, 0.06679, 0.04989, 0.03626, 
#'		0.02561, 0.01755, 0.01165, 0.00749, 0.00466, 0.00281, 0.00163, 
#'		0.00092, 5e-04, 0.00026, 0.00013, 7e-05)
#' ADM(lx1,lx2, 0:110)
#' ADM(lx1,lx2,0:110,ageMax = 80)
ADM <- function(
		lx1, 
		lx2, 
		Age1, 
		Age2 = Age1, 
		ageMin = max(c(min(Age1),min(Age2))), 
		ageMax = min(c(max(Age1), max(Age2)))){
	
    stopifnot(length(lx1) == length(Age1))
    stopifnot(length(lx2) == length(Age2))
	
	# remove open age group
	n1     <- length(lx1)
	n2     <- length(lx2)
	lx1    <- lx1[-n1]
	lx2    <- lx2[-n2]
	Age1   <- Age1[-n1]
	Age2   <- Age2[-n2]
	
	# ages in common only
	age5   <- AGEN(
			    Age1, 
			    Age2, 
			    N = 5, 
			    consecutive = TRUE, 
			    ageMin = ageMin, 
			    ageMax = ageMax - 1)
	# trim lx to needed ages
	lx1_5  <- lx1[Age1 %in% age5]
	lx2_5  <- lx2[Age2 %in% age5]
	
	# survivor ratios
	Sx1    <- ratx(lx1_5)
	Sx2    <- ratx(lx2_5)
	
	# absolute differences
	AD     <- Sx1 - Sx2
	
	# mean absolute difference
	mean(abs(AD))
}

#' mean absolute difference in age-ratios of survival rates
#' 
#' @description Take two survival curves, use them to calculate 5-year survival 
#' ratios, then again take the consecutive age-ratios of these. Finally, take the 
#' mean absolute difference between ratios, with optional age trimming. 
#' Based on LIFIT program from the MPCDA code base.
#' 
#' @param lx1 numeric vector. The first survival function, any radix size
#' @param lx2 numeric vector. The second survival function, any radix size
#' @param Age1 integer vector. The age groups (lower bound) corresponding to \code{lx1}
#' @param Age2 integer vector. The age groups (lower bound) corresponding to \code{lx2}
#' @param ageMin integer. Optional lower age bound for calcs
#' @param ageMax integer. Optional upper age bound for calcs
#' @return the mean absolute difference in survival ratios
#' @export
#' @details \code{lx1} and \code{lx2} can be of different lengths, and needn't have identically 
#' grouped data. For example, either or both input vectors could be in single or five-year age groups
#' for this function. Results are selected internally for 5-year age groups, and vector lengths are matched.
#' The input vectors can also be of different lifetable radices. As with the original Fortran code, 
#' the open age group must be included in input vectors, even though it is not included in calcs. 
#' If your final age group is not open, then tack an extra element to it to simulate an open element,
#' and just make sure to match ages.
#' @references
#' Eduardo Arriaga, Patricia Anderson, Larry Heligman (1976). Computer programs for demographic analysis
#' Washington : U.S. Dept. of Commerce, Bureau of the Census, International Statistical Programs
#' Center.
#' @examples 
#' lx1 <-c(1, 0.94265, 0.93344, 0.92708, 0.923, 0.92023, 0.91796, 0.91601, 
#'		0.91431, 0.9128, 0.91145, 0.91025, 0.90914, 0.90805, 0.90692, 
#'		0.90566, 0.90419, 0.90251, 0.90063, 0.89858, 0.89642, 0.89417, 
#'		0.8918, 0.88923, 0.88647, 0.88356, 0.88046, 0.87721, 0.87386, 
#'		0.87047, 0.86706, 0.8636, 0.86008, 0.85649, 0.85276, 0.84882, 
#'		0.84465, 0.84027, 0.8357, 0.83102, 0.8264, 0.82193, 0.8175, 0.81296, 
#'		0.80827, 0.80343, 0.79845, 0.79329, 0.78788, 0.78218, 0.77617, 
#'		0.76982, 0.76309, 0.75596, 0.74837, 0.74029, 0.73182, 0.72307, 
#'		0.71396, 0.70434, 0.69402, 0.68295, 0.67102, 0.6581, 0.64442, 
#'		0.63012, 0.61486, 0.59811, 0.57943, 0.55896, 0.53739, 0.51528, 
#'		0.49248, 0.46826, 0.44272, 0.41631, 0.38876, 0.36037, 0.33157, 
#'		0.30217, 0.27334, 0.24599, 0.21948, 0.19412, 0.17029, 0.14826, 
#'		0.12771, 0.10909, 0.09241, 0.07763, 0.0647, 0.05363, 0.04403, 
#'		0.03578, 0.02877, 0.02289, 0.018, 0.01399, 0.01075, 0.00815, 
#'		0.0061, 0.00451, 0.00329, 0.00236, 0.00168, 0.00117, 0.00081, 
#'		0.00055, 0.00036, 0.00024, 0.00015)
#'lx2 <- c(1, 0.99361, 0.99315, 0.99284, 0.99264, 0.99246, 0.9923, 0.99216, 
#'		0.99201, 0.99189, 0.99176, 0.99164, 0.99149, 0.99135, 0.99118, 
#'		0.99096, 0.99069, 0.99033, 0.98993, 0.98946, 0.98902, 0.98857, 
#'		0.98809, 0.98763, 0.98717, 0.98672, 0.98623, 0.98574, 0.98521, 
#'		0.98468, 0.9841, 0.98351, 0.98285, 0.98213, 0.98134, 0.9805, 
#'		0.97959, 0.9786, 0.97748, 0.97628, 0.97495, 0.97353, 0.97197, 
#'		0.97032, 0.96847, 0.96655, 0.96443, 0.96225, 0.95984, 0.95724, 
#'		0.95446, 0.95142, 0.94822, 0.94469, 0.94058, 0.93651, 0.93187, 
#'		0.92678, 0.92112, 0.91508, 0.90846, 0.90128, 0.89336, 0.88466, 
#'		0.87543, 0.86532, 0.85442, 0.84265, 0.82993, 0.81641, 0.80212, 
#'		0.78656, 0.77024, 0.75237, 0.73333, 0.71304, 0.69102, 0.66797, 
#'		0.64371, 0.61749, 0.58998, 0.55953, 0.52836, 0.49505, 0.46051, 
#'		0.42472, 0.38756, 0.34995, 0.31203, 0.27485, 0.23825, 0.20292, 
#'		0.16979, 0.13867, 0.11131, 0.08713, 0.06679, 0.04989, 0.03626, 
#'		0.02561, 0.01755, 0.01165, 0.00749, 0.00466, 0.00281, 0.00163, 
#'		0.00092, 5e-04, 0.00026, 0.00013, 7e-05)
#' RDM(lx1, lx2, 0:110)
#' RDM(lx1, lx2, 0:110, ageMax = 80)
RDM <- function(
		lx1, 
		lx2, 
		Age1, 
		Age2 = Age1, 
		ageMin = max(c(min(Age1),min(Age2))), 
		ageMax = min(c(max(Age1), max(Age2)))){
	stopifnot(length(lx1) == length(Age1))
	stopifnot(length(lx2) == length(Age2))
	
	# remove open age group
	n1     <- length(lx1)
	n2     <- length(lx2)
	lx1    <- lx1[-n1]
	lx2    <- lx2[-n2]
	Age1   <- Age1[-n1]
	Age2   <- Age2[-n2]
	
	# ages in common only
	age5   <- AGEN(
				Age1, 
				Age2, 
				N = 5, 
				consecutive = TRUE, 
				ageMin = ageMin, 
				ageMax = ageMax)
	# select only needed lx
	lx1_5  <- lx1[Age1 %in% age5]
	lx2_5  <- lx2[Age2 %in% age5]
	
	# survivor ratios
	Sx1    <- ratx(lx1_5)
	Sx2    <- ratx(lx2_5)
	
	# ratios of the ratios
	Rx1    <- ratx(Sx1)
	Rx2    <- ratx(Sx2)
	
	# differences of ratio ratios
	RD     <- Rx1 - Rx2
	
	# mean absolute difference
	mean(abs(RD))
}
timriffe/DemoTools documentation built on Oct. 14, 2024, 12:53 p.m.