Rの誕生日と任意の日付を指定した場合の効率的で正確な年齢計算（年、月、または週）
私は、生年月日と任意の日付を指定して、年齢（年、月、または週単位）を計算するという共通のタスクに直面しています。問題は、非常に多くのレコード（3億を超える）でこれを実行する必要があることが多いため、パフォーマンスがここで重要な問題であることです。
SOとGoogleでクイック検索した後、私は3つの選択肢を見つけました：
- 一般的な算術演算（/365.25）（ リンク ）
- パッケージ
lubridateからの関数new_interval()およびduration()の使用（ link ） - パッケージ
eeptoolsの関数age_calc()（ link 、 link 、 link ）
だから、これが私のおもちゃのコードです：
# 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")
精度については後で説明し、まずパフォーマンスに焦点を当てましょう。これがコードです：
# 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)
ここに結果：
結論：lubridate関数とeeptools関数のパフォーマンスは、算術法よりもはるかに劣ります（/365.25は少なくとも10倍速い）。残念ながら、算術法は十分に正確ではなく、この方法で発生するいくつかの間違いを許すことはできません。
「現代のグレゴリオ暦の構築方法のため、一般的な用法に従って述べられている、人の年齢を計算する簡単な算術方法はありません。一般的な用法は、人の年齢は常に誕生日に正確に増加する整数であることを意味します。」 （ リンク ）
いくつかの投稿を読んでいるように、lubridateとeeptoolsはそのような間違いを犯しません（ただし、コードを調べたり、これらの関数の詳細を読んでいないので、どのメソッドを使用するかはわかりません）。なぜそれらを使用したかったのですが、実際のアプリケーションではそれらのパフォーマンスは機能しません。
年齢を計算するための効率的で正確な方法に関するアイデアはありますか？
編集
Ops、lubridateも間違いを犯しているようです。そして、明らかにこのおもちゃの例に基づいているため、算術法よりも多くの間違いを犯します（3、6、9、12行目を参照）。 （私は何か間違ったことをしていますか？）
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
わかりましたので、この関数を別の 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)
}
@Jimが投稿した「次の関数は、Dateオブジェクトのベクトルを取得して、うるう年を正しく考慮して年齢を計算します。他のどの回答よりも簡単な解決策のようです」。
それは確かに簡単で、私が探していたトリックを実行します。平均すると、実際には算術法よりも高速です（約75％高速）。
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)
そして、少なくとも私の例では、それは間違いをしません（そして、それはどの例でもそうではありません。これは、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
また、月単位や週単位で年齢を計算したかったため、この機能は完全なソリューションとは見なしていません。この機能は何年も特定されます。とにかくここで投稿します。なぜなら、それは年の問題を数年で解決するからです。私はそれを受け入れません：
- @Jimが回答として投稿するのを待ちます。
- 他の誰かが完全なソリューションを考え出すかどうかを確認します（効率的で正確で、必要に応じて年、月、または週単位の年齢を生成します）。
Lubridateが上記の誤りを犯しているように見える理由は、期間（2つの瞬間間で発生する時刻の変化）ではなく、期間（2つの瞬間間で発生する正確な時間、1年= 31536000s）を計算しているためです。
時刻の変更（年、月、日など）を取得するには、使用する必要があります
as.period(interval(start = birthdate, end = givendate))
次の出力が得られます
"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"
年を抽出するには、以下を使用できます
as.period(interval(start = birthdate, end = givendate))$year
[1] 37 37 36 53 53 52 50 50 49 1 1 0 46 47 47
悲しいことに、上記の方法よりもさらに遅いことに注意してください！
> 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
私はこれをコメントに残すつもりでしたが、別の答えに値すると思います。 @Molxが指摘しているように、「算術」メソッドは見かけほど単純ではありません。最も重要なのは_-.Date_のコードを見てください。
_return(difftime(e1, e2, units = "days"))
_したがって、クラスDateのオブジェクトの「算術」メソッドは、実際にはdifftime関数のラッパーです。 difftimeはどうですか？あなたが求めているものが生の速度である場合、これもオーバーヘッドの束を持っています。
重要なのは、Dateオブジェクトが1970年1月1日から/までの整数の日数として保存されることです（ただし、実際にはintegerとして保存されないため、IDateクラスを_data.table_）に含めることで、これらを差し引いてそれで処理できますが、_-.Date_メソッドが呼び出されないようにするには、入力をunclassする必要があります。
_(unclass(birthdate) - unclass(givendate)) / 365.25
_費用対効果に関しては、この方法は@Jimのageメソッドよりも数桁速いです。
以下は、さらに拡張されたテストデータです。
_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))
_（ほとんど不可能に遅いのでeeptoolsを除きます-_age_calc_のコードを一目見ると、コードがまでの日付のシーケンスを作成することを示唆しています日付の各ペア（O(n^2)- ish） 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
_したがって、小規模データでのベンチマークの愚かさも強調します。
@Jimのメソッドの大きなコストは、ベクトルが大きくなるにつれて_as.POSIXlt_のコストが高くなることです。
不正確さの問題は残っていますが、この正確さが最優先でない限り、unclassメソッドは他に類を見ないようです。
私はこれを叩き続けて、最終的にはa）完全に正確な*（allとは対照的に） これまでに提示された他のオプションの）およびb）かなり速い（他の回答の私のベンチマークを参照）。それは、私が手作業で行った一連の算術演算と、_data.table_パッケージのすばらしいfoverlaps関数に依存しています。
アプローチの本質は、Datesの整数表現から作業することです。また、すべての誕生日が、次の場合に応じて4つの1461（= 365 * 4 + 1）日サイクルのいずれかに該当することを認識します。来年はあなたの誕生日が来るのに366日かかります。
これが関数です：
_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
}
_主な例を比較すると：
_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
_このアプローチのスタイルは、数か月/数週間をかなり簡単に処理するように拡張できます。月は少し長くなります（4年分の月の長さを指定する必要があります）ので、私は気にしませんでした。週は簡単です（週はうるう年の考慮事項の影響を受けないため、7で割ることができます）。
base機能を使用してこれを行うことで多くの進歩を遂げましたが、a）それはかなり醜い（非線形が必要）ネストされたifelseステートメントなどを回避するための0〜1460の変換）およびb）最後に、（日付のリスト全体でapplyの形式で）forループが避けられなかった、だから私はそれが物事を遅くしすぎると決めました。 （変換は、後世のためにx1 = (unclass(birthdays) - 59) %% 1461; x2 = x1 * (729 - x1) / 402232 + x1です）
この関数を my package に追加しました。
*（ 非うるう世紀 の場合の日付範囲については問題ではありません。ただし、そのような日付を処理するための拡張はそれほど面倒ではないはずです）