Loading The Packages

library(Zelig)
library(ggplot2)
library(dplyr)
# Opening and Previewing the "turnout" Dataset 
library(maxLik)
data(turnout)
head(turnout)
Summary of the Data
summary(turnout)
     race           age          educate          income      
 others: 292   Min.   :17.0   Min.   : 0.00   Min.   : 0.000  
 white :1708   1st Qu.:31.0   1st Qu.:10.00   1st Qu.: 1.744  
               Median :42.0   Median :12.00   Median : 3.351  
               Mean   :45.3   Mean   :12.07   Mean   : 3.887  
               3rd Qu.:59.0   3rd Qu.:14.00   3rd Qu.: 5.233  
               Max.   :95.0   Max.   :19.00   Max.   :14.925  
      vote      
 Min.   :0.000  
 1st Qu.:0.000  
 Median :1.000  
 Mean   :0.746  
 3rd Qu.:1.000  
 Max.   :1.000  
mean(turnout$income)
[1] 3.88664
max(turnout$income)
[1] 14.9247
min(turnout$income)
[1] 0

Plotting a graph showing respondents income by amount of education

ggplot(turnout)+geom_point(aes(x=educate,y=income), color="red")

Plotting a graph showing respondents income by age

turnout2 <-turnout
turnout2 <-select(turnout2, income, educate) 
head(turnout2)

Using Mcgryttr

turnout3 <-turnout%>%
  select(income, educate)
head(turnout3)

Plotting a graph showing respondents average income by education

The graph below shows that respondents with a higher level of education also reported a higher average income. As education increased the average income for respondents also increased.

turnout5 <- turnout%>% group_by(educate)%>% summarize(averageincome=mean(income))
ggplot(turnout5)+geom_col(aes(x=educate,y=averageincome), color="red")

Plotting a graph showing respondents average income by age.

The graph below shows that respondents between the age of 30 and 55 reported higher incomes than those younger than 30 and older than 55.

turnout4 <- turnout%>% group_by(age)%>% summarize(averageincome=mean(income))
ggplot(turnout4)+geom_point(aes(x=age,y=averageincome), color="red")

Applying the log-likelihood function to explain the standard deviation of income using age and education as the independent variables.

Using Maxlik Function we can see that age and education each have a significant effect on income. The correlation between both independent variables on income were positive. The significance size for education is .133 meaning that for each unit of education income increases by .133. Whereas for age, the significance size is .017 meaning for each unit(age) income will increase by only .017. We can clearly see that education has more of an effect on income than age does when we look at the maximum likelihood estimation table below. This estimation aligns with the slopes previously shown in which education education had a greater impact on changes in income than age did. The p-values below also show the strength of the relationships.

ols.lf2 <- function(param) {
  mu <- param[1]
  theta <- param[-1]
  y <- as.vector(turnout$income)
  x <- cbind(1, turnout$educate, turnout$age)
  sigma <- x%*%theta
  sum(dnorm(y, mu, sigma, log = TRUE))
}    
mle_ols2 <- maxLik(logLik = ols.lf2, start = c(mu = 1, theta1 = 1, theta2 = 1, theta3 = 1), method = "BFGS")
summary(mle_ols2)
--------------------------------------------
Maximum Likelihood estimation
BFGS maximization, 150 iterations
Return code 0: successful convergence 
Log-Likelihood: -4843.15 
4  free parameters
Estimates:
       Estimate Std. error t value  Pr(> t)    
