Dyplr & purrr - перекрывающиеся интервалы времени по группам - PullRequest
Новая
       34

Dyplr & purrr - перекрывающиеся интервалы времени по группам

0 голосов
/ 21 февраля 2020

Мне нужно использовать следующий код, который смотрит на перекрывающиеся интервалы времени. Функция наложения ниже работает отлично, но мне нужно применить к каждой группе в моей таблице. Группа может быть столбцом MemberID. Не знаете, как использовать функцию group_map (), возможно, это может сработать здесь?

enter image description here

suppressPackageStartupMessages(library(tidyverse))
suppressPackageStartupMessages(library(lubridate))

memberships <- tibble::tibble(
    memberID     = c("A", "A", "A", "B"),
    membershipID = 1:4 %>% as.factor,
    start_date   = ymd(c(20100101, 20101220, 20120415, 20110605)),
    end_date     = ymd(c(20101231, 20111231, 20130430, 20120531)),
    mo_dur       = interval(start_date, end_date) %>%
        as.duration() / dyears() * 12
)

memberships <- tibble::rowid_to_column(memberships)

overlaps <- purrr::map(memberships$rowid, function(id) {
    if (id == nrow(memberships)) {
        NA
    } else {
        row <- memberships[memberships[["rowid"]] == id, ]
        intv <- lubridate::interval(row$start_date, row$end_date)
        # these are the id's of the rows following id
        other_ids <- (id):(nrow(memberships))
        ol <- purrr::map_int(other_ids, function(other_id) {
            other_row <- memberships[memberships[["rowid"]] == other_id, ]
            # either on end is inside of interval or start and end span it
            if (other_row$start_date %within% intv |
                    other_row$end_date %within% intv |
                    (other_row$start_date <= row$start_date &
                     other_row$end_date >= row$end_date)) {
                as.integer(other_row$rowid)
            } else {
                NA_integer_
            }
        })
        # drop the NA's
        ol <- ol[!is.na(ol)]
        # if nothing overlapped return NA
        if (length(ol > 0)) {
            ol
        } else {
            NA
        }
    }
})

# make it a tibbleso youcan bind it
overlaps <- tibble::tibble(following_overlaps = overlaps)
# add as column
memberships <- dplyr::bind_cols(memberships, overlaps)

https://community.rstudio.com/t/counting-overlapping-records-per-day-using-dplyr/4289

...