Нахождение 3 столбца с наибольшим значением в каждой строке и поместить свое имя в новом кадре данных в R

Question

У меня есть следующий кадр данных:

temp1=data.frame(id=c(1,2,3,4,5),p1=c(0,0,1,1,2),p2=c(9,2,3,5,3),p3=c(1,4,10,3,7),p4=c(4,4,7,1,10)) 

    id p1 p2 p3 p4 
    1 0 9 1 4 
    2 0 2 3 4 
    3 1 3 10 7 
    4 1 5 3 1 
    5 2 3 7 10 

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

id top1 top2 top3 
1 p2 p4 p3 
2 p4 p3 p2 
3 p3 p4 p2 
4 p2 p3 p4/p1 
5 p4 p3 p2 

в случае, если есть два одинаковых значения мы позволили поместить их в произвольном порядке.

Answer 1

library("tidyr") 
library("dplyr") 
df <- data.frame(id=c(1,2,3,4,5),p1=c(0,0,1,1,2),p2=c(9,2,3,5,3),p3=c(1,4,10,3,7),p4=c(4,4,7,1,10)) 
df2 <- gather(df,col,val,-id) 
res <- group_by(df2,id) %>% arrange(id,desc(val)) %>% summarise(top1 = first(col),top2 = nth(col,2),top3 = nth(col,3)) 

Результаты в

#  id top1 top2 top3 
# <dbl> <chr> <chr> <chr> 
# 1  1 p2 p4 p3 
# 2  2 p3 p4 p2 
# 3  3 p3 p4 p2 
# 4  4 p2 p3 p1 
# 5  5 p4 p3 p2 

следующие новой информации

res <- group_by(df2,id) %>% mutate(r=rank(-(val/sum(val)*100),ties.method = "min")) %>% arrange(id,r) %>% summarise(top1 = first(col),top2 = nth(col,2),top3 = nth(col,3)) 

приводит

#  id top1 top2 top3 
#  <dbl> <chr> <chr> <chr> 
# 1  1 p2 p4 p3 
# 2  2 p3 p4 p2 
# 3  3 p3 p4 p2 
# 4  4 p2 p3 p1 
# 5  5 p4 p3 p2 

Answer 2

Мы также можем использовать apply с rank из base R

m1 <- t(apply(temp1[-1], 1, FUN = function(x) { 
       i1 <- rank(-x, ties.method = "min") 
       i2 <- i1[i1 %in% 1:3] 
       tapply(names(i2), i2, FUN=paste, collapse="/")})) 
d1 <- setNames(cbind(temp1[1], m1), c("id", paste0("top", 1:ncol(m1)))) 
d1 
# id top1 top2 top3 
#1 1 p2 p4 p3 
#2 2 p4 p3 p2 
#3 3 p3 p4 p2 
#4 4 p2 p3 p1/p4 
#5 5 p4 p3 p2 

---

Если нам нужно, чтобы получить пропорции вместо имен столбцов

d2 <- d1 
lst <- apply(temp1[-1], 1, FUN = function(x) { 
      i1 <- rank(-x, ties.method = "min") 
      i2 <- i1[i1 %in% 1:3] 
      tapply(names(i2), i2, FUN= list)}) 

lst1 <- setNames(lapply(lst, function(x) unlist(x)), seq_len(nrow(temp1))) 

d2[-1] <- t(sapply(
      relist(unlist(lapply(seq_along(lst1), function(i) { 
      x <- temp1[i, lst1[[i]]] 
    x/sum(x) 
      })), 
    skeleton = lst), 
    function(x) sapply(x, function(y) toString(round(y,2))))) 
d2 
# id top1 top2  top3 
# 1 1 0.64 0.29  0.07 
# 2 2 0.44 0.33  0.22 
# 3 3 0.5 0.35  0.15 
# 4 4 0.5 0.3 0.1, 0.1 
# 5 5 0.5 0.35  0.15