4
$\begingroup$

1. Description of Pathway

1.1 Preliminary Definitions

Let $A=[-2,2]^2$, where $\text{Area}(A)=16$ and $\lceil \cdot\rceil$ is the ceiling function.

For $\varepsilon\in\mathbb{R}$, let $\left\{U_i\right\}_{i=1}^{\lceil 16/\varepsilon\rceil}$ be a sequence of pair-wise disjoint sets covering $A$, where for all $i\in\mathbb{N}$, each $\text{Area}(U_i)$ should equal constant $\varepsilon$, such that the difference between the total sum of all $\text{Area}(U_i)$ and $\text{Area}(A)$ is minimized. Furthermore, take point $s_i\in U_i$ where set $\mathcal{S}=\left\{s_i:i\in\mathbb{N},1\le i\le \lceil 16/\varepsilon \rceil\right\}$ is a sample of points.

1.2 Description of Pathway

Suppose we want a "pathway" of line segments between all points in each sample such that if $d(Q,R)$ is the Euclidean-distance between points $Q$ and $R$, we:

  1. Take a point $x_0$ from $\mathcal{S}$
  2. Take a point from $\mathcal{S}$ with smallest euclidean distance from point $x_0\in\mathcal{S}$. The point is denoted $x_1$, where we take $d(x_0,x_1)$. (If more than one point has the smallest Euclidean distance from $x_0$, take either point).
  3. Take a point in $\mathcal{S}$ (excluding $x_0$) with smallest euclidean distance from $x_1$. The point is denoted $x_2$, where we take $d(x_1,x_2)$. (If more than one point has the smallest Euclidean distance from $x_1$, we take either point).
  4. Take a point in $\mathcal{S}$ (excluding $x_0$ and $x_1$) with smallest euclidean distance from $x_2$. The point is denoted $x_3$ then take $d(x_2,x_3)$. (If more than one point has the smallest Euclidean distance from $x_2$, we take either point).
  5. Repeat the process excluding points $x_0,x_1,x_2,x_3,$ etc. until all points in the sample are "denoted". (This should occur $\lceil 16/\varepsilon \rceil -1$ times.)
  6. Take the largest subset of $i$-values, such that $x_{i}$ has the $r_{i}$-th smallest Euclidean distance from $x_{i-1}$ (compared to points in $\mathcal{S}\setminus\left\{x_i\right\}$) such that $r_i$ is not an outlier in: $$\left\{r_t: t\in\mathbb{N}, 1\le t\le \lceil 16/\varepsilon \rceil -1\right\}$$

2. Attempt

Throughout the attempt consider the following questions:

Question: Is there a faster code for displaying sec. 1.1 and 1.2? If not, how do we improve the attempts of sec. 2.1 and 2.2?

2.1: First Part of Attempt

Below is the attempt to code the description.

We'll start with first half:

Clear["Global`*"]
A = Rectangle[{-2, -2}, {2, 2}]; (* Set A, i.e. [-2,2]x[-2,2] *)
U = DiscretizeRegion[A, 
  MaxCellMeasure -> {"Area" -> 
     1.5}]; (* Makes the area of all disjoint sets "nearly equal" .1 *)
S = AnnotationValue[{U, 2}, 
  MeshCellCentroid] (* A list of points from each disjoint set in U *)
Show[U, Graphics[{EdgeForm[{Thick, Blue}], FaceForm[], 
   Rectangle[{-2, -2}, {2, 2}]}], 
 Graphics[{Red, Point[S]}]] (*Illustration of the code above *)

enter image description here

Below are the following issues:

  1. The triangles don't have equal area
  2. The only shapes that I know for DiscretizeRegion are triangles. (I want arbitrary shapes, e.g. squares and rectangles, which cover $A=[-2,2]^2$). The arbitrary shapes (i.e., $\left\{U_i\right\}_{i=1}^{\lceil 16/\varepsilon \rceil}$ in sec. 1.1) may "over-cover" $A$ as long as the total area of the shapes is minimized.
  3. I'm unable to choose a random point in each of the triangles. The best I could do was take the centroids. (This was resolved with @Syed's comment).

2.2: Second Part of Attempt

Below is the second half of the code. We attempt to define a pathway for a given $\mathcal{S}$ (sec. 1.1)

