From 38b5b61405b798d58f23849af1b7912d14be20d0 Mon Sep 17 00:00:00 2001 From: Andrea Onofri Date: Wed, 6 Nov 2019 11:48:39 +0100 Subject: [PATCH] Added negExp self-starters --- .DS_Store | Bin 6148 -> 6148 bytes NAMESPACE | 1 + R/negExp.R | 80 +++++++++++++++++++++++++++++++++++++++++++++ R/selfStarters.R | 82 ----------------------------------------------- 4 files changed, 81 insertions(+), 82 deletions(-) create mode 100644 R/negExp.R diff --git a/.DS_Store b/.DS_Store index 7dca739c344dee59376c70f792ab7ca59fe1c099..19582aa423afc60ecf4884f412f52689a4e5081f 100644 GIT binary patch delta 80 zcmZoMXfc=|&Zs)EPh!NbAWzA^DT^JIPzMM01?3P79y M#9*-5QRFZ)02~e+%m4rY diff --git a/NAMESPACE b/NAMESPACE index 399b61c..599cd84 100755 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,6 +8,7 @@ export(angularTransform, expoGrowth.fun, NLS.expoGrowth, DRC.expoGrowth, expoDecay.fun, NLS.expoDecay, DRC.expoDecay, EXD.fun, asymReg.fun, NLS.asymReg, DRC.asymReg, DRC.SSasymp, + negExp.fun, NLS.negExp, DRC.negExp, YL.fun, NLS.YL, DRC.YL, cousens85.fun, DRC.cousens85, powerCurve.fun, NLS.powerCurve, DRC.powerCurve, diff --git a/R/negExp.R b/R/negExp.R new file mode 100644 index 0000000..45db303 --- /dev/null +++ b/R/negExp.R @@ -0,0 +1,80 @@ +#Negative exponential Function ################################################# +negExp.fun <- function(predictor, a, c) { + x <- predictor + a * (1 - exp (- c * x)) +} + +negExp.Init <- function(mCall, LHS, data) { + xy <- sortedXyData(mCall[["predictor"]], LHS, data) + x <- xy[, "x"]; y <- xy[, "y"] + plateau <- max(y) * 1.05 + ## Linear regression on pseudo y values + pseudoY <- log( 1 - (y / plateau ) ) + coefs <- coef( lm(pseudoY ~ x - 1) ) + a <- plateau + c <- - coefs[1] + value <- c(a, c) + names(value) <- mCall[c("a", "c")] + value +} + +NLS.negExp <- selfStart(negExp.fun, negExp.Init, parameters=c("a", "c")) + +"DRC.negExp" <- +function(fixed = c(NA, NA), names = c("a", "c")) +{ + ## Checking arguments + numParm <- 2 + if (!is.character(names) | !(length(names) == numParm)) {stop("Not correct 'names' argument")} + if (!(length(fixed) == numParm)) {stop("Not correct 'fixed' argument")} + + ## Fixing parameters (using argument 'fixed') + notFixed <- is.na(fixed) + parmVec <- rep(0, numParm) + parmVec[!notFixed] <- fixed[!notFixed] + + ## Defining the non-linear function + fct <- function(x, parm) + { + parmMat <- matrix(parmVec, nrow(parm), numParm, byrow = TRUE) + parmMat[, notFixed] <- parm + + a <- parmMat[, 1]; c <- parmMat[, 2] + a * (1 - exp (- c * x)) + } + + ## Defining self starter function + ssfct <- function(dataf) + { + x <- dataf[, 1] + y <- dataf[, 2] + + plateau <- max(y) * 1.05 + + ## Linear regression on pseudo y values + pseudoY <- log( 1 - (y / plateau ) ) + coefs <- coef( lm(pseudoY ~ x - 1) ) + a <- plateau + c <- - coefs[1] + + return(c(a, c)[notFixed]) + } + + ## Defining names + pnames <- names[notFixed] + + ## Defining derivatives + + ## Defining the ED function + + ## Defining the inverse function + + ## Defining descriptive text + text <- "Negative exponential function" + + ## Returning the function with self starter and names + returnList <- list(fct = fct, ssfct = ssfct, names = pnames, text = text, noParm = sum(is.na(fixed))) + + class(returnList) <- "drcMean" + invisible(returnList) +} diff --git a/R/selfStarters.R b/R/selfStarters.R index 0aab7e1..0f57f48 100644 --- a/R/selfStarters.R +++ b/R/selfStarters.R @@ -418,88 +418,6 @@ function(fixed = c(NA, NA), names = c("init", "k")) invisible(returnList) } - -#Negative exponential ########################################################### -negExp.fun <- function(predictor, a, c) { - x <- predictor - a * (1 - exp (- c * x)) -} - -negExp.Init <- function(mCall, LHS, data) { - xy <- sortedXyData(mCall[["predictor"]], LHS, data) - x <- xy[, "x"]; y <- xy[, "y"] - plateau <- max(y) * 1.05 - ## Linear regression on pseudo y values - pseudoY <- log( 1 - (y / plateau ) ) - coefs <- coef( lm(pseudoY ~ x - 1) ) - a <- plateau - c <- - coefs[1] - value <- c(a, c) - names(value) <- mCall[c("a", "c")] - value -} - -NLS.negExp <- selfStart(negExp.fun, negExp.Init, parameters=c("a", "c")) - -"DRC.negExp" <- -function(fixed = c(NA, NA), names = c("a", "c")) -{ - ## Checking arguments - numParm <- 2 - if (!is.character(names) | !(length(names) == numParm)) {stop("Not correct 'names' argument")} - if (!(length(fixed) == numParm)) {stop("Not correct 'fixed' argument")} - - ## Fixing parameters (using argument 'fixed') - notFixed <- is.na(fixed) - parmVec <- rep(0, numParm) - parmVec[!notFixed] <- fixed[!notFixed] - - ## Defining the non-linear function - fct <- function(x, parm) - { - parmMat <- matrix(parmVec, nrow(parm), numParm, byrow = TRUE) - parmMat[, notFixed] <- parm - - a <- parmMat[, 1]; c <- parmMat[, 2] - a * (1 - exp (- c * x)) - } - - ## Defining self starter function - ssfct <- function(dataf) - { - x <- dataf[, 1] - y <- dataf[, 2] - - plateau <- max(y) * 1.05 - - ## Linear regression on pseudo y values - pseudoY <- log( 1 - (y / plateau ) ) - coefs <- coef( lm(pseudoY ~ x - 1) ) - a <- plateau - c <- - coefs[1] - - return(c(a, c)[notFixed]) - } - - ## Defining names - pnames <- names[notFixed] - - ## Defining derivatives - - ## Defining the ED function - - ## Defining the inverse function - - ## Defining descriptive text - text <- "Negative exponential function" - - ## Returning the function with self starter and names - returnList <- list(fct = fct, ssfct = ssfct, names = pnames, text = text, noParm = sum(is.na(fixed))) - - class(returnList) <- "drcMean" - invisible(returnList) -} - #Negative exponential ########################################################### negExpDist.fun <- function(predictor, c) { x <- predictor