Problem with RandomSearch option

Question

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?

Answer 1

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