COMMunication
RESearch.NET

This page is read only. You can view the source, but not change it. Ask your administrator if you think this is wrong.
====== Data ======
{{:r:featuring.csv}}
{{:r:actors.csv}}
{{:r:movies.csv}}
{{:r:Padgett.csv}}
{{:r:Padgw.csv}}
====== Hawthorne study ======
{{:r:davis.women.club.csv}}
<code>
library(tidiverse)
sd <- read.csv("http://commres.net/wiki/_media/r/davis.women.club.csv")
head(sd)

g <- graph.data.frame(sd, directed=FALSE)
bipartite.mapping(g)

plot(g)

V(g)$color <- ifelse(V(g)$type, "lightblue", "salmon")
V(g)$shape <- ifelse(V(g)$type, "circle", "square")
E(g)$color <- "lightgray"
plot(g, vertex.label.cex = 1.2, vertex.label.color = "black")

</code>
{{:r:pasted:20230611-224359.png}}
{{:r:pasted:20230611-225104.png}}

<code>
V(g)$type <- bipartite_mapping(g)$type
types <- V(g)$type      
deg <- degree(g)
bet <- betweenness(g)
clos <- closeness(g)
eig <- eigen_centrality(g)$vector

deg
bet
clos
eig

cent_df <- data.frame(types, deg, bet, clos, eig)
cent_df[order(cent_df$type, decreasing = TRUE),] 
</code>
<code>
> types <- V(g)$type      
> deg <- degree(g)
> bet <- betweenness(g)
> clos <- closeness(g)
> eig <- eigen_centrality(g)$vector
> 
> deg
   EVELYN     LAURA   THERESA    BRENDA CHARLOTTE   FRANCES   ELEANOR 
        8         7         8         7         4         4         4 
    PEARL      RUTH     VERNE     MYRNA KATHERINE    SYLVIA      NORA 
        3         4         4         4         6         7         8 
    HELEN   DOROTHY    OLIVIA     FLORA        E1        E2        E3 
        7         4         2         2         3         3         6 
       E4        E5        E6        E8        E9        E7       E12 
        4         8         8        14        12        10         7 
      E10       E13       E14       E11 
        6         4         4         4 
> bet
   EVELYN     LAURA   THERESA    BRENDA CHARLOTTE   FRANCES   ELEANOR 
  42.7600   22.8565   38.7393   22.0119    4.7279    4.7516    4.1357 
    PEARL      RUTH     VERNE     MYRNA KATHERINE    SYLVIA      NORA 
   2.9763    7.3609    6.3676    5.9435   16.2889   25.2987   43.9378 
    HELEN   DOROTHY    OLIVIA     FLORA        E1        E2        E3 
  30.7265    5.9435    2.0866    2.0866    0.9737    0.9441    8.1978 
       E4        E5        E6        E8        E9        E7       E12 
   3.4530   16.9812   28.0103  108.2617   96.2295   58.0969   10.2354 
      E10       E13       E14       E11 
   6.8186    1.8892    1.8892    9.0194 
> clos
   EVELYN     LAURA   THERESA    BRENDA CHARLOTTE   FRANCES   ELEANOR 
  0.01667   0.01515   0.01667   0.01515   0.01250   0.01389   0.01389 
    PEARL      RUTH     VERNE     MYRNA KATHERINE    SYLVIA      NORA 
  0.01389   0.01471   0.01471   0.01429   0.01515   0.01613   0.01667 
    HELEN   DOROTHY    OLIVIA     FLORA        E1        E2        E3 
  0.01613   0.01429   0.01220   0.01220   0.01190   0.01190   0.01282 
       E4        E5        E6        E8        E9        E7       E12 
  0.01220   0.01351   0.01562   0.01923   0.01786   0.01667   0.01316 
      E10       E13       E14       E11 
  0.01282   0.01220   0.01220   0.01220 
