Анализ текста в Mathematica: выделение цитат, цветов и многое другое…

Анализ текста в Mathematica: выделение цитат, цветов и многое другое... Статьи

Некоторое время назад в Интернете на сайте журнала Esquire я встретил небольшую красивую статью о цветах, которые использовали авторы в своих произведениях. Ниже вы можете увидеть одну из созданных в статье интерактивных визуализаций. Саму статью можно увидеть перейдя по ссылке.

Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Само собой, у меня появилось желание создать программу в Mathematica, которая позволила бы создавать подобные (и не только) объекты для любых произведений, которые мне интересны.

В качестве интересующего меня произведения я возьму книгу Арнольда Шварценеггера (Arnold Schwarzenegger) "Вспомнить все" (Total Recall). Выбрал я ее по многим причинам, на которых я сейчас не буду останавливаться.

Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Вступительные слова...

Что-ж, давайте загрузим текст в Mathematica:

In[1]:=
Short[fullTextRu=Import[FileNameJoin[{NotebookDirectory[], "ArnoldTotalRecallRu.txt"}]]]
Out[1]//Short=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Перед тем, как приступить к основной работе, можно немного развлечься и произвести разнообразный анализ текста. Для начала, давайте найдем сколько символов использовано в тексте:

In[2]:=
StringLength[fullTextRu]
Out[2]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Теперь узнаем из скольких абзацев состоит текст:

In[3]:=
StringCount[fullTextRu, "\n"]+1
Out[3]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

А также сколько в тексте предложений

In[4]:=
StringCount[fullTextRu, "."]
Out[4]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Теперь найдем количество вхождений каждого из символов, предварительно сделав все буквы строчными:

In[5]:=
charactersData=Tally[Characters[StringReplace[fullTextRu, Thread[CharacterRange["А", "Я"]->CharacterRange["а", "я"]]]]]
Out[5]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Отсортируем символы:

