Use combn within a function for nonlinear regression with nlsLM

Question

Given is a few rows of a dataframe DATA:

> dput(DATA[c(1,7,20,25,26,53,89),])
structure(list(Lanes = c(3, 3, 3, 3, 3, 3, 3), N_b = c(5, 5, 
5, 5, 5, 5, 5), A = c(-12, -12, -15, -9, -9, -15, -9), x.sqr = 
c(1440, 1440, 2250, 810, 810, 2250, 810), e_1 = c(21.8, 21.8, 
29, 14.6, 14.6, 29, 14.6), e_2 = c(9.8, 9.8, 17, 2.6, 2.6, 17, 
2.6), e_3 = c(-2.2, -2.2, 5, -9.4, -9.4, 5, -9.4), e_4 = 
c(-14.2, -14.2, -7, 0, 0, -7, 0), e_5 = c(0, 0, -19, 0, 0, -19, 0), 
S = c(12, 12, 15, 9, 9, 15, 9), CSi = c(0.59189685884369, 
0.574916237257971, 0.644253184434141, 0.474070747691647, 
0.492033722080107, 0.644904371480046, 0.49900365977452), 
m = c(0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85)), row.names = c(1L, 
7L, 20L, 25L, 26L, 53L, 89L), class = "data.frame")

I write the function below to use for nonlinear regression with nlsLM:

library(minpack.lm)

Prposed <- function(N_b,Lanes,m,A,x.sqr,e_1,e_2,e_3,e_4,e_5,S,a) {
  e <- data.frame(e_1,e_2,e_3,e_4,e_5)
  CSi <- m * ((Lanes/N_b) + (A * combn(e,Lanes,sum) / x.sqr) * (b*S^a))
  return(CSi)
}

nlsLM <- nlsLM(CSi ~ Prposed(N_b,Lanes,m,A,x.sqr,e_1,e_2,e_3,e_4,e_5,S,a,b), 
             data = DATA, 
             start = c(a = 0.01, b = 0.01))

summary(nlsLM)

I keep getting an error and it is coming from how I am defining the columns e_1, e_2, etc.. with the combn function.

UPDATE

I found another question: Error when running nlsLM but works for nls which uses a for loop in the original function, and that seems to work fine with the nls2 function from library(nls2). I was wondering if I could get rid of the combn term altogether by going to a for loop instead.

Answer 1

This is not an actual answer since it generates a new error after fixing the combn error but this might give you some direction.

I think you are trying to run nlsLM function for each row in DATA. You need to pass each row separately in Prposed function. Also note that a and b are required in the function to perform calculation so they need to be passed as an argument of the function and I think passing them using start in nlsLM would not work.

So change your function to :

library(minpack.lm)

Prposed <- function(N_b,Lanes,m,A,x.sqr,e_1,e_2,e_3,e_4,e_5,S,a, b) {
  e <- data.frame(e_1,e_2,e_3,e_4,e_5)
  CSi <- m * ((Lanes/N_b) + (A * combn(e,Lanes,sum) / x.sqr) * (b*S^a))
  return(CSi)
}

Now let's run this for first row of DATA :

x <- DATA[1, ]
Prposed(x[[2]], x[[1]], x[[12]], x[[3]], x[[4]], x[[5]], x[[6]], x[[7]], x[[8]],
        x[[9]],x[[10]],a = 0.01, b = 0.01)

#[1] 0.5078651 0.5087365 0.5077053 0.5096079 0.5085767 0.5094481 0.5104793 
#    0.5094481 0.5103195 0.5111909

I don't know the theory so I don't know if these numbers make sense/are correct. However, when you plug this in nlsLM function it gives an error.

nlsLM(CSi~Prposed(x[[2]],x[[1]],x[[12]], x[[3]],x[[4]],x[[5]],x[[6]],x[[7]],
    x[[8]], x[[9]],x[[10]],a = 0.01, b = 0.01),data = DATA)

Error in getInitial.default(func, data, mCall = as.list(match.call(func, : no 'getInitial' method found for "function" objects

Is this because nlsLM expects a formula object but what we are passing to it is values? I am not sure.

---

Once you get the above step working you can plug this in an apply and run it as :

apply(DATA, 1, function(x) {
  nlsLM(CSi~Prposed(x[[2]],x[[1]],x[[12]], x[[3]],x[[4]],x[[5]],x[[6]],x[[7]],
    x[[8]], x[[9]],x[[10]],a = 0.01, b = 0.01), data = DATA)
})

It works and generates numbers without nlsLM function :

apply(DATA, 1, function(x) {
  Prposed(x[[2]],x[[1]],x[[12]], x[[3]],x[[4]],x[[5]],x[[6]],x[[7]],x[[8]], 
         x[[9]],x[[10]],a = 0.01, b = 0.01) 
})

#              1         7        20        25        26        53        89
# [1,] 0.5078651 0.5078651 0.5070307 0.5092470 0.5092470 0.5070307 0.5092470
# [2,] 0.5087365 0.5087365 0.5077293 0.5083395 0.5083395 0.5077293 0.5083395
# [3,] 0.5077053 0.5077053 0.5084280 0.5083395 0.5083395 0.5084280 0.5083395
# [4,] 0.5096079 0.5096079 0.5084280 0.5094980 0.5094980 0.5084280 0.5094980
# [5,] 0.5085767 0.5085767 0.5091267 0.5094980 0.5094980 0.5091267 0.5094980
# [6,] 0.5094481 0.5094481 0.5098253 0.5085905 0.5085905 0.5098253 0.5085905
# [7,] 0.5104793 0.5104793 0.5091267 0.5106565 0.5106565 0.5091267 0.5106565
# [8,] 0.5094481 0.5094481 0.5098253 0.5106565 0.5106565 0.5098253 0.5106565
# [9,] 0.5103195 0.5103195 0.5105240 0.5097490 0.5097490 0.5105240 0.5097490
#[10,] 0.5111909 0.5111909 0.5112227 0.5109075 0.5109075 0.5112227 0.5109075

Answer 2

I had to define the by row operation within the original function

Proposed <- function(N_b,Lanes,m,A,x.sqr,e_1,e_2,e_3,e_4,e_5,S,a,b) {
  e <- data.frame(e_1,e_2,e_3,e_4,e_5)
  CSi <- m * ((Lanes/N_b) + (max(A * combn(seq_along(e), Lanes, FUN = function(i) rowSums(e[i]))) / x.sqr) * (b*S^a))
  return(CSi)
}

nlsLM <- nlsLM(CSi ~ Proposed(N_b,Lanes,m,A,x.sqr,e_1,e_2,e_3,e_4,e_5,S,a,b), 
             data = DATA, 
             start = c(a = 0.01, b = 0.01))

summary(nlsLM)