R: из широкого списка тегов в длинный список соединений

Question

у меня есть фрейм данных с индивидуальными предпочтениями для тегов обозначенного 1 или 0:

mydata <- data.frame(
    ID = c(1:4), 
    tag1 = c(1, 0, 1, 0), 
    tag2 = c(0, 0, 0, 0), 
    tag3 = c(1, 0, 1, 1), 
    tag4 = c(1, 1, 0, 1), 
    tag5 = c(0, 1, 1, 1) 
) 

(Мой данные имеют гораздо больше тегов, чем просто 5)

Для сетевой диаграммы я ищу способ преобразования широкоформатных данных в длинный список вхождений между каждой парой тега = 1 в строке. Для приведенного выше примера это будет выглядеть следующим образом:

mydata2 <- data.frame(
    ID = c(1,1,1,2,3,3,3,4,4,4), 
    target = c("tag1","tag1","tag3","tag4","tag1","tag1","tag3","tag3","tag3","tag4"), 
    source = c("tag3","tag4","tag4","tag5","tag3","tag5","tag5","tag4","tag5","tag5") 
) 

Я хотел использовать tidyr «s gather() для этого, но не знает, как использовать его для пар колонн. Я мог бы просто создавать новые переменные для каждой пары и собирать их, но для длинного списка тегов это становится непрактичным. Есть ли более элегантный способ сделать это? Или даже конкретная функция?

Answer 1

Вот ответ, основанный на apply() (для применения функции по каждой строке) и combn(... , 2), чтобы найти все пары.

ll <- apply(mydata,1, 
       function(x){ 
        if(sum(x[-1])<2) 
         # otherwise you'll get errors if there are less than two 
         # elements selected 
         return(NULL) 

        tmp = combn(names(x[-1])[ !!(x[-1]) ],# see note below 
           2) # pairs 

        # the return value 
        data.frame(ID = x['ID'], 
          target = tmp[1,], 
          source = tmp[2,], 
          # otherwise you get names warning, which is 
          # annoying.j 
          check.names=FALSE) 
       }) 

# bind the individual results together 
do.call(rbind,ll) 

#> ID target source 
#> 1 tag1 tag3 
#> 1 tag1 tag4 
#> 1 tag3 tag4 
#> 2 tag4 tag5 
#> 3 tag1 tag3 
#> 3 tag1 tag5 
#> 3 tag3 tag5 
#> 4 tag3 tag4 
#> 4 tag3 tag5 
#> 4 tag4 tag5 

Обратите внимание, что !!x стандартный трюк JavaScript, чтобы принуждать значения логического, который работает в R тоже.

Answer 2

Возможность использования tidyr/dplyr

library(tidyr) 
library(dplyr) 

tD <- gather(mydata, Var, Val, -ID) %>% #change wide to long format 
          filter(Val!=0) %>% #remove rows with 0 Val 
          select(-Val) #remove the Val column 

tD1 <- left_join(tD, tD, by='ID') %>% #self join with the created data 
         filter(Var.x!=Var.y) %>% #remove rows that are same 
         arrange(ID, Var.x, Var.y) #to order (if needed) 

tD1[-1] <- t(apply(tD1[-1], 1, sort)) #sort the rows of 2nd and 3rd columns 
res <- unique(tD1, by='ID') %>% #keep only unique rows by "ID" 
       rename(target=Var.x, source=Var.y) #rename the column names 
row.names(res) <- NULL #change the rownames to NULL 
#checking the results with the expected result 
mydata2[2:3] <- lapply(mydata2[2:3], as.character) 
all.equal(mydata2, res,check.attributes=FALSE) 
#[1] TRUE 

res 
# ID target source 
#1 1 tag1 tag3 
#2 1 tag1 tag4 
#3 1 tag3 tag4 
#4 2 tag4 tag5 
#5 3 tag1 tag3 
#6 3 tag1 tag5 
#7 3 tag3 tag5 
#8 4 tag3 tag4 
#9 4 tag3 tag5 
#10 4 tag4 tag5 

Answer 3

Самый прямой подход, который я могу думать о том, чтобы использовать melt из "reshape2", а затем использовать combn и melt снова:

library(reshape2) 
M <- melt(mydata, id.vars = "ID")    ## Melt the dataset 
M2 <- M[M$value > 0, 1:2]      ## Subset the rows of interest 
melt(
    lapply(
    split(M2$variable, M2$ID), function(x) { 
     data.frame(t(combn(as.character(x), 2))) ## Inside, we use combn 
    }), id.vars = c("X1", "X2"))    ## We know we'll just have X1 and X2 
#  X1 X2 L1 
# 1 tag1 tag3 1 
# 2 tag1 tag4 1 
# 3 tag3 tag4 1 
# 4 tag4 tag5 2 
# 5 tag1 tag3 3 
# 6 tag1 tag5 3 
# 7 tag3 tag5 3 
# 8 tag3 tag4 4 
# 9 tag3 tag5 4 
# 10 tag4 tag5 4 

Или избежать второй melt примерно:

library(reshape2) 
M <- melt(mydata, id.vars = "ID") 
M2 <- M[M$value > 0, 1:2] 


MS <- split(M2$variable, M2$ID) 
do.call(rbind, 
     lapply(names(MS), function(x) { 
      data.frame(ID = x, t(combn(as.character(MS[[x]]), 2))) 
     })) 

Answer 4

Вот один из способов использования data.table, хотя с использованием невозможен функция vecseq.

require(data.table) 
foo <- function(x) { 
    lx = length(x) 
    idx1 = data.table:::vecseq(rep.int(1L, lx), (lx-1L):0L, NULL) 
    idx2 = data.table:::vecseq(c(seq_len(lx)[-1L], 1L), (lx-1L):0L, NULL) 
    list(x[idx1], x[idx2]) 
} 

melt(dt, id="ID")[value == 1L, foo(variable), by=ID] 
#  ID V1 V2 
# 1: 1 tag1 tag3 
# 2: 1 tag3 tag4 
# 3: 1 tag1 tag4 
# 4: 3 tag1 tag3 
# 5: 3 tag3 tag5 
# 6: 3 tag1 tag5 
# 7: 4 tag3 tag4 
# 8: 4 tag4 tag5 
# 9: 4 tag3 tag5 
# 10: 2 tag4 tag5