mu     3.555011   0.069193  51.378  < 2e-16 ***
theta1 0.362114   0.204550   1.770   0.0767 .  
theta2 0.133349   0.010756  12.398  < 2e-16 ***
theta3 0.017507   0.002852   6.139 8.32e-10 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
--------------------------------------------
LS0tCnRpdGxlOiAiSG9tZXdvcmsgMyIKb3V0cHV0OiBodG1sX25vdGVib29rCi0tLQojIyNMb2FkaW5nIFRoZSBQYWNrYWdlcyAKYGBge3IsIG1lc3NhZ2U9RkFMU0UsIHdhcm5pbmc9RkFMU0V9CmxpYnJhcnkoWmVsaWcpCmxpYnJhcnkoZ2dwbG90MikKbGlicmFyeShkcGx5cikKCgojIE9wZW5pbmcgYW5kIFByZXZpZXdpbmcgdGhlICJ0dXJub3V0IiBEYXRhc2V0IApsaWJyYXJ5KG1heExpaykKZGF0YSh0dXJub3V0KQpoZWFkKHR1cm5vdXQpCmBgYAoKIyMjIyNTdW1tYXJ5IG9mIHRoZSBEYXRhIApgYGB7cn0Kc3VtbWFyeSh0dXJub3V0KQptZWFuKHR1cm5vdXQkaW5jb21lKQptYXgodHVybm91dCRpbmNvbWUpCm1pbih0dXJub3V0JGluY29tZSkKYGBgCgojIyMjUGxvdHRpbmcgYSBncmFwaCBzaG93aW5nIHJlc3BvbmRlbnRzIGluY29tZSBieSBhbW91bnQgb2YgZWR1Y2F0aW9uCmBgYHtyLCBlY2hvPVRSVUV9CmdncGxvdCh0dXJub3V0KStnZW9tX3BvaW50KGFlcyh4PWVkdWNhdGUseT1pbmNvbWUpLCBjb2xvcj0icmVkIikKYGBgCgojIyMjUGxvdHRpbmcgYSBncmFwaCBzaG93aW5nIHJlc3BvbmRlbnRzIGluY29tZSBieSBhZ2UgCmBgYHtyLCBlY2hvPVRSVUV9CmdncGxvdCh0dXJub3V0KStnZW9tX3BvaW50KGFlcyh4PWFnZSx5PWluY29tZSkpKyBnZW9tX3Ntb290aChhZXMoeCA9IGFnZSwgeSA9IGluY29tZSkpCmBgYAoKYGBge3J9CnR1cm5vdXQyIDwtdHVybm91dAp0dXJub3V0MiA8LXNlbGVjdCh0dXJub3V0MiwgaW5jb21lLCBlZHVjYXRlKSAKaGVhZCh0dXJub3V0MikKYGBgCiMjI1VzaW5nIE1jZ3J5dHRyCmBgYHtyfQp0dXJub3V0MyA8LXR1cm5vdXQlPiUKICBzZWxlY3QoaW5jb21lLCBlZHVjYXRlKQpoZWFkKHR1cm5vdXQzKQpgYGAKIyMjUGxvdHRpbmcgYSBncmFwaCBzaG93aW5nIHJlc3BvbmRlbnRzIGF2ZXJhZ2UgaW5jb21lIGJ5IGVkdWNhdGlvbgpUaGUgZ3JhcGggYmVsb3cgc2hvd3MgdGhhdCByZXNwb25kZW50cyB3aXRoIGEgaGlnaGVyIGxldmVsIG9mIGVkdWNhdGlvbiBhbHNvIHJlcG9ydGVkIGEgaGlnaGVyIGF2ZXJhZ2UgaW5jb21lLiBBcyBlZHVjYXRpb24gaW5jcmVhc2VkIHRoZSBhdmVyYWdlIGluY29tZSBmb3IgcmVzcG9uZGVudHMgYWxzbyBpbmNyZWFzZWQuIApgYGB7ciwgZWNobz1UUlVFfQp0dXJub3V0NSA8LSB0dXJub3V0JT4lIGdyb3VwX2J5KGVkdWNhdGUpJT4lIHN1bW1hcml6ZShhdmVyYWdlaW5jb21lPW1lYW4oaW5jb21lKSkKZ2dwbG90KHR1cm5vdXQ1KStnZW9tX2NvbChhZXMoeD1lZHVjYXRlLHk9YXZlcmFnZWluY29tZSksIGNvbG9yPSJyZWQiKQpgYGAKIyMjUGxvdHRpbmcgYSBncmFwaCBzaG93aW5nIHJlc3BvbmRlbnRzIGF2ZXJhZ2UgaW5jb21lIGJ5IGFnZS4gClRoZSBncmFwaCBiZWxvdyBzaG93cyB0aGF0IHJlc3BvbmRlbnRzIGJldHdlZW4gdGhlIGFnZSBvZiAzMCBhbmQgNTUgcmVwb3J0ZWQgaGlnaGVyIGluY29tZXMgdGhhbiB0aG9zZSB5b3VuZ2VyIHRoYW4gMzAgYW5kIG9sZGVyIHRoYW4gNTUuIApgYGB7ciwgZWNobz1UUlVFfQp0dXJub3V0NCA8LSB0dXJub3V0JT4lIGdyb3VwX2J5KGFnZSklPiUgc3VtbWFyaXplKGF2ZXJhZ2VpbmNvbWU9bWVhbihpbmNvbWUpKQpnZ3Bsb3QodHVybm91dDQpK2dlb21fcG9pbnQoYWVzKHg9YWdlLHk9YXZlcmFnZWluY29tZSksIGNvbG9yPSJyZWQiKQpgYGAKIyNBcHBseWluZyB0aGUgbG9nLWxpa2VsaWhvb2QgZnVuY3Rpb24gdG8gZXhwbGFpbiB0aGUgc3RhbmRhcmQgZGV2aWF0aW9uIG9mIGluY29tZSB1c2luZyBhZ2UgYW5kIGVkdWNhdGlvbiBhcyB0aGUgaW5kZXBlbmRlbnQgdmFyaWFibGVzLiAKVXNpbmcgTWF4bGlrIEZ1bmN0aW9uIHdlIGNhbiBzZWUgdGhhdCBhZ2UgYW5kIGVkdWNhdGlvbiBlYWNoIGhhdmUgYSBzaWduaWZpY2FudCBlZmZlY3Qgb24gaW5jb21lLiBUaGUgY29ycmVsYXRpb24gYmV0d2VlbiBib3RoIGluZGVwZW5kZW50IHZhcmlhYmxlcyBvbiBpbmNvbWUgd2VyZSBwb3NpdGl2ZS4gVGhlIHNpZ25pZmljYW5jZSBzaXplIGZvciBlZHVjYXRpb24gaXMgLjEzMyAgbWVhbmluZyB0aGF0IGZvciBlYWNoIHVuaXQgb2YgZWR1Y2F0aW9uIGluY29tZSBpbmNyZWFzZXMgYnkgLjEzMy4gV2hlcmVhcyBmb3IgYWdlLCB0aGUgc2lnbmlmaWNhbmNlIHNpemUgaXMgLjAxNyBtZWFuaW5nIGZvciBlYWNoIHVuaXQoYWdlKSBpbmNvbWUgd2lsbCBpbmNyZWFzZSBieSBvbmx5IC4wMTcuIFdlIGNhbiBjbGVhcmx5IHNlZSB0aGF0IGVkdWNhdGlvbiBoYXMgbW9yZSBvZiBhbiBlZmZlY3Qgb24gaW5jb21lIHRoYW4gYWdlIGRvZXMgd2hlbiB3ZSBsb29rIGF0IHRoZSBtYXhpbXVtIGxpa2VsaWhvb2QgZXN0aW1hdGlvbiB0YWJsZSBiZWxvdy4gIFRoaXMgZXN0aW1hdGlvbiBhbGlnbnMgd2l0aCB0aGUgc2xvcGVzIHByZXZpb3VzbHkgc2hvd24gaW4gd2hpY2ggZWR1Y2F0aW9uIGVkdWNhdGlvbiBoYWQgYSBncmVhdGVyIGltcGFjdCBvbiBjaGFuZ2VzIGluIGluY29tZSB0aGFuIGFnZSBkaWQuIFRoZSBwLXZhbHVlcyBiZWxvdyBhbHNvIHNob3cgdGhlIHN0cmVuZ3RoIG9mIHRoZSByZWxhdGlvbnNoaXBzLgoKYGBge3IsIG1lc3NhZ2U9RkFMU0UsIHdhcm5pbmc9RkFMU0V9Cm9scy5sZjIgPC0gZnVuY3Rpb24ocGFyYW0pIHsKICBtdSA8LSBwYXJhbVsxXQogIHRoZXRhIDwtIHBhcmFtWy0xXQogIHkgPC0gYXMudmVjdG9yKHR1cm5vdXQkaW5jb21lKQogIHggPC0gY2JpbmQoMSwgdHVybm91dCRlZHVjYXRlLCB0dXJub3V0JGFnZSkKICBzaWdtYSA8LSB4JSoldGhldGEKICBzdW0oZG5vcm0oeSwgbXUsIHNpZ21hLCBsb2cgPSBUUlVFKSkKfSAgICAKbWxlX29sczIgPC0gbWF4TGlrKGxvZ0xpayA9IG9scy5sZjIsIHN0YXJ0ID0gYyhtdSA9IDEsIHRoZXRhMSA9IDEsIHRoZXRhMiA9IDEsIHRoZXRhMyA9IDEpLCBtZXRob2QgPSAiQkZHUyIpCnN1bW1hcnkobWxlX29sczIpCgpgYGAKCg==