Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Added monotonic spline-function for dx-values. #43

Merged
merged 7 commits into from
Jul 29, 2019
Merged

Added monotonic spline-function for dx-values. #43

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
7 commits
Select commit Hold shift + click to select a range
6030f00
Added monotonic spline-function for dx-values.
nmueller18 Jul 7, 2019
e622b2b
Removed dependency of package "demography" as suggested
nmueller18 Jul 9, 2019
854c221
Spline-option now refactored and check added for making sure that onl…
nmueller18 Jul 14, 2019
545e6a9
some refactoring
nevrome Jul 21, 2019
e76d717
Made a small change in the variable naming, and the function seems to…
nmueller18 Jul 21, 2019
1fb767b
Merge pull request #44 from ISAAKiel/dx_spline_slightly_changed
nevrome Jul 27, 2019
b288a98
implemented option_spline test a bit more elegant
nevrome Jul 27, 2019
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 2 additions & 1 deletion DESCRIPTION
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -27,7 +27,8 @@ Imports:
magrittr (>= 1.5),
Rdpack (>= 0.4-20),
reshape2 (>= 1.4.2),
methods (>= 3.3.3)
methods (>= 3.3.3),
demography (>= 1.22)
RoxygenNote: 6.1.1
Suggests:
testthat,
Expand Down
1 change: 1 addition & 0 deletions NAMESPACE
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -17,6 +17,7 @@ export(is.mortaar_life_table_list)
export(life.table)
export(prep.life.table)
importFrom(Rdpack,reprompt)
importFrom(demography,cm.spline)
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Probably not necessary to add another dependency: cm.spline is only a wrapper for stats::spline, see below

importFrom(graphics,axis)
importFrom(graphics,grid)
importFrom(graphics,legend)
Expand Down
60 changes: 56 additions & 4 deletions R/analytical_functions.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This option should not soft-depend on an obscure (obscure for the user) option in the prep function. The prep function is not necessary to use life.table(). Instead the conditions to use this option should be explained here directly. I also suggest to add a check at the beginning of the if (length(option_spline) > 0) {...} block to test if the condition is met.

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

A check like this could look like this:

if (!condition) {
  stop("The condition is not fulfilled. Please take a look at ?life.table to determine how your input data should look like for the option_spline option.")
}

#'
#' @return
#' An object of class mortaar_life_table or mortaar_life_table_list.
#' Each mortaar_life_table contains the following variables:
Expand Down Expand Up @@ -123,9 +130,10 @@
#'
#' @importFrom magrittr "%>%"
#' @importFrom Rdpack reprompt
#' @importFrom demography cm.spline
#'
#' @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.
Expand All @@ -150,7 +158,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
Expand All @@ -159,7 +167,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
}

Expand Down Expand Up @@ -244,7 +252,7 @@ inputchecks <- function(neclist, okvars) {

}

life.table.df <- function(necdf, agecor = TRUE, agecorfac = c()) {
life.table.df <- function(necdf, agecor = TRUE, agecorfac = c(), option_spline = NULL) {

# x: well readable rownames for age classes.
limit <- necdf['a'] %>% sum
Expand All @@ -269,9 +277,53 @@ 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) {

a_cumsum <- necdf['a'] %>% cumsum

# add index number to resulting data.frame
a_cumsum$id <- 1:nrow(a_cumsum)

repeat_number <- floor((limit - 20) / option_spline)

a_cumsum_select <- a_cumsum$id[which(a_cumsum$a <= 20)]

for (t in 1 : repeat_number) {
a_cumsum_select <- c(a_cumsum_select, (a_cumsum$id[which(a_cumsum$a == (20 + (t * option_spline)))]))
}

if (((limit - 20) / option_spline) - floor((limit - 20) / option_spline) > 0) {
a_cumsum_select <- c(a_cumsum_select, a_cumsum$id[nrow(necdf)])
}

dx_cumsum <- c(cumsum(necdf[, 'dx']))[1:nrow(necdf)]
y_spline <- dx_cumsum[a_cumsum_select]
x_spline <- a_cumsum$a[a_cumsum_select]

# interpolating the values with a monotonic cubic spline
dem <- cm.spline(x_spline, y_spline, n = (limit/5 + 1), xmin = 0, xmax = limit)
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

could be replaced by:
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 (nrow(necdf) < length(dem$y)) {
dem_dx <- dem$y[c(-1)]
}
else
{
dem_dx <- c(necdf$dx[1], dem$y[c(-1)])
}

necdf['dx'] <- dem_dx - c(0, dem_dx[-nrow(necdf)])

}


Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

the whole function might benefit from refactoring and extracting functions. Can be done after merging pull request

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I agree. Maybe -- as a first step -- it's best to create an individual calculation function for each variable in life.table(). In case of dx the code in life.table() could look like this:

if (!(length(option_spline) > 0)) {
  necdf['dx'] <- dx_default(necdf['Dx'])
} else {
  necdf['dx'] <- dx_spline(necdf['a'], necdf['Dx'])
}

with dx_default() like this

dx_default <- function(Dx) {
 Dx / Dx * 100
}

and dx_spline() with the code you wrote.

# lx: proportion of survivorship within x.
necdf['lx'] <- c(100, 100 - cumsum(necdf[, 'dx'])
)[1:nrow(necdf)]
Expand Down
10 changes: 9 additions & 1 deletion man/life.table.Rd
View file
Open in desktop

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.