# Problem with RandomSearch option

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?

• 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 Commented May 7, 2021 at 12:25
• {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}}. Commented May 7, 2021 at 12:25

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


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

• 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}}, Commented May 7, 2021 at 10:58
• {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. Commented May 7, 2021 at 11:01
• @user64494 My answer shows you a way how to make NMaximize work for RandomSearch and DifferentialEvolution options . That's what you asked for! Commented May 7, 2021 at 11:53
• The cure is not better than the disease. I am right, aren't I? Commented May 7, 2021 at 12:00
• 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 Commented May 7, 2021 at 12:05