自动求解`ncp`的'pt'方程

Question

我想知道是否可以有效地更改代码中的ncp，以便x变为 .025 和。 975 （在舍入误差范围内）。

x <- pt(q = 5, df = 19, ncp = ?)

----------

澄清

q = 5和df = 19（上图）只是两个假设数字，因此q和df可以是任意其他两个数字。我期望的是一个函数/例程，它将q和df作为输入。

Answer 1

uniroot有什么问题？

f <- function (ncp, alpha) pt(q = 5, df = 19, ncp = ncp) - alpha

par(mfrow = c(1,2))
curve(f(ncp, 0.025), from = 5, to = 10, xname = "ncp", main = "0.025")
abline(h = 0)
curve(f(ncp, 0.975), from = 0, to = 5, xname = "ncp", main = "0.975")
abline(h = 0)

因此，对于0.025案例，根位于(7, 8);对于0.975案例，根位于(2, 3)。

uniroot(f, c(7, 8), alpha = 0.025)$root
#[1] 7.476482

uniroot(f, c(2, 3), alpha = 0.975)$root
#[1] 2.443316

---------

（经过一番讨论......）

好的，现在我看到了你的终极目标。您希望将此等式求解器实现为函数，输入为q和df。所以它们不为人知，但已修复。他们可能会从实验中走出来。

理想情况下，如果存在分析解决方案，即ncp可以按q，df和alpha的形式写成公式，那就太棒了。但是，t分布不可能。

数值解是方法，但uniroot不是一个很好的选择，因为它依赖于“plot - view - guess - specification”。 loki 的答案也很粗糙，但有一些改进。它是一种网格搜索，具有固定的步长。从0附近的值开始，比如0.001，并增加此值并检查近似误差。当这个错误没有减少时我们停止。

这确实引发了使用牛顿法或拟牛顿法进行数值优化的想法。在1D的情况下，我们可以使用函数optimize。它在搜索中执行可变步长，因此它比固定的步长搜索更快收敛。

让我们将函数定义为：

ncp_solver <- function (alpha, q, df) {
  ## objective function: we minimize squared approximation error
  obj_fun <- function (ncp, alpha = alpha, q = q, df = df) {
    (pt(q = q, df = df, ncp = ncp) - alpha) ^ 2
    }
  ## now we call `optimize`
  oo <- optimize(obj_fun, interval = c(-37.62, 37.62), alpha = alpha, q = q, df = df)
  ## post processing
  oo <- unlist(oo, use.names = FALSE)  ## list to numerical vector
  oo[2] <- sqrt(oo[2])  ## squared error to absolute error
  ## return
  setNames(oo, c("ncp", "abs.error"))
  }

注意，-37.62 / 37.62被选为ncp的下限/上限，因为它是R中t分布支持的最大值（读?dt）

例如，让我们尝试这个功能。如果您在问题中提供了q = 5和df = 19：

ncp_solver(alpha = 0.025, q = 5, df = 19)
#         ncp    abs.error
#7.476472e+00 1.251142e-07 

结果是一个命名向量，ncp和绝对近似误差。

同样我们可以这样做：

ncp_solver(alpha = 0.975, q = 5, df = 19)
#         ncp    abs.error
#2.443347e+00 7.221928e-07 

----------

跟进

  

在函数ncp_solver()中，alpha是否可能一起使用c(.025, .975)？

为什么不将它包装成“矢量化”：

sapply(c(0.025, 0.975), ncp_solver, q = 5, df = 19)

#                  [,1]         [,2]
#ncp       7.476472e+00 2.443347e+00
#abs.error 1.251142e-07 7.221928e-07

  

0.025如何给出置信区间的上限，而0.975给出置信区间的下限？这种关系应该逆转吗？

毫不奇怪。默认情况下，pt计算较低的尾部概率。如果您想要“正确”的关系，请在lower.tail = FALSE中设置pt：

ncp_solver <- function (alpha, q, df) {
  ## objective function: we minimize squared approximation error
  obj_fun <- function (ncp, alpha = alpha, q = q, df = df) {
    (pt(q = q, df = df, ncp = ncp, lower.tail = FALSE) - alpha) ^ 2
    }
  ## now we call `optimize`
  oo <- optimize(obj_fun, interval = c(-37.62, 37.62), alpha = alpha, q = q, df = df)
  ## post processing
  oo <- unlist(oo, use.names = FALSE)  ## list to numerical vector
  oo[2] <- sqrt(oo[2])  ## squared error to absolute error
  ## return
  setNames(oo, c("ncp", "abs.error"))
  }

现在你看到了：

ncp_solver(0.025, 5, 19)[[1]]  ## use "[[" not "[" to drop name
#[1] 2.443316

