Added negExp self-starters

OnofriAndreaPG · Nov 6, 2019 · 38b5b61 · 38b5b61
1 parent 6898d66
commit 38b5b61
Show file tree

Hide file tree

Showing 4 changed files with 81 additions and 82 deletions.
diff --git a/.DS_Store b/.DS_Store
diff --git 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
@@ -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
@@ -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