Mathematica в действии, блог Осипова Романа

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

Нажмите, чтобы скачать данный пост в виде ноутбука Mathematica...

Общее количество использованных в посте встроенных функций или символов: 122

Список имен используемых встроенных функций и символов в порядке их появления в коде:
Short | Set (=) | Import | FileNameJoin | List ({...}) | NotebookDirectory | StringLength | Plus (+) | StringCount | Tally | Characters | StringReplace | Thread | Rule (->, ->) | CharacterRange | Sort | Function (&) | Less (<) | Part ([[…]]) | ToCharacterCode | Slot (#) | Panel | Rotate | BarChart | Span (;;) | All | ChartLabels | Placed | Map (/@) | Style | Bold | Axis | Times (*, ×) | Degree | ColorFunction | ColorData | ImageSize | GridLinesStyle | Dashed | PlotRangePadding | BarSpacing | Pi (π) | Power (^) | CompoundExpression (;) | Cases | Blank (_) | Condition (/;) | Pattern (:) | Greater (>) | ReplaceAll (/.) | FullForm | DeleteCases | StringSplit | RegularExpression | StringJoin (<>) | Length | ListLogPlot | Joined | True | PlotRange | AspectRatio | PlotStyle | Thick | Frame | FrameLabel | FontFamily | ListLogLogPlot | SetDelayed (:=) | Block | StringPosition | Alternatives (|) | StringTake | StringDrop | Select | Nearest | Grid | Transpose | Background | None | Orange | LightGray | ItemStyle | Directive | Alignment | Left | Dividers | White | Red | Green | Blue | Yellow | Black | Gray | Pink | Brown | Flatten | Partition | Riffle | Mean | Graphics | EdgeForm | Rectangle | Spacings | TextAlignment | Center | With | Increment (++) | Dynamic | Button | If | Equal (==) | Appearance | ItemSize | Pane | Image | RawArray | ColorSpace | Interleaving | Join | PlotLegends | LineLegend | Above

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

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

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

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

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

закрыть

Short[fullTextRu = Import[FileNameJoin[{NotebookDirectory[], "ArnoldTotalRecallRu.txt"}]]]

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

закрыть

StringLength[fullTextRu]

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

закрыть

StringCount[fullTextRu, "\n"] + 1

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

закрыть

StringCount[fullTextRu, "."]

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

закрыть

charactersData = Tally[Characters[ StringReplace[fullTextRu, Thread[CharacterRange["А", "Я"] -> CharacterRange["а", "я"]]]]]

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

закрыть

charactersDataSorted = Sort[charactersData, ToCharacterCode[#1[[1]]][[1]] < ToCharacterCode[#2[[1]]][[1]] &]

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

закрыть

Panel@Rotate[ BarChart[charactersDataSorted[[;; , 2]], ChartLabels -> Placed[Style[#, 12, Bold] & /@ (charactersDataSorted[[;; , 1]]), Axis, Rotate[#, 90 Degree] &], ColorFunction -> Function[{height}, ColorData["Rainbow"][height]], ImageSize -> 950, GridLinesStyle -> Dashed, PlotRangePadding -> 0, BarSpacing -> 0.5], -Pi/2]

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

закрыть

mostCommon = Cases[charactersDataSorted, {_, x_ /; x > 1000}]; Panel@ Rotate[BarChart[mostCommon[[;; , 2]], ChartLabels -> Placed[Style[#, 12, Bold] & /@ (mostCommon[[;; , 1]] /. "\n" -> FullForm["\n"] /. " " -> FullForm[" "]), Axis, Rotate[#, 90 Degree] &], ColorFunction -> Function[{height}, ColorData["Rainbow"][height]], ImageSize -> 900, GridLinesStyle -> Dashed, PlotRangePadding -> 0, BarSpacing -> 0.1], -Pi/2]

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

закрыть

Short[allWords = Sort[Tally[ DeleteCases[ StringSplit[ StringReplace[ StringReplace[fullTextRu, Thread[CharacterRange["А", "Я"] -> CharacterRange["а", "я"]]], RegularExpression[ "[^" <> StringJoin@CharacterRange["а", "я"] <> "]"] -> " "], " "], ""]], #1[[2]] > #2[[2]] &], 5]

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

закрыть

Length[allWords]

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

закрыть

allWords[[1 ;; 200]][[;; , 1]]

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

закрыть

ListLogPlot[allWords[[;; , 2]], Joined -> True, PlotRange -> All, ImageSize -> 600, AspectRatio -> 1, PlotStyle -> Thick, Frame -> True, FrameLabel -> (Style[#, 30, FontFamily -> "Myriad Pro Cond"] & /@ {"Номер слова в списке", "n"})]

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

закрыть

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"})]

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

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

закрыть

replacements = Thread[CharacterRange["а", "я"] -> CharacterRange["А", "Я"]]; wordPosition[word_] := Block[{localWord = " " <> word <> " "}, StringPosition[fullTextRu, localWord | (" " <> StringReplace[StringTake[word, 1], replacements] <> StringDrop[word, 1] <> " ")]]

закрыть

wordPosition["культуризм"]

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

закрыть

Short[dots = #[[1]] & /@ StringPosition[fullTextRu, "."], 5]

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

закрыть

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}]]

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

закрыть

Grid[Transpose@{StringReplace[sentense /@ wordPosition["терминатор"], "\n" -> ""]}, Background -> {None, {{Orange, LightGray}}}, ItemStyle -> Directive[20, Bold, FontFamily -> "Myriad Pro Cond"], Alignment -> Left, Dividers -> All]

или “слай”:

закрыть

Grid[Transpose@{StringReplace[sentense /@ wordPosition["слай"], "\n" -> ""]}, Background -> {None, {{Orange, LightGray}}}, ItemStyle -> Directive[20, Bold, FontFamily -> "Myriad Pro Cond"], Alignment -> Left, Dividers -> All]

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

закрыть

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

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

закрыть

colorInformationPre = {#, wordPosition[#]} & /@ colorRules[[;; , 1]]

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

закрыть

colorInformation = Sort[Flatten[ Partition[Riffle[#[[2]], #[[1]]], 2] & /@ colorInformationPre, 1], Mean[#1[[1]]] < Mean[#2[[1]]] &]

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

закрыть

Panel[Grid[ Partition[ Graphics[{#, EdgeForm[Black], Rectangle[]}, ImageSize -> 40] & /@ (colorInformation[[;; , 2]] /. colorRules), 5, 5, 1, ""], Spacings -> {0, 0}]]

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

закрыть

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}]

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

закрыть

transportInformationPre = {#, wordPosition[#]} & /@ transportRules[[;; , 1]]

закрыть

transportInformation = Sort[Flatten[ Partition[ If[Length[#[[2]]] == 1, #[[2]]~Join~{#[[1]]}, Riffle[#[[2]], #[[1]]]], 2] & /@ transportInformationPre, 1], Mean[#1[[1]]] < Mean[#2[[1]]] &]

закрыть

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}]

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

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

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

закрыть

Short[fullTextEn = Import[FileNameJoin[{NotebookDirectory[], "ArnoldTotalRecallEn.txt"}]], 5]

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

закрыть

{StringLength[fullTextEn], StringLength[fullTextRu]}

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

закрыть

{StringCount[fullTextEn, "\n"] + 1, StringCount[fullTextRu, "\n"] + 1}

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

закрыть

{StringCount[fullTextEn, "."], StringCount[fullTextRu, "."]}

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

закрыть

charactersDataEn = Tally[Characters[ StringReplace[fullTextEn, Thread[CharacterRange["A", "Z"] -> CharacterRange["a", "z"]]]]]

закрыть

charactersDataSortedEn = Sort[charactersDataEn, ToCharacterCode[#1[[1]]][[1]] < ToCharacterCode[#2[[1]]][[1]] &]

закрыть

Panel@Rotate[ BarChart[charactersDataSortedEn[[;; , 2]], ChartLabels -> Placed[Style[#, 12, Bold] & /@ (charactersDataSortedEn[[;; , 1]]), Axis, Rotate[#, 90 Degree] &], ColorFunction -> Function[{height}, ColorData["Rainbow"][height]], ImageSize -> 950, GridLinesStyle -> Dashed, PlotRangePadding -> 0, BarSpacing -> 0.5], -Pi/2]

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

закрыть

mostCommonEn = Cases[charactersDataSortedEn, {_, x_ /; x > 1000}]; Panel@ Rotate[BarChart[mostCommonEn[[;; , 2]], ChartLabels -> Placed[Style[#, 12, Bold] & /@ (mostCommonEn[[;; , 1]] /. "\n" -> FullForm["\n"] /. " " -> FullForm[" "]), Axis, Rotate[#, 90 Degree] &], ColorFunction -> Function[{height}, ColorData["Rainbow"][height]], ImageSize -> 900, GridLinesStyle -> Dashed, PlotRangePadding -> 0, BarSpacing -> 0.1], -Pi/2]

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

закрыть

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]

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

закрыть

{Length[allWordsEn], Length[allWords]}

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

закрыть

allWordsEn[[1 ;; 200]][[;; , 1]]

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

закрыть

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]]

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

закрыть

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]]

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

закрыть

replacementsEn = Thread[CharacterRange["a", "z"] -> CharacterRange["A", "Z"]]; wordPositionEn[word_] := Block[{localWord = " " <> word <> " "}, StringPosition[fullTextEn, localWord | (" " <> StringReplace[StringTake[word, 1], replacementsEn] <> StringDrop[word, 1] <> " ")]]

закрыть

Short[wordPositionEn["bodybuilding"], 5]

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

закрыть

Short[dotsEn = #[[1]] & /@ StringPosition[fullTextEn, "."], 5]

закрыть

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”:

закрыть

Grid[Transpose@{StringReplace[ sentenseEn /@ wordPositionEn["terminator"], "\n" -> ""]}, Background -> {None, {{Orange, LightGray}}}, ItemStyle -> Directive[20, Bold, FontFamily -> "Myriad Pro Cond"], Alignment -> Left, Dividers -> All]

или “sly”:

закрыть

Grid[Transpose@{StringReplace[sentenseEn /@ wordPositionEn["sly"], "\n" -> ""]}, Background -> {None, {{Orange, LightGray}}}, ItemStyle -> Directive[20, Bold, FontFamily -> "Myriad Pro Cond"], Alignment -> Left, Dividers -> All]

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

закрыть

colorRulesEn = {"white" -> White, "red" -> Red, "green" -> Green, "blue" -> Blue, "yellow" -> Yellow, "black" -> Black, "gray" -> Gray, "pink" -> Pink, "brown" -> Brown};

закрыть

Short[colorInformationPreEn = {#, wordPositionEn[#]} & /@ colorRulesEn[[;; , 1]], 5]

закрыть

Short[colorInformationEn = Sort[Flatten[ Partition[Riffle[#[[2]], #[[1]]], 2] & /@ colorInformationPreEn, 1], Mean[#1[[1]]] < Mean[#2[[1]]] &], 5]

закрыть

Panel[Grid[ Partition[ Graphics[{#, EdgeForm[Black], Rectangle[]}, ImageSize -> 40] & /@ (colorInformationEn[[;; , 2]] /. colorRulesEn), 15, 15, 1, ""], Spacings -> {0, 0}]]

закрыть

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}]

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

закрыть

Short[transportInformationPreEn = {#, wordPositionEn[#]} & /@ transportRulesEn[[;; , 1]], 5]

закрыть

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]

закрыть

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}]

Блог принадлежит “Русскоязычной поддержке Wolfram Mathematica"©
При любом использовании материалов блога, ссылка на блог обязательна.
Создано с помощью Wolfram Mathematica 9