Histogram3D with various colors and textures on cuboids' faces

Question

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:

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?

Answer 1

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]

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

Update: better text visibility

Answer 2

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

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

Answer 3

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:

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