Olympics pSum core

> library(Polychrome)
> library(magrittr)
> MT <- fromJSON("Olympics1.json")
> n1 <- nrow(MT$nodes$Olympics); n2 <- nrow(MT$nodes$Country); n3 <- nrow(MT$nodes$Discipline)
> C1 <- 1:n1; C2 <- 1:n2; C3 <- 1:n3
> F12 <- sapply(1:n1,function(u) pSum(MT,u,C2,"Olympics","Country",weight="w"))
> F21 <- sapply(1:n2,function(v) pSum(MT,v,C1,"Country","Olympics",weight="w"))
> table(F12)
F12
1305 1387 1459 1546 1705 1859 1998 2015 2042 
   1    1    1    1    1    1    1    1    1 
> table(F21)
F21
   1    2    3    4    5    6    7    8    9   11   12   13   14   16   17   18   19   20   21   22 
  22   11    6    3    1    2    2    2    1    1    1    1    5    3    2    1    1    1    4    1 
  23   24   29   32   34   35   37   38   39   40   41   49   50   54   56   74   79   82   85   89 
   1    2    2    1    1    1    1    1    1    2    2    1    1    1    1    1    2    1    1    1 
  92  122  148  153  154  193  223  247  263  278  304  318  328  345  349  368  388  428  449  454 
   1    1    2    1    1    1    1    1    1    1    1    1    1    1    1    1    1    1    1    1 
 467  482  486  626  638  679  691  798 1021 1992 
   1    1    1    1    1    1    1    1    1    1 
> PSum <- function(MN,u,C,way1,way2,...) pSum(MN,u,C,way1,way2,weight="w",...)
> cores <- Gen2modeCore(MT,"Olympics","Country",PSum,PSum,900,400)
> cores
$core1
integer(0)
$core2
integer(0)
> cores <- Gen2modeCore(MT,"Olympics","Country",PSum,PSum,900,300)
> cores
$core1
[1] 1 2 3 4 5 6 7 8 9
$core2
 [1]   5  13  17  19  24  30  37  39  44  52  54  58  73  87  88  96  97 117 118 124
> Coli <- cores$core1; Cntr <- cores$core2
> FCp <- sapply(Coli,function(u) pSum(MT,u,Cntr,"Olympics","Country",weight="w"))
> names(FCp) <- MT$nodes$Olympics$ID[Coli]
> rev(sort(FCp))
    Beijing 2008      Athens 2004      Sydney 2000     Atlanta 1996       Seoul 1988 
            1554             1514             1488             1391             1262 
Los Angeles 1984   Barcelona 1992    Montreal 1976      Moscow 1980 
            1198             1137             1050             1017 
> FCl <- sapply(Cntr,function(u) pSum(MT,u,Coli,"Country","Olympics",weight="w"))
> names(FCl) <- MT$nodes$Country$ID[Cntr]
> rev(sort(FCl))
 United States   Soviet Union      Australia        Germany          China         Russia 
          1992           1021            798            691            679            638 
  East Germany          Italy        Romania United Kingdom   Korea, South         France 
           626            486            482            467            454            449 
   Netherlands          Japan        Hungary           Cuba   West Germany          Spain 
           428            388            368            349            345            328 
        Brazil         Canada 
           318            304 
>

