socviz | Little World

Data Vis Chapter 8

Wed, 09 Oct 2019 00:00:00 +0000

head(asasec)

##                                Section         Sname Beginning Revenues
## 1      Aging and the Life Course (018)         Aging     12752    12104
## 2     Alcohol, Drugs and Tobacco (030) Alcohol/Drugs     11933     1144
## 3 Altruism and Social Solidarity (047)      Altruism      1139     1862
## 4            Animals and Society (042)       Animals       473      820
## 5             Asia/Asian America (024)          Asia      9056     2116
## 6            Body and Embodiment (048)          Body      3408     1618
##   Expenses Ending Journal Year Members
## 1    12007  12849      No 2005     598
## 2      400  12677      No 2005     301
## 3     1875   1126      No 2005      NA
## 4     1116    177      No 2005     209
## 5     1710   9462      No 2005     365
## 6     1920   3106      No 2005      NA

p <-
  ggplot(
    data = subset(asasec, Year == 2014),
    mapping = aes(x = Members,
                  y = Revenues, label = Sname)
  )

p + geom_point() + geom_smooth()

p <-
  ggplot(
    data = subset(asasec, Year == 2014),
    mapping = aes(x = Members,
                  y = Revenues, label = Sname)
  )

p + geom_point(mapping = aes(color = Journal)) + geom_smooth(method = "lm")

p0 <-
  ggplot(
    data = subset(asasec, Year == 2014),
    mapping = aes(x = Members,
                  y = Revenues, label = Sname)
  )

p1 <-
  p0 + geom_smooth(method = "lm", se = FALSE, color = "gray80") +
  geom_point(mapping = aes(color = Journal))
library(ggrepel)
p2 <- p1 + geom_text_repel(data = subset(asasec, Year == 2014 &
                                           Revenues > 7000),
                           size = 2)

p3 <- p2 + labs(
  x = "Membership",
  y = "Revenues",
  color = "Section has own Journal",
  title = "ASA Sections",
  subtitle = "2014 Calendar year.",
  caption = "Source: ASA annual report."
)
p4 <- p3 + scale_y_continuous(labels = scales::dollar) +
  theme(legend.position = "bottom")
p4

Use Color Palette

Use the RColorBrewer package. Access the colors by specifying the scale_color_brewer() or scale_ﬁll_brewer() functions, depending on the aesthetic you are mapping.

p <- ggplot(data = organdata,
            mapping = aes(x = roads, y = donors,
                          color = world))
p + geom_point(size = 2) + scale_color_brewer(palette = "Set2") +
  theme(legend.position = "top")

p + geom_point(size = 2) + scale_color_brewer(palette = "Pastel2") +
  theme(legend.position = "top")

p + geom_point(size = 2) + scale_color_brewer(palette = "Dark2") +
  theme(legend.position = "top")

Specify colors manually, via scale_color_manual() or scale_fill_manual(). Try demo('color') to see the color names in R.

cb_palette <-
  c(
    "#999999",
    "#E69F00",
    "#56B4E9",
    "#009E73",
    "#F0E442",
    "#0072B2",
    "#D55E00",
    "#CC79A7"
  )

p4 + scale_color_manual(values = cb_palette)

library(dichromat)
library(RColorBrewer)

Default <- brewer.pal(5, "Set2")

types <- c("deutan", "protan", "tritan")
names(types) <- c("Deuteronopia", "Protanopia", "Tritanopia")

color_table <- types %>% purrr::map(~ dichromat(Default, .x)) %>%
  as_tibble() %>% add_column(Default, .before = TRUE)

color_table

## # A tibble: 5 x 4
##   Default Deuteronopia Protanopia Tritanopia
##   <chr>   <chr>        <chr>      <chr>     
## 1 #66C2A5 #AEAEA7      #BABAA5    #82BDBD   
## 2 #FC8D62 #B6B661      #9E9E63    #F29494   
## 3 #8DA0CB #9C9CCB      #9E9ECB    #92ABAB   
## 4 #E78AC3 #ACACC1      #9898C3    #DA9C9C   
## 5 #A6D854 #CACA5E      #D3D355    #B6C8C8

Layer Color and Text Together

# Democrat Blue and Republican Red party_colors ← c("#2E74C0", "#CB454A")
p0 <- ggplot(
  data = subset(county_data, flipped == "No"),
  mapping = aes(x = pop, y = black / 100)
)
p1 <-
  p0 + geom_point(alpha = 0.15, color = "gray50") + scale_x_log10(labels =
                                                                    scales::comma)
p1

party_colors <- c("#2E74C0", "#CB454A")
p2 <- p1 + geom_point(
  data = subset(county_data, flipped == "Yes"),
  mapping = aes(x = pop, y = black / 100, color = partywinner16)
) +
  scale_color_manual(values = party_colors) 
p2

p3 <-
  p2 + scale_y_continuous(labels = scales::percent) + labs(
    color = "County flipped to ... ",
    x = "County Population (log scale)",
    y = "Percent Black Population",
    title = "Flipped counties, 2016",
    caption = "Counties in gray did not flip."
  )
p3

p4 <-
  p3 + geom_text_repel(
    data = subset(county_data, flipped == "Yes" & black > 25),
    mapping = aes(x = pop, y = black / 100, label = state),
    size = 2
  )
p4 + theme_minimal() + theme(legend.position = "top")

Themes

theme_set(theme_bw()) 
p4 + theme(legend.position = "top")

theme_set(theme_dark()) 
p4 + theme(legend.position = "top")

p4 + theme_gray()

library(ggthemes)
theme_set(theme_economist())
p4 + theme(legend.position = "top")

theme_set(theme_wsj())
p4 + theme(
  plot.title = element_text(size = rel(0.6)),
  legend.title = element_text(size = rel(0.35)),
  plot.caption = element_text(size = rel(0.35)),
  legend.position = "top"
)

Claus O. Wilke’s cowplot package, contains a well-developed theme suitable for figures whose final destination is a journal article. BobRudis’s hrbrthemes package, has a distinctive and compact look and feel that takes advantage of some freely available typefaces.

library(hrbrthemes)
theme_set(theme_ipsum())
p4 + theme(legend.position = "top")

p4 + theme(
  legend.position = "top",
  plot.title = element_text(
    size = rel(2),
    lineheight = .5,
    family = "Times",
    face = "bold.italic",
    colour = "orange"
  ),
  axis.text.x = element_text(
    size = rel(1.1),
    family = "Courier",
    face = "bold",
    color = "purple"
  )
)

Use Theme Elements

yrs <- c(seq(1972, 1988, 4), 1993, seq(1996, 2016, 4))
mean_age <-
  gss_lon %>% filter(age %nin% NA &&
                       year %in% yrs) %>% group_by(year) %>% summarize(xbar = round(mean(age, na.rm = TRUE), 0))
