2
$\begingroup$

I have data, that has the following form: i x y z c ; where i is a number, that goes from 1 to N, x,y,z are thought of as coordinates, and c is supposed to be a value that I want to present as color.

I have some struggles because most of the 3-dimensional histograms are actually 2-dimensional "heatmaps" where the value is presented as height, but this is not a true 3-dimensional histogram.

How can I create a box of the interval [0,1]x[0,1]x[0,1], and at coordinate (x,y,z) put down a dot and color it with C (for all points)?

The colors should range between some range (let's say after rescaling between [+/-1]) and should be colored dark blue/red for +/- 1 and lighter as it gets closer to zero.

$\endgroup$

2 Answers 2

5
$\begingroup$

Update:

"i want the largest positive to be dark blue, small positive to be light blue, small negative to be light red and large negative to be dark red"

SeedRandom[1];
ixyzc = MapIndexed[Flatten@*Reverse@*List]@RandomReal[1, {10, 4}];

Change the last column of input data so that it runs from -1 to 1:

ixyzc2 = MapAt[Rescale[#, MinMax@ixyzc[[All, -1]], {-1, 1}] &, 
   ixyzc, {All, -1}];

Use the last column of input data to specify colors running thru the color list {Darker@Red, Red, LightRed, White, LightBlue, Blue, Darker@Blue} as the value of last column runs from -1 to 1:

styleddata2 = Style[{#2, #3, #4}, Blend[
 Thread[{Subdivide[-1, 1, 6], 
   {Darker@Red, Red, LightRed, White, LightBlue, Blue, Darker@Blue}}], #5]]& @@@ 
  ixyzc2;


ListPointPlot3D[styleddata2, BoxRatios -> 1, 
 BaseStyle -> AbsolutePointSize[15]]

enter image description here

Attach last column values as labels to verify that colors and values match as desired:

styledlabeleddata2 = MapThread[
  Callout[#, Round[#2, .1], LabelStyle -> 14, Appearance -> "Frame"] &]@
  {styleddata2, ixyzc2[[All, -1]]};

ListPointPlot3D[styledlabeleddata2, 
 BoxRatios -> 1, BaseStyle -> AbsolutePointSize[15]]

enter image description here

Graphics3D[styleddata2 /. Style[a_, b_] :> {b, Sphere[a, .05]}, 
 Axes -> True]

enter image description here

Original answer:

SeedRandom[1];
ixyzc = MapIndexed[Flatten@*Reverse@*List]@RandomReal[1, {10, 4}]
{{1, 0.817389, 0.11142, 0.789526, 0.187803},   
 {2, 0.241361, 0.0657388, 0.542247, 0.231155},   
 {3, 0.396006, 0.700474, 0.211826, 0.748657},   
 {4, 0.422851, 0.247495, 0.977172, 0.825163},   
 {5, 0.925275, 0.578056, 0.29287, 0.208051},   
 {6, 0.580474, 0.128821, 0.306427, 0.712012},   
 {7, 0.390582, 0.819967, 0.325351, 0.59326},   
 {8, 0.518774, 0.169013, 0.472565, 0.807161},   
 {9, 0.0118355, 0.316876, 0.789804, 0.011978},   
 {10, 0.391276, 0.458902, 0.458845, 0.727517}}

1. ListPointPlot3D

styleddata = Style[{#2, #3, #4}, Hue@#5] & @@@ ixyzc;


ListPointPlot3D[styleddata, BoxRatios -> 1]

enter image description here

If you want to add labels:

styledlabeleddata =  Callout[Style[{#2, #3, #4}, Hue@#5], #] & @@@ ixyzc;


ListPointPlot3D[styledlabeleddata, BoxRatios -> 1]

enter image description here

2. BubbleChart3D

labeleddata = Association[# -> {##2} & @@@ ixyzc];

BubbleChart3D[labeleddata, 
 ColorFunction -> (Hue@#4 &), 
 BubbleSizes -> {.1, .1}]

enter image description here

BubbleChart3D[labeleddata, ColorFunction -> (Hue@#4 &), 
 BubbleSizes -> {.1, .1}, ChartLabels -> Automatic,  LabelStyle -> 16]

enter image description here

3. Graphics3D

g3ddata = {Hue@#5, Sphere[{#2, #3, #4}, .1]} & @@@ ixyzc;

Graphics3D[g3ddata, Axes -> True]

enter image description here

$\endgroup$
6
  • $\begingroup$ Thank you for the fast answer! How can I remove the text from the dots? $\endgroup$
    – Kregnach
    Nov 16, 2023 at 8:52
  • $\begingroup$ @Kregnach, please see the updated version. $\endgroup$
    – kglr
    Nov 16, 2023 at 9:00
  • $\begingroup$ One last question, and I stop! How to set the colors, let's say to range between red and blue? The color in the data is +/- something (not too large), i want the largest positive to be dark blue, small positive to be light blue, small negative to be light red and large negative to be dark red ? $\endgroup$
    – Kregnach
    Nov 16, 2023 at 9:05
  • $\begingroup$ @Kregnach, please see the update. $\endgroup$
    – kglr
    Nov 16, 2023 at 9:43
  • 1
    $\begingroup$ Thank you! I updated the question to represent the changes! $\endgroup$
    – Kregnach
    Nov 16, 2023 at 9:52
1
$\begingroup$

Actually I found what I wanted using a different function:

data = Import["your_file_path.txt", "Table"];

(* Extract columns x, y, z, and c *) extractedData = data[[All, {2, 3, 4, 6}]];

(* Filter data based on the condition c > -0.0001 *) filteredData = Select[extractedData, #[[4]] > -0.0001 &];

(* Plot the filtered data with ListDensityPlot3D *) plot = ListDensityPlot3D[filteredData, ColorFunction -> "TemperatureMap", PlotLegends -> Automatic];

(* Export the plot to a PNG file *) Export["output_plot.png", plot]

enter image description here

$\endgroup$

Your Answer

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

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