Sottoinsieme più comune della dimensione k

Question

Supponiamo di avere un elenco di sottoinsiemi S1,...,Sn dell'intervallo intero R={1,2,...,N} e un numero intero k. Esiste un modo efficace per trovare un sottoinsieme R della dimensione k in modo tale che C sia un sottoinsieme di un numero massimo di Si?

A titolo di esempio, si R={1,2,3,4} e k=2

S1={1,2,3} 
S2={1,2,3} 
S3={1,2,4} 
S4={1,3,4} 

Poi voglio tornare sia C={1,2} o C={1,3} (non importa quale).

Answer 1

Penso che il tuo problema sia NP-Hard. Si consideri il grafico bipartito con i nodi di sinistra come set e i nodi corretti come interi {1, ..., N}, con un margine tra due nodi se il set contiene il numero intero. Quindi, trovare un sottoinsieme comune di dimensioni k, che è un sottoinsieme di un numero massimo di Si, equivale a trovare un sottografo bipartito completo K(i, k) con il numero massimo di spigoli i*k. Se si potesse fare questo in tempo polinomiale, quindi, si potrebbe trovare il sottografo bipartito completo K(i, j) con il numero massimo di spigoli i*j in tempo polinomiale, provando per ogni fisso k. Ma questo problema in NP-Complete (Complete bipartite graph).

Quindi, a meno che P = NP, il problema non abbia un algoritmo del tempo polinomiale.

Answer 2

Supponendo che capisco la tua domanda Credo che questo sia semplice per set abbastanza piccoli.

Userò il codice Mathematica per illustrazione, ma il concetto è universale.

I generare 10 sottoinsiemi casuali di lunghezza 4, dall'insieme {1 .. 8}:

ss = Subsets[Range@8, {4}] ~RandomSample~ 10 

{{1, 3, 4, 6}, {2, 6, 7, 8}, {3, 5, 6, 7}, {2, 4, 6, 7}, {1, 4, 5, 8}, 
{2, 4, 6, 8}, {1, 2, 3, 8}, {1, 6, 7, 8}, {1, 2, 4, 7}, {1, 2, 5, 7}} 

converte questi per una matrice binaria della presenza di ogni numero in ogni sottoinsieme:

