7
$\begingroup$

I want to create a two-dimensional plot using data from an external file. This file contains several triplets of numbers. The first two columns indicate the x and y position, while the third one works as an indicator for every (x,y) point. The desired plot should depict each point as a colorful dot and the color of each dot should be assigned according to the value of the third column. I used ListDensityPlot to create my plot but for a strange reason it joins all the points together and of course spreads the colors. This is the code I used:

SetDirectory[" ... To be inserted ... "];
data = Import["Esc_data.out", "Table"];
S1 = ListDensityPlot[data, Mesh -> None, ColorFunction -> "Rainbow", 
PlotLegends -> Placed[BarLegend[Automatic, LegendMargins -> 
{{0, 0}, {10, 5}}, LegendLabel -> "\!\(\*SubscriptBox[\(log\), \(10\)]\)(Tesc)",
LabelStyle -> {FontSize -> 15, FontFamily -> "Helvetica"}], 
Right], PerformanceGoal -> "Quality", FrameLabel -> {"x", "y"}, 
RotateLabel -> False, 
LabelStyle -> Directive[FontSize -> 17, FontFamily -> "Helvetica"], 
ImageSize -> 500]

The correct plot should be the following: correc plot

It took me two minutes and four lines in gnuplot to create this plot! So, it must be achievable in Mathematica too. However, I couldn't find out how to control the size of the dots and mainly how to "tell" to the program not to join the points between them.

The data file can be obtained here or here.

Many many thanks in advance!

I modified VLC's last version like this

Clear[colorbar]
colorbar[{min_, max_}, colorFunction_: Automatic, divs_: 150] := 
DensityPlot[y, {x, 0, 0.1}, {y, min, max}, AspectRatio -> 10, 
PlotRangePadding -> 0, PlotPoints -> {2, divs}, MaxRecursion -> 0, 
Frame -> True, 
FrameLabel -> {{None, 
 "log10(\!\(\*SubscriptBox[\(T\), \(esc\)]\))"}, {None, None}}, 
LabelStyle -> Directive[FontFamily -> "Helvetica", 15], 
FrameTicks -> {{None, All}, {None, None}}, 
FrameTicksStyle -> Directive[FontFamily -> "Helvetica", 15, Plain], 
ColorFunction -> colorFunction]

