Label or Callout the Index of a List or Array of Points using ListPointPlot3D

Question

I have found several examples of Callouts and Labels using Text command and/or mapping data to plotted points both in Mathematica documentation and through various forums including this one.

I am relatively new to Mathematica and do not quite understand how to adapt those examples to what I desire.

I am plotting Polytopes to better understand their symmetry and structure.

When I plot them though, sometimes I get confused on which vertices correspond to which faces.

I want to label the vertices with the index number from the vertices list (1,2,3..etc.,) so that when I construct the grouping for the faces to use with the Polygon function, I can easily troubleshoot/fix the faces based on the 3D Plot. That is I can visually see the labeled vertices around the faces and not have to consider which quadrants, etc., I am working in.

I did try the generic Labeling Function and while it shows the label of the points, it shows their values, not the index to them. The values help, but it is not as intuitive or as easy as mapping index numbers to faces. The points are also too cluttered to be useful.

Edit: it would also be useful to plot the index for the faces as well to make it even easier to troubleshoot.

Here is example code to illustrate what I am plotting. I want to move on to more complex Polytopes, but I want to figure this out first to save time and headaches later.

C0 = 1;
C1 = 2;
groupedVertices = {{{0, 0, C1}, {0, 0, -C1}, {C1, 0, 0}, {-C1, 0, 0}, {0, 
     C1, 0}, {0, -C1, 0}}, {{C0, C0, C0}, {C0, C0, -C0}, {C0, -C0, 
     C0}, {C0, -C0, -C0}, {-C0, C0, C0}, {-C0, C0, -C0}, {-C0, -C0, 
     C0}, {-C0, -C0, -C0}}};
vertices = Flatten[groupedVertices, 1];
faces = {{7, 1, 9, 3}, {7, 3, 8, 5}, {7, 5, 11, 1}, {10, 2, 8, 
    3}, {10, 3, 9, 6}, {10, 6, 14, 2}, {12, 2, 14, 4}, {12, 4, 11, 
    5}, {12, 5, 8, 2}, {13, 1, 11, 4}, {13, 4, 14, 6}, {13, 6, 9, 
    1}};
Show[
 ListPointPlot3D[groupedVertices, 
  PlotStyle -> {Directive[Red, PointSize[0.05]], 
    Directive[Blue, PointSize[0.05]]}, AxesLabel -> {x, y, z}],
 Graphics3D[
  Polygon[
   MapThread[
    Table[vertices[[(#1[[j]])]], {j, 1, 4}] &, {faces}]]], 
 BoxRatios -> Automatic]

Polytope Plot in 3D

Answer 1

Clear["Global`*"]

C0 = 1;
C1 = 2;

groupedVertices = {{{0, 0, C1}, {0, 0, -C1}, {C1, 0, 0}, {-C1, 0, 
     0}, {0, C1, 0}, {0, -C1, 0}}, {{C0, C0, C0}, {C0, 
     C0, -C0}, {C0, -C0, C0}, {C0, -C0, -C0}, {-C0, C0, C0}, {-C0, 
     C0, -C0}, {-C0, -C0, C0}, {-C0, -C0, -C0}}};

vertices = Flatten[groupedVertices, 1];

faces = {{7, 1, 9, 3}, {7, 3, 8, 5}, {7, 5, 11, 1}, {10, 2, 8, 
    3}, {10, 3, 9, 6}, {10, 6, 14, 2}, {12, 2, 14, 4}, {12, 4, 11, 
    5}, {12, 5, 8, 2}, {13, 1, 11, 4}, {13, 4, 14, 6}, {13, 6, 9, 1}};

rlGV = Range[Length[groupedVertices]];

lpp3d = ListPointPlot3D[
   Map[# -> Position[vertices, #][[1, 1]] &,
    groupedVertices, {2}],
   LabelingFunction -> Callout,
   PlotStyle -> (
     Directive[ColorData[97][#],
        PointSize[0.05]] & /@
      rlGV)];

Plotting, (EDIT: removed line of code that wasn't doing anything )

Manipulate[
 Legended[
  Show[
   lpp3d,
   Graphics3D[
    Table[
     Flatten[
      {If[MemberQ[selection, n],
        {EdgeForm[Thick], Lighter[Red, 0.25]},
        Nothing],
       Polygon[vertices[[faces[[n]]]]]}],
     {n, Range[Length[faces]]}]],
   AxesLabel -> {x, y, z},
   BoxRatios -> Automatic,
   ImageSize -> Medium],
  PointLegend[
   ColorData[97] /@ rlGV, rlGV,
   LegendLabel -> "Group"]],
 Row[{
   Control[{{selection, {1}, "highlight face"},
     Range[Length[faces]],
     ControlType -> TogglerBar}],
   Spacer[40],
   Button[Style["Clear All", 10], selection = {}]}],
 SynchronousUpdating -> False,
 TrackedSymbols :> {selection}]