mean_age$y <- 0.3
yr_labs <- data.frame(x = 85, y = 0.8, year = yrs)

p <-
  ggplot(data = subset(gss_lon, year %in% yrs),
         mapping = aes(x = age))
p1 <-
  p + geom_density(
    fill = "gray20",
    color = FALSE,
    alpha = 0.9,
    mapping = aes(y = ..scaled..)
  ) +
  geom_vline(
    data = subset(mean_age, year %in% yrs),
    aes(xintercept = xbar),
    color = "white",
    size = 0.5
  ) +
  geom_text(
    data = subset(mean_age, year %in% yrs),
    aes(x = xbar, y = y, label = xbar),
    nudge_x = 7.5,
    color = "white",
    size = 3.5,
    hjust = 1
  ) +
  geom_text(data = subset(yr_labs, year %in% yrs), aes(x = x, y = y, label = year)) +
  facet_grid(year ~ ., switch = "y")

p1 + 
  theme(
    plot.title = element_text(size = 16),
    axis.text.x = element_text(size = 12),
    axis.title.y = element_blank(),
    axis.text.y = element_blank(),
    axis.ticks.y = element_blank(),
    strip.background = element_blank(),
    strip.text.y = element_blank(),
    panel.grid.major = element_blank(),
    panel.grid.minor = element_blank()
  ) +
  labs(x = "Age", y = NULL, title = "Age Distribution of\nGSS Respondents")

library(ggridges)
p <-
  ggplot(data = gss_lon, mapping = aes(x = age, y = factor(
    year, levels = rev(unique(year)), ordered = TRUE
  )))
p + geom_density_ridges(alpha = 0.6,
                        fill = "lightblue",
                        scale = 1.5) + scale_x_continuous(breaks = c(25, 50, 75)) + scale_y_discrete(expand = c(0.01, 0)) + labs(x = "Age", y = NULL, title = "Age Distribution of\nGSS Respondents") +
  theme_ridges() + theme(title = element_text(size = 16, face = "bold"))

Two y-axes

head(fredts)

##         date  sp500 monbase  sp500_i monbase_i
## 1 2009-03-11 696.68 1542228 100.0000  100.0000
## 2 2009-03-18 766.73 1693133 110.0548  109.7849
## 3 2009-03-25 799.10 1693133 114.7012  109.7849
## 4 2009-04-01 809.06 1733017 116.1308  112.3710
## 5 2009-04-08 830.61 1733017 119.2240  112.3710
## 6 2009-04-15 852.21 1789878 122.3245  116.0579

fredts_m <-
  fredts %>% select(date, sp500_i, monbase_i) %>% gather(key = series, value = score, sp500_i:monbase_i)
head(fredts_m)

##         date  series    score
## 1 2009-03-11 sp500_i 100.0000
## 2 2009-03-18 sp500_i 110.0548
## 3 2009-03-25 sp500_i 114.7012
## 4 2009-04-01 sp500_i 116.1308
## 5 2009-04-08 sp500_i 119.2240
## 6 2009-04-15 sp500_i 122.3245

p <-
  ggplot(data = fredts_m,
         mapping = aes(
           x = date,
           y = score,
           group = series,
           color = series
         ))
p1 <-
  p + geom_line() + theme(legend.position = "top") + labs(x = "Date", y = "Index", color = "Series")
p <-
  ggplot(data = fredts,
         mapping = aes(x = date, y = sp500_i - monbase_i))
p2 <- p + geom_line() + labs(x = "Date", y = "Difference")

cowplot::plot_grid(p1, p2, nrow = 2, rel_heights = c(0.75, 0.25), align = "v")

Using two y-axes gives you an extra degree of freedom to mess about with the data that, in most cases, you really should not take advantage of.

p <- ggplot(data = yahoo, mapping = aes(x = Employees, y = Revenue))
p + geom_path(color = "gray80") + geom_text(aes(color = Mayer, label = Year),
                                            size = 3,
                                            fontface = "bold") +
  theme(legend.position = "bottom") + labs(
    color = "Mayer is CEO",
    x = "Employees",
    y = "Revenue (Millions)",
    title = "Yahoo Employees vs Revenues, 2004-2014"
  ) + scale_y_continuous(labels = scales::dollar) + scale_x_continuous(labels = scales::comma)

p <-
  ggplot(data = yahoo,
         mapping = aes(x = Year, y = Revenue / Employees))
p + geom_vline(xintercept = 2012) + geom_line(color = "gray60", size = 2) + annotate(
  "text",
  x = 2013,
  y = 0.44,
  label = " Mayer becomes CEO",
  size = 2.5
) +
  labs(x = "Year\n", y = "Revenue/Employees", title = "Yahoo Revenue to Employee Ratio, 2004-2014")

Saying no to pie

p_xlab <-
  "Amount Owed, in thousands of Dollars" 
p_title <- "Outstanding Student Loans" 
p_subtitle <- "44 million borrowers owe a total of $1.3 trillion" 
p_caption <- "Source: FRB NY"
f_labs <-
  c(`Borrowers` = "Percent of\nall Borrowers", `Balances` = "Percent of\nall Balances")
p <-
  ggplot(data = studebt,
         mapping = aes(x = Debt, y = pct / 100, fill = type))
p + geom_bar(stat = "identity") + scale_fill_brewer(type = "qual", palette = "Dark2") + scale_y_continuous(labels = scales::percent) + guides(fill = FALSE) + theme(strip.text.x = element_text(face = "bold")) + labs(
  y = NULL,
  x = p_xlab,
  caption = p_caption,
  title = p_title,
  subtitle = p_subtitle
) + facet_grid( ~ type, labeller = as_labeller(f_labs)) + coord_flip()

library(viridis)
p <-
  ggplot(studebt, aes(y = pct / 100, x = type, fill = Debtrc)) 
p + geom_bar(stat = "identity", color = "gray80") + scale_x_discrete(labels = as_labeller(f_labs)) + scale_y_continuous(labels = scales::percent) + scale_fill_viridis(discrete = TRUE) + guides(
    fill = guide_legend(
      reverse = TRUE,
      title.position = "top",
      label.position = "bottom",
      keywidth = 3,
      nrow = 1
    )
  ) +
  labs(
    x = NULL,
    y = NULL,
    fill = "Amount Owed, in thousands of dollars",
    caption = p_caption,
    title = p_title,
    subtitle = p_subtitle
  ) +
  theme(
    legend.position = "top",
    axis.text.y = element_text(face = "bold", hjust = 1, size = 12),
    axis.ticks.length = unit(0, "cm"),
    panel.grid.major.y = element_blank()
  ) +
  coord_flip()

http://r-graph-gallery.com/ for more examples

Data Vis Chapter 6

Thu, 26 Sep 2019 00:00:00 +0000