(* Note we created a table so the q-variable (in the table) can 
   vary from q=1 to Length[S] *)
 T = Table[{
   X[1, q] = S[[q]], (*Here X1=x0=S[[q]], the q-
   th point of the sample in the first half of code *)
   Y[1, q] = DeleteCases[S, X[1, q]], (*Deletes X1=
   x0 from the sample S in sec. 1.1*)
   X[x_, q] := Nearest[Y[x - 1, q], X[x - 1, q], 1][[1]],         
   (* Takes X2=x1, X3=x2, X4=x3,... in sec. 1.2 *)
   Y[x_, q] := DeleteCases[Y[x - 1, q], X[x, q]], (* Deletes X1=x0, 
   X2=x1, X3=x2,... from the sample S *)
   P[q] = Table[X[x, q], {x, 1, Length[S]}], (* 
   List of all points in the inital pathway of points in X *)
   r[i_, q] := 
    Flatten[Position[Nearest[S, P[q][[i]], Length[S]], 
      P[q][[i + 1]]]], (* Lists value r_i  where P[[
   i+1]] is the r_i th smallest value from P[[i]],
   see sec. 1.2 crit. 6 *)
   ListofAllr[q] = 
    Flatten[Table[r[i, q], {i, 1, Length[S] - 1}]], (* 
   List of r[i] in sec. 1.2, crit. 6 for all i *)
   IndexofNonOutliers[q] = 
    Flatten[Position[ListofAllr[q], 
      Alternatives @@ DeleteAnomalies[ListofAllr[q]]]], (* 
   Lists Index of non-outliers in the list of r[i] *)
   D1[q] = Table[P[q][[x]], Evaluate[{x, IndexofNonOutliers[q]}]], 
   (*Excludes integer i where r_i are outliers *)
   arrow[coord_, e_] := 
    Piecewise[{{Style[Arrow[coord], Red, Thickness[.01], 
        Arrowheads[0.06]], 
       Boole[MemberQ[N /@ D1[q], First@coord]] == 0}, {Style[
        Arrow[coord], Black, Thickness[.01], Arrowheads[0.06]], 
       Boole[MemberQ[N /@ D1[q], First@coord]] == 
        1}}], (*Labels direction of pathway*)
   Edge[q] = 
    PathGraph[Range[Length[P[q]]], VertexCoordinates -> P[q], 
     EdgeShapeFunction -> arrow, ImageSize -> 300, 
     PlotRangePadding -> .2, 
     VertexLabels -> 
      Table[i -> Subscript[x, i - 1], {i, Length[P[q]]}]],
   (* 'Edge' Illustrates Pathway {x_i} (sec. 1.2). 
   Blue represents the segments we want to keep. 
   Red represents the segments we wish to discard. *)
    Show[U, 
    Graphics[{EdgeForm[{Thick, Blue}], FaceForm[], 
      Rectangle[{-2, -2}, {2, 2}]}], Graphics[{Red, Point[S]}], 
    Edge[q]],
   (* 'Show' graphs parititions, samples, 
   and the "pathway" of every point in the sample, starting with 
   x0=X1=S[[q]] *)
   DistanceD1[q] = 
    Table[EuclideanDistance[P[q][[x]], P[q][[x + 1]]], 
     Evaluate[{x, IndexofNonOutliers[q]}]]}, 
  (*Takes the length of all segments 
    in the pathway whose start-points have index i where r[i] is
    not an outlier 'Listofallr'*)
  , {q, 1, Length[S]}]; (* Table ends *)
GraphofAllPathways = 
 Table[T[[r, Length[T[[1]]] - 1]], {r, 1, 
   Length[S]}] (* Takes the graph of all Pathways in S *)
DD[r_] := 
 T[[r, Length[
    T[[1]]]]] (* Applying 'DistanceD1' or d (sec. 1.2) for 
   q=1,2,...,Length[S] *)

(*Ignore the remaining code below*)
PD[r_] :=  DD[r]/Total[DD[r]]; (* We convert length of line 
segments in 'GraphofD1'(i.e., 'DistanceD1') into a probability 
distribution whose elements sum to 1. *)
Entrop = Table[-N[Total[PD[r] Log[2, PD[r]]]], {r, 1, Length[S]}] 
(*Entropy of Pathway*)
GraphofAllPathways[[Flatten[ Position[Entrop, Max[Entrop]]]]] 
(*Takes "pathways" with the highest entropy*)

Here is an example of an output:

enter image description here

However, there are two problems:

  1. From the first half of the code (i.e., DiscretizeRegion) if the "Area" is approx. less than 1.73, the code takes too long to end. Infact, in the second half of the code, for timing purposes; we set the "Area" to 2.

  2. I want to repeat the code Length[S] number of times (creating a second variable, i.e. replace the 6 of S[[6]] with q=[1,…,Length[S]]). I was unable to complete this, which I believe is due to recurrence relations X and Y (This was resolved using Table; however, the former adds extra time to the computation.)

Edit: I managed to fix the simplified version of the code (which is now deleted) with this version.

Question (Reasked): Is there a faster code for displaying sec. 1.1 and 1.2? If not, how do we improve the attempts of sec. 2.1 and 2.2?

$\endgroup$
4
  • $\begingroup$ rpts = RandomPoint /@ MeshPrimitives[U, 2]; and Show[U, Graphics[{EdgeForm[{Thick, Blue}], FaceForm[], Rectangle[{-2, -2}, {2, 2}]}], Graphics[{Red, Point[rpts]}]] to generate random points inside all polygons. $\endgroup$
    – Syed
    Commented Aug 17, 2023 at 12:56
  • $\begingroup$ @Syed Thanks. How do we cover A with arbitrary shapes of the same area, such that if the arbitrary shapes "over-cover" A, the total area of all the shapes is minimized. $\endgroup$
    – Arbuja
    Commented Aug 17, 2023 at 16:21
  • $\begingroup$ I don't know, but you ask a separate question to cover that part only. I am happy to see that you are making progress. $\endgroup$
    – Syed
    Commented Aug 17, 2023 at 19:34
  • $\begingroup$ See this question, if it's easier to answer. $\endgroup$
    – Arbuja
    Commented Aug 17, 2023 at 23:58

0

Your Answer

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