> eig
   EVELYN     LAURA   THERESA    BRENDA CHARLOTTE   FRANCES   ELEANOR 
   0.6225    0.5735    0.6934    0.5801    0.3081    0.3872    0.4287 
    PEARL      RUTH     VERNE     MYRNA KATHERINE    SYLVIA      NORA 
   0.3453    0.4508    0.4360    0.3891    0.4796    0.5882    0.5599 
    HELEN   DOROTHY    OLIVIA     FLORA        E1        E2        E3 
   0.5058    0.3891    0.1394    0.1394    0.2586    0.2750    0.4607 
       E4        E5        E6        E8        E9        E7       E12 
   0.3209    0.5888    0.6100    1.0000    0.7618    0.7460    0.4873 
      E10       E13       E14       E11 
   0.4239    0.3106    0.3106    0.1957 
> 
> cent_df <- data.frame(types, deg, bet, clos, eig)
> cent_df[order(cent_df$type, decreasing = TRUE),] 
          types deg      bet    clos    eig
E1         TRUE   3   0.9737 0.01190 0.2586
E2         TRUE   3   0.9441 0.01190 0.2750
E3         TRUE   6   8.1978 0.01282 0.4607
E4         TRUE   4   3.4530 0.01220 0.3209
E5         TRUE   8  16.9812 0.01351 0.5888
E6         TRUE   8  28.0103 0.01562 0.6100
E8         TRUE  14 108.2617 0.01923 1.0000
E9         TRUE  12  96.2295 0.01786 0.7618
E7         TRUE  10  58.0969 0.01667 0.7460
E12        TRUE   7  10.2354 0.01316 0.4873
E10        TRUE   6   6.8186 0.01282 0.4239
E13        TRUE   4   1.8892 0.01220 0.3106
E14        TRUE   4   1.8892 0.01220 0.3106
E11        TRUE   4   9.0194 0.01220 0.1957
EVELYN    FALSE   8  42.7600 0.01667 0.6225
LAURA     FALSE   7  22.8565 0.01515 0.5735
THERESA   FALSE   8  38.7393 0.01667 0.6934
BRENDA    FALSE   7  22.0119 0.01515 0.5801
CHARLOTTE FALSE   4   4.7279 0.01250 0.3081
FRANCES   FALSE   4   4.7516 0.01389 0.3872
ELEANOR   FALSE   4   4.1357 0.01389 0.4287
PEARL     FALSE   3   2.9763 0.01389 0.3453
RUTH      FALSE   4   7.3609 0.01471 0.4508
VERNE     FALSE   4   6.3676 0.01471 0.4360
MYRNA     FALSE   4   5.9435 0.01429 0.3891
KATHERINE FALSE   6  16.2889 0.01515 0.4796
SYLVIA    FALSE   7  25.2987 0.01613 0.5882
NORA      FALSE   8  43.9378 0.01667 0.5599
HELEN     FALSE   7  30.7265 0.01613 0.5058
DOROTHY   FALSE   4   5.9435 0.01429 0.3891
OLIVIA    FALSE   2   2.0866 0.01220 0.1394
FLORA     FALSE   2   2.0866 0.01220 0.1394
> 
</code>
<code>
V(g)$size <- degree(g)
V(g)$label.cex <- degree(g) * 0.2

windowsFonts(d2coding = windowsFont("D2Coding"))
windowsFonts(lucida = windowsFont("Lucida Console"))
windowsFonts(courrier = windowsFont("Courrier New"))

shape <- c("circle", "square")
fnts <- c("d2coding", "lucida")

plot(g, layout = layout_with_graphopt,
     vertex.shape= shape[as.numeric(V(g)$type) + 1],
     vertex.label.family= fnts[as.numeric(V(g)$type)+1]
)

</code>
{{:r:pasted:20230611-232937.png}}
<code>
bipartite_matrix <- as_incidence_matrix(g)
bipartite_matrix
</code>

