1
$\begingroup$

enter image description here

Reading the paper Measuring Wigner functions of quantum states of light in the undergraduate laboratory in arXiv, I found the figure above, whose style is very beautiful. I tried to reproduce it, but I failed. Is there an elegant method to obtain a similar style of bar chart?

code:

alpha = 2;
rho[m_, n_] :=  Exp[-Abs[alpha]^2] alpha^n Conjugate[alpha]^m/Sqrt[n! m!]
matrix = Table[rho[m,n],{m,1,20},{n,1,20}];
MatrixPlot[matrix]

I don't know how to plot a 3d bar chart using a matrix, because my data is created by numerical calculation. I found some example in StackExange, but there the data has n * 5 dimensions.

Through trying, I found the following ways to achieve my requirements, thank you all. The effect has not yet been fully reproduced, I will continue to work hard.

revised code version:

alpha=2;
rho[m_,n_]:=Exp[-Abs[alpha]^2] alpha^n Conjugate[alpha]^m/Sqrt[n! m!]
matrix=Table[rho[m,n],{m,1,20},{n,1,20}];
DiscretePlot3D[Abs[matrix[[m,n]]],{m,1,20},{n,1,20},ExtentSize->Full,
ColorFunction->Function[{x,y,z},ColorData["TemperatureMap"]z]],
ColorFunctionScaling->True,BoxRatios->{1, 1, 0.618},Boxed->False]

enter image description here

$\endgroup$
2
  • $\begingroup$ Welcome to the Mathematica Stack Exchange. Your matrix is mostly zeros. Is this what you want to plot? Take a look at DiscretePlot3D for which you would need an expression to plot. $\endgroup$
    – Syed
    Nov 3, 2023 at 2:59
  • $\begingroup$ Thank you for your reply. I try to use the DiscretePlot3D function for processing, but since I only have data (which can be processed numerically), this function does not work. $\endgroup$
    – gang liu
    Nov 3, 2023 at 3:41

2 Answers 2

1
$\begingroup$
alpha = 2;
rho[m_, n_] := 
 Exp[-Abs[alpha]^2] alpha^n Conjugate[alpha]^m/Sqrt[n! m!]
matrix = Table[rho[m, n], {m, 1, 21}, {n, 1, 21}];

p1 = DiscretePlot3D[Abs[matrix[[m, n]]]
  , {m, 1, 20}, {n, 1, 20}
  , ExtentSize -> Right
  , ExtentMarkers -> None
  , AxesLabel -> (Style[#, Black, 14] & /@ {"n", "m", "\[Rho]"})
  , ExtentElementFunction -> "ProfileCube"
  , PlotStyle -> Opacity[0.9, White]
  , BoxRatios -> {1, 1, 0.618}
  , Boxed -> False
  , SphericalRegion -> True
  , AxesEdge -> {{0, -1}, {1, -1}, {0, -1}}
  , ImagePadding -> {{30, 20}, {30, 20}}
  , ImageSize -> 600
  ];

p2 = ListPlot3D[matrix + 0.001
  , PlotRange -> Full
  , DataRange -> {{1, 21}, {1, 21}}
  , Mesh -> None
  , BoundaryStyle -> {Lighter@Black, AbsoluteThickness[1]}
  , InterpolationOrder -> 0
  , ColorFunction -> 
   Function[{x, y, z}, ColorData["TemperatureMap"][z]]
  , ColorFunctionScaling -> True
  , BoxRatios -> {1, 1, 0.618}
  , Boxed -> False
  , ImageSize -> 600
  ];

Show[p1, p2]

enter image description here

$\endgroup$
3
  • $\begingroup$ On v12.2.0, Win7-x64, the use of "DoubleProfileCube" with different opacity settings in PlotStyle crashes the front-end. Perhaps, it is more stable in other/newer versions. $\endgroup$
    – Syed
    Nov 3, 2023 at 8:21
  • $\begingroup$ Thank you so much for your kind assistance! I really appreciate the effort you put into helping me with my question. Your solution works perfectly for what I needed. I am grateful for your expertise and support. Thanks again! $\endgroup$
    – gang liu
    Nov 5, 2023 at 12:25
  • $\begingroup$ You are most welcome @gangliu $\endgroup$
    – Syed
    Nov 5, 2023 at 12:25
1
$\begingroup$

Use the built-in ExtentElementFunction "ProfileCube" to construct two custom functions, one for the caps and the other for sides:

ClearAll[caps, sides]

caps[profile_ : 2] := {EdgeForm[Gray], 
    ChartElementData["ProfileCube", 
     "Profile" -> profile][{#[[1]], #[[2]], {1, 1} #[[3, 2]]}, ##2]} &;

sides[profile_ : 2] :=
   ChartElementData["ProfileCube", "Profile" -> profile][##] /. 
     Rule["SurfaceCaps", _] -> Rule["SurfaceCaps", False] &;

Example:

alpha = 2;

rho[m_, n_] :=  Exp[-Abs[alpha]^2] alpha^n Conjugate[alpha]^m/Sqrt[n! m!]

matrix = Table[rho[m, n], {m, 1, 21}, {n, 1, 21}];

options = Sequence[
   AxesLabel -> (Style[#, Black, 14] & /@ {"n", "m", "ρ"}),
   ExtentSize -> Right, 
   ExtentMarkers -> None,
   AxesEdge -> {{0, -1}, {1, -1}, {0, -1}},
   BoxRatios -> {1, 1, 0.618},
   Boxed -> False, 
   SphericalRegion -> True,
   ImagePadding -> {{30, 20}, {30, 20}}, 
   ImageSize -> 600];

pa = DiscretePlot3D[Abs[matrix[[m, n]]], 
   {m, 1, 20}, {n, 1, 20},
   ColorFunction -> "TemperatureMap",
   ExtentElementFunction -> caps[],
   Evaluate @ options];

pb = DiscretePlot3D[Abs[matrix[[m, n]]], {m, 1, 20}, {n, 1, 20}, 
   ExtentElementFunction -> sides[], 
   FillingStyle -> White, 
   Evaluate @ options];

Post-process pa to fix the colors:

Show[pa /. BSplineSurface[a_, b___] :> 
    {ColorData["TemperatureMap"][
        Rescale[a[[1, 1, -1]], MinMax @ Abs @ matrix]], 
      BSplineSurface[a, b]},
    pb]

enter image description here

$\endgroup$
1
  • $\begingroup$ Thank you so much for your prompt and helpful response! I truly appreciate the time and effort you put into helping me with my question. Your solution worked perfectly, and the code you provided was exactly what I needed. I'm grateful for your expertise. In addition, I would like to inquire about how to quickly enhance my programming skills in Mathematica. I aspire to reach a level similar to yours because there are certain techniques in your code that I have never encountered before. Thanks again! $\endgroup$
    – gang liu
    Nov 5, 2023 at 12:19

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.