stats::nls() function in the TERR does not support port option

the stats::nls() function in the TERR, despite the version of R being 4.0.2 and despite nls showing that “port” is an option for the algorithm argument and the upper/lower arguments are available. Looks like TERR does not support the port algorithm in nls(). This would be essential to fix as nls would be the most common method used in R for non-linear least squares regression and the port algorithm is necessary for constraining.

Cloud Software Group, Inc. Confidential Information
Copyright (C) 1988-2024 Cloud Software Group, Inc. ALL RIGHTS RESERVED
Spotfire Enterprise Runtime for R version 6.1.2 for Microsoft Windows 64-bit

Type 'help()' for help.
Type 'q()' to quit.

R.Version()$version.string
[1] "TIBCO Enterprise Runtime for R version 6.1.2 (2024-02-22)"
paste( version$major, version$minor, sep=",")
[1] "4,0.2"
nls
function (formula, data = parent.frame(), start, control = nls.control(), algorithm = c("default", "plinear", "port"), trace =
FALSE, subset, weights, na.action, model = FALSE, lower = -Inf, upper = Inf, ...)
{
call <- match.call()
controlArg <- control
control <- nls.control()
control[names(controlArg)] <- controlArg
algorithm <- match.arg(algorithm)
if (!missing(lower) || !missing(upper)) {
warning("The 'lower' and 'upper' arguments to 'nls' are ignored")
}
if (algorithm == "port") {
warning("The 'port' algorithm is not yet supported by 'nls', will use the 'default' algorithm")
algorithm <- "default"
}
formula <- as.formula(formula, env = parent.frame())
enclos <- environment(formula)
if (is.list(data)) {
dataNms <- names(data)
if (length(data) > 0) {
if (is.null(dataNms) || any(dataNms == "") || anyDuplicated(dataNms)) {
stop("elements of 'data' should have distinct, non-null names")
}
}
}
else if (is.environment(data)) {
dataNms <- objects(data, all = TRUE)
}
else {
stop("'data' should be an environment or a list")
}
if (length(formula) == 2) {
LHS <- 0
}
else {
LHS <- formula[[2]]
}
RHS <- formula[[length(formula)]]
formulaVars <- all.vars(formula)
if (missing(start)) {
fixedVars <- intersect(formulaVars, dataNms)
if (is.call(RHS) && is.name(SSfunc <- RHS[[1]]) && inherits(SSfunc <- eval(SSfunc, data, enclos), "selfStart")) {
start <- getInitial(formula, data)
paramVars <- names(start)
}
else {
paramVars <- setdiff(formulaVars, dataNms)
start <- structure(rep(1, length(paramVars)), names = paramVars)
warning("No starting values given, setting the following parameters to 1.0: ", sQuote(paramVars), ". Consider supplying the 'start' argument or using a 'selfStart' objective function")
}
}
else {
paramVars <- names(start)
if (length(start) > 0) {
if (is.null(paramVars) || anyNA(paramVars) || any(paramVars == "")) {
stop("'start' should have distinct, non-null names")
}
}
fixedVars <- setdiff(formulaVars, paramVars)
}
start <- lapply(start, as.numeric)
modelFrameCall <- call
modelFrameCall[[1]] <- quote(model.frame)
modelFrameCall$start <- modelFrameCall$control <- modelFrameCall$algorithm <- modelFrameCall$trace <- modelFrameCall$model
<- modelFrameCall$lower <- modelFrameCall$upper <- NULL
fixedVarLengths <- vapply(fixedVars, FUN.VALUE = 0, FUN = function(nm) {
value <- tryCatch(NROW(eval(as.name(nm), data, enclos)), error = function(e) -1)
})
fixedVarsInModelFrame <- fixedVars[fixedVarLengths == max(fixedVarLengths, 0)]
fixedVarsNotInModelFrame <- setdiff(fixedVars, fixedVarsInModelFrame)
names(fixedVarsNotInModelFrame) <- fixedVarsNotInModelFrame
modelFrameCall$formula <- formula(call("~", Reduce(function(a, b) call("+", a, b), lapply(fixedVarsInModelFrame, as.name)))
, env = enclos)
modelFrameCall$data <- data
modelFrame <- eval(modelFrameCall, data, enclos)
env <- new.env(parent = enclos)
list2env(modelFrame, envir = env)
list2env(lapply(fixedVarsNotInModelFrame, function(nm) eval(as.name(nm), data, enclos)), envir = env)
weights <- env$(weights)
response <- eval(LHS, env)
m <- list()
mEnv <- new.env(parent = environment(sys.function()))
mEnv$thisEnv <- mEnv
mEnv$env <- env
m$getEnv <- local(envir = mEnv, function() env)
mEnv$enclos <- enclos
mEnv$formula <- formula
mEnv$nonlinParNames <- names(start)
m$formula <- local(envir = mEnv, function() formula)
m$getAllPars <- local(envir = mEnv, function() coefficients)
m$getResiduals <- local(envir = mEnv, function() resid)
m$fitted <- local(envir = mEnv, function() fittedValues)
if (algorithm == "default") {
mEnv$coefficients <- nlsfit.default(start, RHS, response, mEnv, weights = weights, control = control, trace = trace)
m$Rmat <- local(envir = mEnv, function() qr.R(gaussNewtonFit$qr))
cl <- c("nlsModel")
}
else if (algorithm == "plinear") {
m$Rmat <- local(envir = mEnv, function() {
linearCoef <- coefficients[setdiff(names(coefficients), nonlinParNames)]
Phi <- numericDeriv(weightedRhs, nonlinParNames, rho = env)
grad <- attr(Phi, "gradient")
if (length(dim(grad)) < 3) {
dim(grad) <- c(dim(grad), rep(1L, 3L - length(dim(grad))))
}
tmat <- cbind(matrix(unlist(lapply(seq_len(dim(grad)[3]), function(k) grad[, , k] %*% matrix(lin))), nrow = NROW(Phi)), Phi)
qr.R(qr(tmat))
})
mEnv$coefficients <- nlsfit.plinear(start, RHS, response, mEnv, weights = weights, control = control, trace = trace)
mEnv$lin <- mEnv$coefficients[setdiff(names(mEnv$coefficients), mEnv$nonlinParNames)]
cl <- c("nlsModel.plinear", "nlsModel")
}
else {
stop("algorithm ", sQuote(algorithm), " is not implemented")
}
structure(list(m = structure(m, class = cl), convInfo = mEnv$convInfo, data = substitute(data), call = call, na.action = attr(modelFrame, "na.action"), weights = weights, control = control), class = "nls")
}
<environment: stats>
attr(,"name")
[1] "stats"