R - Найти корреляцию между несколькими строками, учитывая перекрывающиеся даты

Question

У меня есть таблица данных с измерениями осадков от нескольких дождемеров. Это образец моего набора данных:

library(data.table)
dat <- fread("https://www.dropbox.com/s/yub3db3739d80h2/dat.csv?dl=1")
> dat
         ID       date value
    1:  937 2000-01-01  14.2
    2:  937 2000-01-02  68.3
    3:  937 2000-01-03  28.4
    4:  937 2000-01-04  30.2
    5:  937 2000-01-05  12.8
   ---                      
33905: 1600 2017-06-12   0.1
33906: 1600 2017-06-13  36.1
33907: 1600 2017-06-14   0.3
33908: 1600 2017-06-15   0.0
33909: 1600 2017-06-16   0.0

У меня также есть таблица данных с идентификатором каждого датчика вместе с идентификаторами ближайших нескольких датчиков, а также с общими датами измерений осадков:

neighbors <- fread("https://www.dropbox.com/s/phhskbhxsxmrxy1/neighbours.csv?dl=1")
> neighbors
      ID ID_nearest common_date_begin common_date_end diff_days
 1:    1       1117        2000-03-01      2006-12-03      2468
 2:    1        920        2000-03-01      2004-11-04      1709
 3: 1000         48        2000-03-01      2006-12-03      2468
 4: 1000       1600        2000-03-01      2017-06-16      6316
 5: 1000        937        2000-03-01      2017-01-22      6171
 6: 1001        352        2007-07-10      2017-06-16      3629
 7: 1001        324        2007-07-10      2017-06-16      3629
 8: 1002       1338        2006-01-01      2017-06-16      4184
 9: 1002        412        2006-01-01      2009-07-12      1288
10: 1002       1330        2006-01-01      2017-06-16      4184
11: 1002       1349        2006-01-01      2017-06-16      4184
12: 1009        801        2006-01-01      2017-01-22      4039

Например, идентификатор датчика 1 имеет двух близких соседей: идентификаторы 1117 и 920. Период перекрытия измерений для станций 1 и 1117 длится с 01 марта 2000 года по 03 декабря 2006 года.

Для каждой подобной комбинации в neighbors мне нужно рассчитать корреляцию осадков измерения между основным и окружающими датчиками в перекрывающиеся даты.

Например, корреляция для первой пары будет рассчитываться следующим образом:

cor(dat[ID==1 & date %between% c("2000-03-01", "2006-12-03")]$value,
    dat[ID==1117 & date %between% c("2000-03-01", "2006-12-03")]$value)

cor(dat[ID==1 & date %between% c("2000-03-01", "2004-11-04")]$value,
    dat[ID==920 & date %between% c("2000-03-01", "2004-11-04")]$value)

И ожидаемый результат будет чем-то вот так:

  ID ID_nearest correlation    n
   1       1117        0.55 2468
   1        920        0.48 1709
1000         48        0.77 2468
1000       1600        0.52 6316
1000        937        0.84 6171

и так далее для каждого ID в neighbors.

Но мне трудно придумать программный c способ достижения этого .

Как я могу это сделать? Заранее спасибо.

Answer 1

Попробуйте это

library(data.table)
dat <- fread("https://www.dropbox.com/s/yub3db3739d80h2/dat.csv?dl=1")
neighbors <- fread("https://www.dropbox.com/s/phhskbhxsxmrxy1/neighbours.csv?dl=1")

results <- neighbors[, -c(3:4)]

i <- as.numeric(neighbors[1, 1])

correlations <- matrix(NA, nrow = nrow(neighbors), ncol =1)

ids <- unique(neighbors$ID)

x <- 1

for (i in ids) {

  temp <- neighbors[ID==i]

  for (id in 1:nrow(temp)){

    near_id <- as.numeric(temp[id, 2])

    beg_date <- temp[id, 3]

    end_date <- temp[id, 4]

    correlations[x,1] <- cor(dat[ID==i & date %between% c(beg_date, end_date)]$value,
          dat[ID==near_id & date %between% c(beg_date, end_date)]$value)

    x <- x + 1
  }

}

results <- cbind(results[, 1], results[, 2], correlations, results[, 3])

