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==