Psi Chi R - Feb 2025

Start Date: 23 Feb 2025

Report Date: 28 February 2025

Source: Psi Chi R

knitr::opts_chunk$set(echo = T,message = F,warning = F)

#setwd("C:/Users/alanh/Documents/R/Psi_Chi_R")

rm(list=ls())

setwd("~/R/Psi_Chi_R")

library(tidyverse)

#total for bottom row
sum_rows = function(x) {
  x = as.data.frame(x)
  sums = sapply(x,function(col) if (is.numeric(col)) sum(col, na.rm = T) else NA)
  sums = as.data.frame(t(sums))
  names(sums) = names(x)
  rbind(x, sums)
}

## right column for total
sum_cols = function(x) {
  x$Total = rowSums(x[sapply(x, is.numeric)], na.rm = T)
  x
}

#dollar format function
dollars = function(x) {
  paste0("$",format(x,big.mark= ",",scientific=F))
}

desc_stats = function(x){
  c(min = min(x,na.rm=T),
    mode = mode(x,na.rm=T),
    median = median(x,na.rm=T),
    max = max(x,na.rm=T),
    mean = mean(x,na.rm=T),
    sd = sd(x,na.rm=T))
}

#remove upper outliers
upper_fence = function(x){
  quantile(x,.75) + (1.5*IQR(x))
}

#remove lower outliers
lower_fence = function(x){
  quantile(x,.25) - (1.5*IQR(x))
}

Clean and EDA

data=read_csv('data.csv')

names(data) = make.names(colnames(data))

SmartEDA::ExpData(data,type=2) %>% 
  arrange(desc(Per_of_Missing))

Your tasks for the PsiChiR contest for Feb. 2025 include:

Level 1:

Remove participants outside of the United States AND participants who are not identified as “white” (white participants are coded as “1” for the variable “Race”).

data1 = data %>% 
  filter(VGeoCountry == 'United States',
         Race == '1') %>% 
  tibble()

Level 2:

For the remaining participants, calculate the percentage of participants who fell into each income category (1 through 5).

data1_table = data1 %>% 
  mutate(Income = as.character(Income)) %>% 
  group_by(Income) %>% 
  summarise(headcount = n()) %>% 
  mutate(percent = headcount/sum(headcount,na.rm = T) * 100) %>%
  arrange(desc(percent)) %>% 
  sum_rows() %>% 
  mutate(percent = paste(round(percent,2),"%"))

print(data1_table)

##   Income headcount percent
## 1      2       179 27.93 %
## 2      3       163 25.43 %
## 3      1       119 18.56 %
## 4      4       111 17.32 %
## 5      5        69 10.76 %
## 6   <NA>       641   100 %

Level 3:

Create a graph (such as a bar graph) that displays the M and SD for “General Support for Affirmative Action” (variable = “AA”) across income groups.

#M for median
data1.5 = data1 %>% 
  group_by(Income) %>% 
  summarise(Mean = mean(AA,na.rm = T),
            Median = median(AA,na.rm=T),
            SD = sd(AA,na.rm=T))

data1.5 %>% 
  ggplot(aes(x=Income,y=Median))+
  geom_col(fill='darkblue')+
  theme_bw()+
  labs(title='Median of AA by Income')+
  theme(plot.title = element_text(hjust = .5))

data1.5 %>% 
  ggplot(aes(x=Income,y=SD))+
  geom_col(fill='darkred')+
  theme_bw()+
  labs(title='Standard Deviation of AA by Income')+
  theme(plot.title = element_text(hjust = .5))

Level 4:

Test whether “General Support for Affirmative Action” (variable = “AA”) differs across income group.

data1 %>% 
  ggplot(aes(x=Income,y=AA))+
  geom_col(fill='darkgreen')+
  theme_bw()+
  labs(x='Income Group',y='Affirmative Action Support',title="Affirmative Action Across the Income-verse")+
  theme(plot.title = element_text(hjust = .5))

#non-normality
shapiro.test(data1$Income)

## 
##  Shapiro-Wilk normality test
## 
## data:  data1$Income
## W = 0.905, p-value < 2.2e-16

shapiro.test(data1$AA)

## 
##  Shapiro-Wilk normality test
## 
## data:  data1$AA
## W = 0.96283, p-value = 1.156e-11

hist(data1$Income)

hist(data1$AA)

#yes, support for AA differs among income group
wilcox.test(data1$Income,data1$AA)

## 
##  Wilcoxon rank sum test with continuity correction
## 
## data:  data1$Income and data1$AA
## W = 89259, p-value < 2.2e-16
## alternative hypothesis: true location shift is not equal to 0