Рассчитать секунды между 2 временными метками в R, исключая выходные - PullRequest
Новая
       38

Рассчитать секунды между 2 временными метками в R, исключая выходные

1 голос
/ 22 мая 2019

Если у меня есть фрейм данных с двумя столбцами, которые являются ГМ YMD, как рассчитать разницу в секундах между двумя исключениями выходных?

col 2 - col 1 = время в секундах; нужно исключить выходные дни секунд 

Dates1 <- as.POSIXct("2011-01-30 12:00:00") + rep(0, 10)
Dates2 <- as.POSIXct("2011-02-04") + seq(0, 9, 1)
df <- data.frame(Dates1 = Dates1, Dates2 = Dates2)

Мне нужно это, чтобы дать мне (388800 - 43200) = 345600; Причина, по которой я вычитаю 43200, заключается в том, что это время выходного дня воскресенья с полудня до полуночи, когда часы останавливаются.

Ответы [ 2 ]

2 голосов
/ 22 мая 2019

Вот решение с использованием lubridate и других tidyverse пакетов.Приятной особенностью lubridate является то, что он довольно легко справится с множеством странных проблем со временем, от часовых поясов до високосных лет, до перехода на летнее время и обратно.(Если вы заботитесь об этом, просто убедитесь, что ваши данные имеют часовые пояса.)

Я использую здесь концепцию intervals в lubridate (созданную с помощью %--% оператор).Интервал буквально звучит так: очень полезный класс, который в основном имеет время начала и окончания.

Я генерирую два набора данных: один для вашего времени начала и окончания, идругой для выходных времени начала и окончания, каждый со своим собственным столбцом интервалов.В наборе данных выходных обратите внимание, что время начала и окончания произвольно установлено на год суббот и воскресений.Вы должны установить значения со значениями, которые имеют смысл для вас, или найти способ установить это из данных.:)

Отсюда мы найдем перекрытие между вашими интервалами и интервалами выходных, используя функцию lubridate intersect, поэтому позже мы сможем подсчитать соответствующие секунды выходных и вычесть их.

Но сначала мы используем crossing из tidyr, чтобы убедиться, что мы проверяем каждый из ваших интервалов на каждый уик-энд в наборе данных weekends.Он просто запускает декартово произведение двух наборов данных (см. этот ответ SO ).

Наконец, мы используем int_length для подсчета секунд выходных, для суммирования секунд выходных для каждого изваши интервалы, подсчитайте общее количество секунд для каждого и вычтите выходные секунд из общих секунд.И вуаля!У нас есть общее количество секунд, исключая выходные.

Еще одно приятное свойство этого решения - его чрезвычайно гибкое решение.Я определил выходные дни как с 0:00 субботы до 0:00 понедельника ... но вы можете убрать вечера пятницы, понедельника или выходные, все, что вам нравится и соответствует вашим аналитическим требованиям. 

library(dplyr)
library(tidyr)
library(tibble)
library(lubridate) # makes dates and times easier!

test <- tribble(
            ~start_time,             ~end_time,
  "2019-05-22 12:35:42", "2019-05-23 12:35:42", # same week no weekends
  "2019-05-22 12:35:42", "2019-05-26 12:35:42", # ends during weekend
  "2019-05-22 12:35:42", "2019-05-28 12:35:42", # next week full weekend
  "2019-05-26 12:35:42", "2019-05-29 12:35:42", # starts during weekend
  "2019-05-22 12:35:42", "2019-06-05 12:35:42"  # two weeks two weekends
) %>% 
  mutate(
    id = row_number(),
    timespan = start_time %--% end_time
  )

weekend_beginnings <- ymd_hms("2019-05-18 00:00:00") + weeks(0:51)
weekend_endings <- ymd_hms("2019-05-20 00:00:00") + weeks(0:51)
weekends <- weekend_beginnings %--% weekend_endings

final_answer <- crossing(test, weekends) %>% 
  mutate(
    weekend_intersection = intersect(timespan, weekends),
    weekend_seconds = int_length(weekend_intersection)
  ) %>% 
  group_by(id, start_time, end_time, timespan) %>% 
  summarise(
    weekend_seconds = sum(weekend_seconds, na.rm = TRUE)
  ) %>% 
  mutate(
    total_seconds = int_length(timespan),
    weekday_seconds = total_seconds - weekend_seconds
  )

glimpse(final_answer)
1 голос
/ 22 мая 2019

Вот срез, который работает с векторами: 

