0
$\begingroup$

Solving an optimization problem with Method->"RandomSearch" option

ClearAll["Global`*"]; n = 10;
NMaximize[{-Sum[p[k]*Log[p[k]], {k, 1, n}],Sum[p[k], {k, 1, n}] == 1 && Sum[k*p[k], {k, 1, n}] == 2 && 
p[1] > 0 && p[2] > 0,  p[3] > 0 && p[4] > 0 && p[5] > 0 && p[6] > 0 && p[7] > 0 && 
p[8] > 0 && p[9] > 0 && p[10] > 0}, Table[p[k], {k, 1, n}], Method -> {"RandomSearch", "SearchPoints" -> 100}]enter code here

, I obtain a warning

NMaximize::nrnum: The function value -1.22046-0.408196 I is not a real number at {p[1],p[2],p[3],p[4],p[5],p[6],p[7],p[8],p[9],p[10]} = {0.598474,0.1655,0.000789021,<<4>>,0.0343533,0.0636326,-0.129933}.

and an incorrect result

{-Log[p[2]] p[2] - Log[p[3]] p[3] - Log[p[4]] p[4] - Log[p[5]] p[5] - Log[p[6]] p[6] - Log[p[7]] p[7] - Log[p[8]] p[8] - Log[0.111111 - 0.111111 p[2] - 0.222222 p[3] - 0.333333 p[4] - 0.444444 p[5] - 0.555556 p[6] - 0.666667 p[7] - 0.777778 p[8] - 0.888889 p[9]] (0.111111 - 0.111111 p[2] - 0.222222 p[3] - 0.333333 p[4] - 0.444444 p[5] - 0.555556 p[6] - 0.666667 p[7] - 0.777778 p[8] - 0.888889 p[9]) - Log[0.888889 - 0.888889 p[2] - 0.777778 p[3] - 0.666667 p[4] - 0.555556 p[5] - 0.444444 p[6] - 0.333333 p[7] - 0.222222 p[8] - 0.111111 p[9]] (0.888889 - 0.888889 p[2] - 0.777778 p[3] - 0.666667 p[4] - 0.555556 p[5] - 0.444444 p[6] - 0.333333 p[7] - 0.222222 p[8] - 0.111111 p[9]) - Log[p[9]] p[9], {p[1] -> 0.598474, p[2] -> 0.1655, p[3] -> 0.000789021, p[4] -> 0.0231708, p[5] -> 0.0453707, p[6] -> 0.190066, p[7] -> 0.00857625, p[8] -> 0.0343533, p[9] -> 0.0636326, p[10] -> -0.129933}}

The same issue with the Method -> "DifferentialEvolution" option. The following works properly.

NMaximize[{-Sum[p[k]*Log[p[k]], {k, 1, n}],  Sum[p[k], {k, 1, n}] == 1 && Sum[k*p[k], {k, 1, n}] == 2 && 
p[1] > 0 && p[2] > 0, p[3] > 0 && p[4] > 0 && p[5] > 0 && p[6] > 0 && p[7] > 0 && 
p[8] > 0 && p[9] > 0 && p[10] > 0}, Table[p[k], {k, 1, n}]]

{1.3853, {p[1] -> 0.497951, p[2] -> 0.250251, p[3] -> 0.125766, p[4] -> 0.063205, p[5] -> 0.0317643, p[6] -> 0.0159635, p[7] -> 0.00802259, p[8] -> 0.00403182, p[9] -> 0.00202621, p[10] -> 0.00101827}}

How to make the RandomSearch and DifferentialEvolution options work properly?

$\endgroup$
2
  • $\begingroup$ Moreover,n = 12; NMaximize[{-Sum[ p[k]*Log[RealAbs[p[k]]], {k, 1, n}], Sum[p[k], {k, 1, n}] == 1 && Sum[k*p[k], {k, 1, n}] == 2 && Table[p[k], {k, 1, n}] > 0}, Table[p[k], {k, 1, n}], WorkingPrecision -> 20] results in $\endgroup$
    – user64494
    May 7 at 12:25
  • $\begingroup$ {1.4282892260442467457, {p[1] -> 0.4425246563389881153, p[2] -> 0.29444691323000000558, p[3] -> 0.12572534947384017300, p[4] -> 0.077676590570172439455, p[5] -> 0.027188684208537776711, p[6] -> 0.021795299720855472760, p[7] -> 0.0098369941067331116801, p[8] -> 0.0099145281647085854905, p[9] -> 0.0063505406743991386861, p[10] -> 0.0029157117376203413588, p[11] -> 6.1669354330318860399*10^-8, p[12] -> -0.01837532989520949036}}. $\endgroup$
    – user64494
    May 7 at 12:25
0
$\begingroup$

To avoid roundoff errors in the functional change Log[p[k]] to Log[RealAbs[p[k]]]

n = 10;

