The attached who.csv dataset contains real-world data from 2008. The variables included follow.
Country: name of the country
LifeExp: average life expectancy for the country in years
InfantSurvival: proportion of those surviving to one year or more
Under5Survival: proportion of those surviving to five years or more
TBFree: proportion of the population without TB.
PropMD: proportion of the population who are MDs
PropRN: proportion of the population who are RNs
PersExp: mean personal expenditures on healthcare in US dollars at average exchange rate
GovtExp: mean government expenditures per capita on healthcare, US dollars at average exchange rate
TotExp: sum of personal and government expenditures.
#who data
who <- read.csv('https://raw.githubusercontent.com/Riteshlohiya/Data605_HW12/master/who.csv')
summary(who)
## Country LifeExp InfantSurvival
## Afghanistan : 1 Min. :40.00 Min. :0.8350
## Albania : 1 1st Qu.:61.25 1st Qu.:0.9433
## Algeria : 1 Median :70.00 Median :0.9785
## Andorra : 1 Mean :67.38 Mean :0.9624
## Angola : 1 3rd Qu.:75.00 3rd Qu.:0.9910
## Antigua and Barbuda: 1 Max. :83.00 Max. :0.9980
## (Other) :184
## Under5Survival TBFree PropMD PropRN
## Min. :0.7310 Min. :0.9870 Min. :0.0000196 Min. :0.0000883
## 1st Qu.:0.9253 1st Qu.:0.9969 1st Qu.:0.0002444 1st Qu.:0.0008455
## Median :0.9745 Median :0.9992 Median :0.0010474 Median :0.0027584
## Mean :0.9459 Mean :0.9980 Mean :0.0017954 Mean :0.0041336
## 3rd Qu.:0.9900 3rd Qu.:0.9998 3rd Qu.:0.0024584 3rd Qu.:0.0057164
## Max. :0.9970 Max. :1.0000 Max. :0.0351290 Max. :0.0708387
##
## PersExp GovtExp TotExp
## Min. : 3.00 Min. : 10.0 Min. : 13
## 1st Qu.: 36.25 1st Qu.: 559.5 1st Qu.: 584
## Median : 199.50 Median : 5385.0 Median : 5541
## Mean : 742.00 Mean : 40953.5 Mean : 41696
## 3rd Qu.: 515.25 3rd Qu.: 25680.2 3rd Qu.: 26331
## Max. :6350.00 Max. :476420.0 Max. :482750
##
#scatterplot
lm <- lm(LifeExp ~ TotExp, data = who)
plot(who$TotExp, who$LifeExp, xlab = 'Total Expenditure', ylab = 'Average Life Expectancy', main='Average Life Expectancy vs Expenditure')
abline(lm)
summary(lm)
##
## Call:
## lm(formula = LifeExp ~ TotExp, data = who)
##
## Residuals:
## Min 1Q Median 3Q Max
## -24.764 -4.778 3.154 7.116 13.292
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 6.475e+01 7.535e-01 85.933 < 2e-16 ***
## TotExp 6.297e-05 7.795e-06 8.079 7.71e-14 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 9.371 on 188 degrees of freedom
## Multiple R-squared: 0.2577, Adjusted R-squared: 0.2537
## F-statistic: 65.26 on 1 and 188 DF, p-value: 7.714e-14
#plots
hist(resid(lm), main = "Histogram of Residuals", xlab = "Residuals")
plot(fitted(lm), resid(lm))
qqnorm(lm$residuals)
qqline(lm$residuals)
By seeing the R^2 value, we can say that the explained variability is very less @25.77%. The p-value suggests a statistically significant correlation between total expenditures and life expectancy, since p<<0.05. Looking at residuals plots it is clear that there is no constant variability and that residuals are not normally distributed. This model is not a good model.
#model2
LifeExp46 <- who$LifeExp**4.6
TotExp06 <- who$TotExp**0.06
lm1 <- lm(LifeExp46 ~ TotExp06, data = who)
summary(lm1)
##
## Call:
## lm(formula = LifeExp46 ~ TotExp06, data = who)
##
## Residuals:
## Min 1Q Median 3Q Max
## -308616089 -53978977 13697187 59139231 211951764
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -736527910 46817945 -15.73 <2e-16 ***
## TotExp06 620060216 27518940 22.53 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 90490000 on 188 degrees of freedom
## Multiple R-squared: 0.7298, Adjusted R-squared: 0.7283
## F-statistic: 507.7 on 1 and 188 DF, p-value: < 2.2e-16
plot(who$TotExp**0.06, who$LifeExp**4.6, xlab = 'Total Expenditure raised to 0.06 ', ylab = 'Average Life Expectancy raised to 4.6', main='Average Life Expectancy vs Expenditure')
abline(lm1)
#plots
hist(resid(lm1), main = "Histogram of Residuals", xlab = "Residuals")
plot(fitted(lm1), resid(lm1))
qqnorm(lm1$residuals)
qqline(lm1$residuals)
The 2nd model is better than the 1st model. The R^2 is .729, that means the explained variability is 72.9% compared to 25% for the1st model. Looking at residuals plots, variability is fairly constant with a few outliers and distribution of residuals is nearly normal. So 2nd model is better than the 1st model.
The equation:
y = - 736527910 + 620060216*(x)
LE <- function(x)
{y <- -736527910 + 620060216 *(x)
y <- y^(1/4.6)
y}
LE(1.5)
## [1] 63.31153
LE(2.5)
## [1] 86.50645
LifeExp = b0+b1 x PropMd + b2 x TotExp +b3 x PropMD x TotExp
#model3
lm2 <- lm(LifeExp ~ PropMD + TotExp + PropMD*TotExp, data = who)
summary(lm2)
##
## Call:
## lm(formula = LifeExp ~ PropMD + TotExp + PropMD * TotExp, data = who)
##
## Residuals:
## Min 1Q Median 3Q Max
## -27.320 -4.132 2.098 6.540 13.074
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 6.277e+01 7.956e-01 78.899 < 2e-16 ***
## PropMD 1.497e+03 2.788e+02 5.371 2.32e-07 ***
## TotExp 7.233e-05 8.982e-06 8.053 9.39e-14 ***
## PropMD:TotExp -6.026e-03 1.472e-03 -4.093 6.35e-05 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 8.765 on 186 degrees of freedom
## Multiple R-squared: 0.3574, Adjusted R-squared: 0.3471
## F-statistic: 34.49 on 3 and 186 DF, p-value: < 2.2e-16
#plots
hist(resid(lm2), xlab = "Residuals")
plot(fitted(lm2), resid(lm2))
The R^2 is just .3574 that means that the explained variability is just 35.74%. Residuals is right skewed and do not show constant variability. Dont think this is good model.
LifeExp_new <- ( (6.277*10^1) + (1.497*10^3)*.03 + (7.233*10^(-5))*14 - ((6.026*10^(-3))*0.03*14) )
LifeExp_new
## [1] 107.6785
This seems like an outlier as life expectancy of 107 does not look correct.