Nonlinear discrete optimization in R

Question

I have a simple (indeed standard in economics) nonlinear constrained discrete maximisation problem to solve in R and am having trouble. I found solutions for parts of the problem (nonlinear maximisation; discrete maximisation) but not for the union of all the problems.

Here is the problem. A consumer wants to buy three products (ananas, banana, cookie), knows the prices and has a budget of 20€. He likes variety (ie, he wants to have all three products if possible) and his satisfaction is decreasing in the amount consumed (he likes his first cookie way more than his 100th).

The function he wishes to maximise is

and of course since each has a price, and he has a limited budget, he maximises this function under the constraint that

What I want to do is to find the optimal buying list (N ananas, M bananas, K cookies) that satisfies the constraint.

If the problem were linear, I would simply use linprog::solveLP(). But the objective function is nonlinear. If the problem were of a continuous nature, ther would be a simple analytic solution to it.

The question being discrete and nonlinear, I do not know how to proceed.

Here is some toy data to play with.

df <- data.frame(rbind(c("ananas",2.17),c("banana",0.75),c("cookie",1.34)))
names(df) <- c("product","price")

I'd like to have an optimization routine that gives me an optimal buying list of (N,M,K).

Any hints?

Answer 1

If you do not mind using a "by hand" solution:

uf=function(x)prod(x)^.5
bf=function(x,pr){
  if(!is.null(dim(x)))apply(x,1,bf,pr) else x%*%pr
}
budget=20
df <- data.frame(product=c("ananas","banana","cookie"),
                 price=c(2.17,0.75,1.34),stringsAsFactors = F)
an=0:(budget/df$price[1]) #include 0 for all possibilities
bn=0:(budget/df$price[2])
co=0:(budget/df$price[3])
X=expand.grid(an,bn,co)
colnames(X)=df$product
EX=apply(X,1,bf,pr=df$price)
psX=X[which(EX<=budget),] #1st restrict
psX=psX[apply(psX,1,function(z)sum(z==0))==0,] #2nd restrict
Ux=apply(psX,1,uf)
cbind(psX,Ux)
(sol=psX[which.max(Ux),])
uf(sol) # utility
bf(sol,df$price)  #budget

 > (sol=psX[which.max(Ux),]) ananas banana cookie 1444 3 9 5 > uf(sol) # utility [1] 11.61895 > bf(sol,df$price) #budget 1444 19.96 

Answer 2

1) no packages This can be done by brute force. Using df from the question as input ensure that price is numeric (it's a factor in the df of the question) and calculate the largest number mx for each variable. Then create grid g of variable counts and compute the total price of each and the associated objective giving gg . Now sort gg in descending order of objective and take those solutions satisfying the constraint. head will show the top few solutions.

price <- as.numeric(as.character(df$price))
mx <- ceiling(20/price)
g <- expand.grid(ana = 0:mx[1], ban = 0:mx[2], cook = 0:mx[3]) 
gg <- transform(g, total = as.matrix(g) %*% price, objective = sqrt(ana * ban * cook))
best <- subset(gg[order(-gg$objective), ], total <= 20)

giving:

> head(best) # 1st row is best soln, 2nd row is next best, etc.
     ana ban cook total objective
1643   3   9    5 19.96  11.61895
1929   3   7    6 19.80  11.22497
1346   3  10    4 19.37  10.95445
1611   4   6    5 19.88  10.95445
1632   3   8    5 19.21  10.95445
1961   2  10    6 19.88  10.95445

2) dplyr This can also be nicely expressed using the dplyr package. Using g and price from above:

library(dplyr)
g %>% 
  mutate(total = c(as.matrix(g) %*% price), objective = sqrt(ana * ban * cook)) %>%
  filter(total <= 20) %>%
  arrange(desc(objective)) %>%
  top_n(6)

giving:

Selecting by objective
  ana ban cook total objective
1   3   9    5 19.96  11.61895
2   3   7    6 19.80  11.22497
3   3  10    4 19.37  10.95445
4   4   6    5 19.88  10.95445
5   3   8    5 19.21  10.95445
6   2  10    6 19.88  10.95445

Answer 3

I think this problem is very similar in nature to this question ( Solve indeterminate equation system in R ). The answer by Richie Cotton was the basis to this possible solution:

df <- data.frame(product=c("ananas","banana","cookie"),
                 price=c(2.17,0.75,1.34),stringsAsFactors = F)

FUN <- function(w, price=df$price){
  total <- sum(price * w) 
  errs <- c((total-20)^2, -(sqrt(w[1]) * sqrt(w[2]) * sqrt(w[3])))
  sum(errs)
}

init_w <- rep(10,3)
res <- optim(init_w, FUN, lower=rep(0,3), method="L-BFGS-B")
res
res$par # 3.140093 9.085182 5.085095
sum(res$par*df$price) # 20.44192

Notice that the total cost (ie price) for the solution is $ 20.44. To solve this problem, we can weight the error terms to put more emphasis on the 1st term, which relates to the total cost:

### weighting of error terms
FUN2 <- function(w, price=df$price){
  total <- sum(price * w) 
  errs <- c(100*(total-20)^2, -(sqrt(w[1]) * sqrt(w[2]) * sqrt(w[3]))) # 1st term weighted by 100
  sum(errs)
}

init_w <- rep(10,3)
res <- optim(init_w, FUN2, lower=rep(0,3), method="L-BFGS-B")
res
res$par # 3.072868 8.890832 4.976212
sum(res$par*df$price) # 20.00437

Answer 4

As LyzandeR remarked there is no nonlinear integer programming solver available in R. Instead, you can use the R package rneos that sends data to one of the NEOS solvers and returns the results into your R process.

Select one of the solvers for "Mixed Integer Nonlinearly Constrained Optimization" on the NEOS Solvers page, eg, Bonmin or Couenne. For your example above, send the following files in the AMPL modeling language to one of these solvers:

[Note that maximizing the product x1 * x2 * x3 is the same as maximising the product sqrt(x1) * sort(x2) * sqrt(x3) .]

Model file:

param p{i in 1..3};
var x{i in 1..3} integer >= 1;
maximize profit: x[1] * x[2] * x[3];
subject to restr: sum{i in 1..3} p[i] * x[i] <= 20;

Data file:

param p:= 1 2.17  2 0.75  3 1.34 ;

Command file:

solve;
display x;

and you will receive the following solution:

x [*] :=
1  3
2  9
3  5
;

This approach will work for more extended examples were solutions "by hand" are not reasonable and rounded optim solutions are not correct.

To look at a more demanding example, let me propose the following problem:

Find an integer vector x = (x_i), i=1,...,10, that maximizes x1 * ... * x10, such that p1*x1 + ... + p10*x10 <= 10, where p = (p_i), i=1,...,10, is the following price vector

p <- c(0.85, 0.22, 0.65, 0.73, 0.91, 0.11, 0.31, 0.47, 0.93, 0.71)

Using constrOptim for this nonlinear optimization problem with a linear inequality constraint, I get solutions like 900 for different starting points, but never the optimal solutions that is 960 !