Graph 1
Infographics
This infographic deals with comparing purchase intent rate between 2015 and 2016 and the associated percentage point chage over 2015 for the products listed. I did find the title to be good because it asks a question and does well on focusing on the purpose of the infographic. However, the actual percentage value is very hard to see. The donut doesn’t help. The percent change circle is totally confusing. They also used a negative scale to size the circles which requires mental hurdles to overcome. In order to improve the visual, I developed a diverging bar chart where the purchase intent rate for each product in 2015 is given to the left and for year 2016 to the right. Although the percent change is not provided, it is easier to scan down and left to right through each product and its associated purchase intent rate for comparing both years.
library(ggplot2)
library(tidyverse)## Loading tidyverse: tibble
## Loading tidyverse: tidyr
## Loading tidyverse: readr
## Loading tidyverse: purrr
## Loading tidyverse: dplyr## Conflicts with tidy packages ----------------------------------------------## filter(): dplyr, stats
## lag(): dplyr, statslibrary(scales)##
## Attaching package: 'scales'## The following object is masked from 'package:purrr':
##
## discard## The following object is masked from 'package:readr':
##
## col_factor# Data Prep
DATA <- read.csv("Technology Purchase Intent.csv", header = TRUE)
Tech2016 <- DATA %>%
filter(Year==2016) %>%
mutate(Purchase.Intent.Rate = extract_numeric(Purchase.Intent.Rate), Year = as.character(Year)) %>%
arrange(Purchase.Intent.Rate)## extract_numeric() is deprecated: please use readr::parse_number() insteadTech2015 <- DATA %>%
filter(Year == 2015) %>%
mutate(Purchase.Intent.Rate = extract_numeric(Purchase.Intent.Rate), Year = as.character(Year)) %>%
mutate(Purchase.Intent.Rate = -Purchase.Intent.Rate) %>%
arrange(Purchase.Intent.Rate)## extract_numeric() is deprecated: please use readr::parse_number() insteadTech <- bind_rows(Tech2016, Tech2015)
Tech$Product <- factor(Tech$Product, levels = Tech$Product)
attach(Tech)
# Diverging Barcharts
ggplot(Tech, aes(x=Product, y=Purchase.Intent.Rate, fill = Year)) +
geom_bar(stat='identity') +
geom_hline(yintercept = 0) +
labs(title = "Are Consumers Bored with Technology?",
subtitle = "% of consumers planning to purchase the following devices in 2016",
caption = "Source: Accenture") +
scale_fill_manual(name="Year",
labels = c("2015", "2016"),
values = c("2015"="yellow", "2016"="purple")) +
geom_text(data = filter(Tech, Year=="2015"), aes(label = Product), position = position_stack(vjust = 1), size = 2.8) +
geom_text(data = filter(Tech, Year=="2015"), aes(label = percent(abs(Purchase.Intent.Rate)/100)), size = 3, hjust=1) +
geom_text(data = filter(Tech, Year=="2016"), aes(label = percent(abs(Purchase.Intent.Rate)/100)), size = 3, hjust=0) +
theme_classic() +
theme_void() +
coord_flip() 
Graph 2
This last infographic looks at Stephen Curry’s shot selection through mid-way of the 2015 NBA season, which is meant to demonstate that Curry is not a big fan of taking mid-range jumpers. However, the original graph lacks the ability to call out those distances well enough, which are known as the “Dreaded-Twos” distances. Thus, the best solution would be to highlight what distances fall under this category as a way to accentuate on the point being made about Curry’s shot selection.
Infographics
DATA <- read.csv("NBA Savant - Stephen Curry Shots.csv", header = TRUE)
attach(DATA)
summary(DATA)## name team_name game_date
## Stephen Curry:666 Golden State Warriors:666 14/11/2015: 31
## 11/12/2015: 27
## 31/10/2015: 27
## 27/10/2015: 26
## 12/11/2015: 25
## 05/12/2015: 24
## (Other) :506
## season espn_player_id team_id espn_game_id
## Min. :2015 Min. :3975 Min. :1.611e+09 Min. :400827890
## 1st Qu.:2015 1st Qu.:3975 1st Qu.:1.611e+09 1st Qu.:400828007
## Median :2015 Median :3975 Median :1.611e+09 Median :400828101
## Mean :2015 Mean :3975 Mean :1.611e+09 Mean :400828132
## 3rd Qu.:2015 3rd Qu.:3975 3rd Qu.:1.611e+09 3rd Qu.:400828238
## Max. :2015 Max. :3975 Max. :1.611e+09 Max. :400828443
##
## period minutes_remaining seconds_remaining shot_made_flag
## Min. :1.000 Min. : 0.00 Min. : 0.00 Min. :0.0000
## 1st Qu.:1.000 1st Qu.: 1.25 1st Qu.:11.00 1st Qu.:0.0000
## Median :2.000 Median : 4.00 Median :27.00 Median :1.0000
## Mean :2.324 Mean : 4.27 Mean :27.03 Mean :0.5105
## 3rd Qu.:3.000 3rd Qu.: 7.00 3rd Qu.:43.00 3rd Qu.:1.0000
## Max. :5.000 Max. :11.00 Max. :59.00 Max. :1.0000
##
## action_type shot_type
## Jump Shot :324 2PT Field Goal:305
## Pullup Jump shot : 72 3PT Field Goal:361
## Step Back Jump shot : 39
## Layup Shot : 32
## Driving Finger Roll Layup Shot: 29
## Driving Layup Shot : 26
## (Other) :144
## shot_distance opponent x
## Min. : 0.000 Sacramento Kings : 62 Min. :-241.000
## 1st Qu.: 5.475 New Orleans Pelicans: 53 1st Qu.: -83.250
## Median :22.600 Brooklyn Nets : 48 Median : 4.000
## Mean :17.142 Toronto Raptors : 47 Mean : 2.428
## 3rd Qu.:25.100 Denver Nuggets : 44 3rd Qu.: 98.500
## Max. :46.900 Charlotte Hornets : 39 Max. : 240.000
## (Other) :373
## y dribbles touch_time defender_name
## Min. :-21.0 Min. : 0.000 Min. : 0.000 : 27
## 1st Qu.: 21.0 1st Qu.: 0.000 1st Qu.: 0.800 Walker, Kemba : 25
## Median :122.5 Median : 2.000 Median : 2.550 Rondo, Rajon : 24
## Mean :123.8 Mean : 3.444 Mean : 3.682 Jack, Jarrett : 21
## 3rd Qu.:214.0 3rd Qu.: 6.000 3rd Qu.: 5.575 Joseph, Cory : 17
## Max. :712.0 Max. :24.000 Max. :19.900 Bradley, Avery: 14
## (Other) :538
## defender_distance shot_clock
## Min. : 0.000 Min. : 0.00
## 1st Qu.: 2.500 1st Qu.:10.22
## Median : 3.900 Median :14.90
## Mean : 4.015 Mean :13.75
## 3rd Qu.: 5.300 3rd Qu.:18.40
## Max. :17.100 Max. :24.00
## for (i in 1:29){
if (i==1){
shot <- DATA %>%
filter(shot_distance < i) %>%
summarise(shot_attempts = sum(table(shot_distance < i)))
shot_i <- DATA %>%
filter(shot_distance > i, shot_distance < i+1) %>%
summarise(shot_attempts = sum(table(shot_distance > i & shot_distance < i+1)))
shot_attempts <- rbind(shot, shot_i)
}
else {
shot_i <- DATA %>%
filter(shot_distance > i, shot_distance < i+1) %>%
summarise(shot_attempts = sum(table(shot_distance > i & shot_distance < i+1)))
shot_attempts <- rbind(shot_attempts, shot_i)
}
}
shot_distance <- 0:29
shots <- cbind(shot_distance, shot_attempts)
p <- ggplot(data = shots,
aes(x = shot_distance,
y = shot_attempts))
p + geom_bar(stat = "identity") +
labs(title = "The NBA's greatest shooter hates mid-range jump shots",
caption = "Source: NBA Savant") +
xlab("Distance from basket (in feet)") +
ylab("Total shot attempts") +
scale_x_continuous(breaks = seq(0, 29, 1), expand = c(0.01,0)) +
scale_y_continuous(limits = c(0,90), breaks = seq(0, 90, 10), expand = c(0,0)) +
geom_text(aes(label = shot_attempts), size = 3, vjust=-0.5) +
annotate("rect", xmin=6.5, xmax=20.5, ymin=0, ymax=Inf, alpha=0.2, fill="red") +
annotate("text", x = 13.5, y = 70, label = "The Dreaded Twos", size = 5) +
annotate("text", x = 13.5, y = 65, label = "Stephen Curry makes just 42.5% of his shots in the 7-21ft range.", size = 2.5) +
annotate("text", x = 13.5, y = 62, label = "He hits 46% of these, for only 13% of his total score.", size = 2.5) +
theme_classic()