Plot a simple function

[Paul K.]

Hi, a simple query. Do you know how could I plot the entropy function
in Mathematica? I wish to produce an image similar to this one:

http://upload.wikimedia.org/wikipedia/commons/c/c9/Binary_entropy_plot.png

Do you know how could I plot mutual information between two random
variables X and Y in a 3D surface in Mathematica?

Thanks!

Paul.

[Roger Bagula]

Paul K. wrote:

>Hi, a simple query. Do you know how could I plot the entropy function
>in Mathematica? I wish to produce an image similar to this one:
>

>http://upload.wikimedia.org/wikipedia/commons/c/c9/Binary_entropy_plot.p=

ng
>
>Do you know how could I plot mutual information between two random
>variables X and Y in a 3D surface in Mathematica?
>
>Thanks!
>
>Paul.
>
>
>
>

I think you may be looking at multifractal entropy?
The first curve can be done two ways:
1) The logistic way:
y[x_]=-4*x*(1-x)
Plot[y[x],{x,0,1},PlotRange->{{0,1},{0,1}}]
The "And" like plot:
x0 = t;
y0 = p;
z0 = y[t]*y[p];
ParametricPlot3D[{x0, y0, z0}, {t, 0, 1}, {p, 0, 1}]
2) The sine like way:
f[x_]=Sin[Pi*t]
Plot[Sin[Pi*t],{t,0,1},PlotRange->{{0,1},{0,1}}]
x1 = t;
y1 = p;
z1 = f[t]*f[p];
ParametricPlot3D[{x1, y1, z1}, {t, 0, 1}, {p, 0, 1}]

They aren't the same result:

Plot[y[t]-f[t],{t,0,1},PlotRange->{{0,1},{0,1}}]

x2=t;
y2=p;
z2=y[t]*y[p]-f[t]*f[p];
ParametricPlot3D[{x2,y2,z2},{t,0,1},{p,0,1}]

I think the Logistic one is the better of the two theoretically.
Using an Hurst like exponent H they can be made to be the same:
H[h_] = h /. Solve[Sin[Pi*t]^h - y[t] == 0, h]
Plot[H[t], {t, 0, 1}, PlotRange -> {{0, 1}, {0, 1}}]
g[t_]=FullSimplify[f[t]^H[t]]

The H function is a very slippery one.
Although the derivitive existes at t=1/2
you have to use a limit to get the value:
D[Log[-4(-1 + t) t]/Log[Sin[=CF=80 t]], t]
Limit[H[t], t -> 1/2]
{8/Pi^2}
N[%]
{0.810569}

[Roger Bagula]

There is yet another way to get this type of diagram!

http://arxiv.org/pdf/chao-dyn/9804006
Working on these diagrams jogged a memory:
look at figure 3 c) and d) in this paper.
He calls it the Igloo map as related to the Logistic map.

http://scitation.aip.org/getabs/servlet/GetabsServlet?prog=normal&id==
CHAOEH000010000001000180000001&idtype=cvips&gifs=yes

Entropy computing via integration over fractal measures

Wojciech Slomczynski
Instytut Matematyki, Uniwersytet Jagiellonski, ul. Reymonta 4, 30=96059,
Krak=F3w, Poland

Jaroslaw Kwapien
Instytut Fizyki Jadrowej im. H. Niewodniczanskiego, ul. Radzikowskiego
152, 31=96305, Krak=F3w, Poland

Karol Zyczkowski
Instytut Fizyki im. M. Smoluchowskiego, Uniwersytet Jagiellonski, ul.
Reymonta 4, 30=96059, Krak=F3w, Poland

(Received 20 January 1999; accepted 10 August 1999)

We discuss the properties of invariant measures corresponding to
iterated function systems (IFSs) with place-dependent probabilities and
compute their R=E9nyi entropies, generalized dimensions, and multifractal
spectra. It is shown that with certain dynamical systems, one can
associate the corresponding IFSs in such a way that their generalized
entropies are equal. This provides a new method of computing entropy for
some classical and quantum dynamical systems. Numerical techniques are
based on integration over the fractal measures. =A92000 American Institute
of Physics.

PII: S1054-1500(99)01204-5
doi:10.1063/1.166492
PACS: 05.45.Df, 02.50.Cw, 02.60.Jh Additional Information

[Jmba...@aol.com]

Paul, the binary entropy function is defined as h(x) = -p log(p) - (1 - p)
log(1 - p). The log in this formula is binary logarithm. Given that h(0) =
h(1) = 0, you can then execute the following commands to plot the graph you are
looking for:

h[x_] := - x * Log[2,x] - (1 - x) * Log[2,1 - x]
Plot[h[x], {x,0,1}]

Hope this helps.
J. Batista

_______________
In a message dated 4/8/2007 5:31:59 AM Eastern Daylight Time,
jorgec...@gmail.com writes:

Hi, a simple query. Do you know how could I plot the entropy function
in Mathematica? I wish to produce an image similar to this one:

http://upload.wikimedia.org/wikipedia/commons/c/c9/Binary_entropy_plot.png

[Roger Bagula]

Bob Hanlon wrote:

