如何解决源代码中的uniroot函数无法进行修改；无法找出错误
我试图找出R中两条曲线的交点的坐标。输入数据是来自两条曲线的经验点的坐标。我的解决方案是使用功能curve_intersect()。我需要针对2000个复制（即2000对曲线）执行此操作。所以我将数据放在两个列表中。每个列表包含1000个数据框，每个数据框中的x和y坐标为一条曲线。
这是我的数据：data
下面是我使用的代码。
threshold_or1 <- map2_df(recall_or1_4,precision_or1_4,~curve_intersect(.x,.y,empirical = TRUE,domain = NULL))
# recall_or_4 is a list of 2000 data frames. Each data frame
# |contains coordinates from curve #1.
# precision_or_4 is a list of 2000 data frames. Each data frame
# |contains coordinates from curve #2.
我在下面收到此错误消息。
Error in uniroot(function(x) curve1_f(x) - curve2_f(x),c(min(curve1$x),: f() values at end points not of opposite sign
由于函数curve_intersect（）可以成功应用于两个列表中的某些单独的数据帧。我运行以下代码，以准确查看是哪一对数据帧使该过程失败。
test <- for (i in 1:2000){
curve_intersect(recall_or1_4[[i]],precision_or1_4[[i]],domain = NULL)
print(paste("i=",i))}
然后，我收到以下消息，这意味着该过程成功运行，直到到达数据对＃460。所以我检查了那个单独的数据对。
[1] "i= 457"
[1] "i= 458"
[1] "i= 459"
Error in uniroot(function(x) curve1_f(x) - curve2_f(x),: f() values at end points not of opposite sign
我绘制了数据对＃460。
test1 <- precision_or1_4[[460]] %>% mutate(statistics = 'precision')
test2 <- recall_or1_4[[460]] %>% mutate(statistics = 'recall')
test3 <- rbind(test1,test2)
test3 <- test3 %>% mutate(statistics = as.factor(statistics))
curve_test3 <- ggplot(test3,aes(x = x,y = y))+
geom_line(aes(colour = statistics))
curve_test3
Find coordinates of the intersection point
然后我去修改curve_intersect（）的源代码。原始源代码是
curve_intersect <- function(curve1,curve2,empirical=TRUE,domain=NULL) {
if (!empirical & missing(domain)) {
stop("'domain' must be provided with non-empirical curves")
}
if (!empirical & (length(domain) != 2 | !is.numeric(domain))) {
stop("'domain' must be a two-value numeric vector,like c(0,10)")
}
if (empirical) {
# Approximate the functional form of both curves
curve1_f <- approxfun(curve1$x,curve1$y,rule = 2)
curve2_f <- approxfun(curve2$x,curve2$y,rule = 2)
# Calculate the intersection of curve 1 and curve 2 along the x-axis
point_x <- uniroot(function(x) curve1_f(x) - curve2_f(x),max(curve1$x)))$root
# Find where point_x is in curve 2
point_y <- curve2_f(point_x)
} else {
# Calculate the intersection of curve 1 and curve 2 along the x-axis
# within the given domain
point_x <- uniroot(function(x) curve1(x) - curve2(x),domain)$root
# Find where point_x is in curve 2
point_y <- curve2(point_x)
}
return(list(x = point_x,y = point_y))
}
我从第三条if语句修改了uniroot()部分。我没有使用c(min(curve1$x),max(curve1$x))作为uniroot()的参数，而是使用了lower = -100000000,upper = 100000000。修改后的功能是
curve_intersect_tq <- function(curve1,lower = -100000000,upper = 100000000)$root
# Find where point_x is in curve 2
point_y <- curve2_f(point_x)
} else {
# Calculate the intersection of curve 1 and curve 2 along the x-axis
# within the given domain
point_x <- uniroot(function(x) curve1(x) - curve2(x),y = point_y))
}
我试图更改lower =,upper =参数的值。那没起效。我收到了如下所示的错误消息。
curve_intersect_tq(recall_or1_4[[460]],precision_or1_4[[460]],domain = NULL)
Error in uniroot(function(x) curve1_f(x) - curve2_f(x),:
f() values at end points not of opposite sign
我还尝试使用tidyverse软件包中的possibly(fun,NA)，希望该进程即使有错误消息也能运行。我用的时候没用
（1）possibly(curve_intersect(),NA)或
（2）possibly(uniroot(),NA)
出现相同的错误消息。
为什么会有错误消息？有什么可能的解决方案？预先感谢。
解决方法
参加聚会的时间可能会晚一些，但这就是为什么您的代码仍然失败以及您可以做什么的原因，这取决于要从分析中获取的信息：
首先，即使修改后，代码失败的原因是，您只是告诉uniroot在x中搜索更大的窗口。但是，基础曲线永远不会相交-根本找不到curve1_f(x) - curve2_f(x) == 0。
摘自uniroot的文档：
“端点处的函数值必须为相反的符号（或为零），默认情况下，extendInt =” no“。”
在原始的curve_intersect实现中，uniroot正在搜索数据中定义的x间隔（即c(min(curve1$x),max(curve1$x))）。在您的更改中，您要告诉它在x间隔[-100000000,100000000]中进行搜索。您也可以设置extendInt = "yes"，但它不会改变任何内容。
问题不在于搜索间隔，而在于approxfun！
approxfun仅对点之间的经验数据进行内插来帮助您。在您传入的数据之外，返回的函数不知道该怎么办。approxfun允许您为y指定显式值，该值应返回到根据经验定义的窗口之外（带有其参数yleft / yright）或设置{{1 }}。
在上面发布的代码中，rule决定“使用最接近的数据极限值”。因此，rule = 2不会外推您传入的数据。它只会扩展已知的数据。
我们可以绘制approxfun和curve1_f将如何在经验定义的x间隔之外延伸到无穷大：
curve2_f 
因此，现在要如何使代码不崩溃：
（破坏者：这在很大程度上取决于您要完成的项目）
- 接受，观察到的数据范围内没有任何交集。
如果您不想做任何假设，建议您将映射的函数包装在tibble( x = seq(0,1,by = 0.001),curve1_approxed = curve1_f(x),curve2_approxed = curve2_f(x) ) %>% pivot_longer(starts_with("curve"),names_to = "curve",values_to = "y") %>% ggplot(aes(x = x,y = y,color = curve)) + geom_line() + geom_vline(xintercept = c(min(curve1$x),max(curve1$x)),color = "grey75")语句中，并在开箱即用的解决方案无法给您任何结果的地方让它失败。让我们针对先前使整个系统崩溃的部分列表运行此命令：
tryCatch现在，当threshold_or1.fix1 <- map2_df(
recall_or1_4,precision_or1_4,~tryCatch({
curve_intersect(.x,.y,empirical = TRUE,domain = NULL)
},error = function(e){
return(tibble(.rows = 1))
}),.id = "i"
)
无法为您提供结果时，只有NA行。
curve_intersect- 尝试使用线性模型外推您的数据
在这种情况下，我们将使用自定义threshold_or1.fix1[459:461,] # A tibble: 3 x 3 i x y <chr> <dbl> <dbl> 1 459 0.116 0.809 2 460 NA NA 3 461 0.264 0.773函数。让我们将有问题的curve_intersect包裹在uniroot中，如果找不到根，则为每个曲线拟合一个tryCatch，让lm在拟合线性。
根据您的实验，这可能有意义，也可能没有意义，所以在这里让我担任评委。显然，如果您的数据比简单的uniroot更复杂，您可以使用其他模型...
只是为了可视化这种方法与默认方法：
lm 
您会看到tibble(
x = seq(-1,2,curve2_approxed = curve2_f(x),curve1_lm = predict(lm(y ~ x,data = curve1),newdata = tibble(x = x)),curve2_lm = predict(lm(y ~ x,data = curve2),newdata = tibble(x = x))
) %>%
pivot_longer(starts_with("curve"),color = "grey75")
在“失败”的情况下，我们使用approxfun进行了假设，即可以线性外推并在观察到的帧之外在lm周围找到一个交集。
要采用第二种方法，并在我们的搜索中包括x = 1.27的推断，您可以将以下内容放在一起：
（在这里，也仅编辑第三个lm。）
if对于您有问题的列表元素，现在尝试使用天真拟合的curve_intersect_custom <- function(curve1,curve2,empirical=TRUE,domain=NULL) {
if (!empirical & missing(domain)) {
stop("'domain' must be provided with non-empirical curves")
}
if (!empirical & (length(domain) != 2 | !is.numeric(domain))) {
stop("'domain' must be a two-value numeric vector,like c(0,10)")
}
if (empirical) {
return(
tryCatch({
# Approximate the functional form of both curves
curve1_f <- approxfun(curve1$x,curve1$y,rule = 2)
curve2_f <- approxfun(curve2$x,curve2$y,rule = 2)
# Calculate the intersection of curve 1 and curve 2 along the x-axis
point_x <- uniroot(
f = function(x) curve1_f(x) - curve2_f(x),interval = c(min(curve1$x),max(curve1$x))
)$root
# Find where point_x is in curve 2
point_y <- curve2_f(point_x)
return(list(x = point_x,y = point_y,method = "approxfun"))
},error = function(e) {
tryCatch({
curve1_lm_f <- function(x) predict(lm(y ~ x,newdata = tibble(x = x))
curve2_lm_f <- function(x) predict(lm(y ~ x,newdata = tibble(x = x))
point_x <- uniroot(
f = function(x) curve1_lm_f(x) - curve2_lm_f(x),extendInt = "yes"
)$root
point_y <- curve2_lm_f(point_x)
return(list(x = point_x,method = "lm"))
},error = function(e) {
return(list(x = NA_real_,y = NA_real_,method = NA_character_))
})
})
)
} else {
# Calculate the intersection of curve 1 and curve 2 along the x-axis
# within the given domain
point_x <- uniroot(function(x) curve1(x) - curve2(x),domain)$root
# Find where point_x is in curve 2
point_y <- curve2(point_x)
}
return(list(x = point_x,y = point_y))
}
模型进行推断：
lm希望这对了解和解决您的问题有帮助：）
版权声明：本文内容由互联网用户自发贡献，该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容， 请发送邮件至 dio@foxmail.com 举报，一经查实，本站将立刻删除。