Message Boards

GROUPS:

Staff Picks Graphics and Visualization Graphs and Networks Wolfram Language Natural Language Processing Wolfram High School Summer Camp Computational Humanities

Christine Tsu

[WSC21] Creating word clouds of character names from works of fiction

Christine Tsu

Posted 3 months ago

661 Views

1 Reply

3 Total Likes

Follow this post

Pride and Prejudice Word Cloud

Creating word clouds of character names from works of fiction
by Christine Tsu

Introduction

Characters provide the driving force of works of fiction, adding a sense of relatability, personality, and emotion as well as forming a medium through which readers can experience the story. Using a program to identify character names in works of fiction can help reveal trends in the ways characters are written, and visualizations can enhance a reader’s understanding of and connection with the text. My project uses proper nouns and key words, such as "said," "asked," and "believed," to identify character names in works of fiction. It displays those names in a word cloud based on the frequency of each name and also creates a graph of the character relationships, with thicker edges indicating a closer relationship.

Identifying Proper Nouns

This specific code will work for any book entities that have the "Plaintext" property, but most of the code could easily be adapted to work for any plaintext that the user inputs. To begin finding the character names in a work of fiction, I first identified the proper nouns in the work.

Getting the plaintext of a book:

In[]:=

getBook[title_]:=EntityValue[Interpreter["Book"][title],"Plaintext"]

Identifying the proper nouns in a text:

In[]:=

getProperNouns[book_]:=TextCases[book,"ProperNoun"]//DeleteDuplicates

Testing it on Alice’s Adventures in Wonderland by Lewis Carroll:

getProperNouns[getBook["Alice's Adventures in Wonderland"]]

Out[]=

{Alice,White,ORANGE MARMALADE,Dinah,DRINK ME,II,English,Poor Alice,Duchess,Dear,O Mouse,William,Conqueror,Dodo,Lory,Eaglet,III,A CAUCUS-RACE,Ahem,Edwin,Morcar,Earls,Mercia,Northumbria,Stigand,Canterbury,Edgar Atheling,Prizes,Mine,Canary,White Rabbit,Mary Ann,Run,W.,Pat,Bill,Nay,Brandy,ADVICE FROM A CATERPILLAR,Caterpillar,Pigeon,Ugh,Serpent,VI,Fish-Footman,croquet,Frog-Footman,Queen,Footman,Cheshire-Cat,Cheshire-Cats,Cheshire-Puss,Cat,March Hare,Hatter,Dormouse,CROQUET,Miss,First,Kings,Queens,Knave,Hearts,King,Majesty,Herald,March,Pepper,ALICE}

Using Dialogue Tags

For the most part, only characters are able to speak, so dialogue tags (such as “he said” or “she exclaimed”) will help identify character names and distinguish them from other proper nouns (names of places, months, holidays, etc.).

I didn’t want the article “the” to stay in the text because it is not actually part of someone’s name. For example, I wanted to pull out “Hatter” instead of “the Hatter.” I split the text at whitespace and punctuation characters, which left me with a list of words and spaces that I could then use to identify the locations of dialogue words, and subsequently, the locations of character names.

Removing "the" and splitting the plaintext at whitespace and punctuation characters:

In[]:=

getText[title_]:=StringSplit[StringReplace[getBook[title]," the "->" "],{Whitespace,PunctuationCharacter}];

I wanted to catch two-word names, such as "Mary Jones" and "Ms. Jones," as well as one-word names. However, names with abbreviations, like Ms. Jones, will now appear with a blank space between the abbreviation and the last name. To format all two-word names in the same way, I removed the space between “Mrs” and “Jones” in the list.

Example of splitting a string with "Mary Jones" and "Ms. Jones":

splitString=StringSplit["Mary Jones and Ms. Jones",{Whitespace,PunctuationCharacter}]

Out[]=

{Mary,Jones,and,Ms,,Jones}

Deleting the space after an abbreviation:

In[]:=

Delete[splitString,Position[splitString,"Ms"]+1]

Out[]=

{Mary,Jones,and,Ms,Jones}

I applied this logic to create a function that will do the same for the entire text.

A function that deletes the space after abbreviations:

In[]:=

shortenAbbreviations[text_]:=Module[{abbreviationIndices=Position[text,"Mrs"|"Mr"|"Ms"|"Dr"|"Mx"]},Delete[text,abbreviationIndices+1]];