With[{opts = {ImageSize -> {Automatic, 500}}, cf = "Rainbow"}, 
Row[{ListPlot[List /@ data[[All, {1, 2}]], 
PlotStyle -> ({PointSize[0.0045], ColorData[cf][#1]} & /@ 
   Rescale[data[[All, 2]], {1.5, 5}]), 
PlotRange -> {{-1, 1}, {-1, 1}}, AspectRatio -> 1, Frame -> True, 
AspectRatio -> 1, RotateLabel -> False, Axes -> None, 
FrameTicks -> True, FrameLabel -> {"x", "y"}, 
LabelStyle -> Directive[FontFamily -> "Helvetica", 17], 
ImagePadding -> {{60, 10}, {60, 20}}, opts], 
Show[colorbar[{1.5, 5}, cf], ImagePadding -> {{10, 60}, {20, 10}}, 
opts]}]]

Now the frame labels of the main plot are shown. However, the colorbar is larger than the square. I want the height of the colorbar to be the same as the height of the square. Finally, how could I merge in a Show this plot with the following contour

V = 1/2*(ω1^2*x^2 + ω2^2*y^2) - ϵ*x^2*y^2;
ω1 = 0.4; ω2 = 0.4;
ϵ = 1;
xmin = 1;
hesc = 0.0064;
C0 = ContourPlot[V, {x, -xmin, xmin}, {y, -xmin, xmin}, 
Contours -> {hesc}, ContourStyle -> {Gray, Thickness[0.003]}, 
AspectRatio -> 1, ContourShading -> False, PlotRange -> All, 
PlotPoints -> 200, ImageSize -> 500];

new plot

Improve this question
$\endgroup$
3
  • $\begingroup$ @VLC The LegendLabel should be inserted inside the colorbar module? $\endgroup$
    – Vaggelis_Z
    Jan 10, 2013 at 20:50
  • $\begingroup$ I suspect that there must be a much easier way to produce this plot. VLC's code working fine but you have to create the colorbar on your own! What I mean, is that ListDensityPlot SHOULD have an option like Joined->False. $\endgroup$
    – Vaggelis_Z
    Jan 10, 2013 at 20:56
  • $\begingroup$ @VLC Hey, I am new here; I don't know all the rules yet! Anyway, I think that your solution is more close to what I want. The only issue is how to label the colorbar and also how could I change the fonts of the colorbar. $\endgroup$
    – Vaggelis_Z
    Jan 11, 2013 at 11:33

3 Answers 3

Reset to default
13
$\begingroup$

I would simply use ListPlot with a PlotStyle that is defined as a function of your third column:

ListPlot[List /@ data[[All, {1, 2}]], 
 PlotStyle -> ({PointSize[0.01], ColorData["Rainbow"][#1]} & /@ 
    Rescale[data[[All, 3]], {1.5, 4}]), 
 PlotRange -> {{-1, 1}, {-1, 1}}, AspectRatio -> 1, Frame -> True, 
 Axes -> None]

enter image description here

To add the color legend you could use the solution provided here that in your case would look like:

Clear[colorbar]
colorbar[{min_, max_}, colorFunction_: Automatic, divs_: 150] := 
 DensityPlot[y, {x, 0, 0.1}, {y, min, max}, AspectRatio -> 10, 
  PlotRangePadding -> 0, PlotPoints -> {2, divs}, MaxRecursion -> 0, 
  FrameTicks -> {None, Automatic, None, None}, 
  ColorFunction -> colorFunction]

With[{opts = {ImageSize -> {Automatic, 300}, ImagePadding -> 20}, 
  cf = "Rainbow"}, 
 Row[{ListPlot[List /@ data[[All, {1, 2}]], 
    PlotStyle -> ({PointSize[0.01], ColorData["Rainbow"][#1]} & /@ 
       Rescale[data[[All, 3]], {1.5, 4}]), 
    PlotRange -> {{-1, 1}, {-1, 1}}, AspectRatio -> 1, Frame -> True, 
    Axes -> None, FrameTicks -> True, opts], 
   Show[colorbar[{1.5, 4}, cf], opts]}]]

enter image description here

With some additional options you can change the default font and add a label to the color legend:

Clear[colorbar]
colorbar[{min_, max_}, colorFunction_: Automatic, divs_: 150] := 
 DensityPlot[y, {x, 0, 0.1}, {y, min, max}, AspectRatio -> 10, 
  PlotRangePadding -> 0, PlotPoints -> {2, divs}, MaxRecursion -> 0, 
  Frame -> True, FrameLabel -> {{None, "log10(Tesc)"}, {None, None}}, 
  LabelStyle -> Directive[FontFamily -> "Helvetica", 14, Bold], 
  FrameTicks -> {{None, All}, {None, None}}, 
  FrameTicksStyle -> Directive[FontFamily -> "Helvetica", 10, Plain], 
  ColorFunction -> colorFunction]

With[{opts = {ImageSize -> {Automatic, 300}}, cf = "Rainbow"}, 
 Row[{ListPlot[List /@ data[[All, {1, 2}]], 
    PlotStyle -> ({PointSize[0.01], ColorData[cf][#1]} & /@ 
       Rescale[data[[All, 3]], {1.5, 4}]), 
    PlotRange -> {{-1, 1}, {-1, 1}}, AspectRatio -> 1, Frame -> True, 
    Axes -> None, FrameTicks -> True, 
    LabelStyle -> Directive[FontFamily -> "Helvetica", 10], 
    ImagePadding -> {{40, 10}, {20, 20}}, opts], 
   Show[colorbar[{1.5, 4}, cf], ImagePadding -> {{10, 40}, {20, 20}}, 
    opts]}]]

enter image description here

Last additions:

Clear[colorbar]
colorbar[{min_, max_}, colorFunction_: Automatic, divs_: 150] := 
 DensityPlot[y, {x, 0, 0.1}, {y, min, max}, AspectRatio -> 10, 
  PlotRangePadding -> 0, PlotPoints -> {2, divs}, MaxRecursion -> 0, 
  Frame -> True, 
  FrameLabel -> {{None, 
     "log10(\!\(\*SubscriptBox[\(T\), \(esc\)]\))"}, {None, None}}, 
  LabelStyle -> Directive[FontFamily -> "Helvetica", 15], 
  FrameTicks -> {{None, All}, {None, None}}, 
  FrameTicksStyle -> Directive[FontFamily -> "Helvetica", 15, Plain], 
  ColorFunction -> colorFunction]

ω1 = 0.4;
ω2 = 0.4;
ϵ = 1;
V[x_, y_] := 
  1/2*(ω1^2*x^2 + ω2^2*y^2) - ϵ*x^2*y^2;
xmin = 1;

fig = ContourPlot[
   Evaluate[V[x, y]], {x, -xmin, xmin}, {y, -xmin, xmin}, 
   Contours -> 10, ContourStyle -> {{Gray, Thickness[0.003]}}, 
   AspectRatio -> 1, ContourShading -> False, 
   PlotRange -> {{-1, 1}, {-1, 1}}];

With[{opts = {ImageSize -> {Automatic, 500}}, cf = "Rainbow"}, Row[{
   Show[
    ListPlot[List /@ data[[All, {1, 2}]], 
     PlotStyle -> ({PointSize[0.0045], ColorData[cf][#1]} & /@ 
        Rescale[data[[All, 2]], {1.5, 5}]), 
     PlotRange -> {{-1, 1}, {-1, 1}}, AspectRatio -> 1, Frame -> True,
      AspectRatio -> 1, RotateLabel -> False, Axes -> None, 
     FrameTicks -> True, FrameLabel -> {"x", "y"}, 
     LabelStyle -> Directive[FontFamily -> "Helvetica", 17], 
     ImagePadding -> {{60, 20}, {60, 20}}, opts],
    fig],
   Show[colorbar[{1.5, 5}, cf], ImagePadding -> {{20, 60}, {60, 20}}, 
    opts]}]]

enter image description here

Improve this answer
$\endgroup$
12
  • $\begingroup$ Very Good! But how could we insert the vertical PlotLegends in order to indicate the different colors? $\endgroup$
    – Vaggelis_Z
    Jan 10, 2013 at 19:19
  • $\begingroup$ @Vaggelis_Z See update for a plot with a vertical color legend. $\endgroup$
    – VLC
    Jan 10, 2013 at 19:32
  • $\begingroup$ @Vaggelis_Z The last addition should do what you're looking for. I suggest that you play a bit with the different options (ImagePadding,LabelStyle,FrameLabel,FrameTicks,FrameTicksStyle etc.) to see what contribution has each of these. $\endgroup$
    – VLC
    Jan 11, 2013 at 12:12
  • $\begingroup$ Your last version is OK. However, I have two questions: (i) How could I add FrameLabel in the main plot and also (ii) how to combine in a Show this plot with another one let's say a ContourPlot $\endgroup$
    – Vaggelis_Z
    Jan 15, 2013 at 15:53
  • $\begingroup$ @Vaggelis_Z (i) you just need to insert FrameLabel in the list of options that are within the ListPlot function and you will probably have to adjust the ImagePadding in the case the labels are not visible. (ii) Your question is already the answer: enclose the ListPlot and the ContourPlot within Show[] and place it instead of the ListPlot that is now in the code. $\endgroup$
    – VLC
    Jan 15, 2013 at 16:13
7
$\begingroup$

Part of the original question referred to a density plot. To incorporate that element into the solution this version includes Opacity to allow the density of areas with close or overlapping points to be assessed. Such an effect can be observed in the two upper quadrant clusters.

densityHeatMap[data, opacity->0.5, Frame->True, FrameLabel->{"", "", "", "log10(Tesc)"}]

Mathematica graphics

An additional benefit is that it gives some insight into areas where points of some particular some value might be obscured by overlapping, perhaps densely, points of different values. This effect is observable in the tips of the four main clusters where some high value points can be overlapped by lower value ones. 

Clear@densityHeatMap;
Options[densityHeatMap] = {opacity -> 0.25, shiftRatio -> 1.05, 
   colorFunction -> ColorData["Rainbow"], pointSize -> 0.005,
   numHues -> 10, legend -> True, Frame -> True, 
   FrameTicks -> {Automatic, Automatic, Automatic, None}, 
   FrameLabel -> {"", "", "", ""}};
densityHeatMap[data_, opts : OptionsPattern[]] := 
 Module[{hues, shift, lLbls, lLocs, lSize, minX, maxX, minY, maxY, minZ, maxZ, lgnd,
   cf = OptionValue@colorFunction, op = OptionValue@opacity, 
   ps = OptionValue@pointSize, sr = OptionValue@shiftRatio, 
   nh = OptionValue@numHues},
  {{minX, maxX}, {minY, maxY}, {minZ, maxZ}} = {Min@#, Max@#} & /@ (data\[Transpose]);
  shift = {maxX sr, 0}; lLbls = FindDivisions[{minZ, maxZ}, nh] // N;
  hues = Range[0, 1, 1/(Length@lLbls - 1)] // N;

  lLocs = {0, #} & /@ 
    Range[Sequence @@ {minY, 
       maxY}, (Subtract @@ {maxY, minY})/(Length@lLbls - 1)];
  lSize = Subtract @@ lLocs[[{-1, 1}, 2]]/(Length@lLbls);

  lgnd = Graphics@
    MapThread[{cf[#1], Opacity@op, 
       Rectangle @@ {#3 + shift, #3 + {lSize, lSize} + shift},
       Darker@Gray, 
       Text[ToString@#2, #3 + {0.2, lSize/2} + shift]} &, {hues, 
      lLbls, lLocs}];

  Show[Graphics[{cf[#3], PointSize@ps, Opacity@op, 
       Point[{#1, #2}]} & @@@ 
     Transpose[{data[[All, 1]], data[[All, 2]], 
       Rescale@data[[All, 3]]}]], lgnd, 
   Sequence @@ FilterRules[{opts}, Options@Graphics]]  
  ]

A more concise skeletal version is given below.

d = Import["/tmp/Esc_data.out", "Table"];

With[{s=Max@d[[All,3]]},Show[Graphics[{1-Hue[#3/s],Point[{#1, #2}]}& @@@ d], Frame->True]]

Mathematica graphics

You can insert a PointSize directive if you want to adjust the size of the points.

Improve this answer
$\endgroup$
6
  • $\begingroup$ One line indeed! But what about the vertical color legend? $\endgroup$
    – Vaggelis_Z
    Jan 10, 2013 at 20:51
  • $\begingroup$ Use a single Point expression and VertexColors (as I did here) for better performance. +1 $\endgroup$
    – Mr.Wizard
    Jan 11, 2013 at 6:07
  • $\begingroup$ @Mr.Wizard I could use the Point expression but how could I appear the vertical colorbar which explains the different colors? $\endgroup$
    – Vaggelis_Z
    Jan 11, 2013 at 7:54
  • $\begingroup$ You have sacrificed AspectRatio -> 1 for the one line :) $\endgroup$
    – István Zachar
    Jan 11, 2013 at 8:58
  • $\begingroup$ @IstvánZachar Using image_doctor's code how could I insert the vertical colorbar and also name it as log10(Tesc)? $\endgroup$
    – Vaggelis_Z
    Jan 11, 2013 at 11:12
3
$\begingroup$

This is anything but fast, but here's how you do it with BubbleChart:

data = Import["C:\\Temp\\Esc_data.out", "Table"];
range = {Min@#, Max@#} &@data[[All, 3]];

plot =  BubbleChart[data, PlotRange -> {{-1, 1}, {-1, 1}}, ImageSize -> 300, 
   ChartElementFunction -> ({
       EdgeForm@None, 
       Hue[Rescale[Last@#2, range, {.6, 0.}]],
       Disk[Most@#2, .02]
     } &)];

legend = Grid[Table[{Graphics[{Hue[i], Rectangle[]}, ImageSize -> 25], 
              Rescale[i, {0, .6}, Reverse@range]},
       {i, 0, .6, .6/8}], Spacings -> {.3, 0}, Alignment -> Left];

Row@{plot, Labeled[legend, "legend\ntitle", Top]}

Mathematica graphics

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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