p <-  ggplot(data = gapminder,
             mapping = aes(x = log(gdpPercap), y = lifeExp))

p + geom_point(alpha = 0.1) +
  geom_smooth(color = "tomato",
              fill = "tomato",
              method = MASS::rlm) + #robust regression line
  geom_smooth(color = "steelblue",
              fill = "steelblue",
              method = "lm")

p + geom_point(alpha = 0.1) +
  geom_smooth(
    color = "tomato",
    method = "lm",
    size = 1.2,
    formula = y ~ splines::bs(x, 3),
    se = FALSE
  )

p + geom_point(alpha = 0.1) +
  geom_quantile( # specialized version of geom)smooth that can fit quantile regression
    color = "tomato",
    size = 1.2,
    method = "rqss",
    lambda = 1,
    quantiles = c(0.20, 0.5, 0.85)
  )

## Smoothing formula not specified. Using: y ~ qss(x, lambda = 1)

Show Several Fits at Once, with a Legend

model_colors <- RColorBrewer::brewer.pal(3, "Set1")
model_colors

## [1] "#E41A1C" "#377EB8" "#4DAF4A"

p0 <- ggplot(data = gapminder,
             mapping = aes(x = log(gdpPercap), y = lifeExp))

p1 <- p0 + geom_point(alpha = 0.2) +
  geom_smooth(method = "lm", aes(color = "OLS", fill = "OLS")) +
  geom_smooth(
    method = "lm",
    formula = y ~ splines::bs(x, df = 3),
    aes(color = "Cubic Spline", fill = "Cubic Spline")
  ) +
  geom_smooth(method = "loess",
              aes(color = "LOESS", fill = "LOESS"))

p1 + scale_color_manual(name = "Models", values = model_colors) +
  scale_fill_manual(name = "Models", values = model_colors) +
  theme(legend.position = "top")

Model-based Graphics

min_gdp <- min(gapminder$gdpPercap)
max_gdp <- max(gapminder$gdpPercap)
med_pop <- median(gapminder$pop)

pred_df <- expand.grid(gdpPercap = (seq(from = min_gdp, to = max_gdp,
length.out = 100)), pop = med_pop, continent = c("Africa",
"Americas", "Asia", "Europe", "Oceania"))

dim(pred_df)

## [1] 500   3

out <- lm(formula = lifeExp ~ gdpPercap + pop + continent, data = gapminder)

pred_out <- predict(object = out, newdata = pred_df, interval = "predict")
pred_df <- cbind(pred_df, pred_out)

p <-
  ggplot(
    data = subset(pred_df, continent %in% c("Europe", "Africa")),
    aes(
      x = gdpPercap,
      y = fit,
      ymin = lwr,
      ymax = upr,
      color = continent,
      fill = continent,
      group = continent
    )
  )

p + geom_point(
  data = subset(gapminder,
                continent %in% c("Europe", "Africa")),
  aes(x = gdpPercap, y = lifeExp,
      color = continent),
  alpha = 0.5,
  inherit.aes = FALSE
) +
  geom_line() +
  geom_ribbon(alpha = 0.2, color = FALSE) +
  scale_x_log10(labels = scales::dollar)

Tidy Model Objects with Broom

get component-level statistics with tidy()

library(broom)
out_comp <- tidy(out)
out_comp %>% round_df()

## # A tibble: 7 x 5
##   term              estimate std.error statistic p.value
##   <chr>                <dbl>     <dbl>     <dbl>   <dbl>
## 1 (Intercept)          47.8      0.34     141.         0
## 2 gdpPercap             0        0         19.2        0
## 3 pop                   0        0          3.33       0
## 4 continentAmericas    13.5      0.6       22.5        0
## 5 continentAsia         8.19     0.570     14.3        0
## 6 continentEurope      17.5      0.62      28.0        0
## 7 continentOceania     18.1      1.78      10.2        0

“not in” %nin% is availabe via socviz. prefix_strip from socviz drops prefixes

#confidence interval
out_conf <- tidy(out, conf.int = TRUE)
out_conf <- subset(out_conf, term %nin% "(Intercept)")
out_conf$nicelabs <- prefix_strip(out_conf$term, "continent")

p <- ggplot(out_conf,
            mapping = aes(
              x = reorder(nicelabs, estimate),
              y = estimate,
              ymin = conf.low,
              ymax = conf.high
            ))
p + geom_pointrange() + coord_flip() + labs(x = "", y = "OLS Estimate")

Get observation-level statistics with augment()

out_aug <- augment(out)
p <- ggplot(data = out_aug, mapping = aes(x = .fitted, y = .resid))
p + geom_point()

### Get model-level statistics with glance() Broom is able to tidy (and augment, and glance at) a wide range of model types.

library(survival)

out_cph <- coxph(Surv(time, status) ~ age + sex, data = lung)
out_surv <- survfit(out_cph)
out_tidy <- tidy(out_surv)
p <- ggplot(data = out_tidy, mapping = aes(time, estimate))
p + geom_line() + geom_ribbon(mapping = aes(ymin = conf.low,
                                            ymax = conf.high),
                              alpha = 0.2)

Grouped Analysis

nest and unnest

out_le <- gapminder %>%
  group_by(continent, year) %>%
  nest()

fit_ols <- function(df) {
  lm(lifeExp ~ log(gdpPercap), data = df)
}

out_le <- gapminder %>%
  group_by(continent, year) %>%
  nest() %>%
  mutate(model = map(data, fit_ols))



out_tidy <- gapminder %>%
  group_by(continent, year) %>%
  nest() %>%
  mutate(model = map(data, fit_ols),
         tidied = map(model, tidy)) %>%
  unnest(tidied, .drop = TRUE) %>%
  filter(term %nin% "(Intercept)" &
           continent %nin% "Oceania")

## Warning: The `.drop` argument of `unnest()` is deprecated as of tidyr 1.0.0.
## All list-columns are now preserved.
## This warning is displayed once per session.
## Call `lifecycle::last_warnings()` to see where this warning was generated.

p <- ggplot(
  data = out_tidy,
  mapping = aes(
    x = year,
    y = estimate,
    ymin = estimate - 2 * std.error,
    ymax = estimate + 2 * std.error,
    group = continent,
    color = continent
  )
)

p + geom_pointrange(position = position_dodge(width = 1)) +
  scale_x_continuous(breaks = unique(gapminder$year)) +
  theme(legend.position = "top") +
  labs(x = "Year", y = "Estimate", color = "Continent")

## Plot Marginal Effects

library(margins)
gss_sm$polviews_m <- relevel(gss_sm$polviews, ref = "Moderate")
out_bo <- glm(obama ~ polviews_m + sex * race,
              family = "binomial",
              data = gss_sm)
summary(out_bo)

