4
$\begingroup$

I'm attempting to build a nine-region cluster chart using Tooltip to display labels associated with 2-D points also displayed on it. I do NOT want to use "FindClusters". I want to design my own cluster chart as explained below. The following mock data is made-up of 2-D points where each points have a label-identifier called a "NAICS" code (NAICS stands for "North American Industry Classification System").

mockdataWithNAICS = {{"29-1141", 186, 112}, {"41-2031", 123, 92}, {"41-1011", 65, 404}, {"43-4051", 108, 646}, {"31-1014", 643, 246}, {"49-9071", 356, 363}, {"43-1011", 543, 381}, {"43-5081", 268, 674}, {"53-3032", 416, 653}, {"37-3011", 514, 428}, {"37-2012", 501, 58}, {"33-9032", 441, 598}, {"35-2014", 633, 138}, {"29-2061", 414, 590}, {"53-3033", 98, 155}, {"35-3031", 179, 431}, {"49-3023", 93, 623}, {"35-3021", 37, 578}, {"41-2011", 256, 237}, {"37-2011", 302, 50}, {"47-1011", 518, 2}, {"11-9111", 313, 294}, {"31-9092", 698, 136}, {"43-3031", 608, 610}, {"43-6013", 562, 515}, {"13-2011", 415, 327}, {"21-1093", 191, 72}, {"41-4012", 212, 92}, {"41-3031", 546, 418}, {"31-1011", 591, 49}, {"47-2031", 405, 526}, {"41-3021", 191, 297}, {"15-1151", 442, 445}, {"43-6011", 118, 185}, {"49-1011", 472, 402}, {"53-7062", 348, 552}, {"43-4171", 409, 396}, {"43-6014", 348, 247}, {"53-1031", 629, 59}, {"47-2061", 589, 534}, {"27-1026", 22, 377}, {"29-1069", 445, 74}, {"49-9021", 647, 539}, {"43-9061", 25, 543}, {"11-1021", 19, 165}, {"41-1012", 482, 199}, {"29-1062", 1, 68}, {"43-4081", 217, 112}, {"41-3099", 663, 66}, {"11-3031", 329, 392}, {"53-7061", 357, 515}, {"35-2021", 488, 245}, {"31-9091", 318, 679}, {"51-1011", 650, 349}, {"11-9051", 38, 145}, {"53-3031", 166, 691}, {"39-9021", 561, 127}, {"39-5012", 665, 362}, {"47-2111", 397, 532}, {"43-3071", 326, 271}, {"29-2034", 361, 450}, {"35-9011", 12, 366}, {"29-1123", 16, 211}, {"15-1142",162, 662}, {"11-2021", 520, 164}, {"29-2031", 339, 619}, {"25-2011", 263, 564}, {"41-4011", 551, 301}, {"29-2055", 76, 549}, {"29-2052", 285, 640}, {"13-2072", 370, 542}, {"35-2012", 512, 547}, {"11-2022", 130, 154}, {"15-1132", 188, 274}, {"13-2052", 338, 587}, {"15-1199", 455, 5}, {"35-9031", 595, 472}, {"17-2051", 648, 481}, {"11-9199", 430, 189}, {"39-3091", 29, 396}, {"47-2152", 412, 342}, {"29-1122", 582, 20}, {"11-9141", 276, 4}, {"25-2021", 666, 617}, {"15-1134", 236, 334}, {"37-1011", 407, 664}, {"29-1063", 260, 278}, {"49-3031", 161, 354}, {"41-9022", 185, 144}, {"41-9041", 551, 628}, {"25-2031", 529, 505}, {"29-2071", 548, 296}, {"29-1127", 373, 124}, {"21-1023", 473, 71}, {"29-1067", 489, 569}, {"29-1071", 539, 277}, {"11-3121", 390, 348}, {"11-9021", 634, 20}, {"53-3041", 589, 258}, {"49-3021", 47, 206}}; L = Length[mockdataWithNAICS]; counter = Range[L]; counter = Range[L]; mock2Dvalues = {mockdataWithNAICS[[#]][[2]], mockdataWithNAICS[[#]][[3]]} & /@ counter

The following measurements are necessary to build a grid :

minx = Round[Min[Table[{mock2Dvalues[[i]][[1]]}, {i, 1, L}]]]; maxx = Round[Max[Table[{mock2Dvalues[[i]][[1]]}, {i, 1, L}]]]; dx = Round[Subdivide[minx, maxx, 3]]; miny = Round[Min[Table[{mock2Dvalues[[i]][[2]]}, {i, 1, L}]]]; maxy = Round[Max[Table[{mock2Dvalues[[i]][[2]]}, {i, 1, L}]]]; dy = Round[Subdivide[miny, maxy, 3]]; gridpts = Tuples[{dx, dy}];

The following plot will allow you to visualize the grid and all the data points :

plt1 = ListPlot[gridpts, Frame -> True, PlotStyle -> Black, GridLines -> {dx, dy}, Epilog :> {Blue, Point[mock2Dvalues]}]

Mathematica graphics

The purpose of the following plot is to allow you to display the grid points with the aid of Tooltip to define the following nine regions :

plt2 = ListPlot[Tooltip[gridpts], Frame -> True, PlotStyle -> Black, GridLines -> {dx, dy}]

Mathematica graphics

Here we define the nine cluster regions. We assign colors to the region names as a "mnemonic device" to associate the 2-D points with the regions that they belong-to, according to color. The colors are arbitrary :

 magentaregion = Rectangle[gridpts[[1]], gridpts[[6]]] orangeregion = Rectangle[gridpts[[5]], gridpts[[10]]] cyanregion = Rectangle[gridpts[[9]], gridpts[[14]]] redregion = Rectangle[gridpts[[2]], gridpts[[7]]] blueregion = Rectangle[gridpts[[6]], gridpts[[11]]] greenregion = Rectangle[gridpts[[10]], gridpts[[15]]] lightgrayregion = Rectangle[gridpts[[3]], gridpts[[8]]] yellowregion = Rectangle[gridpts[[7]], gridpts[[12]]] blackregion = Rectangle[gridpts[[11]], gridpts[[16]]]

Here we disburse the points according to the regions where they belong to :

magentapts = Select[mock2Dvalues, # \[Element] magentaregion &] orangepts = Select[mock2Dvalues, # \[Element] orangeregion &] cyanpts = Select[mock2Dvalues, # \[Element] cyanregion &] redpts = Select[mock2Dvalues, # \[Element] redregion &] bluepts = Select[mock2Dvalues, # \[Element] blueregion &] greenpts = Select[mock2Dvalues, # \[Element] greenregion &] lightgraypts = Select[mock2Dvalues, # \[Element] lightgrayregion &] yellowpts = Select[mock2Dvalues, # \[Element] yellowregion &] blackpts = Select[mock2Dvalues, # \[Element] blackregion &]

The following plots are necessary to build the final chart below :

plt3 = ListPlot[magentapts, Frame -> True, PlotStyle -> Magenta, GridLines -> {dx, dy}, PlotRange -> {{minx, maxx}, {miny, maxy}}, AspectRatio -> 1]; plt4 = ListPlot[orangepts, Frame -> True, PlotStyle -> Orange, GridLines -> {dx, dy}, PlotRange -> {{minx, maxx}, {miny, maxy}}, AspectRatio -> 1]; plt5 = ListPlot[cyanpts, Frame -> True, PlotStyle -> Cyan, GridLines -> {dx, dy}, PlotRange -> {{minx, maxx}, {miny, maxy}}, AspectRatio -> 1]; plt6 = ListPlot[redpts, Frame -> True, PlotStyle -> Red, GridLines -> {dx, dy}, PlotRange -> {{minx, maxx}, {miny, maxy}}, AspectRatio -> 1]; plt7 = ListPlot[bluepts, Frame -> True, PlotStyle -> Blue, GridLines -> {dx, dy}, PlotRange -> {{minx, maxx}, {miny, maxy}}, AspectRatio -> 1]; plt8 = ListPlot[greenpts, Frame -> True, PlotStyle -> Green, GridLines -> {dx, dy}, PlotRange -> {{minx, maxx}, {miny, maxy}}, AspectRatio -> 1]; plt9 = ListPlot[lightgraypts, Frame -> True, PlotStyle -> LightGray, GridLines -> {dx, dy}, PlotRange -> {{minx, maxx}, {miny, maxy}}, AspectRatio -> 1]; plt10 = ListPlot[yellowpts, Frame -> True, PlotStyle -> Yellow, GridLines -> {dx, dy}, PlotRange -> {{minx, maxx}, {miny, maxy}}, AspectRatio -> 1]; plt11 = ListPlot[blackpts, Frame -> True, PlotStyle -> Black, GridLines -> {dx, dy}, PlotRange -> {{minx, maxx}, {miny, maxy}}, AspectRatio -> 1];

This plot shows the nine-region cluster chart with the points colored by the region that they belong to :

finalchart = Show[{plt3, plt4, plt5, plt6, plt7, plt8, plt9, plt10, plt11}]

Mathematica graphics

Finally; we establish an association between the NAICS codes and their 2 - D points as follows:

mockdataWithNAICSlabels = Association[#[[1]] -> #[[2 ;; 3]] & /@ mockdataWithNAICS]; Dataset[mockdataWithNAICSlabels]

My question is: How can I associate the NAICS codes to their respective points BY COLORED REGION, so that if I use Tooltip; the NAICS codes will be displayed for each point in the above finalchart? Thank you!

Improve this question
$\endgroup$
6
  • $\begingroup$ Gilmar, a gentle reminder (if I may) re the comments following this post of yours re your previous questions $\endgroup$ Commented Sep 20, 2019 at 19:53
  • $\begingroup$ Dear Carl @kglr: I read your answer at the time and accepted your answer. I'm not sure what you are trying to tell me? That was a different topic (and post) altogether. Please, elaborate if you must. $\endgroup$ Commented Sep 20, 2019 at 20:06
  • $\begingroup$ @kglr How do I accept answers retro-actively? When I review my old posts there are no green check marks to be checked any more. As I made clear before; I learned about pressing the green check mark recently and I have done it ever since. I have NOT left the green check marks unchecked intentionally or with malice. Thank you. $\endgroup$ Commented Sep 20, 2019 at 20:27
  • $\begingroup$ @Carl Lange How do I accept answers retro-actively? When I review my old posts there are no green check marks to be checked any more. As I made clear before; I learned about pressing the green check mark recently and I have done it ever since. I have NOT left the green check marks unchecked intentionally or with malice. Thank you. $\endgroup$ Commented Sep 20, 2019 at 20:27
  • $\begingroup$ Thank you Gilmar. This is strange; you should be able accept/unaccept anytime. Perhaps this calls for developer/moderator attention to fix whatever is wrong with the pages you are seeing. $\endgroup$ Commented Sep 20, 2019 at 22:03

2 Answers 2

Reset to default
6
$\begingroup$ 
colors = {Magenta, Orange, Cyan, Red, Blue, Green, LightGray, Yellow, Black}; tooltips = {##2} -> Tooltip[{##2}, #] & @@@ mockdataWithNAICS; {dx, dy} = Round[Subdivide[##, 3]] & @@@ (Round[MinMax@#] & /@ Transpose[mockdataWithNAICS[[All, {2, 3}]]]);

You can use BinLists with {dx} and {dy} as horizontal and vertical bin delimiters to group the data into bins:

binlists = Join @@ BinLists[mockdataWithNAICS[[All, {2, 3}]], {dx}, { dy}];

and use a single ListPlot to plot all groups:

ListPlot[binlists /. tooltips, Frame -> True, PlotStyle -> colors, GridLines -> {dx, dy}, BaseStyle -> PointSize[Large], Axes -> False, AspectRatio -> 1, PlotRange -> {{-10, 710}, {-10, 710}}]

enter image description here

With a minor modification in tooltips, you can also use BubbleChart

tooltips2 = {##2} -> Tooltip[{##2, 1}, #] & @@@ mockdataWithNAICS; BubbleChart[binlists /. tooltips2, Frame -> True, ChartStyle -> colors, GridLines -> {dx, dy}, Axes -> False, BubbleSizes -> {.02, .02}, PlotRange -> {{-10, 710}, {-10, 710}}]

enter image description here

Update: An alternative way to bin the data using Nearest:

bincenters = Tuples[MovingAverage[#, 2] & /@ {dx, dy}]; nF = Nearest[bincenters]; binlists2 = GatherBy[mockdataWithNAICS[[All, {2, 3}]], nF];

Using binlists2 with ListPlot:

ListPlot[binlists2 /. tooltips, Frame -> True, GridLines -> {dx, dy}, BaseStyle -> PointSize[Large], PlotStyle -> colors, Axes -> False, AspectRatio -> 1, PlotRange -> {{-10, 710}, {-10, 710}}]

enter image description here

and with BubbleChart:

BubbleChart[binlists2 /. tooltips2, Frame -> True, GridLines -> {dx, dy}, Axes -> False, BubbleSizes -> {.02, .02}, ChartStyle -> colors, PlotRange -> {{-10, 710}, {-10, 710}}]

enter image description here

Improve this answer
$\endgroup$
2
  • $\begingroup$ Thank you @kglr; I accept your answer (and your update) ! I love the way how you were able to condense the whole process. You will be saving me a lot of work every month! I pressed the checkmark (which went from gray color to green). I think that it should be the other way around (from green to gray) but, the important thing is that it works (I hope). Thanks again! $\endgroup$ Commented Sep 23, 2019 at 13:05
  • $\begingroup$ Thank you @GilmarRodriguezPierluissi. Glad it was useful. $\endgroup$ Commented Sep 23, 2019 at 13:10
5
$\begingroup$

I believe this has the intended functionality, with simplified code.

minx = Round[Min[mockdataWithNAICS[[All, 2]]]]; maxx = Round[Max[mockdataWithNAICS[[All, 2]]]]; dx = Round[Subdivide[minx, maxx, 3]]; miny = Round[Min[mockdataWithNAICS[[All, 3]]]]; maxy = Round[Max[mockdataWithNAICS[[All, 3]]]]; dy = Round[Subdivide[miny, maxy, 3]]; gridpts = Tuples[{dx, dy}]; regions = { Rectangle[gridpts[[1]], gridpts[[6]]], Rectangle[gridpts[[5]], gridpts[[10]]], Rectangle[gridpts[[9]], gridpts[[14]]], Rectangle[gridpts[[2]], gridpts[[7]]], Rectangle[gridpts[[6]], gridpts[[11]]], Rectangle[gridpts[[10]], gridpts[[15]]], Rectangle[gridpts[[3]], gridpts[[8]]], Rectangle[gridpts[[7]], gridpts[[12]]], Rectangle[gridpts[[11]], gridpts[[16]]]}; (* Updated per GilmarRodriguezPierluissi's suggestion, to work with data sets that have empty regions *) pts = Cases[Table[Select[mockdataWithNAICS, #[[{2, 3}]] \[Element] r &], {r, regions}], Except[{}]]; colors = {Magenta, Orange, Cyan, Red, Blue, Green, LightGray, Yellow, Black}; ListPlot[Table[Tooltip[#[[{2, 3}]], #[[1]]] & /@ p, {p, pts}], Frame -> True, PlotStyle -> colors, GridLines -> {dx, dy}, PlotRange -> {{minx, maxx}, {miny, maxy}}, AspectRatio -> 1]

enter image description here

Improve this answer
$\endgroup$
5
  • $\begingroup$ Thank you @MelaGo for your valuable help! I wish I could accept you answer as well but, we are only allowed to accept one answer. Question; what software did you use to build the "gif movie", showing the Tooltip sweeping the points? Thanks again! $\endgroup$ Commented Sep 23, 2019 at 13:13
  • $\begingroup$ For other data sets containing points not as nicely distributed as my mock data set above; using: pts = Cases[ Table[Select[mockdataWithNAICS, #[[{2, 3}]] [Element] r &], {r, regions}], Except[{}]]; accounts for situations in which there are no points in a region. $\endgroup$ Commented Sep 23, 2019 at 17:31
  • $\begingroup$ @GilmarRodriguezPierluissi You're welcome. I used the free version of Active Presenter to screenshot a movie. I couldn't figure out how to directly make an animated gif, so I used mov=Import["file.avi","Animation"]; Export["file.gif",mov,"AnimationRepetitions"->Infinity] in Mathematica. Probably not the best solution... $\endgroup$ Commented Sep 23, 2019 at 18:01
  • $\begingroup$ @GilmarRodriguezPierluissi Good point about the empty regions - I will update the answer with your suggestion. $\endgroup$ Commented Sep 23, 2019 at 18:09
  • $\begingroup$ Thank you @MelaGo for your tip about the Active Presenter (i.e.; "gif maker") ! Also; I just posted the following follow up question for the Stack Exchange Forum via: mathematica.stackexchange.com/questions/206795/… $\endgroup$ Commented Sep 24, 2019 at 20:18

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.