Роман Осипов

"Игра престолов": строим инфографику об убийствах, сексе, путешествиях по Вестеросу и многое другое

БЛОГ переехал на новый адрес: https://blog.wolframmathematica.ru/

Введение

В этом посте я расскажу о том, как применять язык Wolfram Languge в анализе и визуализации данных на примере базы данных по "Игре престолов". В этой статье не уделяется особого внимания парсингу данных, об этом я расскажу отдельно. Вместо этого пост целиком посвящен интересной инфографике и её созданию.
Надеюсь, что построенные визуализации заинтересуют тех, кому нравится этот замечательный сериал).
Созданная для поста инфографика интерактивна в документе Mathematica, который можно скачать по ссылке в шапке.

Взаимоотношения персонажей

Набор рёбер графа взаимоотношений персонажей по типам:
In[18]:=
$GOTCharacterLinks=
    Module[{parser},        
        parser=            
            Flatten[                
                Thread/@
                    DeleteCases[                        
                        Lookup[                            
                            GOTRawData["characters.json"][
                                "characters"
                            ],
                            {"characterName",#}
                        ],
                        {_,_Missing}
                    ],
                1
            ]&;        <|                
        "РодительИРебёнок"
        ->
        Union[            
            DirectedEdge[#[[2]],#[[1]]]&/@parser["parents"],
            DirectedEdge[#[[1]],#[[2]]]&/@parser["parentOf"]
        ],        
        "БратьяИСёстры"
        ->
        DeleteDuplicates[            
            UndirectedEdge[#[[2]],#[[1]]]&/@parser["siblings"],
            #1===Reverse[#2]&
        ],
        "Убил"->
            Union[                
                DirectedEdge[#[[2]],#[[1]]]&/@parser["killedBy"],
                DirectedEdge[#[[1]],#[[2]]]&/@parser["killed"]
            ],
        "Служит"->(DirectedEdge[#[[1]],#[[2]]]&/@parser["serves"]),        
        "ЖенатыОбручены"
        ->
        DeleteDuplicates[            
            UndirectedEdge[#[[1]],#[[2]]]&/@parser["marriedEngaged"],
            #1===Reverse[#2]&
        ],
        "Секс"->
            DeleteDuplicates[                
                Flatten[
                    Map[                        
                        Thread@UndirectedEdge[#[[1]],#[[2]]["with"]]&,
                        Lookup[#,{"name","sex"}]&/@
                            Select[                                
                                Select[                                    
                                    Flatten[
                                        Lookup[                                            
                                            Flatten[                                                
                                                GOTRawData[
                                                    "episodes.json"
                                                ][
                                                    "episodes"
                                                ][
                                                    [;;,"scenes"]
                                                ],
                                                1
                                            ],
                                            "characters"
                                        ]
                                    ],
                                    Keys[#]=!={"name"}&
                                ],
                                MemberQ[Keys[#],"sex"]&
                            ]
                    ]
                ],
                #1===Reverse[#2]&
            ]|>
    ];
Функция GOTCharacterLinksGraph для построения графов взаимосвязей персонажей "Игры престолов".
In[19]:=
ClearAll[GOTCharacterLinksGraph];
GOTCharacterLinksGraph[    
    data_,
    OptionsPattern[
        {            
            "ImageSize"->1500,
            "VertexSize"->Automatic,
            "GraphLayout"->"GravityEmbedding"
        }
    ]
]:=
    Module[{vertexList},        
        vertexList=
            DeleteDuplicates[Flatten[data[[;;,1]]/._[x_,y_]:>{x,y}]];
        Graph[            
            data,
            VertexLabels->
                Map[                                        
                    Rule[                        
                        #,
                        Placed[                            
                            Tooltip[                                                                
                                If[
                                    Head[#]===Image,
                                    Image[#,ImageSize->60],
                                    (* else *)
                                    Style[                                        
                                        StringReplace[#," "->"\n"],
                                        LineSpacing->{0.8,0,0},
                                        FontFamily->"Open Sans Light",
                                        Bold,
                                        12
                                    ]
                                ]&[
                                    #/.$characterImage
                                ],
                                #/.$characterCardFull
                            ],
                            {1/2,1/2}
                        ]
                    ]&,
                    vertexList
                ],
            VertexShapeFunction->"Circle",
            VertexSize->OptionValue["VertexSize"],
            VertexStyle->
                Directive[
                    {White,EdgeForm[{LightGray,AbsoluteThickness[2]}]}
                ],
            ImageSize->OptionValue["ImageSize"],
            Background->GrayLevel[0.95],
            AspectRatio->1,
            GraphLayout->OptionValue["GraphLayout"]
        ]
    ];
Узнаем кто кого родил в "Игре престолов":
In[20]:=
GOTInfographicsPoster[
       #, "Родители и их дети в \"Игре престолов\"", 
   "ImageSize" -> 1500
   ] &@
     GOTCharacterLinksGraph[                
          Property[            
                 #,
                 {
                      EdgeStyle ->
                           Directive[
                                {                            
                                     AbsoluteThickness[2],
                                     Blue,
                                     Arrowheads[{0, {0.01, 0.5}}]
                                 }
                            ]
                  }
             ] & /@
               $GOTCharacterLinks["РодительИРебёнок"],
          "VertexSize" -> 3
      ]
Родители и их дети в "Игре престолов"
Теперь посмотрим, кто кому является братом или сестрой в "Игре престолов":
In[21]:=
GOTInfographicsPoster[
    #,"Братья и сёстры в \"Игре престолов\"","ImageSize"->1500
]&@
    GOTCharacterLinksGraph[                
        Property[            
            #,
            {EdgeStyle->Directive[{AbsoluteThickness[2],Darker@Green}]}
        ]&/@
            $GOTCharacterLinks["БратьяИСёстры"],
        "VertexSize"->0.7,
        "GraphLayout"->Automatic
    ]
Братья и сёстры в "Игре престолов"
Одно из самых интересных: граф убийств в "Игре престолов" (оригинал):
In[22]:=
GOTInfographicsPoster[
    #,"Кто кого убил в \"Игре престолов\"","ImageSize"->2500
]&@
    GOTCharacterLinksGraph[                
        Property[            
            #,
            {
                EdgeStyle->
                    Directive[
                        {                            
                            AbsoluteThickness[2],
                            Black,
                            Arrowheads[{0,{0.0075,0.5}}]
                        }
                    ]
            }
        ]&/@
            $GOTCharacterLinks["Убил"],
        "VertexSize"->1.1,
        "ImageSize"->2500
    ]
Кто кого убил в "Игре престолов"
Не так интересно, но тем не менее — кто кому служит в "Игре престолов":
In[23]:=
GOTInfographicsPoster[
    #,"Кто кому служит в \"Игре престолов\"","ImageSize"->1000
]&@
    GOTCharacterLinksGraph[                
        Property[            
            #,
            {
                EdgeStyle->
                    Directive[
                        {                            
                            AbsoluteThickness[2],
                            Magenta,
                            Arrowheads[{0,{0.02,0.5}}]
                        }
                    ]
            }
        ]&/@
            $GOTCharacterLinks["Служит"],
        "VertexSize"->0.5,
        "ImageSize"->1000,
        "GraphLayout"->Automatic
    ]
Кто кому служит в "Игре престолов"
Помолвленные и женатые персонажи "Игры престолов":
In[24]:=
GOTInfographicsPoster[    
    #,
    "Кто с кем женат или обручен в \"Игре престолов\"",
    "ImageSize"->1000
]&@
    GOTCharacterLinksGraph[                
        Property[
            #,{EdgeStyle->Directive[{AbsoluteThickness[2],Orange}]}
        ]&/@
            $GOTCharacterLinks["ЖенатыОбручены"],
        "VertexSize"->0.5,
        "ImageSize"->1000,
        "GraphLayout"->Automatic
    ]
Кто с кем женат или обручен в "Игре престолов"
Немного погорячее — кто с кем имел секс в "Игре престолов" (количество линий, думаю, не сложно догадаться, что означает ;)).
In[25]:=
GOTInfographicsPoster[#, "Секс в \"Игре престолов\"", 
   "ImageSize" -> 1300] &@
     GOTCharacterLinksGraph[        
          
  Property[#, {EdgeStyle -> 
       Directive[{AbsoluteThickness[2], Red}]}] & /@
               $GOTCharacterLinks["Секс"],
          "VertexSize" -> 0.9,
          "ImageSize" -> 1300,
          "GraphLayout" -> "LayeredDigraphEmbedding"
      ]
Секс в "Игре престолов" (количество линий показывает количество постельных сцен)
Теперь сведем все графы в один большой граф взаимоотношений персонажей в "Игре престолов" (оригинал):
In[26]:=
GOTInfographicsPoster[    
    #,
    "Взаимоотношения персонажей в \"Игре престолов\"",
    "ImageSize"->3000
]&@
    Legended[        
        GOTCharacterLinksGraph[            
            Join[                                
                Property[                    
                    #,
                    {
                        EdgeStyle->
                            Directive[
                                {                                    
                                    AbsoluteThickness[3],
                                    Blue,
                                    Arrowheads[{0,{0.005,0.5}}]
                                }
                            ]
                    }
                ]&/@
                    $GOTCharacterLinks["РодительИРебёнок"],                
                Property[                    
                    #,
                    {
                        EdgeStyle->
                            Directive[
                                {AbsoluteThickness[3],Darker@Green}
                            ]
                    }
                ]&/@
                    $GOTCharacterLinks["БратьяИСёстры"],                
                Property[                    
                    #,
                    {
                        EdgeStyle->
                            Directive[
                                {                                    
                                    AbsoluteThickness[3],
                                    Black,
                                    Arrowheads[{0,{0.005,0.5}}]
                                }
                            ]
                    }
                ]&/@
                    $GOTCharacterLinks["Убил"],                
                Property[                    
                    #,
                    {
                        EdgeStyle->
                            Directive[
                                {                                    
                                    AbsoluteThickness[1],
                                    Magenta,
                                    Arrowheads[{0,{0.005,0.5}}]
                                }
                            ]
                    }
                ]&/@
                    $GOTCharacterLinks["Служит"],                
                Property[                    
                    #,
                    {
                        EdgeStyle->
                            Directive[{AbsoluteThickness[2],Orange}]
                    }
                ]&/@
                    $GOTCharacterLinks["ЖенатыОбручены"],                
                Property[                    
                    #,
                    {EdgeStyle->Directive[{AbsoluteThickness[3],Red}]}
                ]&/@
                    DeleteDuplicates[$GOTCharacterLinks["Секс"]]
            ],
            "ImageSize"->3000,
            "VertexSize"->0.9
        ],
        Placed[            
            LineLegend[                
                {Blue,Darker@Green,Black,Magenta,Orange,Red},
                {                    
                    "Родитеи и дети",
                    "Братья и сёстры",
                    "Убил",
                    "Служит",
                    "Женаты или обручены",
                    "Секс"
                },
                LegendLayout->"Row"
            ],
            Top
        ]
    ]
Взаимоотношения персонажей в "Игре престолов"

Связь персонажей по сценам

Посмотрим на то, какие персонажи появлялись в одной и той же сцене. Каждое ребро между персонажами означает, что они были в одной сцене. Чем ребро толще и краснее, тем больше общих сцен.
Построим несколько графов: первый — показывает связи, с минимальным количеством сцен 2 (оригинал). Далее — 5, 10 и 20.
In[29]:=

Table[    
    Print[        
        GOTInfographicsPoster[            
            GOTGraphPlot[                
                #,
                min,
                "ImageSize"->Which[min==1,5000,min==4,3000,True,2000],
                "MaxThickness"->25
            ],            
            "Появление персонажей \"Игры престолов\" в одной сцене не менее "
            <>
            ToString[min+1]
            <>
            " раз",
            "ImageSize"->Which[min==1,5000,min==4,3000,True,2000]
        ]&@
            Tally[
                UndirectedEdge@@@
                    Map[                        
                        Sort,
                        Flatten[                            
                            Map[                                
                                Subsets[#,{2}]&,
                                Map[                                    
                                    #[[;;,"name"]]&,
                                    Flatten[
                                        Lookup[                                            
                                            GOTRawData[
                                                "episodes.json"
                                            ][
                                                "episodes"
                                            ],
                                            "scenes"
                                        ]
                                    ][
                                        [;;,"characters"]
                                    ]
                                ]
                            ],
                            1
                        ]
                    ]
            ]
    ],
    {min,{1,4,9,19}}
];
Появление персонажей "Игры престолов" в одной сцене не менее 2 раз
Появление персонажей "Игры престолов" в одной сцене не менее 5 раз
Появление персонажей "Игры престолов" в одной сцене не менее 10 раз
Появление персонажей "Игры престолов" в одной сцене не менее 20 раз

Кто самый "популярный" персонаж Игры престолов?

Для ответа на этот вопрос, создадим переменную $GOTEpisodeData в которую поместим набор очищенных данных о сценах по каждому эпизоду "Игры престолов"
In[30]:=

$GOTEpisodeData=    
    With[{data=#},        <|        
        "EpisodeN"->#[[1]],
        "ScreenTime"->
            SortBy[                
                GroupBy[                    
                    Flatten[                                                
                        ReplaceAll[                            
                            Thread/@
                                Transpose[
                                    {                                        
                                        Map[                                            
                                            Lookup[#[[1]],"name"]&,
                                            #[[2]]
                                        ],
                                        Round@
                                            Map[                                                                                                
                                                QuantityMagnitude[
                                                    UnitConvert[                                                        
                                                        Subtract@@
                                                            (
                                                                TimeObject/@
                                                                    #[                                                                        
                                                                        [
                                                                        {                                                                            
                                                                            3,
                                                                            2
                                                                        }
                                                                        ]
                                                                    ]
                                                            ),
                                                        "Seconds"
                                                    ]
                                                ]&,
                                                #[[2]]
                                            ]
                                    }
                                ],                            
                            {Missing["KeyAbsent","name"],x_}
                            :>
                            {{"БезПерсонажей",x}}
                        ]&@
                            data,
                        1
                    ],
                    First,
                    #[[;;,2]]&
                ],
                -Total[#]&
            ],        
        "LocationTime"
        ->
        SortBy[            
            GroupBy[                
                Flatten[                                        
                    ReplaceAll[                        
                        Thread/@
                            Transpose[
                                {                                                                        
                                    Map[{#[[{4,5}]]}&,#[[2]]]
                                    /.
                                    Missing["KeyAbsent","subLocation"]->
                                        Nothing,
                                    Round@
                                        Map[                                                                                        
                                            QuantityMagnitude[
                                                UnitConvert[                                                    
                                                    Subtract@@
                                                        (
                                                            TimeObject/@
                                                                #[                                                                    
                                                                    [
                                                                    {                                                                        
                                                                        3,
                                                                        2
                                                                    }
                                                                    ]
                                                                ]
                                                        ),
                                                    "Seconds"
                                                ]
                                            ]&,
                                            #[[2]]
                                        ]
                                }
                            ],                        
                        {Missing["KeyAbsent","name"],x_}
                        :>
                        {{"БезПерсонажей",x}}
                    ]&@
                        data,
                    1
                ],
                First,
                #[[;;,2]]&
            ],
            -Total[#]&
        ],
        "CharacterLocations"->
            GroupBy[                                
                DeleteCases[                    
                    #/.Missing["KeyAbsent","subLocation"]->Nothing,
                    _Missing
                ]&@
                    Flatten[                        
                        Map[                                                        
                            With[{location=#[[2]]},
                                {#,location}&/@#[[1]]
                            ]&,
                            Transpose[
                                {                                    
                                    Map[Lookup[#[[1]],"name"]&,#[[2]]],
                                    #[[2,;;,{4,5}]]
                                }
                            ]
                        ],
                        1
                    ],
                First,
                #[[;;,2]]&
            ]|>
    ]&/@
        DeleteCases[            
            Map[                                
                {                    
                    #[[{1,2}]],
                    Lookup[                        
                        #[[3]],
                        {                            
                            "characters",
                            "sceneStart",
                            "sceneEnd",
                            "location",
                            "subLocation"
                        }
                    ]
                }&,
                Lookup[                    
                    GOTRawData["episodes.json"]["episodes"],
                    {"seasonNum","episodeNum","scenes"}
                ]
            ],
            {_,{_Missing...}}
        ];
Пример данных по первой серии первого сезона:
Данные о первой серии первого сезона "Игры престолов"

Количество экранного времени у персонажей

30 персонажей "Игры престолов" с самым большим количеством экранного времени:
In[32]:=

GOTInfographicsPoster[    
    #,
    "30 персонажей, которых мы видим больше всего на экране",
    "ImageSize"->1500
]&@
    circleInfographics[                
        {            
            Tooltip[                
                Row[                    
                    {                        
                        #[[1]]/.$characterImage,
                        Style[#[[1]],14,White,Bold],
                        Style[                            
                            UnitConvert[                                
                                Quantity[#[[2]],"Seconds"],
                                MixedUnit[
                                    {"Hours","Minutes","Seconds"}
                                ]
                            ],
                            14,
                            White
                        ]
                    },
                    "\n"
                ],
                #[[1]]/.$characterCardFull
            ],
            #[[2]]
        }&/@
            KeyValueMap[                
                {#1,#2}&,
                SortBy[                    
                    Merge[                        
                        $GOTEpisodeData[[All,"ScreenTime"]],
                        Total[Flatten[#]]&
                    ],
                    -#&
                ]
            ][
                [1;;30]
            ],
        "Precision"->10^-6,
        "StepDecrease"->0.99,
        "ShapeFunction"->Disk,
        "ColorFunction"->ColorData["Rainbow"],
        "ImageSize"->1500
    ]
30 персонажей "Игры престолов", которых мы видим больше всего на экране
Остальных тоже не будем обделять и построим большую таблицу:
In[33]:=

GOTInfographicsPoster[    
    #,
    "550+ персонажей и их экранное время",
    "ImageSize"->1500,
    "ImageResolution"->150
]&@
    Multicolumn[                
        Style[
            Row[{#[[1]]," \[LongDash] ",#[[2]]," c"}],FontFamily->"Myriad Pro",8
        ]&/@
            KeyValueMap[                
                {#1,#2}&,
                SortBy[                    
                    Merge[                        
                        $GOTEpisodeData[[All,"ScreenTime"]],
                        Total[Flatten[#]]&
                    ],
                    -#&
                ]
            ],
        6
    ]
550+ персонажей "Игры престолов" и их экранное время (в секундах)

Сколько персонажей было в сериях?

$GOTEpisodeN — переводит серию из формата {сезон, порядновый номер серии в сезоне} к просто порядковому номеру серии во всём сериале.
In[34]:=

$GOTEpisodeN=    <|
    Thread[
        Rule[#,Range[Length[#]]]&@$GOTEpisodeData[[All,"EpisodeN"]]
    ]|>;
$GOTEpisodeID — операция, обратная к $GOTEpisodeN.
In[35]:=

$GOTEpisodeID=    <|
    Thread[
        Rule[Range[Length[#]],#]&@$GOTEpisodeData[[All,"EpisodeN"]]
    ]|>;
Построим гистрограмму количества персонажей, задействованных в каждой из серий "Игры престолов"
In[36]:=

GOTInfographicsPoster[    
    #,
    "Количество персонажей в сериях \"Игры престолов\"",
    "ImageSize"->1000
]&@
    BarChart[        
        #,
        BarSpacing->{0.05,2},
        AspectRatio->1/2,
        ImageSize->1000,
        ChartLabels->{Keys[#],Range[10]},
        ColorFunction->Function[{x},ColorData["Rainbow"][x]],
        GridLines->{None,Range[0,100,5]},
        FrameLabel->
            Map[                
                Style[#,FontFamily->"Open Sans",20,Bold]&,
                {                    
                    "Сезон и серия в нём",
                    "Число задействованных персонажей"
                }
            ],
        Frame->True,
        Background->GrayLevel[0.95]
    ]&@
    GroupBy[        
        Map[            
            {#["EpisodeN"],Length[#["ScreenTime"]]}&,
            $GOTEpisodeData[[All,{"EpisodeN","ScreenTime"}]]
        ],
        #[[1,1]]&,
        #[[;;,2]]&
    ]
Количество персонажей, задействованных в сериях "Игры престолов"

Кто из персонажей был самом большом количестве серий "Игры престолов"?

Список персонажей "Игры престолов", отсортированный по количеству серий, в который они встречались:
In[37]:=

$GOTCharacters=
    DeleteCases[        
        Reverse[
            SortBy[                
                Tally[
                    Flatten[Keys@$GOTEpisodeData[[All,"ScreenTime"]]]
                ],
                Last
            ]
        ][
            [;;,1]
        ],
        "БезПерсонажей"
    ];
Количество серий в сезоне:
In[38]:=

$GOTSeriesInSeason=    <|
    KeyValueMap[#1->Length@#2&,GroupBy[$GOTEpisodeData[[;;,1]],First]]|>;
"Маска" сезона (служебный символ):
In[39]:=
$GOTSeasonsMask=KeyValueMap[ConstantArray[#1,#2]&,$GOTSeriesInSeason];
GOTCharacterBySeason вычисляет в каких сериях каких сезонов был задействован персонаж "Игры престолов":
In[40]:=
GOTCharacterBySeason[name_]:=
    Module[{initialData,empty},        
        initialData=
            Map[                
                #[[;;,2]]&,
                GroupBy[                    
                    Cases[                        
                        {#[[1]],Keys[#[[2]]]}&/@
                            Lookup[                                
                                $GOTEpisodeData,
                                {"EpisodeN","ScreenTime"}
                            ],
                        {number_,episode_/;Not[FreeQ[episode,name]]}:>
                            number
                    ],
                    First
                ]
            ];
        empty=Complement[Range[1,8],Keys[initialData]];
        If[
            Length[empty]===0,
            initialData,
            (* else *)
            KeySort@<|initialData,<|#->{}&/@empty|>|>
        ]
    ]
GOTCharacterBySeasonPlot визуализирует данные, полученные GOTCharacterBySeason.
In[41]:=
GOTCharacterBySeasonPlot[name_]:=
    Flatten@
        KeyValueMap[                        
            ReplacePart[                
                $GOTSeasonsMask[[#1]],
                Thread[
                    Complement[Range[1,$GOTSeriesInSeason[#1]],#2]->0
                ]
            ]&,
            GOTCharacterBySeason[name]
        ]
$GOTSeasonColors набор цветов, для того, чтобы наглядно отображать набор серий сезона.
In[42]:=

$GOTSeasonColors=    
    {0->White}
    ~
    Join
    ~
    Thread[Range[1,8]->ColorData[54,"ColorList"][[1;;8]]];
Наконец, построим таблицу, в которой наглядно видно, кто из персонажей в какой серии "Игры престолов" был, а в какой не был)
In[43]:=

GOTInfographicsPoster[    
    #,
    "100 персонажей \"Игры престолов\", присутствовавших в наибольшем количестве серий",
    "ImageSize"->2500
]&@
    Grid[                
        {            
            {                
                "Персонаж \\ Сезон и серия",
                SpanFromLeft,
                Style["% серий\nс участием\nперсонажа",12]
            }
            ~
            Join
            ~
            Map[                                
                Style[
                    "S"<>ToString[#[[1]]]<>"\nE"<>ToString[#[[2]]],10
                ]&,
                Keys[$GOTEpisodeN]
            ]
        }
        ~
        Join
        ~
        (
            (                                
                {                    
                    ImageResize[#/.$characterImage,{Automatic,25}],
                    #,
                    PercentForm[                        
                        N@Total[Length/@GOTCharacterBySeason[#]]
                        /
                        Last[$GOTEpisodeN]
                    ]
                }
                ~
                Join
                ~
                ReplaceAll[                    
                    GOTCharacterBySeasonPlot[#],
                    x_Integer:>Item["",Background->x/.$GOTSeasonColors]
                ]&/@
                    DeleteCases[
                        $GOTCharacters[[1;;100]],"БезПерсонажей"
                    ]
            )
        ),
        ItemSize->{{2,10,5,{1.2}},{4,{1}}},
        Background->White,
        Dividers->Gray,        
        ItemStyle
        ->
        Directive[
            FontFamily->"Open Sans",14,Bold,LineSpacing->{0.8,0,0}
        ],
        Alignment->{Center,Center}
    ]
100 персонажей "Игры престолов", присутствовавших в наибольшем количестве серий

Самые популярные локации "Игры престолов"

Карта локаций "Игры престолов"

Построим карту из геометрических примитивов. Создадим их набор:
In[44]:=
index=1;
In[45]:=

$GOTLakesIDs=
    {        
        11,
        8,
        9,
        10,
        2,
        529,
        530,
        522,
        523,
        533,
        532,
        526,
        521,
        525,
        531,
        524,
        528,
        527,
        7,
        3,
        4,
        5,
        6
    };
In[46]:=

$GOTMapPolygons=    
    {        
        FaceForm@If[MemberQ[$GOTLakesIDs,index],LightBlue,LightOrange],
        EdgeForm[AbsoluteThickness[1]],
        index++;Polygon[Accumulate[#]]
    }&/@
        GOTRawData["lands-of-ice-and-fire.json"]["arcs"];
Создадим набор мест на карте "Игры престолов":
In[47]:=

$GOTMapPlaces=
    Lookup[        
        GOTRawData["lands-of-ice-and-fire.json"]["objects"]["places"][
            "geometries"
        ],
        {"coordinates","properties"}
    ];
In[48]:=
$GOTMapPlaceCoordinates=Map[#[[2,"name"]]->#[[1]]&,$GOTMapPlaces];
Функция GOTMap служит для построения всевозможных "географических" мест и траекторий на карте "Игры престолов":
In[49]:=
GOTMap[additinals_,OptionsPattern[{"ImageSize"->1500}]]:=
    Legended[        
        Graphics[            
            {                
                $GOTMapPolygons,                
                (                    
                    {                        
                        {                            
                            AbsolutePointSize[10],
                            Black,
                            Point[#1[[1]]],
                            AbsolutePointSize[5],
                            White,
                            Point[#1[[1]]]
                        },
                        Inset[                            
                            With[{placeType=#1[[2]]["type"]},                                
                                (                                    
                                    Framed[                                        
                                        #1,                                        
                                        Background
                                        ->
                                        (                                            
                                            placeType
                                            /.
                                            Thread[                                                
                                                {                                                    
                                                    "city",
                                                    "castle",
                                                    "ruin",
                                                    "town"
                                                }
                                                ->                                                
                                                (                                                    
                                                    Lighter[                                                        
                                                        RGBColor[
                                                            #1/255
                                                        ],
                                                        0.5
                                                    ]&
                                                )/@
                                                    {                                                        
                                                        {254,92,7},
                                                        {254,252,9},
                                                        {138,182,7},
                                                        {2,130,237}
                                                    }
                                            ]
                                        ),
                                        RoundingRadius->6,
                                        FrameStyle->None,
                                        FrameMargins->2
                                    ]&
                                )[
                                    Style[                                        
                                        #1[[2]]["name"],
                                        LineSpacing->{0.8,0,0},
                                        FontFamily->"Open Sans",
                                        Bold,
                                        12
                                    ]
                                ]
                            ],
                            #1[[1]],
                            If[
                                MemberQ[                                    
                                    {                                        
                                        "Eastwatch",
                                        "The Dreadfort",
                                        "White Harbor",
                                        "Storm's End",
                                        "Ghoyan Drohe",
                                        "Qohor"
                                    },
                                    #1[[2]]["name"]
                                ],
                                Scaled[{-0.1,1/2}],
                                (* else *)
                                Scaled[{1.1,1/2}]
                            ]
                        ]
                    }&
                )/@
                    $GOTMapPlaces,
                additinals
            },
            ImageSize->OptionValue["ImageSize"],
            Background->LightBlue,
            PlotRangePadding->0
        ],
        (Placed[#1,"Bottom"]&)[
            SwatchLegend[                
                (RGBColor[#1/255]&)/@
                    {{254,92,7},{254,252,9},{138,182,7},{2,130,237}},
                {"city","castle","ruin","town"},
                LegendLayout->"Row"
            ]
        ]
    ]
Построим саму карту:
In[50]:=

GOTInfographicsPoster[
    #,"Карта расположения локаций \"Игры престолов\"","ImageSize"->1500
]&@
    GOTMap[{}]
Карта расположения локаций "Игры престолов"

Перемещения персонажей "Игры престолов" от серии к серии

Функция GOTCharacterLocationNamesSequence вычисляет перемещения персонажа между локациями "Игры престолов":
In[51]:=

GOTCharacterLocationNamesSequence[name_]:=
    Merge[$GOTEpisodeData[[;;,"CharacterLocations"]],Identity][name];
Функция GOTCharacterLocationSequence переводит названия мест в их "географические" координаты:
In[52]:=

GOTCharacterLocationSequence[name_]:=
    DeleteCases[        
        Partition[            
            Flatten[                
                DeleteCases[                                                            
                    GOTCharacterLocationNamesSequence[name]
                    /.
                    {{x_String,y_String}:>y,{x_String}:>x}
                    /.
                    $GOTMapPlaceCoordinates,
                    _String,
                    Infinity
                ],
                1
            ],
            2,
            1
        ],
        {x_,x_}
    ];
Функция GOTMapTraectory строит траекторию на карте "Игры престолов":
In[53]:=
ClearAll[GOTMapTraectory];
In[54]:=

GOTMapTraectory[path_,colorFunction_:ColorData["Rainbow"]]:=
    Module[{kol},        
        kol=Length[path];
        Table[            
            {                
                Opacity[0.5],
                colorFunction[(i-1)/(kol-1)],
                AbsoluteThickness[10i/kol+1],
                CapForm["Round"],
                Arrow[
                    BSplineCurve[
                        {                            
                            path[[i,1]],                            
                            Mean[path[[i]]]
                            +                            
                            RandomInteger[{5000,20000}]
                            Function[#/Norm[#]][                                
                                RandomChoice[{1,1}]
                                {-1,1}
                                *
                                Reverse[path[[i,2]]-path[[i,1]]]
                            ],
                            path[[i,2]]
                        }
                    ]
                ]
            },
            {i,1,kol}
        ]
    ];
Наконец, мы можем построить карту перемещения любого персонажа "Игры престолов". Построим их для 10 самых популярных героев.
In[55]:=

(    
    Print[
        With[{track=#1,name=#1[[1]]},            
            (                
                GOTInfographicsPoster[                    
                    #1,
                    Row[
                        {                            
                            "Перемещения ",
                            Style[name,Bold],
                            " в \"Игре престолов\"",
                            "\n",
                            Style[                                
                                "(линия перемещения утолщается от начала к концу)",
                                25
                            ]
                        }
                    ],
                    "ImageSize"->1500
                ]&
            )[
                GOTMap[
                    {                        
                        Arrowheads[{0,0.01}],                        
                        (                            
                            With[{color=#1[[2]]},
                                GOTMapTraectory[
                                    GOTCharacterLocationSequence[name]
                                ]
                            ]&
                        )[
                            track
                        ],
                        Inset[                            
                            track[[1]]/.$characterCardFull,
                            Scaled[{0.99,0.99}],
                            Scaled[{1,1}]
                        ]
                    }
                ]
            ]
        ]
    ]&
)/@
    ({#1,RGBColor[{200,42,102}/255]}&)/@$GOTCharacters[[1;;10]];
Перемещения Тириона Ланнистера в "Игре престолов"
Перемещения Джона Сноу в "Игре престолов"
Перемещения Дейенерис Таргариен в "Игре престолов"
Перемещения Серсеи Ланнистер в "Игре престолов"
Перемещения Сансы Старк в "Игре престолов"
Перемещения Арьи Старк в "Игре престолов"
Перемещения Джейми Ланнистера в "Игре престолов"
Перемещения Джораха Мормонта в "Игре престолов"
Перемещения Теона Грейджоя в "Игре престолов"
Перемещения Сэмвелла Тарли в "Игре престолов"

Кто больше всего "путешествовал" из персонажей "Игры престолов"?

Найдем длину пути, пройденного каждым персонажем "Игры престолов" в условных единицах и посмотрим, кто больше всех поколесил по Вестеросу:
In[57]:=

GOTInfographicsPoster[    
    #1,
    "Кто больше всего \"путешествовал\" в \"Игре престолов\"?",
    "ImageSize"->1500
]&@
    (        
        (            
            BarChart[                
                #1[[1;;All,1]],
                PlotRangePadding->0,
                BarSpacing->0.25,
                BarOrigin->Left,
                AspectRatio->1.8,
                ImageSize->1500,
                ChartLabels->#1[[1;;All,2]],
                Frame->True,
                GridLines->{Range[0,10^6,10^4],None},
                ColorFunction->ColorData["Rainbow"],
                FrameLabel->
                    {                        
                        {None,None},
                        Style[#,FontFamily->"Open Sans Light",16]&/@
                            {                                
                                "Длина пути в условных единицах",
                                "Длина пути в условных единицах"
                            }
                    },
                Background->GrayLevel[0.95]
            ]&
        )[
            Cases[                
                SortBy[                                        
                    (                        
                        {                            
                            Total[
                                (Norm[Subtract@@#1]&)/@
                                    GOTCharacterLocationSequence[#1]
                            ],
                            #1/.$characterCardShortSmall
                        }&
                    )/@
                        DeleteCases[                            
                            $GOTCharacters,
                            Alternatives@@
                                {                                    
                                    "БезПерсонажей",
                                    "Musician #1",
                                    "Musician #2",
                                    "Musician #3"
                                }
                        ],
                    First[#1]&
                ],
                {x_/;x>0,_}
            ][
                [-50;;-1]
            ]
        ]
    )
Кто больше всего "путешествовал" в "Игре престолов"

Самые популярные локации "Игры престолов" (по экранному времени)

Вычислим для каждой локации (и региона) на карте "Игры престолов" общее экранное время и отобразим результат в нескольких формах. Сразу будет видно самые популярные локации.
Данные в виде столбчатой гистограммы:
In[58]:=

GOTInfographicsPoster[    
    #1,
    "Локации \"Игры престолов\" по экранному времени (вид 1)",
    "ImageSize"->2000
]&@
    (        
        BarChart[            
            #[[;;,1]],
            PlotRangePadding->0,
            BarSpacing->{0.5,3},
            BarOrigin->Left,
            AspectRatio->1.5,
            ImageSize->2000,
            ChartLabels->{#[[;;,2]],None},
            ColorFunction->
                Function[
                    {x},If[x>4000,Red,ColorData["Rainbow"][x/4000]]
                ],
            ColorFunctionScaling->False,
            PlotRange->{0,55000},
            Frame->True,
            GridLines->{Range[0,60000,1000],None},
            GridLinesStyle->LightGray,
            FrameTicks->{All,Automatic},
            FrameLabel->
                {                    
                    {None,None},
                    Style[#,FontFamily->"Open Sans Light",16]&/@
                        {                            
                            "Экранное время, секунды",
                            "Экранное время, секунды"
                        }
                },
            Background->GrayLevel[0.95]
        ]&@
            KeyValueMap[                                
                {                                        
                    Callout[                        
                        #[[1]],
                        #[[2]],
                        If[#[[1]]>20000,Bottom,Right],
                        If[#[[1]]>4000,Scaled[1/2],Automatic]
                    ]&/@
                        Transpose[{#2[[;;,2]],#2[[;;,1]]}],
                    #1
                }&,
                SortBy[                    
                    GroupBy[                        
                        KeyValueMap[                            
                            {#1,#2}&,
                            Merge[                                
                                $GOTEpisodeData[[All,"LocationTime"]],
                                Total[Flatten[#]]&
                            ]
                        ],
                        #[[1,1]]&,                        
                        SortBy[                                                        
                            Transpose[
                                {                                                                        
                                    #[[;;,1]]
                                    /.
                                    {                                        
                                        {x_String,y_String}:>y,
                                        {x_String}:>x
                                    },
                                    #[[;;,2]]
                                }
                            ]
                            /.
                            {"",_}:>Nothing,
                            Last[#]&
                        ]&
                    ],
                    Total[#[[;;,2]]]&
                ]
            ]
    )
Локации "Игры престолов" по экранному времени (вид 1)
Данные в виде круговой парной диаграммы:
In[59]:=

{    
    Print[        
        GOTInfographicsPoster[            
            #1,
            "Локации \"Игры престолов\" по экранному времени (вид 2)",
            "ImageSize"->1500
        ]&@
            stripLineInfographics[                
                #,
                "Reverse"->False,
                "Gaps"->{75,50},
                "ColorFunctionRight"->ColorData["Rainbow"]
            ]
    ],
    Print[        
        GOTInfographicsPoster[            
            #1,
            "Локации \"Игры престолов\" по экранному времени\n(отсортированы по географическим областям)",
            "ImageSize"->1500
        ]&@
            stripLineInfographics[                
                #,
                "Reverse"->True,
                "Gaps"->{50,75},
                "ColorFunctionRight"->ColorData["Rainbow"]
            ]
    ]
}&@
    SortBy[        
        GroupBy[            
            KeyValueMap[                
                {#1,#2}&,
                Merge[                    
                    $GOTEpisodeData[[All,"LocationTime"]],
                    Total[Flatten[#]]&
                ]
            ],
            #[[1,1]]&,            
            SortBy[                                
                Transpose[
                    {                                                
                        #[[;;,1]]
                        /.
                        {{x_String,y_String}:>y,{x_String}:>x},
                        #[[;;,2]]
                    }
                ]
                /.
                {"",_}:>Nothing,
                Last[#]&
            ]&
        ],
        -Total[#[[;;,2]]]&
    ];
Локации "Игры престолов" по экранному времени (вид 2)
Локации "Игры престолов" по экранному времени (отсортированы по географическим областям)

В каких фильмах ещё играли актёры Игры престолов и насколько они знакомы?

Конечно, актёры из "Игры престолов" ещё много где играли. Вычислим и поместим в переменную $GOTCharactersInAnotherFilms данные о том, в каких фильмах кто из актёров играл.
In[60]:=

$GOTCharactersInAnotherFilms=
    SortBy[        
        Map[                        
            {                
                #[[1]],
                #[[2]][[;;,"characterName"]],                
                If[
                    Head[#[[3]]]===Missing,
                    0,
                    (* else *)                    
                    StringCases[#[[3]],DigitCharacter..]
                    /.
                    x_/;Length[x]>0:>ToExpression[x]
                ]
                /.
                {{x_}:>x,{}->0}
            }&,
            Lookup[                
                Values[GOTRawData["costars.json"]],
                {"title","actors","year"}
            ]
        ],
        -Length[#[[2]]]&
    ];
Теперь вычислим для каждого актера, в каких фильмах он играл и поместим результат в переменную $GOTCharactersFilmography.
In[61]:=

$GOTCharactersFilmography=
    Association@
        SortBy[            
            Select[                                
                #->
                    SortBy[                        
                        Cases[                            
                            $GOTCharactersInAnotherFilms,
                            {film_,list_/;MemberQ[list,#],year_}:>
                                {film,year}
                        ],
                        -Last[#]&
                    ]&/@
                    $GOTCharacters,
                Length[#[[2]]]>0&
            ],
            -Length[#[[2]]]&
        ];
Выясним в фильмах каких годов выпуска играли актёры "Игры престолов":
In[62]:=

GOTInfographicsPoster[    
    #1,
    "Количество фильмов в зависимости от года выпуска, в которых играли актёры \"Игры престолов\"",
    "ImageSize"->800
]&@
    DateHistogram[        
        DeleteMissing@
            Lookup[Values[GOTRawData["costars.json"]],"year"],
        ColorFunction->"Rainbow",
        ImageSize->800,
        Background->GrayLevel[0.95]
    ]
Количество фильмов в зависимости от года выпуска, в которых играли актёры "Игры престолов"

Фильмы, в которых играли самые "востребованные" актёры "Игры престолов":

In[63]:=

GOTInfographicsPoster[    
    #1,
    "Фильмы в которых играли 20 самых \"востребованных\" актёров \"Игры престолов\"",
    "ImageSize"->1500
]&@
    Grid[                
        {            
            #/.$characterCardFull,            
            TextCell[                
                Grid[                    
                    KeyValueMap[                        
                        {#1/.{0->"неизв."},Row[#2," - "]}&,
                        GroupBy[#,Last,#[[;;,1]]&]
                    ],
                    Alignment->{{Center,Left},{Top,Top}}
                ],
                FontFamily->"Open Sans Light",
                FontSize->14,
                TextAlignment->Left,
                LineSpacing->{0.9,0,0}
            ]&@
                $GOTCharactersFilmography[#]
        }&/@
            $GOTCharacters[[1;;20]],
        Alignment->{{Center,Left},Center},
        ItemSize->{{20,70},Automatic},
        Background->GrayLevel[0.95],
        Dividers->{None,{None,{Gray},None}}
    ]
Фильмы в которых играли 20 самых "востребованных" актёров "Игры престолов"

Актёры "Игры престолов" в "Гарри Поттере"

In[64]:=

GOTInfographicsPoster[
    #,"Актёры \"Игры престолов\" в \"Гарри Поттере\"","ImageSize"->1500
]&@
    Grid[                
        {            
            Style[#[[1]],FontFamily->"Open Sans Light",16,Bold],
            Row[Magnify[#,0.75]&/@(#[[2]]/.$characterCardFull),"  "]
        }&/@
            SortBy[                
                Select[                    
                    $GOTCharactersInAnotherFilms,                    
                    StringMatchQ[
                        ToLowerCase@#[[1]],___~~"harry potter"~~___
                    ]&
                ],
                -Last[#]&
            ][
                [{1,-1,2,3,4,5,6,7}]
            ],
        Background->GrayLevel[0.95],
        ItemSize->{{25,70},Automatic},
        Dividers->{None,{None,{LightGray},None}},
        Alignment->{{Center,Left},Center}
    ]
Актёры "Игры престолов" в "Гарри Поттере"

Актёры "Игры престолов" в "Звёздных войнах"

In[65]:=

GOTInfographicsPoster[    
    #,
    "Актёры \"Игры престолов\" в \"Звёздных войнах\"",
    "ImageSize"->1100
]&@
    Grid[                
        {            
            Style[#[[1]],FontFamily->"Open Sans Light",16,Bold],
            Row[Magnify[#,0.75]&/@(#[[2]]/.$characterCardFull),"  "]
        }&/@
            SortBy[                
                Select[                    
                    $GOTCharactersInAnotherFilms,                    
                    StringMatchQ[
                        ToLowerCase@#[[1]],___~~"star wars"~~___
                    ]&
                ],
                -Last[#]&
            ],
        Background->GrayLevel[0.95],
        ItemSize->{{25,45},Automatic},
        Dividers->{None,{None,{LightGray},None}},
        Alignment->{{Center,Left},Center}
    ]
Актёры "Игры престолов" в "Звёздных войнах"

Актёры "Игры престолов" в "Пиратах карибского моря"

In[66]:=

GOTInfographicsPoster[    
    #,
    "Актёры \"Игры престолов\" в \"Пиратах карибского моря\"",
    "ImageSize"->1300
]&@
    Grid[                
        {            
            Style[#[[1]],FontFamily->"Open Sans Light",16,Bold],
            Row[Magnify[#,0.75]&/@(#[[2]]/.$characterCardFull),"  "]
        }&/@
            SortBy[                
                Select[                    
                    $GOTCharactersInAnotherFilms,                    
                    StringMatchQ[
                        ToLowerCase@#[[1]],___~~"pirates of the"~~___
                    ]&
                ],
                -Last[#]&
            ],
        Background->GrayLevel[0.95],
        ItemSize->{{25,50},Automatic},
        Dividers->{None,{None,{LightGray},None}},
        Alignment->{{Center,Left},Center}
    ]
Актёры "Игры престолов" в "Пиратах карибского моря"

В каких фильмах/сериалах много актёров "Игры престолов"

In[67]:=

GOTInfographicsPoster[    
    #,
    "Фильмы (сериалы) в которых играет больше всего актёров \"Игры престолов\"",
    "ImageSize"->2000
]&@
    Grid[                
        {            
            Style[#[[1]],FontFamily->"Open Sans Light",16,Bold],
            Row[Magnify[#,0.75]&/@(#[[2]]/.$characterCardFull),"  "]
        }&/@
            SortBy[                
                Select[$GOTCharactersInAnotherFilms,Length[#[[2]]]>5&],
                -Length[#[[2]]]&
            ],
        Background->GrayLevel[0.95],
        ItemSize->{{20,100},Automatic},
        Dividers->{None,{None,{LightGray},None}},
        Alignment->{{Center,Left},Center}
    ]
Фильмы (сериалы) в которых играет больше всего актёров "Игры престолов"

Как тесно связаны между собой актёры "Игры престолов"

Построим граф, показывающий в скольких картинах (фильмах, сериалах и пр.) актёры "Игры престолов" играли вместе. Чем толще и краснее линия, тем больше общих картин у данной пары актёров. (Оригинал)
In[68]:=

GOTInfographicsPoster[    
    #,
    "Как тесно связаны между собой актёры \"Игры престолов\"",
    "ImageSize"->2500
]&@
    (        
        ConnectedGraphComponents[
            GOTGraphPlot[#,1,"ImageSize"->2500,"MaxThickness"->20]
        ][
            [1]
        ]&@
            Tally[
                UndirectedEdge@@@
                    Map[                        
                        Sort,
                        Flatten[                            
                            Map[                                
                                Subsets[#,{2}]&,
                                Select[                                    
                                    Values[GOTRawData["costars.json"]][                                        
                                        [                                        
                                        ;;,
                                        "actors",
                                        All,
                                        "characterName"
                                        ]
                                    ],
                                    Length[#]>1&
                                ]
                            ],
                            1
                        ]
                    ]
            ]
    )
Как тесно связаны между собой актёры "Игры престолов"

Разговоры в "Игре престолов"

Многие любят "Игру престолов" за диалоги. Посмотрим, в какой серии их больше всего:
In[69]:=

GOTInfographicsPoster[    
    #,
    "Количество слов, сказанных в сериях \"Игры престолов\"",
    "ImageSize"->1000
]&@
    BarChart[        
        #,
        BarSpacing->{0.05,1},
        AspectRatio->1/2,
        ImageSize->1000,
        ChartLabels->{Keys[#],Range[10]},
        ColorFunction->Function[{x},ColorData["Rainbow"][x]],
        GridLines->{None,Range[0,10000,500]},
        FrameLabel->
            Map[                
                Style[#,FontFamily->"Open Sans",20,Bold]&,
                {"Сезон и серия в нём","Количество сказанных слов"}
            ],
        Frame->True,
        Background->GrayLevel[0.95],
        PlotRangePadding->0,
        PlotRange->All
    ]&@
    GroupBy[        
        Map[            
            {#[[1;;2]],Total[#[[3]][[;;,"count"]]]}&,
            Lookup[                
                GOTRawData["wordcount.json"]["count"],
                {"seasonNum","episodeNum","text"}
            ]
        ],
        #[[1,1]]&,
        #[[;;,2]]&
    ]
Количество слов, сказанных в сериях "Игры престолов"
Выясним, кто больше всего "болтает" в "Игре престолов" — ответ довольно предсказуем, но удивляет отрыв Тириона почти в 2 раза от ближайшего к нему персонажа.
In[70]:=

GOTInfographicsPoster[    
    #1,
    "Кто больше всего говорит в \"Игре престолов\"?",
    "ImageSize"->1500
]&@
    (        
        (            
            BarChart[                
                #1[[1;;All,1]],
                PlotRangePadding->0,
                BarSpacing->0.25,
                BarOrigin->Left,
                AspectRatio->1.9,
                ImageSize->1500,
                ChartLabels->#1[[1;;All,2]],
                Frame->True,
                GridLines->{Range[0,10^5,10^3],None},
                ColorFunction->ColorData["Rainbow"],
                FrameLabel->
                    {                        
                        {None,None},
                        Style[#,FontFamily->"Open Sans Light",16]&/@
                            {                                
                                "Количество сказанных слов",
                                "Количество сказанных слов"
                            }
                    },
                FrameTicks->{Automatic,{All,All}},
                Background->GrayLevel[0.95]
            ]&
        )[
            KeyValueMap[                
                {#2,#1/.$characterCardShortSmall}&,
                Select[                    
                    SortBy[                        
                        GroupBy[                            
                            Flatten[
                                GOTRawData["wordcount.json"]["count"][
                                    [;;,"text"]
                                ]
                            ],
                            #[["name"]]&,
                            Total[#[[;;,"count"]]]&
                        ],
                        #&
                    ],
                    #>1000&
                ]
            ]
        ]
    )
Кто больше всего говорит в "Игре престолов"?
Наконец, построим диаграмму, показывающую количество экранного времени и количество сказанным персонажем слов вместе:
In[71]:=

GOTInfographicsPoster[    
    #1,
    "Соотношение количества экранного времени и сказанных слов у персонажей \"Игры престолов\"\n(масштаб логарифмический)",
    "ImageSize"->2000
]&@
    Module[{data1,data2,intersection},        
        data1=
            Merge[
                $GOTEpisodeData[[;;,"ScreenTime"]],Total[Flatten[#]]&
            ];
        data2=
            GroupBy[                
                Flatten[
                    GOTRawData["wordcount.json"]["count"][[;;,"text"]]
                ],
                #[["name"]]&,
                Total[#[[;;,"count"]]]&
            ];
        intersection=Intersection[Keys@data1,Keys@data2];
        ListPlot[            
            Callout[{data1[#],data2[#]},#/.$characterCardShortSmall]&/@
                intersection,
            AspectRatio->1,
            ImageSize->2000,
            PlotRange->All,
            ScalingFunctions->{"Log10","Log10"},
            GridLines->
                {                    
                    {10,100}~Join~Range[0,10^5,1000],
                    {10,100}~Join~Range[0,10^5,1000]
                },
            Frame->True,
            FrameTicks->All,
            FrameLabel->
                ReplaceAll[                    
                    {                        
                        {1,1}"Количество сказанных слов",
                        {1,1}"Время на экране, с"
                    },
                    x_String:>Style[x,FontFamily->"Open Sans",20,Bold]
                ],
            Background->GrayLevel[0.95],
            PlotMarkers->{Automatic,Small},
            GridLinesStyle->GrayLevel[0.85]
        ]
    ]
Соотношение количества экранного времени и сказанных слов у персонажей "Игры престолов" (масштаб логарифмический)

Пол персонажей "Игры престолов": кого больше, мужчин или женщин?

Пол по имени персонажа:
In[1]:=
$gender=    <|    
    Flatten[
        KeyValueMap[
            Thread[#2->#1]&,GOTRawData["characters-gender-all.json"]
        ]
    ]
    ~
    Join
    ~
    {        
        "Aegon Targaryen"->"male",
        "Aerys II Targaryen"->"male",
        "Archmaester Marwyn"->"male",
        "Baratheon Guard"->"male",
        "Brandon Stark"->"male",
        "Child of the Forest"->"male",
        "Elia Martell"->"female",
        "Eon Hunter"->"male",
        "Goldcloak #1"->"male",
        "Goldcloak #2"->"male",
        "Knight of House Frey"->"male",
        "Knight of House Lynderly"->"male",
        "Kurleket"->"male",
        "Lannister Guardsman"->"male",
        "Lord Galbart Glover"->"male",
        "Male Prostitute"->"male",
        "Masha Heddle"->"female",
        "Meereen Slave Master"->"male",
        "Mikken"->"male",
        "Night's Watch Deserter"->"male",
        "Night's Watch Messenger"->"male",
        "Night's Watch Officer"->"male",
        "Pentoshi Servant"->"male",
        "Rhaella Targaryen"->"female",
        "Rhaenys Targaryen"->"female",
        "Stark Bannerman"->"male",
        "Stark Guard"->"male",
        "Wedding Band"->"male",
        "White Walker #2"->"male",
        "Willis Wode"->"male",
        "Young Ned"->"male"
    }|>
Соотношение персонажей "Игры престолов" по полу — видно, что на одну женщину приходится по 3 мужчины. Создается ощущение иногда, что мужские персонажи лишь антураж для мощных женских).
In[2]:=
GOTInfographicsPoster[
    #,"Соотношение мужских и женских персонажей в Игре престолов"
]&@
    Module[{labels,counts,percents},        
        {labels,counts}=Transpose[Tally[Values[$gender]]];
        percents=PercentForm/@N[counts/Total[counts]];
        PieChart[            
            counts,
            ChartLabels->
                Map[                                        
                    Style[                        
                        Row[#,"\n"],
                        20,
                        Bold,
                        Black,
                        FontFamily->"Open Sans"
                    ]&,
                    Transpose[{labels,counts,percents}]
                ],
            ChartStyle->{LightRed,LightBlue},
            ImageSize->600,
            Background->GrayLevel[0.95]
        ]
    ]

Вспомогательные функции для инфографики

Дом персонажа

Дом персонажа по его имени:
In[3]:=
$GOTCharacterHouse=    <|
    Rule@@@
        Reverse/@
            Flatten[                
                Thread/@
                    Values[
                        GOTRawData["characters-houses.json"]["house"]
                    ],
                1
            ]|>;
Эмблема дома по его названию:
In[4]:=
$GOTHouseSignData=
    AssociationThread[        
        {            
            "Arryn",
            "Baratheon",
            "Frey",
            "Greyjoy",
            "Lannister",
            "Martell",
            "Stark",
            "Targaryen",
            "Tully",
            "Tyrell",
            "White Walkers",
            "Night's Watch",
            "Dothraki",
            "Wildlings",
            "Include",
            "Mormont",
            "Umber",
            "Bolton",
            "Tarly"
        }->
            (
                ImagePad[#,10,White]&/@
                    ConformImages[                                                
                        (
                            ImageCrop/@
                                Flatten[                                    
                                    ImagePartition[
                                        #,ImageDimensions[#]*{1/5,1/2}
                                    ]&[
                                        Import[
                                            "https://7kingdoms.ru/wp-content/uploads/2012/04/GOT_Sigils_01.png"
                                        ]
                                    ]
                                ]
                        )
                        ~
                        Join
                        ~
                        Map[                            
                            Import,
                            {                                
                                "https://i.pinimg.com/originals/5f/35/cb/5f35cb4d592cf7d2cbb4c1103ce31bf8.jpg",
                                "https://i.pinimg.com/originals/4b/de/19/4bde1957b20e0f68a1566b39b408cb38.jpg",
                                "https://i.pinimg.com/originals/4a/1b/59/4a1b59348d3f502bcc3c85340e092edc.jpg",
                                "https://ih1.redbubble.net/image.516956392.1541/raf,750x1000,075,t,fafafa:ca443f4786.jpg",
                                "https://ae01.alicdn.com/kf/HTB19O9dNXXXXXcpaXXXq6xXFXXXS/Iron-Throne-GOT-Toilet-Vinyl-Wall-Sticker-Game-of-thrones-Wall-Decals-For-Bathroom-Decoration.jpg",
                                "https://oyster.ignimgs.com/mediawiki/apis.ign.com/game-of-thrones/7/7a/300px-GoT_sigils_08.jpg",
                                "https://i.etsystatic.com/5840482/r/il/88beca/854713479/il_794xN.854713479_4t7z.jpg",
                                "https://vignette.wikia.nocookie.net/gameofthrones/images/d/dd/House-Bolton-Main-Shield.PNG",
                                "https://vignette.wikia.nocookie.net/gameofthrones/images/2/2d/House-Tarly-Main-Shield.PNG"
                            }
                        ],
                        {150,Automatic},
                        "Fit",
                        Padding->White
                    ]
            )
    ];
    
SetAttributes[$GOTHouseSign, Listable];

$GOTHouseSign[name_String] :=
     $GOTHouseSignData[name];
Вычислим эмблему дома Старков:
In[5]:=
$GOTHouseSign["Stark"]
Сформируем запрос для получения списка нескольких персонажей с эмблемами их домов:
In[6]:=
{#,Image[$GOTHouseSign[$GOTCharacterHouse[#]],ImageSize->100]}&/@
    {"Arya Stark","Walder Frey","Yara Greyjoy","Tyrion Lannister"}

Карточка персонажа — потребуется для всевозможных графов и таблиц

Иконка пола (для персонажей без изображения):
In[7]:=
$GenderIcon=
    AssociationThread[
        {"male","female"}->
            (                
                ImagePad[                    
                    ImageResize[ColorConvert[#,"GrayScale"],150],
                    100,
                    White
                ]&/@
                    (
                        ImageCrop/@
                            (                                
                                {                                    
                                    ImageTake[#,All,{1,450}],
                                    ImageTake[#,All,{-450,-1}]
                                }&@
                                    Import[
                                        "http://clipart-library.com/images/kc85Mg5zi.jpg"
                                    ]
                            )
                    )
            )
    ];
Иконка персонажа по его имени (в оригинальном размере):
In[8]:=
If[
    FileExistsQ[#],
    Get@#,
    (* else *)    
    $characterImageRaw=
        Association@
            Quiet[                
                Rule[                    
                    #[[1]],
                    If[
                        Head[#[[2]]]===Missing,
                        $GenderIcon[$gender[#[[1]]]],
                        (* else *)
                        Check[                            
                            Import[#[[2]]],
                            $GenderIcon[$gender[#[[1]]]]
                        ]
                    ]
                ]&/@
                    Lookup[                        
                        GOTRawData["characters.json"]["characters"],
                        {"characterName","characterImageFull"}
                    ]
            ];
    DumpSave[#,$characterImageRaw]
]&@
    FileNameJoin[{NotebookDirectory[],"$characterImageRaw.mx"}];
Несколько персонажей с их изображениями:
In[9]:=
{#,Image[$characterImageRaw[#],ImageSize->100]}&/@
    RandomSample[Keys[$characterImageRaw],10]
Стандартизация изображений:
In[10]:=

$characterImage=
    With[
    {
        alphaChannel=
            ImageResize[ColorNegate[Rasterize[Graphics[Disk[]]]],300]
    },
        Map[                        
            SetAlphaChannel[                
                ImageResize[
                    ImageCrop[#,{1,1}Min[ImageDimensions[#]]],300
                ],
                alphaChannel
            ]&,
            $characterImageRaw
        ]
    ];
In[11]:=
{#,Image[$characterImage[#],ImageSize->100]}&/@
    RandomSample[Keys[$characterImage],10]
Карточка персонажа:
In[12]:=
$characterCardFull=    <|        
    #[[1]]
    ->
    Framed[                
        Style[            
            #,
            14,
            FontFamily->"Open Sans Light",
            Bold,
            TextAlignment->Center
        ]&@
            Row[
                {                    
                    Row[
                        {                            
                            Image[
                                $characterImage[#[[1]]],ImageSize->100
                            ],
                            " ",
                            If[
                                Head[#[[4]]]===Missing,
                                "",
                                (* else *)
                                Row[                                    
                                    Flatten@
                                        List[                                            
                                            $GOTHouseSign[#[[4]]]
                                            /.                                            
                                            image_Image
                                            :>
                                            Image[                                                
                                                image,
                                                ImageSize->
                                                    {Automatic,100}
                                            ]
                                        ],
                                    " "
                                ]
                            ]
                        }
                    ],
                    "\n",
                    #[[1]],
                    If[
                        Head[#[[2]]]===Missing,
                        Nothing,
                        (* else *)
                        Row[
                            {                                
                                "\nАктёр: ",
                                If[
                                    Head[#[[3]]]===Missing,
                                    #[[2]],
                                    (* else *)
                                    Hyperlink[                                        
                                        #[[2]],
                                        "https://www.imdb.com"<>#[[3]]
                                    ]
                                ]
                            }
                        ]
                    ]
                }
            ],
        RoundingRadius->10,
        Background->White,
        FrameStyle->Directive[LightGray,AbsoluteThickness[2]]
    ]&/@
        Lookup[            
            GOTRawData["characters.json"]["characters"],
            {"characterName","actorName","actorLink","houseName"}
        ]|>;
In[13]:=
$characterCardShort=    <|        
    #[[1]]
    ->
    Framed[                
        Style[            
            #,
            14,
            FontFamily->"Open Sans Light",
            Bold,
            TextAlignment->Center
        ]&@
            Row[
                {                    
                    Image[$characterImage[#[[1]]],ImageSize->40],
                    " ",
                    #[[1]]
                }
            ],
        RoundingRadius->10,
        Background->White,
        FrameStyle->Directive[LightGray,AbsoluteThickness[2]]
    ]&/@
        Lookup[            
            GOTRawData["characters.json"]["characters"],
            {"characterName"}
        ]|>;
In[14]:=
$characterCardShortSmall=    <|        
    #[[1]]
    ->
    Framed[                
        Style[            
            #,
            12,
            FontFamily->"Open Sans Light",
            Bold,
            TextAlignment->Center
        ]&@
            Row[
                {                    
                    Image[$characterImage[#[[1]]],ImageSize->30],
                    "  ",
                    #[[1]]
                }
            ],
        RoundingRadius->6,
        Background->White,
        FrameStyle->Directive[LightGray,AbsoluteThickness[2]],
        FrameMargins->2
    ]&/@
        Lookup[            
            GOTRawData["characters.json"]["characters"],
            {"characterName"}
        ]|>;
In[15]:=
$characterCardFull/@
    {        
        "Arya Stark",
        "Walder Frey",
        "Yara Greyjoy",
        "Tyrion Lannister",
        "Jon Snow"
    }
In[16]:=
$characterCardShort/@
    {        
        "Arya Stark",
        "Walder Frey",
        "Yara Greyjoy",
        "Tyrion Lannister",
        "Jon Snow"
    }
In[17]:=
$characterCardShortSmall/@
    {        
        "Arya Stark",
        "Walder Frey",
        "Yara Greyjoy",
        "Tyrion Lannister",
        "Jon Snow"
    }

GOTRawData

Функция импорта данных из JSON в виде ассоциации Association.
In[72]:=
ClearAll[GOTRawData];
In[73]:=

GOTRawData[name_String/;FileExtension[name]==="json"]:=
    GOTRawData[name]=
        Import[FileNameJoin[{NotebookDirectory[],name}],"RawJSON"];

circleInfographics, circleInfographicsPositions

circleInfographics создает бабл-диаграмму из кругов, пропорциональных величинам данных, при этом поверх самих кругов можно отображать произвольную информацию.
In[74]:=
ClearAll[circleInfographics,circleInfographicsPositions];
In[75]:=

circleInfographicsPositions[    
    data_,
    OptionsPattern[
        {"Precision"->10^-3,"StepDecrease"->N[1-1/100],"MaxSteps"->10000}
    ]
]:=
    Module[
    {        
        radii,
        names,
        kol,
        translate,
        subsets,
        pos,
        valValue,
        colorDataLength,
        colorData,
        mean,
        index,
        colorScale,
        tol,
        mult,
        shapeF,
        colorFunction,
        xmin,
        xmax,
        ymin,
        ymax
    },        
        radii=N[Sqrt[#/Max[#]]]&@data;
        kol=Length[radii];
        pos=RandomReal[{-10,10},{kol,2}];
        translate[{p1_,p2_},dir_]:=
            dirNormalize[p2-p1];
        subsets=Subsets[Range[kol],{2}];
        tol=OptionValue["Precision"];
        mult=OptionValue["StepDecrease"];
        valValue=1.;
        index=1;
        While[            
            valValue>tol&&index=
                                            Total[radii[[#]]],                                            
                                            translate[
                                                {#,mean},valValue
                                            ]&/@
                                                pos[[#]],
                                            (* else *)
                                            With[
                                            {
                                                delta=                                                    
                                                    (                                                        
                                                        Total[
                                                            radii[[#]]
                                                        ]
                                                        -
                                                        Norm[
                                                            Subtract@@
                                                                pos[                                                                    
                                                                    [
                                                                    #
                                                                    ]
                                                                ]
                                                        ]
                                                    )
                                                    /
                                                    2
                                            },
                                                {                                                    
                                                    translate[                                                        
                                                        pos[[#]],
                                                        -delta
                                                    ],
                                                    translate[                                                        
                                                        Reverse[
                                                            pos[[#]]
                                                        ],
                                                        -delta
                                                    ]
                                                }
                                            ]
                                        ]&,
                                        subsets
                                    ],
                                    1
                                ]
                            }
                        ],
                        First
                    ][
                        [;;,;;,2]
                    ]
                ];
            index++;
            valValue=mult*valValue
        ];
        pos
    ];
In[76]:=
circleInfographics[    
    data_,
    OptionsPattern[
        {            
            "Precision"->10^-3,
            "StepDecrease"->N[1-1/100],
            "MaxSteps"->10000,
            "ShapeFunction"->Disk,
            "Background"->GrayLevel[0.95],
            "ColorFunction"->ColorData["TemperatureMap"],
            "ImageSize"->1000
        }
    ]
]:=    
    Module[
    {        
        radii,
        names,
        kol,
        pos,
        colorDataLength,
        colorData,
        colorScale,
        shapeF,
        colorFunction,
        xmin,
        xmax,
        ymin,
        ymax
    },        
        names=data[[;;,1]];
        radii=N[Sqrt[#/Max[#]]]&@data[[;;,2]];
        kol=Length[radii];
        pos=
            circleInfographicsPositions[                
                data[[;;,2]],
                "Precision"->OptionValue["Precision"],
                "StepDecrease"->OptionValue["StepDecrease"],
                "MaxSteps"->OptionValue["MaxSteps"]
            ];
        colorScale=Evaluate[Rescale[#,MinMax[radii],{0,1}]]&;
        colorFunction=OptionValue["ColorFunction"];
        {{xmin,xmax},{ymin,ymax}}=
            RegionBounds[RegionUnion[Disk@@#&/@Transpose@{pos,radii}]];
        shapeF=
            Which[                
                OptionValue["ShapeFunction"]===Disk,                
                {                    
                    {colorFunction[colorScale[#2]],Disk[#1,#2]},
                    Inset[#3,#1,Scaled[{1/2,1/2}],1.75#2]
                }&,
                OptionValue["ShapeFunction"]===Circle,                
                {                    
                    {                        
                        colorFunction[colorScale[#2]],
                        Disk[#1,#2],
                        White,
                        Disk[#1,0.9#2]
                    },
                    Inset[#3,#1,Scaled[{1/2,1/2}],1.75#2]
                }&
            ];
        Graphics[            
            Array[shapeF[pos[[#]],radii[[#]],names[[#]]]&,kol],
            ImageSize->{1,1}OptionValue["ImageSize"],
            PlotRange->1.05{{xmin,xmax},{ymin,ymax}},
            Background->OptionValue["Background"]
        ]
    ]
    circleInfographicsPositions

$GOTLogo, GOTInfographicsPoster

GOTInfographicsPoster служит для создания стилизованного постера с инфографикой из данной статьи.
In[77]:=

$GOTLogo=
    ImageResize[        
        Import[
            "https://7kingdoms.ru/wp-content/uploads/2011/01/got-logo.png"
        ],
        500
    ];
In[78]:=
ClearAll[GOTInfographicsPoster];
In[79]:=

GOTInfographicsPoster[    
    imageInitial_,
    title_,
    OptionsPattern[
        {            
            "Background"->GrayLevel[0.95],
            "ImageResolution"->150,
            "ImageSize"->800
        }
    ]
]:=
    Module[
    {        
        image=
            ImageResize[                
                Rasterize[                    
                    imageInitial,
                    ImageResolution->OptionValue["ImageResolution"]
                ],
                OptionValue["ImageSize"]
            ],
        readyImage
    },        
        readyImage=
            Image[#,ImageSize->All]&@
                ImageResize[                    
                    Rasterize[                        
                        Framed[                            
                            Pane[                                
                                Grid[                                    
                                    {                                        
                                        {                                            
                                            Image[                                                
                                                $GOTLogo,
                                                ImageSize->
                                                    {Automatic,30}
                                            ],
                                            Item[                                                
                                                Style[                                                    
                                                    title,
                                                    FontFamily->
                                                        "Myriad Pro",
                                                    30,
                                                    LineSpacing->
                                                        {0.8,0,0},
                                                    TextAlignment->
                                                        Center
                                                ],
                                                Alignment->Center
                                            ]
                                        },
                                        {"",""},
                                        {                                            
                                            Image[                                                
                                                image,
                                                ImageSize->
                                                    OptionValue[
                                                        "ImageSize"
                                                    ]
                                            ],
                                            SpanFromLeft
                                        },
                                        {"",""},
                                        {                                            
                                            Item[
                                                Style[                                                    
                                                    Row[
                                                        {                                                            
                                                            "Вся инфографика по \"Игре престолов\" \[LongDash] wolframmathematica.ru/blog/got\nКороткая ссылка \[LongDash] ",
                                                            Style[                                                                
                                                                "bit.ly/2GNk5Gw",
                                                                Bold
                                                            ]
                                                        }
                                                    ],
                                                    FontFamily->
                                                        "Myriad Pro",
                                                    20,
                                                    GrayLevel[0.4],
                                                    TextAlignment->
                                                        Center
                                                ]
                                            ],
                                            SpanFromLeft
                                        }
                                    },
                                    Alignment->{Center,Center}
                                ],
                                ImageSize->
                                    (ImageDimensions[image]+{0,100}),
                                ImageSizeAction->"ShrinkToFit"
                            ],
                            Background->OptionValue["Background"],
                            FrameMargins->20,
                            FrameStyle->OptionValue["Background"]
                        ],
                        ImageResolution->OptionValue["ImageResolution"]
                    ],
                    ImageDimensions[image][[1]]
                ];
        Export[            
            FileNameJoin[
                {                    
                    NotebookDirectory[],
                    "GOTInfographics",                    
                    StringReplace[                        
                        StringReplace[                            
                            StringReplace[                                
                                ToLowerCase[ToString@title],
                                {                                    
                                    "\""->"",
                                    ","->" ",
                                    "."->"",
                                    "\n"->" ",
                                    "("->"",
                                    ")"->"",
                                    "?"->""
                                }
                            ],
                            " "..->" "
                        ],
                        " "->"-"
                    ]
                    <>
                    ".png"
                }
            ],
            readyImage
        ];
        readyImage
    ];

stripLineInfographics

stripLineInfographics служит для создания круговой парной диаграммы.
In[80]:=
ClearAll[stripLineInfographics];
In[81]:=
stripLineInfographics[    
    dataInitial_,
    OptionsPattern[
        {            
            "Ordering"->True,
            "Reverse"->False,
            "Gaps"->{50,50},
            "ColorFunctionLeft"->ColorData["Rainbow"],
            "ColorFunctionRight"->
                Function[Blend[ColorData[3,"ColorList"],#]],
            "ImageSize"->1500,
            "Background"->GrayLevel[0.95]
        }
    ]
]:=
    Module[
    {        
        circle,
        zeroElement,
        countSegmentPartition,
        ordering,
        data,
        totalsForRows,
        rowsMainSegments,
        rowsColsSegments,
        totalForCols,
        colsMainSegments,
        colsRowsSegments,
        segmentMaker,
        $colorizationMax,
        rightLabels,
        leftLabels,
        preData,
        dataOriginal
    },        
        If[            
            Head[dataInitial]===Association,            
            {rightLabels,leftLabels,preData}=
                Transpose[
                    KeyValueMap[
                        {#1,#2[[;;,1]],#2[[;;,2]]}&,dataInitial
                    ]
                ];
            leftLabels=Flatten@leftLabels;
            dataOriginal=
                Module[{n=Length[Flatten[preData]],k=Length[preData],acc},                    
                    acc={0}~Join~Accumulate[Length/@preData];
                    Transpose@
                        Table[                                                        
                            ConstantArray[0,{acc[[i]]}]
                            ~
                            Join
                            ~
                            preData[[i]]
                            ~
                            Join
                            ~
                            ConstantArray[0,{n-acc[[i+1]]}],
                            {i,1,k}
                        ]
                ]
        ];
        If[
            OptionValue["Reverse"],            
            {rightLabels,leftLabels}={leftLabels,rightLabels};
            dataOriginal=Transpose[dataOriginal],
            (* else *)
            Nothing
        ];
        circle[pos_,radius_,{min_,max_},numberOfCirclePartition_:50]:=
            If[
                min==max,
                zeroElement[
                    pos+radius{Cos[min],Sin[min]}+0{Cos[min],Sin[min]}
                ],
                (* else *)
                Table[                                        
                    pos
                    +
                    radius{Cos[a],Sin[a]}
                    +
                    0{Cos[(min+max)/2],Sin[(min+max)/2]},
                    {a,min,max,(max-min)/numberOfCirclePartition}
                ]
            ];
        countSegmentPartition[
            data_List,{startOfSegment_,endOfSegment_},gapPercent_:0
        ]:=
            Module[
            {                
                segmentLength=endOfSegment-startOfSegment,
                segmentLengh,
                segments,
                segmentActialLength,
                delta
            },                
                segmentActialLength=(1-gapPercent/100)segmentLength;
                delta=(gapPercent/100)segmentLength/(Length[data]+1);
                If[
                    Total[data]==0,
                    ConstantArray[                        
                        zeroElement[{startOfSegment,endOfSegment}],
                        Length[data]
                    ],
                    (* else *)                    
                    segments=
                        N[                            
                            startOfSegment
                            +                            
                            segmentActialLength
                            *                            
                            Partition[Prepend[Accumulate[data],0],2,1]
                            /
                            Total[data]
                        ]
                    ;                    
                    (*
                    #+0.01{1,-1}(-Subtract@@#)*gapPercent/2&/@segments
                    *)
                    Map[                        
                        delta+#&,
                        Table[                            
                            (i-1)delta+segments[[i]],
                            {i,1,Length[data]}
                        ]
                    ]
                ]
            ];
        ordering=
            If[
                OptionValue["Ordering"],
                Ordering[dataOriginal,All,Total[#1]>Total[#2]&],
                (* else *)
                Range[1,Length[dataOriginal]]
            ];
        data=dataOriginal[[ordering]];
        totalsForRows=Total/@data;
        rowsMainSegments=
            countSegmentPartition[
                totalsForRows,{Pi/2,3Pi/2},OptionValue["Gaps"][[1]]
            ];
        rowsColsSegments=
            Apply[                
                countSegmentPartition[#1,#2,0]&,
                Transpose[{data,rowsMainSegments}],
                {1}
            ];
        totalForCols=Total/@Transpose[data];
        colsMainSegments=
            countSegmentPartition[
                totalForCols,{Pi/2,-Pi/2},OptionValue["Gaps"][[2]]
            ];
        colsRowsSegments=
            Apply[                
                countSegmentPartition[#1,#2,0]&,
                Transpose[{Transpose@data,colsMainSegments}],
                {1}
            ];
        segmentMaker[            
            {{segmentFirst_,segmentSecond_},{colorization_}},
            colorizationMax_
        ]:=
            Module[{splineFragmentFirst,splineFragmentSecond},
                If[                    
                    Head[segmentFirst]===zeroElement
                    ||
                    Head[segmentSecond]===zeroElement,
                    Nothing,
                    (* else *)                    
                    {splineFragmentFirst,splineFragmentSecond}=
                        Map[                            
                            circle[{0,0},1,#]&,
                            {segmentFirst,segmentSecond}
                        ];
                    If[
                        FreeQ[                            
                            {splineFragmentFirst,splineFragmentSecond},
                            zeroElement
                        ],
                        {                            
                            Opacity[0.8]
                            ,
                            OptionValue["ColorFunctionLeft"][
                                1-(colorization-1)/(colorizationMax-1)
                            ]                            
                            (*                            
                            ;
                            Blend[                                
                                ColorData[$colorScheme,"ColorList"],
                                (colorization-1)/(colorizationMax-1)
                            ]
                            *)
                            ,
                            With[
                            {
                                reversedSplineFragmentSecond=
                                    Reverse[splineFragmentSecond]
                            },
                                FilledCurve[
                                    BezierCurve[                                        
                                        Join[                                            
                                            splineFragmentFirst,
                                            {
                                                Mean[
                                                    {                                                        
                                                        splineFragmentFirst[
                                                            [-1]
                                                        ],
                                                        {0,0},
                                                        reversedSplineFragmentSecond[
                                                            [1]
                                                        ]
                                                    }
                                                ]
                                            },
                                            reversedSplineFragmentSecond,
                                            {                                                
                                                Mean[
                                                    {                                                        
                                                        reversedSplineFragmentSecond[
                                                            [-1]
                                                        ],
                                                        {0,0},
                                                        splineFragmentFirst[
                                                            [1]
                                                        ]
                                                    }
                                                ],
                                                splineFragmentFirst[
                                                    [1]
                                                ]
                                            }
                                        ],
                                        SplineDegree->2
                                    ]
                                ]
                            ]
                        },
                        (* else *)
                        Nothing
                    ]
                ]
            ];
        $colorizationMax=Length[rowsColsSegments];
        Graphics[            
            {                
                SortBy[                    
                    MapIndexed[                                                
                        Map[                            
                            segmentMaker[#,$colorizationMax]&,
                            Outer[Sequence,Transpose[#1],{#2},1]
                        ]&,
                        Transpose[
                            {                                
                                rowsColsSegments,
                                Transpose@colsRowsSegments
                            }
                        ]
                    ],
                    ByteCount
                ],
                Table[                                        
                    (circle[{0,0},1,#]&@rowsMainSegments[[i]])
                    /.
                    {                        
                        zeroElement[point_]:>Point[point],
                        line:{_List..}:>
                            {                                
                                CapForm["Round"]
                                ,
                                AbsoluteThickness[5]
                                ,                                
                                (*                                
                                Blend[                                    
                                    ColorData[
                                        $colorScheme,"ColorList"
                                    ],
                                    (i-1)/($colorizationMax-1)
                                ];
                                *)
                                OptionValue["ColorFunctionLeft"][
                                    1-(i-1)/($colorizationMax-1)
                                ]
                                ,
                                Line[line]
                            }
                    },
                    {i,1,Length[rowsMainSegments]}
                ],
                Table[                                        
                    (circle[{0,0},1,#]&@colsMainSegments[[i]])
                    /.
                    {                        
                        zeroElement[point_]:>Point[point],
                        line:{_List..}:>
                            {                                
                                AbsoluteThickness[5],
                                CapForm["Round"],
                                OptionValue["ColorFunctionRight"][                                    
                                    1
                                    -
                                    (i-1)/(Length[colsMainSegments]-1)
                                ],
                                Line[line]
                            }
                    },
                    {i,1,Length[colsMainSegments]}
                ],                
                Text[                    
                    Style[#1,FontFamily->"Open Sans",14],
                    1.025{Cos[#],Sin[#]}&[Mean@#2],
                    {1,0},
                    {Cos[#+Pi],Sin[#+Pi]}&[Mean@#2]
                ]&@@@
                    Transpose[
                        {leftLabels[[ordering]],rowsMainSegments}
                    ],                
                Text[                    
                    Style[#1,FontFamily->"Open Sans",14],
                    1.025{Cos[#],Sin[#]}&[Mean@#2],
                    {-1,0},
                    {Cos[#],Sin[#]}&[Mean@#2]
                ]&@@@
                    Transpose[{rightLabels,colsMainSegments}]
            },
            ImageSize->OptionValue["ImageSize"],
            Background->OptionValue["Background"]
        ]
    ]

GOTGraphPlot

GOTGraphPlot служит для создания специализированных графов.
In[82]:=
Clear[GOTGraphPlot];
In[83]:=

GOTGraphPlot[    
    data_,
    minData_,
    OptionsPattern[
        {            
            "ImageSize"->1500,
            "Background"->GrayLevel[0.95],
            "ColorFunction":>ColorData["Rainbow"],
            "MaxThickness"->10,
            "Opacity"->True,            
            "VertexF"
            ->
            (
                Function[
                    Tooltip[                                                
                        If[
                            Head[#]===Image,
                            Image[#,ImageSize->60],
                            (* else *)
                            Style[                                
                                StringReplace[#," "->"\n"],
                                LineSpacing->{0.8,0,0},
                                FontFamily->"Open Sans Light",
                                Bold,
                                12
                            ]
                        ]&@
                            (#/.$characterImage),
                        #/.$characterCardFull
                    ]
                ]
            ),
            "GraphLayout"->"GravityEmbedding"
        }
    ]
]:=
    Module[{min,max,rescaleF,normF,clearedData,preGraph,vertexList,edgeList},        
        clearedData=Select[data,#[[2]]>minData&];
        {min,max}=MinMax[clearedData[[;;,2]]];
        rescaleF=            
            Evaluate[
                Rescale[#,{min,max},{1,OptionValue["MaxThickness"]}]
            ]&;
        normF=Evaluate[Rescale[#,{min,max},{0,1}]]&;
        preGraph=Graph[clearedData[[;;,1]]];
        vertexList=VertexList[preGraph];
        edgeList=EdgeList[preGraph];
        Graph[            
            Map[                                
                Property[                    
                    #[[1]],
                    {
                        EdgeStyle->
                            Directive[
                                {                                    
                                    AbsoluteThickness[
                                        rescaleF[#[[2]]]
                                    ],
                                    If[
                                        OptionValue["Opacity"],
                                        Opacity[0.3+0.7normF[#[[2]]]],
                                        (* else *)
                                        Nothing
                                    ],
                                    OptionValue["ColorFunction"][
                                        normF[#[[2]]]
                                    ],
                                    CapForm["Round"]
                                }
                            ]
                    }
                ]&,
                clearedData
            ],
            VertexLabels->
                Map[                                        
                    Rule[
                        #,Placed[OptionValue["VertexF"][#],{1/2,1/2}]
                    ]&,
                    vertexList
                ],
            ImageSize->OptionValue["ImageSize"],
            Background->OptionValue["Background"],
            GraphLayout->OptionValue["GraphLayout"],
            AspectRatio->1,
            VertexShapeFunction->None
        ]
    ];
Список имен используемых встроенных функций и символов в порядке их появления в коде:
CompoundExpression (;), Set (=), Association, Join, Flatten, KeyValueMap, Function (&), Thread, Rule (->, ->), Slot (#), List ({...}), Module, Transpose, Tally, Values, Map (/@), PercentForm, N, Times (*, *), Power (^), Total, PieChart, ChartLabels, Style, Row, Bold, Black, FontFamily, ChartStyle, LightRed, LightBlue, ImageSize, Background, GrayLevel, Apply (@@), Reverse, AssociationThread, ImagePad, White, ConformImages, ImageCrop, ImagePartition, ImageDimensions, Import, Automatic, Padding, SetAttributes, Listable, SetDelayed (:=), Pattern (:), Blank (_), String ("..."), Image, ImageResize, ColorConvert, ImageTake, All, If, FileExistsQ, Get (<<), Quiet, Part ([[...]]), SameQ (===), Head, Missing, Check, Lookup, DumpSave, FileNameJoin, NotebookDirectory, RandomSample, Keys, With, ColorNegate, Rasterize, Graphics, Disk, SetAlphaChannel, Min, Framed, TextAlignment, Center, ReplaceAll (/.), RuleDelayed (:>, :>), Nothing, Hyperlink, StringJoin (<>), RoundingRadius, FrameStyle, Directive, LightGray, AbsoluteThickness, FrameMargins, DeleteCases, Union (\[Union]), DirectedEdge, DeleteDuplicates, UndirectedEdge, Select, Span (;;), UnsameQ (=!=), MemberQ, ClearAll, OptionsPattern, Graph, VertexLabels, Placed, Tooltip, StringReplace, LineSpacing, VertexShapeFunction, VertexSize, OptionValue, VertexStyle, EdgeForm, AspectRatio, GraphLayout, Property, EdgeStyle, Blue, Arrowheads, Darker, Green, Magenta, Orange, Red, Legended, LineLegend, LegendLayout, Top, Table, Print, Which, Equal (==), True, ToString, Plus (+), Sort, Subsets, SortBy, GroupBy, Round, QuantityMagnitude, UnitConvert, Subtract (-), TimeObject, First, RepeatedNull (...), Quantity, MixedUnit, Merge, ColorData, Multicolumn, Range, Length, BarChart, BarSpacing, ColorFunction, GridLines, None, FrameLabel, Frame, Last, ConstantArray, Cases, Condition (/;), Not (!, \[Not]), FreeQ, Complement, KeySort, ReplacePart, Grid, SpanFromLeft, Integer, Item, ItemSize, Dividers, Gray, ItemStyle, Alignment, FaceForm, LightOrange, Increment (++), Polygon, Accumulate, AbsolutePointSize, Point, Inset, Lighter, RGBColor, Scaled, PlotRangePadding, SwatchLegend, Identity, Partition, Infinity, Optional (:), Opacity, CapForm, Arrow, BSplineCurve, Mean, RandomInteger, Norm, RandomChoice, Export, BarOrigin, Left, Alternatives (|), Greater (>), ColorFunctionScaling, False, PlotRange, GridLinesStyle, FrameTicks, Callout, Bottom, Right, StringCases, Repeated (..), DigitCharacter, ToExpression, DateHistogram, DeleteMissing, TextCell, FontSize, Magnify, StringMatchQ, ToLowerCase, StringExpression (~~), BlankNullSequence (___), ConnectedGraphComponents, Intersection (\[Intersection]), ListPlot, ScalingFunctions, PlotMarkers, Small, FileExtension, Sqrt, Max, RandomReal, Normalize, While, And (&&, \[And]), Less (<), GatherBy, GreaterEqual (>=, >=), Evaluate, Rescale, MinMax, RegionBounds, RegionUnion, Circle, Array, ImageResolution, Pane, ImageSizeAction, Blend, Cos, Sin, Prepend, Ordering, Pi (\[Pi]), Or (||, \[Or]), FilledCurve, BezierCurve, SplineDegree, MapIndexed, Outer, Sequence, ByteCount, Line, Text, Clear, VertexList, EdgeList
Вебинары о технологиях Wolfram | СКОРО
Каждую неделю мы будем проводить вебинар о применении технологий Wolfram.

Мы будем собираться с вами на удобной онлайн-площадке и обсуждать самые разные вопросы программирования на языке Wolfram Language. Решать задачи в реальном времени и вы сможете, конечно, задавать вопросы.