RStudio не отвечает с большой линейной оптимизацией

Question

У меня есть большая проблема двухэтапной оптимизации, которую я попытался упростить для этого вопроса. Первый шаг - выбрать 10 элементов, чтобы максимизировать полезность с определенными ограничениями. Мне нужно 200 таких наборов, но из-за характера того, что я пытаюсь сделать, должно быть 600 сгенерированных, чтобы могли проявиться правильные комбинации.

Обход этих мини-оптимизационных задач - это большее ограничение, когда каждый отдельный элемент может использоваться только в определенном диапазоне. Первая оптимизация настраивает полезность каждого элемента так, чтобы каждый из них находился относительно близко к границам, но не все могут быть в пределах своих границ. Следовательно, второй шаг состоит в том, чтобы выбрать 200 из 600 наборов таким образом, чтобы удовлетворялось минимальное / максимальное использование каждого отдельного элемента. Это то, что мне нужно помочь.

Я сделал функцию, используя lpSolve это работает, но в 80% случаев это замораживает RStudio, и это просто становится слишком хлопотным - мне нужно либо улучшить свой текущий подход, либо нужен совершенно новый подход. Я не знаю, если lpSolve действительно лучший подход для начала. Несмотря на то, что у меня есть общее заданное значение, которое я могу максимизировать, все, что меня действительно волнует, это наличие каждого элемента в пределах. Я сделал упрощенный пример, чтобы понять суть моей проблемы.

---

Я отвечаю за приготовление 200 блюд из набора из 80 разных фруктов. Каждый прием пищи использует 10 фруктов и не может содержать более 1 одного и того же фрукта. Я ограничен в количестве фруктов, которые у меня есть (и мой босс заставляет меня использовать минимум каждого фрукта, иначе они испортятся), поэтому они должны быть в определенных пределах. У меня есть список из 600 блюд уже создан (Meals), и каждый из них имеет свой уникальный показатель здоровья. В идеале я хотел бы максимизировать показатель здоровья, но, очевидно, наиболее важным моментом является то, что каждый фрукт используется правильное количество раз, в противном случае блюда не могут быть сделаны в первую очередь.

Вот мой код: 1) Установите 600 блюд (случайным образом) 2) Установите минимальное / максимальное количество раз, когда каждый фрукт должен быть использован (случайным образом) 3) Запустите линейную оптимизацию, чтобы выбрать 200 из 600 блюд так, чтобы были соблюдены ограничения для отдельных фруктов, Программа пытается выбрать 200 из 600, но если ограничения не позволяют, то она ослабляет ограничения (например, если решатель не работает в первый раз, я уменьшу минимальное количество раз Apple можно использовать и увеличить максимальное количество раз, когда оно может быть использовано). Это делает это один фрукт за один раз, а не все сразу. В конце концов, ограничения должны быть ослаблены настолько, что сработают любые 200 из 600 (то есть, когда minPercent всех фруктов меньше 0, а maxPercent всех фруктов больше 100), но это не имеет значения, поскольку R замерзает.

library(stringr)
library(dplyr)
library(lpSolve)

# Inputs
MealsNeeded <- 200
Buffer <- 3

# Setup the meals (this is the output of another optimizer in my actual program. Considered "Step 1" as I mentioned above)
Meals <- data.frame()
for(i in 1:(MealsNeeded*Buffer)){

  run <- i
  meal <- sample(fruit, 10)
  healthFactor <- round(runif(1, 10, 30), 0) #(Health factor for the entire meal)

  df <- data.frame(Run = run, Fruit = meal, healthFactor = healthFactor, stringsAsFactors = FALSE)

  Meals <- rbind(Meals, df)

}

# The minimum/maximum number of times each fruit must be used across all 200 meals (these would be inputs in my program)
set.seed(11)
fruitDF <- data.frame(Name = fruit, minSelectPct = round(runif(length(fruit), .05, .1)*100, 0), stringsAsFactors = FALSE) %>% 
  mutate(maxSelectPct = round(minSelectPct/2 + runif(length(fruit), .05, .1)*100, 0))

#### Actual Program Start

# Get objective
obj <- Meals %>% 
  distinct(Run, healthFactor) %>% 
  ungroup() %>% 
  select(healthFactor) %>% 
  pull()