## 
## Call:
## glm(formula = obama ~ polviews_m + sex * race, family = "binomial", 
##     data = gss_sm)
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -2.9045  -0.5541   0.1772   0.5418   2.2437  
## 
## Coefficients:
##                                   Estimate Std. Error z value Pr(>|z|)    
## (Intercept)                       0.296493   0.134091   2.211  0.02703 *  
## polviews_mExtremely Liberal       2.372950   0.525045   4.520 6.20e-06 ***
## polviews_mLiberal                 2.600031   0.356666   7.290 3.10e-13 ***
## polviews_mSlightly Liberal        1.293172   0.248435   5.205 1.94e-07 ***
## polviews_mSlightly Conservative  -1.355277   0.181291  -7.476 7.68e-14 ***
## polviews_mConservative           -2.347463   0.200384 -11.715  < 2e-16 ***
## polviews_mExtremely Conservative -2.727384   0.387210  -7.044 1.87e-12 ***
## sexFemale                         0.254866   0.145370   1.753  0.07956 .  
## raceBlack                         3.849526   0.501319   7.679 1.61e-14 ***
## raceOther                        -0.002143   0.435763  -0.005  0.99608    
## sexFemale:raceBlack              -0.197506   0.660066  -0.299  0.76477    
## sexFemale:raceOther               1.574829   0.587657   2.680  0.00737 ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 2247.9  on 1697  degrees of freedom
## Residual deviance: 1345.9  on 1686  degrees of freedom
##   (1169 observations deleted due to missingness)
## AIC: 1369.9
## 
## Number of Fisher Scoring iterations: 6

bo_m <- margins(out_bo)
summary(bo_m)

##                            factor     AME     SE        z      p   lower
##            polviews_mConservative -0.4119 0.0283 -14.5394 0.0000 -0.4674
##  polviews_mExtremely Conservative -0.4538 0.0420 -10.7971 0.0000 -0.5361
##       polviews_mExtremely Liberal  0.2681 0.0295   9.0996 0.0000  0.2103
##                 polviews_mLiberal  0.2768 0.0229  12.0736 0.0000  0.2319
##   polviews_mSlightly Conservative -0.2658 0.0330  -8.0596 0.0000 -0.3304
##        polviews_mSlightly Liberal  0.1933 0.0303   6.3896 0.0000  0.1340
##                         raceBlack  0.4032 0.0173  23.3568 0.0000  0.3694
##                         raceOther  0.1247 0.0386   3.2297 0.0012  0.0490
##                         sexFemale  0.0443 0.0177   2.5073 0.0122  0.0097
##    upper
##  -0.3564
##  -0.3714
##   0.3258
##   0.3218
##  -0.2011
##   0.2526
##   0.4371
##   0.2005
##   0.0789

The margins library comes with several plot methods of its own. If you wish, at this point you can just try plot(bo_m) to see a plot of the average marginal effects, produced with the general look of a Stata graphic. Other plot methods in the margins library include cplot(), which visualizes marginal effects conditional on a second variable, and image(), which shows predictions or marginal effects as a filled heatmap or contour plot.

bo_gg <- as_tibble(summary(bo_m))
prefixes <- c("polviews_m", "sex")
bo_gg$factor <- prefix_strip(bo_gg$factor, prefixes)
bo_gg$factor <- prefix_replace(bo_gg$factor, "race", "Race: ")

bo_gg %>% select(factor, AME, lower, upper)

## # A tibble: 9 x 4
##   factor                     AME    lower   upper
##   <chr>                    <dbl>    <dbl>   <dbl>
## 1 Conservative           -0.412  -0.467   -0.356 
## 2 Extremely Conservative -0.454  -0.536   -0.371 
## 3 Extremely Liberal       0.268   0.210    0.326 
## 4 Liberal                 0.277   0.232    0.322 
## 5 Slightly Conservative  -0.266  -0.330   -0.201 
## 6 Slightly Liberal        0.193   0.134    0.253 
## 7 Race: Black             0.403   0.369    0.437 
## 8 Race: Other             0.125   0.0490   0.200 
## 9 Female                  0.0443  0.00967  0.0789

p <- ggplot(data = bo_gg, aes(
  x = reorder(factor, AME),
  y = AME,
  ymin = lower,
  ymax = upper
))

p + geom_hline(yintercept = 0, color = "gray80") +
  geom_pointrange() + coord_flip() +
  labs(x = NULL, y = "Average Marginal Effect")

pv_cp <- cplot(out_bo, x = "sex", draw = FALSE)

##    xvals     yvals     upper     lower
## 1   Male 0.5735849 0.6378653 0.5093045
## 2 Female 0.6344507 0.6887845 0.5801169

p <- ggplot(data = pv_cp, aes(
  x = reorder(xvals, yvals),
  y = yvals,
  ymin = lower,
  ymax = upper
))

p + geom_hline(yintercept = 0, color = "gray80") +
  geom_pointrange() + coord_flip() +
  labs(x = NULL, y = "Conditional Effect")

Plots for Surveys

library(survey)

## Loading required package: grid

## Loading required package: Matrix

## 
## Attaching package: 'Matrix'

## The following objects are masked from 'package:tidyr':
## 
##     expand, pack, unpack

## 
## Attaching package: 'survey'

## The following object is masked from 'package:graphics':
## 
##     dotchart

library(srvyr)

## 
## Attaching package: 'srvyr'

## The following object is masked from 'package:stats':
## 
##     filter

options(survey.lonely.psu = "adjust")
options(na.action = "na.pass")

gss_wt <- subset(gss_lon, year > 1974) %>%
  mutate(stratvar = interaction(year, vstrat)) %>%
  as_survey_design(
    ids = vpsu,
    strata = stratvar,
    weights = wtssall,
    nest = TRUE
  )

out_grp <- gss_wt %>%
  filter(year %in% seq(1976, 2016, by = 4)) %>%
  group_by(year, race, degree) %>%
  summarize(prop = survey_mean(na.rm = TRUE)) # calculate  properly weighted survey means

## Warning: Factor `degree` contains implicit NA, consider using
## `forcats::fct_explicit_na`

out_mrg <- gss_wt %>%
  filter(year %in% seq(1976, 2016, by = 4)) %>%
  mutate(racedeg = interaction(race, degree)) %>%
  group_by(year, racedeg) %>%
  summarize(prop = survey_mean(na.rm = TRUE))

## Warning: Factor `racedeg` contains implicit NA, consider using
## `forcats::fct_explicit_na`

out_mrg <- gss_wt %>%  filter(year %in% seq(1976, 2016, by = 4)) %>%
  mutate(racedeg = interaction(race, degree)) %>% group_by(year,
                                                           racedeg) %>% 
  summarize(prop = survey_mean(na.rm = TRUE)) %>%
  separate(racedeg, sep = "\\.", into = c("race", "degree"))

