generalize reformulate() such that drop.terms(terms( ~ x), 1) works

git-svn-id: https://svn.r-project.org/R/trunk@87779 00db46b3-68df-0310-9c12-caf00c1e9a41

Author: maechler

doc/NEWS.Rd

@@ -608,6 +608,10 @@
       desirable according to option \code{max.print}, or argument
       \code{max}, respectively, addressing most of the remaining part of
       \PR{15027}, thanks to \I{Sherry Zhang}'s patch.
+
+      \item \code{drop.terms(y ~ w, 1)} and similar now work, thanks to
+      \I{Benjamin Sommer}'s report in \PR{18861} and collaboration with
+      \I{Heather Turner} improving \code{reformulate()}.
     }
   }
 }

src/library/stats/R/models.R

@@ -1,7 +1,7 @@
 #  File src/library/stats/R/models.R
 #  Part of the R package, https://www.R-project.org
 #
-#  Copyright (C) 1995-2024 The R Core Team
+#  Copyright (C) 1995-2025 The R Core Team
 #
 #  This program is free software; you can redistribute it and/or modify
 #  it under the terms of the GNU General Public License as published by
@@ -183,8 +183,9 @@ delete.response <- function (termobj)
 reformulate <- function (termlabels, response=NULL, intercept = TRUE, env = parent.frame())
 {
     ## an extension of formula.character()
-    if(!is.character(termlabels) || !length(termlabels))
-        stop("'termlabels' must be a character vector of length at least one")
+    if(!is.character(termlabels))
+        stop("'termlabels' must be a character vector")
+    if(intercept && !length(termlabels)) termlabels <- "1"
     termtext <- paste(termlabels, collapse = "+")
     if(!intercept) termtext <- paste(termtext, "- 1")
     terms <- str2lang(termtext)

src/library/stats/man/delete.response.Rd

@@ -1,6 +1,6 @@
 % File src/library/stats/man/delete.response.Rd
 % Part of the R package, https://www.R-project.org
-% Copyright 1995-2024 R Core Team
+% Copyright 1995-2025 R Core Team
 % Distributed under GPL 2 or later
 
 \name{delete.response}
@@ -11,6 +11,8 @@ delete.response(termobj)
 reformulate(termlabels, response = NULL, intercept = TRUE, env = parent.frame())
 
 drop.terms(termobj, dropx = NULL, keep.response = FALSE)
+
+termobj[i]
 }
 \alias{reformulate}
 \alias{drop.terms}
@@ -19,13 +21,13 @@ drop.terms(termobj, dropx = NULL, keep.response = FALSE)
 \arguments{
   \item{termobj}{a \code{\link[=terms.object]{terms}} object.}
   \item{termlabels}{character vector giving the right-hand side of a
-    model formula.  Cannot be zero-length.}
+    model formula.  May be zero-length.}
   \item{response}{a character string, symbol or call giving the left-hand
     side of a model formula, or \code{NULL}.}
   \item{intercept}{logical: should the formula have an intercept?}
   \item{env}{the \code{\link{environment}} of the \code{\link{formula}}
     returned.}
-  \item{dropx}{a numeric vector indexing \code{labels(termobj)}
+  \item{dropx, i}{a numeric vector indexing \code{labels(termobj)}
     (that is, the \code{"term.labels"} attribute of \code{termobj}),
     indicating terms to be dropped from the right-hand side of the
     model, or \code{NULL} (default) to keep all terms.}
@@ -48,10 +50,10 @@ drop.terms(termobj, dropx = NULL, keep.response = FALSE)
   back compatibly, with a deprecation warning.
 }
 \value{
-  \code{delete.response} and \code{drop.terms} return a \code{terms}
+  \code{delete.response} and \code{drop.terms} return a \code{\link{terms}}
   object.
 
-  \code{reformulate} returns a \code{formula}.
+  \code{reformulate} returns a \code{\link{formula}}.
 }
 \seealso{\code{\link{terms}}}
 

tests/reg-tests-1e.R

@@ -1853,6 +1853,19 @@ stopifnot(identical(print(quantile(x, 0.7, type=2)),
 ## was 973  in R <= 4.4.x
 
 
+## drop.terms(<"one" term>, 1) should work, PR#18861
+stopifnot(exprs = {
+    identical( ~  1, reformulate(character()))
+    identical( ~ -1, reformulate(character(), intercept = FALSE))
+    identical(terms( ~ 1 ), drop.terms(terms(y ~ 1 + w), 1))
+    identical(terms( ~ 1 ), drop.terms(terms(y ~     w), 1))
+    identical(terms( ~ -1), drop.terms(terms(y ~ w - 1), 1))
+    identical(terms( ~ -1), drop.terms(terms(y ~ w + 0), 1))
+    identical(terms(y ~ 1), drop.terms(terms(y ~ w), 1, keep.response = TRUE))
+})
+## all these used to error in reformulate()  in R < 4.5.0
+
+
 
 ## keep at end
 rbind(last =  proc.time() - .pt,