8
$\begingroup$

I have the following code:


students=List[List[DateObject[List[2016,1,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2016,9,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2017,11,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2018,1,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2018,3,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2018,4,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2018,5,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2018,6,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2018,9,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2018,12,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2019,1,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2020,2,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2020,4,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2020,5,1,0,0,0.`],"Instant","Gregorian",-4.`]],List[1,2,3,4,5,6,7,8,9,10,11,12,13,14]];
everyone=List[List[DateObject[List[2016,1,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2016,5,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2016,9,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2016,10,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2016,12,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2017,1,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2017,2,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2017,5,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2017,6,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2017,8,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2017,11,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2017,12,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2018,1,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2018,2,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2018,3,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2018,4,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2018,5,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2018,6,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2018,7,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2018,9,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2018,10,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2018,11,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2018,12,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2019,1,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2019,3,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2019,4,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2019,5,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2019,7,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2019,9,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2019,10,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2019,11,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2019,12,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2020,1,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2020,2,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2020,3,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2020,4,1,0,0,0.`],"Instant","Gregorian",-4.`],DateObject[List[2020,5,1,0,0,0.`],"Instant","Gregorian",-4.`]],List[1,2,3,4,5,8,9,12,16,17,18,19,34,35,36,39,42,44,46,49,50,51,52,54,59,61,65,69,73,76,80,85,86,88,90,95,97]];
studentsplot=students//Transpose//DateListPlot[#,Joined->True,Mesh->All,PlotStyle->Directive[Thick,Black],Filling->Bottom,FillingStyle->Lighter[Green]]&;
everyoneplot=everyone//Transpose//DateListPlot[#,Joined->True,Mesh->All,PlotStyle->Directive[Thick,Black],Filling->Bottom,FillingStyle->Lighter[Blue]]&;
Show[everyoneplot,studentsplot]

which produces this graph:

graph from above code

However, I'd like it to appear like this graph from excel:

desired graph from excel

I'm not even sure where to start, can anyone give an example of how to get this pseudo-3D style with Mathematica/Wolfram Language, so that it matches how the graph is plotted in the excel example?

tl;dr:

Q: How do I replicate this pseudo-3D style?

I only need the answer to replicate the style, I can handle everything else, just as an FYI.

Thanks to anyone who chooses to provide advice for this!

$\endgroup$
  • 12
    $\begingroup$ Although you have gotten nice answers already, I would be remiss if I did not mention Tufte's concept of chartjunk, of which "false 3D" is one of the common offenders. Apart from artistic purposes, please consider presenting your data in a less "noisy" format whenever possible. $\endgroup$ – J. M.'s technical difficulties Jun 5 at 3:54
  • 1
    $\begingroup$ @J.M. I am definitely in agreement with you on that one! I am of sure how I would present this data myself, but I am making this as the resident Mathematica-can-do-this-too-but-better member of my research group; I’ll definitely let my colleague that birthed the excel version know of this concept, however ;) I think the deal is that we are presenting this to folks who like the shiny things, and money is pretty shiny, of which they have a lot of it hah! $\endgroup$ – CA Trevillian Jun 5 at 3:56
5
$\begingroup$

Here's something to build upon:

makeRidges[line_, color_, d_] := 
 BlockMap[Splice[{EdgeForm[{Thickness[0.0025], Black}], 
     FaceForm[{Nest[Function[c, Darker[c, 0.15]], color, 
        Round[2 - Subtract @@ (Last /@ #1)]]}], 
     Polygon@Flatten[{#, Reverse@# + {{0, d}, {0, d}}}, 1]}] &, line, 
  2, 1]

junkify[plot_Graphics, shift_] := 
 Module[{ifg, polys, colors, lines, ridges},
  ifg = Cases[InputForm[plot], 
    g_GraphicsComplex :> Normal[g], \[Infinity]];
  polys = 
   MapIndexed[(#1 /. {x_, y_} :> {x, y + shift First@#2}) &, 
    Cases[ifg, {e_EdgeForm, d_Directive, 
       GraphicsGroup[{{p_Polygon}}]} :> {EdgeForm[Black], First@d, 
       p}, \[Infinity]]];
  colors = Cases[polys, color_RGBColor, \[Infinity]];
  lines = 
   MapIndexed[(#1 /. {x_, y_} :> {x, y + shift First@#2}) &, 
    Cases[ifg, Line[p_] :> p, \[Infinity]]];
  ridges = MapThread[makeRidges[#1, #2, shift/2] & , {lines, colors}];
  Graphics[Reverse@Riffle[polys, ridges], 
   AspectRatio -> 1/GoldenRatio, ImageSize -> Large]
  ]

and to use it (first I resample the timeseries to months):

ts = TimeSeriesResample[Transpose@#, "Month", 
     ResamplingMethod -> {"Interpolation", 
       InterpolationOrder -> 0}] & /@ {students, everyone};

junkify[DateListPlot[ts, Joined -> True, InterpolationOrder -> 1, 
  Filling -> Bottom, 
  FillingStyle -> {1 -> Lighter[Green], 2 -> Lighter[Blue]}], 10]

Mathematica graphics

For more than two datasets:

rf := RandomFunction[BinomialProcess[1/3], {0, 50}]

junkify[ListPlot[{rf, rf, rf}, Joined -> True, 
  InterpolationOrder -> 1, Filling -> Bottom, 
  FillingStyle -> {1 -> Lighter[Blue], 2 -> Lighter[Green], 
    3 -> Lighter[Red]}], 5]

Mathematica graphics

| improve this answer | |
$\endgroup$
  • $\begingroup$ Are you shading based on the slope here, chuy? THIS IS AWESOME! $\endgroup$ – CA Trevillian Jun 6 at 1:20
  • 1
    $\begingroup$ Yeah, I just Nest Darker according to its change in y (assuming all changes in x are the same). $\endgroup$ – chuy Jun 8 at 17:41
  • $\begingroup$ thanks for this answer! I know I’ll learn a lot from everyone’s code, but this one comes closest to replicating the excel version. The only missing parts are the borders to the edges of the fillings. If I might ask another point of clarification, how is it that the filling for the plots beyond the first one are shifted along with the plot? I’m not confident on how they still fill to the “axis” even though they’re shifted some amount away from them. Do you think I might be able to give something like an EdgeForm to FillingStyle? $\endgroup$ – CA Trevillian Jun 9 at 2:03
7
$\begingroup$

Maybe this will help as a starting point?

offset = 8;
threeD = 4;
initialheight = 2;
dates = DateRange[students[[1, 1]], students[[1, -1]], 
   Quantity[2, "Months"]];
tsStudents = TimeSeries[Transpose[students]];
tsEveryone = TimeSeries[Transpose[everyone]];
lStudents = 
  Line[{{#, tsStudents[#] + initialheight}, {#, 
       tsStudents[#] + threeD + initialheight}}] & /@ dates;
lEveryone = 
  Line[{{#, tsEveryone[#] + offset + initialheight}, {#, 
       tsEveryone[#] + offset + threeD + initialheight}}] & /@ dates;
DateListPlot[{
  everyone + {0, offset + threeD + initialheight} // Transpose,
  everyone + {0, offset + initialheight} // Transpose,
  students + {0, threeD + initialheight} // Transpose,
  students + {0, initialheight} // Transpose
  },
 Joined -> True,
 Mesh -> All,
 PlotStyle -> Directive[Thick, Black],
 Filling -> {{1 -> {{2}, Lighter[Blue, 0.5]}}, {2 -> {offset, 
      Lighter[Blue]}}, {3 -> {{4}, Darker[Green]}}, {4 -> {Bottom, 
      Lighter[Green]}}},
 Epilog -> {
   AbsoluteThickness[2],
   lEveryone,
   lStudents,
   Line[{{dates[[1]], initialheight}, {dates[[1]], 0}, {dates[[-1]], 
      0}, {dates[[-1]], 
      tsEveryone[dates[[-1]]] + initialheight + offset}}],
   Line[{{dates[[1]], 
      tsEveryone[dates[[1]]] + initialheight + offset}, {dates[[1]], 
      offset}, {dates[[5]], offset}}]
   }
 ]

Pseudo 3D graph.

I'm not totally sure how to vary the shading along the top in a realistic way. I don't think Filling would be sufficient for that. It would probably require a custom polygon with its own shading or something. I kind of think that to get realistic lighting, it might actually be easier to just go full 3D in Mathematica.

I kind of fudge the black line that goes around the bottom edge of the blue region. If I use Prolog, it will look wonky because the filling will go over top of it. If I split it into 2 graphs and use Epilog the second Epilog is not honoured when you use Show. So I kind of just terminated it where I thought it looked good.

Another issue is that the black bars in the graph you posted occur at every "corner". I suspect this is in part because the data itself is evenly spaced, so corners can only occur at particular points. This could be dealt with, but it depends one whether you prefer the black bars to be evenly spaced, or if it's okay to have arbitrary spacing so long as their positions make sense.

Perhaps you or someone else might find a better way, but maybe this will at least stir some creative juices?

| improve this answer | |
$\endgroup$
  • 2
    $\begingroup$ Consider the creative juices stirred AND shaken!! I bet I could even get the weird interpolation they produce by using an evenly spaced discretization as you referenced. The data I have is what was used to make the excel graph, so I'm not sure how that was decided, probably by months I think. It would be something like keeping the slope constant until the next point would adjust that...simple algorithm to say in words, but I am not sure about how I would program it simplistically. $\endgroup$ – CA Trevillian Jun 5 at 3:31
  • $\begingroup$ The realistic lighting will definitely be difficult. Maybe full 3D is indeed the way to go for that. It would require a bit of finesse unless the strict direction of say, Left or Right or related give the proper perspective! $\endgroup$ – CA Trevillian Jun 5 at 17:47
7
$\begingroup$
ClearAll[chartJunk2D]
chartJunk2D[vshift_: 4, rs_: {1, "Month"}] := Module[{ts = TimeSeries[Transpose @ #], 
      resampled}, 
    resampled = TimeSeriesResample[ts, {Automatic, Automatic, rs}]; 
    DateListPlot[{ts, TimeSeriesMap[# + vshift &, ts], 
      resampled, TimeSeriesMap[# + vshift &, resampled] }, 
     PlotStyle -> #2, Joined -> {True, True, False, False}, 
     Filling -> {1 -> {{2}, Opacity[.5, Lighter@#2]}, 
       2 -> {Bottom, Opacity[.5, Lighter@Lighter@#2]}, 
       3 -> {{4}, Opacity[1, #2]}}]] /. _Point -> {} &

Example:

Show[chartJunk2D[][everyone, Blue], chartJunk2D[][students, Red], 
   ImageSize -> Large]

enter image description here

Update:

ClearAll[chartJunk3D]
chartJunk3D = Module[{coords = #[[1, 2, 1]], prims = #[[1, 2, 2]], 
     vp = {0.07, -1., 1.7}, coords3D, replacements},
    coords3D = Join[Append[#, 0] & /@ coords, Append[#, 1] & /@ coords];
    replacements = {Line[x_] :> {Line[x], Line[x + Length@coords]}, 
      Point[x_] :> {Dynamic@EdgeForm[Darker@CurrentValue["Color"]], 
        Polygon /@ (Join[#, Reverse[#] + Length[coords]] & /@ Partition[x, 2, 1])}};
    Graphics3D[GraphicsComplex[coords3D, prims /. replacements], 
     Boxed -> False, BoxRatios -> {1, 1, 1/20}, 
     FaceGrids -> {{{0, 0, -1}, MinMax /@ Transpose[coords]}}, 
     Lighting -> "Neutral", ViewPoint -> vp]] &;

Example:

{dlp1, dlp2} = MapThread[DateListPlot[
   TimeSeriesResample[TimeSeries[Transpose@#], {Automatic, Automatic, {1, "Month"}}], 
     PlotStyle -> #2, Mesh -> All, Filling -> Bottom] &,
   {{everyone, students}, {Blue, Green}}];

Show[chartJunk3D[dlp1], chartJunk3D[dlp2], ImageSize -> Large]

enter image description here

| improve this answer | |
$\endgroup$
  • 1
    $\begingroup$ This is great! I think, now, all I would need to do is figure out the weird interpolation algorithm that is used! It looks to me like it accentuates the additional values when they change, hence why it is used. I imagine it has something to do with how they're discrete values so interpolating a gradual increase doesn't make sense. That's for another day, I think, and not pertaining to how amazing this answer is! The chartjunk version is definitely interesting, but I dig the straightforward simplicity of the non-chartjunk one, too ;) $\endgroup$ – CA Trevillian Jun 5 at 8:42

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.