Распределите значение по зонам, используя соотношение населения и критерии минимума / максимума в R - PullRequest
Новая
       124

Распределите значение по зонам, используя соотношение населения и критерии минимума / максимума в R

4 голосов
/ 09 мая 2020

У меня есть следующие данные: 

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))

Я хотел бы раздать 50, скажем, головных уборов, в эти зоны с учетом численности населения. Однако для некоторых из этих зон требуется по крайней мере 1 головной убор, в то время как другие могут получить только очень небольшое количество головных уборов или вообще не получить их. пропорциональное распределение насколько это возможно), но с учетом минимального и максимального критериев и перераспределения распределения шляпы на другие зоны, когда зона не может получать / больше? например, если Зоне, на основе точного пропорционального распределения, должно быть назначено 20 головных уборов, но можно принять только 10, то остальные 10 должны быть назначены другим зонам с учетом их населения.

Ответы [ 3 ]

4 голосов
/ 09 мая 2020

Я не уверен в этом. Звучит как задача оптимизации или линейного программирования.

Вот функция: 

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)
}

Протестируйте ее на 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 шляп было выделено.

Это может быть не элегантно или математически неуместно, но t hat была моей попыткой w hat это того стоит. Надеюсь, это может быть полезно.

4 голосов
/ 09 мая 2020

Эта функция выполняет описанный вами алгоритм.

Сначала проверяется, достаточно ли у вас шляп для выполнения минимальных требований. Если нет, он выдает ошибку.

Затем он видит, достаточно ли шляп для go раунда, и в этом случае он дает максимальное количество шляп.

В противном случае он распределяет минимальное количество шляп и вычитает эту сумму из оставшихся шляп. Затем он пройдет l oop, давая шляпу оставшемуся ряду с наибольшим разрывом между текущими шляпами и максимальным количеством шляп, умноженным на размер популяции, пока не останется шляп для распределения. 

distribute_hats <- function(df, hats)
{
  if (hats <  sum(df$MIN)) stop("Not enough hats to go round!")
  if (hats >= sum(df$MAX)) {df$HATS <- df$MAX; return(df)}
  df$HATS  <- df$MIN
  hats     <- hats - sum(df$MIN)
  while(hats)
  {
    weights  <- df$HATS/df$POPULATION
    allowed  <- which(df$HATS < df$MAX)
    smallest <- which.min(weights[allowed])[1]
    df$HATS[allowed][smallest] <- df$HATS[allowed][smallest] + 1
    hats <- hats - 1
  }

  return(df)
}

Теперь мы попробуйте с разумными числами: 

dt1 %>% distribute_hats(50)
#>     ZONE POPULATION MIN MAX HATS
#>  1:  A34         40   1  10    3
#>  2: G345        110   0   9    8
#>  3:  H62         80   0   2    2
#>  4: D563         70   1  11    5
#>  5:  T63         90   0  12    6
#>  6: P983         90   1   8    6
#>  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    6
#> 12:  R99         50   1   8    4

dt1 %>% distribute_hats(10)
#>     ZONE POPULATION MIN MAX HATS
#>  1:  A34         40   1  10    1
#>  2: G345        110   0   9    1
#>  3:  H62         80   0   2    1
#>  4: D563         70   1  11    1
#>  5:  T63         90   0  12    1
#>  6: P983         90   1   8    1
#>  7:  S24        130   0   5    0
#>  8:  J54        140   1   3    1
#>  9: W953         80   1   2    1
#> 10:  L97         30   0   0    0
#> 11:  V56         80   1   8    1
#> 12:  R99         50   1   8    1

И крайними случаями: 

dt1 %>% distribute_hats(1000)
#>     ZONE POPULATION MIN MAX HATS
#>  1:  A34         40   1  10   10
#>  2: G345        110   0   9    9
#>  3:  H62         80   0   2    2
#>  4: D563         70   1  11   11
#>  5:  T63         90   0  12   12
#>  6: P983         90   1   8    8
#>  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    8
#> 12:  R99         50   1   8    8

Создано 2020-05-09 пакетом REPEX (v0 .3.0)

2 голосов
/ 10 мая 2020

Формулируя это как целочисленное программирование, где целевая функция минимизирует сумму квадратов между назначенным и целевым выделением с учетом минимальных и максимальных ограничений выделения: 

dt1[, TARGET := POPULATION / sum(POPULATION) * TOTAL]

system.time({
    library(CVXR)
    x <- Variable(nrow(dt1), integer=TRUE)
    mini <- dt1$MIN
    maxi <- dt1$MAX
    target <- dt1$TARGET
    obj <- Minimize(sum_squares(x - target))
    constr <- list(mini <= x, x <= maxi, sum(x) == TOTAL)
    prob <- Problem(obj, constr)
    result <- solve(prob)
})
#   user  system elapsed 
#   1.60    0.17    1.76 


dt1[, ALLOCATION := as.integer(round(result$getValue(x)))]

вывод: 

    ZONE POPULATION MIN MAX   TARGET ALLOCATION
 1:  A34         40   1  10 2.020202          4
 2: G345        110   0   9 5.555556          7
 3:  H62         80   0   2 4.040404          2
 4: D563         70   1  11 3.535354          5
 5:  T63         90   0  12 4.545455          6
 6: P983         90   1   8 4.545455          6
 7:  S24        130   0   5 6.565657          5
 8:  J54        140   1   3 7.070707          3
 9: W953         80   1   2 4.040404          2
10:  L97         30   0   0 1.515152          0
11:  V56         80   1   8 4.040404          6
12:  R99         50   1   8 2.525253          4

данные : 

library(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))
TOTAL <- 50L
...