## Warning: Factor `racedeg` contains implicit NA, consider using
## `forcats::fct_explicit_na`

p <- ggplot(
  data = subset(out_grp, race %nin% "Other"),
  mapping = aes(
    x = degree,
    y = prop,
    ymin = prop - 2 * prop_se,
    ymax = prop + 2 * prop_se,
    fill = race,
    color = race,
    group = race
  )
)

dodge <- position_dodge(width = 0.9)

p + geom_col(position = dodge, alpha = 0.2) +
  geom_errorbar(position = dodge, width = 0.2) +
  scale_x_discrete(labels = scales::wrap_format(10)) +
  scale_y_continuous(labels = scales::percent) +
  scale_color_brewer(type = "qual", palette = "Dark2") +
  scale_fill_brewer(type = "qual", palette = "Dark2") +
  labs(
    title = "Educational Attainment by Race",
    subtitle = "GSS 1976-2016",
    fill = "Race",
    color = "Race",
    x = NULL,
    y = "Percent"
  ) +
  facet_wrap( ~ year, ncol = 2) +
  theme(legend.position = "top")

## Warning: Removed 13 rows containing missing values (geom_col).

## Warning: Removed 13 rows containing missing values (geom_errorbar).

p <- ggplot(
  data = subset(out_grp, race %nin% "Other"),
  mapping = aes(
    x = year,
    y = prop,
    ymin = prop - 2 * prop_se,
    ymax = prop + 2 * prop_se,
    fill = race,
    color = race,
    group = race
  )
)

p + geom_ribbon(alpha = 0.3, aes(color = NULL)) + #Use ribbon to show the error range
  geom_line() + #Use line to show a time trend
  facet_wrap( ~ degree, ncol = 1) +
  scale_y_continuous(labels = scales::percent) +
  scale_color_brewer(type = "qual", palette = "Dark2") +
  scale_fill_brewer(type = "qual", palette = "Dark2") +
  labs(
    title = "Educational Attainment by Race",
    subtitle = "GSS 1976-2016",
    fill = "Race",
    color = "Race",
    x = NULL,
    y = "Percent"
  ) +
  theme(legend.position = "top")

## Warning: Removed 13 rows containing missing values (geom_path).

Other useful packages: infer, ggally

Data Visualization Chapter 2-4

Thu, 26 Sep 2019 00:00:00 +0000

Chapter 2

geom_point

p <- ggplot(data = gapminder,
            mapping = aes(x = gdpPercap, y = lifeExp))
p + geom_point()

Chapter 3

geom_smooth

## `geom_smooth()` using method = 'gam' and formula 'y ~ s(x, bs = "cs")'

p <- ggplot(data = gapminder, mapping = aes(x = gdpPercap, y = lifeExp))
p + geom_point() + geom_smooth()

## `geom_smooth()` using method = 'gam' and formula 'y ~ s(x, bs = "cs")'

scale_x_log10

p <- ggplot(data = gapminder, mapping = aes(x = gdpPercap, y = lifeExp))
p + geom_point() + geom_smooth(method = "gam") + scale_x_log10()

scales::dollar

p <- ggplot(data = gapminder, mapping = aes(x = gdpPercap, y = lifeExp))
p + geom_point() +
geom_smooth(method = "gam") +
scale_x_log10(labels = scales::dollar)

Wrong way to set color

p <- ggplot(data = gapminder, mapping = aes(x = gdpPercap, y = lifeExp,
color = "purple"))
p + geom_point() + geom_smooth(method = "loess") + scale_x_log10()

The aes() function is for mappings only. Do not use it to change properties to a particular value. If we want to set a property, we do it in the geom_ we are using, and outside the mapping =aes(...)step.

p <- ggplot(data = gapminder, mapping = aes(x = gdpPercap, y = lifeExp))
p + geom_point(color = "purple") + geom_smooth(method = "loess") + scale_x_log10()

The various geom_ functions can take many other arguments that will affect how the plot looks but do not involve mapping variables to aesthetic elements. “alpha” is an aesthetic property that points (and some other plot elements) have, and to which variables can be mapped. It controls how transparent the object will appear when drawn. It’s measured on a scale of zero to one.

p <- ggplot(data = gapminder, mapping = aes(x = gdpPercap, y = lifeExp))
p + geom_point(alpha = 0.3) + geom_smooth(color = "orange", se = FALSE,
                                          size = 8, method = "lm") + scale_x_log10()

p <- ggplot(data = gapminder, mapping = aes(x = gdpPercap, y=lifeExp))
p + geom_point(alpha = 0.3) +
  geom_smooth(method = "gam") +
  scale_x_log10(labels = scales::dollar) +
  labs(x = "GDP Per Capita", y = "Life Expectancy in Years",
       title = "Economic Growth and Life Expectancy",
       subtitle = "Data points are country-years",
       caption = "Source: Gapminder.")

p <- ggplot(data = gapminder, mapping = aes(x = gdpPercap, y = lifeExp,
                                            color = continent))
p + geom_point() + geom_smooth(method = "loess") + scale_x_log10()

The color of the standard error ribbon is controlled by the fill aesthetic.

p <- ggplot(data = gapminder, mapping = aes(x = gdpPercap, y = lifeExp,
                                            color = continent, fill = continent))
p + geom_point() + geom_smooth(method = "loess") + scale_x_log10()

Aesthetics Can Be Mapped per Geom

p <- ggplot(data = gapminder, mapping = aes(x = gdpPercap, y = lifeExp))
p + geom_point(mapping = aes(color = factor(year))) + 
  geom_smooth(method = "loess") +
  scale_x_log10()

Order doesn’t matter!!! Besides scale_x_log10(), you can try scale_x_sqrt() and scale_x_reverse()

p <- ggplot(data = gapminder, mapping = aes(x = pop, y = lifeExp))
p + geom_smooth(method = "loess") + 
  geom_point(mapping = aes(color = continent)) + 
  scale_x_reverse(labels = scales::number)

p <- ggplot(data = gapminder, mapping = aes(x = gdpPercap, y = lifeExp))
p + geom_point(mapping = aes(color = log(pop))) + scale_x_log10()

Save plots

p_out <-  p + geom_point() + geom_smooth(method = "loess") + scale_x_log10()
ggsave("my_figure.pdf", plot = p_out)

Chapter 4

Group data and the “Group” Aesthetic

p <- ggplot(data = gapminder, mapping = aes(x = year, y = gdpPercap))
p + geom_line()

use the group aesthetic to tell ggplot explicitly about this country-level structure

p <- ggplot(data = gapminder, mapping = aes(x = year, y = gdpPercap))
p + geom_line(aes(group = country))

Facet to make small multiples

use facet_wrap() to split our plot by continent.

