Lazy Witness

This Mathematica demonstration, created by Henry Adams and Jan Segert, computes and displays lazy witness simplicial complexes.

To run this code, you need to click “Enable Dynamics” or select the menu option ”Evaluation -> Dynamic Updating Enabled”. Click and drag on the “filtration parameter” toggle to change the ball size. You can drag a vertex to a different spot in the plane using your mouse. Hold command and click on an empty spot to add a new vertex; hold command and click on a vertex to remove that vertex.

InitialRadii[distanceMatrix_,nu_]:=
Piecewise[{{ConstantArray[0,Dimensions[distanceMatrix][[2]]],nu==0}},Table[Sort[distanceMatrix[[All,i]]][[nu]],{i,Dimensions[distanceMatrix][[2]]}]]

EdgeMatrix[distanceMatrix_,initialRadii_]:=
Module[{n,m,i,j,edgeMatrix,highlightMatrix},
n=Dimensions[distanceMatrix][[1]];
m=Dimensions[distanceMatrix][[2]];
edgeMatrix = ConstantArray[0,{n,n}];
highlightMatrix = ConstantArray[0,{n,n}];
For[i=1, i≤n, i=i+1,For[j=i+1, j≤n, j=j+1,
edgeMatrix[[i,j]]=Min[Table[Max[{distanceMatrix[[i,k]],distanceMatrix[[j,k]]}- initialRadii[[k]]],{k,m}]];highlightMatrix[[i,j]]=Nearest[Table[Max[{distanceMatrix[[i,k]],distanceMatrix[[j,k]]}- initialRadii[[k]]],{k,m}]->Automatic,0];];];Return[{edgeMatrix,highlightMatrix}];]

DrawBalls[data_,initialRadii_,t_]:=Table[{Hue[0.55,.5,.95,.4],Disk[data[[i]],initialRadii[[i]]+t]},{i,Length[data]}]

DrawHighlights[data_,initialRadii_,edgeMatrix_,highlightMatrix_,t_]:=Union[Flatten[Table[If[0≤edgeMatrix[[i,j]]-t≤0.05,Union[Table[{Hue[0.6],Circle[data[[highlightMatrix[[i,j]][[k]]]],initialRadii[[highlightMatrix[[i,j]][[k]]]]+t]},{k,Length[highlightMatrix[[i,j]]]}]],{}],{i,Length[edgeMatrix]},{j,i+1,Length[edgeMatrix]} ],1]]

DrawOneSimplices[landmarks_,edgeMatrix_,t_]:=Union[Flatten[Table[ If[i<j && edgeMatrix[[i,j]]≤ t,Line[{landmarks[[i]],landmarks[[j]]}],{}],{i,Length[landmarks]},{j,i+1,Length[landmarks]}]]]

DrawTwoSimplices[landmarks_,edgeMatrix_,t_]:=Union[Flatten[Table[ If[edgeMatrix[[i,j]]≤t &&edgeMatrix[[j,k]]≤t &&edgeMatrix[[i,k]]≤t,{Hue[1,.9,.6,.3],EdgeForm[Black],Polygon[{landmarks[[i]],landmarks[[j]],landmarks[[k]]}] },{}],{i,Length[landmarks]},{j,i+1,Length[landmarks]}, {k,j+1,Length[landmarks]}],2]]

DrawData[showIndices_,data_,landmarks_]:=
If[showIndices,
Join[Table[Disk[landmarks[[i]],0.04],{i,Length[landmarks]}],Table[{Hue[0.36,1,0.7],Disk[Complement[data,landmarks][[i]],0.04]},{i,Length[Complement[data,landmarks]]}],
Table[{Hue[0,0],Text[i,data[[i]]]},{i,Length[data]}]],
Join[Table[Disk[landmarks[[i]],0.02],{i,Length[landmarks]}],Table[{Hue[0.36,1,0.7],Disk[Complement[data,landmarks][[i]],0.02]},{i,Length[Complement[data,landmarks]]}]]
]

