Highlighting or coloring certain words / substrings appearing in a larger string

Question

I have one longer string, longString, and a set $S$ of shorter strings {ss1,ss2,ss3,...}. I'd like to print out longString but where the positions of the shorter strings are indicated in some nice way. For example, perhaps we could color the characters in the longer string with a specific specified color for each shorter string. I.e. where would would have an array like {{ss1,'Red'},{ss2,'Green'},{ss3,'Blue'},...} and would then color words appearing in longString Red if the word is ss1, Blue if the word is ss2, and so forth. The idea would be to shade Brown / etc. overlap regions if they occur.

Is this possible?

One can use StringPosition to return the first and last character position for a set of substrings or words appearing in a larger string, for example:

StringPosition["TheBrownFox", {"Brown","Fox"}]

out: {{4, 8}, {9, 11}}

Now, one of the more interesting parts of this question, IMO, is how we handle overlaps between substrings / words (i.e. ss1, ss2, ss3, etc.). For example, if we add the nonsense word "wnFo" to the previous example, we have overlapping words:

testString = TheBrownFox;
StringPosition[testString, {"Brown","Fox","wnFo"}]

out: {{4, 8}, {7, 10}, {9, 11}}

So we need to do a kind of "surgery" on the output list for StringPosition s.t. there is never a situation where we have {..., {integerOne, intTwo}, {intThree, intFour}, ...} where it is NOT the case that intOne < intTwo < intThree < intFour.

Update: Please see Kuba's very slick answer to my question concerning how one might do this: Identifying and isolating sections of overlap in a set of integer intervals

---

I am inspired by this example https://reference.wolfram.com/mathematica/example/HighlightWordsOfAGivenLength.html where words of a certain length are highlighted and bolded.

Answer 1

Using the code for mark, from linked question:

f[string_, cases_] := Module[{pos, agg, res},

   pos = StringPosition[string, cases];

   agg = {Switch[#[[ 1, 2]], 1, Blue, 2, Brown, _, Red], 
          #[[ ;; , {1}]]
         } & /@ GatherBy[Tally@Flatten[Range @@@ pos], Last];

   mark[string, agg]
 ]

f["TheBrownFox", {"TheBrown", "BrownFox"}]
f["TheBrownFox", {"The", "Fox"}]    
f["TheBrownFox", {"The", "eBrownF", "eBrownFox"}]

Detecting overlaps is based on my code from Identifying sections of overlaps in a set of integer intervals

Answer 2

Here is another way to achieve what you want. It is neither very elegant nor very efficient, but should do what I think you try to achieve:

highlight[text_String, rules_List] := 
 Module[{positions, overlap = Underlined},

  positions = SortBy[
     Flatten[Thread[StringPosition[text, #1] -> #2] & @@@ rules, 1], 
     First
  ];

  positions = positions //. {
     {h___, {s1_, e1_} -> c1_, {s2_, e2_} -> c2_, t___} /; 
       s2 <= e1 :> {
       h,
       {s1, Min[e1, s2] - 1} -> c1,
       {Min[e1, s2], Max[e1, s2]} -> overlap,
       If[e2 >= Max[e1, s2]+1, {Max[e1, s2]+1, e2} -> c2,Unevaluated[Sequence[]]],
       t
       }
     };

  StringReplacePart[text,
    ToString[Style[StringTake[text, #1], #2], StandardForm] & @@@ positions,
    positions[[All, 1]]
  ]
];

highlight[
  "The brown, brown fox with overlapping matches...", 
  {"brown" -> Brown, "fox" -> Red, "app" -> Gray, "lap" -> Orange, "erlapp" -> Green}
 ]

The "difficult" part with the overlapping strings I tried to solve with a potentially inefficient pattern matching construct in a ReplaceRepeated (//.). Overlaps are unerlined in the above code but you could of course change that. If efficiency does matter or my approach turns out too be to naive you could try to combine my function with a smarter way to handle these overlaps...