[WSC21]: Automatic Generation of Representational Infographics - Online Technical Discussion Groups

This project worked to automatically generate representative pictograms given the values and their respective icons. This includes both pictograms with a single quantity as well as multiple quantities together. There are options for values such as number of rows and dimensions of the individual icons to be specified or automatically calculated.

Goals

Pictograms are a type of infographic that aim to represent quantities visually by putting up a given image repeatedly, so that the number of images is proportional to quantity the image represents. Multiple images and quantities can be used simultaneously (with the same scale), either in individual grids next to each other or within the same grid, to compare the quantities visually. This project aimed to automatically generate these infographics given the values and their corresponding pictures for each grid.

Generating a pictogram with one image and value

I wrote a function which will generate a pictogram of a given Image with respect to its corresponding value which represents a particular metric. This function puts the number of whole images (the floor of the total input value) together with the proportional part of the whole image, corresponding to the fractional part of the total number (which is padded to have the same dimensions as the whole image) with options to specify if the graphic that will be output should have horizontal or vertical orientation. There is a separate case for if the fractional part is zero to avoid errors resulting from trying to take 0% of an image.

For example, I can use createRepresentationSingle to generate a pictogram that represents the existence of 13.2 million dogs by inputting a dog image and the number 13.2. The function will output 13 whole dog images and .2 of a dog image in one graphic where all images output have the same dimensions.

