daDoctoR/R/age_calc.R

89 lines
3.9 KiB
R
Raw Normal View History

2018-10-02 21:07:43 +02:00
#' Calculating age from date of birth
#'
#' For age calculations.
#' @param dob Date of birth. Data format follows standard POSIX layout. Format is yyyy-mm-dd.
#' @param enddate Date to calculate age at. Format is yyyy-mm-dd.
#' @param units Default is "years". Can be changed to "days".
#' @param precise Default is TRUE. Flag set whether to include calculations of spring years. Only of matter if using units = "days".
2018-10-02 21:07:43 +02:00
#' @keywords age
#' @export
#' @examples
#' ##Kim Larsen (cpr is known from album)
#' dob<-daDoctoR::dob_extract_cpr("231045-0637")
#' date<-as.Date("2018-09-30")
2018-10-04 17:04:15 +02:00
#' trunc(age_calc(dob,date))
2018-10-02 21:07:43 +02:00
2018-10-04 17:04:15 +02:00
age_calc<-function (dob, enddate = Sys.Date(), units = "years", precise = TRUE)
## Build upon the work of Jason P. Becker, as part of the eeptools
2018-10-02 21:07:43 +02:00
{
if (!inherits(dob, "Date") | !inherits(enddate, "Date")) {
stop("Both dob and enddate must be Date class objects")
}
if (length(dob)==1 && enddate < dob) {
stop("End date must be a date after date of birth")
}
if (length(dob)>1 && any(enddate < dob)) {
2018-10-02 21:07:43 +02:00
stop("End date must be a date after date of birth")
}
2018-10-02 21:07:43 +02:00
start <- as.POSIXlt(dob)
end <- as.POSIXlt(enddate)
if (precise) {
2018-10-04 17:04:15 +02:00
start_is_leap <- ifelse(start$year%%400 == 0, TRUE, ifelse(start$year%%100 ==
2018-10-02 21:07:43 +02:00
0, FALSE, ifelse(start$year%%4 == 0, TRUE, FALSE)))
2018-10-04 17:04:15 +02:00
end_is_leap <- ifelse(end$year%%400 == 0, TRUE, ifelse(end$year%%100 ==
2018-10-02 21:07:43 +02:00
0, FALSE, ifelse(end$year%%4 == 0, TRUE, FALSE)))
}
if (units == "days") {
result <- difftime(end, start, units = "days")
}
else if (units == "months") {
2018-10-04 17:04:15 +02:00
months <- sapply(mapply(seq, as.POSIXct(start), as.POSIXct(end),
2018-10-02 21:07:43 +02:00
by = "months", SIMPLIFY = FALSE), length) - 1
if (precise) {
2018-10-04 17:04:15 +02:00
month_length_end <- ifelse(end$mon == 1 & end_is_leap,
29, ifelse(end$mon == 1, 28, ifelse(end$mon %in%
2018-10-02 21:07:43 +02:00
c(3, 5, 8, 10), 30, 31)))
2018-10-04 17:04:15 +02:00
month_length_prior <- ifelse((end$mon - 1) == 1 &
start_is_leap, 29, ifelse((end$mon - 1) == 1,
28, ifelse((end$mon - 1) %in% c(3, 5, 8, 10),
2018-10-02 21:07:43 +02:00
30, 31)))
2018-10-04 17:04:15 +02:00
month_frac <- ifelse(end$mday > start$mday, (end$mday -
start$mday)/month_length_end, ifelse(end$mday <
start$mday, (month_length_prior - start$mday)/month_length_prior +
2018-10-02 21:07:43 +02:00
end$mday/month_length_end, 0))
result <- months + month_frac
}
else {
result <- months
}
}
else if (units == "years") {
2018-10-04 17:04:15 +02:00
years <- sapply(mapply(seq, as.POSIXct(start), as.POSIXct(end),
2018-10-02 21:07:43 +02:00
by = "years", SIMPLIFY = FALSE), length) - 1
if (precise) {
start_length <- ifelse(start_is_leap, 366, 365)
end_length <- ifelse(end_is_leap, 366, 365)
2018-10-04 17:04:15 +02:00
start_day <- ifelse(start_is_leap & start$yday >=
2018-10-02 21:07:43 +02:00
60, start$yday - 1, start$yday)
2018-10-04 17:04:15 +02:00
end_day <- ifelse(end_is_leap & end$yday >= 60, end$yday -
2018-10-02 21:07:43 +02:00
1, end$yday)
2018-10-04 17:04:15 +02:00
year_frac <- ifelse(start_day < end_day, (end_day -
start_day)/end_length, ifelse(start_day > end_day,
(start_length - start_day)/start_length + end_day/end_length,
2018-10-02 21:07:43 +02:00
0))
result <- years + year_frac
}
else {
result <- years
}
}
2018-10-02 21:07:43 +02:00
else {
stop("Unrecognized units. Please choose years, months, or days.")
}
return(result)
2018-10-04 17:04:15 +02:00
}