Next, I needed to find the indices of dialogue words (like "said," "demanded," "exclaimed," etc.). I caught two-word names as well as one-word names by checking if there was an uppercase word located at an index either two above or two below the index of the dialogue word. If not, I just took the single words on either side of the speech word.

A function that finds the indices of speech words and puts the names around them into a list:

In[]:=

findSpeechWords[text_]:=ModulespeechIndices=FlattenPositiontext,

Speech Words

,speechWords,speechWords=Flatten[Table[Which[StringStartsQ[text[[speechIndices[[i]]+2]],ToUpperCase[Alphabet[]]]&&StringStartsQ[text[[speechIndices[[i]]+1]],ToUpperCase[Alphabet[]]],StringJoin[text[[speechIndices[[i]]+1]]," ",text[[speechIndices[[i]]+2]]],StringStartsQ[text[[speechIndices[[i]]-2]],ToUpperCase[Alphabet[]]]&&StringStartsQ[text[[speechIndices[[i]]-1]],ToUpperCase[Alphabet[]]],StringJoin[text[[speechIndices[[i]]-2]]," ",text[[speechIndices[[i]]-1]]],True,{text[[speechIndices[[i]]-1]],text[[speechIndices[[i]]+1]]}],{i,Length[speechIndices]}]]//DeleteDuplicates

Since I removed the periods after abbreviations like "Ms.," I put them back in by adding a line of code to the end of the function above.

A function that finds the indices of speech words, puts the words around them into a list, and adds the periods back to abbreviations:

In[]:=

findSpeechWords[text_]:=ModulespeechIndices=FlattenPositiontext,

Speech Words

Testing the function on Alice’s Adventures in Wonderland:

In[]:=

findSpeechWords[shortenAbbreviations[getText["Alice's Adventures in Wonderland"]]]

Out[]=

{,Alice,she,and,anxiously,this,these,it,nothing,Mouse,Lory,Duck,rather,Dodo,Eaglet,voices,in,Fury,to,cunning,voice,hear,now,master,you,Caterpillar,very,hastily,had,Pigeon,Footman,two,Duchess,She,last,Cat,they,out,he,was,aloud,March Hare,Dormouse,Hatter,no,Seven,Queen,severely,a,Rabbit,Somebody,White Rabbit,King,cook,who,Knave,her}

Using Other Key Verbs

Aside from dialogue tags, I also used other verbs that tend to be exclusively used for characters (like "thought" or "believed"). The same method can be used to create a list of words that appear before these verbs.

A function that creates a list of words that appear before specific verbs:

In[]:=

