## A knapsack riddle [#2]?

Posted in Kids, R, Statistics with tags , , , on February 17, 2017 by xi'an

Still about this allocation riddle of the past week, and still with my confusion about the phrasing of the puzzle, when looking at a probabilistic interpretation of the game, rather than for a given adversary’s y, the problem turns out to search for the maximum of

$\mathbb{E}[L(x,Y)]=\sum_{i=1}^{10} i\{P(Y_ix_i)\}$

where the Y’s are Binomial B(100,p). Given those p’s, this function of x is available in closed form and can thus maximised by a simulated annealing procedure, coded as

utility=function(x,p){
ute=2*pbinom(x[1]-1,100,prob=p[1])+
dbinom(x[1],100,p[1])
for (i in 2:10)
ute=ute+2*i*pbinom(x[i]-1,100,prob=p[i])+
i*dbinom(x[i],100,p[i])
return(ute)}
#basic term in utility
baz=function(i,x,p){
return(i*dbinom(x[i],100,p[i])+
i*dbinom(x[i]-1,100,p[i]))}
#relies on a given or estimated p
x=rmultinom(n=1,siz=100,prob=p)
maxloz=loss=0
newloss=losref=utility(x,p)
#random search
T=1e3
Te=1e2
baza=rep(0,10)
t=1
while ((t<T)||(newloss>loss)){
loss=newloss
i=sample(1:10,1,prob=(10:1)*(x>0))
#moving all other counters by one
xp=x+1;xp[i]=x[i]
#corresponding utility change
for (j in 1:10) baza[j]=baz(j,xp,p)
proz=exp(log(t)*(baza-baza[i])/Te)
#soft annealing move
j=sample(1:10,1,prob=proz)
if (i!=j){ x[i]=x[i]-1;x[j]=x[j]+1}
newloss=loss+baza[j]-baza[i]
if (newloss>maxloz){
maxloz=newloss;argz=x}
t=t+1
if ((t>T-10)&(newloss<losref)){
t=1;loss=0
x=rmultinom(n=1,siz=100,prob=p)
newloss=losref=utility(x,p)}}


which seems to work, albeit not always returning the same utility. For instance,

> p=cy/sum(cy)
> utility(argz,p)
[1] 78.02
> utility(cy,p)
[1] 57.89


or

> p=sy/sum(sy)
> utility(argz,p)
[1] 82.04
> utility(sy,p)
[1] 57.78


Of course, this does not answer the question as intended and reworking the code to that purpose is not worth the time!

## an integer programming riddle

Posted in Books, Kids, R with tags , , , , on April 21, 2016 by xi'an

A puzzle on The Riddler this week that ends up as a standard integer programming problem. Removing the little story around the question, it boils down to optimise

200a+100b+50c+25d

under the constraints

400a+400b+150c+50d≤1000, b≤a, a≤1, c≤8, d≤4,

and (a,b,c,d) all non-negative integers. My first attempt was a brute force R code since there are only 3 x 9 x 5 = 135 cases:

f.obj<-c(200,100,50,25)
f.con<-matrix(c(40,40,15,5,
-1,1,0,0,
1,0,0,0,
0,0,1,0,
0,0,0,1),ncol=4,byrow=TRUE)
f.dir<-c("=","=","=","=","=","=")
f.rhs<-c(100,0,1,8,4)

sol=0
for (a in 0:1)
for (b in 0:a)
for (k in 0:8)
for (d in 0:4){
cost=f.con%*%c(a,b,k,d)-f.rhs
if (max(cost)<=0){ gain=f.obj%*%c(a,b,k,d)
if (gain>sol){
sol=gain
argu=c(a,b,k,d)}}}


which returns the value:

> sol
[,1]
[1,]  425
> argu
[1] 1 0 3 3


This is confirmed by a call to an integer programming code like lpSolve:

> lp("max",f.obj,f.con,f.dir,f.rhs,all.int=TRUE)
Success: the objective function is 425
> lp("max",f.obj,f.con,f.dir,f.rhs,all.int=TRUE)\$sol
[1] 1 0 3 3


which provides the same solution.