Table[
NMaximize[{-Sum[p[k]*Log[RealAbs[p[k]]], {k, 1, n}],Sum[p[k], {k, 1, n}] == 1 && Sum[k*p[k], {k, 1, n}] == 2 && 
 p[1] > 0 && p[2] > 0,p[3] > 0 && p[4] > 0 && p[5] > 0 && p[6] > 0 && p[7] > 0 &&p[8] > 0 && p[9] > 0 && p[10] > 0}, Table[p[k], {k, 1, n}], 
 Method -> {Automatic, "NelderMead", "RandomSearch" ,"DifferentialEvolution"  }[[i]] ] // Quiet
 , {i, 1, 4}]

(*{{1.37947, {p[1] -> 0.486356, p[2] -> 0.260099, p[3] -> 0.131519, p[4] -> 0.0550347, p[5] -> 0.041031, p[6] -> 0.0128654, p[7] -> 0.0056115, p[8] -> 0.00788751, p[9] -> 0.00193489,p[10] -> -0.00233915}}, 
{1.37947, {p[1] -> 0.486356,p[2] -> 0.260099, p[3] -> 0.131519, p[4] -> 0.0550347,p[5] -> 0.041031, p[6] -> 0.0128654, p[7] -> 0.0056115,p[8] -> 0.00788751, p[9] -> 0.00193489,p[10] -> -0.00233915}}, 
{1.38529, {p[1] -> 0.497953,p[2] -> 0.250251, p[3] -> 0.125766, p[4] -> 0.0632046,p[5] -> 0.031764, p[6] -> 0.0159633, p[7] -> 0.00802249,p[8] -> 0.00403177, p[9] -> 0.0020262,p[10] -> 0.00101829}}, 
{1.38302, {p[1] -> 0.501038,p[2] -> 0.257196, p[3] -> 0.114503, p[4] -> 0.0613219,p[5] -> 0.0347692, p[6] -> 0.0149038, p[7] -> 0.00576647,p[8] -> 0.00478949, p[9] -> 0.00330252, p[10] -> 0.00241029}}}*)

addendum

Unfortunately solutions of the first two methods doesn't fullfill the constraints (p[10]<0 )

Further restriction of the parameterranges to 0<p[k]<1 gives similar plausible results for the 4 methods:

n = 10;
Table[NMaximize[{-Sum[p[k]*Log[RealAbs[p[k]]], {k, 1, n}], 
Sum[p[k], {k, 1, n}] == 1, Sum[k*p[k], {k, 1, n}] == 2, 
Map[0 < # < 1 &, Table[p[k], {k, 1, n}]]}, Table[p[k], {k, 1,n}], 
Method -> {Automatic, "NelderMead", "RandomSearch","DifferentialEvolution"}[[i]]] 
, {i, 1, 4}]  
$\endgroup$
11
  • $\begingroup$ The output without Quit produces {{1.37947, {p[1] -> 0.486356, p[2] -> 0.260099, p[3] -> 0.131519, p[4] -> 0.0550347, p[5] -> 0.041031, p[6] -> 0.0128654, p[7] -> 0.0056115, p[8] -> 0.00788751, p[9] -> 0.00193489, p[10] -> -0.00233915}}, {1.37947, {p[1] -> 0.486356, p[2] -> 0.260099, p[3] -> 0.131519, p[4] -> 0.0550347, p[5] -> 0.041031, p[6] -> 0.0128654, p[7] -> 0.0056115, p[8] -> 0.00788751, p[9] -> 0.00193489, p[10] -> -0.00233915}}, $\endgroup$
    – user64494
    May 7 at 10:58
  • $\begingroup$ {1.38529, {p[1] -> 0.497953, p[2] -> 0.250251, p[3] -> 0.125766, p[4] -> 0.0632046, p[5] -> 0.031764, p[6] -> 0.0159633, p[7] -> 0.00802249, p[8] -> 0.00403177, p[9] -> 0.0020262, p[10] -> 0.00101829}}, {1.38302, {p[1] -> 0.501038, p[2] -> 0.257196, p[3] -> 0.114503, p[4] -> 0.0613219, p[5] -> 0.0347692, p[6] -> 0.0149038, p[7] -> 0.00576647, p[8] -> 0.00478949, p[9] -> 0.00330252, p[10] -> 0.00241029}}}. and a lot of warnings.Pay your attention to the incorrect results of Automatic andHealderMead and a variance in the results.. This is not it. $\endgroup$
    – user64494
    May 7 at 11:01
  • $\begingroup$ @user64494 My answer shows you a way how to make NMaximize work for RandomSearch and DifferentialEvolution options . That's what you asked for! $\endgroup$ May 7 at 11:53
  • $\begingroup$ The cure is not better than the disease. I am right, aren't I? $\endgroup$
    – user64494
    May 7 at 12:00
  • $\begingroup$ n = 12; NMaximize[{-Sum[ p[k]*Log[RealAbs[p[k]]], {k, 1, n}], Sum[p[k], {k, 1, n}] == 1 && Sum[k*p[k], {k, 1, n}] == 2 && p[1] > 0 && p[2] > 0, p[3] > 0 && p[4] > 0 && p[5] > 0 && p[6] > 0 && p[7] > 0 && p[8] > 0 && p[9] > 0 && p[10] > 0 && p[11] > 0 && p[12] > 0}, Table[p[k], {k, 1, n}], Method -> "DifferentialEvolution"] performs $\endgroup$
    – user64494
    May 7 at 12:05

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.