Як обчислити коефіцієнт закону Зіпфа з набору верхніх частот?

У мене є кілька частот запитів, і мені потрібно оцінити коефіцієнт закону Зіпфа. Це найвищі частоти:

26486
12053
5052
3033
2536
2391
1444
1220
1152
1039

Оновлення Я оновив код з максимальною оцінкою ймовірності відповідно до пропозиції @whuber. Мінімізація суми квадратів відмінностей між теоретичними ймовірностями журналу та частотами журналу, хоча дає відповідь, була б статистичною процедурою, якщо можна було б показати, що це якийсь М-оцінювач. На жаль, я не міг придумати жодного, який міг би дати однакові результати.

Ось моя спроба. Я обчислюю логарифми частот і намагаюся пристосувати їх до логарифмів теоретичних ймовірностей, заданих цією формулою . Кінцевий результат видається розумним. Ось мій код у Р.

fr <- c(26486, 12053, 5052, 3033, 2536, 2391, 1444, 1220, 1152, 1039)

p <- fr/sum(fr)

lzipf <- function(s,N) -s*log(1:N)-log(sum(1/(1:N)^s))

opt.f <- function(s) sum((log(p)-lzipf(s,length(p)))^2)

opt <- optimize(opt.f,c(0.5,10))

> opt
$minimum
[1] 1.463946

$objective
[1] 0.1346248

Найкраще квадратичне прилягання тоді .$s=1.47$

Максимальна ймовірність R може бути виконана за допомогою mleфункції (з stats4пакета), яка корисно обчислює стандартні помилки (якщо правильна негативна функція максимальної ймовірності):

ll <- function(s) sum(fr*(s*log(1:10)+log(sum(1/(1:10)^s))))

fit <- mle(ll,start=list(s=1))

> summary(fit)
Maximum likelihood estimation

Call:
mle(minuslogl = ll, start = list(s = 1))

Coefficients:
  Estimate  Std. Error
s 1.451385 0.005715046

-2 log L: 188093.4 

Ось графік придатності в масштабі журналу журналу (знову, як запропонував @whuber):

s.sq <- opt$minimum
s.ll <- coef(fit)

plot(1:10,p,log="xy")
lines(1:10,exp(lzipf(s.sq,10)),col=2)
lines(1:10,exp(lzipf(s.ll,10)),col=3)

Червона лінія - це сума відповідних квадратів, зелена - максимально можлива.

Перед будь-якою проблемою оцінки є кілька питань :

1. Оцініть параметр.

2. Оцініть якість цієї оцінки.

3. Дослідіть дані.

4. Оцініть придатність.

Для тих, хто використовує статистичні методи для розуміння та спілкування, перший не повинен обійтися без інших.

$i=1,2,\ldots,n$$i^{-s}$$s$$s\gt 0$

$i$$1$$n$

$f_i, i=1,2,\ldots, n$

Таким чином, вірогідність журналу даних є

$s$

$\hat{s} = 1.45041$$\Lambda(\hat{s}) = -94046.7$$\hat{s}_{ls} = 1.463946$$\Lambda(\hat{s}_{ls}) = -94049.5$

$s$$[1.43922, 1.46162]$

Враховуючи характер закону Зіпфа, правильний спосіб зафіксувати цю придатність - на графіку журналу журналу , де відповідність буде лінійною (за визначенням):

Щоб оцінити корисність придатності та вивчити дані, подивіться на залишки (дані / примір, осі журналу журналу знову):

$\chi^2 = 656.476$

Оскільки залишки виглядають випадковими, ми можемо з задоволенням прийняти Закон Зіпфа (і нашу оцінку параметра) як прийнятний, хоча і приблизний опис частот . Цей аналіз показує, що було б помилкою вважати, що ця оцінка має якесь пояснювальне або прогнозне значення для досліджуваного тут набору даних.

$s$

Однією з імовірнісних мов програмування, наприклад, PyMC3, зробити цю оцінку досить просто. Інші мови включають Стен, який має чудові функції та підтримуючу спільноту.

Ось моя реалізація Python моделі, встановленої на даних ОП (також у Github ):

import theano.tensor as tt
import numpy as np
import pymc3 as pm
import matplotlib.pyplot as plt

data = np.array( [26486, 12053, 5052, 3033, 2536, 2391, 1444, 1220, 1152, 1039] )

N = len( data )

print( "Number of data points: %d" % N )