a = Normal@SparseArray[Join @@ MapIndexed[Tuples[{##}] &, ss] -> 1]; 

Grid[a] 

Ciò significa dieci colonne per dieci sottoinsiemi e otto righe per gli elementi {1 .. 8}.

Ora generare tutti i possibili sottoinsiemi di destinazione (dimensione 3):

keys = Subsets[Union @@ ss, {3}]; 

prendere una "chiave" ed estrarre le righe dalla matrice e fare un operazione BitAnd (tornare 1 se e solo se tutte le colonne uguali 1), poi conta il numero di quelliAd esempio, per la chiave {1, 6, 8} abbiamo:

a[[{1, 6, 8}]] 

Dopo BitAnd:

fare questo per ogni chiave:

counts = Tr[BitAnd @@ a[[#]]] & /@ keys; 

poi trovare la posizione (s) dell'elemento massimo o f quella lista, ed estrarre le parti corrispondenti dei keys:

keys ~Extract~ Position[counts, Max@counts] 

{{1, 2, 7}, {2, 4, 6}, {2, 4, 7}, {2, 6, 7}, {2, 6, 8}, {6, 7, 8}} 

Con memoria adeguata questo processo funziona rapidamente per un insieme più ampio. A partire da 50.000 sottoinsiemi scelti a caso di lunghezza 7 da {1} .. 30:

ss = Subsets[Range@30, {7}] ~RandomSample~ 50000; 

Le massime sotto-sottoinsiemi di lunghezza 4 sono calcolate in circa nove secondi:

AbsoluteTiming[ 
    a = Normal@SparseArray[Join @@ MapIndexed[Tuples[{##}] &, ss] -> 1]; 
    keys = Subsets[Union @@ ss, {4}]; 
    counts = Tr[BitAnd @@ a[[#]]] & /@ keys; 
    keys~Extract~Position[counts, Max@counts] 
] 

{8.8205045, {{2, 3, 4, 20}, 
       {7, 10, 15, 18}, 
       {7, 13, 16, 26}, 
       {11, 21, 26, 28}}} 

Devo aggiungere che Mathematica è un linguaggio di alto livello e queste operazioni sono su oggetti generici, Pertanto, se questo viene fatto veramente a livello binario, questo dovrebbe essere molto più veloce e più efficiente in termini di memoria.

Answer 3

Spero di non fraintendere il problema ... Ecco una soluzione in SWI-Prolog

:- module(subsets, [solve/0]). 
:- [library(pairs), 
    library(aggregate)]. 

solve :- 
    problem(R, K, Subsets), 
    once(subset_of_maximal_number(R, K, Subsets, Subset)), 
    writeln(Subset). 

problem(4, 2, 
[[1,2,3], [1,2,3], [1,2,4], [1,3,4]]). 

problem(8, 3, 
[[1, 3, 4, 6], [2, 6, 7, 8], [3, 5, 6, 7], [2, 4, 6, 7], [1, 4, 5, 8], 
[2, 4, 6, 8], [1, 2, 3, 8], [1, 6, 7, 8], [1, 2, 4, 7], [1, 2, 5, 7]]). 

subset_of_maximal_number(R, K, Subsets, Subset) :- 
    flatten(Subsets, Numbers), 
    findall(Num-Count, 
     ( between(1, R, Num), 
      aggregate_all(count, member(Num, Numbers), Count) 
     ), NumToCount), 
    transpose_pairs(NumToCount, CountToNumSortedR), 
    reverse(CountToNumSortedR, CountToNumSorted), 
    length(Subset, K), % list of free vars 
    prefix(SolutionsK, CountToNumSorted), 
    pairs_values(SolutionsK, Subset). 

uscita di test:

?- solve. 
[1,3] 
true ; 
[7,6,2] 
true. 

edit: Penso che la soluzione sopra è sbagliato, nel senso che ciò che viene restituito non può essere un sottoinsieme di alcun input: qui (una soluzione commentata) senza questo problema:

:- module(subsets, [solve/0]). 
:- [library(pairs), 
    library(aggregate), 
    library(ordsets)]. 

solve :- 
    problem(R, K, Subsets), 
    once(subset_of_maximal_number(R, K, Subsets, Subset)), 
    writeln(Subset). 

problem(4, 2, 
[[1,2,3], [1,2,3], [1,2,4], [1,3,4]]). 

problem(8, 3, 
[[1, 3, 4, 6], [2, 6, 7, 8], [3, 5, 6, 7], [2, 4, 6, 7], [1, 4, 5, 8], 
[2, 4, 6, 8], [1, 2, 3, 8], [1, 6, 7, 8], [1, 2, 4, 7], [1, 2, 5, 7]]). 

subset_of_maximal_number(R, K, Subsets, Subset) :- 
    flatten(Subsets, Numbers), 
    findall(Num-Count, 
     ( between(1, R, Num), 
      aggregate_all(count, member(Num, Numbers), Count) 
     ), NumToCount), 

    % actually sort by ascending # of occurrences 
    transpose_pairs(NumToCount, CountToNumSorted), 
    pairs_values(CountToNumSorted, PreferredRev), 

    % we need higher values first 
    reverse(PreferredRev, Preferred), 

    % empty slots to fill, preferred first 
    length(SubsetP, K), 
    select_k(Preferred, SubsetP), 

    % verify our selection it's an actual subset of any of subsets 
    sort(SubsetP, Subset), 
    once((member(S, Subsets), ord_subtract(Subset, S, []))). 

select_k(_Subset, []). 
select_k(Subset, [E|R]) :- 
    select(E, Subset, WithoutE), 
    select_k(WithoutE, R). 

prova:

?- solve. 
[1,3] 
true ; 
[2,6,7] 
true.