>H[p_] := -p*Log[2, p] -(1-p)*Log[2, 1-p] /; 0 <= p <= 1;
>
>Plot[H[p],{p,0,1},
> PlotStyle->{AbsoluteThickness[3],Blue},
> Frame->True,
> FrameTicks->{Range[0,1,0.5],Range[0,1,0.5],None,None},
> FrameStyle->White,
> FrameLabel->{"Pr(X = 1)","H(X)"},
> AspectRatio->1,
> TextStyle->{FontSize->18},
> GridLines->Table[Table[
> {x,{AbsoluteThickness[2],GrayLevel[0.9]}},
> {x,0,1,0.1}],{2}],
> Prolog->{Black,
> AbsoluteThickness[2],
> Line[{{0,1.05},{0,0},{1.05,0} }]}];
>
>
>Bob Hanlon
>
>
>
>
>>
>>
>>
>
>
>
>
Bob Hanlon,
You are on top of things as usual, but the question wanted a 3d approach!

Well it appears there is a third method and it isn't the same either!
I had forgotten about the Log two entropy approach!
I got a sign wrong in my approach, too.
But a very nice Zeta[2] like constant.
Can you solve the logistic to Log two as a power or as a linear factor?
H[p_] := -p*Log[2, p] -(1-p)*Log[2, 1-p] /; 0 <= p <= 1;

x0 = t;
y0 = p;

z0 = H[t]*H[p];

ParametricPlot3D[{x0, y0, z0}, {t, 0, 1}, {p, 0, 1}]

Solve:
p[t_] := h /. Solve[H[t] - y[t]^h == 0, h]
g3= Plot[p[x], {x, 0, 1}, PlotRange -> {{0, 1}, {0, 1}}]
pp[t_] = Log[ -t*Log[2, t] - (1 - t)*Log[2, 1 - t]]/(Log[4] + Log[(1 -
t) t])
g4 = Plot[p[x], {x, 0, 1}, PlotRange -> {{0, 1}, {0, 1}}]
Limit[pp[t], t -> 1/2]
1/Log[4]
N[%]
0.7213475204444817

Roger Bagula

[Roger Bagula]

New 3d movie based on the entropy like mappings:
http://www.mathematica-users.org/mediawiki/images/8/80/3d_entropy_maps_2x.avi

[Roger Bagula]

The Entropy map type functions made me realize that there was a sequence
of these
mapping functions and their Integrals formed an alternation of integers
and irrationals sequence.
{2., 2.77259, 3., 3.14159, 4., 4.66667, 5., 5.1774, 6.}
After the tent map ( K=0) the curvatures are negative.
I don't know if this is an actually quantum sequence or not!

Clear[e, f]
(* pulse : c[1] = 2*)
f[x_, 1] := 1
(* entropy of information*)
f[x_, 2] := -x*Log[2, x] - (1 - x)*Log[2, 1 - x] /; 0 <= x <= 1;
(* Logistic map*)
f[x_, 3] := 4*x*(1 - x)
(* Sine map*)
f[x_, 4] := Sin[Pi*x]
(* Tent Map*)
f[x_, 5] := 2*x /; 0 <= x <= 1/2
f[x_, 5] := (2 - 2*x) /; 1/2 < x <= 1
(* Square root tent map : equivalent to logistic*)
e[x_] := Sqrt[2*x] /; 0 <= x <= 1/2
e[x_] := Sqrt[(2 - 2*x)] /; 1/2 < x <= 1
(* 4/3 power tent map*)
ha := 4/3
f[x_, 6] := (2*x)^ha /; 0 <= x <= 1/2
f[x_, 6] := (2 - 2*x)^ha /; 1/2 < x <= 1
(* 3/2 power tent map*)
h0 := 3/2
f[x_, 7] := (2*x)^h0 /; 0 <= x <= 1/2
f[x_, 7] := (2 - 2*x)^h0 /; 1/2 < x <= 1
(* Farey map*)
f[x_, 8] := (x/(1 - x)) /; 0 <= x <= 1/2
f[x_, 8] := ((1 - x)/x) /; 1/2 < x <= 1
(*square tent map*)
h := 2;
f[x_, 9] := (2*x)^h /; 0 <= x <= 1/2
f[x_, 9] := (2 - 2*x)^h /; 1/2 < x <= 1
c = Table[1/Integrate[f[x, n], {x, 0, 1/2}], {n, 1, 9}];
N[c]
ListPlot[c,
PlotJoined -> True]
b =
Table[Plot[f[x, n], {x, 0, 1}, PlotRange -> {{0, 1}, {0, 1}}], {n, 1, 9}]
Show[b]

Respectfully, Roger L. Bagula
11759Waterhill Road, Lakeside,Ca 92040-2905,tel: 619-5610814
:http://www.geocities.com/rlbagulatftn/Index.html
alternative email: rlba...@sbcglobal.net

[Roger Bagula]

My investigation of the hanging chain curve and the structure of
suspension briges
which are quadratic ( Logistic like)
until loaded and then go to a cosh like curve made me try the following
curve:
h = Log[2]/Log[Cosh[1/2]]
f[t_] = 2 - Cosh[t - 1/2]^h
g2 = Plot[f[t], {t, 0, 1}]
Integrate[f[t], {t, 0, 1}]
N[%]
0.706785

The entropy curve:

H[p_] := -p*Log[2, p] - (1 - p)*Log[2, 1 - p]

has area:
Integrate[H[x], {x, 0, 1}]
N[%]
0.721348
This result is much closer than the logistic
and the curves are hard to distinguih fron each other.

As far as I know the powered cosh curve in the unit
square is a new curve. The power is necessary to get the
f[0]=f[1]=0
condition.
Thinking of the Saint Louis arch made me try this.

>
>