R | Little World

用R取代Stata与SAS

Mon, 20 Jan 2020 00:00:00 +0000

安装Stata

首先安装ncurses5-compat-libs和libpng12这两个包，其次

% sudo -s

cd /tmp/

mkdir statafiles

cd statafiles

tar -zxf /home/you/Downloads/Stata14Linux64.tar.gz

cd /usr/local

mkdir stata14

cd stata14

/tmp/statafiles/install

安完之后把安装目录加到环境变量中去。我选择编辑/etc/profile加入：

export PATH="$PATH:/usr/local/stata14"

若想不重启就生效可以source /etc/profile

Lic文件可以直接COPY到安装目录，或者在目录中放stata.lic.tar.gz。

在R中调用Stata

通过RStata实现

#run Stata in R----
library("RStata")
options("RStata.StataPath" = "D:\\Stata15\\StataSE-64") #office
options("RStata.StataPath" = "/usr/local/stata14/stata") #linux #cannot use stata-se?
options("RStata.StataVersion" = 14)

三种环境下数据互通

R下通过两个包

library(haven) #nead read_dta to read dta
library(rio) # rio::import to read sas data
#haven::read_sas can also import sas7bdat
f1 <- str_c(data_loc,"after2007.sas7bdat",sep = "/") 
o1 <- str_c(data_loc,"after2007.dta",sep = "/") 
after2007_raw <-  import(f1)
after2007 %>% 
  mutate_if(is.numeric, as.integer) %>% 
  write_dta(.,o1, version = 12)
# Because sas only supports Stata 12 files (or earlier) while haven supports stata versions 8-15.

如以上方法都无法顺利读入sas7bdat，用SAS中转

#import stata data file, only supports 12 or earlier
PROC IMPORT OUT= WORK.S1 
            DATAFILE= "E:\after2007.dta" 
            DBMS=STATA REPLACE;
RUN;

proc export data=raw1 outfile= "D:\sample.dta" replace;
run;

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).

Panel data in R vs in Stata

Tue, 27 Aug 2019 00:00:00 +0000

Panel data with one way fixed effect

mm1 <- invforward ~ TOBINQ + inv + top3 + size + lev + cash + loss + lnage + cfo + sd + ic + factor(year)
zzz <- plm(mm1,data=sample,model="within",index=c("stkcd"))

same as xtreg i.year fe , without robust vcetype 用这种方法算出来$R^2$和Stata报告$R^2$ within的一致

m1 <- invforward ~ TOBINQ + inv + top3 + size + lev + cash + loss + lnage + cfo + sd + ic
zz <- plm(m1,data=sample,model="within",index=c("stkcd", "year"),effect = "twoways")
summary(zz)

same sa xtreg i.year, fe , without robust vcetype，但$R^2$较Stata报告$R^2$ within小

vcetype robust

zz_r <- coeftest(zz, vcov.=function(x) vcovHC(x, type="sss")) # same as stata xtreg i.year, fe r
# OR
zzz_r <- coeftest(zzz, vcov.=function(x) vcovHC(x, type="sss"))

组间系数比较

OLS可用

sur_diff <-  MVBV ~ (Dm + Dh + EBV + DmEBV +DhEBV)*g_layer
h2t <- h2 %>%
  filter(g_layer != 2)%>%
  mutate(g_layer = ifelse(g_layer == 1, 0, 1))
mm <- lm(sur_diff,data=h2t)
ttt <-  coeftest(mm, vcov.=function(x) vcovHC(x, cluster="group", type="HC1"))

stargazer(fpm,models_growth_layer,type = "text", column.labels = table4_label)
stargazer(fpm_r,robusts_growth_layer,type = "text", column.labels = table4_label,
          add.lines=c("DhEBV(4)-(2)", str_c(round(ttt[12,1],3),"**(p=",round(ttt[12,4],3),")")))

Panel Data不行！One way, two way fixed effect都不行！建议直接加interaction

Difference in Difference