SequentialMaxmin[numLandmarks_,data_]:=
Module[{distanceBound,landmarkListOld,notList,k},
distanceBound=Max[Table[EuclideanDistance[data[[i]],data[[j]]],{i,Length[data]},{j, Length[data]}]];
landmarkListOld={1};
notList=Complement[Table[i,{i,Length[data]}],landmarkListOld];
For[k=2,k≤numLandmarks,k=k+1,
Module[{index},
index=Nearest[Table[Norm[Nearest[data[[landmarkListOld]],data[[notList[[i]]]]][[1]]-data[[notList[[i]]]]],{i,Length[notList]}]->Automatic,distanceBound];
landmarkListOld=Join[landmarkListOld,notList[[index]]];
notList=Complement[notList,notList[[index]]]];];
Return[landmarkListOld];]

Manipulate[
Which[
numSeqMaxMin≠0,
	landmarkList=SequentialMaxmin[numSeqMaxMin,data];
	numSeqMaxMin=0,
Length[landmarkList]<2||Length[landmarkList]>10,
	landmarkList=landmarkListOld,
Length[data]<Length[dataOld],
	index=Position[dataOld,Complement[dataOld,data][[1]]][[1]][[1]];
	If[Length[landmarkList]==2&&MemberQ[landmarkList,index],data=dataOld,
		landmarkList=Complement[landmarkList,{index}];
		For[k=1,k≤Length[landmarkList],k=k+1;If[landmarkList[[k]]>index,landmarkList[[k]]=landmarkList[[k]]-1]]]
];
landmarkListOld=landmarkList;
dataOld=data;
Module[{landmarks,initialRadii,distanceMatrix,edgeMatrix,highlightMatrix},
landmarks=data[[landmarkList]];
distanceMatrix=Table[EuclideanDistance[landmarks[[i]],data[[j]]],{i,Length[landmarks]},{j, Length[data]}];
initialRadii=InitialRadii[distanceMatrix, nu];
{edgeMatrix,highlightMatrix}=EdgeMatrix[distanceMatrix, initialRadii];
Graphics[{
	If[showBalls,DrawBalls[data,initialRadii,t],{}],
	If[showHighlights,DrawHighlights[data,initialRadii,edgeMatrix,highlightMatrix,t],{}],
	DrawTwoSimplices[landmarks,edgeMatrix,t],
	DrawOneSimplices[landmarks,edgeMatrix,t],
	DrawData[showIndices,data,landmarks]},
	PlotRange->{{-1,1},{-1,1}},PlotRangeClipping->True,
	ImageSize->{800,500}]
],
Delimiter,Style["Lazy witness complex",12,Bold],
{{nu,0},{0,1,2}},
{{t,0.54,"Filtration parameter"},0,1},
Delimiter,Style["Landmark selection",12,Bold],
{{showIndices,True,"Show landmark indices"},{True,False}},
{{landmarkList,Null,"Manual selection"},Table[i,{i,Length[data]}],ControlType->TogglerBar},
{{numSeqMaxMin,5,"Using sequential maxmin, pick"},Table[i,{i,2,Min[10,Length[data]]}],ControlType->PopupMenu},
"landmarks, with seed index 1",
Delimiter,Style["Appearance",12,Bold],
{{showBalls,True,"Draw balls"},{True,False}},
{{showHighlights,False,"Highlight active balls"},{True,False},ControlPlacement->Top},
{{data,{{-0.31,-0.22},{0.30,0.21},{0.42,0.08},{0.18,0.59},{-0.60,-0.13},{-0.59,0.31},{-0.06,0.53},{-0.36,0.50},{-0.44,0.03},{0.01,-0.26},{0.48,0.30}}},Locator, LocatorAutoCreate->{All,{2,20}},Appearance->None},
Initialization->(dataOld={{-0.31,-0.22},{0.30,0.21},{0.42,0.08},{0.18,0.59},{-0.60,-0.13},{-0.59,0.31},{-0.06,0.53},{-0.36,0.50},{-0.44,0.03},{0.01,-0.26},{0.48,0.30}}),
SaveDefinitions->True]

To cite this demo:
@software{FiltrationDemos,
  author = {Adams, Henry and Segert, Jan},
  title = {Simplicial complex filtration demonstrations in {M}athematica},
  url = {https://www.math.colostate.edu/~adams/research/},
  date = {2011},
}