<code>
> bipartite_matrix <- as_incidence_matrix(g)
> 
> bipartite_matrix
          E1 E2 E3 E4 E5 E6 E8 E9 E7 E12 E10 E13 E14 E11
EVELYN     1  1  1  1  1  1  1  1  0   0   0   0   0   0
LAURA      1  1  1  0  1  1  1  0  1   0   0   0   0   0
THERESA    0  1  1  1  1  1  1  1  1   0   0   0   0   0
BRENDA     1  0  1  1  1  1  1  0  1   0   0   0   0   0
CHARLOTTE  0  0  1  1  1  0  0  0  1   0   0   0   0   0
FRANCES    0  0  1  0  1  1  1  0  0   0   0   0   0   0
ELEANOR    0  0  0  0  1  1  1  0  1   0   0   0   0   0
PEARL      0  0  0  0  0  1  1  1  0   0   0   0   0   0
RUTH       0  0  0  0  1  0  1  1  1   0   0   0   0   0
VERNE      0  0  0  0  0  0  1  1  1   1   0   0   0   0
MYRNA      0  0  0  0  0  0  1  1  0   1   1   0   0   0
KATHERINE  0  0  0  0  0  0  1  1  0   1   1   1   1   0
SYLVIA     0  0  0  0  0  0  1  1  1   1   1   1   1   0
NORA       0  0  0  0  0  1  0  1  1   1   1   1   1   1
HELEN      0  0  0  0  0  0  1  0  1   1   1   1   1   1
DOROTHY    0  0  0  0  0  0  1  1  0   1   1   0   0   0
OLIVIA     0  0  0  0  0  0  0  1  0   0   0   0   0   1
FLORA      0  0  0  0  0  0  0  1  0   0   0   0   0   1
> 
</code>
===== stu x class 처럼 분석한 예 =====

<code>
actor_matrix <- bipartite_matrix %*% t(bipartite_matrix)
event_matrix <- t(bipartite_matrix) %*% bipartite_matrix


diag(actor_matrix) <- 0
actor_matrix
actor_matrix_cff_2 <- ifelse(actor_matrix > 2, actor_matrix, 0) # cuttoff 3 below
actor_matrix_cff_3 <- ifelse(actor_matrix > 3, actor_matrix, 0) # cuttoff 3 below

actor_g <- graph_from_adjacency_matrix(actor_matrix, 
                                       mode = "undirected", 
                                       weighted = TRUE)

actor_g_cff_2 <- graph_from_adjacency_matrix(actor_matrix_cff_2, 
                                             mode = "undirected", 
                                             weighted = TRUE)
actor_g_cff_3 <- graph_from_adjacency_matrix(actor_matrix_cff_3, 
                                             mode = "undirected", 
                                             weighted = TRUE)

V(actor_g)$size <- betweenness(actor_g)
V(actor_g_cff_2)$size <- betweenness(actor_g_cff_2)
V(actor_g_cff_3)$size <- betweenness(actor_g_cff_3)
V(actor_g)$label.cex <- betweenness(actor_g) * 0.2
V(actor_g_cff_2)$label.cex <- betweenness(actor_g_cff_2) * 0.1
V(actor_g_cff_3)$label.cex <- betweenness(actor_g_cff_3) * 0.4

actor_g
actor_g_cff_2
actor_g_cff_3

event_g <- graph_from_adjacency_matrix(event_matrix, 
                                       mode = "undirected", 
                                       weighted = TRUE)
event_g

windowsFonts(d2coding = windowsFont("D2Coding"))
windowsFonts(lucida = windowsFont("Lucida Console"))

shape <- c("circle", "square")
fnts <- c("d2coding", "lucida")