In[6]:=
charactersDataSorted=Sort[charactersData, ToCharacterCode[#1[[1]]][[1]]<ToCharacterCode[#2[[1]]][[1]]&]
Out[6]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Теперь построим их распределение:

In[7]:=
Panel@Rotate[BarChart[charactersDataSorted[[;;, 2]], ChartLabels->Placed[Style[#, 12, Bold]&/@(charactersDataSorted[[;;, 1]]), Axis, Rotate[#, 90Degree]&], ColorFunction->Function[{height}, ColorData["Rainbow"][height]], ImageSize->950, GridLinesStyle->Dashed, PlotRangePadding->0, BarSpacing->0.5], -Pi/2]
Out[7]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Также отобразим только те символы, которые встречаются часто (например, больше 1000 раз):

In[8]:=
mostCommon=Cases[charactersDataSorted, {_, x_/;

x>1000}];

Panel@Rotate[BarChart[mostCommon[[;;, 2]], ChartLabels->Placed[Style[#, 12, Bold]&/@(mostCommon[[;;, 1]]/."\n"->FullForm["\n"]/." "->FullForm[" "]), Axis, Rotate[#, 90Degree]&], ColorFunction->Function[{height}, ColorData["Rainbow"][height]], ImageSize->900, GridLinesStyle->Dashed, PlotRangePadding->0, BarSpacing->0.1], -Pi/2]
Out[8]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Теперь можем найти самые распространенные слова, предлоги и пр.:

In[9]:=
Short[allWords=Sort[Tally[DeleteCases[StringSplit[StringReplace[StringReplace[fullTextRu, Thread[CharacterRange["А", "Я"]->CharacterRange["а", "я"]]], RegularExpression["[^"<>StringJoin@CharacterRange["а", "я"]<>"]"]->" "], " "], ""]], #1[[2]]>#2[[2]]&], 5]
Out[9]//Short=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Можно легко определить количество разнообразных слов и предлогов, которые использованы в тексте:

In[10]:=
Length[allWords]
Out[10]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Теперь выведем список 200 самых часто встречающихся слов и предлогов:

In[11]:=
allWords[[1;;200]][[;;, 1]]
Out[11]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

или их распределение в логарифмическом:

In[12]:=
ListLogPlot[allWords[[;;, 2]], Joined->True, PlotRange->All, ImageSize->600, AspectRatio->1, PlotStyle->Thick, Frame->True, FrameLabel->(Style[#, 30, FontFamily->"Myriad Pro Cond"]&/@{"Номер слова в списке", "n"})]
Out[12]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

или дважды логарифмическом масштабе:

In[13]:=
ListLogLogPlot[allWords[[;;, 2]], Joined->True, ImageSize->600, PlotRange->{All, {1, 10000}}, AspectRatio->1, PlotStyle->Thick, Frame->True, FrameLabel->(Style[#, 30, FontFamily->"Myriad Pro Cond"]&/@{"Номер слова в списке", "n"})]
Out[13]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Выделение цитат, создание цветового портрета произведения

Итак, перейдем к реализации задуманного. Для начала создадим функцию, которая искала бы определенное слово в тексте:

In[14]:=
replacements=Thread[CharacterRange["а", "я"]->CharacterRange["А", "Я"]];

wordPosition[word_]:=Block[{localWord=" "<>word<>" "}, StringPosition[fullTextRu, localWord|(" "<>StringReplace[StringTake[word, 1], replacements]<>StringDrop[word, 1]<>" ")]]
In[15]:=
wordPosition["культуризм"]
Out[15]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Теперь создадим функцию, выделяющую предложение, которое содержит слово с заданной позицией. Для этого нам понадобится знать те позиции, на которых находятся точки:

In[16]:=
Short[dots=#[[1]]&/@StringPosition[fullTextRu, "."], 5]
Out[16]//Short=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Теперь можем создать саму функцию:

In[17]:=
sentense[{min_, max_}]:=Block[{start=Select[Nearest[dots, min, 10], #<min&][[1]]+1, end=Select[Nearest[dots, max, 10], #>max&][[1]]}, StringTake[fullTextRu, {start, end}]]

Она сама по себе интересна, так как позволяет выцеплять из всего текста предложения по интеерсующей тематике, скажем, если мы хотим, можно выцепить все предложения со словом "терминатор":

In[18]:=
Grid[Transpose@{StringReplace[sentense/@wordPosition["терминатор"], "\n"->""]}, Background->{None, {{Orange, LightGray}}}, ItemStyle->Directive[20, Bold, FontFamily->"Myriad Pro Cond"], Alignment->Left, Dividers->All]
Out[18]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

или "слай":

In[19]:=
Grid[Transpose@{StringReplace[sentense/@wordPosition["слай"], "\n"->""]}, Background->{None, {{Orange, LightGray}}}, ItemStyle->Directive[20, Bold, FontFamily->"Myriad Pro Cond"], Alignment->Left, Dividers->All]
Out[19]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

После того, как эта функция создана, можно приступить к выделению цветов. Для начала, создадим правила цветов:

In[20]:=
colorRules={"белый"->White, "красный"->Red, "зеленый"->Green, "синий"->Blue, "желтый"->Yellow, "черный"->Black, "серый"->Gray, "розовый"->Pink, "коричневый"->Brown};

Теперь выделим места в тексте, содержащие упоминания о цвете:

In[21]:=
colorInformationPre={#, wordPosition[#]}&/@colorRules[[;;, 1]]
Out[21]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Отсортируем их в порядке появления:

In[22]:=
colorInformation=Sort[Flatten[Partition[Riffle[#[[2]], #[[1]]], 2]&/@colorInformationPre, 1], Mean[#1[[1]]]<Mean[#2[[1]]]&]
Out[22]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Отобразим карту цветов, как на сайте Esquire:

In[23]:=
Panel[Grid[Partition[Graphics[{#, EdgeForm[Black], Rectangle[]}, ImageSize->40]&/@(colorInformation[[;;, 2]]/.colorRules), 5, 5, 1, ""], Spacings->{0, 0}]]
Out[23]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Добавим возможность увидеть предложение по нажатию на соответствующий цвет:

In[24]:=
colorAndSentense={sentense[#[[1]]], #[[2]]}&/@colorInformation;

index$=1;

i=7;

text=Style[colorAndSentense[[i, 1]], 20, Bold, FontFamily->"Myriad Pro Cond", TextAlignment->Center];

Panel@Grid[{{Panel[Grid[Partition[With[{index=index$++}, Dynamic@Button[If[i==index, Graphics[{#[[2]], EdgeForm[Black], Rectangle[]}, ImageSize->50], Graphics[{#[[2]], EdgeForm[Black], Rectangle[]}, ImageSize->40]], text=Style[#[[1]], 20, Bold, FontFamily->"Myriad Pro Cond", TextAlignment->Center];

i=index, Appearance->None]]&/@(colorAndSentense/.colorRules), 5, 5, 1, ""], Spacings->{0.5, 0.5}, ItemSize->{4, 5}, Alignment->{Center, Center}]], Pane[Dynamic[text], {300, 200}, Alignment->{Center, Center}]}}, Alignment->{Center, Center}]
Out[24]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Аналогично можно сделать с любыми объектами:

In[25]:=
transportRules={"машина"->ByteRGBImageGraphics, "танк"->ByteRGBImageGraphics, "мотоцикл"->ByteRGBImageGraphics, "велосипед"->ByteRGBImageGraphics, "пешком"->ByteRGBImageGraphics, "самолет"->ByteRGBImageGraphics, "вертолет"->ByteRGBImageGraphics};
In[26]:=
transportInformationPre={#, wordPosition[#]}&/@transportRules[[;;, 1]]
Out[26]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...
In[27]:=
transportInformation=Sort[Flatten[Partition[If[Length[#[[2]]]==1, #[[2]]~Join~{#[[1]]}, Riffle[#[[2]], #[[1]]]], 2]&/@transportInformationPre, 1], Mean[#1[[1]]]<Mean[#2[[1]]]&]
Out[27]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...
In[28]:=
transportAndSentense={sentense[#[[1]]], #[[2]]}&/@transportInformation;

index$=1;

i1=10;

text1=Style[transportAndSentense[[i1, 1]], 20, Bold, FontFamily->"Myriad Pro Cond", TextAlignment->Center];

Panel@Grid[{{Pane[Dynamic[text1], {600, 200}, Alignment->{Center, Center}]}, {Panel[Grid[Partition[With[{index=index$++}, Dynamic@Button[If[i1==index, Image[#[[2]], ImageSize->100], Image[#[[2]], ImageSize->50]], text1=Style[#[[1]], 20, Bold, FontFamily->"Myriad Pro Cond", TextAlignment->Center];

i1=index, Appearance->None]]&/@(transportAndSentense/.transportRules), 7, 7, 1, ""], Spacings->{0.5, 0.5}, ItemSize->{6, 9}, Alignment->{Center, Center}]]}}, Alignment->{Center, Center}]
Out[28]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Реализация алгоритмов для оригинального текста

Само собой интересно посмотреть на аналогичные вещи, только для оригинального текста. Приведу тот же текст, чтобы не путать, только все теперь будет относиться к оригиналу. При этом будет произведено сравнение оригинала и перевода.

Загрузим текст в Mathematica:

In[29]:=
Short[fullTextEn=Import[FileNameJoin[{NotebookDirectory[], "ArnoldTotalRecallEn.txt"}]], 5]
Out[29]//Short=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Найдем сколько символов использовано в тексте:

In[30]:=
{StringLength[fullTextEn], StringLength[fullTextRu]}
Out[30]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Узнаем из скольких абзацев состоит текст:

In[31]:=
{StringCount[fullTextEn, "\n"]+1, StringCount[fullTextRu, "\n"]+1}
Out[31]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Количество предложений в тексте:

In[32]:=
{StringCount[fullTextEn, "."], StringCount[fullTextRu, "."]}
Out[32]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Количество вхождений каждого из символов, отсортируем их и построим их распределение:

In[33]:=
charactersDataEn=Tally[Characters[StringReplace[fullTextEn, Thread[CharacterRange["A", "Z"]->CharacterRange["a", "z"]]]]]
Out[33]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...
In[34]:=
charactersDataSortedEn=Sort[charactersDataEn, ToCharacterCode[#1[[1]]][[1]]<ToCharacterCode[#2[[1]]][[1]]&]
Out[34]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...
In[35]:=
Panel@Rotate[BarChart[charactersDataSortedEn[[;;, 2]], ChartLabels->Placed[Style[#, 12, Bold]&/@(charactersDataSortedEn[[;;, 1]]), Axis, Rotate[#, 90Degree]&], ColorFunction->Function[{height}, ColorData["Rainbow"][height]], ImageSize->950, GridLinesStyle->Dashed, PlotRangePadding->0, BarSpacing->0.5], -Pi/2]
Out[35]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Отобразим только те символы, которые встречаются больше 1000 раз:

In[36]:=
mostCommonEn=Cases[charactersDataSortedEn, {_, x_/;

x>1000}];

Panel@Rotate[BarChart[mostCommonEn[[;;, 2]], ChartLabels->Placed[Style[#, 12, Bold]&/@(mostCommonEn[[;;, 1]]/."\n"->FullForm["\n"]/." "->FullForm[" "]), Axis, Rotate[#, 90Degree]&], ColorFunction->Function[{height}, ColorData["Rainbow"][height]], ImageSize->900, GridLinesStyle->Dashed, PlotRangePadding->0, BarSpacing->0.1], -Pi/2]
Out[36]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Самые распространенные слова, предлоги и пр.:

In[37]:=
Short[allWordsEn=Sort[Tally[DeleteCases[StringSplit[StringReplace[StringReplace[fullTextEn, Thread[CharacterRange["A", "Z"]->CharacterRange["a", "z"]]], RegularExpression["[^"<>StringJoin@CharacterRange["a", "z"]<>"]"]->" "], " "], ""]], #1[[2]]>#2[[2]]&], 5]
Out[37]//Short=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Количество разнообразных слов и предлогов, которые использованы в оригинальном тексте:

In[38]:=
{Length[allWordsEn], Length[allWords]}
Out[38]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Список 200 самых часто встречающихся слов и предлогов:

In[39]:=
allWordsEn[[1;;200]][[;;, 1]]
Out[39]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

их распределение в логарифмическом:

In[40]:=
ListLogPlot[{allWordsEn[[;;, 2]], allWords[[;;, 2]]}, Joined->True, PlotRange->All, ImageSize->600, AspectRatio->1, PlotStyle->Thick, Frame->True, FrameLabel->(Style[#, 30, FontFamily->"Myriad Pro Cond"]&/@{"Номер слова в списке", "n"}), PlotLegends->Placed[LineLegend[Style[#, 30, FontFamily->"Myriad Pro Cond"]&/@{"Оригинал", "Перевод"}], Above]]
Out[40]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

и дважды логарифмическом масштабе:

In[41]:=
ListLogLogPlot[{allWordsEn[[;;, 2]], allWords[[;;, 2]]}, Joined->True, ImageSize->600, PlotRange->{All, {1, 10000}}, AspectRatio->1, PlotStyle->Thick, Frame->True, FrameLabel->(Style[#, 30, FontFamily->"Myriad Pro Cond"]&/@{"Номер слова в списке", "n"}), PlotLegends->Placed[LineLegend[Style[#, 30, FontFamily->"Myriad Pro Cond"]&/@{"Оригинал", "Перевод"}], Above]]
Out[41]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Функция, которая ищет определенное слово в тексте:

In[42]:=
replacementsEn=Thread[CharacterRange["a", "z"]->CharacterRange["A", "Z"]];

wordPositionEn[word_]:=Block[{localWord=" "<>word<>" "}, StringPosition[fullTextEn, localWord|(" "<>StringReplace[StringTake[word, 1], replacementsEn]<>StringDrop[word, 1]<>" ")]]
In[43]:=
Short[wordPositionEn["bodybuilding"], 5]
Out[43]//Short=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Функция, выделяющую предложение, которое содержит слово с заданной позицией:

In[44]:=
Short[dotsEn=#[[1]]&/@StringPosition[fullTextEn, "."], 5]
Out[44]//Short=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...
In[45]:=
sentenseEn[{min_, max_}]:=Block[{start=Select[Nearest[dotsEn, min, 10], #<min&][[1]]+1, end=Select[Nearest[dotsEn, max, 10], #>max&][[1]]}, StringTake[fullTextEn, {start, end}]]

Выцепим все предложения со словом "terminator":

In[46]:=
Grid[Transpose@{StringReplace[sentenseEn/@wordPositionEn["terminator"], "\n"->""]}, Background->{None, {{Orange, LightGray}}}, ItemStyle->Directive[20, Bold, FontFamily->"Myriad Pro Cond"], Alignment->Left, Dividers->All]
Out[46]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

или "sly":

In[47]:=
Grid[Transpose@{StringReplace[sentenseEn/@wordPositionEn["sly"], "\n"->""]}, Background->{None, {{Orange, LightGray}}}, ItemStyle->Directive[20, Bold, FontFamily->"Myriad Pro Cond"], Alignment->Left, Dividers->All]
Out[47]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Выделим цвета:

In[48]:=
colorRulesEn={"white"->White, "red"->Red, "green"->Green, "blue"->Blue, "yellow"->Yellow, "black"->Black, "gray"->Gray, "pink"->Pink, "brown"->Brown};
In[49]:=
Short[colorInformationPreEn={#, wordPositionEn[#]}&/@colorRulesEn[[;;, 1]], 5]
Out[49]//Short=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...
In[50]:=
Short[colorInformationEn=Sort[Flatten[Partition[Riffle[#[[2]], #[[1]]], 2]&/@colorInformationPreEn, 1], Mean[#1[[1]]]<Mean[#2[[1]]]&], 5]
Out[50]//Short=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...
In[51]:=
Panel[Grid[Partition[Graphics[{#, EdgeForm[Black], Rectangle[]}, ImageSize->40]&/@(colorInformationEn[[;;, 2]]/.colorRulesEn), 15, 15, 1, ""], Spacings->{0, 0}]]
Out[51]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...
In[52]:=
colorAndSentenseEn={sentenseEn[#[[1]]], #[[2]]}&/@colorInformationEn;

indexEn$=1;

iEn=7;

textEn=Style[colorAndSentenseEn[[iEn, 1]], 20, Bold, FontFamily->"Myriad Pro Cond", TextAlignment->Center];

Panel@Grid[{{Pane[Dynamic[textEn], {600, 200}, Alignment->{Center, Center}]}, {Panel[Grid[Partition[With[{index=indexEn$++}, Dynamic@Button[If[iEn==index, Graphics[{#[[2]], EdgeForm[Black], Rectangle[]}, ImageSize->30], Graphics[{#[[2]], EdgeForm[Black], Rectangle[]}, ImageSize->20]], textEn=Style[#[[1]], 20, Bold, FontFamily->"Myriad Pro Cond", TextAlignment->Center];

iEn=index, Appearance->None]]&/@(colorAndSentenseEn/.colorRulesEn), 15, 15, 1, ""], Spacings->{0.2, 0.2}, ItemSize->{3, 4}, Alignment->{Center, Center}]]}}, Alignment->{Center, Center}]
Out[52]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Пример с транспортом:

In[53]:=
transportRulesEn={"car"->ByteRGBImageGraphics, "tank"->ByteRGBImageGraphics, "motorcycle"->ByteRGBImageGraphics, "bicycle"->ByteRGBImageGraphics, "walk"->ByteRGBImageGraphics, "airplane"->ByteRGBImageGraphics, "helicopter"->ByteRGBImageGraphics};
In[54]:=
Short[transportInformationPreEn={#, wordPositionEn[#]}&/@transportRulesEn[[;;, 1]], 5]
Out[54]//Short=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...
In[55]:=
Short[transportInformationEn=Sort[Flatten[Partition[If[Length[#[[2]]]==1, #[[2]]~Join~{#[[1]]}, Riffle[#[[2]], #[[1]]]], 2]&/@transportInformationPreEn, 1], Mean[#1[[1]]]<Mean[#2[[1]]]&], 5]
Out[55]//Short=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...
In[56]:=
transportAndSentenseEn={sentenseEn[#[[1]]], #[[2]]}&/@transportInformationEn;

index$En=1;

i1En=10;

textEn1=Style[transportAndSentenseEn[[i1En, 1]], 20, Bold, FontFamily->"Myriad Pro Cond", TextAlignment->Center];

Panel@Grid[{{Pane[Dynamic[textEn1], {600, 200}, Alignment->{Center, Center}]}, {Panel[Grid[Partition[With[{index=index$En++}, Dynamic@Button[If[i1En==index, Image[#[[2]], ImageSize->55], Image[#[[2]], ImageSize->40]], textEn1=Style[#[[1]], 20, Bold, FontFamily->"Myriad Pro Cond", TextAlignment->Center];

i1En=index, Appearance->None]]&/@(transportAndSentenseEn/.transportRulesEn), 11, 11, 1, ""], Spacings->{0.2, 0.2}, ItemSize->{4, 6}, Alignment->{Center, Center}]]}}, Alignment->{Center, Center}]
Out[56]=
Анализ текста в Mathematica: выделение цитат, цветов и многое другое...

Оценить статью
Блог о Wolfram Mathematica

Оставить комментарий

avatar
  Подписаться  
Уведомление о