> setwd("C:/Users/vlado/DL/data/kaggle/Olympic/2016/cores")
> library(jsonlite)
> library(Polychrome)
> source("https://raw.githubusercontent.com/bavla/Rnet/master/R/Pajek.R")
> source("https://raw.githubusercontent.com/bavla/ibm3m/master/multiway/MWnets.R")
> OL <- fromJSON("https://raw.githubusercontent.com/bavla/ibm3m/master/data/Olympics16S.json")
> str(OL)
> cw <- c("Games","NOC","Sport")
> ci <- unname(sapply(cw,\(x) which(names(OL$ways)==x)))
> pWSUM <- function(MN,v,cip,C,...) pWsum(MN,v,cip,C,weight="w")
> P <- list(
+ p1 = list(
+ p = pWSUM, t = 100,
+ cwp = c("Games","NOC","Sport"),
+ cip = NULL),
+ p2 = list(
+ p = pWSUM, t = 100,
+ cwp = c("NOC","Games","Sport"),
+ cip = NULL),
+ p3 = list(
+ p = pWSUM, t = 100,
+ cwp = c("Sport","Games","NOC"),
+ cip = NULL),
+ cways = list(cw=cw,ci=ci)
+ )
> for(i in 1:(length(P)-1)) P[[i]]$cip <- unname(sapply(P[[i]]$cwp,\(x) which(cw==x)))
> str(P)
> C <- lapply(cw, \(x) 1:nrow(OL$nodes[[x]])); names(C) <- cw
> listCore(OL,C,P)
> P[[1]]$t <- 400; P[[2]]$t <- 100; P[[3]]$t <- 300
> CC <- MWcore(OL,P,trace=TRUE)
> listCore(OL,CC,P)
1 Games : 400 29 1 2 3
2004 Summer 2008 Summer 2000 Summer 2012 Summer 1996 Summer 1992 Summer 2016 Summer 1988 Summer
1611 1608 1575 1530 1498 1496 1495 1481
1984 Summer 1980 Summer 1976 Summer 1972 Summer 1920 Summer 1968 Summer 1964 Summer 1912 Summer
1414 1325 1294 1170 1159 1016 992 870
1960 Summer 1952 Summer 1956 Summer 1936 Summer 1948 Summer 1924 Summer 1908 Summer 1928 Summer
869 846 843 832 775 694 672 661
1932 Summer 1900 Summer 1906 Summer
608 462 416
2 NOC : 100 147 2 1 3
USA URS GBR GER FRA ITA AUS HUN SWE NED GDR RUS JPN CHN ROU CAN NOR DEN POL FRG
4325 2034 1696 1632 1472 1401 1203 1070 1035 896 843 780 732 681 632 617 580 559 524 500
KOR FIN BRA BEL ESP CUB SUI YUG BUL TCH ARG NZL EUN IND UKR GRE JAM AUT CRO PAK
464 456 446 436 419 399 385 379 317 308 257 211 211 187 179 177 157 148 130 121
RSA KEN
107 106
3 Sport : 300 52 3 1 2
Athletics Swimming Rowing Gymnastics Fencing Hockey Football
3504 2952 2842 2158 1700 1513 1366
Cycling Sailing Shooting Canoeing Handball Wrestling Basketball
1203 1198 1143 1070 1032 1023 974
Water Polo Equestrianism Volleyball Boxing Judo Weightlifting Diving
972 928 911 742 477 475 402
Baseball Archery
316 311
> P[[1]]$t <- 500; P[[2]]$t <- 300; P[[3]]$t <- 350
> CC <- MWcore(OL,P,trace=TRUE)
1 Games 1 : 1 2 3 / 500
1 3 4
2 NOC 2 : 2 1 3 / 300
1 2 3 4 5 6 8 9 10 11 12 14 15 16 17 19 22 24 25 26 27 28 30 31 33 34 35 36 37 39 40 41 42 46 49 51 52 53
...
118 120 121 123 124 126 127 128 129 130 131 132 133 134 135 136 137 139 141 142 143 144 146 147
3 Sport 3 : 3 1 2 / 350
1 2 3 4 6 7 9 10 13 14 19 21 25 26 28 29 30 31 32 33 34 36 37 40 42 43 44 45 46 47 48
1 Games 1 : 1 2 3 / 500
2
2 NOC 2 : 2 1 3 / 300
29
3 Sport 3 : 3 1 2 / 350
1 Games 1 : 1 2 3 / 500
2 NOC 2 : 2 1 3 / 300
3 Sport 3 : 3 1 2 / 350
> str(CC)
List of 3
$ Games: int [1:25] 5 6 7 8 9 10 11 12 13 14 ...
$ NOC : int [1:29] 7 13 18 20 21 23 32 38 43 44 ...
$ Sport: int [1:21] 5 8 11 12 15 16 17 18 20 22 ...
> listCore(OL,CC,P)
1 Games : 500 29 1 2 3
1988 Summer 1984 Summer 2008 Summer 2012 Summer 2000 Summer 2016 Summer 2004 Summer 1980 Summer
1405 1354 1352 1338 1324 1320 1305 1270
1996 Summer 1976 Summer 1992 Summer 1972 Summer 1920 Summer 1964 Summer 1968 Summer 1912 Summer
1251 1220 1112 1080 1054 952 949 853
1960 Summer 1952 Summer 1956 Summer 1936 Summer 1948 Summer 1924 Summer 1908 Summer 1928 Summer
826 797 795 754 731 681 656 610
1932 Summer
577
2 NOC : 300 147 2 1 3
USA URS GBR GER ITA FRA AUS HUN SWE NED GDR RUS CHN JPN ROU CAN NOR POL DEN FRG
4153 2027 1594 1573 1325 1184 1165 1052 1019 854 843 776 662 661 632 613 546 520 519 500
FIN BRA ESP YUG SUI KOR BEL BUL TCH
446 446 416 379 352 347 337 317 308
3 Sport : 350 52 3 1 2
Athletics Swimming Rowing Gymnastics Fencing Football Cycling
2911 2815 2535 2043 1584 1216 1129
Hockey Canoeing Shooting Sailing Wrestling Handball Basketball
1126 1010 995 995 941 924 914
Equestrianism Water Polo Volleyball Boxing Judo Weightlifting Diving
883 876 839 596 425 419 390
> w1 <- CC$Games; w2 <- CC$NOC; w3 <- CC$Sport
> Rcore <- extract(OL,cw,c("w1","w2","w3"))
> c21 <- glasbey.colors(21); Co <- col2rgb(c21)/255; LS <- Rcore$links$Sport
> Col <- cbind(Co[1,LS],Co[2,LS],Co[3,LS])
> Score <- flatten(Rcore,"w",cw)
> mwnX3D(Score,"Games","NOC","Sport","w",maxsize=0.95,col=Col,file="Oly16Core.x3d")
> Cov <- projection(Score,"NOC","w")
> Sav <- salton(Cov); Dv <- as.dist(1-Sav); Dv[is.na(Dv)] <- 1
> tv <- hclust(Dv,method="ward")
> plot(tv,hang=-1,cex=0.7,main="Olympics core - NOCs / Ward")
> Coz <- projection(Score,"Sport","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.7,main="Olympics core - sports / Ward")
> J <- inv(tv$order); K <- inv(tz$order)
> c21 <- glasbey.colors(21); Co <- col2rgb(c21)/255; LS <- Score$links$Sport
> Col <- cbind(Co[1,LS],Co[2,LS],Co[3,LS])
> mwnX3D(Score,"Games","NOC","Sport","w",maxsize=0.95,pv=J,pz=K,col=Col,file="Oly16CoreClu.x3d")
Click a link (cube) for its identification (olympics, NOC, sport)!
> (St <- sum(OL$links$w)) [1] 34088 > (Sc <- sum(Score$links$w)) [1] 25566 > Sc/St [1] 0.75 > nrow(Score$links) [1] 3607 > nrow(OL$links) [1] 10429 > (nrow(Score$links)/nrow(OL$links)) [1] 0.3458625 > NC <- Score$nodes; NT <- OL$nodes > nrow(NC$Games) [1] 25 > nrow(NC$NOC) [1] 29 > nrow(NC$Sport) [1] 21 > nrow(NT$Games) [1] 29 > nrow(NT$NOC) [1] 147 > nrow(NT$Sport) [1] 52 > (nrow(NC$Games)*nrow(NC$NOC)*nrow(NC$Sport))/(nrow(NT$Games)*nrow(NT$NOC)*nrow(NT$Sport)) [1] 0.06868132
> N <- paste(OL$nodes$Games$Year,OL$nodes$Games$City) > Score$nodes$Games$ID <- N[CC$Games] > mwnX3D(Score,"Games","NOC","Sport","w",maxsize=0.95,pv=J,pz=K,col=Col,file="Oly16CoreClu.x3d")