plot(actor_g,      
     vertex.shape= shape[as.numeric(V(g)$type) + 1],
     vertex.label.family= fnts[as.numeric(V(g)$type)+1],
     edge.color="red", edge.width=3
) 
plot(actor_g_cff_2,
     vertex.shape= shape[as.numeric(V(g)$type) + 1],
     vertex.label.family= fnts[as.numeric(V(g)$type)+1],
     edge.color="red", edge.width=3
) 
plot(actor_g_cff_3,
     vertex.shape= shape[as.numeric(V(g)$type) + 1],
     vertex.label.family= fnts[as.numeric(V(g)$type)+1],
     edge.color="red", edge.width=3
) 
</code>

[{{:r:pasted:20230612-081851.png|actor_g}}] \\
[{{:r:pasted:20230612-082040.png|actor_g_cff_2}}] \\
[{{:r:pasted:20230612-082055.png|actor_g_cff_3}}]


===== 다른 방법 =====

<code>
library(ade4)
bipartite_matrix <- as_incidence_matrix(g)  # Extract the matrix

# Method #2 is "simple matching"
women_match <- dist.binary(bipartite_matrix, method=2, upper=TRUE, diag = FALSE) 
event_match <- dist.binary(t(bipartite_matrix), method=2, upper=TRUE, diag = FALSE) 

women_match <- as.matrix(women_match)
matching_women <- ifelse(women_match>0.8, 1, 0)
matching_women

match_women <- graph_from_adjacency_matrix(matching_women, 
                                           mode = "undirected")
plot(match_women)
</code>

<code>
bipartite_matrix <- as_incidence_matrix(g)  # Extract the matrix

women_r <- cor(t(bipartite_matrix))
event_r <- cor(bipartite_matrix)

women_r <- as.matrix(women_r)   
women_r          
# Look at the matrix before you binarize

r_women <- ifelse(women_r>0.6, 1, 0)    # Binarize 
diag(r_women) <- 0
r_women    # Take a look at the matrix if you like

# Create an igraph network
ir_women <- graph_from_adjacency_matrix(r_women,    
                                          mode = "undirected")
plot(ir_women)
</code>
{{:r:pasted:20230612-025040.png}}

<code>
library(psych)

bipartite_matrix <- as_incidence_matrix(g)  # Extract the matrix

women_Q <-YuleCor(t(bipartite_matrix))$rho
event_Q <-YuleCor(bipartite_matrix)$rho

women_Q <- as.matrix(women_Q) 
women_Q  # Look at the matrix before you binalize

Q_women <- ifelse(women_Q>0.9, 1, 0) # Binarize
diag(Q_women)<-0
# Q_women    # Take a look at the matrix

YQ_women <- graph_from_adjacency_matrix(Q_women,     # Create an igraph network
                    mode = "undirected")
plot(YQ_women)
</code>
{{:r:pasted:20230611-235802.png}}
====== Actors network ======
http://rpubs.com/wctucker/302110


====== e.g., ======
<file csv featuring.csv>
from,to,friendship,advice,gender
아이유,G-DRAGON,8,6,2
에픽하이,아이유,4,10,1
에픽하이,오혁,5,5,1
아이유,오혁,2,5,2
HIGH4,아이유,5,9,1
에픽하이,MINO,8,4,1
에픽하이,사이먼 도미닉,9,8,1
에픽하이,더콰이엇,2,5,1
에픽하이,수현,8,6,1
MINO,사이먼 도미닉,3,5,1
MINO,더콰이엇,6,5,1
사이먼 도미닉,더콰이엇,9,10,1

</file>


<code>
## A simple example with a couple of actors
## The typical case is that these tables are read in from files....
actors2 <- data.frame(name=c("Alice", "Bob", "Cecil", "David","Esmeralda"),
                      age=c(48,33,45,34,21),
                      gender=c("F","M","F","M","F"))
