15
$\begingroup$

I was inspired by this question, which showed how we can apply logarithmic scaling to a density plot.

But I'm not always a fan of a logarithmic scale - it tends to overemphasize smaller features. Consider the example from the post linked above, $\mathrm{sinc}(x)^2$. Here is a comparison of linear and log scaling,

GraphicsRow[{Plot[Sinc[x]^2, {x, -20, 20}, PlotRange -> All], 
  LogPlot[Sinc[x]^2, {x, -20, 20}]}, ImageSize -> 500]

enter image description here

Now look at the same plot using an arcsinh scale

Plot[ArcSinh[100 Sinc[x]^2]/ArcSinh[100], {x, -20, 20}, 
 PlotRange -> All]

enter image description here

This is a useful scale since it has odd symmetry (ArcSinh[-x] = -ArcSinh[x]), and it is defined for x=0. And we can see below how it interpolates between linear and logarithmic scaling,

GraphicsRow[{Plot[ArcSinh[x], {x, -1, 1}, PlotRange -> All], 
  Plot[ArcSinh[x], {x, -1000, 1000}]}, ImageSize -> 500]

enter image description here

So what is the best way to implement this in a density or contour plot? How can the legend be modified to show the scale in an easy-to-read fashion? And would it be possible to make the plotting function versitile so that it can take other scaling functions? Ideally the function could handle negative values.

I had previously worked out a function to plot 2D spectroscopy signals using this scale, but looking at it now I'm a little embarrassed at how hacky it is.

Improve this question
$\endgroup$

2 Answers 2

Reset to default
6
$\begingroup$

Here is a slight simplification of Jason's code for scaled density plots:

Needs["CustomTicks`"];
Options[nonLinearDensityPlot] =
{"ColorFunction" -> Automatic, "ScalingFactor" -> 100,
 "ScalingFunction" -> Automatic, "SignedData" -> Automatic};

