Наиболее распространенное подмножество размера k

Question

Предположим, у вас есть список подмножеств S1,...,Sn целочисленного диапазона R={1,2,...,N} и целое число k. Есть ли эффективный способ найти подмножество C из R размера k, чтобы C было подмножеством максимального числа Si?

В качестве примера, пусть R={1,2,3,4} и k=2

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

Тогда я хочу вернуть либо C={1,2}, либо C={1,3} (не важно, какой).

Answer 1

Я думаю, что ваша проблема NP-Hard. Рассмотрим двудольный граф, левые узлы которого являются вашими наборами, а правые узлы - целыми числами {1, ..., N}, с ребром между двумя узлами, если набор содержит целое число. Затем поиск общего подмножества размера k, который является подмножеством максимального числа Si, эквивалентен нахождению полного двудольного подграфа K(i, k) с максимальным числом ребер i*k. Если бы вы могли сделать это за полиномиальное время, то вы могли бы найти полный двудольный подграф K(i, j) с максимальным числом ребер i*j за полиномиальное время, пытаясь для каждого фиксированного k. Но эта проблема в NP-Complete ( Полный двудольный граф ).

Итак, если P = NP, ваша задача не имеет алгоритма полиномиального времени.

Answer 2

Надеюсь, я не пойму проблему неправильно ... Вот решение в 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).

тестовый вывод:

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

edit: Я думаю, что вышеприведенное решение неверно, в том смысле, что возвращаемое решение не может быть подмножеством любого из входных данных: здесь (закомментированное) решение без этой проблемы:

:- 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).

тест:

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

Answer 3

Предполагая, что я понимаю ваш вопрос, я считаю, что это довольно просто для довольно небольших наборов.

Я буду использовать Mathematica код для иллюстрации, но концепция универсальна.

Я генерирую 10 случайных подмножеств длины 4 из набора {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}}

Я преобразую их в двоичный массивналичие каждого числа в каждом подмножестве:

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

Grid[a]

Это десять столбцов для десяти подмножеств и восемь строк для элементов {1 .. 8}.

Теперь сгенерируйте все возможные целевые подмножества (размер 3):

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

Возьмите «ключ», извлеките эти строки из массива и выполните операцию BitAnd (возврат 1, если все столбцы равны1), затем посчитайте количество единиц.Например, для ключа {1, 6, 8} имеем:

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

После BitAnd:

Сделайте это длякаждая клавиша:

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

Затем найдите положение (я) максимального элемента этого списка и извлеките соответствующие части 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}}

При достаточной памяти этот процесс работает быстрее для большого набора.Начиная с 50 000 случайно выбранных подмножеств длины 7 из {1 .. 30}:

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

Максимальные подмножества длины 4 рассчитываются примерно за девять секунд:

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}}}

Я должен добавить, что Mathematica является языком высокого уровня, и эти операции выполняются над общими объектами, поэтому, если это действительно выполняется на двоичном уровне, это должно бытьнамного быстрее и эффективнее с точки зрения памяти.