ListDensityPlot of a data set in polar coordinates

I have this data set composed of a table of {r,f[r]}. I want to make a density plot of the data. It should look like the picture. The data is not normalized like the picture (some help with that would be appreciated) Can you help me?

Data avaliabe at: http://pastebin.com/nLn1c5ff

• Have a look ListDensityPlot – user9660 Oct 7 '16 at 17:04

data = Import["http://pastebin.com/raw/nLn1c5ff", "Table"];
fR = Interpolation[data];
DensityPlot[fR[Sqrt[x^2 + y^2]], {x, -5, 5}, {y, -5, 5},
ColorFunction -> GrayLevel]


I'm not sure how precisely you want to match your image. But it can be done by playing with ColorFunction

• I don't need to match the image, it is just a guide. But that solved my issue. Thanks! – Rodrigo Oct 7 '16 at 17:10
GraphicsRow[{ListPlot[data], ListPlot[data, PlotRange -> All]}, ImageSize -> 600]


{min, max} = MinMax[data[[All, 2]]]


{1.10589*10^-8, 11.7826}

scaled = Transpose @ {data[[All, 1]], (data[[All, 2]] - min)/(max - min)};

GraphicsRow[{ListPlot[scaled], ListPlot[scaled, PlotRange -> All]}, ImageSize -> 600]


Differently:

toplot = Flatten[#, 1] & @
Table[{scaled[[i, 1]] Cos[t], scaled[[i, 1]] Sin[t],
scaled[[i, 2]]}, {t, 0, 2 π, 0.1}, {i, 1, Length @ scaled, 5}];

ListDensityPlot[toplot, PlotRange -> {{-5, 5}, {-5, 5}, All},
ColorFunction -> GrayLevel, PlotLegends -> Automatic]


Or another way of visualisation:

f = Interpolation[scaled];

r = RevolutionPlot3D[f[t], {t, 0, 10}]


• Yeah, I thought about that, but in your approach there are less data points per $dx dy$ when $r$ is large. So I decided to go with interpolation of data in polar coordinates, so the DensityPlot will decide how accurately it has to sample it . – BlacKow Oct 7 '16 at 17:19
• @BlacKow I took every fifth point from data because it took a long time to render the image. I think there is enough data to yield no perceivable difference. I wanted to use Interpolation like you did, but you were faster ;) – corey979 Oct 7 '16 at 17:29

Using your data

{rmin, rmax} = MinMax[data[[All, 1]]]

(*  {2.04082*10^-7, 10.}  *)

{fmin, fmax} = MinMax[data[[All, 2]]]

*  {1.10589*10^-8, 11.7826}  *)


Normalizing the function to be in the interval {0,1}

f = Interpolation[
{#[[1]], (#[[2]] - fmin)/(fmax - fmin)} & /@
data];

Plot[f[r], {r, rmin, rmax}, PlotRange -> All]


The first minimum (EDIT) occurs at

m = r /. FindRoot[f'[r] == 0, {r, 4}]

(*  3.83171  *)

DensityPlot[
f[Sqrt[x^2 + y^2]], {x, -m, m}, {y, -m, m},
PlotTheme -> "Monochrome",
PlotPoints -> 75,
PlotLegends -> Automatic]


• Shouldn't it be "the first minimum occurs" instead of "the first zero occurs"? Since you are solving for derivative = 0? – BlacKow Oct 7 '16 at 20:52
• @BlacKow - corrected. Thanks. – Bob Hanlon Oct 7 '16 at 21:03