findOtherVerbs[text_]:=Module[{verbIndices=Flatten[Position[text,"bought"|"buys"|"heard"|"hears"|"thought"|"thinks"|"sat"|"sits"|"believed"|"believes"]],verbWords},verbWords=DeleteCases[Flatten[Table[Which[StringStartsQ[text[[verbIndices[[i]]-2]],ToUpperCase[Alphabet[]]]&&StringStartsQ[text[[verbIndices[[i]]-1]],ToUpperCase[Alphabet[]]],StringJoin[text[[verbIndices[[i]]-2]]," ",text[[verbIndices[[i]]-1]]],StringStartsQ[text[[verbIndices[[i]]-1]],ToUpperCase[Alphabet[]]],text[[verbIndices[[i]]-1]]],{i,Length[verbIndices]}]],Null]//DeleteDuplicates;verbWords=If[StringContainsQ[#,"Mrs"|"Mr"|"Ms"|"Dr"|"Mx"],StringReplace[#," "->". "],#]&/@verbWords];

Testing the function on Pride and Prejudice:

In[]:=

findOtherVerbs[shortenAbbreviations[getText["Pride and Prejudice"]]]

Out[]=

{Mr. Bingley,I,Elizabeth,Mrs. Hurst,He,Maria,Mrs. Collins,You,Lydia,Mrs. Gardiner,Mr. Bennet,Colonel Forster,Jane,She,Mrs. Bennet}

Removing Duplicates

From the work above, I gathered a list of proper nouns, words from dialogue tags, and words from key verbs. I first combined the words from dialogue tags and words from key verbs to catch as many character names as possible. Then, I found the intersection of this new list with the list of proper nouns.

A function that uses all three lists to create a new list:

In[]:=

getIntersection[wordList1_,wordList2_,properNounList_]:=Flatten[Intersection[properNounList,Union[wordList1,wordList2]]];

Testing it on The Secret Garden:

In[]:=

shortenedText=shortenAbbreviations[getText["The Secret Garden"]];getIntersection[findSpeechWords[shortenedText],findOtherVerbs[shortenedText],getProperNouns[getBook["The Secret Garden"]]]

Out[]=

{Archibald Craven,Basil,Ben,Ben Weatherstaff,Colin,Colonel McGrew,Dickon,Dr. Craven,Martha,Mary,Master Craven,Mem Sahib,Mester Colin,Miss Mary,Mistress Mary,Mother,Mr. Craven,Mr. Roach,Mrs. Medlock,Mrs. Sowerby,Nut,Rajah,Roach,robin,Susan Sowerby,Weatherstaff}

There is some overlap here. For instance, "Mary," "Mary Lennox," "Miss Mary," and "Mistress Mary" all refer to the same person. To remove these duplicates, I first separated the names into a list of one-word names and a list of two-word names.

Separating a list of character names into one-word and two-word names:

In[]:=

twoWordNames={};oneWordNames={};If[StringContainsQ[#,__~~" "~~__],twoWordNames=Append[twoWordNames,#],oneWordNames=Append[oneWordNames,#]]&/@

Character Names

;oneWordNamestwoWordNames

Out[]=

{Basil,Ben,Colin,Dickon,Martha,Mary,Mother,Nut,Rajah,Roach,robin,Weatherstaff}

Out[]=

{Archibald Craven,Ben Weatherstaff,Colonel McGrew,Dr. Craven,Master Craven,Mem Sahib,Mester Colin,Miss Mary,Mistress Mary,Mr. Craven,Mr. Pitcher,Mr. Roach,Mrs. Crawford,Mrs. Medlock,Mrs. Sowerby,Susan Sowerby}

I went through each item in the list of twoWordNames and checked if part of it was already included in oneWordNames (for example, "Miss Mary" includes "Mary"). Then, I collected each group of duplicates in a list.

Collecting the groups of duplicate characters in a list:

In[]:=

duplicateCharacters=DeleteCases[Flatten[Table[Which[StringCount[i,j]!=0&&i!=j,{i,j}],{i,twoWordNames},{j,oneWordNames}],1],Null]

Out[]=

{{Ben Weatherstaff,Ben},{Ben Weatherstaff,Weatherstaff},{Mester Colin,Colin},{Miss Mary,Mary},{Mistress Mary,Mary},{Mr. Roach,Roach}}

I started to create a list of all of the characters by first adding the characters that were not included in the duplicate list.

Collecting the character names that are not duplicates:

In[]:=

allCharacters=Complement

Character Names

,Flatten[duplicateCharacters]

Out[]=

{Archibald Craven,Basil,Colonel McGrew,Dickon,Dr. Craven,Martha,Master Craven,Mem Sahib,Mother,Mr. Craven,Mr. Pitcher,Mrs. Crawford,Mrs. Medlock,Mrs. Sowerby,Nut,Rajah,robin,Susan Sowerby}

I chose the shortest item from each list of duplicate characters (for example, “Mary” instead of “Miss Mary”) and added it to the list of all of the characters.

Add the shorter name from each of the duplicate character lists to the list of all characters:

In[]:=

Table[allCharacters=Append[allCharacters,i[[Flatten[Position[StringLength[i],Min[StringLength[i]]]]]]],{i,duplicateCharacters}];allCharacters

Out[]=

{Archibald Craven,Basil,Colonel McGrew,Dickon,Dr. Craven,Martha,Master Craven,Mem Sahib,Mother,Mr. Craven,Mr. Pitcher,Mrs. Crawford,Mrs. Medlock,Mrs. Sowerby,Nut,Rajah,robin,Susan Sowerby,{Ben},{Weatherstaff},{Colin},{Mary},{Mary},{Roach}}

Organize the list and delete duplicates:

In[]:=

allCharacters=Sort[Flatten[allCharacters//DeleteDuplicates]]

Out[]=

{Archibald Craven,Basil,Ben,Colin,Colonel McGrew,Dickon,Dr. Craven,Martha,Mary,Master Craven,Mem Sahib,Mother,Mr. Craven,Mr. Pitcher,Mrs. Crawford,Mrs. Medlock,Mrs. Sowerby,Nut,Rajah,Roach,robin,Susan Sowerby,Weatherstaff}

Putting It All Together

I wrapped all of the steps above in a function that removes duplicates in a list of characters. One issue is that the function isn't able to tell if names like "Mrs. Sowerby" and "Susan Sowerby" refer to the same person or not. I decided to leave the duplicates in rather than only including one name that has "Sowerby" in it because it is possible that two people have the same last name (for instance, if they are related to each other).

A function that removes duplicates in a list of characters:

In[]:=

removeDuplicates[characterList_]:=Module[{twoWordNames={},oneWordNames={},duplicateCharacters={},allCharacters},If[StringContainsQ[#,__~~" "~~__],twoWordNames=Append[twoWordNames,#],oneWordNames=Append[oneWordNames,#]]&/@characterList;duplicateCharacters=DeleteCases[Flatten[Table[Which[StringCount[i,j]!=0&&i!=j,{i,j}],{i,twoWordNames},{j,oneWordNames}],1],Null];allCharacters=Complement[characterList,Flatten[duplicateCharacters]];Table[allCharacters=Append[allCharacters,i[[Flatten[Position[StringLength[i],Min[StringLength[i]]]]]]],{i,duplicateCharacters}];allCharacters=Sort[Flatten[allCharacters//DeleteDuplicates]]];

Creating the Final List

In my final character list, I decided not to include words that were only prepositions, determiners, interjections, and pronouns, all of which would most likely not be character names. In case some character names had different capitalization styles, I also removed duplicates after changing the entire list to lower case. I reformatted the list after that to make sure that the capitalization style was correct again.

A function that cleans the final character list:

In[]:=

finalCharacterList[allCharacters_]:=Module[{finalCharacters={}},Table[If[PartOfSpeech[i]=!={Entity["GrammaticalUnit","Preposition"]}&&PartOfSpeech[i]=!={Entity["GrammaticalUnit","Determiner"]}&&PartOfSpeech[i]=!={Entity["GrammaticalUnit","Interjection"]}&&PartOfSpeech[i]=!={Entity["GrammaticalUnit","Pronoun"]},finalCharacters=Append[finalCharacters,i]],{i,allCharacters}];finalCharacters=Capitalize[DeleteDuplicates[ToLowerCase[finalCharacters]],"AllWords"];If[StringContainsQ[#,"Mc"],StringReplace[#,"Mc"~~x_->"Mc"~~ToUpperCase[x]],#]&/@finalCharacters];

Testing the function on The Secret Garden:

In[]:=

finalCharacterList

All Characters



Out[]=

Creating a Word Cloud of the Character Names

I used a word cloud to display the character names. Since character names that appear a greater number of times in the text are larger in the word cloud, it provides a visual of the importance of different characters.

First-person narratives present a challenge because the narrator's name may not appear. For instance, if Mary was the narrator of The Secret Garden, it is unlikely that "said Mary" or "Mary thought" would appear in the text. As a temporary work-around for this, I decided to create a function that tests if the work was written in the first person. If it is, a caption under the word cloud will let the user know that the narrator's name may not appear in the cloud.

Testing If the Work Was Written in the First Person

My function first deletes the dialogue in the work of fiction. This way, the program will not have to sift through dialogue that may contain the word "I." Next, the function counts the number of times that the word "I" appears in the work (not including the dialogue) and divides this number by the total word count to come up with a percentage. Through testing, I found that if the percentage is over 1.5%, the work of fiction tends to be in the first person.

A function that tests if the work of fiction as written in the first person:

In[]:=

firstPersonTest[book_]:=Module[{noDialogue=StringDelete[book,Shortest["\""~~___~~"\""]]},If[StringCount[noDialogue," "~~"I"~~" "]/WordCount[noDialogue]>=0.015,"This work of fiction was likely written in the first person, so the narrator's name may not appear in the word cloud and graph.",""]];

Testing it on a book written in the first person (The Time Machine) and a book not written in the first person (The Secret Garden):

In[]:=

firstPersonTest[getBook["The Time Machine"]]

Out[]=

This work of fiction was likely written in the first person, so the narrator's name may not appear in the word cloud and graph.

In[]:=

firstPersonTest[getBook["The Secret Garden"]]

Out[]=

Displaying the Word Cloud

I wrote a function that uses the final list of characters to create a word cloud based on how often each character name appeared in the text. The word cloud also includes a caption below it, which will display the first-person message above if the work was written in the first person.

A function that creates a word cloud of the character names:

In[]:=

createWordCloud[book_,characterList_,str_,caption_]:=LabeledWordCloudWordFrequency[book,characterList,IgnoreCase->True],

SequenceIcon

,Style[caption,"SmallText"];

Testing it on The Secret Garden:

In[]:=

createWordCloudgetBook["The Secret Garden"],

Final Character List

,"The Secret Garden",firstPersonTest[getBook["The Secret Garden"]]

Out[]=

Creating a Graph of the Character Relationships

My graph provides a visualization of how strong/weak character relationships are by correlating edge thickness with how often two character names appear together. Counting the number of times two character names appear in the same chapter would be a good way to measure this. However, different texts have different formatting for chapters, so it would be more complex to separate different books by chapter. I instead decided to count how many times two character names appear in the same 30-paragraph section.

A function that separates the plaintext into 30-paragraph sections:

In[]:=

getNewText[book_]:=Partition[TextCases[book,"Paragraph"],UpTo[30]]

Counting How Many Times Two Character Names Appear in the Same Section

Creating a list of character names for each section:

In[]:=

charactersInSections=TableIf[StringCount[StringJoin[i],j]>0,j,##&[]],{i,getNewText[getBook["The Secret Garden"]]},j,

Final Character List

//Short

Out[]//Short=

{{Mary,Mem Sahib},{Archibald Craven,Basil,Colonel McGrew,Mary,Mrs. Crawford,Mrs. Medlock},71,{Ben,Colin,Mrs. Medlock}}

Placing the lists of character names that include more than one name in a new list:

In[]:=

multipleCharacters={};DeleteCases[If[Length[#]>1,multipleCharacters=Append[multipleCharacters,#]]&/@charactersInSections,Null];multipleCharacters//Short

Out[]//Short=

{{{Mary,Mem Sahib},{Archibald Craven,Basil,Colonel McGrew,Mary,Mrs. Crawford,Mrs. Medlock},71,{Ben,Colin,Mrs. Medlock}}}

Count the number of times two specific character names appear in a sublist:

In[]:=

Counts[Flatten[Subsets[#,{2}]&/@multipleCharacters,1]]//Short

Out[]//Short=

{Mary,Mem Sahib}2,{Archibald Craven,Basil}1,137,{Archibald Craven,Weatherstaff}1,{Mr. Craven,Rajah}1

I created a function to do the three steps above.

A function that counts how many times two characters appear in the same section:

In[]:=

characterCounts[newText_,finalCharacters_]:=Module[{multipleCharacters={},charactersInSections},charactersInSections=Table[If[StringCount[StringJoin[i],j]>0,j,##&[]],{i,newText},{j,finalCharacters}];DeleteCases[If[Length[#]>1,multipleCharacters=Append[multipleCharacters,#]]&/@charactersInSections,Null];Counts[Flatten[Subsets[#,{2}]&/@multipleCharacters,1]]]

Testing it on The Secret Garden:

characterCountsgetNewText[getBook["The Secret Garden"]],

Final Character List

//Short

Out[]//Short=

{Mary,Mem Sahib}2,{Archibald Craven,Basil}1,137,{Archibald Craven,Weatherstaff}1,{Mr. Craven,Rajah}1

Converting the Counts to Edge Weights for the Graph

I wanted to scale the edge weights of my graph so that character relationships with greater counts would have larger weights. I decided to standardize the scale by setting the maximum value to 7 and adjusting the other values accordingly.

A function that converts the counts to a format that will set the edge weights of the graph:

In[]:=

setWeights[counts_]:=Module[{value=Max[Values[counts]]/7,weights},weights=Values[counts]/value;AssociationThread[Table[i[[1]]i[[2]],{i,Keys[counts]}],weights]];

Testing it on The Secret Garden:

In[]:=

setWeights

Character Counts

//Short

Out[]//Short=

MaryMem Sahib

,Archibald CravenBasil

,137,Archibald CravenWeatherstaff

,Mr. CravenRajah