Search code examples
rfor-loopif-statementcircular-dependencycircular-list

Reassigning positions in directional (circular) data using R


I have buckets arranged circularly (labelled pos 1 - 6). A monkey stands at the center and randomly throw stones in each bucket (inf) in three independent trials (sets).

The goal here is to first identify the highest number of stones thrown in the bucket in a particular set. Once identified, the bucket with the highest stones gets assigned the new position (expected_pos) of '1'. Then I need to compare the bucket to the left and right of it to identify which had the second highest number of stones. That bucket gets assigned position '2'. This determines the direction to assign new position for the rest of the buckets. I was able to get to two aspects of it -- finding the maximum from inf and the second highest positions pos2. I really need help with the last part, i.e. assigning new positions for the rest of the buckets. In this dummy dataset I have inserted a column 'expected_pos' that denotes the expected results.

#Dataset
set <- c(1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3)
pos <- c(1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6)
inf <- c(1000,200,3,4,5,6,1,2,3,4,500,6000,1,2,300,4000,5,6)
expected_pos <- c(1,2,3,4,5,6,6,5,4,3,2,1,4,3,2,1,6,5)

df <- data.frame(set,pos,inf, expected_pos)

#Finding the maximum
library(dplyr)
result_df <- df %>%
   group_by(set) %>%
   mutate(result = (inf == max(inf)))
   result_vec <- result_df[which(result_df$result),c(1,2,3)]

  #Finding second highest position
pos1 <- result_vec
pos2 <- array(NA,dim=c(3,3))
   for(i in 1:3)     
   {   
   if(pos1[i,2]==1) pos2[i,c(2,3)] <- c(which(result_df$inf[((i-1)*6+1):((i-1)*6+6)]==max(c(result_df$inf[(i-1)*6+2],result_df$inf[(i-1)*6+6]))),max(c(result_df$inf[(i-1)*6+2],result_df$inf[(i-1)*6+6]))) #Position 2, 6

  if(pos1[i,2]==6) pos2[i,c(2,3)] <- c(which(result_df$inf[((i-1)*6+1):((i-1)*6+6)]==max(c(result_df$inf[(i-1)*6+1],result_df$inf[(i-1)*6+5]))), max(c(result_df$inf[(i-1)*6+1],result_df$inf[(i-1)*6+5]))) #Position 5, 1

  if(pos1[i,2] %in% c("2","3","4","5")) pos2[i,c(2,3)] <- c(which(result_df$inf[((i-1)*6+1):((i-1)*6+6)]==max(c(result_df[result_df$set == as.numeric(pos1[i,1]) & result_df$pos == as.numeric(pos1[i,2]-1),]$inf, result_df[result_df$set == as.numeric(pos1[i,1]) & result_df$pos == as.numeric(pos1[i,2]+1),]$inf))), max(c(result_df[result_df$set == as.numeric(pos1[i,1]) & result_df$pos == as.numeric(pos1[i,2]-1),]$inf, result_df[result_df$set == as.numeric(pos1[i,1]) & result_df$pos == as.numeric(pos1[i,2]+1),]$inf)))
  #Position above or below the focal number pos1
   }

Solution

  • Not sure if I have over-complicated the solution but you can try

    bucket_direction <- function(x, y) {
       order_pos <- order(x, decreasing = TRUE)
       first_pos <- y[order_pos[1L]]
       second_pos <- y[order_pos[2L]]
       if (second_pos < first_pos) {
         temp <- max(order_pos) - first_pos
         c(first_pos:1, rep(max(order_pos), temp) - seq_len(temp) + 1)
        }
        else {
         temp <- first_pos - min(order_pos)
         c(first_pos:6, rep(min(order_pos), temp) + seq_len(temp) - 1)
      }
    }
    

    and then apply the function for each set

    library(dplyr)
    df %>% group_by(set) %>% mutate(res = bucket_direction(inf, pos))
    
    #    set   pos   inf expected_pos   res
    #   <dbl> <dbl> <dbl>        <dbl> <dbl>
    # 1     1     1  1000            1     1
    # 2     1     2   200            2     2
    # 3     1     3     3            3     3
    # 4     1     4     4            4     4
    # 5     1     5     5            5     5
    # 6     1     6     6            6     6
    # 7     2     1     1            6     6
    # 8     2     2     2            5     5
    # 9     2     3     3            4     4
    #10     2     4     4            3     3
    #11     2     5   500            2     2
    #12     2     6  6000            1     1
    #13     3     1     1            4     4
    #14     3     2     2            3     3
    #15     3     3   300            2     2
    #16     3     4  4000            1     1
    #17     3     5     5            6     6
    #18     3     6     6            5     5