Message Boards Message Boards

Mister Rogers' Sweater Colors

GROUPS:

If you (like me) are both a data geek and a Fred-Rogers-raised child of the 70's, you probably caught Owen Phillips's nice piece of cardigan-centric data science yesterday — Every Color Of Cardigan Mister Rogers Wore From 1979–2001. He posted his R code for scraping and visualizing the data on GitHub, but I wanted to see if I could improve slightly on that dataset and post something that other Wolfram Language users could tinker with. With a little bit of experimentation, I found that I could generate a nice little dataset with two lines of code. First, a function that takes an episode number, finds the original air date (on Tim Lybarger's excellent neighborhoodarchive.com), and turns it into a DateObject:

epDate[ep_] := 
 Cases[Import[
    "http://www.neighborhoodarchive.com/mrn/episodes/" <> ep <> 
     "/index.html", "FullData"], {"Air Date", date_} :> 
    DateObject[date], Infinity][[1]]

And second, some code that scrapes episode numbers and approximate sweater colors out of a neighborhoodarchive.com blog post (archived by the Internet Archive), then uses the previous function to get an air date for each episode (and sweater):

sweats = Dataset[<|"EpisodeNumber" -> First@#, 
      "Date" -> epDate@First@#, 
      "SweaterColor" -> Last@#|> & /@ (Cases[
       Import["https://web.archive.org/web/20110525014454/http:\
//neighborhoodarchive.blogspot.com/2011/05/sweater-colors.html", 
        "XMLObject"], 
       XMLElement[
         "td", {"colspan" -> "1", "rowspan" -> "1", 
          "bgcolor" -> col__}, {XMLElement[
           "div", {"align" -> "center", 
            "class" -> "style8"}, {ep___}]}] :> 
        Rule[ep, RGBColor@col], Infinity] //. 
      XMLElement[_, _, {episode_}] :> episode)];

To save others the trouble of scraping and regenerating all this data, I went an extra step and submitted a new ResourceObject to the Wolfram Data Repository (Mister Rogers' Sweater Colors), so you can immediately grab it and start producing interesting visualizations and analyses...

Grid[With[{data = 
    Row[Sort[#]] & /@ 
     Normal[GroupBy[
        ResourceData[
         "Mister Rogers' Sweater Colors"], #Date["Year"] &][[All, All,
        "SweaterColor"]]]}, Transpose[{Keys[data], Values[data]}]], 
 Alignment -> {Left, Center}]

enter image description here

POSTED BY: Alan Joyce
Answer
7 months ago

Two more, since I just can't stop tinkering with this data:

LinearGradientImage across all individual sweater colors, in order:

ImageResize[
 LinearGradientImage[
  Normal@SortBy[ResourceData["Mister Rogers' Sweater Colors"], 
     "Date"][All, "SweaterColor"]], {800, 200}]

enter image description here

First blend all colors for each year, then apply LinearGradientImage to the blended colors:

ImageResize[
 LinearGradientImage[
  Normal@(Blend /@ 
     Values@GroupBy[
        ResourceData[
         "Mister Rogers' Sweater Colors"], #Date["Year"] &][[All, All,
         "SweaterColor"]])], {800, 200}]

enter image description here

POSTED BY: Alan Joyce
Answer
7 months ago

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

POSTED BY: Moderation Team
Answer
7 months ago

Group Abstract Group Abstract