7
$\begingroup$

The code shown below works well, but I think the pure function I'm supplying to the ColorFunction option could be more elegant. How can I simplify it?

f3[w_, h_, z_, d_: 0.04] := 
  Reap[Do[If[Abs[i]/w + Abs[j]/h + Abs[k]/z == 1, 
      Sow@{i, j, k}], {i, -w, w, d}, {j, -h, h, d}, {k, -z, z, 
      d}]][[2, 1]];

ListPointPlot3D[f3[1, 1, 1], PlotStyle -> [email protected],
 ColorFunction -> ({x, y, z} \[Function] Which[
     z > 0 && x > 0 && y > 0, Red,
     z > 0 && x > 0 && y < 0, Green,
     z > 0 && x < 0 && y > 0, Blue,
     z > 0 && x < 0 && y < 0, Orange,

     z < 0 && x > 0 && y > 0, Cyan,
     z < 0 && x > 0 && y < 0, Magenta,
     z < 0 && x < 0 && y > 0, Yellow,
     z < 0 && x < 0 && y < 0, RGBColor[0, 0.5, 1],
     True, Black]), ColorFunctionScaling -> False, 
 BoxRatios -> {1, 1, 1}]
$\endgroup$

7 Answers 7

13
$\begingroup$
 colors = {Red, Green, Blue, Orange, Cyan, Magenta, Yellow,  RGBColor[0, 0.5, 1], Black};
 clrRls = Sequence @@ Join @@ Thread[{Append[Tuples[{1, -1}, 3], _],  colors}]; 
 ListPointPlot3D[f3[1, 1, 1], PlotStyle -> [email protected], BoxRatios -> {1, 1, 1}, 
 ColorFunctionScaling -> False,
 ColorFunction -> (Function[{x, y, z}, Switch[Sign[{z, x, y}], ##] &@clrRls])]

or

clrRls2 = Flatten@Thread[{Append[And @@@ Tuples[{Greater[#, 0], Less[#, 0]} & /@
  {z, x, y}], True], colors}];
ListPointPlot3D[f3[1, 1, 1], PlotStyle -> [email protected],  BoxRatios -> {1, 1, 1},
 ColorFunctionScaling -> False, 
 ColorFunction -> (Function[{x, y, z}, ##] &[Which @@ clrRls2])]

enter image description here

Update: Further alternatives:

Cycling through the colors based on the sign patterns of the coordinates:

  positionRls = Thread[Append[Tuples[{1, -1}, 3], {_, _, _}] -> Range[9]]; 
  ListPointPlot3D[f3[1, 1, 1],  BoxRatios -> {1, 1, 1}, ColorFunctionScaling -> False, 
   PlotStyle -> PointSize[.02],
  ColorFunction -> Function[{x, y, z},
     With[{pos = Sign[{z, x, y}] /. positionRls}, colors[[pos]]]]]

Using PlotStyle instead of ColorFunction:

 dispatch = Thread[Append[Tuples[{1, -1}, 3], {_, _, _}] -> colors]; 
 ListPointPlot3D[{#} & /@ f3[1, 1, 1], BoxRatios -> {1, 1, 1}, 
  PlotStyle -> Thread[{PointSize[.02], (Sign[RotateRight@#] & /@ f3[1, 1, 1] /. 
  dispatch)}]]

Specifying point colors during Sowing and use with PlotStyle:

  f4[w_, h_, z_, d_: 0.04] :=  Reap[Do[If[Abs[i]/w + Abs[j]/h + Abs[k]/z == 1, 
     Sow[{{{i, j, k}}, Sign[{k, i, j}] /. dispatch}]], 
     {i, -w, w, d}, {j, -h, h, d}, {k, -z, z, d}]][[2, 1]];
  ListPointPlot3D[f4[1, 1, 1][[All, 1]], 
   PlotStyle -> (Directive[{PointSize[.02], #}] & /@ f4[1, 1, 1][[All, 2]]),
    BoxRatios -> {1, 1, 1}]

or, with Graphics3D instead of ListPointPlot3D:

  f5[w_, h_, z_, d_: 0.04] :=   Reap[Do[If[Abs[i]/w + Abs[j]/h + Abs[k]/z == 1, 
  Sow[{Sign[{k, i, j}] /. dispatch, Point@{i, j, k}}]], 
   {i, -w, w,   d}, {j, -h, h, d}, {k, -z, z, d}]][[2, 1]];
  Graphics3D[{PointSize[.02], f5[1, 1, 1]}, BoxRatios -> {1, 1, 1}, Axes -> True] 
$\endgroup$
7
$\begingroup$

Another possible way of rewriting it:

cf = Block[{x, y, z},
    Which @@ Flatten[{
        Thread[{
            And[x ~#~ 0, y ~#2~ 0, z ~#3~ 0] & @@@ Tuples[{Greater, Less}, 3], 
            {Red, Cyan, Green, Magenta, Blue, Yellow, Orange, RGBColor[0, 0.5, 1]}
        }], 
        True, Black
    }]
]

ListPointPlot3D[f3[1, 1, 1], PlotStyle -> [email protected], BoxRatios -> {1, 1, 1}, 
 ColorFunctionScaling -> False, ColorFunction -> ({x, y, z} \[Function] Evaluate@cf)]
$\endgroup$
6
$\begingroup$

I think I have the colors around the wrong way, the Black catch-all doesn't get used - but this is as simple as I can get it.

colors = Reverse@{Red, Green, Blue, Orange, Cyan, 
        Magenta, Yellow,  RGBColor[0, 0.5, 1], Black}

 ListPointPlot3D[f3[1, 1, 1], PlotStyle -> [email protected], 
 ColorFunction -> ({x, y, z} \[Function] 
    colors[[ FromDigits[UnitStep /@ {z, x, y}, 2] +1]]), 
 ColorFunctionScaling -> False, BoxRatios -> {1, 1, 1}]

enter image description here

$\endgroup$
1
  • 1
    $\begingroup$ I enjoy your solution. BTW, the minor error in your code can be fixed in this way: ColorFunction -> ({x, y, z} [Function] colors[[ FromDigits[UnitStep /@ {z, x, y}, 2]+1 ]], since there is no colors[[0]] at all. $\endgroup$
    – yulinlinyu
    Jan 23, 2013 at 8:01
4
$\begingroup$

In the spirit of kguler's code, mine comes as:

colors = {Red, Green, Blue, Orange, Cyan, Magenta, Yellow, 
   RGBColor[0, 0.5, 1]};

clrRls = Sequence @@ 
  Riffle[Distribute[ConstantArray[{-1, 1}, 3], List], colors]
ListPointPlot3D[f3[1, 1, 1], PlotStyle -> [email protected], 
 BoxRatios -> {1, 1, 1}, ColorFunctionScaling -> False, 
 ColorFunction -> (Function[{x, y, z}, 
    Switch[Sign[{z, x, y}], ##] &@clrRls])]
$\endgroup$
4
$\begingroup$

A way under spherical coordinates system:

colorSwitchFunc = Function[expr, Evaluate@Module[
    {colorset = {Red, Blue, Orange, Green, Cyan, Yellow, RGBColor[0, 0.5, 1], Magenta}},
    Switch[expr, ##] & @@ Flatten[Prepend[
       {Tuples @ Range @ {2, 4}, colorset}\[Transpose],
       {{0, _} | {_, 0}, Black}], 1]
    ]]

Mathematica graphics

ListPointPlot3D[f3[1, 1, 1], PlotStyle -> PointSize[0.02],
 ColorFunction -> Function[{x, y, z},
   Module[{θ = ArcCos[z/2(*Norm[{x,y,z}]*)], ϕ = If[# < 0, 2 π + #, #] &@Arg[x + y I]},
    {θ, ϕ}/(π/2) /. n_?(FractionalPart[#] == 0 &) :> 0 // Ceiling // colorSwitchFunc ]],
 ColorFunctionScaling -> False, BoxRatios -> {1, 1, 1}, 
 AxesLabel -> {x, y, z}]

Mathematica graphics

Note in θ = ArcCos[z/2(*Norm[{x,y,z}]*)], for better speed, the real Norm is replaced by a constant (here $2$) larger than the maximum absolute value of z.

$\endgroup$
4
$\begingroup$

Lots of fun different suggestions, Didn't see this one pressented so here goes:

colors = {Red, Green, Blue, Orange, Cyan, Magenta, Yellow, RGBColor[0, 0.5, 1]};

cf[x_, y_, z_] := 
   Switch[Sign[{x, y, z}], 
   Evaluate[Sequence @@ Riffle[Tuples[{1, -1}, 3], colors]], _, Black];

ListPointPlot3D[f3[1, 1, 1], PlotStyle -> [email protected], 
ColorFunction -> cf, ColorFunctionScaling -> False, 
BoxRatios -> {1, 1, 1}]

I think there's enough pictures of the results already.


Here is a modification that maintains the ability to change colors conveniently yet speeds the application of the function by partial pre-evaluation.

cfGen[colors_] :=
  Riffle[Tuples[{1, -1}, 3], colors] /.
    _[seq__] :> (Switch[Sign @ {##}, seq, _, Black] &)

Usage is: ColorFunction -> cfGen[colors].

Alternatively:

Block[{colors, Part},
 cf =
   Riffle[Tuples[{1, -1}, 3], colors[[#]] & ~Array~ 8] /.
    _[seq__] :> (Switch[Sign @ {##}, seq, _, Black] &)
];

cf then has the definition:

Switch[Sign[{##1}],
  {1, 1, 1},   colors[[1]],
  {1, 1, -1},  colors[[2]],
  {1, -1, 1},  colors[[3]],
  {1, -1, -1}, colors[[4]],
  {-1, 1, 1},  colors[[5]],
  {-1, 1, -1}, colors[[6]],
  {-1, -1, 1}, colors[[7]],
  {-1, -1, -1},colors[[8]],
  _, Black] &
$\endgroup$
5
  • $\begingroup$ +1 for the correction. It might be a bit faster to inject that sequence directly into the definition so that it is not reevaluated every time the function is called. Edit: Yes, that is about three times as fast. May I make the change? $\endgroup$
    – Mr.Wizard
    Jan 24, 2013 at 14:55
  • $\begingroup$ @Mr.Wizard Indeed, you could do that, but strictly speaking it wouldn't be the same, since the current implementation allows you to change the colors at any point while the faster version would have you redefine the function to change colors. For a fun illustration of the difference, try using ColorFunction -> ((colors = RotateRight@colors; cf[##]) &). :) $\endgroup$
    – jVincent
    Jan 24, 2013 at 15:03
  • $\begingroup$ I've got a solution to that. I can add it to your answer, or mine. Your choice. $\endgroup$
    – Mr.Wizard
    Jan 24, 2013 at 15:08
  • $\begingroup$ @Mr.Wizard Feel free to add it here if you'd like. $\endgroup$
    – jVincent
    Jan 24, 2013 at 15:12
  • $\begingroup$ Edit made. It ended up longer than I intended but I hope you don't mind. (And if you do, just revert the change.) $\endgroup$
    – Mr.Wizard
    Jan 24, 2013 at 15:30
3
$\begingroup$

My take on kguler's first method. First a refactoring of the f3 code:

f3[w_, h_, z_, d_: 0.04] :=
  Select[
    Tuples @ Range[-{w, h, z}, {w, h, z}, d],
    Dot[Abs@#, 1/{w, h, z}] == 1 &
  ]

Rules

colors = {Red, Cyan, Green, Magenta, Blue, Yellow, Orange, RGBColor[0, 0.5, 1], Black};

clrRls = Thread[Append[{1, -1} ~Tuples~ 3, _] -> colors];

ListPointPlot3D[f3[1, 1, 1],
 PlotStyle -> [email protected],
 BoxRatios -> {1, 1, 1}, 
 ColorFunctionScaling -> False,
 ColorFunction -> (Sign@{##} /. clrRls &)
]

Definitions

Alternatively:

colors = {Red, Cyan, Green, Magenta, Blue, Yellow, Orange, RGBColor[0, 0.5, 1]};

fn[x_, y_, z_] := fn @ Sign @ {x, y, z}

MapThread[(fn[#] = #2) &, {{1, -1} ~Tuples~ 3, colors}];

fn[other_] = Black;

ListPointPlot3D[f3[1, 1, 1],
 PlotStyle -> [email protected],
 BoxRatios -> {1, 1, 1}, 
 ColorFunctionScaling -> False,
 ColorFunction -> fn
]

Mathematica graphics

$\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.