R：求解變量（使用 uniroot 函數）

Question

我對 R 比較陌生，確實可能需要社區的幫助來解決以下問題。 我正在嘗試求解以下方程中的變量 r： (EPS2 + r*DPS1-EPS1)/r^2)-PRC 。 這是我解決問題的（失敗）嘗試（使用 uniroot 函數）：

EPS2 = df_final$EPS2

DPS1 = df_final$DPS1

EPS1 = df_final$EPS1

PRC = df_final$PRC

f1 = function(r) {
    ((df_final_test$EPS2 + r * df_final_test$DPS1-df_final_test$EPS1)/r^2)-df_final_test$PRC 
}

uniroot(f1,interval = c(1e-8,100000),EPS2, DPS1, EPS1, PRC , extendInt="downX")$root

然后我收到以下錯誤： f(lower, ...) 中的錯誤：未使用的參數 (c(" 1.39", " 1.39", ...

我很感激你們可以就這個問題給我的任何提示和提示。 或者在這種情況下是否使用不同的功能/包會更好。

添加了一個 reprex (?) 以防有人幫助我解決這個問題：

df <- structure(list(EPS1 = c(6.53, 1.32, 1.39, 1.71, 2.13), DPS1 = c(2.53, 0.63,
0.81, 1.08, 1.33, 19.8), EPS2 = c(7.57,1.39,1.43,1.85,2.49), PRC = c(19.01,38.27,44.82,35.27,47.12)), .Names = c("EPS1", "DPS1", "EPS2", "PRC"), row.names = c(NA,
-5L), class = "data.frame")

Answer 1

如果所有系數都是向量而不是標量，我認為您不能使用uniroot 。 在這種情況下，一種直接的方法是以數學方式解決它們，即，

r1 <- (DPS1 + sqrt(DPS1^2-4*PRC*(EPS1-EPS2)))/(2*PRC)

和

r2 <- (DPS1 - sqrt(DPS1^2-4*PRC*(EPS1-EPS2)))/(2*PRC)

其中r1和r2是兩個根。

Answer 2

免責聲明：我沒有使用uniroot()經驗，也不知道以下是否有意義，但它可以運行！ 這個想法基本上是為數據幀的每一行調用uniroot 。

請注意，我稍微修改了函數f1因此每個附加參數都必須作為函數的參數傳遞，並且不依賴於在父環境中查找具有相同名稱的對象。 我還使用with來避免為每個變量調用df$... 。

library(tidyverse)
#> Warning: package 'ggplot2' was built under R version 4.1.0
library(furrr)
#> Loading required package: future


df <- structure(list(EPS1 = c(6.53, 1.32, 1.39, 1.71, 2.13),
                     DPS1 = c(2.53, 0.63, 0.81, 1.08, 1.33, 19.8),
                     EPS2 = c(7.57,1.39,1.43,1.85,2.49),
                     PRC = c(19.01,38.27,44.82,35.27,47.12)),
                .Names = c("EPS1", "DPS1", "EPS2", "PRC"),
                row.names = c(NA,-5L), class = "data.frame")
df
#> Warning in format.data.frame(if (omit) x[seq_len(n0), , drop = FALSE] else x, :
#> corrupt data frame: columns will be truncated or padded with NAs
#>   EPS1  DPS1 EPS2   PRC
#> 1 6.53  2.53 7.57 19.01
#> 2 1.32  0.63 1.39 38.27
#> 3 1.39  0.81 1.43 44.82
#> 4 1.71  1.08 1.85 35.27
#> 5 2.13  1.33 2.49 47.12

f1 = function(r, EPS2, DPS1, EPS1, PRC) {
  (( EPS2 + r *  DPS1 - EPS1)/r^2) - PRC 
}

# try for first row 
with(df, 
     uniroot(f1, 
             EPS2=EPS2[1], DPS1=DPS1[1], EPS1=EPS1[1], PRC=PRC[1],
             interval = c(1e-8,100000), 
             extendInt="downX")$root)
#> [1] 0.3097291
# it runs! 


# loop over each row
vec_sols <- rep(NA, nrow(df))
for (i in seq_along(1:nrow(df))) {
  
  sol <- with(df, uniroot(f1, 
                          EPS2=EPS2[i], DPS1=DPS1[i], EPS1=EPS1[i], PRC=PRC[i],
                          interval = c(1e-8,100000), 
                          extendInt="downX")$root)
  vec_sols[i] <- sol
}
vec_sols
#> [1] 0.30972906 0.05177443 0.04022946 0.08015686 0.10265226


# Alternatively, you can use furrr's future_map_dbl to use multiple cores.
# the following will basically do the same as the above loop. 
# here with 4 cores. 
plan(multisession, workers = 4)
vec_sols <- 1:nrow(df) %>% furrr::future_map_dbl(
  .f = ~with(df, 
             uniroot(f1, 
                     EPS2=EPS2[.x], DPS1=DPS1[.x], EPS1=EPS1[.x], PRC=PRC[.x],
                     interval = c(1e-8,100000), 
                     extendInt="downX")$root
  ))
vec_sols
#> [1] 0.30972906 0.05177443 0.04022946 0.08015686 0.10265226


# then apply the solutions back to the dataframe (each row to each solution)
df %>% mutate(
  root = vec_sols
)
#> Warning in format.data.frame(if (omit) x[seq_len(n0), , drop = FALSE] else x, :
#> corrupt data frame: columns will be truncated or padded with NAs
#>   EPS1  DPS1 EPS2   PRC       root
#> 1 6.53  2.53 7.57 19.01 0.30972906
#> 2 1.32  0.63 1.39 38.27 0.05177443
#> 3 1.39  0.81 1.43 44.82 0.04022946
#> 4 1.71  1.08 1.85 35.27 0.08015686
#> 5 2.13  1.33 2.49 47.12 0.10265226

^{由reprex 包( v2.0.0 ) 於 2021 年 6 月 20 日創建}