Fix repeated flagged runs

swap_duplicate_runs.r

# Step 1: Identify Binary and Rare Trials
bi_index <- which(curr_block$option_left == 2 | curr_block$option_right == 2)  # Binary option trial indices
rare_index <- which(curr_block$is_rare == 1)  # Rare outcome trial indices

# Step 2: Find Positions of Rare Outcomes within Binary Trials
idx_rare_in_bi <- match(rare_index, bi_index)  # Positions of rare outcomes in binary trials
diff_rare_in_bi <- diff(idx_rare_in_bi)  # Differences between consecutive rare outcomes

# Step 3: Identify Consecutive Rare Outcomes
if (any(diff_rare_in_bi == 1)) {  # Check for consecutive rare outcomes
    pairs_position_bi <- which(diff_rare_in_bi == 1) + 1  # Positions of second trials in consecutive pairs
    pairs_index <- bi_index[idx_rare_in_bi[pairs_position_bi]]  # Actual indices of second trials in pairs
} else {
    pairs_index <- NULL  # No pairs to process
}

# Step 4: Prepare List of Binary Trials Available for Swapping
if (!is.null(pairs_index)) {
    # Find positions of pairs_index in bi_index.
    # eg bi_index <- c(2, 5, 8, 11, 14, 17, 20, 23, 26, 29)
    #    pairs_index <- c(5, 8)
    #    which(bi_index %in% pairs_index) -> c(2, 3)
    pairs_index_positions <- which(bi_index %in% pairs_index)
    
    # Function to get adjacent indices for a given index
    get_adjacent_indices <- function(vec, index) {
        start <- max(1, index - 1)  # Ensure start is not less than 1
        end <- min(length(vec), index + 1)  # Ensure end is not more than length of vector
        return(start:end)  # Return range of indices
    }
    
    # Function to get all indices to remove, including adjacent indices
    get_indices_to_remove <- function(vec, indices) {
        to_remove <- c()  # Initialize empty vector to collect indices
        for (i in indices) {  # Iterate over each index
            to_remove <- c(to_remove, get_adjacent_indices(vec, i))  # Append adjacent indices
        }
        return(unique(to_remove))  # Return unique set of indices to remove
    }
    
    # Function to remove specified indices from a vector
    remove_indices <- function(vec, indices) {
        return(vec[-indices])  # Return the vector with specified indices removed
    }
    
    initial_indices_to_remove <- get_indices_to_remove(bi_index, pairs_index_positions)  # Initial indices to remove
    bi_index_swap_allowed <- remove_indices(bi_index, initial_indices_to_remove)  # Remove these indices
    
    # Avoid edge cases by removing first and last two trials
    bi_index_swap_allowed <- head(tail(bi_index_swap_allowed, -2), -2)
    
    # Check if we have enough trials available for swapping
    if (length(bi_index_swap_allowed) < length(pairs_index)) {
        stop("Not enough trials available for swapping.")
    }
    
    # Pre-compute swap list
    swap_list <- list()
    for (i in seq_along(pairs_index)) {
        if (length(bi_index_swap_allowed) == 0) stop("Not enough trials available for swapping.")
        
        swap_position <- sample(length(bi_index_swap_allowed), 1)  # Randomly select a trial to swap with
        swap_index <- bi_index_swap_allowed[swap_position]
        
        # Add the swap to the list
        swap_list[[i]] <- list(pair_index = pairs_index[i], swap_index = swap_index)
        
        # Update swappable indices by removing the swapped index and its adjacent indices
        adjacent_indices_to_remove <- get_adjacent_indices(bi_index_swap_allowed, swap_position)
        bi_index_swap_allowed <- remove_indices(bi_index_swap_allowed, adjacent_indices_to_remove)
    }
    
    # Step 5: Perform all swaps
    for (swap_pair in swap_list) {
        pair_index <- swap_pair$pair_index
        swap_index <- swap_pair$swap_index
        
        # Swap the trials
        curr_block[c(pair_index, swap_index), ] <- curr_block[c(swap_index, pair_index), ]
    }
}

Original Code

