Final Project
Abhiram
2024-04-20
library(readr)
library(plyr)## Warning: package 'plyr' was built under R version 4.3.3library(dplyr)##
## Attaching package: 'dplyr'## The following objects are masked from 'package:plyr':
##
## arrange, count, desc, failwith, id, mutate, rename, summarise,
## summarize## The following objects are masked from 'package:stats':
##
## filter, lag## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, unionlibrary(ggplot2)df <- read_delim("C:\\Users\\abhir\\OneDrive\\Documents\\luddy\\H510-Stats,R\\adult.csv", delim = ",")## Rows: 32561 Columns: 15
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (9): Work-Class, Education, Marital Status, Occupation, Relationship, Ra...
## dbl (6): Age, Fnl_Wgt, Education_Level, Capital_Gain, Capital_Loss, hrs_week
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.df## # A tibble: 32,561 × 15
## Age `Work-Class` Fnl_Wgt Education Education_Level `Marital Status`
## <dbl> <chr> <dbl> <chr> <dbl> <chr>
## 1 39 " State-gov" 77516 " Bachelo… 13 " Never-married"
## 2 50 " Self-emp-not-inc" 83311 " Bachelo… 13 " Married-civ-s…
## 3 38 " Private" 215646 " HS-grad" 9 " Divorced"
## 4 53 " Private" 234721 " 11th" 7 " Married-civ-s…
## 5 28 " Private" 338409 " Bachelo… 13 " Married-civ-s…
## 6 37 " Private" 284582 " Masters" 14 " Married-civ-s…
## 7 49 " Private" 160187 " 9th" 5 " Married-spous…
## 8 52 " Self-emp-not-inc" 209642 " HS-grad" 9 " Married-civ-s…
## 9 31 " Private" 45781 " Masters" 14 " Never-married"
## 10 42 " Private" 159449 " Bachelo… 13 " Married-civ-s…
## # ℹ 32,551 more rows
## # ℹ 9 more variables: Occupation <chr>, Relationship <chr>, Race <chr>,
## # Sex <chr>, Capital_Gain <dbl>, Capital_Loss <dbl>, hrs_week <dbl>,
## # Country <chr>, Annual_pay <chr>colnames(df)[colnames(df) == "Work-Class"] <- "WorkClass"
# Rename the variable to remove the space
colnames(df)[colnames(df) == "Marital Status"] <- "MaritalStatus"The first variable age is a continuous variable. As an initial step, two histograms are plotted.
# histogram of age by income group
ggplot(df) + aes(x=as.numeric(Age), group=Annual_pay, fill=Annual_pay) +
geom_histogram(binwidth=1, color='black')
# histogram of age by gender group
ggplot(df) + aes(x=as.numeric(Age), group=Sex, fill=Sex) +
geom_histogram(binwidth=1, color='black')
dim(df)## [1] 32561 15#Missing values
sum(is.na(df))## [1] 0df[df == " ?"] <- NA
#Calculate NA percentage in the dataset
print(sapply(df, function(df){ sum(is.na(df)==T) * 100 /length(df) }))## Age WorkClass Fnl_Wgt Education Education_Level
## 0.000000 5.638647 0.000000 0.000000 0.000000
## MaritalStatus Occupation Relationship Race Sex
## 0.000000 5.660146 0.000000 0.000000 0.000000
## Capital_Gain Capital_Loss hrs_week Country Annual_pay
## 0.000000 0.000000 0.000000 1.790486 0.000000#Because the NA values only account for more than 5% at max, so we can remove it
df <- na.omit(df)
sum(is.na(df))## [1] 0#remove whitespace from the beginning of the string of each column
df[]<- lapply(df,trimws)#change data types to numeric and factor
num_var <- c("Age","Fnl_Wgt","Education_Level",
"Capital_Gain","Capital_Loss","hrs_week")
df[num_var] <- sapply(df[num_var], as.numeric)
categ_var <- c("WorkClass","Education","MaritalStatus",
"Occupation","Relationship","Race",
"Sex","Country")
df[,categ_var] <- lapply(df[,categ_var],factor)
str(df)## tibble [30,162 × 15] (S3: tbl_df/tbl/data.frame)
## $ Age : num [1:30162] 39 50 38 53 28 37 49 52 31 42 ...
## $ WorkClass : Factor w/ 7 levels "Federal-gov",..: 6 5 3 3 3 3 3 5 3 3 ...
## $ Fnl_Wgt : num [1:30162] 77516 83311 215646 234721 338409 ...
## $ Education : Factor w/ 16 levels "10th","11th",..: 10 10 12 2 10 13 7 12 13 10 ...
## $ Education_Level: num [1:30162] 13 13 9 7 13 14 5 9 14 13 ...
## $ MaritalStatus : Factor w/ 7 levels "Divorced","Married-AF-spouse",..: 5 3 1 3 3 3 4 3 5 3 ...
## $ Occupation : Factor w/ 14 levels "Adm-clerical",..: 1 4 6 6 10 4 8 4 10 4 ...
## $ Relationship : Factor w/ 6 levels "Husband","Not-in-family",..: 2 1 2 1 6 6 2 1 2 1 ...
## $ Race : Factor w/ 5 levels "Amer-Indian-Eskimo",..: 5 5 5 3 3 5 3 5 5 5 ...
## $ Sex : Factor w/ 2 levels "Female","Male": 2 2 2 2 1 1 1 2 1 2 ...
## $ Capital_Gain : num [1:30162] 2174 0 0 0 0 ...
## $ Capital_Loss : num [1:30162] 0 0 0 0 0 0 0 0 0 0 ...
## $ hrs_week : num [1:30162] 40 13 40 40 40 40 16 45 50 40 ...
## $ Country : Factor w/ 41 levels "Cambodia","Canada",..: 39 39 39 39 5 39 23 39 39 39 ...
## $ Annual_pay : chr [1:30162] "<=50K" "<=50K" "<=50K" "<=50K" ...
## - attr(*, "na.action")= 'omit' Named int [1:2399] 15 28 39 52 62 70 78 94 107 129 ...
## ..- attr(*, "names")= chr [1:2399] "15" "28" "39" "52" ...The graph below shows the correlation between the income level and quantitative features, including age, final weight, education number, capital gain, capital loss, hours per week. Since the income column is categorical data, I turned the data into 0 and 1 to be able to compare with other quantitative features, in which 0 represents income less than or equal to $50k and 1 represents income more than $50k. The correlation heatmap shows that the final weight does not have the least correlation with income, with r = -0.01 while education number appears to be more correlated with income (r = 0.34).
corr_var <- c("Age","Fnl_Wgt","Education_Level",
"Capital_Gain","Capital_Loss","hrs_week","Annual_pay")
df$Annual_pay<-ifelse(df$Annual_pay =='<=50K',0,1)
df$Annual_pay <- as.numeric(df$Annual_pay)
correlation <- round(cor(df[corr_var]),2)
correlation## Age Fnl_Wgt Education_Level Capital_Gain Capital_Loss
## Age 1.00 -0.08 0.04 0.08 0.06
## Fnl_Wgt -0.08 1.00 -0.04 0.00 -0.01
## Education_Level 0.04 -0.04 1.00 0.12 0.08
## Capital_Gain 0.08 0.00 0.12 1.00 -0.03
## Capital_Loss 0.06 -0.01 0.08 -0.03 1.00
## hrs_week 0.10 -0.02 0.15 0.08 0.05
## Annual_pay 0.24 -0.01 0.34 0.22 0.15
## hrs_week Annual_pay
## Age 0.10 0.24
## Fnl_Wgt -0.02 -0.01
## Education_Level 0.15 0.34
## Capital_Gain 0.08 0.22
## Capital_Loss 0.05 0.15
## hrs_week 1.00 0.23
## Annual_pay 0.23 1.00library(reshape2)## Warning: package 'reshape2' was built under R version 4.3.3melted_corr <- melt(correlation)
ggplot(data = melted_corr, aes(x = Var1, y = Var2, fill = value)) +
geom_tile() +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
This shows that all variables are equally correlated.
Age vs Income
The figure below shows that the age distribution skews right, with a majority of the entries having ages between 27 and 50.
df$Age = as.numeric(df$Age)
hist(df$Age,col = 'lavender', main = "Age Distribution",
xlab = "Age", ylab = "Number of people",breaks = 100,prob = T)
abline(v=quantile(df$Age, .25), col='red', lwd = 2, lty = 'dashed')
abline(v=quantile(df$Age, .50), col='red', lwd = 2, lty = 'dashed')
abline(v=quantile(df$Age, .75), col='red', lwd = 2, lty = 'dashed')
lines(density(df$Age),col='purple',lwd = 2)
The stacked histogram and boxplot below illustrate the income distribution by age. Most people who make more than $50k are between their mid thirties to mid fifties.
df$Annual_pay <- as.factor(df$Annual_pay)
ggplot(df, aes(x=Age, fill=Annual_pay)) +
geom_histogram(alpha=0.5, bins=30, color = 'black') +
geom_density(aes(y=after_stat(density), fill=Annual_pay), alpha=0.5)+
scale_fill_manual(values=c("lightgreen", "salmon")) +
labs(x="Age", y="Count") +
ggtitle('Income Classification by Age') +
theme_classic()
ggplot(df, aes(x= Annual_pay, y=Age)) +
geom_boxplot(fill="salmon") +
labs(x="Annual_pay", y="Age") +
ggtitle("Age Distribution by Income Levels") +
theme_classic()
# Import necessary library
library(stats)
# Perform t-test
t_test_result <- t.test(Age ~ Annual_pay, data = df)
# Print the result
print(t_test_result)##
## Welch Two Sample t-test
##
## data: Age by Annual_pay
## t = -49.505, df = 16701, p-value < 2.2e-16
## alternative hypothesis: true difference in means between group 0 and group 1 is not equal to 0
## 95 percent confidence interval:
## -7.64211 -7.05999
## sample estimates:
## mean in group 0 mean in group 1
## 36.60806 43.95911library(ggplot2)
# Calculate mean age for each income group
mean_age <- aggregate(Age ~ Annual_pay, data = df, FUN = mean)
# Calculate standard error for each income group
se_age <- aggregate(Age ~ Annual_pay, data = df, FUN = function(x) sd(x) / sqrt(length(x)))
# Merge mean and standard error data
mean_age$se <- se_age$Age
# Plot bar chart with error bars
ggplot(mean_age, aes(x = Annual_pay, y = Age, fill = Annual_pay)) +
geom_bar(stat = "identity", position = position_dodge()) +
geom_errorbar(aes(ymin = Age - se, ymax = Age + se), position = position_dodge(0.9), width = 0.2) +
labs(x = "Annual Pay", y = "Mean Age", title = "Mean Age by Annual Pay") +
theme_minimal()
Insights: The Welch Two Sample t-test results indicate a significant
difference in the mean age between the two income groups (group 0 and
group 1). The test statistic (t) is -49.505 with 16701 degrees of
freedom, resulting in a p-value less than 2.2×10.(-16). This extremely
low p-value suggests strong evidence against the null hypothesis,
indicating that there is a significant difference in mean age between
the two income groups.
The 95% confidence interval for the difference in means between the two groups is [−7.64211,−7.05999]. This interval does not include zero, further supporting the conclusion of a significant difference in mean age between the income groups.
The estimated mean age for group 0 is 36.60806, and for group 1, it is 43.95911.
For the workclass column, I combine “State-gov”, “Local-gov”, “Federal-gov” as “Government”, and “Self-emp-not-inc”, “Self-emp-inc” as “Self-employment”, and change “Without-pay” to “Unemployment”. This would allow me to interpret the models late on easier.
df$'WorkClass'<- as.character(df$'WorkClass')
df$'WorkClass'[df$'WorkClass' == "State-gov" | df$'WorkClass' == "Local-gov" | df$'WorkClass' == "Federal-gov"] <- "Government"
df$'WorkClass'[df$'WorkClass' == "Self-emp-not-inc" | df$'WorkClass' == "Self-emp-inc"] <- "Self_Employment"
df$'WorkClass'[df$'WorkClass' == "Without-pay"] <- "Unemployment"
unique(df$'WorkClass')## [1] "Government" "Self_Employment" "Private" "Unemployment"From the graph, people who work for private corporations tend to earn income more than $50k the most. There seems to be no distinguishable difference between working for Government and Self-Employment.
ggplot(df, aes(x=WorkClass, fill=Annual_pay)) +
geom_bar() +
labs(x="Workclass", y="Count") +
ggtitle('Income Classification by Workclass')+
theme_classic()
# Recode WorkClass categories with low frequencies
df$WorkClass_recode <- ifelse(df$WorkClass %in% c("Federal-gov", "State-gov", "Local-gov"), "Government",
ifelse(df$WorkClass %in% c("Self-emp-not-inc", "Self-emp-inc"), "Self-Employed",
ifelse(df$WorkClass == "Without-pay", "Unemployed", as.character(df$WorkClass))))
# Create a contingency table with the recoded WorkClass
contingency_table_recode <- table(df$WorkClass_recode, df$Annual_pay)
# Perform chi-square test with the recoded WorkClass
chi_square_test_recode <- chisq.test(contingency_table_recode)## Warning in chisq.test(contingency_table_recode): Chi-squared approximation may
## be incorrect# Print the results
print(chi_square_test_recode)##
## Pearson's Chi-squared test
##
## data: contingency_table_recode
## X-squared = 460.92, df = 3, p-value < 2.2e-16result <- suppressWarnings(chisq.test(contingency_table_recode))
# Print the result
print(result)##
## Pearson's Chi-squared test
##
## data: contingency_table_recode
## X-squared = 460.92, df = 3, p-value < 2.2e-16The Chi-square test of independence conducted on the contingency table after recoding the “WorkClass” variable indicates a significant association between “WorkClass” and “Annual_pay” (χ² = 460.92, df = 3, p < 2.2e-16). This suggests that there is likely a dependency between these two variables.
Next, I also combine factors in Education column to make the data easier to interpret. “Bachelors”, “Masters”, “Doctorate”, “Prof-school” are lumped as “Higher Education”. “Assoc-acdm”, “Assoc-voc” are lumped as “Associates Degree”. “HS-grad”, “12th”, “11th”, “10th” are lumped as “High School”. I keep the “Some college” factor and the remaining factors are lumped as “Others”.
#Combining like factors of workclass column
df$Education <- as.character(df$Education)
df$Education[df$Education == "Bachelors" | df$Education == "Masters" | df$Education == "Doctorate" | df$Education == "Prof-school"] <- "Higher Education"
df$Education[df$Education == "Assoc-acdm" | df$Education == "Assoc-voc"] <- "Associates Degree"
df$Education[df$Education == "HS-grad" | df$Education == "12th" | df$Education == "11th" | df$Education == "10th"] <- "High School"
df$Education[df$Education == "Some-college"] <- "Some College"
df$Education[df$Education == "Preschool" | df$Education == "1st-4th" | df$Education == "5th-6th" | df$Education == "7th-8th" | df$Education == "9th"] <- "Others"
unique(df$Education)## [1] "Higher Education" "High School" "Others"
## [4] "Some College" "Associates Degree"In this dataset, the majority of people finished high school. However, people who have higher education (who have Bachelors degree or above) are most likely to to earn more than $50k. This result is consistent when we look at the education number. People who have 13 years of education tend to have higher income than others. Also, this observation explains the high correlation between education number and income columns as stated previously.
# plot the education distribution and sort the values
ggplot(df, aes(y = Education, fill = Annual_pay)) +
geom_bar(position = "dodge") +
scale_y_discrete(limits = rev(levels(factor(df$Education)))) +
scale_fill_manual(values = c("lightgreen", "salmon")) +
labs(x = "Count", y = "Education_Level", fill = "Annual_pay") +
theme_classic() 
ggplot(df, aes(y = Education_Level,fill=Annual_pay)) +
geom_bar() +
labs(x = "Count", y = "Years of education",
title = "Income Distribution by Years of education") +
theme_classic() 
# Fit ANOVA model
anova_model <- aov(Age ~ Annual_pay + Education_Level + hrs_week, data = df)
# Print ANOVA table
summary(anova_model)## Df Sum Sq Mean Sq F value Pr(>F)
## Annual_pay 1 304725 304725 1884.37 < 2e-16 ***
## Education_Level 1 8294 8294 51.29 8.17e-13 ***
## hrs_week 1 13423 13423 83.01 < 2e-16 ***
## Residuals 30158 4876916 162
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1library(ggplot2)
# Create boxplots
ggplot(df, aes(x = Annual_pay, y = Age, fill = Annual_pay)) +
geom_boxplot() +
labs(x = "Annual Pay", y = "Age", title = "Boxplot of Age by Annual Pay")
ggplot(df, aes(x = Education_Level, y = Age, fill = Annual_pay)) +
geom_boxplot() +
labs(x = "Education Level", y = "Age", title = "Boxplot of Age by Education Level")
ggplot(df, aes(x = hrs_week, y = Age, fill = Annual_pay)) +
geom_boxplot() +
labs(x = "Hours per Week", y = "Age", title = "Boxplot of Age by Hours per Week")
The predictor variables “Annual_pay”, “Education_Level”, and “hrs_week” are all statistically significant predictors of the response variable. This means that there is evidence to suggest that these variables have a significant impact on the response variable in the model. Therefore, the overall conclusion would be that “Annual_pay”, “Education_Level”, and “hrs_week” are important factors influencing the response variable, and they should be considered when analyzing or predicting the response variable in the given context.
In the martial status column, “Married-civ-spouse”, “Married-spouse-absent”, “Married-AF-spouse” are combined as “Married”, and I change “Never-married” to “Single” and keep the remaining factors.
df$'MaritalStatus' <- as.character(df$'MaritalStatus')
df$'MaritalStatus'[df$'MaritalStatus' == "Never_married"] <- "Single"
df$'MaritalStatus'[df$'MaritalStatus' == "Married-civ-spouse" | df$'MaritalStatus' == "Married-spouse-absent" | df$'MaritalStatus' == "Married-AF-spouse"] <- "Married"
unique(df$'MaritalStatus')## [1] "Never-married" "Married" "Divorced" "Separated"
## [5] "Widowed"df3 <- data.frame(table(df$Annual_pay, df$MaritalStatus))
names(df3) <- c('Annual Pay', 'Marital status', 'count')
df3## Annual Pay Marital status count
## 1 0 Divorced 3762
## 2 1 Divorced 452
## 3 0 Married 8016
## 4 1 Married 6440
## 5 0 Never-married 9256
## 6 1 Never-married 470
## 7 0 Separated 873
## 8 1 Separated 66
## 9 0 Widowed 747
## 10 1 Widowed 80result <- ddply(df, .(Annual_pay), summarise, mean_value = mean(Age), count = length(Age))
result## Annual_pay mean_value count
## 1 0 36.60806 22654
## 2 1 43.95911 7508colnames(df)## [1] "Age" "WorkClass" "Fnl_Wgt" "Education"
## [5] "Education_Level" "MaritalStatus" "Occupation" "Relationship"
## [9] "Race" "Sex" "Capital_Gain" "Capital_Loss"
## [13] "hrs_week" "Country" "Annual_pay" "WorkClass_recode"library(ggplot2)
# Create a bar plot
ggplot(df3, aes(x = `Marital status`, y = count, fill = `Annual Pay`)) +
geom_bar(stat = "identity", position = "dodge") +
labs(x = "Marital Status", y = "Count", title = "Counts by Marital Status and Annual Pay")
# histogram of capital_gain
ggplot(df) + aes(x=as.numeric(Capital_Gain), group=Annual_pay, fill=Annual_pay) +
geom_histogram(bins=10, color='black') + ggtitle('Histogram of Capital Gain')
# histogram of capital_loss
ggplot(df) + aes(x=as.numeric(Capital_Loss), group=Annual_pay, fill=Annual_pay) +
geom_histogram(bins=10, color='black') + ggtitle('Histogram of Capital Loss')
I did the same to the occupation where I combine the factors into “White-collar”, “Blue-collar”, “Professisonal”, “Service”, “Sales” and “Other”.
df$Occupation <- as.character(df$Occupation)
df$Occupation[df$Occupation == "Adm-clerical" | df$Occupation == "Exec-managerial"] <- "White-collar"
df$Occupation[df$Occupation == "Handlers-cleaners" |df$Occupation == "Transport-moving" | df$Occupation == "Farming-fishing" |df$Occupation == "Machine-op-inspct" |df$Occupation == "Craft-repair" ] <- "Blue-collar"
df$Occupation[df$Occupation == "Tech-support" | df$Occupation == "Protective-serv" | df$Occupation == "Priv-house-serv" | df$Occupation == "Other-service"] <- "Service"
df$Occupation[df$Occupation == "Prof-specialty"] <- "Professional"
df$Occupation[df$Occupation == "Armed-Forces"] <- "Other"
unique(df$Occupation)## [1] "White-collar" "Blue-collar" "Professional" "Service" "Sales"
## [6] "Other"In the bar graph, people who have white collar and professional jobs are more likely to earn more than $50k.
ggplot(df, aes(y = reorder(Occupation, -table(Occupation)[Occupation]), fill = Annual_pay)) +
geom_bar(position = "dodge") +
scale_fill_brewer(palette = "Set2") +
labs(y = "Occupation", x = "Count", fill = "Annual_pay") 
It is noticeable that those who work 40 hours per week have much higher chance to earn higher than $50k than those who work overtime or undertime. This makes sense because those who work overtime often do blue-collar job and get paid the minimum wage so they still have a low income despite their working hours per week.
ggplot(df, aes(x= hrs_week, fill=Annual_pay)) +
geom_bar() +
labs(x="hrs_week", y="Count") +
ggtitle('Income Classification by Hours per week')+
theme_classic()
As shown in the graph and table below, 24720 people earn less than or equal to $50000 while there are only 7841 earning more than $50000, which creates class imbalance, a common problem in classification that can affect the model accuracy.
table(df$Annual_pay)##
## 0 1
## 22654 7508barplot(table(df$Annual_pay),main = 'Income Classification',col='pink',ylab ='Number of people')
df$Annual_pay <- as.factor(df$Annual_pay)
#A majority of people in this dataset earn below 50klibrary(caTools)## Warning: package 'caTools' was built under R version 4.3.3library('lattice')
library("ROSE")## Warning: package 'ROSE' was built under R version 4.3.3## Loaded ROSE 0.0-4set.seed(200)
sample <- sample.split(df$Annual_pay,SplitRatio = 0.7)
train <- subset(df, sample == TRUE)
test <- subset(df, sample == FALSE)
head(test)## # A tibble: 6 × 16
## Age WorkClass Fnl_Wgt Education Education_Level MaritalStatus Occupation
## <dbl> <chr> <dbl> <chr> <dbl> <chr> <chr>
## 1 37 Private 284582 Higher Educ… 14 Married White-col…
## 2 49 Private 160187 Others 5 Married Service
## 3 56 Government 216851 Higher Educ… 13 Married Service
## 4 39 Private 367260 High School 9 Divorced White-col…
## 5 30 Government 59951 Some College 10 Married White-col…
## 6 21 Private 197200 Some College 10 Never-married Blue-coll…
## # ℹ 9 more variables: Relationship <fct>, Race <fct>, Sex <fct>,
## # Capital_Gain <dbl>, Capital_Loss <dbl>, hrs_week <dbl>, Country <fct>,
## # Annual_pay <fct>, WorkClass_recode <chr>balanced_data <- ovun.sample(Annual_pay~.,data = train,method = "both")$data
print(table(train$Annual_pay))##
## 0 1
## 15858 5256# Filter out rows with "Holand-Netherlands" in the Country variable
test_filtered <- test[test$Country != "Holand-Netherlands", ]# Exclude observations with the new level 'Holand-Netherlands'
test <- test[test$Country != "Holand-Netherlands", ]library('lattice')
library(caret)## Warning: package 'caret' was built under R version 4.3.3log_model <- glm(Annual_pay ~ ., family = binomial(), balanced_data)## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurredlog_pred <- predict(log_model, test, type = "response")## Warning in predict.lm(object, newdata, se.fit, scale = 1, type = if (type == :
## prediction from rank-deficient fit; attr(*, "non-estim") has doubtful caseslog_pred <- ifelse(log_pred > 0.5, "1", "0")
confusionMatrix(as.factor(log_pred), as.factor(test$Annual_pay))## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 5363 398
## 1 1432 1854
##
## Accuracy : 0.7977
## 95% CI : (0.7893, 0.806)
## No Information Rate : 0.7511
## P-Value [Acc > NIR] : < 2.2e-16
##
## Kappa : 0.531
##
## Mcnemar's Test P-Value : < 2.2e-16
##
## Sensitivity : 0.7893
## Specificity : 0.8233
## Pos Pred Value : 0.9309
## Neg Pred Value : 0.5642
## Prevalence : 0.7511
## Detection Rate : 0.5928
## Detection Prevalence : 0.6368
## Balanced Accuracy : 0.8063
##
## 'Positive' Class : 0
## Accuracy: The accuracy of the model is approximately 0.7977, which means that the proportion of correctly predicted outcomes (both true positives and true negatives) is around 79.77%. 95% Confidence Interval (CI): The 95% confidence interval for the accuracy ranges from 0.7893 to 0.806. This interval provides a range of values within which we can be 95% confident that the true accuracy of the model lies. No Information Rate (NIR): The No Information Rate is the accuracy that could be achieved by always predicting the majority class. In this case, it’s approximately 0.7511. P-Value [Acc > NIR]: This p-value indicates the statistical significance of the model’s accuracy compared to the No Information Rate. A very low p-value (< 0.05) suggests that the model’s accuracy is significantly different from the No Information Rate.
summary(log_model)##
## Call:
## glm(formula = Annual_pay ~ ., family = binomial(), data = balanced_data)
##
## Coefficients: (3 not defined because of singularities)
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -6.426e+00 8.408e-01 -7.643 2.12e-14 ***
## Age 3.202e-02 1.917e-03 16.705 < 2e-16 ***
## WorkClassPrivate -2.008e-02 5.727e-02 -0.351 0.725932
## WorkClassSelf_Employment -4.032e-01 7.400e-02 -5.449 5.07e-08 ***
## WorkClassUnemployment -1.362e+01 1.402e+02 -0.097 0.922572
## Fnl_Wgt 8.534e-07 1.925e-07 4.435 9.23e-06 ***
## EducationHigh School 1.600e-01 1.077e-01 1.486 0.137186
## EducationHigher Education 2.219e-01 9.554e-02 2.322 0.020227 *
## EducationOthers 4.244e-01 2.612e-01 1.625 0.104226
## EducationSome College 1.681e-01 8.721e-02 1.928 0.053880 .
## Education_Level 2.970e-01 3.062e-02 9.700 < 2e-16 ***
## MaritalStatusMarried 6.369e-01 1.711e-01 3.724 0.000196 ***
## MaritalStatusNever-married -5.801e-01 8.705e-02 -6.664 2.66e-11 ***
## MaritalStatusSeparated -2.386e-01 1.729e-01 -1.380 0.167562
## MaritalStatusWidowed -2.295e-02 1.525e-01 -0.150 0.880382
## OccupationOther -4.024e-01 1.552e+00 -0.259 0.795442
## OccupationProfessional 7.403e-01 7.514e-02 9.853 < 2e-16 ***
## OccupationSales 6.752e-01 6.870e-02 9.828 < 2e-16 ***
## OccupationService 3.067e-01 6.827e-02 4.493 7.03e-06 ***
## OccupationWhite-collar 7.854e-01 5.594e-02 14.040 < 2e-16 ***
## RelationshipNot-in-family -9.978e-01 1.662e-01 -6.002 1.94e-09 ***
## RelationshipOther-relative -1.072e+00 2.002e-01 -5.353 8.64e-08 ***
## RelationshipOwn-child -2.237e+00 2.060e-01 -10.860 < 2e-16 ***
## RelationshipUnmarried -1.151e+00 1.860e-01 -6.188 6.08e-10 ***
## RelationshipWife 1.455e+00 1.102e-01 13.198 < 2e-16 ***
## RaceAsian-Pac-Islander 4.911e-01 3.099e-01 1.585 0.113060
## RaceBlack -1.997e-01 2.510e-01 -0.796 0.426134
## RaceOther -1.264e-01 3.697e-01 -0.342 0.732389
## RaceWhite 1.455e-01 2.387e-01 0.610 0.542063
## SexMale 1.146e+00 7.885e-02 14.531 < 2e-16 ***
## Capital_Gain 3.362e-04 1.322e-05 25.427 < 2e-16 ***
## Capital_Loss 7.304e-04 4.628e-05 15.781 < 2e-16 ***
## hrs_week 3.712e-02 1.973e-03 18.818 < 2e-16 ***
## CountryCanada -1.725e+00 7.454e-01 -2.314 0.020651 *
## CountryChina -2.328e+00 7.884e-01 -2.952 0.003154 **
## CountryColumbia -3.910e+00 9.315e-01 -4.197 2.70e-05 ***
## CountryCuba -6.419e-01 7.597e-01 -0.845 0.398152
## CountryDominican-Republic -2.854e+00 9.593e-01 -2.976 0.002924 **
## CountryEcuador -3.019e+00 1.040e+00 -2.903 0.003702 **
## CountryEl-Salvador -2.340e+00 8.330e-01 -2.809 0.004968 **
## CountryEngland -1.801e+00 7.995e-01 -2.253 0.024259 *
## CountryFrance -2.811e+00 8.129e-01 -3.458 0.000544 ***
## CountryGermany -1.979e+00 7.599e-01 -2.604 0.009201 **
## CountryGreece -3.671e+00 9.228e-01 -3.978 6.95e-05 ***
## CountryGuatemala -2.126e+00 9.509e-01 -2.235 0.025387 *
## CountryHaiti -1.612e+00 1.011e+00 -1.594 0.110987
## CountryHonduras -3.148e+00 2.712e+00 -1.161 0.245739
## CountryHong -4.584e-01 1.375e+00 -0.333 0.738854
## CountryHungary -2.524e+00 1.011e+00 -2.495 0.012597 *
## CountryIndia -1.898e+00 7.286e-01 -2.605 0.009175 **
## CountryIran -2.350e+00 8.363e-01 -2.810 0.004950 **
## CountryIreland -1.254e+00 9.151e-01 -1.371 0.170424
## CountryItaly -6.588e-02 8.159e-01 -0.081 0.935638
## CountryJamaica -3.023e+00 8.978e-01 -3.367 0.000759 ***
## CountryJapan -1.431e+00 8.019e-01 -1.785 0.074279 .
## CountryLaos -3.091e+00 1.148e+00 -2.692 0.007107 **
## CountryMexico -2.087e+00 7.050e-01 -2.961 0.003070 **
## CountryNicaragua -3.282e+00 9.614e-01 -3.414 0.000640 ***
## CountryOutlying-US(Guam-USVI-etc) -1.199e+01 2.389e+02 -0.050 0.959965
## CountryPeru -2.974e+00 1.084e+00 -2.743 0.006092 **
## CountryPhilippines -1.629e+00 6.959e-01 -2.341 0.019231 *
## CountryPoland -1.713e+00 7.873e-01 -2.175 0.029597 *
## CountryPortugal -1.260e+00 8.880e-01 -1.419 0.155806
## CountryPuerto-Rico -1.911e+00 7.758e-01 -2.463 0.013772 *
## CountryScotland -1.344e+00 2.774e+00 -0.484 0.628081
## CountrySouth -3.052e+00 8.353e-01 -3.654 0.000259 ***
## CountryTaiwan -1.464e+00 9.297e-01 -1.574 0.115432
## CountryThailand -1.234e+00 1.103e+00 -1.119 0.263136
## CountryTrinadad&Tobago 2.850e-01 1.198e+00 0.238 0.811953
## CountryUnited-States -1.601e+00 6.836e-01 -2.341 0.019209 *
## CountryVietnam -1.047e+00 8.053e-01 -1.300 0.193481
## CountryYugoslavia -2.106e+00 8.862e-01 -2.377 0.017455 *
## WorkClass_recodePrivate NA NA NA NA
## WorkClass_recodeSelf_Employment NA NA NA NA
## WorkClass_recodeUnemployment NA NA NA NA
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 29270 on 21113 degrees of freedom
## Residual deviance: 16383 on 21042 degrees of freedom
## AIC: 16527
##
## Number of Fisher Scoring iterations: 12