Come calcolare il numero di occorrenze al minuto per un set di dati di grandi dimensioni

Question

Ho un set di dati con appuntamenti da 500 k che durano tra i 5 ei 60 minuti.

tdata <- structure(list(Start = structure(c(1325493000, 1325493600, 1325494200, 1325494800, 1325494800, 1325495400, 1325495400, 1325496000, 1325496000, 1325496600, 1325496600, 1325497500, 1325497500, 1325498100, 1325498100, 1325498400, 1325498700, 1325498700, 1325499000, 1325499300), class = c("POSIXct", "POSIXt"), tzone = "GMT"), End = structure(c(1325493600, 1325494200, 1325494500, 1325495400, 1325495400, 1325496000, 1325496000, 1325496600, 1325496600, 1325496900, 1325496900, 1325498100, 1325498100, 1325498400, 1325498700, 1325498700, 1325499000, 1325499300, 1325499600, 1325499600), class = c("POSIXct", "POSIXt"), tzone = "GMT"), Location = c("LocationA", "LocationA", "LocationA", "LocationA", "LocationA", "LocationA", "LocationA", "LocationA", "LocationA", "LocationB", "LocationB", "LocationB", "LocationB", "LocationB", "LocationB", "LocationB", "LocationB", "LocationB", "LocationB", "LocationB"), Room = c("RoomA", "RoomA", "RoomA", "RoomA", "RoomB", "RoomB", "RoomB", "RoomB", "RoomB", "RoomB", "RoomA", "RoomA", "RoomA", "RoomA", "RoomA", "RoomA", "RoomA", "RoomA", "RoomA", "RoomA")), .Names = c("Start", "End", "Location", "Room"), row.names = c(NA, 20L), class = "data.frame") 

> head(tdata) 
       Start     End Location Room 
1 2012-01-02 08:30:00 2012-01-02 08:40:00 LocationA RoomA 
2 2012-01-02 08:40:00 2012-01-02 08:50:00 LocationA RoomA 
3 2012-01-02 08:50:00 2012-01-02 08:55:00 LocationA RoomA 
4 2012-01-02 09:00:00 2012-01-02 09:10:00 LocationA RoomA 
5 2012-01-02 09:00:00 2012-01-02 09:10:00 LocationA RoomB 
6 2012-01-02 09:10:00 2012-01-02 09:20:00 LocationA RoomB 

Vorrei calcolare il numero di appuntamenti simultanei in totale, per ogni posizione, e per Camera (e diversi altri fattori di dati originale).

Ho provato con mysql pacchetto per eseguire un join sinistro, che lavora per un piccolo insieme di dati, ma prende per sempre per l'intero insieme di dati:

# SQL Join. 
start.min <- min(tdata$Start, na.rm=T) 
end.max <- max(tdata$End, na.rm=T) 
tinterval <- seq.POSIXt(start.min, end.max, by = "mins") 
tinterval <- as.data.frame(tinterval) 

