Use combn within a function for nonlinear regression with nlsLM - r

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)