colnames(results) <- c("ID", "ID_nearest", "correlation", "n")

Answer 2

Вы можете сначала попробовать:

DT <- rnfl[neighbors, on=.(ID, date>=common_date_begin, date<=common_date_end),
    c(mget(paste0("i.", names(neighbors))), 
    by=.EACHI,
    .(date=x.date, v1=x.value))][, (1L:3L) := NULL]
setnames(DT, names(DT), gsub("i.", "", names(DT), fixed=TRUE))

DT[rnfl, on=.(ID_nearest=ID, date), v2 := value]
DT[, .(correlation=cor(v1, v2)), names(neighbors)]

Если он слишком медленный, мы можем попробовать другой подход.

---

данные, а также из предыдущего qn:

library(data.table)
rnfl <- data.table(ID=c(1,1,1,1,1,2,2,2,2,2),
    date=Sys.Date() + c(0:4, 2:6),
    value=c(17.6, 5.6, 4.5, 8.3, 11.7, 10.7, 15.6, 11.6, 8.3, 2.3))
near <- data.table(ID=1, ID_nearest=2)

summ <- rnfl[, .(startdate=date[1L], enddate=date[.N]),
    .(ID, g=cumsum(c(0L, diff(date)!=1L)))]

setkey(summ, startdate, enddate)
olap <- unique(foverlaps(summ, summ)[ID!=i.ID, .(
    ID1=pmin(ID, i.ID),
    ID2=pmax(ID, i.ID),
    common_date_begin=pmax(startdate, i.startdate),
    common_date_end=pmin(enddate, i.enddate))])

near[, c("ID1", "ID2") := .(pmin(ID, ID_nearest), pmax(ID, ID_nearest))]

cols <- c("common_date_begin", "common_date_end")
neighbors <- near[olap, on=.(ID1, ID2), (cols) := mget(paste0("i.", cols))][,
    n := as.integer(common_date_end - common_date_begin)]

Answer 3

Вот один из способов сделать это

> df <- do.call(rbind, lapply(unique(neighbors$ID), function(id) {
    d <- neighbors[neighbors[, "ID"] %in% id, ]
    main.vals <- dat %>%
        dplyr::filter(ID == id & (date >= d$common_date_begin & date <= max(d$common_date_end))) %>%
        dplyr::select(value)
    main.vals <- main.vals$value
    nearest.vals <- lapply(unique(d$ID_nearest), function(neigh.id) {
        r <- d[d$ID_nearest== neigh.id, ]
        vals <- dat[dat$ID == neigh.id & (dat$date >= r$common_date_begin & dat$date <= r$common_date_end), ]
        return (vals$value)
    })
    d <- d %>%
        dplyr::select(-c(common_date_begin, common_date_end)) %>%
        dplyr::mutate(correlation = sapply(nearest.vals, cor, y = main.vals),
                      n = diff_days)    
    return(d)
}))
> df
#   ID ID_nearest diff_days correlation    n
# 1  1       1117      2468    0.527024 2468
# 2  1        920      1709   -0.469635 1709

, где мы l oop для каждого уникального ID в соседних данных, отфильтровываем его значения из dat date.frame, затем фильтруем выведите значения для каждого соседа в neighbors data.frame и проверьте корреляцию между ливнем, связанным с основным идентификатором и каждым идентификатором соседа.

Я использовал следующие данные (модифицированные для добавления ID_nearest значений до dat):

library(dplyr)
library(magrittr)

dat <- read.table(text = "
    1   2000-03-01  55.3
    1   2000-03-02  55.6
    1   2005-03-03  48.3
    920 2000-03-01  14.2
    920 2000-04-02  68.3
    920 2000-04-03  68.4
    1117 2003-03-01   0.1
    1117 2003-06-13  36.1
    1117 2003-06-14   0.3
", col.names = c("ID", "date", "value"))
dat$date <- as.POSIXct(dat$date)

neighbors <- read.table(text = "
  ID ID_nearest common_date_begin common_date_end diff_days
   1       1117        2000-03-01      2006-12-03      2468
   1        920        2000-03-01      2004-11-04      1709
", header = TRUE)
neighbors$common_date_begin <- as.POSIXct(neighbors$common_date_begin)
neighbors$common_date_end <- as.POSIXct(neighbors$common_date_end)