4
$\begingroup$

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

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

3 Answers 3

6
$\begingroup$

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

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}
$\endgroup$
3
$\begingroup$

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]

matching sequences

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]

matching sequences for multiple ranges

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]

sequences with one range

$\endgroup$

Your Answer

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

Not the answer you're looking for? Browse other questions tagged or ask your own question.