I have a list of intervall.
Some of these intervals are disjoint, some are overlapped and some are included in others. To leave no ambiguity about my explanation, you can see the following examples:
{1, 2} and {3, 4} are disjointed.
{1, 3} and {2, 4} are overlaped.
{2,3} are included in {1,4}.
I would like to identify any intervals in a list that are completely included in others.
For example:
{2,3} are included in {1,4}
{2,4} are included in {1,4}
{1,3} are included in {1,4}
ect ..
Objectives
The goal is to get the list of positions of all intervals that are included in others in order to eliminate them. It's important to notice here that the list to study is always sorted.
Example of list :
ListT = {{1, 8}, {2, 8}, {3, 8}, {4, 8}, {5, 10}, {6, 10}, {7, 11}, {8, 14}};
I already write an algorithm that I find too slow. It is unnecessary to expose here. So I write the followings algorithm :
Supone[x_] := If[x > 1, True, False];
Tentative1[ListT] :=
Block[
{Step2T1, Step3T1, Step4T1, Step5T1, Step6T1,Res},
Step2T1 = Map[Interval[#] &, ListT];
Step3T1 = Table[
IntervalMemberQ[Step2T1[[i]], Step2T1[[j]]],
{i, 1, Length@Step2T1, 1},
{j, 1, Length@Step2T1, 1}
];
Step4T1 = DeleteCases[Step3T1, False, Infinity];
Step5T1 = Map[Count[#, True] &, Step4T1];
Step6T1 = Position[Step5T1, _?Supone];
Res = (Flatten@Step6T1) + 1
];
Tentative2[ListT_] :=
Block[
{Step2T2, Step3T2, Step4T2, Step5T2, Step6T2, Res},
Step2T2 = Map[Interval[#] &, ListT];
Step3T2 = Outer[IntervalMemberQ, Step2T2, Step2T2];
Step4T2 = DeleteCases[Step3T2, False, Infinity];
Step5T2 = Map[Count[#, True] &, Step4T2];
Step6T2 = Position[Step5T2, _?Supone];
Res = (Flatten@Step6T2) + 1;
];
Tentative3[ListT_] :=
Block[
{Step2T3, Step3T3, Step4T3, Step5T3, Step6T3,Res},
Step2T3 = Map[Interval[#] &, ListT];
Step3T3 = Intersection[Step2T3,IntervalIntersection @@@ Subsets[Step2T3, {2}]];
Step4T3 = Map[Position[Step2T3, #] &, Step3T3];
Res = Flatten@Step4T3
];
IMQ[x_, y_] :=
Block[
{Memo, Res},
If[
x[[1]] <= y[[1]],
If[x[[1]] <= y[[1]] && x[[2]] >= y[[2]], Memo = True, Memo = False];,
Memo = False;
];
Res = Memo
];
FBS =
Compile[
{{List, _Real, 2}, {Interv, _Real, 1}},
Module[
{i, j, st, end, xmin, xmax, Restr, Testlog},
xmin = Interv[[1]];
xmax = Interv[[-1]];
st = List[[All, 1]];
end = List[[All, 2]];
i = 1; While[end[[i]] < xmax, i++];
j = 1; While[end[[-j]] > xmax, j++];
Restr = List[[i ;; -j]];
Testlog = Count[Map[IMQ[#, Interv] &, Restr], True];
If[Testlog > 1, 1, -1]
],
Parallelization -> True,
"RuntimeOptions" -> "Speed"
];
Tentative4[ListT_] :=
Block[
{Step2T4, Step3T4, Step4T4, Step5T4, Step6T4, Res},
Step2T4 = ListT;
Step3T4 = Position[Map[FBS[Step2T4, #] &, Step2T4], 1];
Res = Flatten@Step3T4
];
Tentative5[ListT_] :=
Block[
{Step2T5, Step3T5, Step4T5, Step5T5, Step6T5, Res},
Step2T5 = ListT;
Step3T5 =
Module[
{a, b},
{a, b} =Transpose[Outer[Plus, -Step2T5, Step2T5, 1], {2,3,1}];
SparseArray[Total[UnitStep[a] UnitStep[-b]] -1]["AdjacencyLists"]
]
];
Tentative6[ListT_] :=
Block[
{Step2T6, Step3T6, Step4T6, Step5T6, Step6T6, Res},
Step2T6 = ListT;
Step3T6 = Pick[
Range@Length@Step2T6,
Map[MemberQ[Step2T6, {x_, y_} /; x <= #[[1]] && y >= #[[2]] && ! (x == #[[1]] && y == #[[2]])] &, Step2T6]
]
];
GIMQ[x_, y_] :=
Block[
{Memo, Res},
If[
x[[1]] <= y[[1]],
If[x[[1]] <= y[[1]] && x[[2]] >= y[[2]], Memo = True, Memo = False];,
If[y[[1]] <= x[[1]] && y[[2]] >= x[[2]], Memo = True, Memo = False];
];
Res = Memo
];
LIP[List_, i_] :=
Module[
{j, Res},
j = i - 1;
If[
j!= 0,
If[ GIMQ[List[[i]], List[[j]]] == True, Res = 1;, Res = -1;],
Res = -1;
];
Res
];
Tentative7[ListT] :=
Block[
{Step2T7, Step3T7, Step4T7, Step5T7, Step6T7, Res},
Step2T7 = ListT
Step3T7 = Position[Map[LIP[Step2T7, #] &, Range[1, Length@Step2T7, 1]], 1];
Res = Flatten@Step3T7
];
Tentative8[ListT] :=
Block[
{Step2T8, Step3T8, Step4T8, Step5T8, Step6T8, Res},
Step2T8 = ListT
Step3T8 = Pick[
Range[2,Length@Step2T8],
IntervalMemberQ@@@Partition[Interval/@Step28,2,1]
]
];
Timing
With : Length@List = 2000
Tentative1[List, Integer]
-> 10.15 seconds (Personal n°1)
Tentative2[List, Integer]
-> 6.46 seconds (Rasher's n°1)
Tentative3[List, Integer]
-> 3.34 seconds (Rasher's n°2)
Tentative4[List, Integer]
-> 5.42 seconds (Personal n°2)
Tentative5[List, Integer]
-> 7.72 seconds (Simon Woods n°1)
Tentative6[List, Integer]
-> 6,48 seconds (Rasher's n°3)
Tentative7[List, Integer]
-> 0.48 seconds (Personal n°3)
Tentative7[List, Integer]
-> 0.45 seconds (Simon Woods n°2)
Benchmark
For ListT = {{1, 8}, {2, 8}, {3, 8}, {4, 8}, {5, 10}, {6, 10}, {7, 11}, {8, 14}};
The result is : {2, 3, 4, 6}
So we can read this as : {2, 8}, {3, 8}, {4, 8} and {6, 10} are included in other intervals. Which ? We don't care... The objective is to obtain theirs positions.
The subject remains open. I'm interested in any solution that would be faster than the current one.
Additional questions:
- Is it possible to use Compile on LIP ? How ?
- What's the better ? use of Block or use of Module ?
Intersection[list, IntervalIntersection @@@ Subsets[list, {2}]]
might serve your needs. If you want a "True/False" table like your first example, something likeOuter[IntervalMemberQ, list, list]
should be quite quick. $\endgroup$ListT
and check that the posted code actually generates that result. $\endgroup$