# Dummy LU - for each fruit give 1/0 whether or not they were in the meal
dummyLUInd <- data.frame(FruitName = fruitDF$Name, stringsAsFactors = FALSE)
for(i in unique(Meals$Run)){

  selectedFruit <- Meals %>%
    filter(Run == i) %>% 
    select(Fruit) %>% 
    mutate(Indicator = 1)

  dummyLUIndTemp <- fruitDF %>% 
    left_join(selectedFruit, by = c('Name' = 'Fruit')) %>% 
    mutate(Indicator = ifelse(is.na(Indicator), 0, Indicator)) %>% 
    select(Indicator)

  dummyLUInd <- cbind(dummyLUInd, dummyLUIndTemp)
}

## Table create
dummyLUInd <- rbind(dummyLUInd, dummyLUInd)[,-1]
dummyLUInd <- as.data.frame(t(dummyLUInd))
dummyLUInd$Total = 1

## Directions
dirLT <- c(rep('<=', (ncol(dummyLUInd)-1)/2))
dirGT <- c(rep('>=', (ncol(dummyLUInd)-1)/2))
## Multiply percentages by total Meals
MinExp = round(fruitDF$minSelectPct/100 * MealsNeeded - 0.499, 0) 
MaxExp = round(fruitDF$maxSelectPct/100 * MealsNeeded + 0.499, 0)

# Setup constraints like # of tries
CounterMax <- 10000
LPSum = 0
Counter = 0

# Create DF to make it easier to change constraints for each run
MinExpDF <- data.frame(Place = 1:length(MinExp), MinExp = MinExp)
MaxExpDF <- data.frame(Place = 1:length(MaxExp), MaxExp = MaxExp)
cat('\nStarting\n')
Sys.sleep(2)

# Try to get the 200 of 600 Meals that satisfy the constraints for the individual Fruit.
# If the solution doesn't exist, loosen the constraints for each fruit (one at a time) until it does work
while (LPSum == 0 & Counter <= CounterMax) {
  rowUse <- Counter %% length(MaxExp)

  # Knock one of minimum, starting with highest exposure, one at a time
  MinExpDF <- MinExpDF %>%
    mutate(Rank = rank(-MinExp, na.last = FALSE, ties.method = "first"),
           MinExp = ifelse(Rank == rowUse, MinExp - 1, MinExp)
    )
  MinExp <- MinExpDF$MinExp

  # Add one of maximum, starting with highest exposure, one at a time
  MaxExpDF <- MaxExpDF %>%
    mutate(Rank = rank(-MaxExp, na.last = FALSE, ties.method = "first"),
           MaxExp = ifelse(Rank == rowUse, MaxExp + 1, MaxExp))
  MaxExp <- MaxExpDF$MaxExp


  # Solve
  dir <- 'max'
  f.obj <- obj
  f.mat <- t(dummyLUInd)
  f.dir <- c(dirGT, dirLT, '==')
  f.rhs <- c(MinExp, MaxExp, MealsNeeded)
  Sol <- lp(dir, f.obj, f.mat, f.dir, f.rhs, all.bin = T)$solution
  LPSum <- sum(Sol)

  Counter = Counter + 1
  if(Counter %% 10 == 0) cat(Counter, ', ', sep = '')
}

# Get the Run #'s from the lpSolve
if(Counter >= CounterMax){
  cat("Unable to find right exposure, returning all Meals\n")
  MealsSolved <- Meals
} else {
  MealsSolved <- data.frame(Run = unique(Meals$Run))
  MealsSolved$selected <- Sol
  MealsSolved <- MealsSolved[MealsSolved$selected == 1,]
}
# Final Meals
FinalMeals <- Meals %>% 
  filter(Run %in% MealsSolved$Run)

Если вы запускаете этот код достаточно много раз, в конечном итоге RStudio зависнет на вас (по крайней мере, для меня, если не для вас, я полагаю, увеличит количество приемов пищи). Это происходит во время фактического lp, так что на самом деле мало что можно сделать, так как это действительно C-код. Это где я потерян.

Часть меня думает, что это на самом деле не lpSolve проблема, поскольку я действительно не пытаюсь максимизировать что-либо (Фактор Здоровья не слишком важен). Моя настоящая "функция потерь" - это количество раз, когда каждый фрукт поднимается выше / ниже их минимальной / максимальной экспозиции, но я не могу придумать, как настроить что-то подобное. Может ли мой текущий подход работать, или мне нужно сделать что-то совсем другое?