Блог

Главная - Вопросы по программированию - Р: Если разделить год фиников на 2 месячные ячейки, получится 7 ячеек вместо 6?

Р: Если разделить год фиников на 2 месячные ячейки, получится 7 ячеек вместо 6?

#r #date #cut #bins

#r #Дата #вырезать #ячейки

Вопрос:

Я пытаюсь использовать функцию cut() в R, чтобы разделить год дат на 6 двухмесячных ячеек. Когда я это делаю, получается 7 ячеек вместо 6, причем последняя ячейка пуста. Я использую следующий код:

 dates <- seq(as.Date("2021-1-1"),as.Date("2021-12-31"),by="day")
months <- cut(dates,"month",labels=1:12)
table(months)
# months
#  1  2  3  4  5  6  7  8  9 10 11 12 
# 31 28 31 30 31 30 31 31 30 31 30 31 
sextiles <- cut(dates,"2 months",labels=1:6)
# Error in cut.default(unclass(x), unclass(breaks), labels = labels, right = right,  : 
#   lengths of 'breaks' and 'labels' differ
sextiles <- cut(dates,"2 months",labels=1:7)
table(sextiles)
# sextiles
#  1  2  3  4  5  6  7 
# 59 61 61 62 61 61  0

Код работает нормально, когда я делю год на ячейки за один месяц, но выдает ошибку, когда я делю на ячейки за 2 месяца, если только я не учитываю 7 ячеек вместо 6 в аргументе labels . Если я начну удалять даты с конца года, код в конечном итоге будет работать с 6 ячейками после удаления последних 3 дней года:

 dates_364 <- dates[-length(dates)]
sextiles <- cut(dates_364,"2 months",labels=1:6)
# Error in cut.default(unclass(x), unclass(breaks), labels = labels, right = right,  : 
#   lengths of 'breaks' and 'labels' differ
dates_363 <- dates_364[-length((dates_364))]
sextiles <- cut(dates_363,"2 months",labels=1:6)
# Error in cut.default(unclass(x), unclass(breaks), labels = labels, right = right,  : 
#   lengths of 'breaks' and 'labels' differ
dates_362 <- dates_363[-length((dates_363))]
sextiles <- cut(dates_362,"2 months",labels=1:6)
table(sextiles)
# sextiles
#  1  2  3  4  5  6 
# 59 61 61 62 61 58

Это похоже на ошибку в функции. Кто-нибудь может пролить свет на то, что я упускаю из виду? Спасибо!

Ответ №1:

Существует два способа определить «ячейки» для диапазона номеров таким образом, чтобы все предоставленные номера находились в пределах одной из ячеек:

  • найдите минимум, найдите максимум, и поскольку Date -ячейки обычно right=FALSE означают правильное открытие, немного увеличьте максимум; или
  • найдите минимум и не находите максимум, вместо этого используйте Inf так, чтобы он всегда содержал максимальные значения.

cut.Date выбрал первое из двух. Кроме того, вместо того, чтобы «отклониться от максимума на 1 день», он выбрал «отклониться на «шаг»». Это означает, что, когда вы говорите "2 months" , это гарантирует, что следующий «край» ячейки находится в 2 месяцах от предпоследней границы.

А именно, если вы посмотрите на источник для cut.Date :

         start <- as.POSIXlt(min(x, na.rm = TRUE))
# ...
            end <- as.POSIXlt(max(x, na.rm = TRUE))
# and then if 'months', then
            end <- as.POSIXlt(end   (31 * step * 86400))
# and eventually
            breaks <- as.Date(seq(start, end, breaks))

Так что я пойду debug(cut.Date) и взгляну на cut(dates, "2 months") :

 start
# [1] "2021-01-01 UTC"
# debug: end <- as.POSIXlt(max(x, na.rm = TRUE))
# debug: step <- if (length(by2) == 2L) as.integer(by2[1L]) else 1L
end
# [1] "2021-12-31 UTC"
step
# [1] 2

# debug: as.integer(by2[1L])
# debug: end <- as.POSIXlt(end   (31 * step * 86400))
end
# [1] "2022-03-03 UTC"

# debug: end$mday <- 1L
# debug: end$isdst <- -1L
# debug: breaks <- as.Date(seq(start, end, breaks))
breaks
# [1] "2021-01-01" "2021-03-01" "2021-05-01" "2021-07-01" "2021-09-01" "2021-11-01" "2022-01-01"
# [8] "2022-03-01"

Затем это в конце концов происходит breaks[-length(breaks)] , что объясняет, почему мы не видим восьмерки. Я предполагаю, что есть угловые случаи (возможно, високосные годы?). где 31 * step * 86400 (или другие by единицы измерения) не всегда идеально выравниваются, поэтому они немного буферизовали его.