nonLinearDensityPlot[func_, {x_, xmin_, xmax_}, {y_, ymin_, ymax_}, 
                     plotopts : OptionsPattern[{nonLinearDensityPlot, DensityPlot}]] := 
   Module[{col, legend, minval, maxval, scalingfunction, sf, sfun, signed},

          {minval, maxval} =
          Table[op[{func, xmin <= x <= xmax && ymin <= y <= ymax},
                {x, y}], {op, {NMinValue, NMaxValue}}];

          signed = OptionValue["SignedData"] /. 
          Automatic -> If[Abs[minval/maxval] < 0.01, False, True];

          col = OptionValue["ColorFunction"] /.
          {Automatic -> If[signed, ColorData[{"ThermometerColors", {-1, 1}}], 
                           ColorData["M10DefaultDensityGradient"]], 
           s_String :> If[signed, ColorData[{s, {-1, 1}}], ColorData[s]]};

          sf = OptionValue["ScalingFunction"] /. 
          Automatic -> (ArcSinh[#1 #2/#3]/ArcSinh[#2] &);
          scalingfunction = sf[#, OptionValue["ScalingFactor"], maxval, minval] &;

          legend = BarLegend[{col, {-Boole[signed], 1}}, 
                             Ticks -> LinTicks[-1, 1, 
                             TickPostTransformation ->
                             (scalingfunction[# maxval] &)] /. 
                             Indeterminate -> 0];

          DensityPlot[func, {x, xmin, xmax}, {y, ymin, ymax}, 
                      ColorFunction -> (Composition[col, scalingfunction][#] &), 
                      ColorFunctionScaling -> False, PlotLegends -> legend, 
                      Evaluate[FilterRules[{plotopts}, Options[DensityPlot]]], 
                      PlotPoints -> 100, PlotRange -> All]]

Some examples:

nonLinearDensityPlot[Sinc[x]^2 Sinc[y]^2, {x, -20, 20}, {y, -20, 20}, 
                     ColorFunction -> "DeepSeaColors"]

the old colors

nonLinearDensityPlot[x y Sinc[x]^2 Sinc[y]^2, {x, -20, 20}, {y, -20, 20}, 
                     ColorFunction -> "TemperatureMap"]

it has its positives and negatives

I haven't quite yet thought about how to cleanly re-implement the scaled contour plotting; I'll edit this if I come up with something.

Improve this answer
$\endgroup$
6
  • $\begingroup$ J.M. - looking into this now, thank you for your attention. Do you mind if I blatantly rip this off, and turn my answer into a community wiki? I want to get these optimized and wrap it up into a package (with attribution to contributors) $\endgroup$
    – Jason B.
    Commented Dec 16, 2015 at 11:20
  • $\begingroup$ Certainly, you can use it as you see fit; as I said on my profile, my licensing is very permissive. ;) $\endgroup$
    – J. M.'s missing motivation ♦
    Commented Dec 16, 2015 at 12:06
  • $\begingroup$ A few points, so you may want to answer me in chat. How do you get such nice indentation? I had given up on it, and just let the front end blast it all to hell as it sees fit. Also, such a better way to treat an Automatic option than what I was doing with SameQ. Last, why does it not matter whether you use "ColorFunction" or ColorFunction as an option, when you've clearly defined only the string version to be an option? $\endgroup$
    – Jason B.
    Commented Dec 16, 2015 at 13:07
  • $\begingroup$ Also, I thought the coloring was odd in your last plot, it seems there is some problem with the NMinValue function and how the constraints are applied. $\endgroup$
    – Jason B.
    Commented Dec 16, 2015 at 13:42
  • $\begingroup$ (I warned you, lol) - Which of these color bars do you think goes better to display the nonlinear scaling? $\endgroup$
    – Jason B.
    Commented Dec 16, 2015 at 14:27
14
$\begingroup$

In order to make the legend properly, I elected to use the CustomTicks package, available here.

The code for the density plotting function is 

<< "CustomTicks`";

Options[nonLinearDensityPlot] = {"SignedData" -> Automatic, 
   "ScalingFactor" -> 100, "Color" -> Automatic, 
   "ScalingFunction" -> (ArcSinh[#1 #2 / #3]/ArcSinh[#2] &)};
nonLinearDensityPlot[func_, xvar_, yvar_, 
  plotopts : OptionsPattern[{DensityPlot, nonLinearDensityPlot}]] := 
 Module[{scalingfunction, minval, maxval, legend, sf, col, signed},

  sf = OptionValue["ScalingFactor"];


  {minval,maxval} = Reap[
       DensityPlot[func, xvar, yvar, 
        PlotRange -> All, PlotPoints -> 50, 
        EvaluationMonitor :> Sow[func]
        ]][[2, 1]] // MinMax;

  signed = If[
    SameQ[OptionValue["SignedData"], Automatic],
        If[Abs[minval/maxval] < 0.01, False, True],
    OptionValue["SignedData"]];

  col = If[SameQ[OptionValue["Color"], Automatic],
    If[signed, (ColorData[
         "ThermometerColors"][.5 # + .5] &), (ColorData[
         "M10DefaultDensityGradient"][#] &)],
    OptionValue["Color"]
    ];
  scalingfunction[dat_] := 
   OptionValue["ScalingFunction"][dat, sf, maxval, minval];

  legend = BarLegend[{col, {If[signed, -1, 0], 1}},
    Ticks -> 
      LinTicks[maxval If[signed,{-1.,-.4,-.2,0,.2,.4,1.0},{0,.2,.4,1.0}],
               maxval If[signed,{-0.9,-0.8,-0.7,-0.6,-0.5,-0.3,0.1,0.3,0.5,0.6,0.7,0.8,0.9},{0.1,.3,.5,.6,.7,0.8,.9}], 
       TickPostTransformation -> (scalingfunction[# ] &),
       TickLabelFunction->(NumberForm[#,ExponentFunction->(If[-2<#<2,Null,#]&)]&),
       TickLabelStep -> 1] /. 
     Indeterminate -> 0];

  DensityPlot[func, xvar, yvar,
   PlotPoints -> 100,
   PlotRange -> All,
   PlotLegends -> legend, ColorFunction -> (col[scalingfunction[#]] &),
   ColorFunctionScaling -> False,
   Evaluate[FilterRules[{plotopts}, Options[Plot]]]
   ]

  ]

It can be called via

nonLinearDensityPlot[Sinc[x]^2 Sinc[y]^2, {x, -20, 20}, {y, -20, 20}]

Mathematica graphics

It has it's own options, and can also take the options of DensityPlot (unfortunately, the color function has to be entered in this awkward way)

nonLinearDensityPlot[40 Sinc[x]^2 Sinc[y]^2, {x, -20, 20}, {y, -20, 20}, 
 BaseStyle -> 18, "ScalingFactor" -> 1000, 
 "Color" -> (ColorData["AvocadoColors"][#] &)]

Mathematica graphics

You can even get the log plot from 's post by giving a custom scaling function,

nonLinearDensityPlot[Sinc[x]^2 Sinc[y]^2, {x, -20, 20}, {y, -20, 20}, 
 "Color" -> (ColorData["DeepSeaColors"][#] &), 
 "ScalingFunction" -> (Log[#1/.00003]/Log[#3/.00003] &)]

Mathematica graphics

And, finally, it can deal with data that takes positive and negative values.

nonLinearDensityPlot[
 x y Sinc[x]^2 Sinc[y]^2, {x, -20, 20}, {y, -20, 20}]

Mathematica graphics

The ContourPlot counterpart is a bit more complicated, as we need to use an inverse function to decide where to draw the contour lines,

     Options[nonLinearContourPlot] = {"SignedData" -> Automatic, 
       "ScalingFactor" -> 100, "Color" -> Automatic, 
       "ScalingFunction" -> (ArcSinh[#1 #2 / #3]/ArcSinh[#2] &),"NContours"->20};
    nonLinearContourPlot[func_, xvar_, yvar_, 
      plotopts : OptionsPattern[{ContourPlot, nonLinearContourPlot}]] := 
     Module[{scalingfunction, minval, maxval, legend, sf, col, signed, 
       inversescalingfunction, contourlevels},

      sf = OptionValue["ScalingFactor"];

   {minval,maxval} = Reap[
       DensityPlot[func, xvar, yvar, 
        PlotRange -> All, PlotPoints -> 50, 
        EvaluationMonitor :> Sow[func]
        ]][[2, 1]] // MinMax;

      signed       = If[
        SameQ[OptionValue["SignedData"], Automatic],
            If[Abs[minval/maxval] < 0.01, False, True],
        OptionValue["SignedData"]];

      col = If[SameQ[OptionValue["Color"], Automatic],
        If[signed, (ColorData[
             "ThermometerColors"][.5 # + .5] &), (ColorData[
             "Rainbow"][#] &)],
        OptionValue["Color"]
        ];
      scalingfunction[dat_] := 
       OptionValue["ScalingFunction"][dat, sf, maxval, minval];

      inversescalingfunction = InverseFunction[scalingfunction[#] &];

      contourlevels = ({inversescalingfunction[#/maxval] , 
           col[#/maxval]} &) /@ 
        Range[If[signed, -maxval, 0], maxval, maxval/OptionValue["NContours"]];

     legend = BarLegend[{col, {If[signed, -1, 0], 1}},
       Ticks -> 
         LinTicks[maxval If[signed,{-1.,-.4,-.2,0,.2,.4,1.0},{0,.2,.4,1.0}],
                  maxval If[signed,{-0.9,-0.8,-0.7,-0.6,-0.5,-0.3,0.1,0.3,0.5,0.6,0.7,0.8,0.9},{0.1,.3,.5,.6,.7,0.8,.9}], 
          TickPostTransformation -> (scalingfunction[# ] &),
          TickLabelFunction->(NumberForm[#,ExponentFunction->(If[-2<#<2,Null,#]&)]&),
          TickLabelStep -> 1] /. 
        Indeterminate -> 0];

      ContourPlot[func, xvar, yvar,
       PlotPoints -> 100,
       PlotRange -> All,
       PlotLegends -> legend,
       Contours -> contourlevels,
       ColorFunction -> (col[scalingfunction[#]] &),
       ColorFunctionScaling -> False,
       Evaluate[FilterRules[{plotopts}, Options[ContourPlot]]],
       ContourShading -> False
       ]

      ]

It can be called via

nonLinearContourPlot[
 3 Sinc[x]^2 Sinc[y]^2, {x, -20, 20}, {y, -20, 20}, "NContours" -> 60]

Mathematica graphics

Turning on ContourShading slows it down a good deal, and ends up making a similar plot to the DensityPlot

nonLinearContourPlot[
 3 Sinc[x]^2 Sinc[y]^2, {x, -20, 20}, {y, -20, 20}, 
 ContourShading -> True]

Mathematica graphics

Any thoughts on improving these functions, making them less of a kludge, are greatly appreciated.

Improve this answer
$\endgroup$

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.