library(sqldf) 
system.time(
    output <- sqldf("SELECT * 
       FROM tinterval 
       LEFT JOIN tdata 
       ON tinterval.tinterval >= tdata.Start 
       AND tinterval.tinterval < tdata.End ")) 

head(output) 
      tinterval    Start     End Location Room 
1 2012-01-02 09:30:00 2012-01-02 09:30:00 2012-01-02 09:40:00 LocationA RoomA 
2 2012-01-02 09:31:00 2012-01-02 09:30:00 2012-01-02 09:40:00 LocationA RoomA 
3 2012-01-02 09:32:00 2012-01-02 09:30:00 2012-01-02 09:40:00 LocationA RoomA 
4 2012-01-02 09:33:00 2012-01-02 09:30:00 2012-01-02 09:40:00 LocationA RoomA 
5 2012-01-02 09:34:00 2012-01-02 09:30:00 2012-01-02 09:40:00 LocationA RoomA 
6 2012-01-02 09:35:00 2012-01-02 09:30:00 2012-01-02 09:40:00 LocationA RoomA 

Essa crea un frame di dati in cui tutti gli appuntamenti "attivi" sono elencati per ogni minuto. Il grande set di dati copre un anno intero (~ 525600 minuti). Con una durata media degli appuntamenti di 18 minuti, mi aspetto che sql join crei un set di dati con ~ 5 milioni di righe, che posso utilizzare per creare grafici di occupazione per diversi fattori (posizione/sala ecc.).

Costruire sulla soluzione sapply suggerita in How to count number of concurrent users Ho provato ad utilizzare data.table e snowfall come segue:

require(snowfall) 
require(data.table) 
sfInit(par=T, cpu=4) 
sfLibrary(data.table) 

tdata <- data.table(tdata) 
tinterval <- seq.POSIXt(start.min, end.max, by = "mins") 
setkey(tdata, Start, End) 
sfExport("tdata") # "Transport" data to cores 

system.time(output <- data.frame(tinterval,sfSapply(tinterval, function(i) length(tdata[Start <= i & i < End,Start])))) 

> head(output) 
      tinterval sfSapply.tinterval..function.i..length.tdata.Start....i...i... 
1 2012-01-02 08:30:00                1 
2 2012-01-02 08:31:00                1 
3 2012-01-02 08:32:00                1 
4 2012-01-02 08:33:00                1 
5 2012-01-02 08:34:00                1 
6 2012-01-02 08:35:00                1 

Questa soluzione è veloce, richiede ~ 18 secondi per calcolare 1 giorno (circa 2 ore per un anno intero) . Lo svantaggio è che non posso creare sottoinsiemi di numero di appuntamenti simultanei per determinati fattori (Posizione, Stanza ecc.). Ho la sensazione che ci debba essere un modo migliore per farlo ... qualche consiglio?

UPDATE: La soluzione finale si presenta così, in base alla risposta di Geoffrey. L'esempio mostra come possono essere determinate le occupazioni per ciascuna località.

setkey(tdata, Location, Start, End) 
vecTime <- seq(from=tdata$Start[1],to=tdata$End[nrow(tdata)],by=60) 
res <- data.frame(time=vecTime) 

for(i in 1:length(unique(tdata$Location))) { 
    addz <- array(0,length(vecTime)) 
    remz <- array(0,length(vecTime)) 

    tdata2 <- tdata[J(unique(tdata$Location)[i]),] # Subset a certain location. 

    startAgg <- aggregate(tdata2$Start,by=list(tdata2$Start),length) 
    endAgg <- aggregate(tdata2$End,by=list(tdata2$End),length) 
    addz[which(vecTime %in% startAgg$Group.1)] <- startAgg$x 
    remz[which(vecTime %in% endAgg$Group.1)] <- -endAgg$x 

    res[,c(unique(tdata$Location)[i])] <- cumsum(addz + remz) 
} 

> head(res) 
       time LocationA LocationB 
1 2012-01-01 03:30:00   1   0 
2 2012-01-01 03:31:00   1   0 
3 2012-01-01 03:32:00   1   0 
4 2012-01-01 03:33:00   1   0 
5 2012-01-01 03:34:00   1   0 
6 2012-01-01 03:35:00   1   0 

Answer 1

È meglio.

Creare un vettore di tempo vuoto e un vettore di conteggio vuoto.

vecTime <- seq(from=tdata$Start[1],to=tdata$End[nrow(tdata)],by=60) 
addz <- array(0,length(vecTime)) 
remz <- array(0,length(vecTime)) 


startAgg <- aggregate(tdata$Start,by=list(tdata$Start),length) 
endAgg <- aggregate(tdata$End,by=list(tdata$End),length) 
addz[which(vecTime %in% startAgg$Group.1)] <- startAgg$x 
remz[which(vecTime %in% endAgg$Group.1)] <- -endAgg$x 
res <- data.frame(time=vecTime,occupancy=cumsum(addz + remz)) 

Answer 2

Non sono esattamente sicuro, se capisco il tuo obiettivo. Tuttavia, questo potrebbe essere utile:

#I changed the example to actually have concurrent appointments 
DF <- read.table(text="    Start,     End, Location, Room 
1, 2012-01-02 08:30:00, 2012-01-02 08:40:00, LocationA, RoomA 
2, 2012-01-02 08:40:00, 2012-01-02 08:50:00, LocationA, RoomA 
3, 2012-01-02 08:50:00, 2012-01-02 09:55:00, LocationA, RoomA 
4, 2012-01-02 09:00:00, 2012-01-02 09:10:00, LocationA, RoomA 
5, 2012-01-02 09:00:00, 2012-01-02 09:10:00, LocationA, RoomB 
6, 2012-01-02 09:10:00, 2012-01-02 09:20:00, LocationA, RoomB",header=TRUE,sep=",",stringsAsFactors=FALSE) 

DF$Start <- as.POSIXct(DF$Start,format="%Y-%d-%m %H:%M:%S",tz="GMT") 
DF$End <- as.POSIXct(DF$End,format="%Y-%d-%m %H:%M:%S",tz="GMT") 

library(data.table) 
DT <- data.table(DF) 
DT[,c("Start_num","End_num"):=lapply(.SD,as.numeric),.SDcols=1:2] 

fun <- function(s,e) { 
    require(intervals) 
    mat <- cbind(s,e) 
    inter <- Intervals(mat,closed=c(FALSE,FALSE),type="R") 
    io <- interval_overlap(inter, inter) 
    tablengths <- table(sapply(io,length))[-1] 
    sum(c(0,as.vector(tablengths/as.integer(names(tablengths))))) 
} 

#number of overlapping events per room and location 
DT[,fun(Start_num,End_num),by=list(Location,Room)] 
#  Location Room V1 
#1: LocationA RoomA 1 
#2: LocationA RoomB 0 

Non l'ho provato, soprattutto non per la velocità.

Answer 3

Ecco una strategia: ordina per ora di inizio, quindi deseleziona i dati andando all'inizio, alla fine, all'inizio, alla fine ... e vedi se quel vettore deve essere riordinato. In caso contrario, non ci sono conflitti e se lo fa puoi vedere quanti appuntamenti (e quali appuntamenti se ti piacciono) sono in conflitto tra loro.

# Using Roland's example: 
DF <- read.table(text="    Start,     End, Location, Room 
1,2012-01-02 08:30:00,2012-01-02 08:40:00,LocationA,RoomA 
2,2012-01-02 08:40:00,2012-01-02 08:50:00,LocationA,RoomA 
3,2012-01-02 08:50:00,2012-01-02 09:55:00,LocationA,RoomA 
4,2012-01-02 09:00:00,2012-01-02 09:10:00,LocationA,RoomA 
5,2012-01-02 09:00:00,2012-01-02 09:10:00,LocationA,RoomB 
6,2012-01-02 09:10:00,2012-01-02 09:20:00,LocationA,RoomB",header=TRUE,sep=",",stringsAsFactors=FALSE) 

dt = data.table(DF) 

# the conflicting appointments 
dt[order(Start), 
    .SD[unique((which(order(c(rbind(Start, End))) != 1:(2*.N)) - 1) %/% 2 + 1)], 
    by = list(Location, Room)] 
# Location Room    Start     End 
#1: LocationA RoomA 2012-01-02 08:50:00 2012-01-02 09:55:00 
#2: LocationA RoomA 2012-01-02 09:00:00 2012-01-02 09:10:00 

# and a speedier version of the above, that avoids constructing the full .SD: 
dt[dt[order(Start), 
     .I[unique((which(order(c(rbind(Start, End))) != 1:(2*.N)) - 1) %/% 2 + 1)], 
     by = list(Location, Room)]$V1] 

Forse la formula per andare da fine senza pari per correggere gli indici di cui sopra può essere semplificata, non ho speso troppo tempo a pensare a questo proposito e solo utilizzato la prima cosa che ha ottenuto il lavoro fatto.