3
$\begingroup$

I have a data file (can be downloaded here). Each line of the data has three numbers corresponding to x,y,z, the data can be formed by

data = ReadList["test.dat",{number,number,number}];

If I plot this data with ListPointPlot3D@data, I got

enter image description here

You can see that it is extremely dense in the y axis, and sparse on x axis.

But if I plot the data with ListDensityPlot@data, I got

enter image description here

Though this plot capture the shape, but it is misleading. It plots many segments of horizontal lines instead of a continuous line with varying line width ( the line width indicate the weight). It makes people feel the following way

enter image description here

Interpolation order doesn't solve this.

For example,

f = Interpolation[data, InterpolationOrder -> 4];
DensityPlot[f[x, y], {x, 1, 41}, {y, -5, 19.52`}, PlotPoints -> 150, 
 PlotRange -> All]

still gives the same result.

Of course, one simple way to improve this is to increase x grid. But x grid has a much more computational cost than y grid.

So how to get better interpolation of such kind of DensityPlot dataset with very asymmetry grid? The Plot should be showing continuous lines with varying line width like this

enter image description here

$\endgroup$
  • $\begingroup$ Well, is the graphic posted in the end generated from such a coarse grid? $\endgroup$ – xzczd Oct 27 '17 at 8:30
  • $\begingroup$ @xzczd No, they use dense grid. And this is my problem, dense grid takes time. I think, proper interpolation scheme specific to this problem could achieve the same effect with much coarser grid. But the default interpolation is not suited for this problem. $\endgroup$ – matheorem Oct 27 '17 at 8:42
2
$\begingroup$

So you want continuous lines in your density plot, but you have very sparse data. So here's an upsampling-based method.

First some trivial upsampling based on neighbor-distance:

subdata = Pick[data, GreaterThan[.1] /@ Rescale@data[[All, 3]]];

upsampled =
  DeleteDuplicates[#, Norm[#[[;; 2]] - #2[[;; 2]]] < .1 &] &@
   Join[
    Flatten[
     Table[
      If[1 < Norm[subdata[[i, ;; 2]] - subdata[[j, ;; 2]]] < 1.5,
       Mean@subdata[[{i, j}]],
       Nothing
       ],
      {i, Length@subdata},
      {j, Length@subdata}
      ],
     1
     ],
    subdata
    ];
upsampled[[All, ;; 2]] // Point // Graphics

upsamp 1

Then make a background grid where the true interpolation will live:

gridspacings =
  MapThread[
   Append[
     MinMax[#],
     Min@{
       Min@
        Select[GreaterThan[10^-3]]@
         Differences@Sort[#2],
       .1
       }
     ] &, {
    Transpose@data[[All, ;; 2]],
    Transpose@upsampled[[All, ;; 2]]
    }];
background =
  Flatten[
   Table[{x, y},
    Evaluate@{x, Sequence @@ gridspacings[[1]]},
    Evaluate@{y, Sequence @@ gridspacings[[2]]}
    ],
   1
   ];

Next let grid points have the value of the nearest point in the original sample and use a 1/r^n-type decay to assign the real value at a grid point:

nf = Nearest[Thread[upsampled[[All, ;; 2]] -> upsampled]];
bgn = nf[background, 1][[All, 1]];
mtBg =
  Compile[
   {{bg, _Real, 2}, {nb, _Real, 
     2}, {maxnorm, _Real}, {minRad, _Real}, {scl, _Real}, {pow, \
_Real}},
   MapThread[
    Append[#,
      If[Norm[# - #2[[;; 2]]] < maxnorm,
       #2[[3]]/(scl*Max@{Norm[# - #2[[;; 2]]], minRad})^pow,
       0.
       ]
      ] &,
    {
     bg,
     nb
     }
    ]
   ];
updata = mtBg[background, bgn, 100, .5, 1., 2];

This can be trivially interpolated and DensityPlot-ted:

itf = Interpolation[updata];
DensityPlot[itf[x, y], {x, 1, 41}, {y, -5, 19.5}]

meh

You can kinda tune the look of that by the parameters in mtBg.

Here's another version:

itf2 = Interpolation[mtBg[background, bgn, .8, .1, .1, 1]];
DensityPlot[itf2[x, y], {x, 1, 41}, {y, -5, 19.5}, PlotRange -> All ]

meh2


Original

It seems to be a bit better if you do some clipping first:

data = Import["https://pastebin.com/raw/TZwajVgT", "TSV"];

Pick[data, GreaterThan[0] /@ Rescale@data[[All, 3]]] //

 ListDensityPlot[#,
   Background -> ColorData["DarkRainbow"][0],
   ColorFunction -> ColorData["DarkRainbow"]
   ] &

moop

Alternatively you can build it from the ground up:

With[{cd = ColorData["DarkRainbow"]},
 Graphics[
  {
   PointSize[Large],
   Point[data[[All, ;; 2]],
    VertexColors ->
     Map[Directive[Opacity[#], cd[1 - #]] &, Rescale@data[[All, 3]]]
    ]
   },
  Background -> cd[0]
  ]
 ]

nibblez

Note that that's pretty much the same as this:

With[{cd = ColorData["DarkRainbow"]},
 ListPointPlot3D[data,
  ColorFunction -> Function@Directive[Opacity[#3], cd[1 - #3]],
  Background -> cd[0],
  ViewPoint -> Above,
  Boxed -> False
  ]
 ]

woo woo

$\endgroup$
  • $\begingroup$ Which version are you in? In v9.0.1 the 1st method doesn't work well: i.stack.imgur.com/qNilz.png $\endgroup$ – xzczd Oct 27 '17 at 8:03
  • $\begingroup$ Hi, b3m2a1. Thank you so much for answer. But I need a continuous lines. I edited my post. $\endgroup$ – matheorem Oct 27 '17 at 8:18
  • $\begingroup$ @xzczd I'm using 11.2. That seems to be a color-scheme issue or something. $\endgroup$ – b3m2a1 Oct 27 '17 at 14:15

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.