Каков наилучший способ найти период в повторяющемся списке?
Например:
a = {4, 5, 1, 2, 3, 4, 5, 1, 2, 3, 4, 5, 1, 2}
имеет повторение {4, 5, 1, 2, 3} с остатком {4, 5, 1, 2}, но неполным.
Алгоритм должен быть достаточно быстрым, чтобы обрабатывать более длинные случаи, например:
b = RandomInteger[10000, {100}];
a = Join[b, b, b, b, Take[b, 27]]
Алгоритм должен возвращать $Failed, если не существует повторяющегося шаблона, как указано выше.
Пожалуйста, ознакомьтесь с комментариями, вкрапленными с кодом о том, как он работает.
(* True if a has period p *)
testPeriod[p_, a_] := Drop[a, p] === Drop[a, -p]
(* are all the list elements the same? *)
homogeneousQ[list_List] := [email protected][list] === 1
homogeneousQ[{}] := Throw[$Failed] (* yes, it ugly to put this here ... *)
(* auxiliary for findPeriodOfFirstElement[] *)
reduce[a_] := [email protected]@Position[a, First[a], {1}]
(* the first element occurs every ?th position ? *)
findPeriodOfFirstElement[a_] := Module[{nl},
nl = NestWhileList[reduce, reduce[a], ! homogeneousQ[#] &];
Fold[[email protected][#2, #1] &, 1, Reverse[nl]]
]
(* the period must be a multiple of the period of the first element *)
period[a_] := [email protected][{fp = findPeriodOfFirstElement[a]},
Do[
If[testPeriod[p, a], Return[p]],
{p, fp, Quotient[Length[a], 2], fp}
]
]
Пожалуйста, спросите, не ясно ли findPeriodOfFirstElement[]. Я сделал это самостоятельно (для удовольствия!), Но теперь я вижу, что принцип такой же, как и в решении Вербей, за исключением того, что проблема, отмеченная Бреттом, исправлена.
Я тестировал
b = RandomInteger[100, {1000}];
a = Flatten[{ConstantArray[b, 1000], Take[b, 27]}];
(Обратите внимание на низкое целочисленное значение: в течение того же периода будет много повторяющихся элементов *)
РЕДАКТИРОВАТЬ: В соответствии с комментарием Leonid ниже, еще 2-3 раза быстрее (~ 2.4x на моей машине) можно используя пользовательскую функцию позиции, скомпилированную специально для списков целых чисел:
(* Leonid reduce[] *)
myPosition = Compile[
{{lst, _Integer, 1}, {val, _Integer}},
Module[{pos = Table[0, {Length[lst]}], i = 1, ctr = 0},
For[i = 1, i <= Length[lst], i++,
If[lst[[i]] == val, pos[[++ctr]] = i]
];
Take[pos, ctr]
],
CompilationTarget -> "C", RuntimeOptions -> "Speed"
]
reduce[a_] := [email protected][a, First[a]]
Компиляция testPeriod дает более быстрое ускорение ~ 20% при быстром тестировании, но я полагаю, что это будет зависеть от входных данных:
Clear[testPeriod]
testPeriod =
Compile[{{p, _Integer}, {a, _Integer, 1}},
Drop[a, p] === Drop[a, -p]]
Выше методы лучше, если у вас нет шума. Если ваш сигнал приблизительный, то методы преобразования Фурье могут оказаться полезными. Я проиллюстрирую "параметризованную" настройку, в которой длина и количество повторений базового сигнала, длина конечной части и оценка шумового возмущения - все переменные, с которыми можно играть.
noise = 20;
extra = 40;
baselen = 103;
base = RandomInteger[10000, {baselen}];
repeat = 5;
signal = Flatten[Join[ConstantArray[base, repeat], Take[base, extra]]];
noisysignal = signal + RandomInteger[{-noise, noise}, Length[signal]];
Мы вычисляем абсолютное значение БПФ. Мы соединяем нули с обоих концов. Объект будет пороговым по сравнению с соседями.
sigfft = Join[{0.}, Abs[Fourier[noisysignal]], {0}];
Теперь мы создаем два вектора 0-1. В одном из них порог, создавая 1 для каждого элемента в fft, который больше чем в два раза превышает среднее геометрическое для двух его соседей. В другом мы используем среднее (среднее арифметическое), но мы уменьшаем размер, связанный с 3/4. Это было основано на некоторых экспериментах. Мы подсчитываем количество 1 в каждом случае. В идеале мы получили бы 100 для каждого, так как это было бы количество ненулевых в "идеальном" случае без шума и без хвостовой части.
In[419]:=
thresh1 =
Table[If[sigfft[[j]]^2 > 2*sigfft[[j - 1]]*sigfft[[j + 1]], 1,
0], {j, 2, Length[sigfft] - 1}];
count1 = Count[thresh1, 1]
thresh2 =
Table[If[sigfft[[j]] > 3/4*(sigfft[[j - 1]] + sigfft[[j + 1]]), 1,
0], {j, 2, Length[sigfft] - 1}];
count2 = Count[thresh2, 1]
Out[420]= 114
Out[422]= 100
Теперь мы получаем самое лучшее представление о значении "повторений", принимая пол общей длины в среднем по нашим подсчетам.
approxrepeats = Floor[2*Length[signal]/(count1 + count2)]
Out[423]= 5
Итак, мы обнаружили, что основной сигнал повторяется 5 раз. Это может дать начало уточнению, чтобы оценить правильную длину (baselen, выше). С этой целью мы могли бы попытаться удалить элементы в конце и увидеть, когда мы получим ffts ближе к фактическому прогону с четырьмя 0s между ненулевыми значениями.
Что-то еще, что могло бы работать для оценки количества повторов, заключается в нахождении модального числа нулей в кодировании длины пробега пороговых ffts. В то время как я на самом деле не пытался это сделать, похоже, что это может быть устойчиво к плохим выборам в деталях того, как происходит порог (мои были просто эксперименты, которые, похоже, работают).
Даниэль Лихтблау
Далее предполагается, что цикл начинается с первого элемента и задает длину периода и цикл.
findCyclingList[a_?VectorQ] :=
Module[{repeats1, repeats2, cl, cLs, vec},
repeats1 = [email protected][Position[a, First[a]]];
repeats2 = Flatten[Position[repeats1, First[repeats1]]];
If[Equal @@ Differences[repeats2] && Length[repeats2] > 2(*
is potentially cyclic - first element appears cyclically *),
cl = Plus @@@ Partition[repeats1, First[Differences[repeats2]]];
cLs = Partition[a, First[cl]];
If[SameQ @@ cLs (* candidate cycles all actually the same *),
vec = First[cLs];
{Length[vec], vec}, $Failed], $Failed] ]
Тестирование
b = RandomInteger[50, {100}];
a = Join[b, b, b, b, Take[b, 27]];
findCyclingList[a]
{100, {47, 15, 42, 10, 14, 29, 12, 29, 11, 37, 6, 19, 14, 50, 4, 38,
23, 3, 41, 39, 41, 17, 32, 8, 18, 37, 5, 45, 38, 8, 39, 9, 26, 33,
40, 50, 0, 45, 1, 48, 32, 37, 15, 37, 49, 16, 27, 36, 11, 16, 4, 28,
31, 46, 30, 24, 30, 3, 32, 31, 31, 0, 32, 35, 47, 44, 7, 21, 1, 22,
43, 13, 44, 35, 29, 38, 31, 31, 17, 37, 49, 22, 15, 28, 21, 8, 31,
42, 26, 33, 1, 47, 26, 1, 37, 22, 40, 27, 27, 16}}
b1 = RandomInteger[10000, {100}];
a1 = Join[b1, b1, b1, b1, Take[b1, 23]];
findCyclingList[a1]
{100, {1281, 5325, 8435, 7505, 1355, 857, 2597, 8807, 1095, 4203,
3718, 3501, 7054, 4620, 6359, 1624, 6115, 8567, 4030, 5029, 6515,
5921, 4875, 2677, 6776, 2468, 7983, 4750, 7609, 9471, 1328, 7830,
2241, 4859, 9289, 6294, 7259, 4693, 7188, 2038, 3994, 1907, 2389,
6622, 4758, 3171, 1746, 2254, 556, 3010, 1814, 4782, 3849, 6695,
4316, 1548, 3824, 5094, 8161, 8423, 8765, 1134, 7442, 8218, 5429,
7255, 4131, 9474, 6016, 2438, 403, 6783, 4217, 7452, 2418, 9744,
6405, 8757, 9666, 4035, 7833, 2657, 7432, 3066, 9081, 9523, 3284,
3661, 1947, 3619, 2550, 4950, 1537, 2772, 5432, 6517, 6142, 9774,
1289, 6352}}
Этот случай должен завершиться неудачно, потому что он не цикличен.
findCyclingList[Join[b, Take[b, 11], b]]
$Failed
Я попытался что-то сделать с помощью Repeated, например. a /. Repeated[t__, {2, 100}] -> {t}, но это просто не работает для меня.
Это работает для вас?
period[a_] :=
Quiet[Check[
First[Cases[
Table[
{k, Equal @@ Partition[a, k]},
{k, Floor[Length[a]/2]}],
{k_, True} :> k
]],
$Failed]]
Строго говоря, это не удастся для таких вещей, как
a = {1, 2, 3, 1, 2, 3, 1, 2, 3, 4, 5}
хотя это можно исправить, используя что-то вроде:
(Equal @@ Partition[a, k]) && (Equal @@ Partition[Reverse[a], k])
(возможно, вычисление Reverse[a] только раз за раз.)
Я предлагаю это. Он заимствует ответы Вербейи и Бретта.
Do[
If[MatchQ @@ Equal @@ Partition[#, i, i, 1, _], Return @@ i],
{i, #[[ 2 ;; Floor[[email protected]#/2] ]] ~Position~ [email protected]#}
] /. Null -> $Failed &
Он не так эффективен, как функция Vebeia в длительные периоды, но быстрее на коротких, и это проще.
Я не знаю, как его решить в математике, но должен работать следующий алгоритм (написанный на python). Это O (n), поэтому скорость не должна беспокоить.
def period(array):
if len(array) == 0:
return False
else:
s = array[0]
match = False
end = 0
i = 0
for k in range(1,len(array)):
c = array[k]
if not match:
if c == s:
i = 1
match = True
end = k
else:
if not c == array[i]:
match = False
i += 1
if match:
return array[:end]
else:
return False
# False
print(period([4, 5, 1, 2, 3, 4, 5, 1, 2, 3, 4, 5, 1, 2,1]))
# [4, 5, 1, 2, 3]
print(period([4, 5, 1, 2, 3, 4, 5, 1, 2, 3, 4, 5, 1, 2]))
# False
print(period([4]))
# [4, 2]
print(period([4,2,4]))
# False
print(period([4,2,1]))
# False
print(period([]))
Хорошо, просто чтобы показать свою работу здесь:
ModifiedTortoiseHare[a_List] := Module[{counter, tortoise, hare},
Quiet[
Check[
counter = 1;
tortoise = a[[counter]];
hare = a[[2 counter]];
While[(tortoise != hare) || (a[[counter ;; 2 counter - 1]] != a[[2 counter ;; 3 counter - 1]]),
counter++;
tortoise = a[[counter]];
hare = a[[2 counter]];
];
counter,
$Failed]]]
Я не уверен, что это на 100% правильно, особенно в таких случаях, как {pattern, pattern, different, pattern, pattern}, и он становится медленнее и медленнее, когда есть много повторяющихся элементов, например:
{ 1,2,1,1, 1,2,1,1, 1,2,1,1, ...}
потому что он делает слишком много дорогостоящих сравнений.
#include <iostream>
#include <vector>
using namespace std;
int period(vector<int> v)
{
int p=0; // period 0
for(int i=p+1; i<v.size(); i++)
{
if(v[i] == v[0])
{
p=i; // new potential period
bool periodical=true;
for(int i=0; i<v.size()-p; i++)
{
if(v[i]!=v[i+p])
{
periodical=false;
break;
}
}
if(periodical) return p;
i=p; // try to find new period
}
}
return 0; // no period
}
int main()
{
vector<int> v3{1,2,3,1,2,3,1,2,3};
cout<<"Period is :\t"<<period(v3)<<endl;
vector<int> v0{1,2,3,1,2,3,1,9,6};
cout<<"Period is :\t"<<period(v0)<<endl;
vector<int> v1{1,2,1,1,7,1,2,1,1,7,1,2,1,1};
cout<<"Period is :\t"<<period(v1)<<endl;
return 0;
}
Похоже, что это может относиться к выравниванию последовательностей. Эти алгоритмы хорошо изучены и могут быть уже реализованы в математике.