How can I create an interactive ColorFunction using Manipulate?

Question

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?

Answer 1

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]

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]

Answer 2

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"]}]]]}]]]]

(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:

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":

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"]}]]]}]]]]]