Wed, 10 Jul 2019 00:00:00 +0000

效應評估模型

“提高最低工資是否會減少就業？”

“最低工資提高是否餐廳的全職員工數會減少？”

假設 $MinWage$為「最低工資有提高」的虛擬變數， $FEmp$為餐廳全職員工數。

\[ FEmp_i=FEmp_{0,i}+\beta^*MinWage_i \]

\[ FEmp_i=\beta_0+\beta_1 MinWage_i+\epsilon_i \]

「沒有受到最低工資提高影響下的員工數」$FEmp_{0,i}$與「有無受到最低工資提高影響」无關时OLS是一致估计。

令 $s$表示餐廳所屬的州，則原本的效應模型可以寫成： $ \begin{eqnarray} FEmp_{is}=FEmp_{0,is}+\beta^*MinWage_{s} \tag{7.1} \end{eqnarray} $

	Pre	Post
Control		$MinWage=1$:PA
Treatment		$MinWage=1$:NJ

複迴歸模型

餐廳的型態（大型連鎖、咖啡店、小吃店等等）會影響員工僱用量。 $ \begin{eqnarray} FEmp_{is} =FEmp_{0,-type,is}+\beta^*MinWage_s+\gamma'type_{is} \tag{7.2} \end{eqnarray} $ 其中 $ FEmp_{0,-type,is}=FEmp_{0,is}-\mathbb{E}(FEmp_{0,is}|type_{is}) $

在思考怱略變數偏誤(omitted variable bias)時，可能的confounder都必需放在（依實驗組/控制組分的）加總層級來思考。

固定效果

組固定效果

\[ FEmp_{is}=FEmp_{0,is}+\beta^*MinWage_{s} \]

多數時候實驗組/控制組在政策還沒施行前，他們就存在組間的特質差異，也就是 $ FEmp_{0,is}=FEmp_{0,-\alpha_s,is}+\alpha_s $ 其中$\alpha_s$ 代表因組而異的confounder效果。

若沒有其他confounder，我們可以估計以下迴歸模型： $ FEmp_{ist}=\alpha_s+\beta^* MinWage_{st}+\epsilon_{ist} $

時間固定效果

\[ FEmp_{ist}=FEmp_{0,-(\alpha_s,\delta_t),ist}+\alpha_s+\delta_t+\beta^*MinWage_{st} \]

所對應的迴歸模型為： $ FEmp_{ist}=\alpha_s+\delta_t+\beta^* MinWage_{st}+\epsilon_{ist} $

資料追踪/不追踪

雖然$FEmp_{ist}$ 有到個別餐廳（即有下標 $i$），然而固定效果只到組層級（即下標 $s$)，因此在估計上我們並不需要追踪同一家餐廳——各期抽樣的餐廳可以不同。

DiD 估计法

\[ \begin{eqnarray} FEmp_{ist}=\alpha_s+\delta_t+\beta^*MinWage_{st}+\epsilon_{ist} \tag{7.3} \end{eqnarray} \]

\[ FEmp_{ist}=\beta_0+\alpha_1D1_s+\delta_1B1_t+\beta_1MinWage_{st}+\epsilon_{ist} \]

令$D1=1$代表來自第1個州（NJ）的虛擬變數。
令$B1 = 1$代表政策施行「後」的虛擬變數。
$MinWage_{st}=D1_s\times B1_t$

State	t=0	T=1
NJ	D1=1,B1=0	D1=1,B1=1
PA	D1=0,B1=0	D1=0,B1=1

cluster standard error

我們有G1-G4共四群誤差項的變異數及跨群間的共變異數需要去留意，當誤差項有聚類（clustering）可能時，必需要適當的調整估計式標準誤。

Panel Data

Wed, 10 Jul 2019 00:00:00 +0000

效應評估模型

\[ mrall=mrall_{-BeerTax}+\beta^*BeerTax \]

提高啤酒稅（BeerTax）是否有助減低車禍死亡率（mrall）？

