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?

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

$\endgroup$
  • 1
    $\begingroup$ This. Is. Magic! $\endgroup$ – Taiki Nov 6 '15 at 23:21
  • $\begingroup$ Amazing clarity and rotation speed! $\endgroup$ – Ralph Dratman Nov 11 '15 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

$\endgroup$
  • 1
    $\begingroup$ Nice solution, but very slow $\endgroup$ – eldo Nov 5 '15 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.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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