There exist many applications to visualize cube files, such as VMD or GaussView, but I wanted to take advantage of Mathematica‘s  capability to easily combine graphics, as well as the ability to automate the process in order to efficiently create frames for a movie.

First off, we need a function to extract the data from the cube file.  In the process, we will create the text for an XYZ file, a format also developed by Gaussian.  The function OutForm is used here to mimic the printf function found in other programming languages.

OutForm[num_?NumericQ, width_Integer, ndig_Integer, 
   OptionsPattern[]] :=
  Module[{mant, exp, val},
   {mant, exp} = MantissaExponent[num];
   mant = ToString[NumberForm[mant, {ndig, ndig}]];
   exp = If[Sign[exp] == -1, "-", "+"] <> IntegerString[exp, 10, 2];
   val = mant <> "E" <> exp;
   StringJoin@PadLeft[Characters[val], width, " "]
   ];


ReadCube[cubeFileName_?StringQ] := Module[
   {moltxt, nAtoms, lowerCorner, nx, ny, nz, xstep, ystep, zstep, 
    atoms, desc1, desc2, xyzText, cubeDat, xgrid, ygrid, zgrid, 
    dummy1, dummy2, atomicNumber, atomx, atomy, atomz, tmpString, 
    headerTxt,bohr2angstrom},
   bohr2angstrom = 0.529177249;
   moltxt = OpenRead[cubeFileName];
   desc1 = Read[moltxt, String];
   desc2 = Read[moltxt, String];
   lowerCorner = {0, 0, 0}; 
   {nAtoms, lowerCorner[[1]], lowerCorner[[2]], lowerCorner[[3]]} = 
    Read[moltxt, String] // ImportString[#, "Table"][[1]] &;
   xyzText = ToString[nAtoms] <> "\n";
   xyzText = xyzText <> desc1 <> desc2 <> "\n";
   {nx, xstep, dummy1, dummy2} = 
    Read[moltxt, String] // ImportString[#, "Table"][[1]] &;
   {ny, dummy1, ystep, dummy2} = 
    Read[moltxt, String] // ImportString[#, "Table"][[1]] &;
   {nz, dummy1, dummy2, zstep} = 
    Read[moltxt, String] // ImportString[#, "Table"][[1]] &;
   Do[
    {atomicNumber, dummy1, atomx, atomy, atomz} = 
     Read[moltxt, String] // ImportString[#, "Table"][[1]] &;
    xyzText = If[Sign[lowerCorner[[1]]] == 1,
      xyzText <> ElementData[atomicNumber, "Abbreviation"] <> 
       OutForm[atomx, 17, 7] <> OutForm[atomy, 17, 7] <> 
       OutForm[atomz, 17, 7] <> "\n",
      xyzText <> ElementData[atomicNumber, "Abbreviation"] <> 
       OutForm[bohr2angstrom atomx, 17, 7] <> 
       OutForm[bohr2angstrom atomy, 17, 7] <> 
       OutForm[bohr2angstrom atomz, 17, 7] <> "\n"];
    , {nAtoms}];
   cubeDat = 
    Partition[Partition[ReadList[moltxt, Number, nx ny nz], nz], ny];
   Close[moltxt];
   moltxt = OpenRead[cubeFileName];
   headerTxt = Read[moltxt, Table[String, {2 + 4 + nAtoms}]];
   Close[moltxt];
   headerTxt = StringJoin@Riffle[headerTxt, "\n"];
   xgrid = 
    Range[lowerCorner[[1]], lowerCorner[[1]] + xstep (nx - 1), xstep];
   ygrid = 
    Range[lowerCorner[[2]], lowerCorner[[2]] + ystep (ny - 1), ystep];
   zgrid = 
    Range[lowerCorner[[3]], lowerCorner[[3]] + zstep (nz - 1), zstep];
   {cubeDat, xgrid, ygrid, zgrid, xyzText, headerTxt}
   ];