> MTcore <- extract(MT,c("Olympics","Country"),c("Coli","Cntr")) 
> MTcore$nodes$Olympics <- as.data.frame(data.frame(ID=MTcore$nodes$Olympics))
> MTcore$nodes$Country <- as.data.frame(data.frame(ID=MTcore$nodes$Country))
> str(MTcore)
List of 6
 $ format: chr "MWnets"
 $ info  :List of 6
  ..$ network: chr "Olympic"
  ..$ title  : chr "Summer Olympic medals 1976 to 2008"
  ..$ by     : chr "DF2MWN"
  ..$ date   : chr "Wed Feb  1 03:53:17 2023"
  ..$ URL    : chr "https://github.com/kalilurrahman/dataset"
  ..$ trace  :List of 1
  .. ..$ :List of 3
  .. .. ..$ op  : chr "extract"
  .. .. ..$ P   : chr "Olympics/Coli,Country/Cntr"
  .. .. ..$ date: chr "Wed Feb  1 05:05:31 2023"
 $ ways  :List of 3
  ..$ Olympics  : chr "Olympics"
  ..$ Country   : chr "Country"
  ..$ Discipline: chr "Discipline"
 $ nodes :List of 3
  ..$ Olympics  :'data.frame':  9 obs. of  1 variable:
  .. ..$ ID: chr [1:9] "Athens 2004" "Atlanta 1996" "Barcelona 1992" "Beijing 2008" ...
  ..$ Country   :'data.frame':  20 obs. of  1 variable:
  .. ..$ ID: chr [1:20] "Australia" "Brazil" "Canada" "China" ...
  ..$ Discipline:'data.frame':  41 obs. of  1 variable:
  .. ..$ ID: chr [1:41] "Archery" "Artistic G." "Athletics" "Badminton" ...
 $ links :'data.frame': 1671 obs. of  4 variables:
  ..$ Olympics  : int [1:1671] 1 9 1 2 3 4 5 3 4 2 ...
  ..$ Country   : int [1:1671] 1 1 4 4 4 4 4 7 7 8 ...
  ..$ Discipline: int [1:1671] 1 1 1 1 1 1 1 1 1 1 ...
  ..$ w         : int [1:1671] 1 1 3 1 3 7 1 1 3 3 ...
 $ data  : list()
> CC <- col2rgb(createPalette(41,c("#ff0000","#00ff00","#0000ff")))/255
> LC <- MTcore$links
> Col <- cbind(CC[1,LC$Discipline],CC[2,LC$Discipline],CC[3,LC$Discipline])
> mwnX3D(MTcore,"Olympics","Country","Discipline","w",maxsize=0.95,col=Col,file="OlympicsCoreS.x3d")
> MTcore$nodes$Olympics$ID
[1] "Athens 2004"      "Atlanta 1996"     "Barcelona 1992"   "Beijing 2008"     "Los Angeles 1984"
[6] "Montreal 1976"    "Moscow 1980"      "Seoul 1988"       "Sydney 2000"     
> Cov <- projection(MTcore,"Country","w")
> Sav <- salton(Cov); Dv <- as.dist(1-Sav); Dv[is.na(Dv)] <- 1
> tv <- hclust(Dv,method="ward")
> plot(tv,hang=-1,cex=1,main="Olympics core - countries / Ward")
> Coz <- projection(MTcore,"Discipline","w")
> Saz <- salton(Coz); Dz <- as.dist(1-Saz); Dz[is.na(Dz)] <- 1
> tz <- hclust(Dz,method="ward")
> plot(tz,hang=-1,cex=0.6,main="Olympics core - disciplines / Ward")
> I <- inv(c(6,7,5,8,3,2,9,1,4)) 
> J <- inv(tv$order); K <- inv(tz$order) 
> mwnX3D(MTcore,"Olympics","Country","Discipline","w",pu=I,pv=J,pz=K,maxsize=0.95,col=Col,file="OlympicsCoreClusS.x3d")

Olympics sum core This is a 3D layout using X3DOM.
Use the mouse to navigate the space - rotate, zoom in/out, ...

Click a link (cube) for its identification (Olympics, Country, Discipline)!

> sum(MN$links$w)
[1] 15316
> sum(MTcore$links$w)
[1] 11611
> sum(MTcore$links$w)/sum(MN$links$w)
[1] 0.7580961
> length(MN$nodes$Countries$ID)
[1] 0
> length(MN$nodes$Country$ID)
[1] 127
> length(MTcore$nodes$Country$ID)
[1] 20
> length(MTcore$nodes$Country$ID)/length(MN$nodes$Country$ID)
[1] 0.1574803