Message Boards Message Boards

[GIF] Visualizing the boxing career of Muhammad Ali, alias "The Greatest"

Note: in this post I will show how to create the following animation using the Wolfram Language.

enter image description here

Last Friday, Muhammad Ali alias "the Greatest" died at age 74. He was one of the most iconic heavyweight boxers of all times. Outside the ring he was famous for his public stance against the Vietnam War and his longtime battle with Parkinson's disease. I'm not a huge fan of boxing, but I have to admit that Ali's biography captivated me.

I will start by checking the info about him on Wolfram|Alpha: enter image description here

On his wikipedia page there is a nice table about all his official fights. I will import this data directly from this HTML as follows:

wikiPage = Import["https://en.wikipedia.org/wiki/Muhammad_Ali", "Source"];
tableRaw = StringCases[wikiPage, "<table class=\"wikitable succession-box\" style=\"margin:0.5em \
auto; font-size:95%;clear:both;\">" ~~ x__ ~~ "</table>" -> x];
list = StringCases[tableRaw, Shortest["<td" ~~ x__ ~~ "</td>"] -> x];

From here it's easy to get fights he won and the ones he lost:

resultsI =  StringContainsQ[Table[list[[1, 10 i + 4]], {i, 33, 61}], "Win"];    
resultsII =  StringContainsQ[Table[list[[1, 10 i + 3]], {i, 32}], "Win"];
results = Reverse[Join[resultsII, resultsI]] /. {True -> "Win", False -> "Loss"}

{"Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Loss", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Loss", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Win", "Loss", "Win", "Loss", "Loss"}

I can obtain the opponents info in a similar way:

opponents = 
  Reverse@Join[
    StringCases[Table[list[[1, 10 i + 5]], {i, 32}], Shortest["title=" ~~ x__ ~~ ">"] -> x], 
    StringCases[Table[list[[1, 10 i + 6]], {i, 33, 61}], Shortest["title=" ~~ x__ ~~ ">"] -> x]];

I can delete the quotation marks from the opponent's list with StringDelete:

