Automatically Extracting Character Networks from Narrative Texts

Robert B. Nachbar

Wolfram Solutions

Join the Conversation #WolframTechConf

ABSTRACT

Of late there has been an increased interest understanding and modeling social networks. One example of these social networks is found in narrative texts, where the nodes represent the characters, and the edges represent their interactions. Until recently, the extraction of the data necessary for the construction of the networks was entirely manual. Various means of natural language processing (NLP) have been applied to this problem with varying degrees of success. In this talk, we will describe our approach using the tools available in Wolfram Language to automatically identify characters and their interactions. Our goal is to compare the networks from a series of novels in a single genre written by one author to study how the network structures evolved over time both in structure and the semantic nature of the interactions. Ultimately, one would like to study the character networks from several authors within a genre, and the tools developed here will help bring that ambition within reach.

Why this project?

Always fascinated and intrigued by graphs and networks

Their inherent structure

As models for objects, data, and processes

Two recent uses to investigate an old problem with new methods

Colonial Patriot network

Wolfram Data Repository contribution found here

\[KernelIcon];ResourceObject["Paul Revere's Social Network in Colonial Boston"]

\[KernelIcon];colonialPatriotNetwork[]

Irish-Viking network

Wolfram Data Repository contribution found here

Original publication found here

\[KernelIcon];ResourceObject["Irish-Viking Networks in 'Cogadh Gaedhel re Gallaibh'"]

\[KernelIcon];irishVikingNetwork[]

Wouldn’t it be cool if…

The Plan

Construct the character networks in the works of Tony Hillerman

Two characters are connected if they speak to each other

Two characters are connected if they have direct physical interaction (e.g., policeman and murder victim at crime scene)

How similar are the character networks?

Are they all very similar or do a few stand apart?

Is there a steady change over the span of publication?

How do the character groups Police, Criminals, Victims, Civilians feature in the networks?

Use semantic analysis of the spoken parts to classify interactions as friendly or adversarial

Two characters are present in almost every mystery: Joe Leaphorn and Jim Chee

Are they always the dominant characters?

Does their relative relationship change?

Anne Hillerman has picked up where her father left off with 4 more mysteries in the series

Are her character networks similar or different (and how)?

Her writing style is different, can it be quantified?

First Steps

Manually extract the character interactions

It was fairly easy to skim the first novel, The Blessing Way, and manually record the interactions in a spread sheet

Manually Created Network

\[KernelIcon];rawData=;
First@%

\[KernelIcon];characters=Union@@Rest@getData[rawData,{"character 1","character 2"}]//DeleteCases[#,""]&;
Length@%

\[KernelIcon];renameCharacterRules={"Navajo wolf"|"Big Navajo"->"the Big Navajo","Eddie"->"Eddie Poher","brother-in-law of Old Woman Gray Rocks"->"uncle of Billy Nez","son of Charley Tsosie"->"son 1 of Charley Tsosie"};

\[KernelIcon];rawEdges=(Rest@getData[rawData,{"character 1","character 2"}]/.renameCharacterRules);

\[KernelIcon];edges=rawEdges//DeleteCases[#,{Except[""],""}]&//DeleteCases[#,{a_,a_}]&//Map[Sort,#]&//Apply[UndirectedEdge,#,{1}]&//Union;
Length@%

\[KernelIcon];vertices=characters/.renameCharacterRules;
Length@%

\[KernelIcon];manualNetwork=Graph[vertices,edges,VertexLabels->Placed["Name",Tooltip],ImageSize->Medium]

With a little additional effort (see Initialization section at end of notebook)

\[KernelIcon];theBlessingWayNetwork[manualNetwork]

Reality Strikes!

It was too easy to capture “extra” interactions, e.g., rows 5, 6, 10 in the spreadsheet above

Those described by the narrator in a flashback

Those spoken about by a character

Additional sociological data was also being captured, such as clan membership, which could be a distraction

The process was not sustainable without an army of graduate students

One really needs the text in electronic form…

eBooks

Project Gutenberg

https://www.gutenberg.org

Over 57,000 free eBooks

Some mysteries or other narratives are available as curated plain text:

“The Mysterious Affair at Styles” by Agatha Christie

“The Legends Of King Arthur And His Knights” by Knowles and Malory

eBook Converter

https://www.ebookconverter.com/epub-to-txt-converter/

Buy the Kindle eBook from Amazon and convert it to plain text with the EPubsoft EBook Converter app

Know the copyright restrictions

Not all formats and vendors allow easy access to the eBook file

Plan B

Buy several Hillerman mysteries as eBooks and convert to plain text

\[KernelIcon];FileNameTake/@FileNames["Books/*.txt"]//Column

Use built-in text analysis functions and “prior art” to process the text

Identify spoken text and the speaker

Identify interactions by spoken text proximity

Early workers used the “same chapter” criterion; e.g., Donald Knuth with Les Misérable

Could we do better with sentence and/or paragraph structure?

When done, sit back and appreciate how easily the human mind does all this!

Prior Art with Wolfram Language

Literary Analysis and the Wolfram Language: Jumping Down a Reading Rabbit Hole

We borrowed many utility functions, adapting them as needed

Tracking a Descent to Savagery with the Wolfram Language: Plotting Sentiment Analysis in Lord of the Flies

Character chronology

Sentence sentiment

Built-in Text Processing Functions

(RefLinkPlain[Text Analysis, paclet:guide/TextAnalysis]) guide page

These are the two functions we made most use of:

\[KernelIcon];?TextSentences

\[KernelIcon];?TextStructure

\[KernelIcon];ExampleData[{"Text","AliceInWonderland"}]//StringTake[#,1200]&

\[KernelIcon];(sentences=TextSentences[StringTake[ExampleData[{"Text","AliceInWonderland"}],{25,1195}]])//framedColumn

\[KernelIcon];TextStructure[First@sentences]

\[KernelIcon];TextStructure[First@sentences,"PartsOfSpeech"]

What We Accomplished

First look

Is the text well structured?

Are typographic conventions used consistently?

Chapters & paragraphs

How are chapters identified?

How are paragraphs delimited?

Special characters

Are non-ASCII characters used that could make problems for the text analysis functions?

Data cleaning & refactoring

Always needed!

Structuring the text

A good data structure design makes processing easier

Character identification (a dead end)

Part of speech (POS) tagging wasn’t specific enough

Manual character identification (a rabbit hole)

Too labor intensive

Speech extraction

String patterns and TextElement patterns

Speech attribution

A partial success

Pronominal resolution not attempted (yet)

Network generation

The finish line!

First look

\[KernelIcon];fullText=Import["Books/The Blessing Way.txt",CharacterEncoding-> "UTF8"];
StringLength@%

How much front and back matter need to be excised?

Are new lines only between paragraphs or are they used liberally?

\[KernelIcon];?viewData

\[KernelIcon];viewData@StringTake[fullText,15000]

\[KernelIcon];viewData@StringTake[fullText,{-15000,-1}]

