14
$\begingroup$

I am trying to specify my own colors and scaling for the ColorFunction in ListDensityPlot. I have several lists of 2D values which I plot in multiple images, and I want to scale the data according to the absolute maximum and minimum value taken from all the lists.

I want to visualize all the data, but some lists contain quite small values, and a few lists contain data approximately 100× larger.

I have been trying to use Blend, with the intention of scaling from the minimum to the maximum of the plotted values, using custom colors:

MyPlot = ListDensityPlot[Transpose[Join[Transpose[Points],
                                        Rescale[Transpose[#], {MinV, MaxV}]]],
                         AspectRatio -> Automatic,
                         ColorFunction -> (Blend[{{0, Purple}, {0.5, Blue},
                                                  {1, Green}, {3, Yellow},
                                                  {6, Red}}, #] &),
                         ColorFunctionScaling -> False,
                         PerformanceGoal -> "Quality",
                         PlotRange -> All] &;

However, I was thinking that it would be nice to create something like a Manipulate bar to change the values related to the used colors and "tune" the colors in a more comfortable way.

Can anyone give me advice on how to implement it?

$\endgroup$
12
$\begingroup$

This is a really neat idea, and I'm happy with how straightforward it was to make, and fun it is to move the sliders around:

Manipulate[
 {a, x, y, z, b} = 
  Rescale[{aa, xx, yy, zz, bb}, MinMax@{aa, xx, yy, zz, bb}];
 colors = 
  Transpose[{{a, x, y, z, b}, {Purple, Blue, Green, Yellow, Red}}];
 DensityPlot[
  Sin[x] Cos[y], {x, -2 π, 2 π}, {y, -2 π, 2 π},
  ColorFunction -> (Blend[colors, #] &), PlotLegends -> Automatic, 
  PlotPoints -> 100],
 {{aa, 0, "Purple"}, 0, 1, .01},
 {{xx, .25, "Blue"}, 0, 1, .01},
 {{yy, .5, "Green"}, 0, 1, .01},
 {{zz, .75, "Yellow"}, 0, 1, .01},
 {{bb, 1, "Red"}, 0, 1, .01}]
Dynamic[colors]

enter image description here

After you've moved the slider and found the color function you like, the list of colors and their values are stored in the global variable colors and so you can recover the final ColorFunction as (Blend[colors, #]&)

Total control over colors and Blend

You can easily use Manipulate to make a custom color function like this,

Manipulate[
  {a, x, y, z, b} = 
    Rescale[{aa, xx, yy, zz, bb}, MinMax@{ aa, xx, yy, zz, bb}];
  colors = 
    Transpose[{{a, x, y, z, b}, {color1, color2, color3, color4, 
     color5}}];
  DensityPlot[
    Sin[x] Cos[y], {x, -2 π, 2 π}, {y, -2 π, 2 π},
    ColorFunction -> (Blend[colors, #] &), PlotLegends -> Automatic, 
    PlotPoints -> 100],
 Grid[{
   {Control[{{aa, 0, ""}, 0, 1}], 
    Control[{{color1, Purple, "Color1"}, Red}]},
   {Control[{{xx, .25, ""}, 0, 1}], 
    Control[{{color2, Cyan, "Color2"}, Red}]},
   {Control[{{yy, .5, ""}, 0, 1}], 
    Control[{{color3, Brown, "Color3"}, Red}]},
   {Control[{{zz, .75, ""}, 0, 1}], 
    Control[{{color4, Yellow, "Color4"}, Red}]},
   {Control[{{bb, 1, ""}, 0, 1}], 
    Control[{{color5, Magenta, "Color5"}, Red}]}
   }],
 ControlPlacement -> Top
  ]
Dynamic[colors]

enter image description here

$\endgroup$
6
$\begingroup$

I recently needed to do something like this. The only wrinkle is that I did not find Manipulate[] to be sufficiently flexible for my needs, so I fell back on using DynamicModule[]. Hopefully, this is still admissible.

With[{cmax = 12}, (* maximum number of colors *)
     DynamicModule[{k = 3, cols = {Red, White, Blue}, vals = {0., 0.5, 1.}}, 
                   Panel[Column[{Column[{
                   Row[{Dynamic[Style["colors: " <> IntegerString[k], Bold]], Spacer[20], 
                        Slider[Dynamic[k, (k = #; cols = PadRight[cols, k, Gray]; 
                                           vals = Rescale[ArrayPad[vals,
                                                                   {0, k - Length[vals]},
                                                                   "Extrapolated"]]) &],
                               {2, cmax, 1}]}], 
                   Dynamic[Multicolumn[Array[
                   Column[{ColorSlider[Dynamic[cols[[#]]]], 
                           Row[{Dynamic[Style[vals[[#]], Small, Bold]], Spacer[20], 
                           Slider[Dynamic[vals[[#]]], ImageSize -> Small]}]}] &, k], 6,
                                  Appearance -> "Horizontal"], TrackedSymbols :> {k}]}], 
                   Dynamic[With[{cl = Transpose[{vals, cols}]}, 
                                Column[{Panel[LinearGradientImage[Blend[cl, #] &,
                                                                  {600, 60}]], 
                                        Button["Copy to clipboard", 
                                               CopyToClipboard[Defer[Blend[cl, #] &]],
                                               ImageSize -> Medium,
                                               Method -> "Queued"]}]]]}]]]]

interactive color gradient maker

(Thanks to Karsten for some suggested improvements.)


update 9/10/2017

Prompted by this Wolfram Community post by Kevin Daily, I've written an expanded version of the interface given above:

extended interactive color gradient maker

Apart from creating your own, one can now load the available color gradients into Mathematica for editing. I've added a "Resample" mode (versus the original "Pad" mode), which allows one to make a finer (or coarser, as the case may be) resampling of the currently loaded gradient. Finally, one can now use the sliders to the right of the ColorSlider[] objects to tweak the $\alpha$ parameter for a color.

Here is the interface being used to edit "M10DefaultDensityGradient":

editing a built-in color gradient

The code is now quite a bit longer, but hopefully not very:

With[{cmax = 18},
     DynamicModule[{k = 3, cols = {Red, White, Blue}, vals = {0., 0.5, 1.},
                    alf = {1, 1, 1}, grad = None, mode = 2, tmp},
                   Deploy[Panel[Column[{Column[{Row[{
                          PopupMenu[Dynamic[grad,
                                            (grad = #;
                                             tmp = ColorData[grad, "BlendArgument"];
                                             k = Length[tmp]; 
                                             alf = ConstantArray[1, k]; 
                                             If[ArrayDepth[tmp] == 1, cols = tmp; 
                                                vals = N[Subdivide[k - 1]],
                                                {vals, cols} = Transpose[tmp]];) &], 
                                    Join[ColorData["Gradients"], {Delimiter}, 
                                         ColorData["ThemeGradients"]],
                                    "Select gradient…"],
                          Spacer[30],
                          Dynamic[Style["colors: " <> IntegerString[k], Bold]], 
                          Spacer[10], 
                          Slider[Dynamic[k, (k = #; alf = PadRight[alf, k, 1];
                                             If[mode == 1,
                                                cols = PadRight[cols, k, Gray]; 
                                                vals = 
                                                Rescale[ArrayPad[vals, {0,
                                                                 k - Length[vals]},
                                                                 "Extrapolated"]],
                                                tmp = N[Subdivide[k - 1]]; 
                                                cols =
                                                With[{cl = Transpose[{vals, cols}]}, 
                                                     Blend[cl, #] & /@ tmp];
                                                vals = tmp]) &], {2, cmax, 1}],
                          Spacer[30], Style["mode:", Bold], Spacer[5], 

                          RadioButtonBar[Dynamic[mode], {1 -> "Pad", 2 -> "Resample"},
                                         Appearance -> "Row"]}], 
                          Dynamic[Multicolumn[Array[
                                  Column[{Row[{ColorSlider[Dynamic[cols[[#]]]], 
                                               Spacer[5], 
                                               VerticalSlider[Dynamic[alf[[#]]],
                                                              ImageSize ->
                                                              {Automatic, 40}]}], 
                                          Row[{Dynamic[Style[vals[[#]], Small, Bold]],
                                          Spacer[20],
                                          Slider[Dynamic[vals[[#]]],
                                                 ImageSize -> Small]}]}] &,
                                  k], 6, Appearance -> "Horizontal"],
                                  TrackedSymbols :> {k}]}], 
                          Dynamic[With[{cl = Transpose[{vals, 
                                                        If[Max[Unitize[1 - alf]] == 0,
                                                           cols,
                                                           MapThread[Append,
                                                                     {cols, alf}]]}]}, 
                                       Column[{Panel[LinearGradientImage[Blend[cl, #] &,
                                                                         {600, 60}]],
                                               Button["Copy to clipboard", 
                                                      CopyToClipboard[Defer[InputForm[
                                                                      Blend[cl, #] &]]], 
                                                      ImageSize -> Medium,
                                                      Method -> "Queued"]}]]]}]]]]]
$\endgroup$
  • $\begingroup$ The vals Slider are unresponsive when I'm trying to move them while keeping the left mouse button clicked. I can only change their values with single mouse clicks. Adding TrackedSymbols :> {k} to the Dynamic wrapped around Multicolumn solves that issue. But now the styled vals also need to be Dynamic, which makes the spacing change. $\endgroup$ – Karsten 7. May 24 '16 at 15:30
  • $\begingroup$ Yes, those tweaks certainly improved the response time. Thanks @Karsten! I will edit this in a few. $\endgroup$ – J. M. is in limbo May 24 '16 at 15:52

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.