diff --git a/R/analytical_functions.R b/R/analytical_functions.R index c1973da..b89d262 100644 --- a/R/analytical_functions.R +++ b/R/analytical_functions.R @@ -43,6 +43,13 @@ #' #' Default setup is 1/3 for every age class <= 5 life years, and 1/2 for the others. #' +#' @param option_spline integer, optional. If > 0, values for adults will be +#' interpolated by a monotonic cubic spline. Usual options will by '10' or '20' which +#' will interpolate the values for individuals of an age of 20 or older by 10- or 20- +#' year cumulated values. To be used carefully, as diagnostic features of the life +#' table might be smoothed and essentially removed. Only available when the methods +#' 'Standard' or 'Equal5' in prep.life.table have been chosen. +#' #' @return #' An object of class mortaar_life_table or mortaar_life_table_list. #' Each mortaar_life_table contains the following variables: @@ -125,7 +132,7 @@ #' @importFrom Rdpack reprompt #' #' @export -life.table <- function(neclist, agecor = TRUE, agecorfac = c()) { +life.table <- function(neclist, agecor = TRUE, agecorfac = c(), option_spline = NULL) { # Check if the input list is a data.frame, if so, it is # packed into a list. @@ -138,7 +145,7 @@ life.table <- function(neclist, agecor = TRUE, agecorfac = c()) { okvars <- c("x", "a", "Dx") # Check the input. - inputchecks(neclist, okvars) + inputchecks(neclist, okvars, option_spline) # Apply life.table.vec to every column of the input df # and create an output mortaar_life_table_list of @@ -150,7 +157,7 @@ life.table <- function(neclist, agecor = TRUE, agecorfac = c()) { lapply(., function(necdf) { vars <- colnames(necdf)[colnames(necdf) %in% okvars] life.table.df( - necdf[,vars], agecor = agecor, agecorfac = agecorfac) + necdf[,vars], agecor = agecor, agecorfac = agecorfac, option_spline = option_spline) } ) %>% `class<-`(c("mortaar_life_table_list", class(.))) -> res @@ -159,7 +166,7 @@ life.table <- function(neclist, agecor = TRUE, agecorfac = c()) { necdf <- neclist[[1]] vars <- colnames(necdf)[colnames(necdf) %in% okvars] life.table.df( - necdf[,vars], agecor = agecor, agecorfac = agecorfac + necdf[,vars], agecor = agecor, agecorfac = agecorfac, option_spline = option_spline ) -> res } @@ -174,7 +181,9 @@ life.table <- function(neclist, agecor = TRUE, agecorfac = c()) { return(res) } -inputchecks <- function(neclist, okvars) { +#### input checks #### + +inputchecks <- function(neclist, okvars, option_spline) { # Checks if the input is a list. if (neclist %>% is.list %>% `!`) { @@ -242,9 +251,40 @@ inputchecks <- function(neclist, okvars) { ) %>% warning } + # Checks if the special conditions for the option_spline are met + if (length(option_spline) > 0) { + + option_spline_test <- function(necdf) { + unique_a <- c(unique(necdf['a'])) + unique_a <- unlist(unique_a$a) + return( + !(((length(unique_a) == 1) & (5 %in% unique_a)) || ( + (length(unique_a) == 3) & ( + (5 %in% unique_a[3]) & + (4 %in% unique_a[2]) & + (1 %in% unique_a[1]) + ) + ) + )) + } + + if (neclist %>% lapply(option_spline_test) %>% unlist %>% any) { + paste0( + "One of your data.frames does not fulfill the conditions for the spline ", + "creation option. ", + "Spline-interpolation works only with 5-year-age classes (or 1- and ", + "4-year classes for the first 5 years). Please take a look at ?life.table ", + "to determine how your input data should look like." + ) %>% stop + } + + } + } -life.table.df <- function(necdf, agecor = TRUE, agecorfac = c()) { +#### core algorithm #### + +life.table.df <- function(necdf, agecor = TRUE, agecorfac = c(), option_spline = NULL) { # x: well readable rownames for age classes. limit <- necdf['a'] %>% sum @@ -269,12 +309,15 @@ life.table.df <- function(necdf, agecor = TRUE, agecorfac = c()) { ) } - # dx: proportion of deaths within x. - necdf['dx'] <- necdf['Dx'] / sum(necdf['Dx']) * 100 + # in case of spline-interpolation, dx-values will be replaced with interpolated once + if (!(length(option_spline) > 0)) { + necdf['dx'] <- dx_default(necdf[['Dx']]) + } else { + necdf['dx'] <- dx_spline(necdf[['a']], necdf[['Dx']], limit, option_spline) + } # lx: proportion of survivorship within x. - necdf['lx'] <- c(100, 100 - cumsum(necdf[, 'dx']) - )[1:nrow(necdf)] + necdf['lx'] <- c(100, 100 - cumsum(necdf[, 'dx']))[1:nrow(necdf)] # qx: probability of death within x. necdf['qx'] <- necdf['dx'] / necdf['lx'] * 100 @@ -349,3 +392,50 @@ life.table.df <- function(necdf, agecor = TRUE, agecorfac = c()) { `class<-`(c("mortaar_life_table", class(.))) %>% return() } + +#### helper functions #### + +## dx ## +dx_default <- function(Dx) { + Dx / sum(Dx) * 100 +} + +dx_spline <- function(a, Dx, limit, option_spline) { + + working_data <- data.frame( + id = 1:length(a), + a = a, + Dx = Dx, + a_cumsum = a %>% cumsum, + dx_default = Dx %>% dx_default + ) + + repeat_number <- floor((limit - 20) / option_spline) + + a_cumsum_select <- working_data$id[which(working_data$a_cumsum <= 20)] + for (t in 1:repeat_number) { + a_cumsum_select <- c(a_cumsum_select, (working_data$id[which(working_data$a_cumsum == (20 + (t * option_spline)))])) + } + if (((limit - 20) / option_spline) - floor((limit - 20) / option_spline) > 0) { + a_cumsum_select <- c(a_cumsum_select, working_data$id[length(a)]) + } + + x_spline <- working_data$a_cumsum[a_cumsum_select] + dx_cumsum <- c(cumsum(working_data$dx_default))[1:length(a)] + y_spline <- dx_cumsum[a_cumsum_select] + + # interpolating the values with a monotonic cubic spline + dem <- stats::spline(x_spline, y_spline, n = (limit/5 + 1), xmin = 0, xmax = limit, method = "hyman") + + # the first value of the interpolation has to be discarded and replaced + if (length(a) < length(dem$y)) { + dem_dx <- dem$y[c(-1)] + } else { + dem_dx <- c(working_data$dx_default[1], dem$y[c(-1)]) + } + + dx_approx <- dem_dx - c(0, dem_dx[-length(a)]) + + return(dx_approx) + +} diff --git a/man/life.table.Rd b/man/life.table.Rd index 95cdd10..819b4c6 100644 --- a/man/life.table.Rd +++ b/man/life.table.Rd @@ -4,7 +4,8 @@ \alias{life.table} \title{Calculates a life table} \usage{ -life.table(neclist, agecor = TRUE, agecorfac = c()) +life.table(neclist, agecor = TRUE, agecorfac = c(), + option_spline = NULL) } \arguments{ \item{neclist}{single data.frame or list of data.frames @@ -28,6 +29,13 @@ Default setup is: TRUE.} replace the standard values from the first age interval onward. Default setup is 1/3 for every age class <= 5 life years, and 1/2 for the others.} + +\item{option_spline}{integer, optional. If > 0, values for adults will be +interpolated by a monotonic cubic spline. Usual options will by '10' or '20' which +will interpolate the values for individuals of an age of 20 or older by 10- or 20- +year cumulated values. To be used carefully, as diagnostic features of the life +table might be smoothed and essentially removed. Only available when the methods +'Standard' or 'Equal5' in prep.life.table have been chosen.} } \value{ An object of class mortaar_life_table or mortaar_life_table_list.