#' Seconds difference without weekends
#'
#' @param a, b POSIXt
#' @param weekends 'character', day of the week (see
#'   [base::strptime()] for the "%w" argument), "0" is Sunday, "6" is
#'   Saturday; defaults to `c("0","6")`: Saturday and Sunday
#' @param units 'character', legal values for [base::units()], such as
#'   "secs", "mins", "hours"
#' @return 'difftime' object
#' @md
secs_no_weekend <- function(a, b, weekends = c("0", "6"), units = "secs") {
  out <- mapply(function(a0, b0) {
    astart <- as.POSIXct(format(a0, "%Y-%m-%d 00:00:00"))
    aend <- as.POSIXct(format(a0, "%Y-%m-%d 24:00:00"))
    bstart <- as.POSIXct(format(b0, "%Y-%m-%d 00:00:00"))
    days <- seq.POSIXt(astart, bstart, by = "day")
    ndays <- length(days)
    if (ndays == 1) {
      d <- b0 - a0
      units(d) <- "secs"
    } else {
      d <- rep(60 * 60 * 24, ndays) # secs
      d[1] <- `units<-`(aend - a0, "secs")
      d[ndays] <- `units<-`(b0 - bstart, "secs")
      wkend <- format(days, "%w")
      d[ wkend %in% weekends ] <- 0
    }
    sum(pmax(0, d))
  }, a, b)
  out <- structure(out, class = "difftime", units = units)
  out
}

Тестирование / проверка:

Возможно, это будет обновлено, так как появятся примеры, которые не соответствуют моим предположениям.

Для перспективы, вот календарь на этот месяц (июнь 2019 года) в ISO-8601 (справа) и США / не-ISO (слева): 

week <- c("Mon","Tue","Wed","Thu","Fri","Sat","Sun")
# sunfirst <- ... calculated
monfirst <- tibble(dt = seq(as.Date("2019-06-01"), as.Date("2019-06-30"), by="days")) %>%
  mutate(
    dow = factor(format(dt, format = "%a"), levels = week),
    dom = as.integer(format(dt, format = "%e")),
    wom = format(dt, format = "%V") # %U for sunfirst, %V for monfirst
  ) %>%
  select(-dt) %>%
  spread(dow, dom) %>%
  select(-wom)
monfirst <- rbind(monfirst, NA)
cbind(sunfirst,   ` `="     ",        monfirst                   )
#   Sun Mon Tue Wed Thu Fri Sat       Mon Tue Wed Thu Fri Sat Sun
# 1  NA  NA  NA  NA  NA  NA   1        NA  NA  NA  NA  NA   1   2
# 2   2   3   4   5   6   7   8         3   4   5   6   7   8   9
# 3   9  10  11  12  13  14  15        10  11  12  13  14  15  16
# 4  16  17  18  19  20  21  22        17  18  19  20  21  22  23
# 5  23  24  25  26  27  28  29        24  25  26  27  28  29  30
# 6  30  NA  NA  NA  NA  NA  NA        NA  NA  NA  NA  NA  NA  NA

Некоторые данные и ожидания.(Я использую dplyr здесь для простоты / читабельности, функция выше не требует этого.) 

dh <-  43200 # day-half, 60*60*12
d1 <-  86400 # day=1, 60*60*24
d4 <- 345600 # days=4, 4*d1
d5 <- 432000 # days=5
d7 <- 432000 # 7 days minus weekend
d <- tribble(
  ~x                   , ~y                   , ~expect, ~description
, "2019-06-03 12:00:00", "2019-06-03 12:00:05",      5 , "same day"
, "2019-06-03 12:00:00", "2019-06-04 12:00:05",   d1+5 , "next day"
, "2019-06-03 12:00:00", "2019-06-07 12:00:05",   d4+5 , "4d + 5"
, "2019-06-03 12:00:00", "2019-06-08 12:00:05",  d4+dh , "start weekday, end weekend, no 5"
, "2019-06-03 12:00:00", "2019-06-09 12:00:05",  d4+dh , "start weekday, end weekend+, no 5, same"
, "2019-06-03 12:00:00", "2019-06-10 12:00:05",   d7+5 , "start/end weekday, 1 full week"
, "2019-06-02 12:00:00", "2019-06-03 12:00:05",   dh+5 , "start weekend, end weekday, 1/2 day"
, "2019-06-02 12:00:00", "2019-06-08 12:00:05",     d7 , "start/end weekend, no 5"
) %>% mutate_at(vars(x, y), as.POSIXct)
(out <- secs_no_weekend(d$x, d$y))
# Time differences in secs
# [1]      5  86405 345605 388800 388800 432005  43205 432000
all(out == d$expect)
# [1] TRUE
...