knitr::opts_chunk$set(message = FALSE, warning = FALSE)This morning, I just found out about #tidytuesday and I figured it would be a fun thing to play with.
\nFor my first foray into tidytuesday, we have data on Bob Ross’s paintings during his show. The data were compiled by fivethirtyeight and reported here.
\nThe data are available here. On the info page for the data, they show how to load the data and give an example of some basic tidying. I’ll do that below:
\nlibrary(dplyr)\nlibrary(tidyr)\nlibrary(stringr)\n\nbob_ross <-\n readr::read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-08-06/bob-ross.csv")\n\n# to clean up the episode information\nbob_ross <-\n bob_ross %>%\n janitor::clean_names() %>%\n separate(episode, into = c("season", "episode"), sep = "E") %>%\n mutate(season = str_extract(season, "[:digit:]+")) %>%\n mutate_at(vars(season, episode), as.integer)\n\nhead(bob_ross)There are a couple of paintings that are named the same thing.
\nbob_ross <-\n bob_ross %>%\n group_by(title) %>%\n mutate(title_count = 1:group_size(.)) %>%\n ungroup() %>%\n mutate(title = if_else(title_count > 1,\n paste(title, title_count),\n title)) %>%\n select(-title_count)There are some columns that are relate to the frame the painting got put into and some columns that relate to elements inside each painting. Like the fivethirtyeight crew, I’m more interested in the elements inside the paintings as opposed to the frames, so i’ll go ahead and drop those columns
\npainting_data <-\n bob_ross %>%\n select(-contains("frame"), -steve_ross, -guest, -diane_andre)In my professional work, I perform social network analysis, so let’s go ahead and look at networks of elements in Bob Ross’s paintings!
\nTo get us looking at social networks, we first need to take the data from this wide format and turn it into an edge list. The edge list will connect each painting to every element that is inside it. From there, we can get a picture of what the network of paintings looks like!
\nlibrary(igraph)\nlibrary(ggnetwork)\n\ntitles <- painting_data[["title"]]\nincidence_mat <-\n painting_data %>%\n select(-season, -episode, -title)\n\nincidence_mat <- as.matrix(incidence_mat)\nrownames(incidence_mat) <- titles\n\nincidence_graph <-\n graph_from_incidence_matrix(incidence_mat, )\n\nggplot(incidence_graph, aes(x = x, y = y, xend = xend, yend = yend)) +\n geom_edges() +\n # type is TRUE if a node is an episode and FALSE if it's an element\n geom_nodes(aes(color = type)) +\n theme_blank()That’s real busy! It looks like there are a few episodes that only have a few elements and some episodes that have many elements in it. There’s also that one episode that shares three elements with another episode and no others.
\nLet’s see if we can clean this up a bit! First, i’ll connect episodes by how many elements they share.
\nepisode_x_episode <- incidence_mat %*% t(incidence_mat)\n\nep_x_ep_graph <-\n graph_from_adjacency_matrix(episode_x_episode,\n # only look at the upper part of the matrix since it is symetrical\n mode = "upper",\n # the connections are weighted\n weighted = TRUE,\n # don't count self-loops\n diag = FALSE)\n\nggnetwork(ep_x_ep_graph, weight = "weight") %>%\n ggplot(aes(x = x, y = y, xend = xend, yend = yend)) +\n geom_edges() +\n geom_nodes() +\n theme_blank()Not much to look at. Or better yet, Ross’s paintings tend to share something in common with other paintings.
\nInstead of looking at all the features at once, why don’t we look at groups of features. I’ve gone ahead and grouped each feature into different categories. I’ll load that up and then split up the painting df into different categories.
\nfeature_categories <-\n readr::read_csv("../../data/Bob Ross/ross_painting_features.csv")\n\npainting_categories <-\n painting_data %>%\n gather(feature, value, -season, -episode, -title) %>%\n left_join(feature_categories, by = "feature") %>%\n filter(value > 0) %>%\n count(season, episode, title, category) %>%\n spread(category, n) %>%\n mutate_at(vars(-season, -episode, -title), ~if_else(is.na(.), 0, 1))\n\ntitles <- painting_categories[["title"]]\n\n\nincidence_mat <-\n painting_categories %>%\n select(-season, -episode, -title) %>%\n as.matrix()\nrownames(incidence_mat) <- titles\n\nepisode_x_episode <- incidence_mat %*% t(incidence_mat)\n\n\nep_x_ep_graph <-\n graph_from_adjacency_matrix(\n episode_x_episode,\n # only look at the upper part of the matrix since it is symetrical\n mode = "upper",\n # the connections are weighted\n weighted = TRUE,\n # don't count self-loops\n diag = FALSE)\n\n# add in season as an attribute of each episode\nvertex_attr(ep_x_ep_graph, "season") <- painting_categories[["season"]]Now to plot! I’m going to build these plots with a cutpoint though, because otherwise they become very unweildy.
\nep_x_ep_graph %>%\n delete_edges(which(edge_attr(ep_x_ep_graph)$weight <= 2)) %>%\n delete_vertices(., which(igraph::degree(.) == 0)) %>% \n ggnetwork(weight = "weight") %>%\n ggplot(aes(x = x, y = y, xend = xend, yend = yend)) +\n geom_edges(color = "gray") +\n geom_nodes(aes(color = season)) +\n theme_blank() +\n Friedman::scale_color_drexel(discrete = FALSE) +\n labs(title = "Paintings that share 3, 4, or 5 feature categories")Above, I’ve colored nodes by season and only shown connections between episodes if those episodes share more than two classes of feature (e.g. two episodes have a sky feature, tree and plant feature, and a man-made feature).
\nWhat happens if we filter to only show edges if two espodes share 4 features? 5?
\nep_x_ep_graph %>%\n delete_edges(which(edge_attr(ep_x_ep_graph)$weight <= 3)) %>%\n delete_vertices(., which(igraph::degree(.) == 0)) %>% \n ggnetwork(weight = "weight") %>%\n ggplot(aes(x = x, y = y, xend = xend, yend = yend)) +\n geom_edges(color = "gray") +\n geom_nodes(aes(color = season)) +\n theme_blank() +\n Friedman::scale_color_drexel(discrete = FALSE) +\n labs(title = "Paintings that share 4 or 5 feature categories")Looking at the paintings that share more than 3 features really brings about that there is a central group of paintings that all share a lot in common and then a few different groups of paintings that all have different things in common.
\nep_x_ep_graph %>%\n delete_edges(which(edge_attr(ep_x_ep_graph)$weight <= 4)) %>%\n delete_vertices(., which(igraph::degree(.) == 0)) %>% \n ggnetwork(weight = "weight") %>%\n ggplot(aes(x = x, y = y, xend = xend, yend = yend)) +\n geom_edges(color = "gray") +\n geom_nodes(aes(color = season)) +\n theme_blank() +\n Friedman::scale_color_drexel(discrete = FALSE) +\n labs(title = "Paintings that share 5 feature categories")Now looking just at paintings that share 5 feature categories, it can really be seen that there is a central set of themes that is very common accross seasons. What are they?
\nepisodes_of_interest <-\n ep_x_ep_graph %>%\n delete_edges(which(edge_attr(ep_x_ep_graph)$weight <= 4)) %>%\n delete_vertices(., which(igraph::degree(.) == 0)) %>%\n vertex_attr("name")\n\npainting_categories %>%\n filter(title %in% episodes_of_interest) %>%\n mutate(feature_sum = aquatic + clouds + `general nature` +\n `man made` + nature + sky + `trees and plants`) %>%\n filter(feature_sum > 4) %>%\n summarize_at(vars(-season, -episode, -title, -feature_sum), sum)All (or near all) of these paintings have an aquatic element, a general nature element, and trees and plants. So the real defining factor between the three groups in the plot above probably has to do with the other four categories. Next time I play with these data, I’ll look at that and do a deeper dive on components of the network of Bob Ross paintings.
","fields":{"slug":"/posts/happy-little-accidents","tagSlugs":["/tag/tidytuesday/","/tag/r-4-ds/","/tag/five-thirty-eight/","/tag/dplyr/","/tag/tidyr/"]},"frontmatter":{"date":"2019-08-05","description":"Exploring Data on Bob Ross paintings for Tidy Tuesday.","tags":["tidytuesday","r4ds","five_thirty_eight","dplyr","tidyr"],"title":"Happy Little Accidents","socialImage":null}}},"pageContext":{"slug":"/posts/happy-little-accidents"}}}