# Look for suitable trials to switch with
bi_index_swap <- bi_index
for (num in rare_index) {
  if (num %in% bi_index_swap) {
    index <- which(bi_index_swap == num)
    if (index == 1) {
      bi_index_swap <- bi_index_swap[-c(index, index + 1)]
    } else if (index == length(bi_index_swap)) {
      bi_index_swap <- bi_index_swap[-c(index - 1, index)]
    } else {
      bi_index_swap <- bi_index_swap[-c(index - 1, index, index + 1)]
    }
  }
}

This fails:

• Removing elements in each iteration shifts the indices of remaining elements, causing incorrect identification and removal of subsequent elements.

• Close rare trials lead to multiple and incorrect removals, resulting in an invalid list of trials for swapping.

# Example data setup
curr_block <- data.frame(
  option_left = c(1, 2, 2, 1, 2, 2, 2, 1, 2, 2),
  option_right = c(2, 1, 1, 2, 1, 1, 1, 2, 1, 1),
  is_rare = c(0, 0, 1, 0, 1, 1, 0, 0, 0, 1)
)
bi_index <- which(curr_block$option_left == 2 | curr_block$option_right == 2)  # [1, 2, 3, 5, 6, 7, 9, 10]
rare_index <- which(curr_block$is_rare == 1)  # [3, 5, 6, 10]

# Identify consecutive rare outcomes
idx_rare_in_bi <- match(rare_index, bi_index)  # [3, 4, 5, 8]
diff_rare_in_bi <- diff(idx_rare_in_bi)        # [1, 1, 3]
pairs_position_bi <- which(diff_rare_in_bi == 1) + 1  # [2, 3]
pairs_index <- bi_index[idx_rare_in_bi[pairs_position_bi]]  # [5, 6]

# Remove adjacent trials
bi_index_swap_allowed <- bi_index  # [1, 2, 3, 5, 6, 7, 9, 10]
for (pair_i in pairs_index) {
  index_to_remove <- which(bi_index_swap_allowed == pair_i)
  bi_index_swap_allowed <- remove_adjacent(bi_index_swap_allowed, index_to_remove)
}

# Example iterations
# First iteration (pair_i = 5):
# index_to_remove <- which(bi_index_swap_allowed == pair_i)  # which([1, 2, 3, 5, 6, 7, 9, 10] == 5) gives: [4]
# bi_index_swap_allowed <- remove_adjacent(bi_index_swap_allowed, index_to_remove)  # Removes 3, 4, 5
# bi_index_swap_allowed becomes: [1, 2, 7, 9, 10]

# Second iteration (pair_i = 6):
# index_to_remove <- which(bi_index_swap_allowed == pair_i)  # which([1, 2, 7, 9, 10] == 6) gives: integer(0)
# bi_index_swap_allowed <- remove_adjacent(bi_index_swap_allowed, index_to_remove)  # No removal occurs
# bi_index_swap_allowed remains: [1, 2, 7, 9, 10]
# This is obviously not the intended result

Proposed Fix

• Insteaed of modifying the list of indices in each iteration, we can identify the indices to remove and remove them in a single step. This avoids all of the above.

    if (index == 1) {
        bi_index_swap <- bi_index_swap[-c(index, index + 1)]
    } else if (index == length(bi_index_swap)) {
        bi_index_swap <- bi_index_swap[-c(index - 1, index)]
    } else {
      bi_index_swap <- bi_index_swap[-c(index - 1, index, index + 1)]
    }

We rewrite the above code into a function that will return adjacent indices. Note we use the name index and position interchangeably. https://www.karlton.org/2017/12/naming-things-hard/

    get_adjacent_indices <- function(vec, index) {
        start <- max(1, index - 1)  # Ensure start is not less than 1
        end <- min(length(vec), index + 1)  # Ensure end is not more than length of vector
        return(start:end)  # Return range of indices
    }

This function is also used in the second half of the code again to find adjacent indices. We can wrap this function with something that gets all adjacent indices:

    get_indices_to_remove <- function(vec, indices) {
        to_remove <- c()  # Initialize empty vector to collect indices
        for (i in indices) {  # Iterate over each index
            to_remove <- c(to_remove, get_adjacent_indices(vec, i))  # Append adjacent indices
        }
        return(unique(to_remove))  # Return unique set of indices to remove
    }