単純グッド・チューリング推定法 (Simple Good-Turing Estimation) とは何ぞや？

sgt <- function(r, Nr) {
    # number of words
    N <- sum(r * Nr)
    d <- diff(r)
    
    # Turing estimate
    {
        # turing estimate index
        ti <- which(d == 1)
        # discount coefficients of Turing estimate
        dct <- numeric(length(r))
        dct[ti] <- (r[ti] + 1) / r[ti] * c(Nr[-1], 0)[ti] / Nr[ti]
    }
    
    # Linear Good-Turing estimate
    {
        #Zr <- Nr / c(1, 0.5 * diff(r, lag = 2), r[length(r)] - r[length(r) - 1])
        Zr <- Nr / c(1, 0.5 * (d[-1] + d[-length(d)]), d[length(d)])
        f <- lsfit(log(r), log(Zr))
        coef <- f$coef
        # corrected term frequency
        rc <- r * (1 + 1 / r)^(1 + coef[2])  
        # discount coefficients of Linear Good-Turing estimate
        dclgt <- rc / r
    }
    
    
    # make switch from Turing to LGT estimates
    {
        # standard deviation of term frequencies between 'r' and 'rc' (?)
        rsd <- rep(1,length(r))        
        rsd[ti] <- (seq_len(length(r))[ti] + 1) / Nr[ti] * sqrt(Nr[ti + 1] * (1 + Nr[ti + 1] / Nr[ti]))
        
        dc <- dct
        for (i in 1:length(r)) {
            if (abs(dct[i] - dclgt[i]) * r[i] / rsd[i] <= 1.65) {
                dc[i:length(dc)] <- dclgt[i:length(dc)]
                break
            }
        }
    }
    
    # renormalize the probabilities for observed objects
    {
        # summation of probabilities
        sump <- sum(dc * r * Nr) / N
        # renormalized discount coefficients
        dcr <- (1 - Nr[1] / N) * dc / sump
    }
    
    # term frequency
    tf <- c(Nr[1] / N, r * dcr)
    p <- c(Nr[1] / N, r * dcr / N)
    names(p) <- names(tf) <- c(0, r)        
    
    list(p = p, r = tf)
}


# comarison between Laplace smoothing and Simple Good-Turing estimation
compare <- function(tf, N0 = NULL) {
    # Laplace Smoothing
    tbl <- table(tf)
    r <- as.integer(names(tbl))
    Nr <- as.integer(tbl)
    if (!is.null(N0)) {
        Nr[1] <- N0
    }
    N <- sum(r * Nr)
    p <- (r + 1) / (N + sum(Nr))
    names(p) <- r
    lsp <- list(p = p, r =  p * N)
    cat("Laplace Smoothing\n")
    print(head(lsp$r))
    cat("\n")
    
    # Simple Good-Turing Estimation
    if (is.null(N0)) {
        N0 <- sum(tf == 0)
    }
    r <- r[-1]
    Nr <- Nr[-1]
    sgtp <- sgt(r, Nr)
    sgtp$p[1] <- sgtp$p[1] / N0
    cat("Simple Good Turing estimation\n")
    print(head(sgtp$r))
    cat("\n")
}

library(RMeCab)

d <- t(docMatrix2("data/writers/"))

train.index <- c(1:3, 5, 6)
tf <- colSums(d[train.index,])
compare(tf)
compare(tf, 100000)

$ R --slave -f tmp.R
file_name =  data/writers//ogai_gan.txt opened
file_name =  data/writers//ogai_kanoyoni.txt opened
file_name =  data/writers//ogai_niwatori.txt opened
file_name =  data/writers//ogai_vita.txt opened
file_name =  data/writers//soseki_eijitsu.txt opened
file_name =  data/writers//soseki_garasu.txt opened
file_name =  data/writers//soseki_omoidasu.txt opened
file_name =  data/writers//soseki_yume.txt opened
number of extracted terms = 5209
to make matrix now

Laplace Smoothing
        0         1         2         3         4         5 
0.7569295 1.5138591 2.2707886 3.0277182 3.7846477 4.5415772 

Simple Good Turing estimation
        0         1         2         3         4         5 
0.1259478 0.6147441 1.3373734 2.2621483 3.2214393 4.1980137 

Laplace Smoothing
        0         1         2         3         4         5 
0.1351457 0.2702914 0.4054372 0.5405829 0.6757286 0.8108743 

Simple Good Turing estimation
        0         1         2         3         4         5 
0.1259478 0.6147441 1.3373734 2.2621483 3.2214393 4.1980137