estratto voce più recente, in una certa condizione

Question

sto lottando per ottenere i seguenti fatto:

Esempio set di dati:

belongID uniqID Time Rating 
    1   101  5  0 
    1   102  4  0 
    2   103  4  0 
    2   104  3  0 
    2   105  2  5 
    3   106  4  2 
    3   107  5  0 
    3   108  5  1 

Il problema è: vorrei estrarre la voce più recente (valore più grande per il tempo) per appartenente, a meno che questa valutazione sia 0. Se la valutazione della voce più recente è 0, tuttavia. Voglio la prima voce con una valutazione (non la valutazione più alta, solo il primo valore con una valutazione diversa da zero). Se anche tutte le altre voci sono zero, è necessario selezionare quello più recente.

Il risultato finale dovrebbe essere di:

belongID uniqID Time Rating 
    1   101  5  0 
    2   105  2  5 
    3   108  5  1 

Il set di dati è abbastanza grande ed è ordinato da belongID. Non è ordinato in base all'ora, quindi le voci più recenti possono arrivare dopo le voci più vecchie con lo stesso appartenente.

Senza avere il vincolo "0 Rating", ho usato la seguente funzione per calcolare la voce più recente:

>uniqueMax <- function(m, belongID = 1, time = 3) { 
    t(
     vapply(
     split(1:nrow(m), m[,belongID]), 
     function(i, x, time) x[i, , drop=FALSE][which.max(x[i,time]),], m[1,], x=m, time=time 
    ) 
    ) 
} 

Non so come incorporare il vincolo "0 Rating".

EDIT: Un follow-up domanda:

Qualcuno sa come la funzione getRating deve essere modificato se non solo zero rating, ma altre valutazioni devono essere prese in considerazione (per esempio 0,1,4 e 5)? Assegnare così al più recente, a meno che non sia Rating 0 o 1 o 4 o 5? Se il punteggio è 0,1,4,5, assegnare alla voce più recente con una valutazione diversa. Se tutte le valutazioni sono 0,1,4 o 5, assegnale alla più recente di quelle. Ho provato quanto segue, ma che non ha funzionato:

getRating <- function(x){ 
    iszero <- x$Rating == 0 | x$Rating == 1 | x$Rating == 4 | x$Rating ==5 
    if(all(iszero)){ 
    id <- which.max(x$Time) 
    } else { 
    id <- which.max((!iszero)*x$Time) 
      # This trick guarantees taking 0 into account 
    } 
    x[id,] 
} 
# Do this over the complete data frame 
do.call(rbind,lapply(split(Data,Data$belongID),getRating)) 
    # edited per Tyler's suggestion' 

Answer 1

Ecco una soluzione che utilizza data.table per facilità di filtraggio e svolgere la mia funzione getRecentRow separatamente per ogni belongID.

library(data.table) 

# Load the data from the example. 
dat = structure(list(belongID = c(1L, 1L, 2L, 2L, 2L, 3L, 3L, 3L), 
      uniqID = 101:108, Time = c(5L, 4L, 4L, 3L, 2L, 4L, 5L, 5L), 
      Rating = c(0L, 0L, 0L, 0L, 5L, 2L, 0L, 1L)), 
      .Names = c("belongID", "uniqID", "Time", "Rating"), 
      row.names = c(NA, -8L), class = c("data.table", "data.frame")) 

dat = data.table(dat) # Convert to data table. 

# Function to get the row for a given belongID 
getRecentRow <- function(data) { 
    # Filter by Rating, then order by time, then select first. 
    row = data[Rating != 0][order(-Time)][1] 

    if(!is.na(row$uniqID)) { 
     # A row was found with Rating != 0, return it. 
     return(row) 
    } else { 
      # The row was blank, so filter again without restricting. rating. 
      return(data[order(-Time)][1]) 
     } 
} 

# Run getRecentRow on each chunk of dat with a given belongID 
result = dat[,getRecentRow(.SD), by=belongID] 

    belongID uniqID Time Rating 
[1,]  1 101 5  0 
[2,]  2 105 2  5 
[3,]  3 108 5  1 

Answer 2

Un suggerimento potrebbe essere:

library(plyr) 

maxV <- function(b) { 
    if (b[which.max(b$Time), "Rating"] != 0) { 
     return(b[which.max(b$Time), ]) 
    } else if (!all(b$Rating==0)) { 
     bb <- b[order(b$Rating), ] 
     return(bb[bb$Rating != 0,][1, ]) 
    } else { 
     return(b[which.max(b$Time),]) 
    } 
} 