ncp_solver(0.975, 5, 19)[[1]]
#[1] 7.476492

--------

错误报告并修复

据报道，上述ncp_solver不稳定。例如：

ncp_solver(alpha = 0.025, q = 0, df = 98)
#      ncp abs.error 
#-8.880922  0.025000 

但另一方面，如果我们在这里仔细检查uniroot：

f <- function (ncp, alpha) pt(q = 0, df = 98, ncp = ncp, lower.tail = FALSE) - alpha
curve(f(ncp, 0.025), from = -3, to = 0, xname = "ncp"); abline(h = 0)

uniroot(f, c(-2, -1.5), 0.025)$root
#[1] -1.959961

ncp_solver显然有问题。

事实证明，我们不能使用太大的界限c(-37.62, 37.62)。如果我们将其缩小到c(-35, 35)，那就没问题了。

另外，为避免容差问题，我们可以将目标函数从平方误差更改为绝对误差：

ncp_solver <- function (alpha, q, df) {
  ## objective function: we minimize absolute approximation error
  obj_fun <- function (ncp, alpha = alpha, q = q, df = df) {
    abs(pt(q = q, df = df, ncp = ncp, lower.tail = FALSE) - alpha)
    }
  ## now we call `optimize`
  oo <- optimize(obj_fun, interval = c(-35, 35), alpha = alpha, q = q, df = df)
  ## post processing and return
  oo <- unlist(oo, use.names = FALSE)  ## list to numerical vector
  setNames(oo, c("ncp", "abs.error"))
  }

ncp_solver(alpha = 0.025, q = 0, df = 98)
#          ncp     abs.error 
#-1.959980e+00  9.190327e-07 

该死的，这是一个非常讨厌的bug。但现在放松一下。

从pt

获取警告消息的报告

我还收到一些关于来自pt的恼人警告消息的报告：

ncp_solver(0.025, -5, 19)
#          ncp     abs.error 
#-7.476488e+00  5.760562e-07
#Warning message:
#In pt(q = q, df = df, ncp = ncp, lower.tail = FALSE) :
#  full precision may not have been achieved in 'pnt{final}'

我不太确定这里发生了什么，但同时我没有发现误导结果。因此，我决定使用pt

来取消suppressWarnings的警告

ncp_solver <- function (alpha, q, df) {
  ## objective function: we minimize absolute approximation error
  obj_fun <- function (ncp, alpha = alpha, q = q, df = df) {
    abs(suppressWarnings(pt(q = q, df = df, ncp = ncp, lower.tail = FALSE)) - alpha)
    }
  ## now we call `optimize`
  oo <- optimize(obj_fun, interval = c(-35, 35), alpha = alpha, q = q, df = df)
  ## post processing and return
  oo <- unlist(oo, use.names = FALSE)  ## list to numerical vector
  setNames(oo, c("ncp", "abs.error"))
  }

ncp_solver(0.025, -5, 19)
#          ncp     abs.error 
#-7.476488e+00  5.760562e-07

好的，现在安静。

Answer 2

您可以使用两个while循环：

i <- 0.001
lowerFound <- FALSE
while(!lowerFound){
  x <- pt(q = 5, df = 19, ncp = i)
  if (round(x, 3) == 0.025){
    lowerFound <- TRUE
    print(paste("Lower is", i))
    lower <- i
  } else {
    i <- i + 0.0005
  }
}

i <- 0.001
upperFound <- FALSE
while(!upperFound){
  x <- pt(q = 5, df = 19, ncp = i)
  if (round(x, 3) == 0.975){
    upperFound <- TRUE
    print(paste("Upper is ", i))
    upper <- i
  } else {
    i <- i + 0.0005
  }
}

c(Lower = lower, Upper = upper)
#  Lower  Upper 
# 7.4655 2.4330 

当然，您可以调整i <- i + ....中的增量或更改检查if (round(x,...) == ....)以使此解决方案符合您的具体精确度需求。

Answer 3

我知道这是一个古老的问题，但是现在使用MBESS软件包中的conf.limits.nct()函数可以单线解决此问题。

install.packages("MBESS")
library(MBESS)

result <- conf.limits.nct(t.value = 5, df = 19)
result

$Lower.Limit
[1] 2.443332

$Prob.Less.Lower
[1] 0.025

$Upper.Limit
[1] 7.476475

$Prob.Greater.Upper
[1] 0.025

$Lower.Limit是pt = 0.975

的结果

$Upper.Limit是pt = 0.025

的结果

pt(q=5,df=19,ncp=result$Lower.Limit)
[1] 0.975
> pt(q=5,df=19,ncp=result$Upper.Limit)
[1] 0.025