Message Boards Message Boards

Hamilton meets Hamilton -- a Hamiltonian Hamilton graph

GROUPS:

The popularity of the Hamilton musical is just nonstop. There are even some Hamilton goodies in WolframAlpha and the Wolfram Language:

EntityList[EntityClass["PopularCurve", "Hamilton"]]

enter image description here

GraphicsGrid[Partition[EntityValue[EntityList[EntityClass["PopularCurve", "Hamilton"]], "Image"], 4], ImageSize -> Large]

enter image description here

But before 2015, the only Hamilton I ever heard about regularly was...

"What's your name, man?"
"William Rowan Hamilton!"

Sir William was a young, scrappy, and hungry Irish mathematician and physicist for whom several objects in math and physics are named. His name also appears in some Wolfram Language symbols:

?*Hamilton*

enter image description here

These symbols have to do with Hamiltonian paths. A Hamiltonian path through a graph passes through each vertex exactly once. A Hamiltonian path that begins and ends at the same vertex is called a Hamiltonian cycle, and a graph is Hamiltonian if it contains a Hamiltonian cycle.

Personally I think the world is wide enough for both Hamiltons. So can we find a Hamiltonian graph in the Hamilton musical? It's time to take a shot.

To form a graph, we need vertices and edges. The 1, 2, 3, 4, 5, 6, 7, 8 characters represented by popular curves make natural vertices, since we have nice pictures for them. We just need to decide how to draw edges between them. One possibility would be to connect two characters if they're on stage at the same time, but that information isn't easy to get programmatically. We have the lyrics, thanks to the cast recording booklets and Genius. So let's draw a graph showing which characters talk about which other characters, drawing an edge from character $A$ to character $B$ if $A$ mentions $B$. Since the edges are directed edges, this will make it a bit harder for the graph to be Hamiltonian.

What comes next? A lot of text processing to get the lyrics into a structured form. For each character, we need the lines sung by that character. This requires handling compound instructions like "HAMILTON/BURR/LAURENS/ALL WOMEN (EXCEPT ELIZA)", realizing that "SCHUYLER SISTERS" includes Angelica, Eliza, #andPeggy, and correcting a few typos (notice the 4 ways of spelling "WASHINGTON"). enter image description here

That list of 66 "characters" of course contains duplicates, non-characters, and characters we don't care about. Many lines are sung by multiple characters, so I distributed those lines to each character they are assigned to, and finally collected all lines by character. I've attached the file to the bottom of this post.

linesbycharacter = Import["linesbycharacter.m"];

Here are the characters:

Sort[First /@ linesbycharacter]

{"ANGELICA", "BURR", "DOCTOR", "DOLLY", "ELIZA", "GEORGE", "HAMILTON", "JAMES", "JEFFERSON", "KING GEORGE", "LAFAYETTE",
  "LAURENS", "LEE", "MADISON", "MARIA", "MARTHA", "MULLIGAN", "PEGGY", "PHILIP", "SEABURY", "WASHINGTON"}

At this point it's easy to compute statistics on the lyrics. Here are the number of words each character sings, and a log plot:

Reverse[Sort[WordCount /@ Association[linesbycharacter]]]
ListLogPlot[%, Filling -> Axis, Ticks -> {None, Automatic}]

<|"HAMILTON" -> 5977, "BURR" -> 3889, "ELIZA" -> 1805, "WASHINGTON" -> 1634, "JEFFERSON" -> 1596, "ANGELICA" -> 1410,
  "LAURENS" -> 854, "MADISON" -> 738, "LAFAYETTE" -> 688, "PHILIP" -> 572, "KING GEORGE" -> 568, "MULLIGAN" -> 543, "PEGGY" -> 162,
  "MARIA" -> 137, "SEABURY" -> 128, "LEE" -> 99, "JAMES" -> 83, "GEORGE" -> 59, "DOCTOR" -> 56, "MARTHA" -> 18, "DOLLY" -> 5|>

enter image description here

And we can create word clouds for each character.

WordCloud["BURR" /. linesbycharacter, FontFamily -> "American Typewriter"]

enter image description here

I posted a bunch of these on Twitter a while back.