relations <- data.frame(
    from=c("Bob", "Cecil", "Cecil", "David", "David", "Esmeralda"),
    to=c("Alice", "Bob", "Alice", "Alice", "Bob", "Alice"),
    same.dept=c(FALSE,FALSE,TRUE,FALSE,FALSE,TRUE),
    friendship=c(4,5,5,2,1,1), advice=c(4,5,5,4,2,3))

g <- graph_from_data_frame(relations, directed=TRUE, vertices=actors)

print(g, e=TRUE, v=TRUE)

## The opposite operation
as_data_frame(g, what="vertices")
as_data_frame(g, what="edges")
</code>

위에서 
  - 성별에 따라서 색을 달리하여 plot을 그려보라.
  - department에 따라서 색을 달리하는 것을 더하여 plot를 그려보라.
  - betweenness가 가장 큰 인물은?

====== Featuring ======
<file csv feat.csv>
from,to,friendship,advice,gender
아이유,GDRAGON,8,6,2
에픽하이,아이유,4,10,1
에픽하이,오혁,5,5,1
아이유,오혁,2,5,2
HIGH4,아이유,5,9,1
에픽하이,MINO,8,4,1
에픽하이,사이먼 도미닉,9,8,1
에픽하이,더콰이엇,2,5,1
에픽하이,수현,8,6,1
MINO,사이먼 도미닉,3,5,1
MINO,더콰이엇,6,5,1
사이먼 도미닉,더콰이엇,9,10,1
</file>

<code>
feat <- read.csv("http://commres.net/wiki/_media/r/featuring.csv")
feat
g <- graph_from_data_frame(feat)
g
plot(g)
V(g)
E(g)
</code>

<code>
 feat <- read.csv("http://commres.net/wiki/_media/r/featuring.csv")
> feat
            from            to friendship advice
1         아이유      G-DRAGON          8      6
2       에픽하이        아이유          4     10
3       에픽하이          오혁          5      5
4         아이유          오혁          2      5
5          HIGH4        아이유          5      9
6       에픽하이          MINO          8      4
7       에픽하이 사이먼 도미닉          9      8
8       에픽하이      더콰이엇          2      5
9       에픽하이          수현          8      6
10          MINO 사이먼 도미닉          3      5
11          MINO      더콰이엇          6      5
12 사이먼 도미닉      더콰이엇          9     10
> g <- graph_from_data_frame(feat)
> g
IGRAPH e7c59b8 DN-- 9 12 -- 
+ attr: name (v/c), friendship (e/n), advice (e/n)
+ edges from e7c59b8 (vertex names):
 [1] 아이유       ->G-DRAGON      에픽하이     ->아이유        에픽하이     ->오혁          아이유       ->오혁         
 [5] HIGH4        ->아이유        에픽하이     ->MINO          에픽하이     ->사이먼 도미닉 에픽하이     ->더콰이엇     
 [9] 에픽하이     ->수현          MINO         ->사이먼 도미닉 MINO         ->더콰이엇      사이먼 도미닉->더콰이엇     
> plot(g)
> V(g)
+ 9/9 vertices, named, from e7c59b8:
[1] 아이유        에픽하이      HIGH4         MINO          사이먼 도미닉 G-DRAGON      오혁          더콰이엇     
[9] 수현         
> E(g)
+ 12/12 edges from e7c59b8 (vertex names):
 [1] 아이유       ->G-DRAGON      에픽하이     ->아이유        에픽하이     ->오혁          아이유       ->오혁         
 [5] HIGH4        ->아이유        에픽하이     ->MINO          에픽하이     ->사이먼 도미닉 에픽하이     ->더콰이엇     
 [9] 에픽하이     ->수현          MINO         ->사이먼 도미닉 MINO         ->더콰이엇      사이먼 도미닉->더콰이엇     
> 
</code>


<code>
data.frame(V(g)$name)
      V.g..name
1        아이유
2      에픽하이
3         HIGH4
4          MINO
5 사이먼 도미닉
6      G-DRAGON
7          오혁
8      더콰이엇
9          수현

</code>