# Function that returns minimal cover of a list S by given list of sublists

Given a list S and a list of sublists L = { SL[1], SL[2], ... , SL[n] } of which I know that they cover S, i.e. for each element in S there is at least one sublist that contains that element. I'm looking for a way to efficiently create a minimal cover for S by elements of L. The way this cover is represented doesn't really matter. The problem sizes I have in mind are have Length[L] about 100000, Length[SL[i]] about 10 Length[S] about 5000.

Background

I'm interested in applying such functionality to situations where

• E is a list of equations
• S a list of variables

and I'm searching for a smallest set of equations for which each variable in S is present. The list of equations is often very long, but this way, I could have a small subset that contains all the variables in S. (of course, I would have to map each equation to its list of variables first to link this problem to the above).

Update 2: Adding an optional third argument specifying target variables and embellishing the output with additional properties (code below):

varCover[equations]["Properties"]

{"Solution", "CoverIndices", "Cover", "VariablesInCover",
"Cost", "HighlightedExpressions", "Input", "Expressions", "Weights",
"TargetVariables", "Variables", "CoverageMatrix",
"HighlightedCoverageMatrix", "RelationGraph",
"HighlightedGraph", "Properties"}

varCover[equations]["Cover"]

{y + z == 6, Sqrt[b - c^3] x == 3, 3 a - w == 4}

varCover[equations]["HighlightedExpressions"]


varCover[equations]["HighlightedCoverageMatrix"]


varCover[equations]["HighlightedGraph"]


If any of the target variables (specified in the third argument) does not appear in expressions (specified in the first argument) it is highlighted in associated results:

varCover[equations,
Automatic, {x, w, c, blah1, blah2}]["HighlightedExpressions"]


varCover[equations,
Automatic, {x, w, c, blah1, blah2}]["HighlightedCoverageMatrix"]


varCover[equations,
Automatic, {x, w, c, blah1, blah2}]["HighlightedGraph"]


### Code

ClearAll[varCover]