createRepresentationSingle[picture_Graphics|picture_Image,n_Real|n_Integer,rows_Integer,width_,height_,horizontalQ_Symbol] := GraphicsGrid[ If[ horizontalQ == True, Transpose[#], #]&[ If[ FractionalPart[n]==0, Partition[Join[Table[picture,n], Table["",rows-Mod[n,rows]]], UpTo[rows]], Partition[Join[ Table[picture, Floor[n]], ImagePad[ ImageTrim[picture, {{0,0}, {ImageDimensions[picture][[1]]*FractionalPart[n],ImageDimensions[picture][[2]]}}], {{0,ImageDimensions[picture][[1]]*(1-FractionalPart[n])},{0,0}}, White ], Table["",(rows-Mod[Ceiling[n],rows])] ], rows] ] ], Alignment -> Left, ImageSize -> If[horizontalQ, {Automatic,height*rows}, {width*rows,Automatic}], Spacings->5]

An example pictogram for 16.3 people that is horizontal:

In[]:=

createRepresentationSingle

men's room

ICON

["Image"],16.3,3,50,114,True

Out[]=

Resizing the images

This resizes all the images put in so they have the same dimensions.

resizeImages[pictures_List,width_Integer,height_Integer] := ImageResize[#,{width,height}]&/@pictures

Generating a pictogram with multiple images and values

I also wanted to create a function to handle the case if there is more than one image to be used in a pictogram. The function works similarly to createRepresentationSingle and considers two cases for general pictogram: - if there are just two images and corresponding values are given - if more than two images and corresponding values are given If there are two images, it takes the floor of the first value corresponding to the first image, and then stitches together the fractional part of the first image with the remainder of the second image to generate a combined image.If there are multiple images, it gives the number of whole first images (which is the floor of the first value), and then one final image which takes the proportional part from the corresponding part of each of the remaining images and combines them, up until a whole image is reached, cutting off the last image. For example, suppose we have the values {2.2, .3, .1, 4}. The last image combines 0 to .2 of the first image, .2 to .5 of the second, .5 to .6 of the third, and .6 to 1 of the fourth, with the option for white bars to be inserted between each different image for clarity.Note that these images should all be (and will be when called in future functions) the same dimension, and that the sum of the fractional part of the first value and all the other values except for the last one should be less than 1, but the sum of the fractional part of the first value and all the others should be at least 1, since these are the values that make up the last image and that image should both be filled completely but not be overfilled with extraneous values.

imageTrimCombiner[images_List,values_List,height_,separateQ_Symbol]:= Flatten[ Table[images[[1]],Floor[values[[1]]]], ImageAssemble[ If[separateQ, Riffle[#, ImageTrim[Graphics[{White, Rectangle[{-2,0},{2,height}]}], {{0,0},{1,height-1}}]], #]&[ If[ Length[images]==2,  If[ FractionalPart[values[[1]]] < 10^(-10), Nothing, ImageTrim[images[[1]], {{2,0}, {ImageDimensions[images[[1]]][[1]]*FractionalPart[values[[1]]] - If[separateQ, 1, 0], height}}] ], ImageTrim[images[[2]],  {ImageDimensions[images[[2]]][[1]]*(FractionalPart[values[[1]]]) + If[separateQ, 1, 0], 0}, {ImageDimensions[images[[2]]][[1]],height} ] , Join[ If[ FractionalPart[values[[1]]] < 10^(-10), Nothing, ImageTrim[images[[1]], {{2,0}, {ImageDimensions[images[[1]]][[1]]*FractionalPart[values[[1]]] - If[separateQ,1,0], height}}] ], Table[ If[ FractionalPart[values[[i]]] < 10^(-10), Nothing, ImageTrim[images[[i]],  {1 + ImageDimensions[images[[i]]][[1]]*(FractionalPart[values[[1]] + Total[Take[values, {2,i-1}]]]) + If[separateQ, 1, 0], 0}, {ImageDimensions[images[[i]]][[1]]*(FractionalPart[values[[1]]] + Total[Take[values, {2,i}]]) - If[separateQ,1,0],height} ] ], {i,2,Length[images]-1} ],  ImageTrim[images[[-1]],  {ImageDimensions[images[[-1]]][[1]]*(FractionalPart[values[[1]]] + Total[Take[values, {2,-2}]]) + If[separateQ, 1, 0], 0}, {ImageDimensions[images[[-1]]][[1]], height}  ]  ] ] ] ]]

This determines which values (and their corresponding images) go into the imageTrimCombiner, based off of the criteria mentioned above. It then changes the values of all numbers that were part of the last imageTrimCombiner, taking away all of the portions of each value that was used so that the values are the remaining amount to be shown in the graphic. It then runs imageTrimCombiner on each set of values & images.

createRepresentationMultiple[images_List,size_List,rows_Integer,width_Integer,height_Integer,horizontalQ_Symbol,separateQ_Symbol]:= Module[ {sizes=size, imagesList=resizeImages[images,width,height], indexs={0,0}}, GraphicsGrid[ If[horizontalQ, Transpose[#], #]&[ Partition[Join[ Flatten[ Table[ Which[ i < indexs[[2]], sizes[[i]] = 0, i == indexs[[2]] && (indexs[[2]] - indexs[[1]]) > 1, sizes[[i]] = sizes[[i]]-1 + FractionalPart[sizes[[indexs[[1]]]]] + Total[Take[size, {indexs[[1]]+1, indexs[[2]]-1}]], i == indexs[[2]] && (indexs[[2]] - indexs[[1]]) == 1, sizes[[i]] = sizes[[i]]-1 + FractionalPart[sizes[[indexs[[1]]]]] ]; Which[ sizes[[i]] < 10^(-10),(*If size is 0*) Nothing, i==1, (*If first element, *) indexs = {i, Values[Select[Association[Thread[sizes -> Range[Length[sizes]]]], FractionalPart[sizes[[1]]]+Total[Take[sizes,{2,#}]]>=1&]][[1]]}; imageTrimCombiner[Take[imagesList, indexs], Take[sizes,indexs], height, separateQ] , i == Length[sizes], (*If end element,*) Join[ Table[imagesList[[i]], Floor[sizes[[i]]]], If[ FractionalPart[sizes[[i]]] < 10^(-10), Nothing, ImageTrim[imagesList[[i]], {{0,0}, {ImageDimensions[imagesList[[i]]][[1]]*FractionalPart[sizes[[i]]], height}}] ] ], True, (*If intermediate element,*) indexs = i, Values[Select[ Association[Thread[Drop[sizes,i-1]->Range[Length[Drop[sizes, i-1]]]]], FractionalPart[Drop[sizes,i-1][[1]]] + Total[Take[Drop[sizes, i-1], {2,#}]] >= 1&] ][[1]] + i-1; imageTrimCombiner[Take[imagesList, indexs], Take[sizes, indexs], height, separateQ] ], {i,Length[imagesList]} ] ], If[ Mod[Ceiling[Total[size]],rows] == 0, {}, Table["", rows - Mod[Ceiling[Total[size]], rows]] ] ], rows] ], Alignment -> Left, ImageSize -> If[horizontalQ, {Automatic, height*rows}, {width*rows, Automatic}], Spacings->5 ]]

An example pictogram for 16.3 blue,0.5 green, 3.3 purple, and 4.9 red people that is vertical and has the separating bars:

In[]:=

x=createRepresentationMultipleColorReplace

men's room

ICON

["Image"],Black->Blue,ColorReplace

men's room

ICON

["Image"],Black->Green,ColorReplace

men's room

ICON

["Image"],Black->Purple,ColorReplace

men's room

ICON

["Image"],Black->Red,{16.3,.5,3.3,4.9},5,50,114,False,True;ImageResize[x, Scaled[.7]]

Out[]=

Combining Multiple Pictograms

This constructs multiple pictograms side by side with the same style (number of rows, dimensions of each icon, direction, separating bar) for easy comparison between them by taking in set values for each of those stylistic factors and tabling through lists of lists of images and values that give the data for each pictogram (which can each be of either one or multiple images/values).

createRepresentations[imagesLists_,valuesLists_,rows_Integer,dimensions_List,horizontalQ_Symbol,separateQ_Symbol] := Module[ {max=0}, If[ horizontalQ, max = Max[ImageDimensions[#][[1]]&/@#]; GraphicsColumn[ImagePad[#,{{0,max-ImageDimensions[#][[1]]},{0,0}},White]&/@#,Left,20,ImageSize->{max,Automatic}], max = Max[ImageDimensions[#][[2]]&/@#]; GraphicsRow[ImagePad[#,{{0,0},{max-ImageDimensions[#][[2]],0}},White]&/@#,20,AlignmentTop,ImageSize->{Automatic,max}] ]&[ Table[ If[ Length[imagesLists[[i]]]==1, createRepresentationSingle[resizeImages[imagesLists[[i]], dimensions[[1]], dimensions[[2]]][[1]], valuesLists[[i,1]], rows, dimensions[[1]], dimensions[[2]], horizontalQ], createRepresentationMultiple[imagesLists[[i]], valuesLists[[i]], rows, dimensions[[1]], dimensions[[2]], horizontalQ, separateQ] ], {i, Length[imagesLists]} ] ]]

Here is an example pair of pictograms

In[]:=

ImageResizecreateRepresentationsColorReplace

men's room

ICON

["Image"],Black->Black,ColorReplace

men's room

ICON

["Image"],Black->Green,

men's room

ICON

["Image"],{{8},{4.6,10}},2,{50,114},True,True,Scaled[.4]

Out[]=

Calculation of Extra Values

These functions allow some values (specifically, numeric values that are not the raw data) of createRepresentations to not be manually inputted, and instead calculated by the computer.

This scales the raw data to an appropriate size for a pictogram, with all pictograms being scaled the same power of 10 and the largest total final number of an individual pictogram being no greater than 150:

scaledLargestTotal[valuesLists_List]:= Divide[ #, 10.^(Floor[Max[Log[10, #]&/@Total/@valuesLists]] - If[#/10^Floor[Log[10, #]]&[Max[Total/@valuesLists]] <= 1.5, 2, 1])]&/@valuesLists

This calculates the dimensions that each icon will be, with the width being 75 and the ratio of width to height being the geometric mean of all width to height ratios of the images:

widthHeight[imagesLists_List]:={75, Floor[75.*GeometricMean[ImageDimensions[#][[2]]/ImageDimensions[#][[1]]&/@Flatten[imagesLists]]]}

This calculates the number of rows so that the overall ratio of the final infographic will be close to ratio:

calculateRows[scaledValuesLists_List,ratio_,dimensions_,horizontalQ_Symbol] := Module {totals=Total/@scaledValuesLists}, If Max[totals] <= 12, 1, FloorSqrt If horizontalQ, dimensions[[1]]dimensions[[2]], dimensions[[2]]dimensions[[1]] *Max[totals]*ratioLength[totals]  

Compilation into Final Function

This runs createRepresentations, but with default values assigned to options and calculations to find other options using the above functions, such that the only required inputs are the list of lists of images and list of lists of values:

Options[makePictogram] = {"rows"->0,"ratio"->((1+Sqrt[5])/2),"dimensions"->{0,0},"scaleNumbersQ"->True,"separateQ"->False};makePictogram[imagesLists_List,valuesLists_List,horizontalQ_Symbol:False,opt:OptionsPattern[]] := Module[ {rows = OptionValue["rows"], ratio=OptionValue["ratio"], dimensions=OptionValue["dimensions"], scaleNumbersQ=OptionValue["scaleNumbersQ"], separateQ=OptionValue["separateQ"], scaled}, scaled=If[ OptionValue["scaleNumbersQ"]===False, valuesLists, scaledLargestTotal[valuesLists] ]; createRepresentations[ imagesLists, scaled, If[ rows<1, calculateRows[ scaled, ratio, If[ dimensions[[1]] > 0 && dimensions[[2]] > 0, dimensions, widthHeight[imagesLists] ], horizontalQ ], rows ], If[ dimensions[[1]] > 0 && dimensions[[2]] > 0, dimensions, widthHeight[imagesLists] ], horizontalQ, separateQ ]]

A couple of example output infographics:

In[]:=

ImageResizemakePictogram

men's room

ICON

["Image"],

men's room

ICON

["Image"],ColorReplace

men's room

ICON

["Image"],Black->Red,

men's room

ICON

["Image"],ColorReplace

men's room

ICON

["Image"],Black->Red,ColorReplace

men's room

ICON

["Image"],Black->Orange,

men's room

ICON

["Image"],

men's room

ICON

["Image"],ColorReplace

men's room

ICON

["Image"],Black->Red,ColorReplace

men's room

ICON

["Image"],Black->Orange,ColorReplace

men's room

ICON

["Image"],Black->Yellow,ColorReplace

men's room

ICON

["Image"],Black->Green,ColorReplace

men's room

ICON

["Image"],Black->Blue,ColorReplace

men's room

ICON

["Image"],Black->Purple,ColorReplace

men's room

ICON

["Image"],Black->Gray,ColorReplace

men's room

ICON

["Image"],Black->Brown,{{4},{12.4,5.6},{1,3.2,2},{13.6},{1,2.2,.1,.3,4,.2,1.3,1.9,3.9}},Scaled[.2]

Out[]=

In[]:=

x=makePictogram

men's room

ICON

["Image"],ColorReplace

men's room

ICON

["Image"],Black->Blue,

men's room

ICON

["Image"],ColorReplace

men's room

ICON

["Image"],Black->Blue,ColorReplace

men's room

ICON

["Image"],Black->Purple,

men's room

ICON

["Image"],{{320000,532942},{221794,184571,570002},{177777}},True;ImageResize[x, Scaled[.1]]

Out[]=

x = makePictogramBinarize

United States

COUNTRY



flag

,

United States

COUNTRY



flag

,Binarize

United Kingdom

COUNTRY



flag

,

United Kingdom

COUNTRY



flag

,Binarize

Greece

COUNTRY



flag

,

Greece

COUNTRY



flag

,Binarize

Canada

COUNTRY



flag

,

Canada

COUNTRY



flag

<