Calcul efficace et précis de l'âge (en années, mois ou semaines) en R avec une date de naissance donnée et une date arbitraire
Je suis confronté à la tâche courante de calculer l'âge (en années, mois ou semaines) compte tenu de la date de naissance et d'une date arbitraire. Le fait est que je dois souvent le faire sur de nombreux enregistrements (> 300 millions), donc les performances sont un problème clé ici.
Après une recherche rapide dans SO et Google, j'ai trouvé 3 alternatives:
- Une procédure arithmétique commune (/365.25) ( link )
- Utilisation des fonctions
new_interval()etduration()du packagelubridate( link ) - Fonction
age_calc()du packageeeptools( link , link , link )
Alors, voici mon code de jouet:
# Some toy birthdates
birthdate <- as.Date(c("1978-12-30", "1978-12-31", "1979-01-01",
"1962-12-30", "1962-12-31", "1963-01-01",
"2000-06-16", "2000-06-17", "2000-06-18",
"2007-03-18", "2007-03-19", "2007-03-20",
"1968-02-29", "1968-02-29", "1968-02-29"))
# Given dates to calculate the age
givendate <- as.Date(c("2015-12-31", "2015-12-31", "2015-12-31",
"2015-12-31", "2015-12-31", "2015-12-31",
"2050-06-17", "2050-06-17", "2050-06-17",
"2008-03-19", "2008-03-19", "2008-03-19",
"2015-02-28", "2015-03-01", "2015-03-02"))
# Using a common arithmetic procedure ("Time differences in days"/365.25)
(givendate-birthdate)/365.25
# Use the package lubridate
require(lubridate)
new_interval(start = birthdate, end = givendate) /
duration(num = 1, units = "years")
# Use the package eeptools
library(eeptools)
age_calc(dob = birthdate, enddate = givendate, units = "years")
Parlons plus tard de la précision et concentrons-nous d'abord sur les performances. Voici le code:
# Now let's compare the performance of the alternatives using microbenchmark
library(microbenchmark)
mbm <- microbenchmark(
arithmetic = (givendate - birthdate) / 365.25,
lubridate = new_interval(start = birthdate, end = givendate) /
duration(num = 1, units = "years"),
eeptools = age_calc(dob = birthdate, enddate = givendate,
units = "years"),
times = 1000
)
# And examine the results
mbm
autoplot(mbm)
Voici les résultats:
Conclusion: les performances des fonctions lubridate et eeptools sont bien pires que la méthode arithmétique (/365.25 est au moins 10 fois plus rapide). Malheureusement, la méthode arithmétique n'est pas assez précise et je ne peux pas me permettre les quelques erreurs que cette méthode fera.
"En raison de la façon dont le calendrier grégorien moderne est construit, il n'y a pas de méthode arithmétique simple qui produit l'âge d'une personne, exprimée selon l'usage courant - usage courant signifiant que l'âge d'une personne devrait toujours être un entier qui augmente exactement le jour de son anniversaire". ( lien )
Comme je l'ai lu sur certains messages, lubridate et eeptools ne font pas de telles erreurs (cependant, je n'ai pas regardé le code/en savoir plus sur ces fonctions pour savoir quelle méthode elles utilisent) et c'est pourquoi je voulais les utiliser, mais leurs performances ne fonctionnent pas pour ma vraie application.
Des idées sur une méthode efficace et précise pour calculer l'âge?
ÉDITER
Ops, il semble que lubridate commette également des erreurs. Et apparemment basé sur cet exemple de jouet, il fait plus d'erreurs que la méthode arithmétique (voir lignes 3, 6, 9, 12). (Est-ce que je fais quelque chose de mal?)
toy_df <- data.frame(
birthdate = birthdate,
givendate = givendate,
arithmetic = as.numeric((givendate - birthdate) / 365.25),
lubridate = new_interval(start = birthdate, end = givendate) /
duration(num = 1, units = "years"),
eeptools = age_calc(dob = birthdate, enddate = givendate,
units = "years")
)
toy_df[, 3:5] <- floor(toy_df[, 3:5])
toy_df
birthdate givendate arithmetic lubridate eeptools
1 1978-12-30 2015-12-31 37 37 37
2 1978-12-31 2015-12-31 36 37 37
3 1979-01-01 2015-12-31 36 37 36
4 1962-12-30 2015-12-31 53 53 53
5 1962-12-31 2015-12-31 52 53 53
6 1963-01-01 2015-12-31 52 53 52
7 2000-06-16 2050-06-17 50 50 50
8 2000-06-17 2050-06-17 49 50 50
9 2000-06-18 2050-06-17 49 50 49
10 2007-03-18 2008-03-19 1 1 1
11 2007-03-19 2008-03-19 1 1 1
12 2007-03-20 2008-03-19 0 1 0
13 1968-02-29 2015-02-28 46 47 46
14 1968-02-29 2015-03-01 47 47 47
15 1968-02-29 2015-03-02 47 47 47
Ok, donc j'ai trouvé cette fonction dans un autre post :
age <- function(from, to) {
from_lt = as.POSIXlt(from)
to_lt = as.POSIXlt(to)
age = to_lt$year - from_lt$year
ifelse(to_lt$mon < from_lt$mon |
(to_lt$mon == from_lt$mon & to_lt$mday < from_lt$mday),
age - 1, age)
}
Il a été publié par @Jim en disant: "La fonction suivante prend un vecteur d'objets Date et calcule les âges, prenant correctement en compte les années bissextiles. Semble être une solution plus simple que toutes les autres réponses".
C'est en effet plus simple et ça fait le tour que je cherchais. En moyenne, elle est en fait plus rapide que la méthode arithmétique (environ 75% plus rapide).
mbm <- microbenchmark(
arithmetic = (givendate - birthdate) / 365.25,
lubridate = interval(start = birthdate, end = givendate) /
duration(num = 1, units = "years"),
eeptools = age_calc(dob = birthdate, enddate = givendate,
units = "years"),
age = age(from = birthdate, to = givendate),
times = 1000
)
mbm
autoplot(mbm)
Et au moins dans mes exemples, il ne fait aucune erreur (et il ne devrait pas dans aucun exemple; c'est une fonction assez simple en utilisant ifelses).
toy_df <- data.frame(
birthdate = birthdate,
givendate = givendate,
arithmetic = as.numeric((givendate - birthdate) / 365.25),
lubridate = interval(start = birthdate, end = givendate) /
duration(num = 1, units = "years"),
eeptools = age_calc(dob = birthdate, enddate = givendate,
units = "years"),
age = age(from = birthdate, to = givendate)
)
toy_df[, 3:6] <- floor(toy_df[, 3:6])
toy_df
birthdate givendate arithmetic lubridate eeptools age
1 1978-12-30 2015-12-31 37 37 37 37
2 1978-12-31 2015-12-31 36 37 37 37
3 1979-01-01 2015-12-31 36 37 36 36
4 1962-12-30 2015-12-31 53 53 53 53
5 1962-12-31 2015-12-31 52 53 53 53
6 1963-01-01 2015-12-31 52 53 52 52
7 2000-06-16 2050-06-17 50 50 50 50
8 2000-06-17 2050-06-17 49 50 50 50
9 2000-06-18 2050-06-17 49 50 49 49
10 2007-03-18 2008-03-19 1 1 1 1
11 2007-03-19 2008-03-19 1 1 1 1
12 2007-03-20 2008-03-19 0 1 0 0
13 1968-02-29 2015-02-28 46 47 46 46
14 1968-02-29 2015-03-01 47 47 47 47
15 1968-02-29 2015-03-02 47 47 47 47
Je ne la considère pas comme une solution complète car je voulais aussi avoir l'âge en mois et semaines, et cette fonction est spécifique depuis des années. Je le poste ici quand même car il résout le problème de l'âge en années. Je ne l'accepterai pas car:
- J'attendrais que @Jim le poste comme réponse.
- J'attendrai de voir si quelqu'un d'autre proposera une solution complète (efficace, précise et produisant l'âge en années, mois ou semaines comme souhaité).
La raison pour laquelle lubridate semble faire des erreurs ci-dessus est que vous calculez la durée (la durée exacte qui se produit entre deux instants, où 1 an = 31536000s), plutôt que les périodes (le changement de temps d'horloge qui se produit entre deux instants).
Pour obtenir le changement d'horloge (en années, mois, jours, etc.), vous devez utiliser
as.period(interval(start = birthdate, end = givendate))
ce qui donne la sortie suivante
"37y 0m 1d 0H 0M 0S"
"37y 0m 0d 0H 0M 0S"
"36y 11m 30d 0H 0M 0S"
...
"46y 11m 30d 1H 0M 0S"
"47y 0m 0d 1H 0M 0S"
"47y 0m 1d 1H 0M 0S"
Pour extraire simplement des années, vous pouvez utiliser ce qui suit
as.period(interval(start = birthdate, end = givendate))$year
[1] 37 37 36 53 53 52 50 50 49 1 1 0 46 47 47
Notez malheureusement semble encore plus lent que les méthodes ci-dessus!
> mbm
Unit: microseconds
expr min lq mean median uq max neval cld
arithmetic 116.595 138.149 181.7547 184.335 196.8565 5556.306 1000 a
lubridate 16807.683 17406.255 20388.1410 18053.274 21378.8875 157965.935 1000 b
J'allais laisser cela dans les commentaires, mais je pense que cela mérite une réponse distincte. Comme le souligne @Molx, votre méthode "arithmétique" n'est pas aussi simple qu'il y paraît - jetez un œil au code de -.Date, Surtout:
return(difftime(e1, e2, units = "days"))
Ainsi, la méthode "arithmétique" sur les objets de classe Date est vraiment un wrapper pour la fonction difftime. Qu'en est-il de difftime? Cela a aussi un tas de frais généraux si ce que vous recherchez est la vitesse brute.
La clé est que les objets Date sont stockés sous forme de nombre entier de jours depuis/jusqu'au 1er janvier 1970 (bien qu'ils ne soient pas réellement stockés en tant que integer, d'où la naissance du IDate classe dans data.table), donc nous pouvons simplement les soustraire et en finir, mais pour éviter d'appeler la méthode -.Date, nous devons unclass notre contributions:
(unclass(birthdate) - unclass(givendate)) / 365.25
En ce qui concerne le rapport qualité-prix, cette approche est encore plus rapide de plusieurs ordres de grandeur que la méthode age de @ Jim.
Voici quelques données de test plus évolutives:
set.seed(20349)
NN <- 1e6
birthdate <- as.Date(sprintf('%d-%02d-%02d',
sample(1901:2030, NN, TRUE),
sample(12, NN, TRUE),
sample(28, NN, TRUE)))
#average 30 years, most data between 20 and 40 years
givendate <- birthdate + as.integer(rnorm(NN, mean = 10950, sd = 1000))
(à l'exclusion de eeptools car il est presque incroyablement plus lent - un coup d'œil au code de age_calc suggère que le code va jusqu'à créer une séquence de dates pour chaque paire de dates (O(n^2)- ish), sans parler d'un peppering de ifelses )
microbenchmark(
arithmetic = (givendate - birthdate) / 365.25,
lubridate = interval(start = birthdate, end = givendate) /
duration(num = 1, units = "years"),
age = age(from = birthdate, to = givendate),
fastar = (unclass(givendate) - unclass(birthdate)) / 365.25,
overlaps = get_age(birthdate, givendate),
times = 50)
# Unit: milliseconds
# expr min lq mean median uq max neval cld
# arithmetic 28.153465 30.384639 62.96118 31.492764 34.052991 180.9556 50 b
# lubridate 94.327968 97.233009 157.30420 102.751351 240.717065 265.0283 50 c
# age 338.347756 479.598513 483.84529 483.580981 488.090832 770.1149 50 d
# fastar 7.740098 7.831528 11.02521 7.913146 8.090902 153.3645 50 a
# overlaps 316.408920 458.734073 459.58974 463.806255 470.320072 769.0929 50 d
Ainsi, nous soulignons également la folie de l'analyse comparative des données à petite échelle.
Le gros coût de la méthode @ Jim est que as.POSIXlt Est de plus en plus cher à mesure que vos vecteurs se développent.
Le problème de l'inexactitude demeure, mais à moins que cette précision ne soit primordiale, il semble que la méthode unclass soit sans précédent.
J'ai martelé cela et j'ai finalement quelque chose qui est a) parfaitement précis * (contrairement à tout des autres options présentées jusqu'à présent) et b) raisonnablement rapide (voir mes repères dans l'autre réponse). Il repose sur un tas d'arithmétique que j'ai fait à la main et sur la merveilleuse fonction foverlaps du package data.table.
L'essence de l'approche est de travailler à partir de la représentation entière de Dates, ainsi que de reconnaître que toutes les dates de naissance tombent dans l'un des quatre cycles de 1461 (= 365 * 4 + 1) jours, selon le moment où l'année prochaine, c'est quand il faudra 366 jours pour que votre anniversaire arrive.
Voici la fonction:
library(data.table)
get_age <- function(birthdays, ref_dates){
x <- data.table(bday <- unclass(birthdays),
#rem: how many days has it been since the lapse of the
# most recent quadrennium since your birth?
rem = ((ref <- unclass(ref_dates)) - bday) %% 1461)
#cycle_type: which of the four years following your birthday
# was the one that had 366 days?
x[ , cycle_type :=
foverlaps(data.table(start = bdr <- bday %% 1461L, end = bdr),
#these intervals were calculated by hand;
# e.g., 59 is Feb. 28, 1970. I made the judgment
# call to say that those born on Feb. 29 don't
# have their "birthday" until the following March 1st.
data.table(start = c(0L, 59L, 424L, 790L, 1155L),
end = c(58L, 423L, 789L, 1154L, 1460L),
val = c(3L, 2L, 1L, 4L, 3L),
key = "start,end"))$val]
I4 <- diag(4L)[ , -4L] #for conciseness below
#The `by` approach might seem a little abstruse for those
# not familiar with `data.table`; see the edit history
# for a more palatable version (which is also slightly slower)
x[ , extra :=
foverlaps(data.table(start = rem, end = rem),
data.table(start = st <- cumsum(c(0L, rep(365L, 3L) +
I4[.BY[[1L]],])),
end = c(st[-1L] - 1L, 1461L),
int_yrs = 0:3, key = "start,end")
)[ , int_yrs + (i.start - start) / (end + 1L - start)], by = cycle_type]
#grand finale -- 4 years for every quadrennium, plus the fraction:
4L * ((ref - bday) %/% 1461L) + x$extra
}
Comparer sur votre exemple principal:
toy_df <- data.frame(
birthdate = birthdate,
givendate = givendate,
arithmetic = as.numeric((givendate - birthdate) / 365.25),
lubridate = interval(start = birthdate, end = givendate) /
duration(num = 1, units = "years"),
eeptools = age_calc(dob = birthdate, enddate = givendate,
units = "years"),
mine = get_age(birthdate, givendate)
)
toy_df
# birthdate givendate arithmetic lubridate eeptools mine
# 1 1978-12-30 2015-12-31 37.0020534 37.027397 37.0027397 37.0027322 #eeptools wrong: will be 366 days until 12/31/16, so fraction is 1/366
# 2 1978-12-31 2015-12-31 36.9993155 37.024658 37.0000000 37.0000000
# 3 1979-01-01 2015-12-31 36.9965777 37.021918 36.9972603 36.9972603
# 4 1962-12-30 2015-12-31 53.0020534 53.038356 53.0027397 53.0027322 #same problem
# 5 1962-12-31 2015-12-31 52.9993155 53.035616 53.0000000 53.0000000
# 6 1963-01-01 2015-12-31 52.9965777 53.032877 52.9972603 52.9972603
# 7 2000-06-16 2050-06-17 50.0013689 50.035616 50.0000000 50.0027397 #eeptools wrong: not exactly the birthday
# 8 2000-06-17 2050-06-17 49.9986311 50.032877 50.9972603 50.0000000 #eeptools wrong: _is_ exactly the birthday
# 9 2000-06-18 2050-06-17 49.9958932 50.030137 49.9945205 49.9972603 #eeptools wrong: fraction should be 364/365
# 10 2007-03-18 2008-03-19 1.0047912 1.005479 1.0027322 1.0027397 #eeptools wrong: 2/29 already passed, only 365 days until 3/19/2009
# 11 2007-03-19 2008-03-19 1.0020534 1.002740 1.0000000 1.0000000
# 12 2007-03-20 2008-03-19 0.9993155 1.000000 0.9966839 0.9972678 #eeptools wrong: we passed 2/29, so should be 365/366
# 13 1968-02-29 2015-02-28 46.9979466 47.030137 46.9977019 46.9972603 #my judgment: birthday occurs on 3/1 for 2/29 babies, so 364/365 the way there
# 14 1968-02-29 2015-03-01 47.0006845 47.032877 47.0000000 47.0000000
# 15 1968-02-29 2015-03-02 47.0034223 47.035616 47.0027397 47.0027322
Ce style d'approche pourrait être étendu pour gérer des mois/semaines assez facilement. Les mois seront un peu longs (il faut spécifier 4 mois de durée), donc je n'ai pas pris la peine; semaines est facile (les semaines ne sont pas affectées par les considérations relatives aux années bissextiles, nous pouvons donc simplement diviser par 7).
J'ai également fait beaucoup de progrès en faisant cela avec les fonctionnalités de base, mais a) c'était assez moche (a besoin d'un non-linéaire transformation de 0-1460 pour éviter de faire des instructions imbriquées ifelse, etc.) et b) à la fin une boucle for (sous la forme de apply sur toute la liste des dates) était inévitable, j'ai donc décidé que cela ralentirait trop les choses. (la transformation est x1 = (unclass(birthdays) - 59) %% 1461; x2 = x1 * (729 - x1) / 402232 + x1, pour la postérité)
J'ai ajouté cette fonction à mon package .
* (pour les plages de dates où siècles non bissextiles ne sont pas un problème; je pense cependant que l'extension pour gérer ces dates ne devrait pas être trop lourde)