I have the following data:
require("data.table")
dt1 <- data.table(ZONE = c("A34","G345","H62","D563","T63","P983","S24","J54","W953","L97","V56","R99"), POPULATION = c(40,110,80,70,90,90,130,140,80,30,80,50), MIN = c(1,0,0,1,0,1,0,1,1,0,1,1), MAX = c(10,9,2,11,12,8,5,3,2,0,8,8))
I would like to distribute 50, let's say hats, to these zones weighted on the population. However, some of these zones require at least 1 hat while others can receive only a very small number or no hats at all.
Is there a way of allocating the 50 hats based on the population (so as an exact proportional allocation as possible) but taking into account the minimum and maximum criteria and redistributing the hat allocation to other zones when a zone can't receive any/anymore? e.g. if a Zone should, based on exact proportional allocation, be assigned 20 hats but can only accept 10, then the other 10 should be assigned to other zones weighted on their populations.
I'm not sure about this. It sounds like an optimization or linear programming task
Here's the function:
allocate <- function(dt, N){
if(N>dt[,sum(MAX)])
stop("Too many hats to go around")
if(N<dt[,sum(MIN)])
stop("Not enough hats to go around")
# Allocate hats initially based on proportion but use clamping
dt[, HATS := pmax(MIN, pmin(MAX, round(N * +(MAX>0) * POPULATION / sum(POPULATION[MAX>0]))))]
n <- N - dt[,sum(HATS)]
if(n==0) # All hats accouted for
return(dt)
if(n>0){ # Allocate the extra hats, again proportional to pop with clamping
dt[HATS<MAX, HATS := HATS + pmax(MIN, pmin(MAX,
round(n * +(MAX>0) * POPULATION / sum(POPULATION[MAX>0]))))]
} else { # Or subtract the superfluous hats, according to pop
dt[HATS>MIN, HATS := HATS - pmax(MIN, pmin(MAX,
round(abs(n) * +(MAX>0) * POPULATION / sum(POPULATION[MAX>0]))))]
}
n <- N - dt[,sum(HATS)] # Check again
if(n==0) # All hats accouted for
return(dt)
if(n>0){ # This time, just add 1 hat to those that require them
dt[HATS<MAX, i:=.I][i<=n, HATS := HATS + 1]
} else { # Or reduce the number of hats by one
dt[HATS>MIN, i:=.I][i<=abs(n), HATS := HATS - 1]
}
dt[, i:=NULL] # Remove this guy
return(dt)
}
Test it for 50:
dt2 <- allocate(dt1, 50)
dt2
ZONE POPULATION MIN MAX HATS
1: A34 40 1 10 2
2: G345 110 0 9 8
3: H62 80 0 2 2
4: D563 70 1 11 5
5: T63 90 0 12 7
6: P983 90 1 8 7
7: S24 130 0 5 5
8: J54 140 1 3 3
9: W953 80 1 2 2
10: L97 30 0 0 0
11: V56 80 1 8 5
12: R99 50 1 8 4
50 hats were allocated.
It may not be elegant or mathematically sound, but that was my attempt for what it's worth. Hope it can be of some use.