固定效應模型

令 $W$代表「州愛喝酒程度」。

$W$與 $mrall_{-BeerTax}+$有關
$W$與 $BeerTax$有關

\[ mrall=(mrall_{-BT}-\mathbb{E}(mrall_{-BT}|W))+\mathbb{E}(mrall_{-BT}|W) + \beta^*BeerTax \]

\[ mrall_{-BT,-W}\equiv mrall_{-BT}-\mathbb{E}(mrall_{-BT}|W) \]

\[ mrall=mrall_{-BT,-W}+\mathbb{E}(mrall_{-BT}|W)+\beta^*BeerTax \]

$mrall_{-BT,-W}$為「去除」 $W$影響的「非啤酒稅造成的車禍死亡因素」：

它與 $W$無關。
若兩筆obs有相同飲酒文化，即$W$相同，他們的 $\mathbb{E}(mrall_{-BT}|W)$ 會相同。

「假設」一個地方的飲酒文化「不隨時間改變」，即同一州在不同時點的$W$相同。

令$\mathbb{E}(mrall_{-BT,it}|W_i)=\alpha_i$，故我們的效應模型可以寫成： $ mrall_{it}=mrall_{-BT,-W,it}+\alpha_i+\beta^*BeerTax_{it} $ 其中$\alpha_i$為第 $i$ 個州的固定效果：

$BearTax$與$mrall_{-BT,-W}$無關
$BearTax$與$\alpha$有關

組內差異最小平方法

差分OLS解决$\alpha_i$不可得的阻碍

\[ mrall_{i1}-mrall_{i0}=\beta^* (BeerTax_{i1}-BearTax_{i0})+(mrall_{-BT,-W,i1}-mrall_{-BT,-W,i0}) \]

如果$t$超過兩期，考慮用組內平均為差分比較的點。

即$x_1-\bar{x},x_2-\bar{x},...,x_n-\bar{x}, \bar{x}=\sum_{i=1}^n x_i/n$ $ \bar{mrall}_i=\sum_{t=1}^T mrall_{it}/T \\ \bar{BeerTax}_i=\sum_{t=1}^T BeerTax_{it}/T\\ \bar{mrall}_{-BT,-W,i}=\sum_{t=1}^T mrall_{-BT,-W,it}/T $

\[ mrall_{it}-\bar{mrall}_i=\beta^*\left( BeerTax_{it}-\bar{BeerTax}_i\right)+(mrall_{-BT,-W,it}-\bar{mrall}_{-BT,-W,i}) \]

固定效果模型下，我們可以以最小平方法估計下面的迴歸式： $ mrall_{it}-\bar{mrall}_i=\beta_0+\beta_1\left( BeerTax_{it}-\bar{BeerTax}_i\right)+\epsilon_{it} $ 其中$\hat{\beta}_1$即為$\beta^*$的一致性估計

常見的固定效果模型

Identity fixed effect:$\alpha_i$
Time fixed effect: $\delta_i$

\[ mrall_{-BT,it}=mrall_{-BT,-W_i,-Z_t}+\alpha_i+\delta_t \]

$W_i$為造成效應係數估計偏誤的變數，它在$i$面向固定不變。
$Z_t$為造成效應係數估計偏誤的變數，它在$t$面向固定不變。

如$Z_t$為全美國的景氣狀況。

對應的迴歸模型： $ mrall_{it}=\alpha_i+\delta_t+\beta_1 BeerTax_{it}+\epsilon_{it} $

廣義的固定效果模型

\[ mrall=mrall_{-BeerTax}+\beta^*BeerTax \]

但 $ \begin{equation} mrall_{-BT,it}\not\perp BeerTax_{it} \tag{5.1} \end{equation} $

複迴歸控制

先思考造成(5.1)的變數有哪些——統計上稱這些變數為混淆變數(confounder)。Confounder中有資料的（令為$Z$）可進一步用來擴充模型成為： $ mrall_{it}=mrall_{-BT,-Z,it}+\beta^*BeerTax_{it}+\gamma'Z_{it} $ 其中： $ mrall_{-BT,-Z}=mrall_{-BT}-\mathbb{E}(mrall_{-BT}|Z) $

