Извлечение индексов для строк фрейма данных, которые имеют значение MAX для именованного поля

Question

У меня есть довольно большой фрейм данных, и мне нужен хороший способ (объяснено ниже), чтобы извлечь индексы для строк, которые имеют максимальные значения для данного поля, в пределах определенного набора меток. Чтобы объяснить это немного лучше, вот пример фрейма данных из 10 строк:

      value label
1  5.531637     D
2  5.826498     A
3  8.866210     A
4  1.387978     C
5  8.128505     C
6  7.391311     B
7  1.829392     A
8  4.373273     D
9  7.380244     A
10 6.157304     D

Для генерации:

structure(list(value = c(5.531637, 5.826498, 8.86621, 1.387978, 8.128505, 
7.391311, 1.829392, 4.373273, 7.380244, 6.157304), 
label = c("D", "A", "A", "C", "C", "B", "A", "D", "A", "D")), 
.Names = c("value", "label"), class = "data.frame", row.names = c(NA, -10L))

Если я хочу узнать, что такое индекс для строк с максимальным значением для метки, я сейчас использую следующий код:

idx <- sapply(split(1:nrow(d), d$label), function(x) {
  x[which.max(d[x,"value"])]
})

Генерация этого ответа:

A  B  C  D 
3  6  5 10

Я также играл с ddply, но пока не нашел лучшего способа сделать это. В данном случае под словом «лучше» я подразумеваю более быструю (ddply довольно медленная, и то, что я использую в настоящее время, не сильно отстает), а также более элегантная, поскольку приведенное выше решение кажется мне слишком многословным.

Answer 1

Прежде всего: вы можете увеличить скорость, используя:

idx <- sapply(split(seq_len(nrow(d)), d$label), function(x) {
      x[which.max(d$value[x])]})

Для 100k data.frame, на моей машине это в 5 раз быстрее, чем d[x,"value"] версия.

Для больших data.frame и многих ярлыков вы можете использовать аналогичный метод, который я опубликовал в предыдущем вопросе :

dd <- d[i<-order(d$label, d$value),] # dd is sorted by label and value
ind <- c(dd$label[-1] != dd$label[-n], TRUE)
idx <- setNames(seq_len(nrow(d))[i][ind], dd$label[ind])

---

edit: A moreэффективное решение с использованием трюка от Мартин Морган ответ :

v <- d$label[i<-order(d$value)] # we need only label, and with Martin
                                # trick sorting over label is not needed
ind <- !duplicated(v, fromLast=TRUE) # it finds last (max) occurrence of label
idx <- setNames(seq_len(nrow(d))[i][ind], v[ind])

ПРИМЕЧАНИЕ: порядок конечного вектора отличается.

Это зависит от вашей фактической структуры данныхно вы должны получить хорошее ускорение:

Время:

# NOTE: different machine, so timing differ from previous
set.seed(6025051)
n <- 100000; k <- 20000
d <- data.frame(value=rnorm(n), 
    label=sample(paste("A",seq_len(k),sep="_"), n, replace=TRUE))

system.time(
    idx_1 <- sapply(split(1:nrow(d), d$label), function(x) {
        x[which.max(d[x,"value"])]})
)
# user  system elapsed 
# 1.30    0.02    1.31 
system.time(
    idx_1b <- sapply(split(seq_len(nrow(d)), d$label), function(x) {
        x[which.max(d$value[x])]})
)
# user  system elapsed 
# 0.23    0.00    0.23
all.equal(idx_1, idx_1b)
# [1] TRUE
system.time({
    dd <- d[i<-order(d$label, d$value),]
    ind <- c(dd$label[-1] != dd$label[-n], TRUE)
    idx_2 <- setNames(seq_len(nrow(d))[i][ind],dd$label[ind])
})
# user  system elapsed 
# 0.19    0.00    0.19 
all.equal(idx_1, idx_2)
# [1] TRUE

---

новое решение

system.time({
    v <- d$label[i<-order(d$value)]
            ind <- !duplicated(v, fromLast=TRUE)
            idx_3 <- setNames(seq_len(nrow(d))[i][ind], v[ind])
})
# user  system elapsed 
# 0.05    0.00    0.04 
all.equal(sort(idx_1), sort(idx_3))
# [1] TRUE

Answer 2

Вы можете ускорить его немного быстрее, написав его на C;этот вопрос дал мне повод попробовать Rcpp и inline;Я уверен, что код мог бы быть написан лучше, так как это мой первый шаг.

Вот код:

library(Rcpp)
library(inline)

src <- '
  Rcpp::NumericVector xx(x);
  Rcpp::IntegerVector gg(g);
  Rcpp::NumericVector mx(m);
  Rcpp::IntegerVector wh(w);
  int nx = xx.size();
  for(int i = 0; i < nx; i++) {
    if( xx[i] > mx[gg[i]-1] ) {
      mx[gg[i]-1] = xx[i];
      wh[gg[i]-1] = i+1;
    }
  }
  return wh;
'

fun <- cxxfunction(signature(x="numeric", g="integer", 
                             m="numeric", w="integer"), 
                   src, plugin="Rcpp")

maxg <- function(x, g) {
  g <- factor(g)
  n <- nlevels(g)
  out <- fun(x=x, g=as.integer(g), m=rep(-Inf, n), w=integer(n))
  names(out) <- levels(g)
  out
}

Используя данные Марека,

set.seed(6025051)
n <- 100000; k <- 20000
d <- data.frame(
  value=rnorm(n),
  label=sample(paste("A", seq_len(k), sep="_"), n, replace=TRUE)
)

этопримерно в 4 раза быстрее, чем решение Marek $ в моей системе.

system.time({
    idx_1b <- sapply(split(1:nrow(d), d$label), function(x) {
        x[which.max(d$value[x])]})
})
#   user  system elapsed 
#  0.209   0.000   0.208 

system.time({
  idx_c <- maxg(d$value, d$label)
})
#   user  system elapsed 
#  0.049   0.000   0.048 

all.equal(idx_1b, idx_c)
# [1] TRUE

Интересно, что дополнительное решение Marek (кстати, я пока не понимаю, кстати), лишь незначительно быстрее, чем решение $ намоя система.

system.time({
  dd <- d[i <- order(d$label, d$value),]
  ind <- c(dd$label[-1] != dd$label[-n], TRUE)
  idx_2 <- setNames(seq_len(nrow(d))[i][ind],dd$label[ind])
})
#   user  system elapsed 
#  0.198   0.001   0.199 

Answer 3

Возможно, это может помочь:

tapply(seq(dim(d)[1]), d$label, function(rns){rns[which.max(d$value[rns])]} )

(примечание: я получил этот трюк из кода 'by')