https://github.com/cran/emplik
Raw File
Tip revision: 6499006531aa58c62dc136e7a2daf03dfbc5aa36 authored by Mai Zhou on 07 September 2023, 17:00:02 UTC
version 1.3-1
Tip revision: 6499006
el.test.wt.R
eltestwtinC <- function(x, wt, mu) {
    Lx <- length(x)
    lam0 <- 0
    if (any(is.na(x))) stop("NaNs") ## if (sum(is.na(x))>0)stop('NaNs');
    re <- .C("eltestwt",
        x = as.numeric(x),
        wt = as.numeric(wt),
        mu1 = as.double(mu), ## added as.double() 3/2015 by M Zhou
        Lx1 = Lx,
        prob = as.numeric(x),
        lamre = as.double(lam0), ## added as.double() 3/2015 by M Zhou
        package = "emplik"
    )
    return(list(x = re$x, wt = re$wt, prob = re$prob, lam = re$lamre))
}


el.test.wt <- function(x, wt, mu, usingC = TRUE) {
    if (length(mu) != 1) stop("mu must be a scalar")

    if (usingC) {
        return(eltestwtinC(x, wt, mu))
    } else {
        xmu <- x - mu
        allw <- sum(wt)
        BU <- 0.02 * allw / max(abs(xmu))

        lamfun <- function(lam, xmu, wt, allw) {
            sum(wt * xmu / (allw + lam * xmu))
        }

        if (lamfun(0, xmu, wt, allw) == 0) {
            lam0 <- 0
        } else {
            if (lamfun(0, xmu, wt, allw) > 0) {
                lo <- 0
                up <- BU
                while (lamfun(up, xmu, wt, allw) > 0) {
                    up <- up + BU
                }
            } else {
                up <- 0
                lo <- -BU
                while (lamfun(lo, xmu, wt, allw) < 0) {
                    lo <- lo - BU
                }
            }
            lam0 <- uniroot(lamfun, lower = lo, upper = up, tol = 1e-9, xmu = xmu, wt = wt, allw = allw)$root
        }
        prob <- wt / (allw + lam0 * xmu)
        return(list(x = x, wt = wt, prob = prob, lam = lam0))
    }
}
### add output of lam0, 5/2007
###  Can simplify by use the uniroot() option entendInt="yes".
###  Comment added 10/28/2021  M Zhou
back to top