p <- ggplot(data = gapminder, mapping = aes(x = year, y = gdpPercap))
p + geom_line(aes(group = country)) + facet_wrap(~continent)

Add another enhancements

p <- ggplot(data = gapminder, mapping = aes(x = year, y = gdpPercap))
p + geom_line(color="gray70", aes(group = country)) + 
  geom_smooth(size= 1.1, method = "loess", se = FALSE) +
  scale_y_log10(labels=scales::dollar) +
  facet_wrap(~continent , ncol = 5) +
  labs(x = "Year",
       y = "GDP per capita on Five Continents")

Use facet_grid

p <- ggplot(data = gss_sm, mapping = aes(x = age, y = childs))
p + geom_point(alpha = 0.2) +
  geom_smooth() + 
  facet_grid(sex ~ race)

## `geom_smooth()` using method = 'gam' and formula 'y ~ s(x, bs = "cs")'

## Warning: Removed 18 rows containing non-finite values (stat_smooth).

## Warning: Removed 18 rows containing missing values (geom_point).

p <- ggplot(data = gss_sm, mapping = aes(x = age, y = childs))
p + geom_point(alpha = 0.2) +
  geom_smooth() + 
  facet_grid(sex ~ race + degree)

## `geom_smooth()` using method = 'loess' and formula 'y ~ x'

## Warning: Removed 18 rows containing non-finite values (stat_smooth).

## Warning in simpleLoess(y, x, w, span, degree = degree, parametric =
## parametric, : span too small. fewer data values than degrees of freedom.

## Warning in simpleLoess(y, x, w, span, degree = degree, parametric =
## parametric, : pseudoinverse used at 62.87

## Warning in simpleLoess(y, x, w, span, degree = degree, parametric =
## parametric, : neighborhood radius 2.13

## Warning in simpleLoess(y, x, w, span, degree = degree, parametric =
## parametric, : reciprocal condition number 0

## Warning in simpleLoess(y, x, w, span, degree = degree, parametric =
## parametric, : There are other near singularities as well. 582.26

## Warning in predLoess(object$y, object$x, newx = if
## (is.null(newdata)) object$x else if (is.data.frame(newdata))
## as.matrix(model.frame(delete.response(terms(object)), : span too small.
## fewer data values than degrees of freedom.

## Warning in predLoess(object$y, object$x, newx = if
## (is.null(newdata)) object$x else if (is.data.frame(newdata))
## as.matrix(model.frame(delete.response(terms(object)), : pseudoinverse used
## at 62.87

## Warning in predLoess(object$y, object$x, newx = if
## (is.null(newdata)) object$x else if (is.data.frame(newdata))
## as.matrix(model.frame(delete.response(terms(object)), : neighborhood radius
## 2.13

## Warning in predLoess(object$y, object$x, newx = if
## (is.null(newdata)) object$x else if (is.data.frame(newdata))
## as.matrix(model.frame(delete.response(terms(object)), : reciprocal
## condition number 0

## Warning in predLoess(object$y, object$x, newx = if
## (is.null(newdata)) object$x else if (is.data.frame(newdata))
## as.matrix(model.frame(delete.response(terms(object)), : There are other
## near singularities as well. 582.26

## Warning: Removed 18 rows containing missing values (geom_point).

Geoms can transform data

p <- ggplot(data = gss_sm, mapping = aes(x = bigregion))
p + geom_bar()

geom_bar called the default stat_ function associated with it,stat_count().

p <- ggplot(data = gss_sm, mapping = aes(x = bigregion))
p + geom_bar(mapping = aes(y = ..prop..))

p <- ggplot(data = gss_sm, mapping = aes(x = bigregion))
p + geom_bar(mapping = aes(y = ..prop.., group = 1))

table(gss_sm$religion)

## 
## Protestant   Catholic     Jewish       None      Other 
##       1371        649         51        619        159

p <- ggplot(data = gss_sm, mapping = aes(x = religion, color = religion))
p + geom_bar()

p <- ggplot(data = gss_sm, mapping = aes(x = religion, fill = religion))
p + geom_bar() + guides(fill = FALSE)

p + geom_bar()

p <- ggplot(data = gss_sm, mapping = aes(x = bigregion, fill = religion))
p + geom_bar()

p <- ggplot(data = gss_sm, mapping = aes(x = bigregion, fill = religion))
p + geom_bar(position = "fill")

if you want separate bars

p <- ggplot(data = gss_sm, mapping = aes(x = bigregion, fill = religion))
p + geom_bar(position = "dodge", mapping = aes(y = ..prop..,
                                               group = religion))

However, they don’t sum to one within each region. They sum to one across regions.

p <- ggplot(data = gss_sm, mapping = aes(x = religion))
p + geom_bar(position = "dodge", mapping = aes(y = ..prop..,
                                               group = bigregion)) +
  facet_wrap(~bigregion, ncol=1)

Histgrams and Density Plots

p <- ggplot(data = midwest, mapping = aes( x = area))
p + geom_histogram()

## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.

p <- ggplot(data = midwest, mapping = aes( x = area))
p + geom_histogram(bins = 10)

oh_wi <- c("OH", "WI")
p <- ggplot(data = subset(midwest, subset = state %in% oh_wi),
            mapping = aes(x = percollege, fill = state))
p + geom_histogram(alpha = 0.4, bins = 20)

p <- ggplot(data = midwest, mapping = aes( x = area))
p + geom_density()

p <- ggplot(data = midwest, mapping = aes( x = area, fill = state,
                                           color = state))
p + geom_density(alpha = 0.3)

Avoid Transformations When Necessary

p <- ggplot(data = titanic, mapping = aes(x = fate, y = percent,
                                          fill = sex))
p + geom_bar(position = "dodge", stat = "identity") + theme(legend.position = "top")

p <- ggplot(data = oecd_sum,
            mapping = aes(x = year, y = diff, fill = hi_lo))
