Extract Najnowszy wpis, pod pewnym warunkiem

Question

jestem stara się uzyskać następujące zrobić:

Przykład zbioru danych:

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 

Problemem jest: chciałbym wyodrębnić Najnowszy wpis (największa wartość dla czasu) na belongsID, chyba że ta ocena to 0. Jeśli ocena najnowszego wpisu wynosi 0 jednak. Chcę pierwszy wpis z ratingiem (nie najwyższą oceną, tylko pierwsza wartość z ratingiem, który nie wynosi zero). Jeśli wszystkie inne wpisy są równe zero, należy wybrać najnowszą.

Wynik końcowy powinien być niż:

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

Zbiór danych jest dość duży i jest sortowana według belongID. Nie jest ono uporządkowane według czasu, więc nowsze wpisy mogą pochodzić z starszych wpisów o tym samym należącym identyfikatorze.

Bez konieczności „0 rating” ograniczenie, kiedyś następującą funkcję do obliczania najnowszy wpis:

>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 
    ) 
    ) 
} 

nie wiem jak włączyć się „0 rating” ograniczenie.

EDIT: kontynuacją pytanie:

Czy ktoś wie jak funkcja getRating powinny być zmienione, jeśli nie tylko ocena zera, ale więcej ocen muszą być brane pod uwagę (na przykład 0,1,4 i 5)? W ten sposób przypisać do najnowszych, chyba że Ocena 0 lub 1 lub 4 lub 5? Jeśli Ocena wynosi 0,1,4,5, przypisz do najnowszego wpisu z inną oceną. Jeśli wszystkie oceny wynoszą 0,1,4 lub 5, przypisz je do ostatnich. Próbowałem następujących, ale to nie działa:

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

Oto rozwiązanie, które wykorzystuje data.table dla ułatwienia filtrowania i wykonywania mojej funkcji getRecentRow oddzielnie dla każdego 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

Jedna sugestia będzie:

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

Oto mój pęknięcie na niego (ciekawy problem):

Reading swoje dane:

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) 

wyodrębnieniu wiersze, o które pytałeś:

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 

co daje:

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

EDIT Przy tak wielu ludzi odpowiadających ten problem (zabawy rozwiązywać IMHO) to błagał o teście 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 

I wykres:

Answer 4

EDIT:

Ponieważ prędkość jest głównym problemem, ja edytowane moją sztuczkę do swojego pierwotnego roztworu, co przekłada się mniej więcej tak:

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 
    ) 
    ) 
} 

moje oryginalne rozwiązania, które jest nieco bardziej czytelny niż poprzedni:

# 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 

Wynik:

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)) 

dać:

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

---

EDIT: Tak dla zabawy, zrobiłem benchmarking oraz (za pomocą rbenchmark) na małym zbiorze danych z 1000 powtórzeniach, a jeden duży z 10 powtórzeniami:

Wynik:

> 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 

Tutaj po prostu owinięty funkcję Joris() i Tyler() wokół naszych rozwiązań i stworzył dane2 następująco:

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