E4
Zhicheng Zhong
2024-04-06
Load packages
Same data processing as E3. infer race, gender and tenure days from the data.
Obtain examiner attributes and join it to the edge dataset. In the edge dataset, there exist observations whose ego and alter examiner id are the same. This time I filtered them out before proceeding with the analysis
Plotting the graphs this time, there’s no arrow going from one node to itself.Same observation as E3 that white examiners are more connected with each other through clusters than black and Asian examiners
# Set vertex colors based on gender
vertex_colors <- ifelse(V(g)$gender == "Female", "pink", "gray")
for(r in unique(applications$race)){
# Subset the graph to include only vertices in work units 161 and 249
g_sub <- induced_subgraph(g, V(g)$race %in% c(r))
# Plot the subgraph using igraph
plot(g_sub, vertex.label = NA, vertex.color = vertex_colors[V(g_sub)], vertex.size = 5,
edge.arrow.size = 0.5, edge.width = 0.5, layout = layout_with_fr)
title(r)
}
Male examiners are more connected to one another than female examiners.Female examiners have a highly centralized cluster that excludes the peripheral nodes.
vertex_colors <- ifelse(V(g)$race == "white", "pink",
ifelse(V(g)$race == "asian", "yellow",
ifelse(V(g)$race == "black", "brown",
ifelse(V(g)$race == "hispanic", "orange", "gray"))))
for(r in unique(examiner_attrs$gender)){
# Subset the graph to include only vertices in work units 161 and 249
g_sub <- induced_subgraph(g, V(g)$gender %in% c(r))
# Plot the subgraph using igraph
plot(g_sub, vertex.label = NA, vertex.color = vertex_colors[V(g_sub)], vertex.size = 5,
edge.arrow.size = 0.5, edge.width = 0.5, layout = layout_with_fr)
title(r)
}
Calculate and degree and betweenness for the network and join it to examiner attributes. Repeating the correlation calculation as in E3, tenure days and betweenness are positively correlated.
cor_matrix <- cor(selected_centrality_scores[, c("degree", "betweenness","tenure")])
print(cor_matrix)## degree betweenness tenure
## degree 1.000000000 0.21610408 -0.007875468
## betweenness 0.216104080 1.00000000 0.015947141
## tenure -0.007875468 0.01594714 1.000000000heatmap(
cor_matrix,
Rowv = NA,
Colv = NA,
col = colorRampPalette(c("white", "darkred"))(25),
margins = c(15, 10)
)
Join the centrality score to applications and process the merged dataset to obtain processing time. As degree, betweeness are right skewed, a log transformation and smoothing of negative infinite were applied first
hist(centrality$degree)
hist(centrality$betweenness)
centrality <- centrality %>% mutate(log_degree = log(degree), log_betweenness = log(betweenness))%>%
mutate(
log_degree = replace(log_degree, log_degree == -Inf, 0),
log_betweenness = replace(log_betweenness, log_betweenness == -Inf, 0)
)Since tenure days and centrality are in different measures, they are standardized before the regression analysis.
applications_mutated <- applications %>%
mutate(app_proc_time_issue = patent_issue_date - filing_date,
app_proc_time_abandon = abandon_date - filing_date) %>%
mutate(app_pro_time = ifelse(is.na(app_proc_time_issue),
app_proc_time_abandon, app_proc_time_issue)) %>%
filter(app_pro_time > 0) %>%
select(app_pro_time, gender, race, tenure_days, log_degree, log_betweenness) %>%
drop_na() %>%
mutate(log_degree = (log_degree - mean(log_degree)) / sd(log_degree),
log_betweenness = (log_betweenness - mean(log_betweenness)) / sd(log_betweenness),
tenure_days = (tenure_days - mean(tenure_days)) / sd(tenure_days))Runing two regression models, one based on siloed variables, the other including interaction terms
model_1 <- lm(app_pro_time ~ log_degree + log_betweenness +
gender + race + tenure_days, data = applications_mutated)
model_2 <- lm(app_pro_time ~ log_degree + log_betweenness +
gender + race + tenure_days +
log_degree:gender +
log_betweenness:gender + tenure_days:gender +
log_degree:race + log_betweenness:race + tenure_days:race, data = applications_mutated)Based on model1, we can draw the following conclusion: - Higher degree and betweenness centrality increase the processing time (people can ask for lots of advice) - Gender difference in processing time is statistically insignificant - Compared to Asian, examiners of other races tend to take less time to process - tenure days irrelevant to processing time
model_1##
## Call:
## lm(formula = app_pro_time ~ log_degree + log_betweenness + gender +
## race + tenure_days, data = applications_mutated)
##
## Coefficients:
## (Intercept) log_degree log_betweenness genderMale
## 1238.43 49.24 17.77 35.42
## raceblack racehispanic racewhite tenure_days
## -73.58 -47.73 -105.87 18.43summary(model_1)##
## Call:
## lm(formula = app_pro_time ~ log_degree + log_betweenness + gender +
## race + tenure_days, data = applications_mutated)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1276.9 -413.7 -109.7 263.0 4069.6
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 1238.430 24.267 51.033 < 2e-16 ***
## log_degree 49.242 10.494 4.692 2.79e-06 ***
## log_betweenness 17.768 10.397 1.709 0.08753 .
## genderMale 35.421 22.208 1.595 0.11080
## raceblack -73.584 26.816 -2.744 0.00609 **
## racehispanic -47.732 46.587 -1.025 0.30562
## racewhite -105.872 23.893 -4.431 9.61e-06 ***
## tenure_days 18.432 9.986 1.846 0.06500 .
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 630.7 on 4162 degrees of freedom
## Multiple R-squared: 0.01467, Adjusted R-squared: 0.01301
## F-statistic: 8.853 on 7 and 4162 DF, p-value: 7.396e-11Based on model1, we can draw the following conclusion: - Higher degree centrality increase the processing time (people can ask for lots of advice) - Male examiner with high betweeness take longer to prorcess applications - Compared to Asian, examiners of other races tend to take less time to process - White examiner with high degree centrality takes less time than asian counterparts - Examiners that have longer tenure days may take more time to process applications - However,white and hispanic examiner with long tenure days take less time than asains
model_2##
## Call:
## lm(formula = app_pro_time ~ log_degree + log_betweenness + gender +
## race + tenure_days + log_degree:gender + log_betweenness:gender +
## tenure_days:gender + log_degree:race + log_betweenness:race +
## tenure_days:race, data = applications_mutated)
##
## Coefficients:
## (Intercept) log_degree
## 1245.913 37.012
## log_betweenness genderMale
## 2.561 31.518
## raceblack racehispanic
## -72.595 -74.963
## racewhite tenure_days
## -109.310 22.207
## log_degree:genderMale log_betweenness:genderMale
## 8.080 6.701
## genderMale:tenure_days log_degree:raceblack
## 30.052 -7.963
## log_degree:racehispanic log_degree:racewhite
## 116.661 4.621
## log_betweenness:raceblack log_betweenness:racehispanic
## 43.483 -76.777
## log_betweenness:racewhite raceblack:tenure_days
## 5.273 -50.959
## racehispanic:tenure_days racewhite:tenure_days
## -124.108 -20.811summary(model_2)##
## Call:
## lm(formula = app_pro_time ~ log_degree + log_betweenness + gender +
## race + tenure_days + log_degree:gender + log_betweenness:gender +
## tenure_days:gender + log_degree:race + log_betweenness:race +
## tenure_days:race, data = applications_mutated)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1437.4 -410.2 -110.2 264.5 4095.8
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 1245.913 24.584 50.680 < 2e-16 ***
## log_degree 37.012 26.303 1.407 0.15945
## log_betweenness 2.561 25.738 0.099 0.92075
## genderMale 31.518 22.464 1.403 0.16067
## raceblack -72.595 26.999 -2.689 0.00720 **
## racehispanic -74.963 48.486 -1.546 0.12216
## racewhite -109.310 23.967 -4.561 5.24e-06 ***
## tenure_days 22.207 24.362 0.912 0.36208
## log_degree:genderMale 8.080 25.006 0.323 0.74663
## log_betweenness:genderMale 6.701 25.909 0.259 0.79593
## genderMale:tenure_days 30.052 23.123 1.300 0.19379
## log_degree:raceblack -7.963 27.682 -0.288 0.77363
## log_degree:racehispanic 116.661 44.450 2.625 0.00871 **
## log_degree:racewhite 4.621 25.969 0.178 0.85877
## log_betweenness:raceblack 43.483 28.680 1.516 0.12955
## log_betweenness:racehispanic -76.777 80.212 -0.957 0.33853
## log_betweenness:racewhite 5.273 23.691 0.223 0.82390
## raceblack:tenure_days -50.959 27.046 -1.884 0.05962 .
## racehispanic:tenure_days -124.108 45.322 -2.738 0.00620 **
## racewhite:tenure_days -20.811 23.957 -0.869 0.38506
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 629.9 on 4150 degrees of freedom
## Multiple R-squared: 0.01994, Adjusted R-squared: 0.01545
## F-statistic: 4.444 on 19 and 4150 DF, p-value: 4.139e-10