使用optimize（）找到R中曲线下95％面积的最短区间

Question

背景

我有一条曲线，其Y值是由我的小 R函数（ 整齐注释 ）生成的。如果你运行我的整个R代码，你会看到我的曲线（但请记住，这是一个函数，所以如果我改变了参数值，我可以获得不同的曲线）：

问题：

显然，可以确定/假设多个间隔，这将覆盖/占据此曲线下总面积的95％。但是，使用optimize()，如何找到这些可能的95％间隔的 SHORTEST（以x值为单位）？然后，这个最短的95％间隔的两端的相应x值是什么？

注意： 像我这样的单模态曲线的最短间隔的想法是有道理的。实际上，最短的那个是倾向于朝向高度（y值）较大的中间的那个，所以那么x值不需要如此大以使预期的间隔覆盖/采取95曲线下总面积的百分比。

这是我的R代码（请运行整个代码）：

ppp <- function(f, N, df1, df2, petasq, alpha, beta) {

 pp <- function(petasq) dbeta(petasq, alpha, beta)
 ll <- function(petasq) df(f, df1, df2, (petasq * N) / (1 - petasq) )

 marg <- integrate(function(x) pp(x)*ll(x), 0, 1)[[1]]

po <- function(x) pp(x)*ll(x) / marg
return(po(petasq) )

}
## @@@ END OF MY R FUNCTION.

# Now I use my function above to get the y-values for my plot:

petasq  <- seq(0, 1, by = .0001) ## These are X-values for my plot
f  <- 30       # a function needed argument
df1 <- 3       # a function needed argument
df2 <- 108     # a function needed argument
N  <- 120      # a function needed argument
alpha = 5      # a function needed argument
beta = 4       # a function needed argument


## Now use the ppp() function to get the Y-values for the X-value range above:
y.values <- ppp(f, N, df1, df2, petasq, alpha, beta)

## Finally plot petasq (as X-values) against the Y.values:
plot(petasq, y.values, ty="l", lwd = 3 )

Answer 1

如果我们将此视为尝试计算具有最小面积的区间，我们可以开始计算我们正在绘制的每个区域的面积。然后我们可以找到最大的区域（可能会在中心附近）并开始走出去，直到找到我们正在寻找的区域。

由于您已经计算了图表的%macro ScanDirec(STRING=); filename temptree pipe 'dir "&STRING" /s /b' lrecl=5000; data SmallList; infile temptree truncover; input dirlist $char1000.; run; data BigList; set BigList SmallList; run; %mend ScanDirec; data SmallList; run; data BigList; run; data _null_; set Directories; call execute('%ScanDirectories('||directory||')'); run; 和x值，因此我会重复使用这些值来保存一些计算。这是该算法的实现

y

我们用

来称呼它

pseduoarea <- function(x, y, target=.95) {
  dx <- diff(x)
  areas <- dx * .5 * (head(y,-1) + tail(y, -1))
  peak <- which.max(areas)
  range <- c(peak, peak)
  found <- areas[peak]
  while(found < target) {
    if(areas[range[1]-1] > areas[range[2]+1]) {
      range[1] <- range[1]-1
      found <- found + areas[range[1]-1]
    } else {
      range[2] <- range[2]+1
      found <- found + areas[range[2]+1]
    }   
  }
  val<-x[range]
  attr(val, "indexes")<-range
  attr(val, "area")<-found
  return(val)
}

这假设pseduoarea(petasq, y.values) # [1] 0.3194 0.5413 中的所有值均等间隔

Answer 2

根据您修改后的问题，我发现优化可以最小化LEFT和RIGHT边界之间的SHORTEST距离（以x值为单位）：

ppp <- function(petasq, f, N, df1, df2, alpha, beta) {

 pp <- function(petasq) dbeta(petasq, alpha, beta)
 ll <- function(petasq) df(f, df1, df2, (petasq * N) / (1 - petasq) )

 marg <- integrate(function(x) pp(x)*ll(x), 0, 1)[[1]]

po <- function(x) pp(x)*ll(x) / marg
return(po(petasq) )
}

