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, 2021 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, 2021 at 12:25

1 Answer 1

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, 2021 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, 2021 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, 2021 at 11:53
  • $\begingroup$ The cure is not better than the disease. I am right, aren't I? $\endgroup$
    – user64494
    May 7, 2021 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, 2021 at 12:05

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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