Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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 -> PointSize@0.02,
 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}]
share|improve this question

7 Answers 7

up vote 13 down vote accepted
 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 -> PointSize@0.02, 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 -> PointSize@0.02,  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] 
share|improve this answer

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 -> PointSize@0.02, BoxRatios -> {1, 1, 1}, 
 ColorFunctionScaling -> False, ColorFunction -> ({x, y, z} \[Function] Evaluate@cf)]
share|improve this answer

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 -> PointSize@0.02, 
 ColorFunction -> ({x, y, z} \[Function] 
    colors[[ FromDigits[UnitStep /@ {z, x, y}, 2] +1]]), 
 ColorFunctionScaling -> False, BoxRatios -> {1, 1, 1}]

enter image description here

share|improve this answer
1  
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. –  yulinlinyu Jan 23 '13 at 8:01

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 -> PointSize@0.02, 
 BoxRatios -> {1, 1, 1}, ColorFunctionScaling -> False, 
 ColorFunction -> (Function[{x, y, z}, 
    Switch[Sign[{z, x, y}], ##] &@clrRls])]
share|improve this answer

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.

share|improve this answer

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 -> PointSize@0.02, 
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] &
share|improve this answer
    
+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? –  Mr.Wizard Jan 24 '13 at 14:55
    
@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[##]) &). :) –  jVincent Jan 24 '13 at 15:03
    
I've got a solution to that. I can add it to your answer, or mine. Your choice. –  Mr.Wizard Jan 24 '13 at 15:08
    
@Mr.Wizard Feel free to add it here if you'd like. –  jVincent Jan 24 '13 at 15:12
    
Edit made. It ended up longer than I intended but I hope you don't mind. (And if you do, just revert the change.) –  Mr.Wizard Jan 24 '13 at 15:30

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 -> PointSize@0.02,
 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 -> PointSize@0.02,
 BoxRatios -> {1, 1, 1}, 
 ColorFunctionScaling -> False,
 ColorFunction -> fn
]

Mathematica graphics

share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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