SH: doBy

CRAN-SUBMISSION

@@ -1,3 +1,3 @@
-Version: 4.6.24
-Date: 2024-10-07 19:46:42 UTC
-SHA: 808da86e05b77cb938fa916100637443eea8269c
+Version: 4.6.25
+Date: 2025-01-29 21:14:31 UTC
+SHA: e0fc0658ef42d704e64c9510f257ea96dfccbdef

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: doBy
-Version: 4.6.24
+Version: 4.6.25
 Title: Groupwise Statistics, LSmeans, Linear Estimates, Utilities 
 Authors@R: c(
     person(given = "Ulrich", family = "Halekoh",

NAMESPACE

@@ -76,7 +76,6 @@ export(as_rhs_chr)
 export(as_rhs_frm)
 export(binomial_to_bernoulli_data)
 export(bquote_fun_list)
-export(col_basis)
 export(cv_glm_fitlist)
 export(descStat)
 export(doby.xtabs)
@@ -105,17 +104,14 @@ export(is_grouped)
 export(lapplyBy)
 export(lapply_by)
 export(lastobs)
-export(left_null_basis)
 export(linest)
 export(lmBy)
 export(lm_by)
 export(matrix2set_list)
 export(mb_summary)
 export(model_stability_glm)
-export(null_basis)
 export(orderBy)
 export(order_by)
-export(orth_comp_basis)
 export(parseGroupFormula)
 export(plot_lm)
 export(popMeans)
@@ -125,7 +121,6 @@ export(recover_pca_data)
 export(renameCol)
 export(response_plot)
 export(rle2)
-export(row_basis)
 export(sampleBy)
 export(sample_by)
 export(sapplyBy)

NEWS.md

@@ -1,3 +1,8 @@
+doBy v4.6.25 (Release date: 2025-01-29)
+=======================================
+
+* Various minor changes; too many to remember.
+
 doBy v4.6.24 (Release date: 2024-10-07)
 =======================================
 

R/by_lmBy.R

@@ -36,8 +36,6 @@
 #' coef(summary(bb))
 #' coef(summary(bb), simplify=TRUE)
 
-
-
 #' @export
 #' @rdname by-lmby
 lm_by <- function (data, formula, id=NULL, ...) {
@@ -49,8 +47,6 @@ lm_by <- function (data, formula, id=NULL, ...) {
     eval(cl)
 }
 
-
-
 #' @export
 #' @rdname by-lmby
 lmBy <- function(formula, data, id=NULL, ...){
@@ -146,8 +142,9 @@ coef.lmBy <- function(object, augment=FALSE, ...){
 fitted.lmBy <- function(object, augment=FALSE, ...){
   ans <- lapply(object, fitted)
   if (augment) {
-    ans <- mapply(function(a,b){data.frame(.fit=a,b)}, ans, getBy(object, "dataList"),
-                  SIMPLIFY=FALSE)
+      ans <- mapply(function(a,b){
+          data.frame(.fit=a,b)
+      }, ans, getBy(object, "dataList"), SIMPLIFY=FALSE)
   }
   ans
 }
@@ -156,8 +153,9 @@ fitted.lmBy <- function(object, augment=FALSE, ...){
 residuals.lmBy <- function(object, augment=FALSE, ...){
   ans <- lapply(object, residuals)
   if (augment) {
-    ans <- mapply(function(a,b){data.frame(.fit=a,b)}, ans, getBy(object, "dataList"),
-                  SIMPLIFY=FALSE)
+      ans <- mapply(function(a,b){
+          data.frame(.fit=a,b)
+      }, ans, getBy(object, "dataList"), SIMPLIFY=FALSE)
   }
   ans
 }

R/expr_to_fun.R

@@ -1,5 +1,3 @@
-##ee <- expression(matrix(c(a, b, 0, b, a, b, 0, b, a), nrow = 3))
-
 #' Convert expression into function object.
 #'
 #' @param expr_ R expression.
@@ -8,27 +6,22 @@
 #'
 #' @examples
 #'
-#' ee <- expression(b1 + (b0 - b1)*exp(-k*x) + b2*x)
-#' ff <- expr_to_fun(ee)
-#'
+#' ee  <- expression(b1 + (b0 - b1)*exp(-k*x) + b2*x)
+#' ff1 <- expr_to_fun(ee)
+#' formals(ff1)
+#' 
+#' ff2 <- expr_to_fun(ee, vec_arg=TRUE)
+#' formals(ff2)
+#' formals(ff2)$length_parm
+#' formals(ff2)$names_parm |> eval()
+#' 
 #' ee <- expression(matrix(c(x1+x2, x1-x2, x1^2+x2^2, x1^3+x2^3), nrow=2))
-#' ff <- expr_to_fun(ee)
+#' ff1 <- expr_to_fun(ee)
+#' ff2 <- expr_to_fun(ee, vec_arg=TRUE)
 #'
-#' ee <- expression(
-#'   matrix(
-#'     c(8 * x1 * (4 * x1^2 - 625 * x2^2 - 2 * x2
-#'     - 1) + 9 * x1 - 20 * x2 * (x3 + 0.473809523809524 + exp(-x1 *
-#'     x2)/20) * exp(-x1 * x2) - 3 * cos(x2 * x3) - 4.5,
-#'     -20 * x1 * (x3 + 0.473809523809524 + exp(-x1 * x2)/20) * exp(-x1 * x2) + 3 * x3 *
-#'     (x1 - cos(x2 * x3)/3 - 0.5) * sin(x2 * x3) + (-1250 * x2 - 2) * (4
-#'     * x1^2 - 625 * x2^2 - 2 * x2 - 1),
-#'     3 * x2 * (x1 - cos(x2 * x3)/3 -
-#'     0.5) * sin(x2 * x3) + 400 * x3 + 189.52380952381 + 20 * exp(-x1 *
-#'     x2)), nrow = 3))
-#' f1 <- expr_to_fun(ee)
-#' f2 <- expr_to_fun(ee, vec_arg=TRUE)
-#' ## Note: how long should parm be in f2?
-#' formals(f2)$length_parm
+#' formals(ff2)
+#' formals(ff2)$length_parm
+#' formals(ff2)$names_parm |> eval()
 #' 
 #' @export
 expr_to_fun <- function(expr_, order=NULL, vec_arg=FALSE) {
@@ -69,8 +62,10 @@ expr_to_one_param_fun <- function(e, order=NULL) {
     }
 
     comb <- c(aux, e_str)    
+
+    uuu <- paste("c(",paste0(sQuote(nms, q="'"), collapse=", "), ")")
 
-    fun_str <- sprintf("function(parm, length_parm=%d)", length(nms))
+    fun_str <- sprintf("function(parm, length_parm=%d, names_parm=%s)", length(nms), uuu)
 
     bd <- paste0("\n{ \n ", paste0(comb, collapse=";\n "), "\n}")
 

R/linest_LSmeans.R

@@ -26,8 +26,7 @@
 #' 
 #' @return A dataframe with results from computing the contrasts.
 #'
-#' @note \code{LSmeans} and \code{popMeans} are synonymous. Some of
-#'     the code has been inspired by the \bold{lsmeans} package.
+#' @note \code{LSmeans} and \code{popMeans} are synonymous. 
 #' 
 #' @section Warning: Notice that \code{LSmeans} and \code{LE_matrix}
 #'     fails if the model formula contains an offset (as one would

R/linest_matrix.R

@@ -128,15 +128,6 @@ LE_matrix.default <- function(object, effect=NULL, at=NULL){
 }
 
 
-
-## OLD
-## LE_matrix.default <- function(object, effect=NULL, at=NULL){
-##     out <- get_linest_list(object, effect, at)
-##     out <- aggregate_linest_list (out)
-##     class(out) <- c("linest_matrix_class", "matrix")
-##     out
-## }
-
 #' @export
 #' @rdname linest-matrix
 aggregate_linest_list <- function (linest_list){
@@ -240,10 +231,10 @@ get_linest_list <- function(object, effect=NULL, at=NULL){
             }
         }
 
-        XXlist <- list(get_X(object, newdata=newdata, at=NULL))
-        ## cat("XXlist:\n"); print(XXlist)
-        attr(XXlist, "at")   <- at[intersect(vartype$numeric, names(at))]
-        attr(XXlist, "grid") <- NULL
+        out_list <- list(get_X(object, newdata=newdata, at=NULL))
+        ## cat("out_list:\n"); print(out_list)
+        attr(out_list, "at")   <- at[intersect(vartype$numeric, names(at))]
+        attr(out_list, "grid") <- NULL
     }
     else
     {
@@ -254,27 +245,24 @@ get_linest_list <- function(object, effect=NULL, at=NULL){
         ## nfl <<- new.fact.lev
         ## gd <<- grid.data
         ##str(list(new.fact.lev=new.fact.lev, grid.data=grid.data))
-
-        ## cat("HHHH grid.data\n")
-        ## print(grid.data)
 
-        XXlist    <- list()
+        out_list    <- list()
         for (ii in 1:nrow(grid.data)){
             config    <- grid.data[ii, ,drop=FALSE ]
             fact.lev2 <- set_xlevels(fact.lev, at=config)
             newdata   <- expand.grid(fact.lev2)
             newdata[, cov.ave.name]  <- cov.ave
             XX             <- get_X(object, newdata=newdata, at=at)
-            XXlist[[ ii ]] <- XX
+            out_list[[ ii ]] <- XX
         }
 
         grid.data[, names(cov.ave) ] <- cov.ave
-        attr(XXlist, "at") <- at
-        attr(XXlist, "grid") <- grid.data
-        attr(XXlist, "offset") <- attr(XX, "offset")  ## FIXME: reference to XX; what is offset?
+        attr(out_list, "at") <- at
+        attr(out_list, "grid") <- grid.data
+        attr(out_list, "offset") <- attr(XX, "offset")  ## FIXME: reference to XX; what is offset?
     }
-    class(XXlist) <- "linest_list_class"
-    XXlist
+    class(out_list) <- "linest_list_class"
+    out_list
 }
 
 

R/linest_utilities.R

@@ -21,9 +21,6 @@
 #' @author Søren Højsgaard, \email{sorenh@@math.aau.dk}
 #' @references \url{http://web.mit.edu/18.06/www/Essays/newpaper_ver3.pdf}
 #' @keywords utilities
-#' @examples
-#' 
-#' ## TO BE WRITTEN
 #' 
 #' @export is_estimable
 is_estimable <- function(K, null.basis){
@@ -41,3 +38,6 @@ is_estimable <- function(K, null.basis){
 }
 
 
+null_basis <- function(M){
+    MASS::Null(t(M))
+}