R/linking_haberman_compute_lts_mean.R

In sirt: Supplementary Item Response Theory Models

## File Name: linking_haberman_compute_lts_mean.R
## File Version: 0.08

linking_haberman_compute_lts_mean <- function(x, w, lts_prop, maxiter=10)
{
    res <- linking_haberman_remove_missings_vector(x=x,w=w)
    x <- res$x
    w <- res$w
    n <- length(x)
    k <- max(2, ceiling(n*lts_prop))
    if (n < k){
        k <- n
    }
    index <- 1:k
    m1 <- stats::weighted.mean(x=x, w=w)
    iter <- 0
    iterate <- TRUE
    dfr <- data.frame(index=1:n, x=x, e=x-m1, w=w)
    while(iterate){
        m0 <- m1
        dfr <- dfr[ order(abs(dfr$e)), ]
        m1 <- stats::weighted.mean(x=dfr$x[1:k], w=dfr$w[1:k])
        dfr$e <- dfr$x - m1
        iter <- iter + 1
        if (iter>maxiter){ iterate <- FALSE }
        if (abs(m0-m1) < 1e-4 ){ iterate <- FALSE }
    }
    res <- m1
    return(res)
}