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$
    – kglr
    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$
    – Gilmar Rodriguez Pierluissi
    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$
    – Gilmar Rodriguez Pierluissi
    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$
    – Gilmar Rodriguez Pierluissi
    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$
    – kglr
    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$
    – Gilmar Rodriguez Pierluissi
    Sep 23, 2019 at 13:05
  • $\begingroup$ Thank you @GilmarRodriguezPierluissi. Glad it was useful. $\endgroup$
    – kglr
    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$
    – Gilmar Rodriguez Pierluissi
    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$
    – Gilmar Rodriguez Pierluissi
    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$
    – MelaGo
    Sep 23, 2019 at 18:01
  • $\begingroup$ @GilmarRodriguezPierluissi Good point about the empty regions - I will update the answer with your suggestion. $\endgroup$
    – MelaGo
    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$
    – Gilmar Rodriguez Pierluissi
    Sep 24, 2019 at 20:18

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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