a <- read.table(textConnection(" belongID uniqID Time Rating 
    1   101  5  0 
    1   102  4  0 
    2   103  4  0 
    2   104  3  0 
    2   105  2  5 
    3   106  4  2 
    3   107  5  0 
    3   108  5  1 "), header=T) 

ddply(a, .(belongID), maxV) 
    belongID uniqID Time Rating 
1  1 101 5  0 
2  2 105 2  5 
3  3 108 5  1 

Answer 3

Ecco il mio crepa in esso (problema interessante):

lettura nei dati:

m <- read.table(text="belongID uniqID Time Rating 
    1   101  5  0 
    1   102  4  0 
    2   103  4  0 
    2   104  3  0 
    2   105  2  5 
    3   106  4  2 
    3   107  5  0 
    3   108  5  1 ", header=T) 

Estrazione del righe richieste:

m2 <- m[order(m$belongID, -m$Time), ]     #Order to get max time first 
LIST <- split(m2, m$belongID)       #split by belongID 
FUN <- function(x) which(cumsum(x[, 'Rating'])!=0)[1] #find first non zero Rating 
LIST2 <- lapply(LIST, function(x){     #apply FUN; if NA do 1st row 
     if (is.na(FUN(x))) { 
      x[1, ] 
     } else { 
      x[FUN(x), ] 
     } 
    } 
) 
do.call('rbind', LIST2)        #put it all back together 

che produce:

belongID uniqID Time Rating 
1  1 101 5  0 
2  2 105 2  5 
3  3 108 5  1 

EDIT Con così tante persone che rispondono a questo problema (divertimento per risolvere i IMHO) si pregò per un test microbenchmark (Windows 7):

Unit: milliseconds 
    expr  min  lq median  uq  max 
1 JIGR 6.356293 6.656752 7.024161 8.697213 179.0884 
2 JORRIS 2.932741 3.031416 3.153420 3.552554 246.9604 
3 PETER 10.851046 11.459896 12.358939 17.164881 216.7284 
4 TYLER 2.864625 2.961667 3.066174 3.413289 221.1569 

E un grafico:

Answer 4

EDIT:

Come la velocità è la vostra preoccupazione principale, ho modificato il mio trucco nella soluzione iniziale, che si traduce in qualcosa di simile a questo:

uniqueMax <- function(m, belongID = 1, time = 3) { 
    t(
    vapply(
     split(1:nrow(m), m[,belongID]), 
     function(i, x, time){ 
     is.zero <- x[i,'Rating'] == 0 
     if(all(is.zero)) is.zero <- FALSE 
     x[i, , drop=FALSE][which.max(x[i,time]*(!is.zero)),] 
     } 
     , m[1,], x=m, time=time 
    ) 
    ) 
} 

La mia soluzione originale, che è un po 'più leggibile rispetto al precedente:

# Get the rating per belongID 
getRating <- function(x){ 
    iszero <- x$Rating == 0 
    if(all(iszero)){ 
    id <- which.max(x$Time) 
    } else { 
    id <- which.max((!iszero)*x$Time) 
      # This trick guarantees taking 0 into account 
    } 
    x[id,] 
} 
# Do this over the complete data frame 
do.call(rbind,lapply(split(Data,Data$belongID),getRating)) 
    # edited per Tyler's suggestion 

Il risultato:

tc <- textConnection(' 
belongID uniqID Time Rating 
    1   101  5  0 
    1   102  4  0 
    2   103  4  0 
    2   104  3  0 
    2   105  2  5 
    3   106  4  2 
    3   107  5  0 
    3   108  5  1 ') 

Data <- read.table(tc,header=TRUE) 

do.call(rbind,lapply(split(Data,Data$belongID),getRating)) 

invia:

belongID uniqID Time Rating 
1  1 101 5  0 
2  2 105 2  5 
3  3 108 5  1 

---

EDIT: Solo per divertimento, ho fatto un'analisi comparativa così (usando rbenchmark) su un piccolo set di dati con 1000 repliche, e una grande con 10 repliche:

Il risultato:

> benchmark(Joris(Data),Tyler(Data),uniqueMax(Data), 
+   columns=c("test","elapsed","relative"), 
+   replications=1000) 
      test elapsed relative 
1  Joris(Data) 1.20 1.025641 
2  Tyler(Data) 1.42 1.213675 
3 uniqueMax(Data) 1.17 1.000000 

> benchmark(Joris(Data2),Tyler(Data2),uniqueMax(Data2), 
+   columns=c("test","elapsed","relative"), 
+   replications=10) 
       test elapsed relative 
1  Joris(Data2) 3.63 1.174757 
2  Tyler(Data2) 4.02 1.300971 
3 uniqueMax(Data2) 3.09 1.000000 

Qui ho appena finito di girare una funzione Joris() e Tyler() intorno alle nostre soluzioni, e ha creato Data2 come segue:

Data2 <- data.frame(
    belongID = rep(1:1000,each=10), 
    uniqID = 1:10000, 
    Time = sample(1:5,10000,TRUE), 
    Rating = sample(0:5,10000,TRUE) 
)