opponentsAll = 
 Map[StringDelete[# , "\""] &, 
  ReplacePart[opponents, 
   MapThread[#1 -> #2 &, {Position[Map[Length[#] &, opponents], 1], 
     Partition[Flatten@Transpose[{Select[opponents, Length[#] == 1 &], 
         Part[Reverse@Join[
            StringCases[Table[list[[1, 10 i + 5]], {i, 32}], Longest["</a></span>" ~~ x__ ~~ ""] -> x], 
            StringCases[Table[list[[1, 10 i + 6]], {i, 33, 61}], Longest["</a></span>" ~~ x__ ~~ ""] -> x]], 
          Flatten@Position[Map[Length[#] &, opponents], 1]]}], 2]}]]]

Then it is straightforward to get the opponents names and their nationality separately:

opponentsNames = opponentsAll[[1 ;; All, 2]]

{Tunney Hunsaker,Herb Siler, Tony Esperti,Jim Robinson (boxer), Donnie Fleeman, LaMar Clark, Duke Sabedong, Alonzo Johnson, Alex Miteff,Willi Besmanoff,Sonny Banks, Don Warner, George Logan, Billy Daniels, Alejandro Lavorante,Archie Moore,Charlie Powell,Doug Jones (boxer),Henry Cooper,Sonny Liston,Sonny Liston,Floyd Patterson,George Chuvalo,Henry Cooper,Brian London,Karl Mildenberger,Cleveland Williams,Ernie Terrell,Zora Folley,Jerry Quarry,Oscar Bonavena,Joe Frazier,Jimmy Ellis (boxer),Buster Mathis,Jürgen Blin,Mac Foster,George Chuvalo,Jerry Quarry,Alvin Lewis (boxer),Floyd Patterson,Bob Foster (boxer),Joe Bugner,Ken Norton,Ken Norton,Rudie Lubbers,Joe Frazier,George Foreman,Chuck Wepner,Ron Lyle,Joe Bugner,Joe Frazier,Jean-Pierre Coopman,Jimmy Young (boxer),Richard Dunn (boxer),Ken Norton,Alfredo Evangelista,Earnie Shavers,Leon Spinks,Leon Spinks,Larry Holmes,Trevor Berbick}

opponentsNationality = opponentsAll[[1 ;; All, 1]] /. "West Germany" -> "Germany"

{United States,United States,United States,United States,United States,United States,United States,United States,Argentina,Germany,United States,United States,United States,United States,Argentina,United States,United States,United States,United Kingdom,United States,United States,United States,Canada,United Kingdom,United Kingdom,Germany,United States,United States,United States,United States,Argentina,United States,United States,United States,Germany,United States,Canada,United States,United States,United States,United States,United Kingdom,United States,United States,Netherlands,United States,United States,United States,United States,United Kingdom,United States,Belgium,United States,United Kingdom,United States,Uruguay,United States,United States,United States,United States,Canada}

I can directly obtain the flags of their countries using the CountryData function: 

opponentsFlags = Map[CountryData[#, "Flag"] &, opponentsNationality]

Then in order to get the result type from each fight, I can do the following:

types = Flatten@Reverse@Join[
     StringCases[Table[list[[1, 10 i + 6]], {i, 32}], Shortest["<small>" ~~ x__ ~~ "</small>"] -> x], 
     StringCases[Table[list[[1, 10 i + 7]], {i, 33, 61}], Shortest["<small>" ~~ x__ ~~ "</small>"] -> x]] /. {"UD" -> "UD, Unanimous decision",
 "KO" -> "KO, Knockout", "TKO" -> "TKO, Technical Knockout", "SD" -> "SD, Split decision"}

In a similar way, I can obtain the dates of the fights:

dates = Flatten@Reverse@Join[
    StringCases[Table[list[[1, 10 i + 8]], {i, 32}], Shortest["<small>" ~~ x__ ~~ "</small>"] -> x], 
    StringCases[Table[list[[1, 10 i + 9]], {i, 33, 61}], Shortest["<small>" ~~ x__ ~~ "</small>"] -> x]]

And convert them into DateObjects using Interpreter:

dateObjects = Interpreter["Date"][dates]

Ali's birthday was on:

birthDay = DateObject[{1942, 01, 17}]

Then I can construct the TimeSeries in the following way:

timeseries = Table[TimeSeries[Transpose[{dateObjects, Map[r = 0; r += # &, results]}][[1 ;; u]]], {u, 61}]
timeseriesLosses = Table[TimeSeries[Part[Transpose[{dateObjects, Map[r = 0; r += # &, results]}],
    If[u >= 32,
     If[u >= 43,
      If[u >= 58,
       If[u >= 60,
        If[u >= 61,
         Flatten@Position[results, 0][[1 ;; 5]],
         Flatten@Position[results, 0][[1 ;; 4]]],
        Flatten@Position[results, 0][[1 ;; 3]]],
       Flatten@Position[results, 0][[1 ;; 2]]],
      Flatten@Position[results, 0][[1]]], {0}]]], {u, 61}]

The locations of the fights were:

locations = Reverse@Join[
   StringCases[Table[list[[1, 10 i + 10]], {i, 32}], Shortest["title=" ~~ x__ ~~ ">"] -> x], 
   StringCases[Table[list[[1, 10 i + 11]], {i, 33, 61}], Shortest["title=" ~~ x__ ~~ ">"] -> x]]

locationslist = Map[StringReplace[StringJoin[#], "\"" -> " "] &, locations]

And now I can use Interpreter with "Location" in order to get the coordinates of the places:

locationsObjects = Interpreter["Location"][locationslist]

I can get the flags from the countries of the fights locations with CountryData and GeoNearest:

flagslist = Map[CountryData[GeoNearest[Entity["Country"], #][[1]], "Flag"] &, locationsObjects]

And I can create custom GeoMarkers for the Geographics Map of the fights:

geomarkersColored = Table[ReplacePart[
Map[GeoMarker[#, "Scale" -> Scaled[0.04], "Color" -> RGBColor[0.22, 0.71, 0.21, 0.97]] &, locationsObjects], 
Partition[Append[Riffle[Flatten@Position[results, 0], 3], 3], 2] -> "Color" -> RGBColor[1, 0, 0]][[1 ;; u]], {u, 61}]

Finally, I can use the ServiceConnect to search images of the opponents with "BingSearch":

bs = ServiceConnect["BingSearch"];
opponentsImages = Map[ServiceExecute["BingSearch", "Search", {"Query" -> #, "SearchType" -> "Images", 
     "MaxItems" -> 1, "Elements" -> "Thumbnails"}] &, oponentsNames]

I want all the images to have the same height. I can achieve this with ImageResize:

opponentsIcons = Map[ImageResize[#[[1]], {Automatic, 147}] &, opponentsImages]

Finally, using Grids and different styles I can generate the original GIF on top of the post using Export:

Export["ali_career.gif", Table[Rasterize@Grid[{{Grid[{{Grid[{{Style["Muhammad Ali    " , 48, Italic, 
         FontFamily -> "Helvetica Neue"] }, {}, {},
       { Style["\"The Greatest\"    ", 48, Bold, 
         FontFamily -> "Helvetica Neue"]}}], ImageResize[Ali_Image,140], 
     Style["  VS  ", 38, Bold, FontFamily -> "Helvetica Neue"], 
     opponentsIcons[[u]], , 
     Style[opponentsNames[[u]], 28, Italic, FontFamily -> "Helvetica Neue"]}}, 
   Alignment -> Left, 
   ItemSize -> {{Automatic, Automatic, Automatic, 10, Automatic, 20}, {Automatic}}]}, {},
 {Grid[{{Grid[{
       {Style["Fight No.", 14, Bold, FontFamily -> "Helvetica Neue"], 
        Style[u, 15, Bold, FontFamily -> "Helvetica Neue"]},
       {Style["Date", 14, Bold, FontFamily -> "Helvetica Neue"], 
        Style[dates[[u]], 16, Bold, FontFamily -> "Helvetica Neue"]},
       {Style["Age", 14, Bold, FontFamily -> "Helvetica Neue"], 
        Style[DateDifference[birthDay, dateObjects[[u]], {"Year", "Month", "Day"}], 14, Bold, FontFamily -> "Helvetica Neue"]},
       {Style["Opponent", 14, Bold, FontFamily -> "Helvetica Neue"], 
        Grid[{{ImageResize[oponentsFlags[[u]], 40], 
           Style[oponentsNames[[u]], 14, Italic, FontFamily -> "Helvetica Neue"]}}]},
       {Style["Result", 14, Bold, FontFamily -> "Helvetica Neue"], resultsColored[[u]]},
       {Style["Type", 14, Bold, FontFamily -> "Helvetica Neue"], 
        Style[types[[u]], 14, FontFamily -> "Helvetica Neue"]},
       {Style["Location", 14, Bold, FontFamily -> "Helvetica Neue"], 
        Grid[{{ImageResize[flaglist[[u]], 40], 
           Style[locationsList[[u]], 14, Italic, FontFamily -> "Helvetica Neue"]}}]}},

      ItemSize -> {{Automatic, 15}, {Automatic, Automatic, Automatic, 4, Automatic, Automatic, 4}},
      Frame -> All,
      FrameStyle -> LightGray,
      Spacings -> {2, 1},
      Alignment -> Left,
      Background -> Lighter[Gray, 0.97]], ,

     DateListPlot[{Style[timeseries[[u]], RGBColor[0.09, 0.71, 0.21, 0.88]], 
      Style[timeseriesLosses[[u]], RGBColor[1, 0.24, 0]]},
      Joined -> False,
      FrameTicks -> {{Range[0, 60, 10], Automatic}, {Map[{#} &, Range[1960, 1982, 2]], Automatic}},
      FrameTicksStyle -> {{Directive[16], Automatic}, {Directive[16], Automatic}},
      Filling -> {1 -> {Axis, RGBColor[0.09, 0.71, 0.25, 0.78]}, 2 -> {Axis, RGBColor[1, 0.24, 0]}},
      DateTicksFormat -> {"Year"},
      PlotLabel -> Style["Victories over Time", 24],
      PlotTheme -> "Detailed",
      PlotLegends -> SwatchLegend[{Style["Victories", 18], Style["Losses", 18]}],
      PlotRange -> {{{1959}, {1983}}, {0, 60}},
      AspectRatio -> 1/2.2,
      ImageSize -> 600]}}]}, {},

 {GeoGraphics[{geomarkersColored[[u]], geomarkers[[u]]}, 
   ImageSize -> 1060, 
   GeoRange -> {{-60., 75.}, {-165., 155.}}]}}],
 {u, 1, 61}], "DisplayDurations" -> 1.1]
POSTED BY: Jofre Espigule-Pons
2 Replies
Sort By:

enter image description here - another post of yours has been selected for the Staff Picks group, congratulations !

We are happy to see you at the top of the "Featured Contributor" board. Thank you for your wonderful contributions, and please keep them coming!
POSTED BY: EDITORIAL BOARD

Great job! Very nice! I'm waiting for the Moderation Team to make this a staff pick...
POSTED BY: Sander Huisman
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Tag limit exceeded
Note: Only the first five people you tag will receive an email notification; the other tagged names will appear as links to their profiles.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract