Switch rows in data.table to create uniform variable

user_11339429 0
Viewed 93

I want to write a script to help me distribute piglets over pens while maintaining a similar average weight between pens by switching animals (rows) between pens to achieve this, but only switching piglets which have the same mother (i.e. the same sowid). So far I got the following script which leads to some improvement but I suspect it is not the optimal algorithm to achieve this goal. Any better ideas?

    test <- data.table(sowid=c(12,23,25,45,65,12,58,85,96,85,45,23),pen=c(1,1,1,1,2,2,2,2,3,3,3,3),pigletid=c(1,2,3,4,5,6,7,8,9,10,11,12),weight=c(6.5,5.9,6.2,5.8,7.5,7.2,7.8,6.9,9.5,10.2,9.8,6.4))

count <- 0
switch <- c(0,0)
cutoff <- 0.1

while(count == 0){
  meanPP <- test [,mean(weight),.(pen)]
  names(meanPP) <- c("pen","Mean")
  meanPP <- meanPP[order(Mean)]

  if (max(meanPP$Mean) - min(meanPP$Mean) <= cutoff){
    test <- test[order(pen)]
    count <- count + 1
  }else{
    count2 <- 0
    i <- 0
    while (count2 == 0 & i <= nrow(meanPP)){
      maxH <- meanPP$pen[nrow(meanPP)-i] 
      for (j in (nrow(test)/nrow(meanPP)):1){
        maxA <- test[pen==maxH]
        maxA <- maxA[order(weight)]$pigletid[j]
        if ((test$sowid[which(test$pigletid == maxA)] %in% test$sowid[-which(test$pigletid == maxA)]) && test[sowid == test$sowid[which(test$pigletid == maxA)],min(weight)] < test[pigletid == maxA,weight]){
          maxA <- which(test$pigletid == maxA)
          count2 <- count2 +1
          break
        }
      }
      i <- i + 1
    }

    for (i in 1:nrow(meanPP)) {
      minH <- meanPP$pen[i]
      minA <- test[pen==minH]
      if (test$sowid[maxA] %in% minA$sowid && minA[sowid==test$sowid[maxA]]$weight < test$weight[maxA]){
        minA <- minA[sowid==test$sowid[maxA]]
        minA <- minA[sowid==test$sowid[maxA]]$pigletid
        minA <- which(test$pigletid == minA)
        break
      }
    }

    if (minA == switch[2] & maxA == switch[1]){
      count <- count +1
    }

    switch <- c(minA,maxA)

    tempRow <- test$pen[maxA]
    test$pen[maxA] <- test$pen[minA]
    test$pen[minA] <- tempRow

    test <- test[order(pen)]
  }
}

In response to Anurag N. Sharma, I would like output something like this:

> test
    sowid pen pigletid weight
 1:    25   1        3    6.2
 2:    45   1       11    9.8
 3:    23   1       12    6.4
 4:    12   1        6    7.2
 5:    12   2        1    6.5
 6:    65   2        5    7.5
 7:    58   2        7    7.8
 8:    85   2        8    6.9
 9:    85   3       10   10.2
10:    23   3        2    5.9
11:    45   3        4    5.8
12:    96   3        9    9.5

Where I can get the mean weight of each pen within as close to 0.1 difference as possible to the other pens.

data.table r optimization loops
1 Answers

I'd suggest trying a (stochastic) Local Search to solve the problem. In essence, you make random switches to your allocation of piglets and keep those that decrease the differences in weights.

Alternative representations are possible, but one possibility is this: A candidate solution is a vector that maps the piglets to pens; so your column pen would be an initial solution. The k-th element of such a solution gives the pen in which piglet k goes.

Let's map this initial solution into a solution quality, i.e. write an objective function OF.

df <- data.frame(sowid = c(12,23,25,45,65,12,58,85,96,85,45,23),
                 pen   = c(1,1,1,1,2,2,2,2,3,3,3,3),
                 pigletid = c(1,2,3,4,5,6,7,8,9,10,11,12),
                 weight   = c(6.5,5.9,6.2,5.8,7.5,7.2,7.8,6.9,9.5,10.2,9.8,6.4))

x <- df$pen
OF <- function(x, df, ...)
    sd(tapply(df$weight, x, mean))
OF(x, df)
## [1] 1.44157

Note that I used a standard data.frame to represent your data. OF computes the standard deviation of average weights, but you could try other specifications as well.

Now for the random sampling: randomly select one sow s with more than one piglet; random select two piglets that belong to s; exchange their positions. Note that I precompute sowids so that I do not end up with sows with only a single piglet.

sowids <- as.numeric(names(table(df$sowid)[table(df$sowid) > 1]))

nb <- function(x, df, sowids) {
    s <- sowids[sample(length(sowids), 1)]
    ij <- sample(which(df$sowid == s))[1:2]
    x[ij] <- x[rev(ij)]
    x    
}

nb (which stands for neighbour) implements this sampling. The function takes a candidate solution xand returns a slightly changed solution.

x
## [1] 1 1 1 1 2 2 2 2 3 3 3 3
nb(x, df, sowids)
## [1] 1 1 1 2 2 1 2 2 3 3 3 3
nb(nb(x, df, sowids), df, sowids)
## [1] 2 1 1 1 2 2 1 2 3 3 3 3

Now we can run the Local Search. I use the implementation in package NMOF (of which I am the maintainer).

library("NMOF")
sol.ls <- LSopt(OF, list(x0 = df$pen,
                         neighbour = nb,
                         nI = 1000),
                df = df, sowids = sowids)
## Local Search.
## Initial solution:  1.44157 
## Best solution overall: 0.3307189

We can compare the final solution with the initial one: average weights by pen.

tapply(df$weight, df$pen, mean)
##     1     2     3 
## 6.100 7.350 8.975 
tapply(df$weight, sol.ls$xbest, mean)
##     1     2     3 
## 7.225 7.350 7.850

And a check: did we keep the correct sowids?

sort(df$sowid[test$pen == 1])
sort(df$sowid[which(sol.ls$xbest == 1)])

sort(df$sowid[test$pen == 2])
sort(df$sowid[which(sol.ls$xbest == 2)])

sort(df$sowid[test$pen == 3])
sort(df$sowid[which(sol.ls$xbest == 3)])
user_70156750
Related