def build_model():
    with pm.Model() as model:
        # unsure about the prior...
        #s = pm.Normal( 's', mu=0.0, sd=100 )
        #s = pm.HalfNormal( 's', sd=10 )
        s = pm.Gamma('s', alpha=1, beta=10)

        def logp( f ):
            r = tt.arange( 1, N+1 )
            return -s * tt.sum( f * tt.log(r) ) - tt.sum( f ) * tt.log( tt.sum(tt.power(1.0/r,s)) )

        pm.DensityDist( 'obs', logp=logp, observed={'f': data} )

    return model


def run( n_samples=10000 ):
    model = build_model()
    with model:
        start = pm.find_MAP()
        step = pm.NUTS( scaling=start )
        trace = pm.sample( n_samples, step=step, start=start )

    pm.summary( trace )
    pm.traceplot( trace )
    pm.plot_posterior( trace, kde_plot=True )
    plt.show()

if __name__ == '__main__':
    run()

$s$$s$

Для надання основної діагностики вибірки ми можемо побачити, що вибірка "добре перемішувалася", оскільки ми не бачимо жодної структури в сліді:

Для запуску коду потрібен Python із встановленими пакетами Theano та PyMC3.

Дякуємо @ w-huber за його чудову відповідь та коментарі!

Ось моя спроба встановити дані, оцінити та вивчити результати за допомогою VGAM:

require("VGAM")

freq <- dzipf(1:100, N = 100, s = 1)*1000 #randomizing values
freq <- freq  + abs(rnorm(n=1,m=0, sd=100)) #adding noize

zdata <- data.frame(y = rank(-freq, ties.method = "first") , ofreq = freq)
fit = vglm(y ~ 1, zipf, zdata, trace = TRUE,weight = ofreq,crit = "coef")
summary(fit)

s <- (shat <- Coef(fit)) # the coefficient we've found
probs <- dzipf(zdata$y, N = length(freq), s = s) # expected values
chisq.test(zdata$ofreq, p = probs) 
plot(zdata$y,(zdata$ofreq),log="xy") #log log graph
lines(zdata$y, (probs)*sum(zdata$ofreq),  col="red") # red line, num of predicted frequency

    Chi-squared test for given probabilities

data:  zdata$ofreq
X-squared = 99.756, df = 99, p-value = 0.4598

У нашому випадку нульова гіпотеза квадрата Chi полягає в тому, що дані поширюються відповідно до закону zipf, отже, більші р-значення підтримують твердження, що дані поширюються відповідно до нього. Зауважте, що навіть дуже великі значення p не є доказом, а лише показником.

$x = 1$$\hat{w_{x=1}}$

$\hat{w_{x=1}} = 0.4695599775$

Знову ж таки, UWSE надає лише послідовну оцінку - відсутність довірчих інтервалів, і ми можемо побачити деякий компроміс у точності. Рішення mpiktas вище - це також програма UWSE - хоча програмування потрібно. Повне пояснення оцінювача див: https://paradsp.wordpress.com/ - повністю внизу.

Моє рішення намагається доповнювати відповіді, надані mpiktas та whuber, що виконують реалізацію в Python. Наші частоти та діапазони x:

freqs = np.asarray([26486, 12053, 5052, 3033, 2536, 2391, 1444, 1220, 1152, 1039])
x = np.asarray([1, 2, 3, 4, 5 ,6 ,7 ,8 ,9, 10])

Оскільки наша функція не визначена у всьому діапазоні, нам потрібно перевіряти, що ми нормалізуємо кожного разу, коли ми її обчислюємо. У дискретному випадку просте наближення - ділити на суму всіх у (х). Таким чином ми можемо порівняти різні параметри.

f,ax = plt.subplots()
ax.plot(x, f1, 'o')
ax.set_xscale("log")
ax.set_yscale("log")

def loglik(b):  
    # Power law function
    Probabilities = x**(-b)

    # Normalized
    Probabilities = Probabilities/Probabilities.sum()

    # Log Likelihoood
    Lvector = np.log(Probabilities)

    # Multiply the vector by frequencies
    Lvector = np.log(Probabilities) * freqs

    # LL is the sum
    L = Lvector.sum()

    # We want to maximize LogLikelihood or minimize (-1)*LogLikelihood
    return(-L)

s_best = minimize(loglik, [2])
print(s_best)
ax.plot(x, freqs[0]*x**-s_best.x)

Результат дає нам нахил 1.450408, як у попередніх відповідях.