Роман Осипов
"Игра престолов": строим инфографику об убийствах, сексе, путешествиях по Вестеросу и многое другое
БЛОГ переехал на новый адрес: 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. Решать задачи в реальном времени и вы сможете, конечно, задавать вопросы.
Мы будем собираться с вами на удобной онлайн-площадке и обсуждать самые разные вопросы программирования на языке Wolfram Language. Решать задачи в реальном времени и вы сможете, конечно, задавать вопросы.
Оставить заказ
Мы любим новые задачи!
Давайте начнём обсуждать вашу задачу и способы её совместного решения.
Давайте начнём обсуждать вашу задачу и способы её совместного решения.
Вебинары о технологиях Wolfram | СКОРО
Каждую неделю мы будем проводить вебинар о применении технологий Wolfram.
Мы будем собираться с вами на удобной онлайн-площадке и обсуждать самые разные вопросы программирования на языке Wolfram Language. Решать задачи в реальном времени и вы сможете, конечно, задавать вопросы.
Мы будем собираться с вами на удобной онлайн-площадке и обсуждать самые разные вопросы программирования на языке Wolfram Language. Решать задачи в реальном времени и вы сможете, конечно, задавать вопросы.
© ИП "Осипов Роман Алексеевич", 2019.
ОГРНИП 315774600050891