varCover[expressions_, weights_ : Automatic, targetvariables_ : Automatic] :=
Module[{$$vars = Level[#, {-1}, DeleteCases[_?NumericQ]@*Union@*List] &, properties = {"Solution", "CoverIndices", "Cover", "VariablesInCover", "Cost", "HighlightedExpressions", "Input", "Expressions", "Weights", "TargetVariables", "Variables", "CoverageMatrix", "HighlightedCoverageMatrix", "RelationGraph", "HighlightedGraph", "Properties"}, highlighting = {v : Alternatives @@ # :> Placed[ Highlighted[v, Frame -> True], Before], v : (Alternatives @@ #2) :> Placed[v /. tv : Alternatives @@ #3 :> Highlighted[tv, Background -> LightRed, Frame -> True], After]} &}, Module[{bpg, hbpg, m, cm, sol, d, ivl, uvl, notcovered, pos, sel, w = weights /. Automatic -> ConstantArray[1, Length@expressions], vl = Apply[Union]@Map[vars]@expressions}, ivl = Intersection[vl, targetvariables /. Automatic -> vl]; uvl = DeleteDuplicates@Join[vl, targetvariables /. Automatic -> {}]; notcovered = Complement[uvl, vl]; m = Boole@Outer[MemberQ[$$vars@#2, #] &, ivl, expressions];
sol = First @ LinearOptimization[w . d,
{m . d \[VectorGreaterEqual] 1.,
0. \[VectorLessEqual] d \[VectorLessEqual] 1.},
d ∈ Vectors[Length@expressions, Integers]];
pos = PositionIndex[d /. sol][1];
sel = expressions[[pos]];
cm = Transpose @
Boole @ Outer[MemberQ[$$vars @ #2, #] &, uvl, expressions]; bpg = RelationGraph[MemberQ[$$vars@#, #2] &, expressions, uvl,
VertexCoordinates ->
GraphEmbedding[CompleteGraph[Length /@ {expressions, uvl}]],
VertexLabels -> {v_ :> Placed[v , Before],
v : (Alternatives @@ uvl) :> Placed[v, After]}];
hbpg = HighlightGraph[bpg,
Subgraph[bpg, DirectedEdge[Alternatives @@ sel, _]],
GraphHighlightStyle -> "Thick",
VertexLabels -> highlighting[sel, uvl, notcovered]];
{d, pos, sel, \$vars /@ sel, w . d,
Column[Join[expressions, notcovered] /.
highlighting[sel, uvl, notcovered] /. Placed -> (# &)],
"TargetVariables"}, {expressions, w, targetvariables}],
expressions, w, targetvariables, vl,
Panel @ TableForm[cm, TableHeadings -> {expressions, uvl}],
Panel @ TableForm[cm, TableHeadings -> ({expressions, uvl} /.
highlighting[sel, uvl, notcovered] /. Placed -> (# &))],
Panel @ bpg, Panel @ hbpg, properties} /. sol]]]


Update: A function that takes a list of expressions and, optionally, a cost vector; sets up and solves the associated LinearOptimization problem; and returns an Association with keys "Inputs", "Decisions", "Indices", "Selection", "Variables" and "Cost":

ClearAll[varCover]

varCover[eq_, costs_ : Automatic][q_ : Automatic] :=
Module[{$$vars = Level[#, {-1}, DeleteCases[_?NumericQ]@* Union@*List] &}, Module[{assoc, sol, d, pos, c = costs /. Automatic -> ConstantArray[1, Length@eq], m = Boole@Outer[MemberQ[vars@#2, #] &, Apply[Union]@Map[vars]@eq, eq]}, sol = First @ LinearOptimization[c . d, {m . d \[VectorGreaterEqual] 1., 0. \[VectorLessEqual] d \[VectorLessEqual] 1.}, Element[d, Vectors[Length@eq, Integers]]]; pos = PositionIndex[d /. sol][1]; assoc = AssociationThread[ {"Inputs", "Decision", "Indices", "Selection", "Variables", "Cost"}, {AssociationThread[{"Equations", "Costs"}, {eq, c}], d, pos, eq[[pos]],$$vars /@ eq[[pos]], c . d} /. sol];
q /. {Automatic -> assoc, _ -> Lookup[q] @ assoc}]]


Examples

varCover[equations][]


varCover[equations][{"Indices", "Selection", "Variables"}]

{{2, 3, 5},
{y + z == 6, Sqrt[b - c^3] x == 3, 3 a - w == 4},
{{y, z}, {b, c, x}, {a, w}}}


## Linear Optimization

This is a simple adaptation of the example in Linear Optimization >> Applications >> Set Covering Problems.

Using @flinty's input example:

equations = {x^2 + 2 a - 3 w^(z + 1) == x,
y + z == 6,
x Sqrt[b - c^3] == 3,
b + 1 == 0,
3 a - w == 4,
Cos[x]/4 + z == -5,
Log[a] + Log[b] == Sqrt[x + 1],
Sqrt[x + Sqrt[Cos[y]] - Sqrt[Sin[z] + 1]/a*b]};

varList = Level[#, {-1}, DeleteCases[_?NumericQ] @* Union @* List] &;

allvars = Apply[Union] @ Map[varList] @ equations

{a, b, c, w, x, y, z}

memberships = Boole @ Outer[MemberQ[varList @ #2, #] &, allvars, equations];

TeXForm @ MatrixForm @ memberships


$$\left( \begin{array}{cccccccc} 1 & 0 & 0 & 0 & 1 & 0 & 1 & 1 \\ 0 & 0 & 1 & 1 & 0 & 0 & 1 & 1 \\ 0 & 0 & 1 & 0 & 0 & 0 & 0 & 0 \\ 1 & 0 & 0 & 0 & 1 & 0 & 0 & 0 \\ 1 & 0 & 1 & 0 & 0 & 1 & 1 & 1 \\ 0 & 1 & 0 & 0 & 0 & 0 & 0 & 1 \\ 1 & 1 & 0 & 0 & 0 & 1 & 0 & 1 \\ \end{array} \right)$$

solution = First @ LinearOptimization[
ConstantArray[1, Length @ equations] . decisions,
{memberships . decisions \[VectorGreaterEqual] 1.,
0. \[VectorLessEqual] decisions \[VectorLessEqual] 1.},
Element[decisions, Vectors[Length @ equations, Integers]]]

 decisions -> {0, 1, 1, 0, 1, 0, 0, 0}

selectedequations = Pick[equations, Values @ solution, 1];
selectedindices = Flatten @ PositionIndex[Values @ solution][1]

TeXForm @ Grid[#, Dividers -> All] & @
Prepend[{{Column @ selectedindices,
Column @ selectedequations,
Column[varList /@ selectedequations],
Union @@ (varList /@ selectedequations)}},
{"indices",
"selectedequations",
"selectedvariables",
"Union @ selectedvariables"}]


$$\begin{array}{|c|c|c|c|} \hline \text{indices} & \text{selectedequations} & \text{selectedvariables} & \text{Union @ selectedvariables} \\ \hline \begin{array}{l} 2 \\ 3 \\ 5 \\ \end{array} & \begin{array}{l} y+z=6 \\ x \sqrt{b-c^3}=3 \\ 3 a-w=4 \\ \end{array} & \begin{array}{l} \{y,z\} \\ \{b,c,x\} \\ \{a,w\} \\ \end{array} & \{a,b,c,w,x,y,z\} \\ \hline \end{array}$$

Note: Minimizing an alternative objective function that weights each equation with the number of variables in it, that is, using

 (Length /@ varList /@ equations) . decisions


instead of ConstantArray[1, Length @ equations] . decisions as the objective gives the same solution for this example.

Here is my greedy solution from the answer mentioned in the comments, adapted for equations / variables. Note that greedy is not optimal, but generally performs well as the problem size grows. For very large problems it becomes intractable to solve using ILP and other methods, and the greedy algorithm is usually good enough (see here)

greedyfactor[curunion_, set_] :=
If[ContainsAll[curunion, set[[1]]], Infinity,
set[[2]]/(Length[Union[curunion, set[[1]]]] - Length[curunion])]

greedy[sets_] :=
Module[{target = Union @@ sets[[All, 1]], remaining = sets,
curunion = {}, sel},
Reap[While[! ContainsAll[curunion, target],
sel = First[MinimalBy[remaining, greedyfactor[curunion, #] &]];
Sow[sel];
remaining = DeleteCases[remaining, sel];
curunion = Union[curunion, sel[[1]]]]][[-1, 1]]]

equations = {
x^2 + 2 a - 3 w^(z + 1) == x,
y + z == 6,
x Sqrt[b - c^3] == 3,
b + 1 == 0,
3 a - w == 4,
Cos[x]/4 + z == -5,
Log[a] + Log[b] == Sqrt[x + 1],
Sqrt[x + Sqrt[Cos[y]] - Sqrt[Sin[z] + 1]/a*b]
};

getSymbols[expr_] :=
Sort@DeleteDuplicates@Cases[expr, Except[_?NumericQ, _Symbol], Infinity];

allvariables = getSymbols[equations];
sets = {getSymbols[#], LeafCount[#]} & /@ equations;

(*confirm we cover all elements*)
chosenSets = greedy[sets];
indices = First[FirstPosition[sets, #]] & /@ chosenSets;
equations[[indices]]

(** {y + z == 6, Log[a] + Log[b] == Sqrt[1 + x], 3 a - w == 4,
Sqrt[b - c^3] x == 3} **)


• I think you need a pattern like Except[_?NumericQ, _Symbol] in Cases[...] to leave numeric symbols like E and Pi.
– kglr
Commented May 10, 2023 at 15:01
• @kglr thanks. OP may want to also have equations like x+1 == f[g[y]] and have all of x, f, g, y as variables, but not sure how to do that. Adding Heads->True doesn't work. Commented May 10, 2023 at 15:06
• @flinty In my special case I know that all variables are labeled by s[i] with s a chosen symbol and i an integer so just Cases[ expr, s[_], Infinity ] does the job. Thanks for the Wikipedia link btw :)
– Gert
Commented May 10, 2023 at 16:04