-
Notifications
You must be signed in to change notification settings - Fork 2
/
pin_age.R
82 lines (73 loc) · 2.48 KB
/
pin_age.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
#' @title Extract Age from Personal Identity Code
#' @description Calculate age in years, months, weeks or days from
#' personal identity codes.
#' @inheritParams hetu
#' @param date Date at which age is calculated. If a vector is provided it
#' must be of the same length as the \code{pin} argument.
#' @param timespan Timespan to use to calculate age. The possible timespans are:
#' \itemize{
#' \item \code{years} (Default)
#' \item \code{months}
#' \item \code{weeks}
#' \item \code{days}
#' }
#' @aliases hetu_age
#' @return Age as an integer vector.
#'
#' @examples
#' ex_pin <- c("010101-0101", "111111-111C")
#' pin_age(ex_pin, date = "2012-01-01")
#'
#' @importFrom checkmate assert_date assert_choice
#' @importFrom lubridate ymd interval years weeks days period
#'
#' @export
pin_age <- function(pin,
date=Sys.Date(),
timespan = "years",
allow.temp = FALSE) {
date <- as.Date(date)
checkmate::assert_date(date, any.missing = FALSE)
checkmate::assert_choice(timespan, choices = c("years",
"months",
"weeks",
"days"))
if (length(date) == 1) {
message("The age in ", timespan, " has been calculated at ",
as.character(date), ".")
} else if (length(date) == length(pin)) {
message("The age is calculated relative to the '",
deparse(substitute(date)), "' date")
} else {
stop("Multiple dates used.")
}
hetuframe <- hetu(pin)
date <- lubridate::ymd(date)
all_pins <- pin
all_pins[!hetuframe$valid.pin] <- NA
if (length(date) > 1) {
valid_diff <- !is.na(all_pins) & !is.na(date)
} else{
valid_diff <- !is.na(all_pins)
}
pin <- all_pins[valid_diff]
pin_dates <- as.Date(hetuframe$date[valid_diff])
diff <- lubridate::interval(pin_dates, date)
timespan_lubridate <-
switch(timespan,
"years" = lubridate::years(1),
"months" = lubridate::period(months = 1),
"weeks" = lubridate::weeks(1),
"days" = lubridate::days(1))
age <- suppressMessages(as.integer(diff %/% timespan_lubridate))
if (any(date < pin_dates)) warning("Negative age(s).")
all_age <- rep(as.integer(NA), length(all_pins))
all_age[valid_diff] <- age
all_age
}
#' @rdname pin_age
#' @examples
#' ex_pin <- c("010101-0101", "111111-111C")
#' hetu_age(ex_pin, date = "2012-01-01")
#' @export
hetu_age <- pin_age