p + geom_col() + guides(fill = FALSE) + 
  labs(x = NULL, y = "Difference in Years",
       title = "The US Life Expectancy Gap",
       subtitle = "Difference between US and OECD 
       average life expectancies, 1960-2015",
       caption = "Data: OECD. After a chart by Christopher Ingraham,
       Washington Post, December 27th 2017.")

## Warning: Removed 1 rows containing missing values (position_stack).

Data Visualization Chapter 5

Thu, 26 Sep 2019 00:00:00 +0000

Chapter 5

Use Pipes to Summerize Data

rel_by_region <- gss_sm %>%
  group_by(bigregion, religion) %>%
  summarize(N = n()) %>%
  mutate(freq = N / sum(N),
         pct = round((freq*100), 0))

## Warning: Factor `religion` contains implicit NA, consider using
## `forcats::fct_explicit_na`

rel_by_region

## # A tibble: 24 x 5
## # Groups:   bigregion [4]
##    bigregion religion       N    freq   pct
##    <fct>     <fct>      <int>   <dbl> <dbl>
##  1 Northeast Protestant   158 0.324      32
##  2 Northeast Catholic     162 0.332      33
##  3 Northeast Jewish        27 0.0553      6
##  4 Northeast None         112 0.230      23
##  5 Northeast Other         28 0.0574      6
##  6 Northeast <NA>           1 0.00205     0
##  7 Midwest   Protestant   325 0.468      47
##  8 Midwest   Catholic     172 0.247      25
##  9 Midwest   Jewish         3 0.00432     0
## 10 Midwest   None         157 0.226      23
## # … with 14 more rows

rel_by_region %>% group_by(bigregion) %>% summarize(total = sum(pct))

## # A tibble: 4 x 2
##   bigregion total
##   <fct>     <dbl>
## 1 Northeast   100
## 2 Midwest     101
## 3 South       100
## 4 West        101

p <- ggplot(rel_by_region, aes(x = bigregion, y = pct, fill = religion))
p + geom_col(position = "dodge2") +
  labs(x = "Region",y = "Percent", fill = "Religion") +
  theme(legend.position = "top")

Use coord_flip()

p <- ggplot(rel_by_region, aes(x = bigregion, y = pct, fill = religion))
p + geom_col(position = "dodge2") +
  labs(x = "Region",y = "Percent", fill = "Religion") +
  guides(fill = FALSE) + 
  coord_flip() + 
  facet_grid(~ bigregion)

p <- ggplot(rel_by_region, aes(x = religion, y = pct, fill = religion))
p + geom_col(position = "dodge2") +
  labs(x = NULL,y = "Percent", fill = "Religion") +
  guides(fill = FALSE) + 
  coord_flip() + 
  facet_grid(~ bigregion)

Continuous Variables by Group or Category

p <- ggplot(data = organdata, mapping = aes(x = year, y = donors))
p + geom_line(aes(group = country)) + facet_wrap(~country)

## Warning: Removed 34 rows containing missing values (geom_path).

p <- ggplot(data = organdata, mapping = aes(x = country, y = donors))
p + geom_boxplot() + coord_flip()

## Warning: Removed 34 rows containing non-finite values (stat_boxplot).

p <- ggplot(data = organdata, mapping = aes(x = reorder(country,
                                                        donors, na.rm = TRUE), y = donors))
p + geom_boxplot() + labs(x = NULL) + coord_flip()

## Warning: Removed 34 rows containing non-finite values (stat_boxplot).

p <- ggplot(data = organdata, mapping = aes(x = reorder(country, donors, na.rm = TRUE), 
                                            y = donors, fill = world))
p + geom_boxplot() + labs(x = NULL) + 
  coord_flip() + theme(legend.position = "top")

## Warning: Removed 34 rows containing non-finite values (stat_boxplot).

p <- ggplot(data = organdata, mapping = aes(x = reorder(country, donors, na.rm = TRUE), 
                                            y = donors, color = world))
p + geom_point() + labs(x = NULL) + 
  coord_flip() + theme(legend.position = "top")

## Warning: Removed 34 rows containing missing values (geom_point).

p <-
  ggplot(data = organdata,
         mapping = aes(
           x = reorder(country, donors, na.rm = TRUE),
           y = donors,
           color = world
         ))
p + geom_jitter() + labs(x = NULL) +
  coord_flip() + theme(legend.position = "top")

## Warning: Removed 34 rows containing missing values (geom_point).

p <-
  ggplot(data = organdata,
         mapping = aes(
           x = reorder(country, donors, na.rm = TRUE),
           y = donors,
           color = world
         ))
p + geom_jitter(position = position_jitter(width = 0.15)) + labs(x = NULL) +
  coord_flip() + theme(legend.position = "top")

## Warning: Removed 34 rows containing missing values (geom_point).

by_country <-
  organdata %>% group_by(consent_law, country) %>% summarize(
    donors_mean = mean(donors, na.rm = TRUE),
    donors_sd = sd(donors, na.rm = TRUE),
    gdp_mean = mean(gdp, na.rm = TRUE),
    health_mean = mean(health, na.rm = TRUE),
    roads_mean = mean(roads, na.rm = TRUE),
    cerebvas_mean = mean(cerebvas, na.rm = TRUE)
  )

by_country

## # A tibble: 17 x 8
## # Groups:   consent_law [2]
##    consent_law country donors_mean donors_sd gdp_mean health_mean
##    <chr>       <chr>         <dbl>     <dbl>    <dbl>       <dbl>
##  1 Informed    Austra…        10.6     1.14    22179.       1958.
##  2 Informed    Canada         14.0     0.751   23711.       2272.
##  3 Informed    Denmark        13.1     1.47    23722.       2054.
##  4 Informed    Germany        13.0     0.611   22163.       2349.
##  5 Informed    Ireland        19.8     2.48    20824.       1480.
##  6 Informed    Nether…        13.7     1.55    23013.       1993.
##  7 Informed    United…        13.5     0.775   21359.       1561.
##  8 Informed    United…        20.0     1.33    29212.       3988.
##  9 Presumed    Austria        23.5     2.42    23876.       1875.
## 10 Presumed    Belgium        21.9     1.94    22500.       1958.
## 11 Presumed    Finland        18.4     1.53    21019.       1615.
## 12 Presumed    France         16.8     1.60    22603.       2160.
## 13 Presumed    Italy          11.1     4.28    21554.       1757 
## 14 Presumed    Norway         15.4     1.11    26448.       2217.
## 15 Presumed    Spain          28.1     4.96    16933        1289.
## 16 Presumed    Sweden         13.1     1.75    22415.       1951.
## 17 Presumed    Switze…        14.2     1.71    27233        2776.
## # … with 2 more variables: roads_mean <dbl>, cerebvas_mean <dbl>

by_country <- organdata %>% group_by(consent_law, country) %>%
  summarize_if(is.numeric, lst(mean, sd), na.rm = TRUE) %>%
  ungroup()
by_country

## # A tibble: 17 x 28
##    consent_law country donors_mean pop_mean pop_dens_mean gdp_mean
##    <chr>       <chr>         <dbl>    <dbl>         <dbl>    <dbl>
##  1 Informed    Austra…        10.6   18318.         0.237   22179.
##  2 Informed    Canada         14.0   29608.         0.297   23711.
##  3 Informed    Denmark        13.1    5257.        12.2     23722.
##  4 Informed    Germany        13.0   80255.        22.5     22163.
##  5 Informed    Ireland        19.8    3674.         5.23    20824.
##  6 Informed    Nether…        13.7   15548.        37.4     23013.
##  7 Informed    United…        13.5   58187.        24.0     21359.
##  8 Informed    United…        20.0  269330.         2.80    29212.
##  9 Presumed    Austria        23.5    7927.         9.45    23876.
## 10 Presumed    Belgium        21.9   10153.        30.7     22500.
## 11 Presumed    Finland        18.4    5112.         1.51    21019.
## 12 Presumed    France         16.8   58056.        10.5     22603.
## 13 Presumed    Italy          11.1   57360.        19.0     21554.
## 14 Presumed    Norway         15.4    4386.         1.35    26448.
## 15 Presumed    Spain          28.1   39666.         7.84    16933 
## 16 Presumed    Sweden         13.1    8789.         1.95    22415.
## 17 Presumed    Switze…        14.2    7037.        17.0     27233 
## # … with 22 more variables: gdp_lag_mean <dbl>, health_mean <dbl>,
## #   health_lag_mean <dbl>, pubhealth_mean <dbl>, roads_mean <dbl>,
## #   cerebvas_mean <dbl>, assault_mean <dbl>, external_mean <dbl>,
## #   txp_pop_mean <dbl>, donors_sd <dbl>, pop_sd <dbl>, pop_dens_sd <dbl>,
## #   gdp_sd <dbl>, gdp_lag_sd <dbl>, health_sd <dbl>, health_lag_sd <dbl>,
## #   pubhealth_sd <dbl>, roads_sd <dbl>, cerebvas_sd <dbl>,
## #   assault_sd <dbl>, external_sd <dbl>, txp_pop_sd <dbl>

p <- ggplot(data = by_country,
            mapping = aes(
              x = donors_mean,
              y = reorder(country, donors_mean),
              color = consent_law
            ))
p + geom_point(size = 3) +
  labs(x = "Donor Procurement Rate",
       y = "", color = "Consent Law") +
  theme(legend.position = "top")

p <- ggplot(data = by_country,
            mapping = aes(x = donors_mean,
                          y = reorder(country, donors_mean)))

p + geom_point(size = 3) +
  facet_wrap( ~ consent_law, scales = "free_y", ncol = 1) +
  labs(x = "Donor Procurement Rate",
       y = "")

p <- ggplot(data = by_country,
            mapping = aes(x = reorder(country,
                                      donors_mean), y = donors_mean))

p + geom_pointrange(mapping = aes(ymin = donors_mean - donors_sd,
                                  ymax = donors_mean + donors_sd)) +
  labs(x = "", y = "Donor Procurement Rate") + coord_flip()

### Plot Text Directly

p <- ggplot(data = by_country,
            mapping = aes(x = roads_mean,
                          y = donors_mean))
p + geom_point() + geom_text(mapping = aes(label = country))

p <- ggplot(data = by_country,
            mapping = aes(x = roads_mean,
                          y = donors_mean))
p + geom_point() + geom_text(mapping = aes(label = country), hjust = 0)

ggrepel is better than geom_text()

library(ggrepel)

p_title <-
  "Presidential Elections: Popular & Electoral College Margins"
p_subtitle <- "1824-2016"
p_caption <- "Data for 2016 are provisional."
x_label <- "Winner's share of Popular Vote"
y_label <- "Winner's share of Electoral College Votes"

p <- ggplot(elections_historic,
            aes(x = popular_pct, y = ec_pct,
                label = winner_label))

p + geom_hline(yintercept = 0.5,
               size = 1.4,
               color = "gray80") +
  geom_vline(xintercept = 0.5,
             size = 1.4,
             color = "gray80") +
  geom_point() +
  geom_text_repel() +
  scale_x_continuous(labels = scales::percent) +
  scale_y_continuous(labels = scales::percent) +
  labs(
    x = x_label,
    y = y_label,
    title = p_title,
    subtitle = p_subtitle,
    caption = p_caption
  )

### Label Outliers

p <- ggplot(data = by_country,
            mapping = aes(x = gdp_mean, y = health_mean))

p + geom_point() +
  geom_text_repel(data = subset(by_country, gdp_mean > 25000),
                  mapping = aes(label = country))

p <- ggplot(data = by_country,
            mapping = aes(x = gdp_mean, y = health_mean))

p + geom_point() +
  geom_text_repel(
    data = subset(
      by_country,
      gdp_mean > 25000 | health_mean < 1500 |
        country %in% "Belgium"
    ),
    mapping = aes(label = country)
  )

organdata$ind <- organdata$ccode %in% c("Ita", "Spa") &
  organdata$year > 1998

p <- ggplot(data = organdata,
            mapping = aes(x = roads,
                          y = donors, color = ind))
p + geom_point() +
  geom_text_repel(data = subset(organdata, ind),
                  mapping = aes(label = ccode)) +
  guides(label = FALSE, color = FALSE)

## Warning: Removed 34 rows containing missing values (geom_point).

Write and Draw in the Plot Area

p <- ggplot(data = organdata, mapping = aes(x = roads, y = donors))
p + geom_point() + annotate(
  geom = "text",
  x = 91,
  y = 33,
  label = "A surprisingly high \n recovery rate.",
  hjust = 0
)

## Warning: Removed 34 rows containing missing values (geom_point).

p <- ggplot(data = organdata,
            mapping = aes(x = roads, y = donors))
p + geom_point() +
  annotate(
    geom = "rect",
    xmin = 125,
    xmax = 155,
    ymin = 30,
    ymax = 35,
    fill = "red",
    alpha = 0.2
  ) +
  annotate(
    geom = "text",
    x = 157,
    y = 33,
    label = "A surprisingly high \n recovery rate.",
    hjust = 0
  )

## Warning: Removed 34 rows containing missing values (geom_point).

Scales, Guides, and Themes

p <- ggplot(data = organdata,
            mapping = aes(x = roads,
                          y = donors,
                          color = world))
p + geom_point()

## Warning: Removed 34 rows containing missing values (geom_point).

p <- ggplot(data = organdata,
            mapping = aes(x = roads,
                          y = donors,
                          color = world))
p + geom_point() + scale_x_log10() + scale_y_continuous(breaks = c(5,
                                                                   15, 25),
                                                        labels = c("Five", "Fifteen", "Twenty Five"))

## Warning: Removed 34 rows containing missing values (geom_point).

p <- ggplot(data = organdata,
            mapping = aes(x = roads, y = donors,
                          color = world))
p + geom_point() + scale_color_discrete(labels = c("Corporatist",
                                                   "Liberal", "Social Democratic", "Unclassified")) + 
  labs(x = "Road Deaths",
       y = "Donor Procurement", color = "Welfare State")

## Warning: Removed 34 rows containing missing values (geom_point).

p <- ggplot(data = organdata,
            mapping = aes(x = roads, y = donors,
                          color = world))
p + geom_point() + labs(x = "Road Deaths", y = "Donor Procurement") +
  guides(color = FALSE)

## Warning: Removed 34 rows containing missing values (geom_point).