Merge pull request #248 from kenkellner/fitList_names

Add option to fitList to auto-name models based on their formulas

7 files changed, 60 insertions, 31 deletions

diff --git a/R/unmarkedFitList.R b/R/unmarkedFitList.R
index 2974678..67e94ae 100644
--- a/R/unmarkedFitList.R
+++ b/R/unmarkedFitList.R
@@ -42,32 +42,52 @@ setClass("unmarkedFitList",
 
 
 # constructor of unmarkedFitList objects
-fitList <- function(..., fits) {
-    if(length(list(...)) > 0 & !missing(fits))
-        stop("Do not use both the '...' and 'fits' arguments")
-    if(missing(fits)) {
-        fits <- list(...)
-        isList <- sapply(fits, function(x) is.list(x))
-        if(sum(isList) > 1)
-            stop("Specify models as common-seperated objects, or use fits = 'mylist'")
-        if(isList[1L]) {
-            warning("If supplying a list of fits, use fits = 'mylist'")
-            fits <- fits[[1L]] 	# This is allowed for back-compatability.
-            }
-        if(is.null(names(fits))) {
-            c <- match.call(expand.dots = FALSE)
-            names(fits) <- as.character(c[[2]])
-            warning("Your list was unnamed, so model names were added as object names")
-            }
-        }
+fitList <- function(..., fits, autoNames=c("object","formula")) {
+  autoNames <- match.arg(autoNames)
+  if(length(list(...)) > 0 & !missing(fits))
+    stop("Do not use both the '...' and 'fits' arguments")
+  if(missing(fits)) {
+    fits <- list(...)
+    isList <- sapply(fits, function(x) is.list(x))
+    if(sum(isList) > 1)
+      stop("Specify models as common-seperated objects, or use fits = 'mylist'")
+    if(isList[1L]) {
+      warning("If supplying a list of fits, use fits = 'mylist'")
+      fits <- fits[[1L]] 	# This is allowed for back-compatability.
+    }
     if(is.null(names(fits))) {
-        names(fits) <- as.character(1:(length(fits)))
-        warning("Your list was unnamed, so model names were added as c('1','2',...)")
+      message("Your list was unnamed, so model names were added automatically")
+      if(autoNames=="formula"){
+        if(inherits(fits[[1]], c("unmarkedFitOccuMulti", "unmarkedFitOccuMS"))){
+          warning("simple formula not available, naming based on object instead", call.=FALSE)
+          autoNames <- "object"
+        } else {
+          names(fits) <- lapply(fits, function(x) gsub(" ", "", as.character(deparse(x@formula))))
         }
-    umfl <- new("unmarkedFitList", fits=fits)
-    return(umfl)
+      }
+      if(autoNames=="object"){
+        c <- match.call(expand.dots = FALSE)
+        names(fits) <- as.character(c[[2]])
+      }
     }
-
+  }
+  if(is.null(names(fits))) {
+    message("Your list was unnamed, so model names were added automatically")
+    if(autoNames=="formula"){
+        if(inherits(fits[[1]], c("unmarkedFitOccuMulti", "unmarkedFitOccuMS"))){
+        warning("simple formula not available, naming as numbers instead", call.=FALSE)
+        autoNames <- "object"
+      } else {
+        names(fits) <- lapply(fits, function(x) gsub(" ", "", as.character(deparse(x@formula))))
+      }
+    }
+    if(autoNames=="object"){
+      names(fits) <- as.character(1:(length(fits)))
+    }
+  }
+  umfl <- new("unmarkedFitList", fits=fits)
+  return(umfl)
+}
 
 setMethod("summary", "unmarkedFitList", function(object) {
     fits <- object@fits
diff --git a/man/fitList.Rd b/man/fitList.Rd
index e5047bd..e01e315 100644
--- a/man/fitList.Rd
+++ b/man/fitList.Rd
@@ -1,11 +1,12 @@
 \name{fitList}
 \alias{fitList}
 \title{constructor of unmarkedFitList objects}
-\usage{fitList(..., fits)}
+\usage{fitList(..., fits, autoNames=c("object", "formula"))}
 \description{Organize models for model selection or model-averaged prediction.}
 \arguments{
 \item{...}{Fitted models. Preferrably named.}
 \item{fits}{An alternative way of providing the models. A (preferrably named) list of fitted models.}
+\item{autoNames}{Option to change the names \code{unmarked} assigns to models if you don't name them yourself. If \code{autoNames="object"}, models in the \code{fitList} will be named based on their R object names.  If \code{autoNames="formula"}, the models will instead be named based on their formulas. This is not possible for some model types.}
 }
 \note{Two requirements exist to conduct AIC-based model-selection and model-averaging in unmarked. First, the data objects (ie, unmarkedFrames) must be identical among fitted models. Second, the response matrix must be identical among fitted models after missing values have been removed. This means that if a response value was removed in one model due to missingness, it needs to be removed from all models.
 } 
diff --git a/tests/testthat/test_fitList.R b/tests/testthat/test_fitList.R
index c33c03d..444a3a0 100644
--- a/tests/testthat/test_fitList.R
+++ b/tests/testthat/test_fitList.R
@@ -37,5 +37,9 @@ test_that("fitList operations work",{
 
   se <- SE(mt)
   expect_equal(dim(se), c(2,5))
-
+  
+  fl <- expect_message(fitList(fm, fm2, autoNames='formula'))
+  expect_equal(names(fl@fits), c("~o1+o2~x", "~1~x"))
+  fl <- expect_message(fitList(fits=list(fm, fm2), autoNames='formula'))
+  expect_equal(names(fl@fits), c("~o1+o2~x", "~1~x"))
 })
diff --git a/tests/testthat/test_modSel.R b/tests/testthat/test_modSel.R
index 14fffc2..b6d1485 100644
--- a/tests/testthat/test_modSel.R
+++ b/tests/testthat/test_modSel.R
@@ -12,11 +12,11 @@ test_that("fitLists can be constructed",{
 
   fits1.1 <- fitList(m1=fm1, m2=fm2)
   expect_equal(names(fits1.1@fits), c("m1","m2"))
-  expect_warning(fits1.2 <- fitList(fm1, fm2))
+  expect_message(fits1.2 <- fitList(fm1, fm2))
   expect_equal(names(fits1.2@fits), c("fm1","fm2"))
   fits2.1 <- fitList(fits = list(m1=fm1, m2=fm2))
   expect_equal(names(fits2.1@fits), c("m1","m2"))
-  expect_warning(fits2.2 <- fitList(fits = list(fm1, fm2)))
+  expect_message(fits2.2 <- fitList(fits = list(fm1, fm2)))
   expect_equal(names(fits2.2@fits), c("1","2"))
 
   expect_equal(fits1.1, fits2.1)
diff --git a/tests/testthat/test_occuFP.R b/tests/testthat/test_occuFP.R
index f1381bb..fc61461 100644
--- a/tests/testthat/test_occuFP.R
+++ b/tests/testthat/test_occuFP.R
@@ -22,7 +22,7 @@ test_that("occuFP model can be fit",{
   m1 <- occuFP(detformula = ~ METH, FPformula = ~1,
                stateformula = ~ habitat, data = umf1)
   expect_equal(names(m1), c("state","det","fp"))
-  expect_warning(fl <- fitList(m1,m1))
+  expect_message(fl <- fitList(m1,m1))
   expect_is(fl,"unmarkedFitList")
   expect_equal(length(fl@fits), 2)
 
diff --git a/tests/testthat/test_occuMS.R b/tests/testthat/test_occuMS.R
index aa0d024..7c25acf 100644
--- a/tests/testthat/test_occuMS.R
+++ b/tests/testthat/test_occuMS.R
@@ -227,7 +227,9 @@ test_that("occuMS can fit the multinomial model",{
   expect_equivalent(r@post[1,,1], c(0,0.5222,0.4778), tol=1e-4)
 
   #Check fitList
-  expect_warning(fl <- fitList(fit_C, fit_C))
+  expect_message(fl <- fitList(fit_C, fit_C))
+  expect_message(expect_warning(fl <- fitList(fit_C, fit_C, autoNames='formula')))
+  expect_message(expect_warning(fl <- fitList(fits=list(fit_C, fit_C), autoNames='formula')))
   expect_is(fl,"unmarkedFitList")
   expect_equivalent(length(fl@fits), 2)
 
diff --git a/tests/testthat/test_occuMulti.R b/tests/testthat/test_occuMulti.R
index fbc264a..d37cbc5 100644
--- a/tests/testthat/test_occuMulti.R
+++ b/tests/testthat/test_occuMulti.R
@@ -42,7 +42,9 @@ test_that("occuMulti can fit simple models",{
   expect_equivalent(det, rep(1,length(detlist)), tolerance= 1e-4)
 
   #Check fitList
-  expect_warning(fl <- fitList(fm, fm))
+  expect_message(fl <- fitList(fm, fm))
+  expect_message(expect_warning(fl <- fitList(fm, fm, autoNames='formula')))
+  expect_message(expect_warning(fl <- fitList(fits=list(fm, fm), autoNames='formula')))
   expect_is(fl,"unmarkedFitList")
   expect_equivalent(length(fl@fits), 2)
 
@@ -335,7 +337,7 @@ test_that("occuMulti predict method works",{
 
   #fitList with maxOrder set
   fm2 <- occuMulti(c("~1","~1"), c("~1","~1"), umf, maxOrder=1)
-  expect_warning(fl2 <- fitList(fm, fm2))
+  expect_message(fl2 <- fitList(fm, fm2))
   expect_is(fl2, "unmarkedFitList")
   ms <- modSel(fl2)
   expect_is(ms, "unmarkedModSel")