petasq  <- seq(0, 1, by = .0001) ## These are X-values for my plot
f  <- 30       # a function needed argument
df1 <- 3       # a function needed argument
df2 <- 108     # a function needed argument
N  <- 120      # a function needed argument
alpha = 5      # a function needed argument
beta = 4       # a function needed argument

optim_func <- function(x_left) {
    int_function <- function(petasq) {
        ppp(petasq, f=f, N=N, df1=df1, df2=df2, alpha=alpha, beta=beta)
    }

    # For every LEFT value, find the corresponding RIGHT value that gives 95% area.  

    find_95_right <- function(x_right) {
        (0.95 - integrate(int_function, lower=x_left, upper=x_right, subdivisions = 10000)$value)^2
    }
    x_right_obj <- optimize(f=find_95_right, interval=c(0.5,1))
    if(x_right_obj$objective > .Machine$double.eps^0.25) return(100)

    #Return the DISTANCE BETWEEN LEFT AND RIGHT
    return(x_right_obj$minimum - x_left)
}

#MINIMIZE THE DISTANCE BETWEEN LEFT AND RIGHT
x_left <- optimize(f=optim_func, interval=c(0.30,0.40))$minimum
find_95_right <- function(x_right) {
    (0.95 - integrate(int_function, lower=x_left, upper=x_right, subdivisions = 10000)$value)^2
}
    int_function <- function(petasq) {
        ppp(petasq, f=f, N=N, df1=df1, df2=df2, alpha=alpha, beta=beta)
    }
x_right <- optimize(f=find_95_right, interval=c(0.5,1))$minimum

请参阅代码中的注释。希望这最终满足你的问题:)结果：

> x_right
[1] 0.5409488
> x_left
[1] 0.3201584

此外，您可以将左边和右边之间的距离绘制为左边界的函数：

left_x_values <- seq(0.30, 0.335, 0.0001)
DISTANCE <- sapply(left_x_values, optim_func)

plot(left_x_values, DISTANCE, type="l")

Answer 3

我认为你不需要使用优化（除非这是未完成的家庭作业的一部分）。相反，只需将累积总和标准化并找出符合条件的点：

> which(cusm.y >= 0.025)[1]
[1] 3163
> which(cusm.y >= 0.975)[1]
[1] 5375

您可以检查这些是用于从petasq向量中提取值的合理索引：

abline( v= c( petasq[  c( which(cusm.y >= 0.025)[1], which(cusm.y >= 0.975)[1])]),
        col="red")

这无疑等同于在＆＃34;密度＆＃34;的范围内构建具有归一化常数的积分函数。功能。间隔全部具有相同维度的事实允许从高度乘以基数计算中省略＆＃34; x＆＃34; -vector的差分。

我想有另一种解释可能。这将要求我们发现需要将petasq的升序排序版本的多少值合计为总和的95％。这给出了不同的策略，该图显示了水平线与曲线相交的位置：

which( cumsum( sort( y.values, decreasing=TRUE) ) > 0.95* sum(y.values, na.rm=TRUE) )[1]
#[1] 2208
sort( y.values, decreasing=TRUE)[2208]
#[1] 1.059978
png()
  plot(petasq, y.values, ty="l", lwd = 3 )
  abline( h=sort( y.values, decreasing=TRUE)[2208], col="blue")
dev.off()

要获取petasq值，您需要确定超过该值的第一个y.values，然后确定低于该值的下一个y.values。这些可以通过以下方式获得：

order(y.values, decreasing=TRUE)[2208]
#[1] 3202
order(y.values, decreasing=TRUE)[2209]
#[1] 5410

然后情节看起来像：

png(); plot(petasq, y.values, ty="l", lwd = 3 )
      abline( v=  petasq[  c(3202, 5410)], col="blue", lty=3, lwd=2)
dev.off()

两条蓝色虚线之间的区域是零线以上总面积的95％：