14
$\begingroup$

I'm trying to produce an Histogram3D-like graph, but with a little more customization.

In particular I want to manually specify the color of each cuboid and to print some information on the top faces.

I did manage to do this, more or less, with a code like the following:

Graphics3D[{ With[{data = RandomReal[{0, 1}, {10, 10}], additionalHeight = 0.0001}, Table[ With[{color = Which[ 0 <= data[[i, o]] <= 0.2, Red, 0.2 < data[[i, o]] <= 0.5, Orange, 0.5 < data[[i, o]] <= 1, Green ]}, { color, Cuboid[{i - 1/2, o - 1/2, 0}, {i + 1/2, o + 1/2, #}], Texture[ Style[ Column[{"in=" <> ToString@i, "out=" <> ToString@o}, Right, Background -> color], Black, Bold ] ], EdgeForm[], Polygon[{{i - 0.4, o - 0.4, # + additionalHeight}, {i + 0.4, o - 0.4, # + additionalHeight}, {i + 0.4, o + 0.4, # + additionalHeight}, {i - 0.4, o + 0.4, # + additionalHeight}}, VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}}] } &@data[[i, o]] ], {i, 10}, {o, 10} ] ] }, Axes -> True, ImageSize -> Large, RotationAction -> "Clip" ]

which produces the following: enter image description here

However, as you can see, the output can definitely be better. In particular I would like to remove those lines above and below each texture. I'm guessing they are due to the slight difference in height between the top face of the cuboid and the texture. However, removing this difference produces an even worse result.

Do you have any tip on how can this code be improved?

Improve this question
$\endgroup$
1

3 Answers 3

Reset to default
8
$\begingroup$

The existing answers show how to perfectly generate small textures on top of the cuboids. Unfortunately, the resulting 3D scene it is quite slow when you try to rotate it (about one frame per second).

I propose to use one GraphicsComplex object with only one texture (aka atlas)

histogram[data_, cf_] := Module[{nx, ny}, {nx, ny} = Dimensions@data; {coords, vtc} = Outer[Plus, N@Tuples@Append[Range@{nx, ny}, {0}], Tuples@{{-#, #}, {-#, #}, {0., 1.}}, 1] & /@ {.5, .4}; coords[[;; , ;; , 3]] *= Flatten@data; coords = Flatten[coords, 1]; vtc = (Flatten[vtc, 1][[;; , ;; 2]] - .5).{{1./nx, 0.}, {0., 1./ny}}; polygons = Flatten[#, 1] &@ Outer[Plus, Developer`ToPackedArray@{{1, 3, 7, 5}, {1, 5, 6, 2}, {5, 7, 8, 6}, {7, 3, 4, 8}, {3, 1, 2, 4}, {6, 8, 4, 2}}, 8 Transpose@Range[{0, 0, 0, 0}, nx ny - 1], 1]; tex = Grid[ Reverse@Array[ Item[Column[{"in=" <> ToString@#2, "out=" <> ToString@#}, Right, BaseStyle -> {Bold}], Background -> cf@data[[#2, #]]] &, {nx, ny}], ItemSize -> {6.3, 6.3}, Spacings -> {0, 0}, Alignment -> Center {1, 1}]; Graphics3D[{Texture[tex], GraphicsComplex[coords, Polygon@polygons, VertexTextureCoordinates -> vtc]}, Lighting -> "Neutral", Axes -> True, ImageSize -> 700, BoxRatios -> {1, 1, 0.2}]]; data = RandomReal[1, {10, 10}]; cf = Piecewise[{{Red, # <= 0.2}, {Orange, 0.2 < # <= 0.5}, {Green, # > 0.5}}] &; histogram[data, cf]

enter image description here

I can seamlessly rotate even 100×100 grid (which looks like a grass field).

Update: better text visibility

Improve this answer
$\endgroup$
2
  • 1
    $\begingroup$ This. Is. Magic! $\endgroup$ Commented Nov 6, 2015 at 23:21
  • $\begingroup$ Amazing clarity and rotation speed! $\endgroup$ Commented Nov 11, 2015 at 9:16
10
$\begingroup$

For some reason those lines are created during the rasterization of the thing inside Texture:

Rasterize[ Style[ Column[{"in=" <> ToString@1, "out=" <> ToString@2}, Right, Background -> Green], Black, Bold ] ]

rasterized image

As you can see, the lines are part of the rasterized image's background. Manually rasterizing the thing inside Texture allows us to take control, e.g. overriding the default background colour:

Graphics3D[ { With[ {data = RandomReal[{0, 1}, {10, 10}], additionalHeight = 0.0001}, Table[ With[ { color = Which[ 0 <= data[[i, o]] <= 0.2, Red, 0.2 < data[[i, o]] <= 0.5, Orange, 0.5 < data[[i, o]] <= 1, Green ] }, { color, Cuboid[{i - 1/2, o - 1/2, 0}, {i + 1/2, o + 1/2, #}], Texture[ Rasterize[#, Background -> color] & @ Style[ Column[ {"in=" <> ToString @ i, "out=" <> ToString @ o}, Right, Background -> color ], Black, Bold ] ], EdgeForm[], Polygon[ { {i - 0.4, o - 0.4, # + additionalHeight}, {i + 0.4, o - 0.4, # + additionalHeight}, {i + 0.4, o + 0.4, # + additionalHeight}, {i - 0.4, o + 0.4, # + additionalHeight} }, VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}} ] } & @ data[[i, o]] ], {i, 10}, {o, 10} ] ] }, Axes -> True, ImageSize -> Large, RotationAction -> "Clip" ]

Lines removed

Improve this answer
$\endgroup$
1
  • 1
    $\begingroup$ Nice solution, but very slow $\endgroup$ Commented Nov 5, 2015 at 12:32
5
$\begingroup$

I was able to get rid of the light-colored bars at the bottom and top by passing a Graphics object to Texture, and setting the Background on that, like so:

infoTexture[i_, o_, color_] := With[{text = Text@Column[{HoldForm["in" == i], HoldForm["out" == o]}, Right, BaseStyle -> {Bold}]}, Texture@Graphics[ text, Background -> color, ImageSize -> {40, 40}]]; Graphics3D[{With[{data = RandomReal[{0, 1}, {10, 10}], additionalHeight = 0.0001}, Table[With[{color = Which[0 <= data[[i, o]] <= 0.2, Red, 0.2 < data[[i, o]] <= 0.5, Orange, 0.5 < data[[i, o]] <= 1, Green]}, {color, Cuboid[{i - 1/2, o - 1/2, 0}, {i + 1/2, o + 1/2, #}], infoTexture[i, o, color], EdgeForm[], Green, Polygon[{{i - 0.4, o - 0.4, # + additionalHeight}, {i + 0.4, o - 0.4, # + additionalHeight}, {i + 0.4, o + 0.4, # + additionalHeight}, {i - 0.4, o + 0.4, # + additionalHeight}}, VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}}]} &@data[[i, o]]], {i, 10}, {o, 10}]]}, Axes -> True, ImageSize -> Large, RotationAction -> "Clip"]

This gives the following, and fairly quickly:

enter image description here

Picking the ImageSize for the Graphics object used to make the Texture was just a matter of trial and error.

Improve this answer
$\endgroup$
0

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.