Короче говоря (слишком поздно), я предлагаю вам использовать labels=FALSE вместо этого.

 sextiles <- cut(dates, "2 months", labels = FALSE)
table(sextiles)
# sextiles
#  1  2  3  4  5  6 
# 59 61 61 62 61 61

Если вы хотите, чтобы они выглядели как целочисленные factor s (которые представляют собой уровни строк с истинными целыми числами внизу), то, возможно

 sextiles <- factor(sextiles)
head(sextiles)
# [1] 1 1 1 1 1 1
# Levels: 1 2 3 4 5 6

Комментарии:

1. Если это ошибка R, то поздравляю с ее обнаружением! Он должен быть отправлен в список рассылки R-devel.

2. Спасибо @r2evans! Ваше элегантное решение отлично работает! Изучая ваш ответ, я обнаружил ошибку в коде для cut.Date. Просто не хватает нескольких строк кода, которые проверяли бы, попадает ли максимальная дата перед последней ячейкой, и в этом случае она удалит эту ячейку. Если вы посмотрите на код для breaks=»quarters» или valid==5L, последняя строка кода делает именно это для этого случая. Это необходимо и здесь по той же причине: потому что месяцы имеют разное количество дней, создавая несогласованные интервалы.

Ответ №2:

Благодаря проницательности, предоставленной @r2evans, я нашел ответ на свой вопрос.

В коде для вырезания есть ошибка.Функция даты. Строки с 31 по 41 обрабатывают случай, когда разрывы указаны в месяцах:

 if (valid == 3L) {
  start$mday <- 1L
  start$isdst <- -1L
  end <- as.POSIXlt(max(x, na.rm = TRUE))
  step <- if (length(by2) == 2L) 
    as.integer(by2[1L])
  else 1L
  end <- as.POSIXlt(end   (31 * step * 86400))
  end$mday <- 1L
  end$isdst <- -1L
  breaks <- as.Date(seq(start, end, breaks))

Строка 38, end <- as.POSIXlt(end (31 * step * 86400)) настраивает конец вперед на 31 день, умноженный на шаг, или количество месяцев в каждой ячейке. Поскольку не во всех месяцах 31 день, бывают случаи, когда конец отодвигается достаточно далеко, чтобы создать лишнюю ячейку. Это можно легко исправить с помощью нескольких строк кода, как мы видим в случае, когда разрывы делятся на четверти. См . Строки с 57 по 75:

 else if (valid == 5L) {
  qtr <- rep(c(0L, 3L, 6L, 9L), each = 3L)
  start$mon <- qtr[start$mon   1L]
  start$mday <- 1L
  start$isdst <- -1L
  maxx <- max(x, na.rm = TRUE)           # Note this line
  end <- as.POSIXlt(maxx)                # Note this line
  step <- if (length(by2) == 2L) 
    as.integer(by2[1L])
  else 1L
  end <- as.POSIXlt(end   (93 * step * 86400))
  end$mon <- qtr[end$mon   1L]
  end$mday <- 1L
  end$isdst <- -1L
  breaks <- as.Date(seq(start, end, paste(step * 3L, 
                                          "months")))
  lb <- length(breaks)                   # Note this line
  if (maxx < breaks[lb - 1])             # If extra bin
    breaks <- breaks[-lb]                # Then remove extra bin

Если мы используем тот же метод и изменим раздел кода, касающийся перерывов =»месяцев»,:

 if (valid == 3L) {
  start$mday <- 1L
  start$isdst <- -1L
  maxx <- max(x, na.rm = TRUE)     # Line added
  end <- as.POSIXlt(maxx)          # Line modified
  step <- if (length(by2) == 2L) 
    as.integer(by2[1L])
  else 1L
  end <- as.POSIXlt(end   (31 * step * 86400))
  end$mday <- 1L
  end$isdst <- -1L
  breaks <- as.Date(seq(start, end, breaks))
  lb <- length(breaks)             # Line added
  if (maxx < breaks[lb - 1])       # Line added
    breaks <- breaks[-lb]          # Line added

Сохраняя измененную функцию в cut_Date, мы получаем следующее:

 dates <- seq(as.Date("2021-1-1"),as.Date("2021-12-31"),by="day")
sextiles <- cut(dates,"2 months",labels=1:6)
# Error in cut.default(unclass(x), unclass(breaks), labels = labels, right = right,  : 
#   lengths of 'breaks' and 'labels' differ
sextiles <- cut_Date(dates,"2 months",labels=1:6)
table(sextiles)
# sextiles
#  1  2  3  4  5  6 
# 59 61 61 62 61 61

Исправлена ошибка!