2
$\begingroup$

I want to create a graph that looks similar to this "BarPlot3D" here [1]:

Figure S13 from PCCP, 2014,16, 26184-26192

My input for testing purposes:

xyz={{487, 507, 0.000687138}, {487, 512, 0}, {487, 587, 0}, {487, 591, 
  3.33204*10^-8}, {487, 596, 0}, {487, 609, 0}, {487, 639, 0}, {487, 
  640, 0}, {487, 703, 0.344578}, {487, 768, 0}, {511, 507, 0}, {511, 
  512, 0}, {511, 587, 0}, {511, 591, 0}, {511, 596, 0}, {511, 609, 
  0}, {511, 639, 0}, {511, 640, 0}, {511, 703, 0}, {511, 768, 
  3.33204*10^-8}, {595, 507, 0}, {595, 512, 0}, {595, 587, 0}, {595, 
  591, 0}, {595, 596, 0}, {595, 609, 0}, {595, 639, 
  5.41254*10^-6}, {595, 640, 0}, {595, 703, 3.33204*10^-8}, {595, 768,
   0}, {627, 507, 2.86652*10^-7}, {627, 512, 0.0227501}, {627, 587, 
  0.0227501}, {627, 591, 0}, {627, 596, 0}, {627, 609, 0}, {627, 639, 
  0}, {627, 640, 0}, {627, 703, 0}, {627, 768, 0.000159109}, {641, 
  507, 2.86652*10^-7}, {641, 512, 0}, {641, 587, 2.86652*10^-7}, {641,
   591, 0}, {641, 596, 0}, {641, 609, 0}, {641, 639, 0}, {641, 640, 
  0}, {641, 703, 0}, {641, 768, 0}, {643, 507, 0}, {643, 512, 
  0.0227501}, {643, 587, 9.86588*10^-10}, {643, 591, 0}, {643, 596, 
  0}, {643, 609, 0}, {643, 639, 0.42074}, {643, 640, 0.11507}, {643, 
  703, 0}, {643, 768, 7.93328*10^-7}, {654, 507, 7.93328*10^-7}, {654,
   512, 0}, {654, 587, 0}, {654, 591, 0}, {654, 596, 0}, {654, 609, 
  0}, {654, 639, 0}, {654, 640, 0}, {654, 703, 1.07176*10^-8}, {654, 
  768, 0}, {675, 507, 0}, {675, 512, 7.93328*10^-7}, {675, 587, 
  0.000687138}, {675, 591, 2.11245*10^-6}, {675, 596, 
  0.00466119}, {675, 609, 0}, {675, 639, 2.86652*10^-7}, {675, 640, 
  0}, {675, 703, 0.158655}, {675, 768, 0}, {682, 507, 0}, {682, 512, 
  0}, {682, 587, 0.0359303}, {682, 591, 0.211855}, {682, 596, 
  0}, {682, 609, 0}, {682, 639, 0}, {682, 640, 0}, {682, 703, 
  0}, {682, 768, 0.0000133457}, {712, 507, 0}, {712, 512, 0}, {712, 
  587, 0.344578}, {712, 591, 0.000072348}, {712, 596, 
  0.000336929}, {712, 609, 0}, {712, 639, 0}, {712, 640, 
  0.00819754}, {712, 703, 0}, {712, 768, 0}}

So far, I came up with the following:

bar[x_, y_, z_] := Cuboid[{x - 10, y - 2, 0}, {x + 10, y + 2, z}];
Show[
 Plot3D[None, {x, 470, 780}, {y, 470, 780},
  PlotRange -> {0, All},
  ViewPoint -> {1000, 1000, 600},
  BoxRatios -> {1, 1, 1},
  AxesLabel -> {"Triplet Excited States \!\(\*SubscriptBox[\(T\), \(m\
\)]\) (nm)", 
    "Singlet Excited States \!\(\*SubscriptBox[\(S\), \(n\)]\) (nm)", 
    Rotate["\[LeftAngleBracket]\!\(\*SubscriptBox[\(S\), \
\(n\)]\)|\!\(\*SubscriptBox[\(H\), \
\(SO\)]\)|\!\(\*SubscriptBox[\(T\), \(m\)]\)\[RightAngleBracket] \
(1/cm)", 90 Degree]},
  LabelStyle -> Directive[Bold, Black, Medium],
  TicksStyle -> Directive[Black, Bold],
  BoxStyle -> Directive[Black, Thick],
  Boxed -> False,
  Axes -> {True, True, True},
  FaceGrids -> Dynamic[Sign /@ DiagonalMatrix[-{1, 1, 1}]]],
 Graphics3D[Map[bar @@ # &, Flatten[xyz, 1]]],
 ImageSize -> Large]

my version of the previous image

Am I at a dead end or what would be the way to go on?
What other solutions would be better?

The labeling looks like as if it has been done afterwards, so maybe I will choose the same way for that.


[1] Phys. Chem. Chem. Phys., 2014, 16, 26184-26192

$\endgroup$
  • 2
    $\begingroup$ I always tried to separate the labeling from the plotmaking for this reason. First make the plot in Mathematica, then import it as a bitmap to some other program for adding text. I'd just copy and paste it into Inkscape, use its $\LaTeX$ plugin to make better labels I could rotate and resize. Then if I need to redo the plot, I just replace that element of the figure. $\endgroup$ – Jason B. Aug 22 '17 at 14:09
  • $\begingroup$ do you know the formula for z? $\endgroup$ – Alucard Aug 22 '17 at 14:48
  • $\begingroup$ There is no formula. They come from a parsed matrix, but in this example they are random. $\endgroup$ – pH13 - Yet another Philipp Aug 22 '17 at 15:10
3
$\begingroup$
xyz = {{487, 507, 0.000687138}, {487, 512, 0}, {487, 587, 0}, {487, 
    591, 3.33204*10^-8}, {487, 596, 0}, {487, 609, 0}, {487, 639, 
    0}, {487, 640, 0}, {487, 703, 0.344578}, {487, 768, 0}, {511, 507,
     0}, {511, 512, 0}, {511, 587, 0}, {511, 591, 0}, {511, 596, 
    0}, {511, 609, 0}, {511, 639, 0}, {511, 640, 0}, {511, 703, 
    0}, {511, 768, 3.33204*10^-8}, {595, 507, 0}, {595, 512, 0}, {595,
     587, 0}, {595, 591, 0}, {595, 596, 0}, {595, 609, 0}, {595, 639, 
    5.41254*10^-6}, {595, 640, 0}, {595, 703, 3.33204*10^-8}, {595, 
    768, 0}, {627, 507, 2.86652*10^-7}, {627, 512, 0.0227501}, {627, 
    587, 0.0227501}, {627, 591, 0}, {627, 596, 0}, {627, 609, 
    0}, {627, 639, 0}, {627, 640, 0}, {627, 703, 0}, {627, 768, 
    0.000159109}, {641, 507, 2.86652*10^-7}, {641, 512, 0}, {641, 587,
     2.86652*10^-7}, {641, 591, 0}, {641, 596, 0}, {641, 609, 
    0}, {641, 639, 0}, {641, 640, 0}, {641, 703, 0}, {641, 768, 
    0}, {643, 507, 0}, {643, 512, 0.0227501}, {643, 587, 
    9.86588*10^-10}, {643, 591, 0}, {643, 596, 0}, {643, 609, 
    0}, {643, 639, 0.42074}, {643, 640, 0.11507}, {643, 703, 0}, {643,
     768, 7.93328*10^-7}, {654, 507, 7.93328*10^-7}, {654, 512, 
    0}, {654, 587, 0}, {654, 591, 0}, {654, 596, 0}, {654, 609, 
    0}, {654, 639, 0}, {654, 640, 0}, {654, 703, 1.07176*10^-8}, {654,
     768, 0}, {675, 507, 0}, {675, 512, 7.93328*10^-7}, {675, 587, 
    0.000687138}, {675, 591, 2.11245*10^-6}, {675, 596, 
    0.00466119}, {675, 609, 0}, {675, 639, 2.86652*10^-7}, {675, 640, 
    0}, {675, 703, 0.158655}, {675, 768, 0}, {682, 507, 0}, {682, 512,
     0}, {682, 587, 0.0359303}, {682, 591, 0.211855}, {682, 596, 
    0}, {682, 609, 0}, {682, 639, 0}, {682, 640, 0}, {682, 703, 
    0}, {682, 768, 0.0000133457}, {712, 507, 0}, {712, 512, 0}, {712, 
    587, 0.344578}, {712, 591, 0.000072348}, {712, 596, 
    0.000336929}, {712, 609, 0}, {712, 639, 0}, {712, 640, 
    0.00819754}, {712, 703, 0}, {712, 768, 0}};

{ymin, ymax} = MinMax[xyz[[All, 2]]];

bar[x_, y_, z_] := {
   ColorData["BrightBands"][Rescale[y, {ymin, ymax}]],
   Cuboid[{x - 10, y - 2, 0}, {x + 10, y + 2, z}]};

You can put everything into the Graphics3D use of an empty Plot along with Show is unnecessary.

Graphics3D[bar @@@ xyz,
 PlotRange -> {{470, 780}, {470, 780}, All},
 ViewPoint -> {1000, 1000, 600},
 BoxRatios -> {1, 1, 1},
 LabelStyle -> Directive[Bold, Black, Medium],
 TicksStyle -> Directive[Black, Bold],
 BoxStyle -> Directive[Black, Thick],
 Boxed -> False,
 Axes -> True,
 AxesLabel -> {
   Rotate[
    StringForm["``Triplet Excited States `` (nm)", Spacer[40], 
     Subscript[T, m]], 26 Degree],
   Rotate[
    StringForm["Singlet Excited States `` (nm)``", Subscript[S, n], 
     Spacer[40]], -24 Degree],
   Rotate[
    StringForm[
     "\n\[LeftAngleBracket]``|``|``\[RightAngleBracket] (1/cm)", 
     Subscript[S, n], Subscript[H, SO], Subscript[T, m]], 
    90 Degree]},
 FaceGrids -> DiagonalMatrix[-{1, 1, 1}],
 ImageSize -> Large]

enter image description here

$\endgroup$
2
$\begingroup$

You may use Histogram3D.

The data is first GatherBy the x-values in bins of width 5. Each set is converted into WeightedData with sets of all zero weights dropped. The remaining sets are plotted by Histogram3D with bin widths of 5 on the x-axis and 10 on the y-axis.

With xyz as defined in the OP.

With[{dat = 
   Query[All, WeightedData[#[[All, ;; 2]], #[[All, -1]]] &, FailureAction -> "Drop"]@
     GatherBy[xyz, Ceiling[First@#, 5] &]},
 Histogram3D[dat, {{5}, {10}},
  ChartStyle -> (Opacity[1, ColorData[{"Indexed", "NeonColor"}]@#] & /@Range[Length@dat]),
  PlotRangePadding -> {Automatic, Automatic, {None, Automatic}},
  Boxed -> False,
  BoxRatios -> 1,
  FaceGrids -> {{-1, 0, 0}, {0, 1, 0}, {0, 0, -1}},
  AxesEdge -> {{-1, -1}, {1, -1}, {-1, -1}},
  ScalingFunctions -> {"Reverse", None, None},
  ImageSize -> Large
  ]
 ]

Mathematica graphics

Hope this helps.

$\endgroup$
  • $\begingroup$ While this is technically a good idea, I think by using a histogram and binning, close values would be combined. I'd say this is physically not right as every single bar represents sth unique. $\endgroup$ – pH13 - Yet another Philipp Aug 23 '17 at 5:13

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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