Phylogenetic Tree

Author

Eric W. Weisstein
August 3, 2026

This notebook downloaded from https://mathworld.wolfram.com/notebooks/GraphTheory/PhylogeneticTree.nb.

For more information, see Eric's MathWorld entry https://mathworld.wolfram.com/PhylogeneticTree.html.

©2026 Wolfram Research, Inc. except for portions noted otherwise

Illustration

A stylized rooted binary phylogenetic tree. Colored terminal branches identify four taxonomic groups; horizontal positions show branching order rather than evolutionary time.

Module[
		{
			coordinates,
			edges,
			leafGroups,
			edgeGroups,
			palette,
			bands,
			internalVertices,
			neutral,
			textColor
		},
		coordinates = <|
			"root" -> {0.6, 5.125},
			"primates" -> {1.55, 6.875},
			"greatApes" -> {2.5, 7.75},
			"humanChimp" -> {3.45, 8.5},
			"carnivora" -> {2.5, 4.5},
			"laurasiatheria" -> {1.55, 3.375},
			"whippomorpha" -> {2.5, 2.25},
			"cetacea" -> {3.45, 1.5},
			"Homo sapiens" -> {5., 9.},
			"Pan troglodytes" -> {5., 8.},
			"Gorilla gorilla" -> {5., 7.},
			"Pongo pygmaeus" -> {5., 6.},
			"Felis catus" -> {5., 5.},
			"Canis lupus" -> {5., 4.},
			"Hippopotamus amphibius" -> {5., 3.},
			"Balaenoptera musculus" -> {5., 2.},
			"Tursiops truncatus" -> {5., 1.}
		|>;
		edges = {
			{"root", "primates"},
			{"root", "laurasiatheria"},
			{"primates", "greatApes"},
			{"primates", "Pongo pygmaeus"},
			{"greatApes", "humanChimp"},
			{"greatApes", "Gorilla gorilla"},
			{"humanChimp", "Homo sapiens"},
			{"humanChimp", "Pan troglodytes"},
			{"laurasiatheria", "carnivora"},
			{"laurasiatheria", "whippomorpha"},
			{"carnivora", "Felis catus"},
			{"carnivora", "Canis lupus"},
			{"whippomorpha", "Hippopotamus amphibius"},
			{"whippomorpha", "cetacea"},
			{"cetacea", "Balaenoptera musculus"},
			{"cetacea", "Tursiops truncatus"}
		};
		leafGroups = <|
			"Homo sapiens" -> "Primates",
			"Pan troglodytes" -> "Primates",
			"Gorilla gorilla" -> "Primates",
			"Pongo pygmaeus" -> "Primates",
			"Felis catus" -> "Carnivora",
			"Canis lupus" -> "Carnivora",
			"Hippopotamus amphibius" -> "Hippopotamidae",
			"Balaenoptera musculus" -> "Cetacea",
			"Tursiops truncatus" -> "Cetacea"
		|>;
		edgeGroups = <|
			"primates" -> "Primates",
			"greatApes" -> "Primates",
			"humanChimp" -> "Primates",
			"Pongo pygmaeus" -> "Primates",
			"Gorilla gorilla" -> "Primates",
			"Homo sapiens" -> "Primates",
			"Pan troglodytes" -> "Primates",
			"carnivora" -> "Carnivora",
			"Felis catus" -> "Carnivora",
			"Canis lupus" -> "Carnivora",
			"Hippopotamus amphibius" -> "Hippopotamidae",
			"cetacea" -> "Cetacea",
			"Balaenoptera musculus" -> "Cetacea",
			"Tursiops truncatus" -> "Cetacea"
		|>;
		palette = <|
			"Primates" -> RGBColor[0.43, 0.3, 0.78],
			"Carnivora" -> RGBColor[0.92, 0.47, 0.13],
			"Hippopotamidae" -> RGBColor[0.17, 0.64, 0.45],
			"Cetacea" -> RGBColor[0.09, 0.5, 0.78]
		|>;
		bands = {
			{"Primates", {4.75, 5.64}, {9.95, 9.36}},
			{"Carnivora", {4.75, 3.64}, {9.95, 5.36}},
			{"Hippopotamidae", {4.75, 2.64}, {9.95, 3.36}},
			{"Cetacea", {4.75, 0.64}, {9.95, 2.36}}
		};
		internalVertices = Complement[Keys[coordinates], Keys[leafGroups]];
		neutral = LightDarkSwitched[Darker[StandardGray, 0.55], Lighter[StandardGray, 0.55]];
		textColor = LightDarkSwitched[Black, White];
		Graphics[
			{
				Map[
					{
						Opacity[0.09],
						Lookup[palette, #[[1]]],
						Rectangle[#[[2]], #[[3]], RoundingRadius -> 0.14]
					} &,
					bands
				],
				Map[
					Function[
						edge,
						With[
							{
								parent = Lookup[coordinates, edge[[1]]],
								child = Lookup[coordinates, edge[[2]]]
							},
							{
								Lookup[palette, Lookup[edgeGroups, edge[[2]], "Trunk"], neutral],
								AbsoluteThickness[2.6],
								CapForm["Round"],
								JoinForm["Round"],
								Line[{parent, {parent[[1]], child[[2]]}, child}]
							}
						]
					],
					edges
				],
				{
					EdgeForm[Directive[neutral, AbsoluteThickness[1.25]]],
					FaceForm[LightDarkSwitched[White, Darker[StandardGray, 0.55]]],
					Map[Disk[Lookup[coordinates, #], 0.085] &, internalVertices]
				},
				Map[
					{
						EdgeForm[Directive[neutral, AbsoluteThickness[1.15]]],
						Lookup[palette, Lookup[leafGroups, #]],
						Disk[Lookup[coordinates, #], 0.13],
						Text[
							Style[#, 15, Italic, FontFamily -> "Times", FontColor -> textColor],
							Lookup[coordinates, #] + {0.27, 0},
							{-1, 0}
						]
					} &,
					Keys[leafGroups]
				],
				{
					neutral,
					AbsoluteThickness[1.4],
					Arrow[{{0.08, 5.125}, {0.48, 5.125}}],
					Text[
						Style["root", 14, Italic, FontFamily -> "Times", FontColor -> textColor],
						{-0.08, 5.125},
						{1, 0}
					]
				}
			},
			AspectRatio -> 3/4,
			PlotRange -> {{-0.9, 10}, {0.5, 9.5}}
		]
	]

Reference

Jessica Alfonsi, "Four-Color Graphical Bioinformatics: The Machinery Behind Phylogenetic Trees," Wolfram Community, August 3, 2026. https://community.wolfram.com/groups/-/m/t/3773012