Grid[Partition[
  (Labeled[WordCloud[
       StringReplace[TextWords[DeleteStopwords[
          StringDelete[#1 /. linesbycharacter, "ev'ry" | "there'll", IgnoreCase -> True]]], "'" -> "\[CloseCurlyQuote]"], 
       FontFamily -> "American Typewriter"], #] &) /@ 
    Keys[Take[Reverse[Sort[WordCount /@ Association[linesbycharacter]]], 15]], 
  5
]]

enter image description here

Okay, can we get back to politics? Let's construct the graph showing who mentions who. We have each character's lines, so now we have to extract mentions of each character from those lines. Again this isn't totally straightforward, because characters are referred to in multiple ways. Eliza never says "Hamilton" because she calls him "Alexander". Eliza refers to the Washington Monument but not Washington the person by name; but she does say "the General", so we'll count it. Here's what we get when we restrict to the 8 popular curve characters:

edges = Join @@ Thread /@ {
   "Angelica" -> {"Angelica", "Burr", "Eliza", "Hamilton", "Jefferson"}, 
   "Burr" -> {"Angelica", "Burr", "Eliza", "Hamilton", "Jefferson", "Washington"}, 
   "Eliza" -> {"Angelica", "Eliza", "Hamilton", "Washington"}, 
   "Hamilton" -> {"Angelica", "Burr", "Eliza", "Hamilton", 
   "Jefferson", "King George", "Lafayette", "Washington"}, 
   "Jefferson" -> {"Burr", "Hamilton", "Lafayette", "Washington"}, 
   "King George" -> {"Washington"}, 
   "Lafayette" -> {"Burr", "Hamilton", "Lafayette"}, 
   "Washington" -> {"Burr", "Hamilton", "Jefferson", "Lafayette"}
};

To draw the graph, let's pick some patriotic colors.

EntityValue[Entity["Country", "UnitedStates"], "Flag"]
{blue, red, white} = Union[Cases[%, _RGBColor, Infinity]]

enter image description here

Extract the blue from the Hamilton curve so we can replace it with the flag blue:

curveblue = First[Cases[EntityValue[Entity["PopularCurve", "HamiltonCurve"], "Image"], _RGBColor, Infinity]]

enter image description here

Here's the graph:

graph = Graph[edges, 
  EdgeShapeFunction -> GraphElementData[{"Arrow", "ArrowSize" -> .02, "ArrowPositions" -> .5}],
  EdgeStyle -> red, 
  GraphLayout -> "LayeredDigraphEmbedding",
  ImageSize -> 600, 
  PerformanceGoal -> "Quality", 
  VertexShapeFunction -> (Inset[Replace[EntityValue[Entity["PopularCurve", StringDelete[#2, Whitespace] <> "Curve"], "Image"] /.
    curveblue -> blue, {(Axes -> _) -> Axes -> False, (ImageSize -> _) -> ImageSize -> 70}, {1}], #1] &)
]

enter image description here

Is the graph Hamiltonian??? Wait for it...

HamiltonianGraphQ[graph]

True

Let's see a Hamiltonian cycle!

HighlightGraph[graph, First[FindHamiltonianCycle[graph]], GraphHighlightStyle -> "DehighlightGray"]

enter image description here

Just the cycle, without the other edges:

HighlightGraph[graph, First[FindHamiltonianCycle[graph]], GraphHighlightStyle -> "DehighlightHide"]

enter image description here

Here's a text version of the Hamiltonian cycle:

StringJoin[Riffle[(Append[#, First[#]] &)[RotateLeft[First /@ First[FindHamiltonianCycle[graph]], 2]], " mentions "]]

"Hamilton mentions King George mentions Washington mentions Lafayette mentions Burr mentions Eliza mentions Angelica mentions Jefferson mentions Hamilton"

So there we have it — a Hamiltonian Hamilton graph. For each edge in the graph, can you think of a line where character $A$ mentions character $B$?

And for bonus points.... can you now analyze the lyrics using quaternions?

Attachments:
POSTED BY: Eric Rowland
Answer
11 months ago

enter image description here - Congratulations! This post is now Staff Pick! Thank you for your wonderful contributions. Please, keep them coming!

POSTED BY: Moderation Team
Answer
11 months ago

Hi Eric,

I have a friend who knows a lot about the periodic table, and also loves Hamilton the show. After months wondering why Americans would be so interested in attending something Irish, my friend finally explained to me that it was actually about the US politician.

Ha!

Your post is reminding me about the "Almost Regular Representation", so maybe I will write a post about that, especially if I can think up a clever title.

Cheers,

Brad

POSTED BY: Brad Klee
Answer
11 months ago

I'm not familiar with the almost regular representation, so that would be great!

POSTED BY: Updating Name
Answer
11 months ago

Group Abstract Group Abstract