R/social_increased_testing_selected_groups_module.R

In EvoNetHIV/Test_and_Treat: Evonet: Integrated Bio-Social Models for HIV Epidemiology

#' @title Title
#'
#' @description Description
#'
#' @param x A number.
#' @param y A number.
#' @return return value here.
#' @details
#' Additional details here
#' @examples
#' example function call here

#' @export
social_increased_testing_selected_groups_module <- function(dat, at){   
 
  #Description: Identifies agents who should be tested more frequently ("enhanced testing")
  #              based on a user-specified priority list (e.g., "high_risk", "under35", "random") 
  #Inputs: 
    # dat$param$scale_up_type  -- a list of people (e.g., "high_risk", "under35") targeted for enhanced testing 
    # dat$param$start_scale_up_campaign
    # dat$param$prob_enhanced_testing_after_campaign
    # Long list of agent-specific attributes (dat$pop vals) that could potentially be used as a basis for prioritizing people for testing and care
    #   Examples: att1 (risk group), CD4, STI, sex, age, total_acts, circum
  #Outputs: 
    # pop$enhanced_testing
  #Notes: If included, "random" needs to be the last element of the scale_up_type
  
  # Assume regular probability of testing in the absence of an intervention
  all_agents <- which(dat$pop$Status >= -10)
  dat$pop$enhanced_testing[all_agents] <- 0 # Zero out the list each day (to allow for evolving lists: e.g., people aging out of the enhanced testing group)

  if(at < dat$param$start_scale_up_campaign){return(dat)}
  
  # scale_up_type is a list of people (e.g., "high_risk", "under35") that one might target for enhanced testing 
  scale_up_strategy <- dat$param$scale_up_type[[1]]  # First convert into a non-subscripted list for ease of programming
  num_care_strategies <- length(scale_up_strategy) # length of the list 
  
  # Loop through the list of strategies in order
  for (j in 1:num_care_strategies) {
    
     # Identify living people who haven't been diagnosed and who aren't already getting tested at an enhanced rate
     not_curr_enhanced <- dat$pop$Status >= 0 &  dat$pop$diag_status %in% c(0,NA) & dat$pop$enhanced_testing %in% c(0,NA)
     eligible_enhancement <- NULL
    
    if (scale_up_strategy[j] == "AIDS")            eligible_enhancement <- not_curr_enhanced & dat$pop$CD4 == 4 # assume AIDS is recognizable
    if (scale_up_strategy[j] == "CD4_under200")    eligible_enhancement <- not_curr_enhanced & dat$pop$CD4 == 4 # same as AIDS
    if (scale_up_strategy[j] == "CD4_under350")    eligible_enhancement <- not_curr_enhanced & dat$pop$CD4 >= 3 # assume rapid CD4 test
    if (scale_up_strategy[j] == "CD4_under500")    eligible_enhancement <- not_curr_enhanced & dat$pop$CD4 >= 2 # assume rapid CD4 test
    
    if (scale_up_strategy[j] == "highrisk" ) eligible_enhancement <- not_curr_enhanced & dat$pop$att1 >= dat$param$attr_treatment_threshold
    if (scale_up_strategy[j] == "riskgroup_over2" ) eligible_enhancement <- not_curr_enhanced & dat$pop$att1 >= 2
    
    if (scale_up_strategy[j] == "STIs")        eligible_enhancement <- not_curr_enhanced & dat$pop$sti_status == 1
     
     if (scale_up_strategy[j] == "baserand")  eligible_enhancement <- not_curr_enhanced & (dat$pop$rand_prob_test_init < dat$param$prob_enhanced_testing_before_campaign)
     
     if (scale_up_strategy[j] == "random")  eligible_enhancement <- not_curr_enhanced
     
    
   if (scale_up_strategy[j] == "recent_sex_known_hiv_pos")   eligible_enhancement <- not_curr_enhanced & (at - dat$pop$time_hiv_sex_act <= 90)
    
    if (scale_up_strategy[j] == "circum")      eligible_enhancement <- not_curr_enhanced & dat$pop$circum == 1
    if (scale_up_strategy[j] == "not_circum")  eligible_enhancement <- not_curr_enhanced & dat$pop$circum == 0
    
    if (scale_up_strategy[j] == "men")         eligible_enhancement <- not_curr_enhanced & dat$pop$sex == "m"
    if (scale_up_strategy[j] == "women")       eligible_enhancement <- not_curr_enhanced & dat$pop$sex == "f"
 
    # The next three are only really applicable to MSM relationships
    if (dat$param$model_sex == "msm") {
      if (scale_up_strategy[j] == "insertive")  eligible_enhancement <- not_curr_enhanced & dat$pop$role == "I"
      if (scale_up_strategy[j] == "receptive")  eligible_enhancement <- not_curr_enhanced & dat$pop$role == "R"
      if (scale_up_strategy[j] == "versatile")  eligible_enhancement <- not_curr_enhanced & dat$pop$role == "V"
    }

    if (scale_up_strategy[j] == "under50")  eligible_enhancement <- not_curr_enhanced & dat$pop$age <= 45
    if (scale_up_strategy[j] == "under45")  eligible_enhancement <- not_curr_enhanced & dat$pop$age <= 45
    if (scale_up_strategy[j] == "under40")  eligible_enhancement <- not_curr_enhanced & dat$pop$age <= 40
    if (scale_up_strategy[j] == "under35")  eligible_enhancement <- not_curr_enhanced & dat$pop$age <= 35
    if (scale_up_strategy[j] == "under30")  eligible_enhancement <- not_curr_enhanced & dat$pop$age <= 30
    if (scale_up_strategy[j] == "under25")  eligible_enhancement <- not_curr_enhanced & dat$pop$age <= 25
    
    if (scale_up_strategy[j] == "under_max_age_over_min_age") {  # Target people of intermediate ages
           eligible_enhancement <- not_curr_enhanced & dat$pop$age > dat$param$min_age_recruit_for_care & dat$pop$age <= dat$param$max_age_recruit_for_care
           # Note: Although this is more general than "under50" etc., the fixed ones like "under50" are more useful for nested tests (so keep them)
    }
    
    if (scale_up_strategy[j] == "10acts")     eligible_enhancement <- not_curr_enhanced & dat$pop$total_acts >= 10
    if (scale_up_strategy[j] == "25acts")     eligible_enhancement <- not_curr_enhanced & dat$pop$total_acts >= 25
    if (scale_up_strategy[j] == "50acts")     eligible_enhancement <- not_curr_enhanced & dat$pop$total_acts >= 50
    if (scale_up_strategy[j] == "100acts")    eligible_enhancement <- not_curr_enhanced & dat$pop$total_acts >= 100
    if (scale_up_strategy[j] == "200acts")    eligible_enhancement <- not_curr_enhanced & dat$pop$total_acts >= 200
    if (scale_up_strategy[j] == "400acts")    eligible_enhancement <- not_curr_enhanced & dat$pop$total_acts >= 400
    if (scale_up_strategy[j] == "800acts")    eligible_enhancement <- not_curr_enhanced & dat$pop$total_acts >= 800
  
    if (scale_up_strategy[j] == "men_under45")  eligible_enhancement <- not_curr_enhanced & dat$pop$sex == "m" & dat$pop$age <= 45
    if (scale_up_strategy[j] == "men_under40")  eligible_enhancement <- not_curr_enhanced & dat$pop$sex == "m" & dat$pop$age <= 40
    if (scale_up_strategy[j] == "men_under35")  eligible_enhancement <- not_curr_enhanced & dat$pop$sex == "m" & dat$pop$age <= 35
    if (scale_up_strategy[j] == "men_under30")  eligible_enhancement <- not_curr_enhanced & dat$pop$sex == "m" & dat$pop$age <= 30
    if (scale_up_strategy[j] == "men_under25")  eligible_enhancement <- not_curr_enhanced & dat$pop$sex == "m" & dat$pop$age <= 25
    
    if (scale_up_strategy[j] == "women_under45")  eligible_enhancement <- not_curr_enhanced & dat$pop$sex == "f" & dat$pop$age <= 45
    if (scale_up_strategy[j] == "women_under40")  eligible_enhancement <- not_curr_enhanced & dat$pop$sex == "f" & dat$pop$age <= 40
    if (scale_up_strategy[j] == "women_under35")  eligible_enhancement <- not_curr_enhanced & dat$pop$sex == "f" & dat$pop$age <= 35
    if (scale_up_strategy[j] == "women_under30")  eligible_enhancement <- not_curr_enhanced & dat$pop$sex == "f" & dat$pop$age <= 30
    if (scale_up_strategy[j] == "women_under25")  eligible_enhancement <- not_curr_enhanced & dat$pop$sex == "f" & dat$pop$age <= 25
 
    # If the number of newly enhanced people exceeds the target, randomly sample from the list of eligibles for enhancement
    if (length(which(eligible_enhancement==TRUE)) >= 1) {
      # Count number of possible people who could be subject to enhanced testing using the criteria above
      if (is.null(eligible_enhancement)) {
        num_eligible_enhancement <- 0 
      } else {
        num_eligible_enhancement <- length(which(eligible_enhancement==TRUE))
      }    
      # Determine upper limit to the percentage of the population that can be tested 
      if (dat$param$testing_limit == "percent_agents") {
        upper_limit_enhanced_testing <- round(length(which(dat$pop$Status >= 0))*dat$param$prob_enhanced_testing_after_campaign)
      }
      
      if (dat$param$testing_limit == "percent_agents_minus_diagnosed") {
        upper_limit_enhanced_testing <- round(  length(which(dat$pop$Status >= 0))*dat$param$prob_enhanced_testing_after_campaign 
                                              - length(which(dat$pop$diag_status==1)) )
      }
      # Determine number who are already being tested more frequently 
      current_enhanced_testing <- length(which(dat$pop$Status >= 0 & dat$pop$diag_status==1))
      
      # Increase number tested until we get to the desired diagnosed and/or enhanced testing
      max_enhanced_testing <- max(0,upper_limit_enhanced_testing - current_enhanced_testing)
     
     if (num_eligible_enhancement <= max_enhanced_testing) {
        # Enhance testing of all eligibles
        selected <- eligible_enhancement
        dat$pop$enhanced_testing[selected] <- 1  
      } else {
        # Limit enhanced testing to stay under the maximum
        which_eligible_enhancement <- which(eligible_enhancement==TRUE)
        weight_eligible_enhancement <- dat$pop$rand_prob_test[which_eligible_enhancement]
        selected <- which_eligible_enhancement[which(rank(weight_eligible_enhancement)<=max_enhanced_testing)]
        dat$pop$enhanced_testing[selected] <- 1
      }
      last_ever_enhanced_testing <- dat$pop$ever_enhanced_testing
      dat$pop$ever_enhanced_testing[selected] <- 1
      #if (length(setdiff(which(dat$pop$ever_enhanced_testing==1),which(last_ever_enhanced_testing==1)))>0) {
      #  cat("\nsetdiff: ",setdiff(which(dat$pop$ever_enhanced_testing==1),which(last_ever_enhanced_testing==1)),"\n")
      #}
    } # At least one eligible in j-th strategy
  } # j-th strategy
  return(dat)
}