# Find shortest subsequence

We will deal with arrays of chars, but not strings! Let we have the next three arrays:

{"c", "o", "m", "b", "i", "n", "a", "t", "i", "o", "n"},
{"i", "n", "t", "e", "r", "n", "a", "t", "i", "o", "n", "a", "l"},
{"n", "o", "t", "a", "t", "i", "o", "n"}


and the target array

target = {"n", "a", "t", "i", "o", "n"}


I need to find shortest occurrence (and position) of target in every array as a sequence, maybe alternate with other chars. The next pattern is created:

pat = Riffle[ target,  ___ ]


It works well for the first and the last arrays:

SequencePosition[{"c", "o", "m", "b", "i", "n", "a", "t", "i", "o", "n"}, pat] → {{6,11}}
SequencePosition[{"n", "o", "t", "a", "t", "i", "o", "n"}, pat] → {{1, 8}}


But for the second array two occurrences are found:

SequencePosition[{"i", "n", "t", "e", "r", "n", "a", "t", "i", "o", "n", "a", "l"}, pat] → {{2, 11}, {6, 11}}


Manually I can select the last as shortest, but it's not possible in a real task.
So I tried this:

pat2 = Riffle[str, Shortest@x___ ]


It works good for the second:

SequencePosition[{"i", "n", "t", "e", "r", "n", "a", "t", "i", "o", "n", "a", "l"}, pat2] → {{6, 11}}


but not work at all for the last:

SequencePosition[{"n", "o", "t", "a", "t", "i", "o", "n"}, pat2] → {}


So i'm very confused

• Have you looked at SequenceAlignment? E.g., SequenceAlignment[Characters @ "notation", Characters @ "nation"] Commented Jun 14, 2023 at 17:37
• maybe ssp = First@*MaximalBy[Apply@Subtract]@*SequencePosition used as ssp[list1, pat]?
– kglr
Commented Jun 14, 2023 at 17:58
• btw, pat2 says letters of target are separated by the same sub-pattern.
– kglr
Commented Jun 14, 2023 at 18:02
• @kglr, yes, thank you, x___ is bad idea! Commented Jun 14, 2023 at 18:04
• @CarlWoll, to my shame I didn’t know SequenceAlignment Now try it Commented Jun 14, 2023 at 18:06

### SequencePosition

ClearAll[shortestSequencePosition]

shortestSequencePosition = First @* MinimalBy[Differences] @* SequencePosition;


Examples:

{l1, l2, l3, l4, l5} = Characters @
{"combination", "international","notation",
"internationaln" <> StringJoin[ConstantArray["x", 100]] <> "ational",
"intern" <> StringJoin[ConstantArray["x", 100]] <> "ationalnational"};

pat = Riffle[{"n", "a", "t", "i", "o", "n"}, ___];

