# Sample discrete distributions with a good range of observed entropies

For a numerical sanity check, I need to sample random sequences of $$n$$ positive numbers adding up to 1, and having a high chance of observing both high entropy and low entropy sequences. Compute the entropy by treating sequence as a discrete probability distribution.

Ideally, the histogram of sampled sequence entropies would approach uniform distribution.

Can someone suggest a way to do this in Mathematica? Here's a naive generation method, showing non-uniform entropy histogram, and the kind of histogram I would like to see.

n = 10;
s = 10000;
normalize[seq_] := seq/Total@seq;
sequences =
normalize /@ RandomVariate[UniformDistribution[], {s, n}];
entropy[seq_] := -Total[# Log[#] & /@ seq];
Histogram[entropy /@ sequences, PlotLabel -> "observed"]
Histogram[RandomVariate[UniformDistribution[], s],
PlotLabel -> "desired"]


• Mathematica already has Entropy so you don't need to define it yourself. Jun 23, 2021 at 16:45
• What do you mean by "ideally"? If there is some theoretical reason, that clearly flies in the face of the observed data given the definition of entropy you're using. Also, the distribution you get depends on how one creates sequences as there are many ways to get random vectors that sum to 1. For example: sequences = RandomVariate[DirichletDistribution[ConstantArray[1, n]], s]; sequences = Flatten[{#, 1 - Total[#]}] & /@ sequences; Histogram[entropy /@ sequences].
– JimB
Jun 23, 2021 at 17:48
• What is a typical value of n? The largest and smallest values of n you plan to consider? Jun 23, 2021 at 17:52
• @mikado n=1000 is the largest one I would consider, but I would settle for smaller values as well. Jun 23, 2021 at 18:17
• One potential approach could be generate a set of equidistant points in an n-dimensional simplex, weigh each point by entropy, then resample Jun 23, 2021 at 19:32

If the objective is to get a collection of vectors with a reasonably wide range of entropy values and have the distribution of those entropy values be approximately uniform, then you can first do almost exactly as you did:

n = 10;
s = 10000;
normalize[seq_] := seq/Total@seq;
SeedRandom[12345];
sequences = normalize /@ RandomVariate[UniformDistribution[], {s, n}];
entropy[seq_] := -Total[# Log[#] & /@ seq];
data = entropy /@ sequences;
SmoothHistogram[data, Automatic, "PDF", PlotLabel -> "observed"]


(Note that it's time to retire the histogram especially when sample sizes are large.)

Now we ignore the histogram and sample the entropy values in a "uniform" manner:

(* Generate uniformly random entropy values between the min and max of the observed values *)
eValues = RandomVariate[UniformDistribution[MinMax[data]], 10000];

(* Join the entropy values with the sequences *)
data = Transpose[{data, sequences}];

(* Initialize array to hold entropy values and associated sequence *)
newData = ConstantArray[0, Length[eValues]];

(* Generate new data (sequences) with a wide range of entropy values *)
Do[newData[[i]] = {eValues[[i]], SelectFirst[data, #[[1]] > eValues[[i]] &]}, {i, Length[eValues]}]
SmoothHistogram[newData[[All, 1]], {Automatic, {"Bounded", {0, Log[n]}, "Gaussian"}}, "PDF"]


Now ignoring the distribution of the original entropy values makes no sense if one is attempting to make inferences about entropy values as they were originally generated. But if just a wide range of test vectors need to be generated that have a roughly uniform distribution, then this technique will do that.

From the comment to obtain an assortment of vectors with lower entropy values one might use the Dirichlet distribution appropriately parameterized. The elements by definition sum to 1 so there's no messing around with normalizing. The lowest entropy is zero (assuming that 0*Log[0] is defined as zero) so vectors should look closer to {1,0,0,...,0} than {1,1,...,1}/n.

n = 10;
s = 10000;
sequences =  RandomVariate[DirichletDistribution[Flatten[{{n^2}, ConstantArray[1, n - 1]}]], s];
entropy[seq_] := -Total[# Log[#] & /@ seq];
lowE = entropy /@ sequences;
SmoothHistogram[lowE, Automatic, "PDF", PlotLabel -> "observed"]


More "mid-range" entropy values could be found by

s = 10000;
sequences = RandomVariate[DirichletDistribution[Flatten[{{n, n}, ConstantArray[1, n - 2]}]], s];
entropy[seq_] := -Total[# Log[#] & /@ seq];
midE = entropy /@ sequences;
SmoothHistogram[midE, Automatic, "PDF", PlotLabel -> "observed"]


All of the datasets could be joined and then sampled "as if uniform" as done previously.

• @YarsolovBulatov Too weird an answer? This approach is at least vaguely related to importance sampling: statweb.stanford.edu/~owen/mc/Ch-var-is.pdf.
– JimB
Jun 24, 2021 at 18:15
• Neat resampling trick with SelectFirst. The only downside is that the smallest entropy obtained in a sample of 10k from Uniform might be considerably larger than smallest possible entropy Jun 24, 2021 at 21:09