# Can my color function be written more simply?

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}]

-

 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])]


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]

-

Another possible way of rewriting it:

cf = Block[{x, y, z},
Which @@ Flatten[{
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)]

-

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}]


-
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])]

-

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]
]]


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}]


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.

-

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
]


-

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] &

-
+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