固定效果模型

Confounder中沒有資料但在某些面向固定的，假設分成以下兩類：

$W_i$：在同個identity下固定。
$V_t$：在同個time下固定。

\[ \begin{eqnarray} mrall_{it}=mrall_{-BT,-(Z,W,V),it}+\beta^*BeerTax_{it}+\\ \alpha_i+\delta_t+\gamma'Z_{it} \tag{5.2} \end{eqnarray} \]

(5.2)是相當廣義的固定效果效應模型——有兩個面向的固定效果及控制變數。

隨機效果模型

\[ mrall_{it}=mrall_{-BT,-Z,it}+\beta^*BeerTax_{it}+\gamma'Z_{it} \]

隨機效果模型(Random Effect model)的設定：

使用迴歸模型：

\[ \begin{eqnarray} mrall_{it}=\beta_0+\beta_{1}BeerTax_{it}+\gamma'Z_{it}+\nu_{it} \tag{5.3} \end{eqnarray} \]

假設$\nu_{it}$ 具有某種結構。

其中假设：

$\nu_{it}\perp BeerTax_{it}$
$var(\alpha_i|X)=\sigma_{\alpha}^2$
$var(\epsilon_{it}|X)=\sigma^2$
$cov(\epsilon_{it},\epsilon_{is}|X)=0$

隨機效果模型帶有高度誤差項假設，故不建議使用。

Hausman檢定

固定效果模型(FE)

表示使用組內差異最小平法方去估算以下迴歸模型中的$\beta_1$: $ mrall_{it}=\beta_0+\beta_{1}BeerTax_{it}+\gamma'Z_{it}+\alpha_i+\epsilon_{it} $

隨機效果模型(RE)

表示使用GLS去估算以下迴歸模型中的$\beta_1$: $ mrall_{it}=\beta_0+\beta_{1}BeerTax_{it}+\gamma'Z_{it}+\nu_{it} $

$\nu_{it}=\alpha_i+\epsilon_{it}$

假設

RE下「關於variance、covariance的假設」都成立。
$\epsilon_{it} \perp BeerTax_{it} | \alpha_i,Z_{it}$

H0: $\alpha_i \perp BeerTax_{it} |Z_{it}$

H0为RE，拒绝则为FE

Linear Regression

Thu, 04 Jul 2019 00:00:00 +0000

OLS estimator

The method to compute (or estimate) $b_0$ and $b_1$ we illustrated above is called Ordinary Least Squares, or OLS. $b_0$ and $b_1$ are therefore also often called the OLS coefficients. By solving problem

\[ \begin{align} e_i & = y_i - \hat{y}_i = y_i - \underbrace{\left(b_0 + b_1 x_i\right)}_\text{prediction}\\ e_1^2 + \dots + e_N^2 &= \sum_{i=1}^N e_i^2 \equiv \text{SSR}(b_0,b_1) \\ (b_0,b_1) &= \arg \min_{\text{int},\text{slope}} \sum_{i=1}^N \left[y_i - \left(\text{int} + \text{slope } x_i\right)\right]^2 \end{align} \]

one can derive an explicit formula for them:

$ \begin{equation} b_1 = \frac{cov(x,y)}{var(x)} \end{equation} $ i.e. the estimate of the slope coefficient is the covariance between $x$ and $y$ divided by the variance of $x$, both computed from our sample of data. With $b_1$ in hand, we can get the estimate for the intercept as

\[\begin{equation} b_0 = \bar{y} - b_1 \bar{x} \end{equation}\]

where $\bar{z}$ denotes the sample mean of variable $z$. The interpretation of the OLS slope coefficient $b_1$ is as follows. Given a line as in $y = b_0 + b_1 x$,

$b_1 = \frac{d y}{d x}$ measures the change in $y$ resulting from a one unit change in $x$
For example, if $y$ is wage and $x$ is years of education, $b_1$ would measure the effect of an additional year of education on wages.

There is an alternative representation for the OLS slope coefficient which relates to the correlation coefficient $r$. Remember that $r = \frac{cov(x,y)}{s_x s_y}$, where $s_z$ is the standard deviation of variable $z$. With this in hand, we can derive the OLS slope coefficient as

$$ \begin{align} b_1 &= \frac{cov(x,y)}{var(x)}\

&= \frac{cov(x,y)}{s_x s_x} \\
&= r\frac{s_y}{s_x} \end{align}

In other words, the slope coefficient is equal to the correlation coefficient $r$ times the ratio of standard deviations of $y$ and $x$.

Linear Regression without Regressor

\[ \begin{equation} y = b_0 \end{equation} \]

This means that our minimization problem becomes very simple: We only have to choose $b_0$! We have

$ b_0 = \arg\min_{\text{int}} \sum_{i=1}^N \left[y_i - \text{int}\right]^2, $ which is a quadratic equation with a unique optimum such that $ b_0 = \frac{1}{N} \sum_{i=1}^N y_i = \overline{y}. $

Least Squares without regressor $x$ estimates the sample mean of the outcome variable $y$, i.e. it produces $\overline{y}$.

Regression without an Intercept

We follow the same logic here, just that we miss another bit from our initial equation and the minimisation problem now becomes: $ \begin{align} b_1 &= \arg\min_{\text{slope}} \sum_{i=1}^N \left[y_i - \text{slope } x_i \right]^2\\ \mapsto b_1 &= \frac{\frac{1}{N}\sum_{i=1}^N x_i y_i}{\frac{1}{N}\sum_{i=1}^N x_i^2} = \frac{\bar{x} \bar{y}}{\overline{x^2}} \end{align} $

Least Squares without intercept (i.e. with $b_0=0$) is a line that passes through the origin.

In this case we only get to choose the slope $b_1$ of this anchored line.¹

Centering A Regression

By centering or demeaning a regression, we mean to substract from both $y$ and $x$ their respective averages to obtain $\tilde{y}_i = y_i - \bar{y}$ and $\tilde{x}_i = x_i - \bar{x}$. We then run a regression without intercept as above. That is, we use $\tilde{x}_i,\tilde{y}_i$ instead of $x_i,y_i$ in

\[ \begin{align} b_1 &= \arg\min_{\text{slope}} \sum_{i=1}^N \left[y_i - \text{slope } x_i \right]^2\\ \mapsto b_1 &= \frac{\frac{1}{N}\sum_{i=1}^N x_i y_i}{\frac{1}{N}\sum_{i=1}^N x_i^2} = \frac{\bar{x} \bar{y}}{\overline{x^2}} \end{align} \]

to obtain our slope estimate $b_1$:

$$ \begin{align} b1 &= \frac{\frac{1}{N}\sum^N \tilde{x}_i \tilde{y}i}{\frac{1}{N}\sum^N \tilde{x}_i^2}\

&= \frac{\frac{1}{N}\sum_{i=1}^N (x_i - \bar{x}) (y_i - \bar{y})}{\frac{1}{N}\sum_{i=1}^N (x_i - \bar{x})^2} \\
&= \frac{cov(x,y)}{var(x)}

\end{align} $$

This last expression is identical to the one in OLS estimate! It's the standard OLS estimate for the slope coefficient. We note the following:

Adding a constant to a regression produces the same result as centering all variables and estimating without intercept. So, unless all variables are centered, always include an intercept in the regression.

Standardizing A Regression

Standardizing a variable $z$ means to demean as above, but in addition to divide the demeaned value by its own standard deviation. Similarly to what we did above for centering, we define transformed variables $\breve{y}_i = \frac{y_i-\bar{y}}{\sigma_y}$ and $\breve{x}_i = \frac{x_i-\bar{x}}{\sigma_x}$ where $\sigma_z$ is the standard deviation of variable $z$. From here on, you should by now be used to what comes next! As above, we use $\breve{x}_i,\breve{y}_i$ instead of $x_i,y_i$:

$$ \begin{align} b1 &= \frac{\frac{1}{N}\sum^N \breve{x}_i \breve{y}i}{\frac{1}{N}\sum^N \breve{x}_i^2}\

&= \frac{\frac{1}{N}\sum_{i=1}^N \frac{x_i - \bar{x}}{\sigma_x} \frac{y_i - \bar{y}}{\sigma_y}}{\frac{1}{N}\sum_{i=1}^N \left(\frac{x_i - \bar{x}}{\sigma_x}\right)^2} \\
&= \frac{Cov(x,y)}{\sigma_x \sigma_y} \\
&= Corr(x,y)

\end{align} $$

After we standardize both $y$ and $x$, the slope coefficient $b_1$ in the regression without intercept is equal to the correlation coefficient.

Predictions and Residuals

Now we want to ask how our residuals $e_i$ relate to the prediction $\hat{y_i}$. Let us first think about the average of all predictions $\hat{y_i}$, i.e. the number $\frac{1}{N} \sum_{i=1}^N \hat{y_i}$. Let's just take

\[ \begin{equation} \hat{y}_i = b_0 + b_1 x_i \end{equation} \]

and plug this into this average, so that we get

\[ \begin{align} \frac{1}{N} \sum_{i=1}^N \hat{y_i} &= \frac{1}{N} \sum_{i=1}^N b_0 + b_1 x_i \\ &= b_0 + b_1 \frac{1}{N} \sum_{i=1}^N x_i \\ &= b_0 + b_1 \bar{x} \\ \end{align} \]

But that last line is just equal to the formula for the OLS intercept $b_0 = \bar{y} - b_1 \bar{x}$! That means of course that

$ \frac{1}{N} \sum_{i=1}^N \hat{y_i} = b_0 + b_1 \bar{x} = \bar{y} $ in other words:

The average of our predictions $\hat{y_i}$ is identically equal to the mean of the outcome $y$. This implies that the average of the residuals is equal to zero.

Related to this result, we can show that the prediction $\hat{y}$ and the residuals are uncorrelated, something that is often called orthogonality between $\hat{y}_i$ and $e_i$. We would write this as

\[ \begin{align} Cov(\hat{y},e) &=\frac{1}{N} \sum_{i=1}^N (\hat{y}_i-\bar{y})(e_i-\bar{e}) = \frac{1}{N} \sum_{i=1}^N (\hat{y}_i-\bar{y})e_i \\ &= \frac{1}{N} \sum_{i=1}^N \hat{y}_i e_i-\bar{y} \frac{1}{N} \sum_{i=1}^N e_i = 0 \end{align} \]

Correlation, Covariance and Linearity

It is important to keep in mind that Correlation and Covariance relate to a linear relationship between x and y. Given how the regression line is estimated by OLS (see just above), you can see that the regression line inherits this property from the Covariance.

Always visually inspect your data, and don't rely exclusively on summary statistics like mean, variance, correlation and regression line. All of those assume a linear relationship between the variables in your data.

Analysing $Var(y)$

Analysis of Variance (ANOVA) refers to a method to decompose variation in one variable as a function of several others. We can use this idea on our outcome $y$. Suppose we wanted to know the variance of $y$, keeping in mind that, by definition, $y_i = \hat{y}_i + e_i$. We would write

\[ \begin{align}Var(y) &= Var(\hat{y} + e)\\ &= Var(\hat{y}) + Var(e) + 2 Cov(\hat{y},e)\\ &= Var(\hat{y}) + Var(e) \end{align} \]

We have seen that the covariance between prediction $\hat{y}$ and error $e$ is zero, that's why we have $Cov(\hat{y},e)=0$. What this tells us in words is that we can decompose the variance in the observed outcome $y$ into a part that relates to variance as explained by the model and a part that comes from unexplained variation. Finally, we know the definition of variance, and can thus write down the respective formulae for each part:

\[Var(y) = \frac{1}{N}\sum_{i=1}^N (y_i - \bar{y})^2\]
$Var(\hat{y}) = \frac{1}{N}\sum_{i=1}^N (\hat{y_i} - \bar{y})^2$, because the mean of $\hat{y}$ is $\bar{y}$ as we know.
Finally, $Var(e) = \frac{1}{N}\sum_{i=1}^N e_i^2$, because the mean of $e$ is zero. We can thus formulate how the total variation in outcome $y$ is apportioned between model and unexplained variation:

The total variation in outcome $y$ (often called SST, or total sum of squares) is equal to the sum of explained squares (SSE) plus the sum of residuals (SSR). We have thus SST = SSE + SSR.

Assessing the Goodness of Fit

In our setup, there exists a convenient measure for how good a particular statistical model fits the data. It is called $R^2$ (R squared), also called the coefficient of determination. We make use of the just introduced decomposition of variance, and write the formula as

\[ \begin{equation}R^2 = \frac{\text{variance explained}}{\text{total variance}} = \frac{SSE}{SST} = 1 - \frac{SSR}{SST}\in[0,1] \end{equation} \]

It is easy to see that a good fit is one where the sum of explained squares (SSE) is large relative to the total variation (SST). In such a case, we observe an $R^2$ close to one. In the opposite case, we will see an $R^2$ close to zero. Notice that a small $R^2$ does not imply that the model is useless, just that it explains a small fraction of the observed variation.

This slope is related to the angle between vectors $\mathbf{a} =(\overline{x},\overline{y})$, and $\mathbf{b} = (\overline{x},0)$. Hence, it's related to the scalar projection of $\mathbf{a}$ on $\mathbf{b}$] ^{^}

工具变量

Thu, 04 Jul 2019 00:00:00 +0000

效應評估模型

\[Y_{i}={Y}_{-p,i}+\beta_i P_{i}\]

\[ Y_i=Y_{-P,i}+\beta^* P_i \]

\[ \begin{equation} Y_i=\beta_0+\beta_1P_i+w_i'\gamma+\varepsilon \tag{3.2} \end{equation} \]

在$w_{i}$條件下，「香煙售價」$P_{i}$必需要與「非價格效應的香煙銷售量」$Y_{-P}$獨立，即：$P_i\perp Y_{-p,i} | w_i$ 另一個同義說法是：「香煙售價」$P_{i}$必需要與「控制$w_{i}$條件後的非價格效應香煙銷售量」獨立。

对$Y_{-P}$进行$rincome$下分解 $ \begin{equation} Y_{i}=Y_{-P,i}-\mathbb{E}(Y_{-P,i}|rincome_{i})+\beta^{*}P_{i}+\mathbb{E}(Y_{-P,i}|rincome_{i}) \tag{3.3} \end{equation} $

把資料依$w_{i}$條件變數不同, 分群觀察「香煙售價」$P_{i}$與「香煙銷售量」$Y_{i}$之間的斜率。如果$w_{i}$變數選得好，同一群資料$P_{i}$與$Y_{i}$間的關連會反映應有的效應斜率——雖然有時$Y_{i}$會因為$Y_{-P,i}$的干擾影響我們對斜率高低的觀察，但因為$Y_{-P,i}$不會與$P_{i}$有關了，這些觀察干擾在大樣本下會互相抵消掉而還原應有的效應斜率值。

如果不管我們怎麼選擇$w_{i}$還是無法控制住$Y_{-P,i}$對與關連$Y_{i}$的干擾，那我們就要進行【資料轉換】直接從原始資料中【去除這些干擾】，其中最常見的兩種去除法為：工具變數法、追蹤資料固定效果模型。

工具變數法：透過工具變數留下$P_{i}$不與$Y_{-P,i}$相關的部份。
追蹤資料：透過變數轉換去除$P_{i}$中與$Y_{-P,i}$相關的部份。

\[ Y_i=Y_{-p,i}+\beta\mathbb{E}(P_i|z_i)+\beta (P_i-\mathbb{E}(P_i|z_i)) \]

Relevance condition

$\mathbb{E}(P|z)\neq 常数$即$z$对$P$具有解释力

Exclusion condition

$Y_{-p,i}+\beta(P_i-\mathbb{E}(P_i|z_i))$与$z_{i}$无关

三个假设

\[ \begin{equation} Y_i=\beta_0+\beta_1 P_i + \gamma_1 rincome_i + \epsilon_i \tag{3.5} \end{equation} \]

Q1: 我的工具變數有滿足排除條件（或外生條件）嗎?

香煙稅是否與控制條件下的「非售價因素銷售」無關？

\[ Y =\underset{(\times k)}{X}\beta+\underset{(\times p)}{W}\gamma +\epsilon \]

其中$X$為要進行效應評估的變數群，$W$為控制變數群，故$ϵ$為「$W$控制條件下排除$X$效果的Y值」。另外，我們額外找了工具變數: $\underset{\times m)}{Z}$, 要驗證：

$H_{0}$: 工具變數$Z$與迴歸模型誤差項$ϵ$無關

進行TSLS，取得 $ \hat{\epsilon}_{_{TSLS}}=Y-\hat{Y}_{TSLS} $.
將 $ \hat{\epsilon}_{_{TSLS}} $ 迴歸在總工具變數群（即$Z$與$W$）並進行所有係數為0的聯立檢定，計算檢定量 $J=mF\sim\chi^{2}(m-k)$，其中F係數聯立檢定的F檢定值。

此檢定的自由度為$m−k$，所以$m$要大於$k$。“等於”時是無法進行檢定的。

Q2: 我的工具變數關聯性夠強嗎？

香煙稅真的與「售價」很有關連嗎？

工具變數$Z$必需要與效應解釋變數$X$有「足夠強」的關聯，否則$\hat{\beta}_{_{TSLS}}$的大樣本漸近分配不會是常態分配。

考慮TSLS中的第一階段迴歸模型：$X=Z\alpha_z+W\alpha_w+u$我們希望$\alpha_z$聯立夠顯著。

檢定原則

$H_0$:$Z$ 工具變數只有微弱關聯性。

$X$迴歸在「總」工具變數群($Z$,$W$)，進行$\alpha_z=0$的聯立F檢定。
$F>10$拒絕$H_0$。

Q3: 我對遺漏變數偏誤(OVB)的擔心是否多餘？

或許根本沒有必要用工具變數，在(3.5)迴歸模型下，PP早已和ϵϵ（即「控制條件下的非售價因素銷售」）無關——直接對(3.5)進行最小平方法估計即可。 $ \begin{equation} Y =X\beta+W\gamma +\epsilon \tag{3.6} \end{equation} $ $H_0 $: 迴歸模型(3.6)中的$\beta$係數估計「沒有」面臨OVB: 用OLS或TSLS都可以: 在大樣本下，$\\hat{\beta}_{OLS}\approx\hat{\beta}_{TSLS}$。

$H_1 $: 迴歸模型(3.6)中的$\beta$係數估計「有」面臨OVB: 只能用TSLS :在大樣本下，$\\hat{\beta}_{OLS}\neq \hat{\beta}_{TSLS}$。

Hausman檢定統計量: $ H\equiv\left(\hat{\beta}_{IV}-\hat{\beta}_{OLS}\right)^{'}\left[V(\hat{\beta}_{IV}-\hat{\beta}_{OLS})\right]^{-1}\left(\hat{\beta}_{IV}-\hat{\beta}_{OLS}\right)\sim\chi_{(df)}^{2}. $ – df： $\beta$係數個數.

當$H>\chi_{(df)}^{2}(\alpha)$才拒絕$H_0$。