根据@ahmohamed的回答更新：

Question

我正在尝试使用以下等式拟合一些数据：y= (exp(p1x1+p2x2+p3)+p4)^p5 这是一个可重复的例子：

 dat1 <- array(1:60, c(3,5,4));dat1=dat1*2
 dat2 <- array(1:60, c(3,5,4));dat2=dat2*0.5
 dat3 <- array(1:60, c(3,5,4))
 #reorder dimensions 
 dat1 <- aperm(dat1, c(3,1,2));dat2 <- aperm(dat2, c(3,1,2)) 
 dat3 <- aperm(dat3, c(3,1,2))
 #make array a matrix 
 dat1a <- dat1;dim(dat1a) <- c(dim(dat1)[1],prod(dim(dat1)[2:3])) 
 dat2a <- dat2;dim(dat2a) <- c(dim(dat2)[1],prod(dim(dat2)[2:3])) 
 dat3a <- dat3;dim(dat3a) <- c(dim(dat3)[1],prod(dim(dat3)[2:3])) 
 #function for fitting
  fun <- function(x1, x2, y) {
              keep <- !(is.na(x1) | is.na(x2) | is.na(y))
              if (sum(keep) > 1) { 
                 res <- summary(nlsLM(y[keep]~(exp(p1*x1[keep]+p2*x2[keep]+p3)+p4)^p5,  x1=x1,x2=x2,y=y, start=list(p1=4.5,p2=5,p3=3,p4=0,p5=1)))$coefficients[, 1]
              } else { 
                 res <- c(NA, NA, NA,NA,NA)
              } 
              res
          }
  #loop for fitting
  res <- mapply(fun, x1=as.data.frame(dat1a), x2=as.data.frame(dat2a),  y=as.data.frame(dat3a))

但是我收到了这个错误：

Error in fn(par, ...) : 
  unused arguments (x1 = c(2, 32, 62, 92), x2 = c(0.5, 8, 15.5, 23), y = c(1, 16, 31,

根据@ahmohamed的回答更新：

 dat2 <- array(1:60, c(3,5,4));dat2=dat2*0.5
 dat3 <- array(1:60, c(3,5,4))
 dat1=(exp(4*dat2+2*dat3+0.3)+0)^1

  #reorder dimensions 
  dat1 <- aperm(dat1, c(3,1,2));dat2 <- aperm(dat2, c(3,1,2)) 
  dat3 <- aperm(dat3, c(3,1,2))
  #make array a matrix 
  dat1a <- dat1;dim(dat1a) <- c(dim(dat1)[1],prod(dim(dat1)[2:3])) 
  dat2a <- dat2;dim(dat2a) <- c(dim(dat2)[1],prod(dim(dat2)[2:3])) 
  dat3a <- dat3;dim(dat3a) <- c(dim(dat3)[1],prod(dim(dat3)[2:3]))

   fun <- function(x1, x2, y) {
          keep <- !(is.na(x1) | is.na(x2) | is.na(y))
          if (sum(keep) > 1) { 
             res <- summary(nlsLM(y~(exp(p1*x1+p2*x2+p3)+p4)^p5,  data =   data.frame(x1=x1,x2=x2,y=y)[keep,], start=list(p1=4,p2=2,p3=0.3,p4=0,p5=1)))$coefficients[, 1]
          } else { 
             res <- c(NA, NA, NA,NA,NA)
          } 
          res
      }
    res <- mapply(fun, x1=as.data.frame(dat1a), x2=as.data.frame(dat2a),  y=as.data.frame(dat3
     error:Error in numericDeriv (form [[3L]], names (ind), env):

在模型计算中获得的缺失值或无限值

Answer 1

通过查看nlsLM中提供的example，您可以提供如下相似的参数：

fun <- function(x1, x2, y) {
              keep <- !(is.na(x1) | is.na(x2) | is.na(y))
              if (sum(keep) > 1) { 
                 res <- summary(nlsLM(y~(exp(p1*x1+p2*x2+p3)+p4)^p5,  data = data.frame(x1=x1,x2=x2,y=y)[keep,], start=list(p1=4.5,p2=5,p3=3,p4=0,p5=1)))$coefficients[, 1]
              } else { 
                 res <- c(NA, NA, NA,NA,NA)
              } 
              res
          }

我修改了调用函数nlsLM：

nlsLM(y~(exp(p1*x1+p2*x2+p3)+p4)^p5,  
   data = data.frame(x1=x1,x2=x2,y=y)[keep,],
   start=list(p1=4.5,p2=5,p3=3,p4=0,p5=1))

将所有data分组到一个data.frame中，完全如文档示例所示。当然，您可以通过[keep,]

从NA-contianing行中过滤生成的数据框

现在mapply会将数据框列提供给您的函数。

使用上述函数运行代码仍会引发错误：

res <- mapply(fun, x1=as.data.frame(dat1a), x2=as.data.frame(dat2a),  y=as.data.frame(dat3a)) 

Error in summary(nlsLM(y ~ (exp(p1 * x1 + p2 * x2 + p3) + p4)^p5, data = data.frame(x1 = x1,  : 
  error in evaluating the argument 'object' in selecting a method for function 'summary': Error in nlsModel(formula, mf, start, wts) : 
  singular gradient matrix at initial parameter estimates

出于以下三个原因可能会发生这种情况：

您的变量（dat1，dat2）是dependent（您的数据就是这种情况），因此总是会产生一个奇异的矩阵。使用更多随机变量修改数据将克服这个问题。

代码：

set.seed(123)
x1 = matrix(runif(50), ncol=5)
x2 = matrix(runif(50), ncol=5)
y = (exp(p1*x1+p2*x2+p3)+p4)^p5 #calculate y with known parameters for testing

初始参数start使矩阵成为单数。这可以通过将初始参数设置为 real 参数来测试：

代码：

y = (exp(4.5*x1 + 5*x2 + 3)+0)^1 ## setting p1~p5 similar to our start argument
mapply(fun, x1=as.data.frame(x1), x2=as.data.frame(x2),  y=as.data.frame(y))

您需要修改您想要修改的曲线（details here）。将公式简化为y~(exp(p1*x1+p2*x2+p3)将删除所有错误。

<强>功能

fun <- function(x1, x2, y) {
    keep <- !(is.na(x1) | is.na(x2) | is.na(y))
    if (sum(keep) > 1) { 
       res <- summary(nlsLM(y~exp(p1*x1+p2*x2+p3),  
                    data = data.frame(x1=x1,x2=x2,y=y)[keep,], 
                    start=list(p1=4.5,p2=5,p3=3))
            )$coefficients[, 1]
    } else { 
       res <- c(NA, NA, NA,NA,NA)
    } 
    res
}

<强>测试

set.seed(123)
x1 = matrix(runif(50), ncol=5)
x2 = matrix(runif(50), ncol=5)

y = exp(4*x1 + 3*x2 + 3) ## True parameters: p1=4, p2=3, p3=3

mapply(fun, x1=as.data.frame(x1), x2=as.data.frame(x2),  y=as.data.frame(y))

<强>结果

   V1 V2 V3 V4 V5
p1  4  4  4  4  4
p2  3  3  3  3  3
p3  3  3  3  3  3

R中的“nlsLM”面临错误？

根据@ahmohamed的回答更新：

1 个答案: