Absorbing Markov Chains

Instructions

We are given a dataset with information regarding 500 individuals and their state transition status within the justice system.

• The dataset tracks 500 individuals over a maximum of 5 time periods, recording their state transitions within the justice system.
• Individuals start as either law-abiding citizens (No Record) or First-Time Offenders.
• As time progresses, they move through different states (probation, prison, reformation, life sentence) based on realistic transition probabilities.
• If an individual reaches Reformed Citizen or Life Sentence, they exit the system (absorbing states).

Steps to Complete the Assignment

• Identify all the states
• Extract the Transition Probability Matrix
• Compute Absorption Probabilities
• Interpret the results:
  What % of first-time offenders eventually become reformed vs. end up in life sentence?
  On average, how many steps (years) does it take for someone to exit the justice system?
  If someone proposes a new policy that improves the system how can you prove its effectiveness?
  

Load relevant libraries

library(matlib)
library(ggplot2)

Read the data

read.csv('JusticeDataset.csv')->data
head(data)

Identify all the states

Extract states and print them

states <- unique(c(unique(data$Current_State), unique(data$Next_State)))
print(states)

[1] "Citizen (No Record)" "First-Time Offender" "Long-Term Prison"   
[4] "Probation/Parole"    "Short-Term Prison"   "Reformed Citizen"   
[7] "Life Sentence"      

Extract the transition probability matrix

mat <- matrix(NA, nrow = length(states), ncol = length(states))


for(i in 1:length(states)){

  for(j in 1:length(states)){

      mat[i,j] <- sum(data$Current_State == states[i] & data$Next_State == states[j])

  }


}

Define absorbing states and set the probability of staying in those states to 1 manually

absorbing_states <- c("Reformed Citizen", "Life Sentence")
absorbing.idx.vect <- which(states %in% absorbing_states)
for(state.idx in absorbing.idx.vect){
  mat[state.idx, state.idx]<-1
}

mat <- mat/rowSums(mat)

This is the transition probability matrix

mat

          [,1]       [,2]      [,3]      [,4]      [,5]      [,6]      [,7]
[1,] 0.9728507 0.02714932 0.0000000 0.0000000 0.0000000 0.0000000 0.0000000
[2,] 0.0000000 0.00000000 0.0640000 0.4560000 0.2160000 0.2640000 0.0000000
[3,] 0.0000000 0.00000000 0.3333333 0.0000000 0.0000000 0.5454545 0.1212121
[4,] 0.0000000 0.00000000 0.1111111 0.1666667 0.2638889 0.4583333 0.0000000
[5,] 0.0000000 0.00000000 0.2340426 0.2765957 0.1914894 0.2978723 0.0000000
[6,] 0.0000000 0.00000000 0.0000000 0.0000000 0.0000000 1.0000000 0.0000000
[7,] 0.0000000 0.00000000 0.0000000 0.0000000 0.0000000 0.0000000 1.0000000

Compute absorption probabilities

R <- mat[1:5, 6:7]
Q <- mat[1:5, 1:5]
absorption.probs <- inv(diag(5)-Q)%*%R
absorption.probs

          [,1]       [,2]
[1,] 0.9526840 0.04731601
[2,] 0.9526840 0.04731601
[3,] 0.8181818 0.18181818
[4,] 0.9541206 0.04587935
[5,] 0.9316729 0.06832715

Interpretation

print(paste0('The percentage of first time offenders that eventually become a reformed citizen is: ', absorption.probs[2,1]*100, ' %'))

[1] "The percentage of first time offenders that eventually become a reformed citizen is: 95.2683991462766 %"

print(paste0('The percentage of first time offenders that eventually get a life sentence is: ', absorption.probs[2,2]*100, ' %'))

[1] "The percentage of first time offenders that eventually get a life sentence is: 4.73160133333333 %"

time.period.reformed <- data[data$Next_State=='Reformed Citizen',]$Time_Period+1
time.period.life.sentence <- data[data$Next_State=='Life Sentence',]$Time_Period+1

ggplot()+geom_density(aes(time.period.reformed, color='reformed'), size=1.3)+
  geom_density(aes(time.period.life.sentence, color='life sentence'),size=1.3)+
  theme(
    panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    panel.background = element_blank(),
    axis.line = element_line(colour = "black"),
    plot.title = element_text(hjust = 0.5, size = 20),
    axis.text = element_text(size = 15),
    text = element_text(size = 18)
  )+
  scale_color_manual(values=c('reformed'='darkred', 'life sentence'='navy'))+
  labs(colour="Absorbing state", x='Time period', y='Density')

print(paste0('The average time it takes for a person to exit the justice system reformed is ', round(mean(time.period.reformed), 3), ' \n'))

[1] "The average time it takes for a person to exit the justice system reformed is 2.622 \n"

print(paste0('The average time it takes for a person to exit the justice system reformed is ', round(mean(time.period.life.sentence), 3)))

[1] "The average time it takes for a person to exit the justice system reformed is 4.75"

If someone proposes a new policy that improves the system, we can evaluate its effectiveness by running similar analysis. We can assess whether the policy decreases the mean absorption time to the reformed state for people in the Markov chain system or whether the number of people that get absorbed to the reformed state increases.