使用optimize（）查找占用R中曲线下95％面积的最短间隔

Question

背景：

我有一条曲线，其Y值由下面的我的小R函数产生（ 标明 ）。 如果运行我的整个R代码，则会看到我的曲线（但是请记住，这是一个函数，因此如果我更改参数值，我可以得到另一条曲线）：

题：

显然，可以确定/假设许多区间将覆盖/占据此曲线下总面积的95％。 但是，使用optimize() ，如何找到这些许多可能的95％间隔中最短的（以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

如果我们认为这是在尝试计算最小面积的间隔，则可以开始计算要绘制的每个区域的面积。 然后，我们可以找到最大的区域（大概会在中心附近）并开始走出去，直到找到所需的区域。

由于您已经计算出该图的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

这确实假设petasq中的所有值均等距

Answer 2

根据您修改后的问题，我发现了优化方法，该优化方法使LEFT和RIGHT边界之间的最短距离（以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和RIGHT之间的距离：

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")

公认地，这等效于在“密度”函数的整个域中构造具有归一化常数的积分函数。 间隔全都相等的事实允许从高度乘以基数计算中省去“ x”矢量的差异。

我想还有另一种可能的解释。 这将要求我们发现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％：