Utwórz macierz kwadratowej przyległości z data.frame lub data.table

Question

Próbuję zbudować kwadratową przyległość matrix z data.table. Oto powtarzalne przykładem tego, co już mam:

require(data.table) 
require(plyr) 
require(reshape2) 
# Build a mock data.table 
dt <- data.table(Source=as.character(rep(letters[1:3],2)),Target=as.character(rep(letters[4:2],2))) 
dt 
# Source Target 
#1:  a  d 
#2:  b  c 
#3:  c  b 
#4:  a  d 
#5:  b  c 
#6:  c  b 
sry <- ddply(dt, .(Source,Target), summarize, Frequency=length(Source)) 
sry 
# Source Target Frequency 
#1  a  d   2 
#2  b  c   2 
#3  c  b   2 
mtx <- as.matrix(dcast(sry, Source ~ Target, value.var="Frequency", fill=0)) 
rownames(mtx) <- mtx[,1] 
mtx <- mtx[,2:ncol(mtx)] 
mtx 
# b c d 
#a "0" "0" "2" 
#b "0" "2" "0" 
#c "2" "0" "0" 

Teraz, to jest bardzo zbliżony do tego, co chcę dostać, oprócz tego, że chciałbym, aby wszystkie węzły reprezentowane w obu wymiarach, jak:

a b c d 
a 0 0 0 2 
b 0 0 2 0 
c 0 2 0 0 
d 0 0 0 0 

Należy zauważyć, że pracuję nad dość dużymi danymi, więc chciałbym znaleźć skuteczne rozwiązanie tego problemu.

Dziękuję za pomoc.

---

ROZWIĄZANIA (Edit):

Biorąc pod uwagę jakość oferowanych rozwiązań i wielkość moim zbiorze, ja benchmarkingowi wszystkie rozwiązania.

#The bench was made with a 1-million-row sample from my original dataset 
library(data.table) 
aa <- fread("small2.csv",sep="^") 
dt <- aa[,c(8,9),with=F] 
colnames(dt) <- c("Source","Target") 
dim(dt) 
#[1] 1000001  2 
levs <- unique(unlist(dt, use.names=F)) 
length(levs) 
#[1] 2222 

Biorąc pod uwagę dane, sygnał wyjściowy jest 2222 * 2222 macierzy (2222 * 2223 są rozwiązania, w których pierwsza kolumna zawiera wierszowi nazwy również oczywiście dopuszczalne).

# Ananda Mahto's first solution 
am1 <- function() { 
    table(dt[, lapply(.SD, factor, levs)]) 
} 
dim(am1()) 
#[1] 2222 2222 

# Ananda Mahto's second solution 
am2 <- function() { 
    as.matrix(dcast(dt[, lapply(.SD, factor, levs)], Source~Target, drop=F, value.var="Target", fun.aggregate=length)) 
} 
dim(am2()) 
#[1] 2222 2223 

library(dplyr) 
library(tidyr) 
# Akrun's solution 
akr <- function() { 
    dt %>% 
     mutate_each(funs(factor(., levs))) %>% 
     group_by(Source, Target) %>% 
     tally() %>% 
     spread(Target, n, drop=FALSE, fill=0) 
} 
dim(akr()) 
#[1] 2222 2223 

library(igraph) 
# Carlos Cinelli's solution 
cc <- function() { 
    g <- graph_from_data_frame(dt) 
    as_adjacency_matrix(g) 
} 
dim(cc()) 
#[1] 2222 2222 

a wynik benchmarku jest ...

library(rbenchmark) 
benchmark(am1(), am2(), akr(), cc(), replications=75) 
# test replications elapsed relative user.self sys.self user.child sys.child 
# 1 am1()   75 15.939 1.000 15.636 0.280   0   0 
# 2 am2()   75 111.558 6.999 109.345 1.616   0   0 
# 3 akr()   75 43.786 2.747 42.463 1.134   0   0 
# 4 cc()   75 46.193 2.898 45.532 0.563   0   0 

Answer 1

Brzmi jak jesteś po prostu patrząc na table, ale należy upewnić się, że obie kolumny mają te same poziomy Opóźnienie:

levs <- unique(unlist(dt, use.names = FALSE)) 
table(lapply(dt, factor, levs)) 
#  Target 
# Source a b c d 
#  a 0 0 0 2 
#  b 0 0 2 0 
#  c 0 2 0 0 
#  d 0 0 0 0 

---

Nie wiem, czy oferowałoby to jakąkolwiek poprawę szybkości, ale można również użyć dcast z "data.table":

dcast(lapply(dt, factor, levs), Source ~ Target, drop = FALSE, 
     value.var = "Target", fun.aggregate = length) 

Answer 2

Możemy użyć dplyr/tidyr

library(dplyr) 
library(tidyr) 
dt %>% 
    mutate_each(funs(factor(., letters[1:4]))) %>% 
    group_by(Source, Target) %>% 
    tally() %>% 
    spread(Target, n, drop=FALSE, fill=0) 
# Source  a  b  c  d 
# (fctr) (dbl) (dbl) (dbl) (dbl) 
#1  a  0  0  0  2 
#2  b  0  0  2  0 
#3  c  0  2  0  0 
#4  d  0  0  0  0 

Answer 3

Można również użyć igraph. Skoro powiedział, że masz do czynienia z dużymi danych igraph ma tę zaletę, że wykorzystuje macierze rzadkie:

library(igraph) 
g <- graph_from_data_frame(dt) 
as_adjacency_matrix(g) 
4 x 4 sparse Matrix of class "dgCMatrix" 
    a b c d 
a . . . 2 
b . . 2 . 
c . 2 . . 
d . . . .