WriteCube[cubeFileName_?StringQ, headerTxt_?StringQ, cubeData_] := 
 Module[{stream}, 
  stream = OpenWrite[cubeFileName, FormatType -> FortranForm];
  WriteString[stream, headerTxt, "\n"];
  Map[WriteString[stream, ##, "\n"] & @@ 
     Riffle[ScientificForm[#, {3, 4}, 
         NumberFormat -> (Row[{#1, "E", If[#3 == "", "+00", #3], 
              "\t"}] &), NumberPadding -> {"", "0"}, 
         NumberSigns -> {"-", " "}] & /@ #, "\n", {7, -1, 7}] &, 
   cubeData, {2}];
  Close[stream];]

CubePlot[{cub_, xg_, yg_, zg_, xyz_}, plotopts : OptionsPattern[]] := 
   Module[{xyzplot, bohr2picometer, datarange3D, pr},
    bohr2picometer = 52.9177249;
    datarange3D = 
      bohr2picometer {{xg[[1]], xg[[-1]]}, {yg[[1]], 
         yg[[-1]]}, {zg[[1]], zg[[-1]]}};
    xyzplot = ImportString[xyz, "XYZ"];
    Show[xyzplot, 
     ListContourPlot3D[Transpose[cub, {3, 2, 1}], 
       Evaluate[FilterRules[{plotopts}, Options[ListContourPlot3D]]], 
       Contours -> {-.02, .02}, ContourStyle -> {Blue, Red}, 
       DataRange -> datarange3D, MeshStyle -> Gray, 
       Lighting -> {{"Ambient", White}}], 
       Evaluate[
        FilterRules[{plotopts}, {ViewPoint, ViewVertical, ImageSize}]]]
    ];    

{cubedata,xg,yg,zg,xyz,header}= ReadCube["cys-MO35.cube"];

CubePlot[{cubedata, xg, yg, zg, xyz}]

When I want to create a movie file, I want all the images to have exactly the same ViewAngle, ViewPoint, and ViewCenter.  When you give these options to CubePlot, it feeds them directly to the Show function

vp = {ViewCenter -> {0.5, 0.5, 0.5}, 
   ViewPoint -> {1.072, 0.665, -3.13}, 
   ViewVertical -> {0.443, 0.2477, 1.527}};


CubePlot[{cubedata, xg, yg, zg, xyz}, vp]

Finally, you can also give any options that normally go to ListContourPlot3D

CubePlot[{cubedata, xg, yg, zg, xyz}, vp, 
 ContourStyle -> {Texture[ExampleData[{"ColorTexture", "Vavona"}]], 
   Texture[ExampleData[{"ColorTexture", "Amboyna"}]]}, 
 Contours -> {-.015, .015}] 

Many thanks to Daniel Healion for the ReadCube and WriteCube functions.

Some general info for those who are not familiar with the Tech Conference:

There are several types of talks, and you can easily cram your schedule bumper to bumper:

• WRI overview talks (presenting some topic, e.g. “Mathematica Connectivity” or “Image Processing” in general)
• WRI in-depth talks (taking on a specific area, e.g. “Manipulate Secrets”)
• Hands-on workshops (big this year: SystemModeler)
• User talks that cover the wide range of Mathematica application in education, science, industry and entertainment. See the 2011 schedule and the 2012 videos to get an impression.

The Champaign Hilton Garden Inn is a decent venue, the only thing to be aware of is the sometimes lethal airconditioning, so be sure to bring warm clothes.

The focus of most presentations is on Mathematica, but since it is the Wolfram Technology Conference, things like Wolfram Alpha, SystemModeler and other technologies start to feature more and more prominently. There is an exceptional density of Wolfram developers (and thus WRI competence)  and you can set up meetings with them and other participants with the online conference system (crowdvine) or just try to taser and drag them into the coffee room downstairs (there is also a merchandise and book store offering conference discounts).

The program  is quite packed with three to four tracks and other things like meet-ups, lunch round tables on certain subjects and similar. On all evenings there is some kind social event either on-site or in Champaign at large. The crowd is a very easygoing one with a quite high proportion of regulars.

2012-10-15:

Landing at ORD.

2012-10-16:

Yawn. The good thing about flying west is that getting up early (really early) is easy. Staying awake will be the hard part. Met Murta both in chat and real world  (see the chat transcript, and no, we did not make that up). Met up with rcollyer and a few WRI MMA.SE regulars at the reception.

2012-10-17:

Opening keynote by Stephen Wolfram: As every year, Stephen demoed a lot of interesting things to come — all of which were NDA’d. Bugger. Except for the fact that the next release will have version No. 9. Enjoyable: Stephen took the epic crashes of some demos (all on Apple devices) with good grace (John Fultz does not look too amused, though). Watch this:

Accelerate session: One hour of 5min talks about things Mathematica. My personal highlight was Mark McClure’s astounding quadratic camera.  My 5min: a mashup of my selection of the most entertaining Q&A’s, most of them of the graphical persuasion:

Stickers and pens provided by Aarthi vanished swiftly. It seems that Mathematica.SE is still not known to quite a number of serious Mathematica users.

2012-10-18:

Soundbite from the front end keynote by John Fultz about coming interface features (paraphrased): “We decided we needed more hubris, more arrogance. Stephen took the lead on that”.

Assembling all present MMA.SE personnel for the group shot proved astonishingly difficult (think herding cats), so this was the best one we got (From left to right: Mark McClure, Murta, rcollyer, Arnoud, Brett, myself, Michael Wijaya, Daniel ):

Fun: “Connecting the ARDrone Quadrocopter to Mathematica” by Christopher Wolfram and Todd Gayley. The demo devil struck again, so for the first few minutes Todd did all the acting (including sound). Fear not, in the end the drone followed a simple line path defined in Mathematica and reacted to signs shown to it´s camera.

Evening event: Conference Dinner. Food, drink and nice company and then Stephen presents the Wolfram Innovator Awards for the second time. I´ll not spoil the fun and tell and instead leave authoring the proper accolades to WRI on their blog. Check up on this year’s laureates. Not to be missed: The yearly comprehensive Q&A by Stephen.

2012-10-19:

Shaky screenshot of my presentation, “Fun with Flaps”, which went reasonably well (well, it’s got airplanes in it and with that, plus pop culture reference, you cannot go wrong).

Another really awful photo of one highly entertaining events: The oneliner competition. A pity that Chris Carlson’s hilarious presentation is not taped. Again, Chris will probably do a splendid job showing those oneliners on the Wolfram Blog, so I´ll simply mention that a certain CEO’s head featured prominently in the winner entry and then some. If you are not familiar with the oneliner competition, this one was the fourth (enjoy #1, #2 and #3).

Remarkable: The youngest (conference, oneliner and probably Mathematica.SE) participant ever not related to WRI shareholders, Jesse Friedman, is eleven years old and got an honorable mention for his concise Wolfram Alpha interface oneliner which won him his own brandnew student license with upgrade to version 9! Kudos, Jesse! We are looking forward to hear more of you in the future.

Nice:Luc Barthelet’s “Introduction to Image Processing–Solving the Rubik’s Cube from Pictures”

One for the hardware-tinkerers: “Arduino and Mathematica – Computation in the Maker World”. A laser pointer controlled by an arduino board targets objects recognized by image processing in Mathematica.

Evening Event: “Discover Downtown”: Free choice of several bars and restaurants in downtown Champaign, and coupons to redeem at will there (venue switching encouraged). From sushi to pizza, from sake to stout. One detail of one of the more robust venues in the murky birds-eye shot below:

TL;DR

All in all, a really enjoyable, densely packed conference with excellent networking opportunities and highly recommended if you are a serious Mathematica user (or seriously planning on becoming one).

PS: Heavy loot from the oneliner competition: Generous WRI goodie basket! As far as carry-on luggage goes, this really makes one think about getting a kindle.

PPS: Thanks to the Stackexchange team (esp. Aarthi) for providing swag and support! I still got some stickers, but t-shirts and pens sure diffused nicely.

I can’t emphasize enough how important it is to look up the documentation from time to time, even for the functions you think you already know. There are so many options and additional arguments to workhorse functions that you might not have appreciated. Here are a few of my favorites. Some of them were noted in a question I once asked about the issue.

Hooray for Array

If you want to iterate over arbitrary objects, you need Table.

Table[f[i], {i, {a, b, whatever}}]
{f[a], f[b], f[whatever]}

If instead the iterator increments by one each time, Array is cleaner. You don’t even need to give the iterator a name.

Array[f, 3]
{f[1], f[2], f[3]}

It’s easy to forget the extended forms of standard functions like this. The iterator in Array does not have to start at 1. Don’t forget that the first argument gives the resulting list’s length, not the end value of the iterator.

Array[f, {3}, {5}]
{f[5], f[6], f[7]}

This is a general example of the flexible pattern-matching in Mathematica, which allows separate function definitions for different numbers and types of arguments.

Totally rad

Total[somematrix, {2}] 

is equivalent to Mapping the Total function onto the rows of the matrix.

Partition magic

The third argument to Partition defines the offset, so that instead of

Partition[Array[f, 5], 2] // TableForm
f[1]    f[2]
f[3]    f[4]

You get

Partition[Array[f, 5], 2, 1] // TableForm
f[1]    f[2]
f[2]    f[3]
f[3]    f[4]
f[4]    f[5]

This means that, for example

Divide @@@ Partition[somevector, 2, 1] 

is equivalent to

Most[somevector]/Rest[somevector]

This question on the Mathematica.SE site shows how to generalise Partition for ragged lists (i.e., those with sub-lists that are not all the same length). There are a number of different ways to do this, including using Partition itself, as well as various combinations of NestWhile and Prepend.

Join in the fun

The third argument of Join is also incredibly useful. How many times have you seen complicated code with Transpose and Append all over the place, just to join two matrices by column, instead of by row? The default syntax for Join joins the rows, but you can join by columns with just two extra keystrokes. As noted in the answers to this question, this is also usually a little faster than the little-known but highly useful ArrayFlatten function.

Join[Array[g, {4, 2}], Array[f, {4, 2}]] // TableForm
g[1,1]  g[1,2]
g[2,1]  g[2,2]
g[3,1]  g[3,2]
g[4,1]  g[4,2]
f[1,1]  f[1,2]
f[2,1]  f[2,2]
f[3,1]  f[3,2]
f[4,1]  f[4,2]


Join[Array[g, {4, 2}], Array[f, {4, 2}], 2] // TableForm
g[1,1]  g[1,2]  f[1,1]  f[1,2]
g[2,1]  g[2,2]  f[2,1]  f[2,2]
g[3,1]  g[3,2]  f[3,1]  f[3,2]
g[4,1]  g[4,2]  f[4,1]  f[4,2]

Flip and Flatten

There are also additional options and arguments in some other basic list-manipulation commands. For example, most experienced users know that Flatten takes a level specification. For example, Flatten[list,1] turns a three-dimensional tensor into a matrix.

Flatten[Array[f, {3, 3, 2}], 1] // TableForm
f[1,1,1]    f[1,1,2]
f[1,2,1]    f[1,2,2]
f[1,3,1]    f[1,3,2]
f[2,1,1]    f[2,1,2]
f[2,2,1]    f[2,2,2]
f[2,3,1]    f[2,3,2]
f[3,1,1]    f[3,1,2]
f[3,2,1]    f[3,2,2]
f[3,3,1]    f[3,3,2]

But did you know that the second argument can also be a matrix? This popular question on the Mathematica.SE site contains a lot of information about how it works. It can be used to Transpose ragged lists, as this answer explains.

Speaking of Transpose, consider what is possible using its second argument. Here is the result of a normal transpose on a three-dimensional list with dimensions 342.

t1 = Transpose[Array[f, {3, 4, 2}]]

{{{f[1, 1, 1], f[1, 1, 2]}, {f[2, 1, 1], f[2, 1, 2]}, {f[3, 1, 1], 
   f[3, 1, 2]}}, {{f[1, 2, 1], f[1, 2, 2]}, {f[2, 2, 1], 
   f[2, 2, 2]}, {f[3, 2, 1], f[3, 2, 2]}}, {{f[1, 3, 1], 
   f[1, 3, 2]}, {f[2, 3, 1], f[2, 3, 2]}, {f[3, 3, 1], 
   f[3, 3, 2]}}, {{f[1, 4, 1], f[1, 4, 2]}, {f[2, 4, 1], 
   f[2, 4, 2]}, {f[3, 4, 1], f[3, 4, 2]}}}

Effectively it treats the list as a matrix to transpose normally: it just happens that the elements of that matrix are themselves lists.

Dimensions@t1
{4, 3, 2}

You can get a completely different result by choosing a different specification in the second argument of Transpose. (The default is equivalent to specifying {2,1,3} for the second argument.)

t2 = Transpose[Array[f, {3, 4, 2}], {2, 3, 1}]
{{{f[1, 1, 1], f[1, 2, 1], f[1, 3, 1], f[1, 4, 1]}, {f[2, 1, 1], 
   f[2, 2, 1], f[2, 3, 1], f[2, 4, 1]}, {f[3, 1, 1], f[3, 2, 1], 
   f[3, 3, 1], f[3, 4, 1]}}, {{f[1, 1, 2], f[1, 2, 2], f[1, 3, 2], 
   f[1, 4, 2]}, {f[2, 1, 2], f[2, 2, 2], f[2, 3, 2], 
   f[2, 4, 2]}, {f[3, 1, 2], f[3, 2, 2], f[3, 3, 2], f[3, 4, 2]}}}

Dimensions@t2
{2, 3, 4}

The Bottom Line

Bottom line? Even if you are an experienced Mathematica user, it is worth having a good look at the documentation for basic functions from time to time. You might be missing some of the power they contain in their optional arguments.

Let’s start with the first example of a heat map from the Wikipedia entry. I don’t have the real data, so let’s make some fake data.

testdata = RandomVariate[TriangularDistribution[{-1, 1}, 0.2], {30, 15}];

We’ll also need some tick labels. Here, I’ve used Array, which is the simplest and fastest way to build up a matrix or vector of things that depend on iterators that increment by 1, such as 1, 2…. If you can something a bit more complicated, such as a different step size, you could alway use Table. Array expects pure functions (Slot notation), so you don’t actually need to give the iterator a name. This is one of the features of Mathematica that new users find most difficult, but I find it quite useful because I don’t have to worry which i or j I am referring to (because everybody uses i or j for iterators, don’t they, and then finds it hard to keep all the iterators straight in their minds?). Notice how I’ve used the Rotate command (and a rotation angle in radians) to get sideways text, and the pair {0,0}, to ensure that we have a label and no tick. You can read more about these settings in the FrameTicks documentation.

xtix = Array[{#, Rotate["E"  ToString[#], 3 Pi/2], {0, 0}} &, {15}];

ytix = Array[{#, "F"  ToString[#], {0, 0}} &, {30}];

Mathematica has a huge range of built-in color schemes, including “TemperatureMap”, “LightTemparatureMap” and “ThermometerColors”. All three scale from blue to red, but differ slightly in the details. There is also “RedGreenSplit” and “WatermelonColors” which scale from red to green or vice versa, with white in the middle. The way these color gradients work is that they assign a particular shade to any value from 0 to 1.

Column[Show[ColorData[#, "Image"], 
  ImageSize -> 110] & /@ {"TemperatureMap", "LightTemperatureMap", 
  "ThermometerColors", "RedGreenSplit", "WatermelonColors"}, Spacings -> .5]

But what if you want more control over your color gradient, or it doesn’t conform to the color combinations Mathematica has built in? A good example of a custom gradient is the red-black-green scaling in the Wikipedia example. This is where the Blend function comes into its own. In the simplest case, this function just provides a linear interpolation between the colors, as this example from the documentation shows.

Graphics[Table[{Blend[{Red, Green}, x], Disk[{8 x, 0}]}, {x, 0, 1, 1/8}]]

But as the documentation also shows, you can specify multiple “attachment points” for multiple colours. Here’s an example that goes through red to black to green, like many traditional heat maps, with a “flat spot” of black when the data takes values between zero and 0.5. Notice how I can then pass the iterator x to the function myblend just like any other function.

myblend = (Blend[{{-1, Red}, {0, Black}, {0.5, Black}, {1, Green}}, #] &);
Graphics[Table[{myblend[x], Disk[{8 (x + 1), 0}]}, {x, -1, 1, 1/8}]]

To turn the data above into a heat map, just use the MatrixPlot function. You can also use ArrayPlot, but it is better for smaller matrices. MatrixPlot works for wider data ranges and sparse arrays. To get the right coloring, you need to turn the ColorFunctionScaling option to False. This is because MatrixPlot and ArrayPlot implicitly rescale the data to run between 0 and 1 to determine the coloring to use for each cell. If your Blend function is designed to take a wider data range, as this one is, then you want to maintain control over the mapping from data to color this way.

Manipulate[
  MatrixPlot[testdata, ColorFunctionScaling -> False, AspectRatio -> 1,
   ColorFunction -> (Blend[{{r, Red}, {r + b1, Black}, {r + b1 + b2, 
     Black}, {r + b1 + b2 + g, Green}}, #] &), 
     FrameStyle -> AbsoluteThickness[0], PlotRangePadding -> 0, 
     FrameTicks -> {{ytix, None}, {xtix, None}}], {r, -2, 1}, {b1, 0, 1}, {b2, 0, 1}, {g, 0, 1}]

Now, what if I want to combine more than one of these arrays? People often resort first to GraphicsGrid, but that command assumes that all the columns are the same width. If that isn’t the case, just use Grid. There are other ways to combine graphics in this way: this question and the answers there provide some other useful ideas.

testdata2 = RandomVariate[TriangularDistribution[{-1, 1}, 0.4], {30, 5}];

fat = ArrayPlot[testdata, ColorFunctionScaling -> False, 
  ColorFunction -> myblend, PlotRangePadding -> 0, Frame -> False];
skinny = ArrayPlot[testdata2, ColorFunctionScaling -> False, 
  ColorFunction -> myblend, PlotRangePadding -> 0, Frame -> False];
Grid[{{fat, skinny}}]

Finally, we want to put the heat map next to the associated dendrograms. Searching on “dendrogram” in the Mathematica documentation brings up the HierarchicalClustering package and its DendrogramPlot function.

Needs["HierarchicalClustering`"]

Using it is pretty straightforward. Strangely, it takes all the usual Graphics and Plot-related options, but in version 8, at least, the front end does not recognise this and colors them red.

DendrogramPlot[Transpose@testdata, AspectRatio -> 1/5]

So we can put all this together in a Grid. Notice that I have clustered the data and the transpose of the data to get the two dendrograms. I don’t know anything about DNA microarrays, so I assume that this is what is required. Getting everything to line up takes a little bit of fiddling, but in essence, you need to pay attention to the width and height of the elements, as specified by the ImageSize and AspectRatio options. The ImagePadding takes care of any need to shift the edge of one element inside the outer edge defined by a larger element. Obviously if your FrameTick labels are longer, or the underlying graphic larger or a different AspectRatio, you will need to tweak these other dimensions.

Grid[{{DendrogramPlot[Transpose@testdata, AspectRatio -> 1/5, 
     ImageSize -> 240, ImagePadding -> {{15, 0}, {0, 0}}], Null}, 
 {MatrixPlot[testdata, ColorFunctionScaling -> False, 
     AspectRatio -> 1, ColorFunction -> myblend, 
     FrameStyle -> AbsoluteThickness[0], PlotRangePadding -> 0, 
     FrameTicks -> {{ytix, None}, {xtix, None}}, 
     BaseStyle -> {FontFamily -> "Helvetica Neue", FontSize -> 8}, ImageSize -> 250], 
    DendrogramPlot[testdata, AspectRatio -> 5, Orientation -> Right, 
     ImageSize -> 45, ImagePadding -> {{0, 0}, {20, 0}}]}}, Spacings -> {0, -0.2}]

So there you have it. It takes a little bit of fiddling of the available options, but it is more than possible to create all sorts of custom visualisations specific to your field.

This isn’t my story alone. wxffles had the original idea; J.M. came up with a variant that allowed the colouring to be defined in a very granular way. I took their code and started playing with it, and developed a slightly more generalized function to parametrize the colour palette. (You should always leave colour choices to girls, right?)

So how did we get there?

First, start with a simple pentagon:

p5 = Polygon[Table[N[{Cos[t], Sin[t]}], {t, Pi/10, 2 Pi, 2 Pi/5}]];

Then, create some replacement rules to turn polygons into more complex shapes:

triangulate =
  Polygon[v_] :> (Polygon[Append[#, Mean[v]]] & /@ Partition[v, 2, 1, {1, 1}]);

To give you an idea of what this does, we can try:

Graphics[{FaceForm[White], EdgeForm[Black], p5 /. triangulate}]

Then, add another layer of triangulation:

moretriangles = Polygon[{a_, b_, c_}] :>
  With[{ab = (a + b)/2, bc = (b + c)/2, ca = (c + a)/2},
       {Polygon[{a, ab, ca}], Polygon[{ab, b, bc}],
        Polygon[{c, ca, ab}], Polygon[{c, ab, bc}]}];

Graphics[{FaceForm[White], EdgeForm[Black], p5 /. triangulate /. moretriangles}]

The next function turns those simple edges into “facets”:

shrink = Polygon[{a_, b_, c_}] :>
  With[{aa = (6 a + b + c)/8, bb = (a + 6 b + c)/8, cc = (a + b + 6 c)/8},
       {Polygon[{a, b, bb, aa}], Polygon[{b, c, cc, bb}],
        Polygon[{c, a, aa, cc}], Polygon[{aa, bb, cc}]}];

Graphics[{FaceForm[White], EdgeForm[Black], p5 /. triangulate /. shrink}]

Next, colour in the background areas with a light grey colour (that’s the colour3 rule set). And then, colour in the other segments according to how far they are from the centre (that’s the colour4 rule set). Notice the helper function PolygonCentroid.

colour3[s_: LightGray] := q : Polygon[{_, _, _}] :> {s, q};

PolygonCentroid[pts_?MatrixQ] :=
  With[{dif = Map[Det, Partition[pts, 2, 1, {1, 1}]]},
    ListConvolve[{{1, 1}}, Transpose[pts], {-1, -1}] . dif / (3 Total[dif])
]

colour4[s_: "SunsetColors"] := Polygon[v_] /; Length[v] == 4 :>
  {ColorData[s, 8/7 - 35/34 Norm[PolygonCentroid[v]]], Polygon[v]}

Finally, change the outer edges of the polygon into a hyperbolic curve. One does this by changing the outer edge of a polygon to have several intermediate points (the curve function), and then shifting those points onto a hyperbolic curve (that’s what the ArcSin function is doing).

curve = Polygon[v_] :>
  FilledCurve[
    Line[Map[{10 - #, #}/10 &, Range[0, 10]].#] &
      /@ Partition[v, 2, 1, {1, 1}]];

bolics = v : {_?NumberQ, _} :> v Re[(ArcSin[2 Norm[v] - 1] + Pi/2)/2];

Mathematica comes with a whole suite of colour schemes built in. Some of them are "Indexed" schemes, collections of discrete colours. These are useful for tasks like colouring successive lines in a plot. For our purposes, we need the continuous colour schemes (gradients). If I hadn’t liked any of the built-in schemes, I could have used the Blend[] function to come up with my own. Let’s allow for some tweaking of that colour scheme if needed. Notice how the pattern-matching capabilities of Mathematica allow you to have different numbers of arguments and the same function name.

colour4[s_: "SunsetColors", a_?NumericQ, b_?NumericQ] :=
  Polygon[v_] /; Length[v] == 4 :>
    {ColorData[s, a - b Norm[PolygonCentroid[v]]], Polygon[v]}

This was the version that everyone seemed to like and it was the basis of the original version of the site design.

Graphics[p5 /. triangulate /. moretriangles /. shrink /. shrink
  /. colour3[] /. colour4[] /. curve /. bolics]

That wasn’t the end of the process, though. We’d settled on the pointy star shape largely because it was an homage to the Wolfram Mathematica logo. What else to signify a site about Mathematica than a spiky thing? We had thought that 2D versus 3D was enough of a distinction to avoid trademark violations. But none of us are trademark lawyers and Wolfram’s lawyers disagreed. Fair enough; that’s their prerogative.

We needed to come up with a new logo fast – the site was due to graduate out of beta.

The code that created the logo was based on replacement rules, and I can’t think of a better exposition of just how powerful they are than to show how small changes in the composition of rules could change our proposed logo.

The first issue was to avoid a five-pointed thing. Easy, just change the starting polygon to:

p7 = Polygon[Table[N[{Cos[t], Sin[t]}], {t, Pi/14, 2 Pi, 2 Pi/7}]];

Six and eight-pointed things work exactly the same way.

The other issue was the spikiness of the shape. This was created by two sets of rules used in succession: bolics and curve. Essentially what these rules do is add a set of intermediate points in between each polygon corner, and then move these points inwards according to the required hyperbolic function.

I experimented with reducing the amount of curvature, by changing bolics to a function:

bolicsn[n_] := v : {_?NumberQ, _} :> v Re[(ArcSin[2 Norm[v] - 1] + Pi/n)/2];

It is also possible to have the indentations without the curvature: Here’s a version I tried with a straight-line indentation and a different colour scheme. Notice how I changed the extent of indentation by using the more general bolicsn function. Removing the curve set of rules removes the curvature of the outside edge.

p7b = Polygon[Table[N[{Cos[t], Sin[t]}], {t, 3 Pi/14, 2 Pi, 2 Pi/7}]];

Graphics[p7b /. triangulate /. moretriangles /. shrink /. shrink /. shrink
  /. colour3[] /. colour4["SunsetColors", .95, 32/34] /. bolicsn[0.4]]

In the end we went with a straight line side and no curvature: the lawyers felt that this was the version that posed the least trademark issues. As you can see, all I had to do was remove the bolics and curve rules, and add another iteration of internal faceting by using the shrink rules a third time. Oh, and I had to tweak the colours a little to match the earlier version. All of this was possible in under an hour of fiddling.

Graphics[p7 /. triangulate /. moretriangles /. shrink /. shrink /. shrink
  /. colour3[] /. colour4["SunsetColors", 1, 28/34]]

The net result is something we are still happy with, even if it wasn’t our first idea. Apparently we are the first StackExchange community to design our own logo ourselves. What better way for a community of Mathematica users to do it, than with Mathematica?

Download this blog post as a Mathematica notebook

We will have plenty to talk about, from behind-the-scenes explications of our most popular posts, to exposés on how to get even more out of the Mathematica software. Mathematica is an exceptionally rich environment that goes beyond pure programming. Over on the Q&A site, you will find questions (and answers) on front-end features like stylesheets, as well as interfacing with other languages, and everything in between. We also have some questions that are just plain fun!

As for who we are, the blog team is made up of many of the regular users on the Mathematica Stack Exchange site, including the moderators and some of the other top-ranking participants. Our backgrounds and expertise are diverse, but we’re all enthusiastic about the possibilities that Mathematica can offer.