shortestSequencePosition[#, pat, Overlaps -> All] & /@ {l1, l2, l3, l4, l5}

{{6, 11}, {6, 11}, {1, 8}, {6, 11}, {114, 119}}


### ReplaceList

shortestSeqPos = First @ ReplaceList[#,
{a___,  b : Shortest[PatternSequence @@ #2], ___} :>
{1 + Length[{a}], Length@{a, b}}, 1] &;


Examples:

shortestSeqPos[#, pat] & /@ {l1, l2, l3, l4, l5}

 {{6, 11}, {6, 11}, {1, 8}, {6, 11}, {114, 119}}

• Consider shortestSequencePosition = Last @* SequencePosition;? Commented Jun 15, 2023 at 9:36
• @creidhne, that does not give the correct answer for cases like l4 = Characters[ "internationaln" <> StringJoin[ConstantArray["x", 20]] <> "ational"]
– kglr
Commented Jun 15, 2023 at 10:06
• I was about to remark that shortestSequencePosition[#, pat]& /@ {l4} == {Last[SequencePosition[l4, pat]]}, before your Overlaps revision. Good test case. Commented Jun 15, 2023 at 11:18
• @kglr Thank you! But I wonder is it possible to use LongestCommonSequencePositions? Commented Jun 16, 2023 at 16:48

Here is a bit of a hack. We may calculate the length of the matched pieces by:

Subtract @@@ (t = SequencePosition[data, pat])


where data is the character list and pat the pattern from above. Note we stored the differences, for later use, in t. Now we can get the order of the length and take the index of the shortest by:

Ordering[t][[-1]]


Finally, we may use the this index to get the shortest:

Subtract @@@ (t = SequencePosition[data, pat])[[Ordering[t][[-1]]]]


With this:

d1 = {"c", "o", "m", "b", "i", "n", "a", "t", "i", "o", "n"};
d2 = {"i", "n", "t", "e", "r", "n", "a", "t", "i", "o", "n", "a", "l"};
d3 = {"n", "o", "t", "a", "t", "i", "o", "n"};
target = {"n", "a", "t", "i", "o", "n"};
pat = Riffle[target, ___];

Subtract @@@ (t = SequencePosition[d1, pat])[[Ordering[t][[-1]]]]
Subtract @@@ (t = SequencePosition[d2, pat])[[Ordering[t][[-1]]]]
Subtract @@@ (t = SequencePosition[d3, pat])[[Ordering[t][[-1]]]]

{6, 11}
{6, 11}
{1, 8}


Edit

In a comment, kglr suggested an important test case. His improved solution adds the Overlaps -> All to SequencePosition. The Overlaps option is necessary to include overlapping ranges; the change means we can't rely on the last SequencePosition result to be the shortest. I've added the test case and implemented kglr's revised solution.

First, set target and pat from your question. Next, create a regular expression pattern from the target characters. Use regex to get a list of words that we can use for testing.

target = Characters["nation"];
pat = Riffle[target, ___];

regex = RegularExpression[StringRiffle[target, {"^.*", ".*", ".*\$"}]];
words = DeleteDuplicates[ToLowerCase[DictionaryLookup[regex, IgnoreCase -> True]]];


Problem:

1. When there is no matching pattern of characters in a sequence, SequencePosition returns an empty list.
2. Some sequences match pat in more than one range of positions. We want the shortest range, e.g., we want to select {6, 11} and reject {2, 11}.

Sequences like noNationMatch cause a problem when we try to find the shortest character range.

noNationMatch = Characters["regurgitation"];
SequencePosition[noNationMatch, pat]
(* {} *)


I suggest that pat is an efficient way to match character ranges, but we first must eliminate sequences with no possibility for a match. For example, consider these test cases. Use regex to reject "regurgitation". We'll use the list of sequences seq to check each sequence in a table.

testCases = {"regurgitation", "combination", "international", "notation",
"tintinnabulation", "interdenominational",
"internationalnxxxxxxxxxxational"};
Column[seq = Characters/@Select[seqList, StringMatchQ[regex]]]

{"c","o","m","b","i","n","a","t","i","o","n"},
{"i","n","t","e","r","n","a","t","i","o","n","a","l"},
{"n","o","t","a","t","i","o","n"},
{"t","i","n","t","i","n","n","a","b","u","l","a","t","i","o","n"},
{"i","n","t","e","r","d","e","n","o","m","i","n","a","t","i","o","n","a","l"},
{"i","n","t","e","r","n","a","t","i","o","n","a","l","n","x","x","x","x","x","x","x","x","x","x","a","t","i","o","n","a","l"}


These are the ranges we find by matching pat with SequencePosition.

Table[
DeleteDuplicates[SequencePosition[s, pat, Overlaps -> All]],
{s, seq}]//Column

{{6,11}},
{{2,11}, {6,11}},
{{1,8}},
{{3,16}, {6,16}, {7,16}},
{{2,17}, {8,17}, {12,17}},
{{2,29}, {2,14}, {2,11}, {6,29}, {6,14}, {6,11}, {11,29}, {14,29}}


Find the shortest of the ranges.

Table[
First[MinimalBy[SequencePosition[s, pat, Overlaps -> All], Differences]],
{s, seq}]

{{6,11}, {6,11}, {1,8}, {7,16}, {12,17}, {6,11}}


Let's make a way to illustrate the ranges we find. Each result shows the range of characters, the sequence of matching characters, and the highlighted characters in the sequence we tested. We can verify that we've matched the shortest range of characters.

Clear[highlight];
SetAttributes[highlight, HoldAll];
highlight[pattern_, style_] :=
s_String :> (Row[{##}]&@@StringReplace[s, t:pattern :> style[t]])

TableForm[Table[{
p = First@MinimalBy[SequencePosition[s, pat, Overlaps -> All], Differences],
StringJoin@Take[s, p],
StringJoin[s] /. highlight[StringJoin@Take[s, p], Style[#, Red] &]},
{s, seq}], TableDepth -> 2]


Testing

Make sequences from words that match 2 or more ranges.

mp = Cases[words, w_ /; Length[SequencePosition[Characters[w], pat]] >= 2];
seq = Characters/@mp;
TableForm[Table[{
p = First@MinimalBy[SequencePosition[s, pat, Overlaps -> All], Differences],
StringJoin@Take[s, p],
StringJoin[s] /. highlight[StringJoin@Take[s, p], Style[#, Red] &]},
{s, seq}], TableDepth -> 2]


Make sequences from a sample of words that match exactly one range.

SeedRandom[123];
sp = Sort@RandomSample[
Cases[words, w_ /; Length[SequencePosition[Characters[w], pat]] == 1], 50];
seq = Characters/@sp;
TableForm[Table[{
p = First@MinimalBy[SequencePosition[s, pat, Overlaps -> All], Differences],
StringJoin@Take[s, p],
StringJoin[s] /. highlight[StringJoin@Take[s, p], Style[#, Red] &]},
{s, seq}], TableDepth -> 2]


a = {"c", "o", "m", "b", "i", "n", "a", "t", "i", "o", "n"};

b = {"i", "n", "t", "e", "r", "n", "a", "t", "i", "o", "n", "a", "l"};

c = {"n", "o", "t", "a", "t", "i", "o", "n"};

target = {"n", "a", "t", "i", "o", "n"};

pattern = Riffle[target, ___]


{"n", ___, "a", ___, "t", ___, "i", ___, "o", ___, "n"}

SequencePosition only uses pattern if target has failed

First @ SequencePosition[#, target | pattern] & /@ {a, b, c}


{{6, 11}, {6, 11}, {1, 8}}

It also works with the more complicated data of kglr