Things to note:

First three words are all caps

Songs or chants may need special treatment; there are 2 in the first chapter

Curly quotes are used—are straight quotes used also?

There are letters with accent marks ("ñ")

Chapters & paragraphs

Break up the body of the book into chapters, as nested Associations.

chapters begin with the pattern "\n> "~~DigitCharacter..~~" <\n"

the pattern "\nAcknowledgment\n" effectively ends the last chapter

\[KernelIcon];StringCases[fullText,("\n"~~c:("> "~~DigitCharacter..~~" <")|("Acknowledgment")~~"\n"):>c]//Echo[#,"",Length]&

\[KernelIcon];chapterPositions=Rest@StringPosition[fullText,("\n"~~("> "~~DigitCharacter..~~" <")|("Acknowledgment")~~"\n")]

\[KernelIcon];StringSplit/@StringTake[fullText,chapterPositions]

\[KernelIcon];startPositions=Last/@Most@chapterPositions+1
endPositions=First/@Rest@chapterPositions-1

\[KernelIcon];chapters=Association@@MapThread[With[{chapterAndTitle=StringSplit[StringTake[fullText,#1]]//DeleteCases[#,">"|"<"]&//{First@#,""}&},First@chapterAndTitle-><|"Title"->Last@chapterAndTitle,"Body"->StringTrim@StringTake[fullText,{#2,#3}]|>]&,{Most@chapterPositions,startPositions,endPositions}];

\[KernelIcon];Keys@chapters

\[KernelIcon];Keys@chapters["1"]

\[KernelIcon];StringLength/@chapters[[All,"Body"]]

\[KernelIcon];MinMax@%

\[KernelIcon];ListPlot[StringLength/@chapters[[All,"Body"]]//Values,Filling->Axis,FrameLabel->{"chapter","# text characters"},ImageSize->Large]

Special characters

Are there any special characters or formatting that need to be handled?

\[KernelIcon];(characterCounts=CharacterCounts[StringJoin@@chapters[[All,"Body"]]]//KeySort)//Normal//#/.s_String:>InputForm[s]&

\[KernelIcon];Values@characterCounts//Total

what are the non-ASCII characters?

\[KernelIcon];(specialCharacters=Complement[Keys@characterCounts,FromCharacterCode/@Range[0,127]])//#/.s_String:>InputForm[s]&

there is an em-dash ("—"), are there double dashes ("--")?

\[KernelIcon];StringCount[#,"--"]&/@chapters[[All,"Body"]]
Total@%

there is an ellipsis ("…"), are there 3 consecutive periods?

\[KernelIcon];StringCount[#,"..."]&/@chapters[[All,"Body"]]
Total@%

what are the non-letter and non-digit characters?

\[KernelIcon];Complement[Intersection[Keys@characterCounts,FromCharacterCode/@Range[0,127]],StringCases[StringJoin@@Keys@characterCounts,LetterCharacter|DigitCharacter]]//#/.s_String:>InputForm[s]&

there are curly quotes, and no straight quotes (single or double)

Data cleaning & refactoring

There were a number of minor typographical errors that we came across while working with the text

As they were encountered, we came back to this point and implemented algorithmic corrections

We never edited the text

\[KernelIcon];chapterBodies=Values@chapters[[All,"Body"]];
StringLength/@%
Length@%

Clean up leading words of each chapter

\[KernelIcon];chapterBodies=MapThread[StringReplace,{chapterBodies,{
"LUIS HORSEMAN LEANED"->"Luis Horseman leaned",
"THAT NIGHT THE"->"That night the",
"BERGEN MCKEE APPROACHED"->"Bergen McKee approached",
"BERGEN MCKEE HAD"->"Bergen McKee had",
"JOSEPH BEGAY AWAKENED"->"Joseph Begay awakened",
"IT WAS MIDMORNING"->"It was midmorning",
"OLD WOMAN GRAY"->"Old Woman Gray",
"MCKEE LEFT THE"->"McKee left the",
"BERGEN MCKEE HONKED"->"Bergen McKee honked",
"SANDOVAL SQUATTED BESIDE"->"Sandoval squatted beside",
"THERE HAD BEEN"->"There had been",
"IT WAS WELL"->"It was well",
"IT WAS A"->"It was a",
"THERE IS NO"->"There is no",
"AT APPROXIMATELY FOUR"->"At approximately four",
"BERGEN MCKEE HAD"->"Bergen McKee had",
"THE SUN WAS"->"The sun was",
"HE WAS AWARE"->"He was aware"}
}];

For all intents and purposes, a sequence of new lines delimit paragraphs

\[KernelIcon];chapterBodies=StringReplace[chapterBodies,br:"\n\n"~~"\n"..:>br];

We need to treat songs and spoken quotations specially, otherwise we will not be able to recover spoken text across contiguous paragraphs; a single new line should suffice, as multiple new lines signify paragraphs

\[KernelIcon];songPattern=song:(("“"~~(Except[{"“","\n","”"}]..~~"\n\n")..)..~~Except[{"“","\n","”"}]..~~"”")~~trailer:("\n\n"|EndOfString);
songRule=songPattern:>StringReplace[song,"\n\n"~~fc:Except["“"]:>"\n"<>fc]<>trailer;
chapterBodies=StringReplace[chapterBodies,songRule];

There is an instance of LetterCharacter..~~"? “\n" that needs to be fixed

\[KernelIcon];chapterBodies=StringReplace[chapterBodies,{w:LetterCharacter..~~p:("."|"?"|"!")~~" “\n":>w<>p<>"”\n"}];

There are some opening curly double quotes after a closing curly quote that should be closing curly double quotes

\[KernelIcon];chapterBodies=StringReplace[chapterBodies,{"’"~~" "~~"“":>"’"<>" "<>"”"}];

New lines in quotations handled here

\[KernelIcon];quotationPattern=quotation:(("“"~~Except[{"”"}]..~~"‘"~~(Except[{"‘","\n","”"}]..~~"\n\n")..)..~~Except[{"\n"}]..~~"’"|"’ ”")~~trailer:("\n\n"|EndOfString);
quotationRule=quotationPattern:>StringReplace[quotation,"\n"~~"\n"..->"\n"]<>trailer;
chapterBodies=StringReplace[chapterBodies,quotationRule];

Missing space after period at end of sentence

\[KernelIcon];chapterBodies=StringReplace[chapterBodies,{"thought.I"->"thought. I","said.Whoo"->"said. Whoo"}];

Missing space between words

\[KernelIcon];chapterBodies=StringReplace[chapterBodies,{"fromEthnology":>"from Ethnology","he stirs…."->"he stirs….”"}];

\[KernelIcon];chapters[[All,"Body"]]=chapterBodies;

Structuring the text

Break up the chapter bodies into paragraphs,  the paragraphs into sentences, and tag parts of speech in the sentences

\[KernelIcon];body=chapters["1","Body"];

\[KernelIcon];paragraphs=StringTrim@StringSplit[body,"\n"~~"\n"..];
Length@%

\[KernelIcon];paragraphs[[1]]

\[KernelIcon];(sentences=TextSentences@paragraphs[[1]])//framedColumn

\[KernelIcon];TextStructure[#,"PartsOfSpeech"]&/@sentences//framedColumn

Note that the apostrophe in "rat’s" became "rat's" in the text structure object

\[KernelIcon];(sentences=TextSentences@paragraphs[[2]])//framedColumn

\[KernelIcon];TextStructure[#,"PartsOfSpeech"]&/@sentences//framedColumn

Curly double quotes are detected as punctuation, but modified in the text structure object: "“" ⟶ "``" and "”" ⟶ "''"

The output of TextStructure has the pattern TextElement[{TextElement[pos:{__TextElement},"Text"]}], which could be simplified to TextElement[pos:{__TextElement},"Text"], which will simplify downstream pattern creation and matching

The whole book was processed with this code, adding the keys "TextSentences" and "TextStructure" to each chapter

Each of these elements is a ragged 2-dimensional array, with paragraphs at the first level and sentences at the second level

Processing time is about 13 minutes

book=Function[chapter,Echo[(*chapter["Title"]*)StringRiffle@Most@StringSplit[#," ",5]&@StringTake[chapter["Body"],100]];With[{paragraphs=TextSentences/@StringTrim@StringSplit[chapter["Body"],"\n"~~"\n"..]},Join[chapter,<|"TextSentences"->paragraphs,"TextStructure"->(Map[TextStructure[#,"PartsOfSpeech"][[1,1]]&,paragraphs,{2}])|>]]]/@chapters;//Timing//AbsoluteTiming

Keys@First@book

MatchQ[Values@book[[All,"TextStructure"]],{{{TextElement[{__},"Text"]..}..}..}]

We exported the book for subsequent reuse

Export[FileNameJoin[{"Books","The Blessing Way.m"}],Compress@book]

Speech extraction

\[KernelIcon];book=Uncompress@Get@"Books/The Blessing Way.m";
Keys@%

textSearch

\[KernelIcon];txt=StringTake[book["1","Body"],625]

\[KernelIcon];?textSearch

\[KernelIcon];textSearch[txt,WordBoundary~~"he"~~WordBoundary,IgnoreCase->True]

speechPattern for "Body" text

The pattern needed for identifying spoken text in a String is fairly simple:

\[KernelIcon];speechPattern="“"~~Longest[Except["”"]]..~~"”";

\[KernelIcon];speechCounts=StringCount[#,speechPattern]&/@book[[All,"Body"]]
Total@%

\[KernelIcon];ListPlot[Values@speechCounts,Filling->Axis,FrameLabel->{"chapter","quoted text count"},ImageSize->Large]

\[KernelIcon];StringForm["chapter ``",#]->textSearch[book[#,"Body"],speechPattern]&/@{"1","2","11"}//TabView

There are some cases of quoted text that are not spoken text

We’ll leave them in and see if we fail to attribute a speaker to them as a means of filtering them out

speechPattern for "TextSentences" text

We want to get the paragraph and sentence indices so that the speeches can be retrieved later to examine preceding & following sentences for the identity of the speaker

The structure of the first two levels of "TextSentences" and "TextStructure" are identical, so the same set of indices can be used for both

We can accomplish this task by replacing the quoted text in "TextSentences" by a unique identifier for each instance, and then use Position to get the location of the identifiers

The first pattern identifies quoted text that spans paragraphs

The second pattern identifies quoted text within a sentence

\[KernelIcon];speechPositions=MapIndexed[Function[{chapter,idx},Module[{map,n=0,speech,redactedChapter},Echo[idx];
map=Join@@MapIndexed[Thread[Append[#2,Range[Length[#]]]]&,chapter]//Thread[List/@Range[Length[#]]->#]&(*//Echo*);redactedChapter=SequenceReplace[Join@@chapter,{
(* span paragraphs *)
{a:(_String?(StringMatchQ[#,___~~"“"~~Except["”"]..]&))|(_String?(StringMatchQ[#,"“"~~Except["”"]..~~"”"~~Except["“"]..~~"“"~~Except["”"]..]&)),b:Longest[(_String?(StringMatchQ[#,Except["”"]..]&)|_String?(StringMatchQ[#,__~~"”—"~~__~~"—“"~~__]&))...],c:(_String?(StringMatchQ[#,__~~"”"~~___]&))}:>Sequence[speech[++n],Sequence@@ConstantArray[speech[n],Length[{b}]],speech[n]],

(* within sentence *)
{str_String/;StringMatchQ[str,___~~speechPattern~~___]}:>speech[++n]
}];
Table[Position[redactedChapter,speech[i]]/.map,{i,n}]
]],book[[All,"TextSentences"]]];

\[KernelIcon];speechPositions[[1]]//Column

It’s OK for a speech to span paragraphs

It’s not OK for a paragraph to span speeches, as only a single character can speak in a paragraph

Therefore, we can combine discontinuous sentences from the same paragraph

\[KernelIcon];speechPositions=SequenceReplace[#,{a:{___,{p_,_}},b:{{p_,_},___}..}:>Join[a,b]]&/@speechPositions;

How many speeches?

\[KernelIcon];Length/@speechPositions//Echo//Total

Here is an interactive that allows one to peruse the speeches by chapter

\[KernelIcon];peruseQuotedText[speechPositions,"Speeches"]

Speech attribution

Divide and conquer

There are 2 kinds of speeches:

Those without narrative text embedded

\[KernelIcon];speechPositions[["3",1]]

\[KernelIcon];book[["3","TextSentences",2,{1}]]//framedColumn

Those with narrative text embedded:

\[KernelIcon];speechPositions[["3",3]]

\[KernelIcon];book[["3","TextSentences",5,{1,2}]]//framedColumn

These positions often have the speaker’s identity

Split the speechPositions into two groups

\[KernelIcon];ClearAll[narrativeTextFreeQ]
narrativeTextFreeQ[chapter:{{__TextElement}..},pos:{{_,_}..}]:=
FixedPoint[SequenceReplace[#,
{
(* span paragraphs *)
{PatternSequence[TextElement[{({{"``"}, {"Punctuation"}}),Except[({{"''"}, {"Punctuation"}})]..},"Text"],TextElement[{Except[({{"``"}, {"Punctuation"}})]..},"Text"]...]..,TextElement[{Except[({{"``"}, {"Punctuation"}})]..,({{"''"}, {"Punctuation"}})},"Text"]}->Sequence[],
(* within sentence *)
{TextElement[{({{"``"}, {"Punctuation"}}),Except[({{"''"}, {"Punctuation"}})]..,({{"''"}, {"Punctuation"}})},"Text"]}->Sequence[]
}
]&,Extract[chapter,pos]]//MatchQ[#,{}]&

Speech positions without embedded narrative text

\[KernelIcon];narrativeFreeSpeechPositions=Association@KeyValueMap[Function[{k,v},k->Echo[Select[v,narrativeTextFreeQ[book[[k,"TextStructure"]],#]&],k,Length]],speechPositions];

\[KernelIcon];Length/@narrativeFreeSpeechPositions//Echo//Total

\[KernelIcon];peruseQuotedText[narrativeFreeSpeechPositions,"Narrative-free Speeches"]

Speech positions with embedded narrative text

\[KernelIcon];narrativeSpeechPositions=MapThread[SortBy[Complement[##],First]&,{speechPositions,narrativeFreeSpeechPositions}];

\[KernelIcon];Length/@narrativeSpeechPositions//Echo//Total

\[KernelIcon];peruseQuotedText[narrativeSpeechPositions,"Narrative-embedded Speeches"]

Identifying the speakers

We’ll work just the speeches that have embedded narrative text

Delete quoted text to leave the narrative text

We can delete the quoted text from the "TextStructure" element, and then examine the remaining parts of speech for speaker identity pattern(s)

\[KernelIcon];ClearAll[deleteSpeechText]
(* at beginning *)
deleteSpeechText[{TextElement[{({{"``"}, {"Punctuation"}}),Except[({{"''"}, {"Punctuation"}})]..,({{"''"}, {"Punctuation"}})},"Text"],moreSentences__}]:=
(If[TrueQ[$debug],Echo[1]];deleteSpeechText[{moreSentences}])


deleteSpeechText[{PatternSequence[TextElement[{({{"``"}, {"Punctuation"}}),Except[({{"''"}, {"Punctuation"}})]..},"Text"],TextElement[{Except[({{"``"}, {"Punctuation"}})]..},"Text"]...]..,TextElement[{Except[({{"``"}, {"Punctuation"}})]..,({{"''"}, {"Punctuation"}}),moreWords___},"Text"],moreSentences___}]:=
(If[TrueQ[$debug],Echo[2]];deleteSpeechText[{TextElement[{moreWords},"Text"],moreSentences}])


(* at end *)
deleteSpeechText[{moreSentences__,TextElement[{({{"``"}, {"Punctuation"}}),Except[({{"''"}, {"Punctuation"}})]..,({{"''"}, {"Punctuation"}})},"Text"]}]:=
(If[TrueQ[$debug],Echo[3]];deleteSpeechText[{moreSentences}])


deleteSpeechText[{moreSentences___,PatternSequence[TextElement[{moreWords___,({{"``"}, {"Punctuation"}}),Except[({{"''"}, {"Punctuation"}})]..},"Text"],TextElement[{Except[({{"``"}, {"Punctuation"}})]..},"Text"]...]..,TextElement[{Except[({{"``"}, {"Punctuation"}})]..,({{"''"}, {"Punctuation"}})},"Text"]}]:=
(If[TrueQ[$debug],Echo[4]];deleteSpeechText[{moreSentences,TextElement[{moreWords},"Text"]}])


(* in middle *)
deleteSpeechText[{beginningSentences___,TextElement[{begginingWords___,({{"``"}, {"Punctuation"}}),Except[({{"''"}, {"Punctuation"}})]..,({{"''"}, {"Punctuation"}}),endWords___},"Text"],endSenetences___}]:=
(If[TrueQ[$debug],Echo[5]];deleteSpeechText[{beginningSentences,TextElement[{begginingWords,endWords},"Text"],endSenetences}])


deleteSpeechText[{beginningSentences___,TextElement[{begginingWords___,({{"``"}, {"Punctuation"}}),Except[({{"''"}, {"Punctuation"}})]..},"Text"],TextElement[{Except[({{"''"}, {"Punctuation"}})]..},"Text"]...,TextElement[{Except[({{"''"}, {"Punctuation"}})]..,({{"''"}, {"Punctuation"}}),endWords___},"Text"],endSenetences___}]:=
(If[TrueQ[$debug],Echo[6]];deleteSpeechText[{beginningSentences,TextElement[{begginingWords,endWords},"Text"],endSenetences}])


(* residue *)
deleteSpeechText[text:{TextElement[{___TextElement},"Text"]...}]:=
(If[TrueQ[$debug],Echo[-2]];DeleteCases[deleteSpeechText/@text,TextElement[{},"Text"]])

deleteSpeechText[TextElement[text:{___TextElement},"Text"]]:=
(If[TrueQ[$debug],Echo[-1]];TextElement[SequenceReplace[text,{{({{"``"}, {"Punctuation"}}),Except[({{"''"}, {"Punctuation"}})]..,Repeated[({{"''"}, {"Punctuation"}}),{0,1}]}->Sequence[],{Repeated[({{"``"}, {"Punctuation"}}),{0,1}],Except[({{"''"}, {"Punctuation"}})]..,({{"''"}, {"Punctuation"}})}->Sequence[]}],"Text"])

Here is an example of its use

\[KernelIcon];Extract[book[[14,"TextStructure"]],narrativeSpeechPositions[[14,2]]]//framedColumn

\[KernelIcon];deleteSpeechText@Extract[book[[14,"TextStructure"]],narrativeSpeechPositions[[14,2]]]//framedColumn

Now we process the whole list of speeches

\[KernelIcon];narrativeText=Join@@KeyValueMap[Function[{chapter,positions},({chapter,#,deleteSpeechText@Extract[book[[chapter,"TextStructure"]],#]}&)/@positions],narrativeSpeechPositions];
Dimensions@%
First@%%

Most "TextStructure" elements leave a single residual piece of narrative text:

\[KernelIcon];Length/@Last/@narrativeText//tally

Extract the speaker from the residual narrative text

Here is where we make use of the POS tagging

Each TextElement for a part of speech has an Association with a "GrammaticalUnit" key:

\[KernelIcon];narrativeText[[1,3,1,1,1]]//InputForm

For example, this residual narrative text:

\[KernelIcon];narrativeText[[1,3,1,1]]

gives this pattern of POS:

\[KernelIcon];"GrammaticalUnit"/.(Last/@%)

We can use the pattern of grammatical unit entities to extract the speaker

\[KernelIcon];speakerPatterns={
{(Entity["proper noun", Entity["GrammaticalUnit","ProperNoun"], "Entity[\"GrammaticalUnit\", \"ProperNoun\"]", "grammatical unit"])..,(Entity["adverb", Entity["GrammaticalUnit","Adverb"], "Entity[\"GrammaticalUnit\", \"Adverb\"]", "grammatical unit"])...,(Entity["verb", Entity["GrammaticalUnit","Verb"], "Entity[\"GrammaticalUnit\", \"Verb\"]", "grammatical unit"])..,__},
{(Entity["pronoun", Entity["GrammaticalUnit","Pronoun"], "Entity[\"GrammaticalUnit\", \"Pronoun\"]", "grammatical unit"]),(Entity["adverb", Entity["GrammaticalUnit","Adverb"], "Entity[\"GrammaticalUnit\", \"Adverb\"]", "grammatical unit"])...,(Entity["verb", Entity["GrammaticalUnit","Verb"], "Entity[\"GrammaticalUnit\", \"Verb\"]", "grammatical unit"])..,__},
{Repeated[(Entity["determiner", Entity["GrammaticalUnit","Determiner"], "Entity[\"GrammaticalUnit\", \"Determiner\"]", "grammatical unit"]),{0,1}],(Entity["adjective", Entity["GrammaticalUnit","Adjective"], "Entity[\"GrammaticalUnit\", \"Adjective\"]", "grammatical unit"])...,(Entity["noun", Entity["GrammaticalUnit","Noun"], "Entity[\"GrammaticalUnit\", \"Noun\"]", "grammatical unit"]),(Entity["adverb", Entity["GrammaticalUnit","Adverb"], "Entity[\"GrammaticalUnit\", \"Adverb\"]", "grammatical unit"])...,(Entity["verb", Entity["GrammaticalUnit","Verb"], "Entity[\"GrammaticalUnit\", \"Verb\"]", "grammatical unit"])..,__},
{(Entity["determiner", Entity["GrammaticalUnit","Determiner"], "Entity[\"GrammaticalUnit\", \"Determiner\"]", "grammatical unit"]),(Entity["proper noun", Entity["GrammaticalUnit","ProperNoun"], "Entity[\"GrammaticalUnit\", \"ProperNoun\"]", "grammatical unit"])..,(Entity["adverb", Entity["GrammaticalUnit","Adverb"], "Entity[\"GrammaticalUnit\", \"Adverb\"]", "grammatical unit"])...,(Entity["verb", Entity["GrammaticalUnit","Verb"], "Entity[\"GrammaticalUnit\", \"Verb\"]", "grammatical unit"])..,__},
{(Entity["pronoun", Entity["GrammaticalUnit","Pronoun"], "Entity[\"GrammaticalUnit\", \"Pronoun\"]", "grammatical unit"]),(Entity["noun", Entity["GrammaticalUnit","Noun"], "Entity[\"GrammaticalUnit\", \"Noun\"]", "grammatical unit"]),(Entity["verb", Entity["GrammaticalUnit","Verb"], "Entity[\"GrammaticalUnit\", \"Verb\"]", "grammatical unit"])..,__},
{(Entity["verb", Entity["GrammaticalUnit","Verb"], "Entity[\"GrammaticalUnit\", \"Verb\"]", "grammatical unit"]),(Entity["pronoun", Entity["GrammaticalUnit","Pronoun"], "Entity[\"GrammaticalUnit\", \"Pronoun\"]", "grammatical unit"]),__},
{(Entity["verb", Entity["GrammaticalUnit","Verb"], "Entity[\"GrammaticalUnit\", \"Verb\"]", "grammatical unit"]),(Entity["proper noun", Entity["GrammaticalUnit","ProperNoun"], "Entity[\"GrammaticalUnit\", \"ProperNoun\"]", "grammatical unit"])..,__},
{(Entity["verb", Entity["GrammaticalUnit","Verb"], "Entity[\"GrammaticalUnit\", \"Verb\"]", "grammatical unit"]),(Entity["verb", Entity["GrammaticalUnit","Verb"], "Entity[\"GrammaticalUnit\", \"Verb\"]", "grammatical unit"]),__}(* this is a special case where the surname "Takes" is cast as a verb *),
{(Entity["determiner", Entity["GrammaticalUnit","Determiner"], "Entity[\"GrammaticalUnit\", \"Determiner\"]", "grammatical unit"]),(Entity["adjective", Entity["GrammaticalUnit","Adjective"], "Entity[\"GrammaticalUnit\", \"Adjective\"]", "grammatical unit"]),(Entity["verb", Entity["GrammaticalUnit","Verb"], "Entity[\"GrammaticalUnit\", \"Verb\"]", "grammatical unit"]),__}(* this is a special case where "Indian" is cast as an adjective *)
};

There are about a dozen patterns that were not going to tackle at this time

\[KernelIcon];usableNarrativeText=Cases[narrativeText,{_,_,nt_}/;(nt/.TextElement[text:{__},"Text"]:>("GrammaticalUnit"/.(Last/@text))//riffleLists//MatchQ[#,Alternatives@@speakerPatterns]&)];
Length@%

We use these rules to extract the desired POS

While they are general, they are not necessarily exhaustive

\[KernelIcon];properNoun=TextElement[_,\[LeftAssociation]"GrammaticalUnit"->(Entity["proper noun", Entity["GrammaticalUnit","ProperNoun"], "Entity[\"GrammaticalUnit\", \"ProperNoun\"]", "grammatical unit"])\[RightAssociation]];
noun=TextElement[_,\[LeftAssociation]"GrammaticalUnit"->(Entity["noun", Entity["GrammaticalUnit","Noun"], "Entity[\"GrammaticalUnit\", \"Noun\"]", "grammatical unit"])\[RightAssociation]];
pronoun=TextElement[_,\[LeftAssociation]"GrammaticalUnit"->(Entity["pronoun", Entity["GrammaticalUnit","Pronoun"], "Entity[\"GrammaticalUnit\", \"Pronoun\"]", "grammatical unit"])\[RightAssociation]];
determiner=TextElement[_,\[LeftAssociation]"GrammaticalUnit"->(Entity["determiner", Entity["GrammaticalUnit","Determiner"], "Entity[\"GrammaticalUnit\", \"Determiner\"]", "grammatical unit"])\[RightAssociation]];
adjective=TextElement[_,\[LeftAssociation]"GrammaticalUnit"->(Entity["adjective", Entity["GrammaticalUnit","Adjective"], "Entity[\"GrammaticalUnit\", \"Adjective\"]", "grammatical unit"])\[RightAssociation]];
adverb=TextElement[_,\[LeftAssociation]"GrammaticalUnit"->(Entity["adverb", Entity["GrammaticalUnit","Adverb"], "Entity[\"GrammaticalUnit\", \"Adverb\"]", "grammatical unit"])\[RightAssociation]];
verb=TextElement[_,\[LeftAssociation]"GrammaticalUnit"->(Entity["verb", Entity["GrammaticalUnit","Verb"], "Entity[\"GrammaticalUnit\", \"Verb\"]", "grammatical unit"])\[RightAssociation]];
speakerRules={
TextElement[{pn:properNoun..,adverb...,verb..,__},"Text"]:>TextElement[{pn},"Text"],
TextElement[{pn:pronoun,adverb...,verb..,__},"Text"]:>TextElement[{pn},"Text"],
TextElement[{d:Repeated[determiner,{0,1}],a:adjective...,n:noun,adverb...,verb..,__},"Text"]:>TextElement[{d,a,n},"Text"],
TextElement[{d:determiner,pn:properNoun..,adverb...,verb..,__},"Text"]:>TextElement[{d,pn},"Text"],
TextElement[{pn:pronoun,n:noun,verb..,__},"Text"]:>TextElement[{pn,n},"Text"],
TextElement[{verb,pn:pronoun,__},"Text"]:>TextElement[{pn},"Text"],
TextElement[{verb,pn:properNoun..,__},"Text"]:>TextElement[{pn},"Text"],
TextElement[{pn:verb,verb,__},"Text"]:>TextElement[{pn},"Text"],
TextElement[{d:determiner,adj:adjective,verb,__},"Text"]:>TextElement[{d,adj},"Text"]
};

\[KernelIcon];usableNarrativeTextSpeakers=usableNarrativeText/.speakerRules/.{te:TextElement[_,"Text"],___}:>te;
First@%

Note that we have retrained the chapter, paragraph, and sentence indices so that

we can examine the extracted text in situ

determine the proximity of speakers for network generation

Here are the speakers:

\[KernelIcon];(characterTextElements=Last/@usableNarrativeTextSpeakers//Union)//Echo[#,"",Length]&//Multicolumn[#,4,Spacings->3]&

some of these characters look suspicious, such as "It" and "There"

\[KernelIcon];(pos=Cases[usableNarrativeTextSpeakers,{_,_,TextElement[{TextElement["It"|"There",<|"GrammaticalUnit"->_|>]},"Text"]}])//Column

\[KernelIcon];highlight[#,"There"|"It"]&/@Join@@(Extract[book[[#1,"TextSentences"]],#2]&)@@@pos

We can drop the 2 instances of speeches associated with "There" from usableNarrativeTextSpeakers

We should also remove the references from the antecedents usableNarrativeText, narrativeText, narrativeSpeechPositions, and speechPositions, but have not for brevity

\[KernelIcon];usableNarrativeTextSpeakers=DeleteCases[usableNarrativeTextSpeakers//Echo[#,"",Length]&,{"3",{{25,1}},_}|{"8",{{10,1}},_}];
Length@%

\[KernelIcon];(characterTextElements=Last/@usableNarrativeTextSpeakers//Union)//Echo[#,"",Length]&//Multicolumn[#,4,Spacings->3]&

These are the characters from which we can construct our character network

Network generation

Manual intervention is needed to take care of synonymy and give full names where known:

\[KernelIcon];characterNameRules={
(RowWithSeparators[ , " ", ({{"Bergen"}, {"Proper Noun"}})])|(RowWithSeparators[ , " ", ({{"McKee"}, {"Proper Noun"}})])->"Bergen McKee",
(RowWithSeparators[ , " ", ({{"Bitsi"}, {"Proper Noun"}})])->"Rudolf Bitsi",
(RowWithSeparators[ , " ", ({{"Canfield"}, {"Proper Noun"}})])->"Jeremy Canfield",
(RowWithSeparators[ , " ", ({{"Eddie"}, {"Proper Noun"}})])->"Eddie Poher",
(RowWithSeparators[ , " ", ({{"Ellen"}, {"Proper Noun"}})])->"Ellen Leon",
(RowWithSeparators[ , " ", ({{"Hall"}, {"Proper Noun"}})])->"Jimmy W. Hall",
(RowWithSeparators[ , " ", ({{"Horseman"}, {"Proper Noun"}})])->"Luis Horseman",
(RowWithSeparators[ , " ", ({{"Leaphorn"}, {"Proper Noun"}})])|(RowWithSeparators[ , " ", ({{"the"}, {"Determiner"}}), ({{"policeman"}, {"Noun"}})])->"Joe Leaphorn",
(RowWithSeparators[ , " ", ({{"Nez"}, {"Proper Noun"}})])|(RowWithSeparators[ , " ", ({{"Billy"}, {"Proper Noun"}}), ({{"Nez"}, {"Proper Noun"}})])->"Billy Nez",
(RowWithSeparators[ , " ", ({{"Roanhorse"}, {"Proper Noun"}})])->"Dick Roanhorse",
(RowWithSeparators[ , " ", ({{"Sandoval"}, {"Proper Noun"}})])->"Sandoval",
(RowWithSeparators[ , " ", ({{"Shoemaker"}, {"Proper Noun"}})])->"Old Man Shoemaker",
(RowWithSeparators[ , " ", ({{"Takes"}, {"Verb"}})])->"Sam George Takes",
(RowWithSeparators[ , " ", ({{"Horn"}, {"Proper Noun"}}), ({{"Rims"}, {"Proper Noun"}})])->"Horn Rims",
(RowWithSeparators[ , " ", ({{"Miss"}, {"Proper Noun"}}), ({{"Leon"}, {"Proper Noun"}})])->"Ellen Leon",
(RowWithSeparators[ , " ", ({{"Mrs."}, {"Proper Noun"}}), ({{"Kreutzer"}, {"Proper Noun"}})])->"Mrs. Kreutzer",
(RowWithSeparators[ , " ", ({{"the"}, {"Determiner"}}), ({{"Indian"}, {"Adjective"}})])|(RowWithSeparators[ , " ", ({{"the"}, {"Determiner"}}), ({{"Indian"}, {"Proper Noun"}})])|(RowWithSeparators[ , " ", ({{"the"}, {"Determiner"}}), ({{"man"}, {"Noun"}})])|(RowWithSeparators[ , " ", ({{"the"}, {"Determiner"}}), ({{"Navajo"}, {"Proper Noun"}})])|(RowWithSeparators[ , " ", ({{"the"}, {"Determiner"}}), ({{"big"}, {"Adjective"}}), ({{"man"}, {"Noun"}})])|(RowWithSeparators[ , " ", ({{"the"}, {"Determiner"}}), ({{"Big"}, {"Proper Noun"}}), ({{"Navajo"}, {"Proper Noun"}})])->"the Big Navajo",
(RowWithSeparators[ , " ", ({{"Old"}, {"Proper Noun"}}), ({{"Woman"}, {"Proper Noun"}}), ({{"Gray"}, {"Proper Noun"}}), ({{"Rocks"}, {"Proper Noun"}})])->"Old Woman Gray Rocks",
TextElement[te:{__TextElement},"Text"]:>(StringRiffle@(ToLowerCase/@First/@te))};

The list of rules was partially generated with this code that was evaluated in place (⌘⇧⌤)

characterNameRules=Thread[characterTextElements->"\[Placeholder]"];

Here is the list of network vertices:

\[KernelIcon];vertices=characterTextElements/.characterNameRules//Union;
Length@%

The criteria (perhaps näive) for an edge will be the characters within 2 paragraphs of each other in the same chapter:

\[KernelIcon];contactQ[{ci_,{{pi_,_},___}},{cj_,{{pj_,_},___}},d_:2]:=ci==cj&&Abs[pi-pj]≤d

Here are the edges of the network:

\[KernelIcon];edges=Join@@Table[If[contactQ[Most@usableNarrativeTextSpeakers[[i]],Most@usableNarrativeTextSpeakers[[j]]],UndirectedEdge[Last@usableNarrativeTextSpeakers[[i]],Last@usableNarrativeTextSpeakers[[j]]],Nothing],{i,1,Length[usableNarrativeTextSpeakers]-1},{j,i+1,Length[usableNarrativeTextSpeakers]}]/.characterNameRules//DeleteCases[#,n_\[UndirectedEdge]n_]&//DeleteDuplicates[#,#1===#2||#1===Reverse[#2]&]&;
Length@%
First@%%

\[KernelIcon];network=Graph[vertices,edges,VertexLabels->Placed["Name",Tooltip]];

\[KernelIcon];Grid[{{"manual network","partial automatic network"},theBlessingWayNetwork/@{manualNetwork,network},StringForm["N = ``, M = ``",##]&@@@{{VertexCount[manualNetwork],EdgeCount[manualNetwork]},{VertexCount[network],EdgeCount[network]}}},Dividers->{All,{True,True,{False},True}}]

What’s next

Extending this analysis

Pronominal resolution

Coreferent resolution

Explore use of dependency strings

\[KernelIcon];TextStructure[Echo@First@sentences,"DependencyStrings"]

Next books in series

Try the functions and rules on Dance Hall of the Dead and Listening Women

Handling text with straight quotes

Machine learning

We anticipate that ML methods will be needed to handle a large number of books

Supervised learning problem

properties: plain text or POS?

response: a sing character name for character identification, or a pair of names for interaction identification

Initialization

SetDirectory@NotebookDirectory[];

<<NachbarDataFunctions`

Colonial Patriot network

Select[ResourceData["Paul Revere's Social Network in Colonial Boston"],#Name=="Paul Revere"&]

Select[ResourceData["Paul Revere's Social Network in Colonial Boston"],#Name=="Samuel Adams"&]

colonialPatriotNetwork[]:=Module[{lodges},
lodges=Normal@Rest[Keys[First[ResourceData["Paul Revere's Social Network in Colonial Boston"]]]];
HighlightGraph[Graph[Flatten[Normal[With[{row=#,name=#Name},If[row[#],name<->#,Nothing]&/@lodges]&/@ResourceData["Paul Revere's Social Network in Colonial Boston"]]],VertexLabels->Placed["Name",Tooltip]],lodges]
]

Irish-Viking network

gravityEmbedding[g_Graph,opts:OptionsPattern[{Graph}]]:=Module[{newVertex=Unique[v],newEdges,coords,gOpts},newEdges=(newVertex\[UndirectedEdge]#1&)/@VertexList[g];coords=GraphEmbedding[EdgeAdd[VertexAdd[g,newVertex],newEdges],"SpringElectricalEmbedding",2];gOpts=FilterRules[Options[g],Except[{VertexCoordinates,GraphLayout}]];Graph[VertexList[g],EdgeList[g],VertexCoordinates->Most[coords],opts,gOpts]]

edgeTypes={"Unsigned","Positive","Negative"};

factions={"FullCast","Irish","Viking"};

ClearAll[faction]
SetAttributes[faction,Listable];
Scan[(faction[#["Character"]]=#["Faction"])&,ResourceData["Irish-Viking Networks in 'Cogadh Gaedhel re Gallaibh'"]]
faction[e:(_DirectedEdge|_UndirectedEdge)]:=faction/@e
faction[_]:=Missing["NotAvailable"]

ClearAll[irishQ]
SetAttributes[irishQ,Listable];
Scan[(irishQ[#["Character"]]=MatchQ[#["Faction"],"Irish"])&,ResourceData["Irish-Viking Networks in 'Cogadh Gaedhel re Gallaibh'"]]
irishQ[_]:=False

ClearAll[vikingQ]
SetAttributes[vikingQ,Listable];
Scan[(vikingQ[#["Character"]]=MatchQ[#["Faction"],"Viking"])&,ResourceData["Irish-Viking Networks in 'Cogadh Gaedhel re Gallaibh'"]]
vikingQ[_]:=False

ClearAll[otherQ]
SetAttributes[otherQ,Listable];
Scan[(otherQ[#["Character"]]=MatchQ[#["Faction"],"Unassigned"])&,ResourceData["Irish-Viking Networks in 'Cogadh Gaedhel re Gallaibh'"]]
otherQ[_]:=False

ClearAll[network]
Do[
Module[{edges,vertices},edges=Cases[s[[2]],s_?(n[[2]])\[UndirectedEdge]t_?(n[[2]])];vertices=Union@@List@@@edges;network[s[[1]],n[[1]]]=Graph[vertices,edges]],{s,{{"Unsigned",EdgeList@ResourceData["Irish-Viking Networks in 'Cogadh Gaedhel re Gallaibh'",All]["FullNetwork"]},{"Positive",EdgeList@ResourceData["Irish-Viking Networks in 'Cogadh Gaedhel re Gallaibh'",All]["PositiveNetwork"]},{"Negative",EdgeList@ResourceData["Irish-Viking Networks in 'Cogadh Gaedhel re Gallaibh'",All]["NegativeNetwork"]}}},{n,{{"FullCast",True&},{"Irish",irishQ},{"Viking",vikingQ}}}]

irishVikingLegend=Module[{irishColor=Lighter@Darker@Green,vikingColor=Blue,otherColor=Gray,irishIrishColor=Darker@Green,vikingVikingColor=Blue,irishVikingColor=Brown,otherOtherColor=Gray,vertex,edge},
vertex[color_,p_:{0,0}]:=Graphics[{color,EdgeForm[Darker@Gray],Disk[p,1]},ImageSize->12];
edge[colorLeft_,colorRight_,colorLine_]:=Graphics[{{AbsoluteThickness[2],colorLine,Line[{{0,0},{5,0}}]},First@vertex[colorLeft,{0,0}],First@vertex[colorRight,{5,0}]},ImageSize->40];
Grid[
{{vertex[irishColor],"Irish"},{vertex[vikingColor],"Viking"},{vertex[otherColor],"Other"},
{edge[irishColor,irishColor,irishIrishColor],"Irish—Irish"},{edge[irishColor,vikingColor,irishVikingColor],"Irish—Viking"},{edge[irishColor,otherColor,otherOtherColor],"Irish—Other"},{edge[vikingColor,otherColor,otherOtherColor],"Viking—Other"},{edge[otherColor,otherColor,otherOtherColor],"Other—Other"}},
Alignment->{{Center,Left}}
]
]

irishVikingNetwork[]:=TabView[Function[edgeType,edgeType->Module[{g=network[edgeType,"FullCast"],vertexStyles,edgeStyles},vertexStyles=#->Switch[faction[#],"Irish",Lighter@Darker@Green,"Viking",Blue,_(*"Unassigned"*),Gray]&/@VertexList[g];
edgeStyles=#->Switch[faction[#],"Irish"\[UndirectedEdge]"Irish",Darker@Green,"Viking"\[UndirectedEdge]"Viking",Blue,("Irish"\[UndirectedEdge]"Viking")|("Viking"\[UndirectedEdge]"Irish"),Brown,_(*"Unassigned"*),Gray]&/@EdgeList[g];
gravityEmbedding[g,VertexStyle->vertexStyles,VertexLabels->Placed["Name",Tooltip],EdgeStyle->edgeStyles,EdgeShapeFunction->"CurvedArc",ImageSize->Large]//Labeled[#,StringForm["N = ``, M = ``",VertexCount[#],EdgeCount[#]],Bottom]&//Legended[#,Placed[irishVikingLegend,After]]&
]]/@edgeTypes]

Manual network

g=gravityEmbedding[manualNetwork,EdgeShapeFunction->"CurvedArc"];

victimColor=Black;
policeColor=Lighter@Blue;
perpetratorColor=Lighter@Red;
civilianColor=LightGray;

ClearAll[theBlessingWayNetwork]
theBlessingWayNetwork[g_Graph] := 
	Module[{vertices, victims, police, perpetrators, civilians, role, vf}, 
		vertices = VertexList[g];
		victims = {"Luis Horseman", "Jeremy Canfield"}; 
		police = {"Dick Roanhorse", "dispatcher", "Joe Leaphorn", "Rudolf Bitsi"}; 
		perpetrators = {"the Big Navajo", "Eddie Poher", "Jimmy W. Hall"}; 
		civilians = Complement[vertices, victims, police, perpetrators];

		SetAttributes[role, Listable];
		Scan[(role[First@#] = Last@#)&, Join @@ Thread /@ {{victims, "Victim"}, {police, "Police"}, 
			{perpetrators, "Perpetrator"}, {civilians, "Civilian"}}];
		role[_] := Missing[];
		
		vf[{xc_, yc_}, name_, {w_, h_}] := Module[{r = 3/4 Sqrt[w^2 + h^2]},
			{Switch[role[name], 
				"Victim", victimColor, 
				"Police", policeColor, 
				"Perpetrator", perpetratorColor, 
				"Civilian", civilianColor, 
				_, Magenta], Disk[{xc, yc}, r]}
			];
  
		Graph[gravityEmbedding[g, EdgeShapeFunction -> "CurvedArc"], VertexShapeFunction -> vf, ImageSize -> Medium] // 
			Legended[#1, SwatchLegend[{victimColor, policeColor, perpetratorColor, civilianColor}, 
			{"Victim", "Police", "Perpetrator", "Civilian"}, LegendMarkers -> "Bubble"]] &
		]

Plan B

framedColumn::usage = "framedColumn[list] displays list in a column with a frame around every element.";
framedColumn[list_List] := Column[list, Frame -> All, FrameStyle -> Blue]

ClearAll[viewData]
viewData::usage = "viewData[expr] displays expr in a scrollable pane.
viewData[expr, h] displays expr in a scrollable pane h inches high.";
viewData[x_, h_:3] := Framed[Pane[x, {Automatic, 72 h}, Scrollbars -> True]]

ClearAll[StringPatternQ]
stringPatternQ[_String] := True
stringPatternQ[_StringExpression] := True
stringPatternQ[_RegularExpression] := True
stringPatternQ[_Longest] := True
stringPatternQ[_Shortest] := True
stringPatternQ[LetterCharacter | DigitCharacter | WordCharacter | NumberString] := True
stringPatternQ[HoldPattern[Repeated][_?stringPatternQ, ___]] := True
stringPatternQ[HoldPattern[RepeatedNull][_?stringPatternQ, ___]] := True
stringPatternQ[alt:_Alternatives] := And @@ stringPatternQ /@ List @@ alt

StringPatternQ[_] := False

ClearAll[textSearch]
textSearch::usage = "textSearch[text, pattern] returns a TabView of the occurances of pattern in text. \
The size of the leading and following context is controlled by the option \"window\"."; 
Options[textSearch] = {
	"window" -> 20
	};
textSearch[txt_String, (str_)?stringPatternQ, opts:OptionsPattern[{textSearch, StringPosition}]] := 
	Module[{win}, 
		win = OptionValue["window"]; 
		TabView[splitAndHighlight[txt, #, win]& /@ StringPosition[txt, str, opts, Overlaps -> False], 
			BaseStyle -> {LineIndent -> 0}
			]
		]
splitAndHighlight[txt_String, pos:{_, _}, win_] := 
	Module[{before, target, after}, 
		{before, target, after} = StringTake[txt, #] & /@ 
			{{1, First@pos - 1}, pos, {Last@pos + 1, StringLength[txt]}};

		before = StringSplit[before, ws:Whitespace :> ws](* // Echo[#, "", FullForm]&*) // 
			Take[#, -Min[2 win, Length[#]]]& // Apply[StringJoin, #]&; 
		after = StringSplit[after, ws:Whitespace :> ws] // 
			Take[#, Min[2 win, Length[#]]]& // Apply[StringJoin, #]&; 
		Row[{before, Style[target, Red], after}]
		]

peruseQuotedText[(*book_,*)quotePositions_,title_]:=(DynamicModule[{c=1,p=1},
Dynamic@Grid[{{Grid[{
{Row[{"# c: ",Length[book]}],SpanFromLeft,SpanFromLeft},
{Button["⇐",p=1;c=1,Appearance->None],Button["←",p=1;c=Max[1,c-1],Appearance->None],c,Button["->",p=1;c=Min[c+1,Length[book]],Appearance->None],Button["\[Implies]",p=1;c=Length[book],Appearance->None]},
{Row[{"# p: ",Length[quotePositions[[c]]]}],SpanFromLeft,SpanFromLeft},
{Button["⇐",p=1,Appearance->None],Button["←",p=Max[1,p-1],Appearance->None],p,Button["->",p=Min[p+1,Length[quotePositions[[c]]]],Appearance->None],Button["\[Implies]",p=Length[quotePositions[[c]]],Appearance->None]}
},
ItemSize->{{1,1,2,1,1}},Spacings->{{0.5,{0},0.5}},Alignment->{{Left,Left,Center,Right,Right}},Dividers->{None,{False,False,True,False}}
],
s=1;
Pane[If[Length[quotePositions[[c]]]>0,
Extract[book[[c,"TextSentences"]],quotePositions[[c,p]]]//framedColumn,
Highlighted["no quotations",Background->LightYellow]],{Automatic,72 4},Scrollbars->True]}},
ItemSize->{{7,40}},Alignment->{{{Left}},{Top}},Frame->All],

TrackedSymbols:>{c,p}
]//Labeled[#,Style[title,Bold],Top]&)

ClearAll[riffleLists]
riffleLists[lists:{_,__List}]:=Join@@Riffle[lists,{{"●"}}]
riffleLists[{list_List}]:=list

highlight::usage="highlight[test, patt] returns a Row expression with patt highlighted in text.";
highlight[text_String, word:(_String|_StringExpression|_Alternatives)] := Row[StringSplit[text, ss:word :> Highlighted[ss]]]

highlight["The quick brown fox jumps over the lazy dog.","fox"]

highlight["The quick brown fox jumps over the lazy dog.","f"~~LetterCharacter~~"x"]

highlight["The quick brown fox jumps over the lazy dog.","o"]

ByteCount@book