5
$\begingroup$

Let's say I have an association like the following.

asc=<|a->{p1,p2,p3,p4},b->{p1,p2},c->{p3,p4},d->{p3}|>

The association basically tells how each of the keys is covered using the patterns shown in the value. It also shows, given a pattern what all keys it can cover as well.

Question: How to get a minimum number of patterns that can cover all of the keys? In the above example, possible solutions are as follows.

{p3, p1} --> p3 covers a, c, d & p1 covers a, b [optimal solution]
{p4, p1, p3}
{p1, p2, p3}
.... 

This is what I've tried using RandomChoice,

DeleteDuplicates[Values@(RandomChoice[#, 1] & /@ asc)]

I have tried using Fold[] as well as follows.

choosePatterns[{{patAcc_, coveredVars_}, {patCurr_, possibleVars_}, 
   allvars_}] := Module[{currentVars, remainingVars},
  Print[{coveredVars, possibleVars, allvars}];
  currentVars = Union[coveredVars, possibleVars];
  If[Length@currentVars == Length@allvars,
   {Flatten[{patAcc, patCurr}], currentVars},
   {patAcc, coveredVars}
   ]
  ];

asc=<|a->{p1,p2,p3,p4},b->{p1,p2},c->{p3,p4},d->{p3}|>;
revasc = 
  GroupBy[Flatten[KeyValueMap[Thread[{#2, #1}] &, asc], 1], 
   First -> Last];
patLst = 
  List @@@ 
   Normal@GroupBy[Flatten[KeyValueMap[Thread[{#2, #1}] &, asc], 1], 
     First -> Last];
patLstSorted = SortBy[patLst, Length[Last[#]] &, Greater];
vars = Keys@asc;
FoldList[choosePatterns[{#1, #2, vars}] &, patLstSorted]

{{p3, {a, c, d}}, {p3, {a, c, d}}, {{p3, p2}, {a, b, c, d}}, {{p3, p2, p1}, {a, b, c, d}}}

As can be observed that p3 and p2 are enough to cover {a,b,c,d}

In the current implementation, what I have done is I've tried to groupby keys based on patterns and then sorted them based on their keys. Then I tried to Fold them to get the pattern sequence that satisfies the criteria.

I am not sure if my current implementation is optimal. Are there any other ways to implement this?

$\endgroup$
3
  • 1
    $\begingroup$ Isn't this the set cover problem? It is NP-complete, as is the integer linear programming solution below. ILP is likely to be as good solution as any for this task when number of keys is relatively low. For large number of keys or large universe to cover finding optimal solutions can easily become computationally infeasible. $\endgroup$
    – kirma
    Aug 23, 2023 at 17:07
  • 3
    $\begingroup$ related Q/A: Mathematica Function that returns minimal cover of a list S by given list of sublists $\endgroup$
    – kglr
    Aug 24, 2023 at 14:32
  • 1
    $\begingroup$ Thank you @kirma for this information. Haven't heard of it at all. Thanks for sharing this. $\endgroup$ Aug 25, 2023 at 15:21

1 Answer 1

7
$\begingroup$

The first thing that came to my mind was linear optimization:

Assuming:

asc = <|a -> {p1, p2, p3, p4}, b -> {p1, p2}, c -> {p3, p4}, 
   d -> {p3}|>;

We create a matrix that shows which patterns are included in each key:

Normal @ Last @
  CoefficientArrays[Plus @@@ Values[asc], Variables @ Values[asc]]

(* Out: {{1, 1, 1, 1}, {1, 1, 0, 0}, {0, 0, 1, 1}, {0, 0, 1, 0}} *)

Now we store the previous result in the matrix variable and use LinearOptimization to select the minimum number of patterns while covering all of them:

Block[{matrix},

 matrix = Last@CoefficientArrays[Plus @@@ Values[asc], Variables@Values[asc]];

 LinearOptimization[
  Total[v], {matrix . v \[VectorGreaterEqual] 1, 
   0 \[VectorLessEqual] v \[VectorLessEqual] 1}, 
  v \[Element] Vectors[Last@Dimensions[matrix], Integers]]
 ]

(* Out: {v -> {1, 0, 1, 0}} *)

It shows you only have to pick the first and third patterns.

* I used \[VectorLessEqual]/\[VectorGreaterEqual] which were introduced in version 12.

$\endgroup$
5
  • 3
    $\begingroup$ Here's shorter version for the first part d = Values[asc] // Map[Counts] // KeyUnion[#, 0 &] &; elements = Keys @ First @ d; temp = elements 0; matrix = Values @ d $\endgroup$
    – Kuba
    Aug 23, 2023 at 6:59
  • $\begingroup$ Thanks a lot for your detailed answer. Definitely will check the LinearOptimization[] function, it is great to know that it could be used for this. $\endgroup$ Aug 23, 2023 at 8:57
  • $\begingroup$ @AnjanKumar You're welcome. @Kuba ♦ thanks for the tip. Even better with Last@CoefficientArrays[Plus @@@ Values[asc], Variables@Values[asc]]. $\endgroup$
    – Ben Izd
    Aug 23, 2023 at 15:59
  • 2
    $\begingroup$ @BenIzd Problem: This works if Length@asc == Length@Variables@Values[asc], but fails in cases like asc = <|a->{p1,p2,p3,p4}, b->{p1,p2}, c->{p3,p4}|>. I suggest an easy fix by changing Vectors[Length[matrix], Integers] to Vectors[Last@Dimensions@matrix, Integers]. $\endgroup$
    – creidhne
    Aug 23, 2023 at 17:06
  • $\begingroup$ @creidhne Thanks for pointing that out. I appreciate it. $\endgroup$
    – Ben Izd
    Aug 24, 2023 at 9:53

Your Answer

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

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