prefer vapply and lapply to sapply internally

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: pomp
 Type: Package
 Title: Statistical Inference for Partially Observed Markov Processes
-Version: 4.5.2.0
+Version: 4.5.2.1
 Date: 2023-01-04
 Authors@R: c(person(given=c("Aaron","A."),family="King",
 		role=c("aut","cre"),email="[email protected]"),

R/abc.R

@@ -286,9 +286,9 @@ abc.internal <- function (object,
   if (is.null(probes))
     pStop_(sQuote("probes")," must be specified.")
   if (!is.list(probes)) probes <- list(probes)
-  if (!all(sapply(probes,is.function)))
+  if (!all(vapply(probes,is.function,logical(1L))))
     pStop_(sQuote("probes")," must be a function or a list of functions.")
-  if (!all(sapply(probes,function(f)length(formals(f))==1)))
+  if (!all(vapply(probes,\(f)length(formals(f))==1L,logical(1L))))
     pStop_("each probe must be a function of a single argument.")
 
   if (length(scale)==0)

R/builder.R

@@ -202,9 +202,14 @@ Cbuilder <- function (..., templates, name = NULL, dir = NULL,
   ## 'registry' holds a list of functions to register
   registry <- c("__pomp_load_stack_incr","__pomp_load_stack_decr")
   ## which utilities are needed?
-  utils <- which(sapply(seq_along(pomp_templates$utilities),
-    function(x) any(grepl(pomp_templates$utilities[[x]]$trigger,
-      snippets))))
+  utils <- which(
+    vapply(
+      seq_along(pomp_templates$utilities),
+      \(x) any(grepl(pomp_templates$utilities[[x]]$trigger,
+        snippets)),
+      logical(1L)
+    )
+  )
 
   ## rely on "-I" flags under *nix
   if (.Platform$OS.type=="unix") {
@@ -384,7 +389,7 @@ cleanForC <- function (text) {
 render <- function (template, ...) {
   vars <- list(...)
   if (length(vars)==0) return(template)
-  n <- sapply(vars,length)
+  n <- vapply(vars,length,integer(1L))
   if (!all((n==max(n))|(n==1)))
     pStop("render","incommensurate lengths of replacements.") #nocov
   short <- which(n==1)

R/filter_traj.R

@@ -69,7 +69,7 @@ setMethod(
   signature=signature(object="pfilterList"),
   definition=function (object, vars, ...) {
     fts <- lapply(object,filter_traj,vars=vars,...)
-    d <- sapply(fts,dim)
+    d <- vapply(fts,dim,integer(3L))
     if (!all(apply(d,1L,function(x)x==x[1L])))
       pStop("filter_traj","incommensurate dimensions.")
     d <- d[,1L]

R/melt.R

@@ -49,7 +49,7 @@ setMethod(
   definition=function (data, ...) {
     dn <- dimnames(data)
     nullnames <- which(unlist(lapply(dn,is.null)))
-    dn[nullnames] <- lapply(nullnames,function(i)seq_len(dim(data)[i]))
+    dn[nullnames] <- lapply(nullnames,\(i)seq_len(dim(data)[i]))
     labels <- expand.grid(dn,KEEP.OUT.ATTRS=FALSE,stringsAsFactors=FALSE)
     dim(data) <- NULL
     cbind(labels,value=data)

R/mif2.R

@@ -498,7 +498,7 @@ perturbn.kernel.sd <- function (rw.sd, time, paramnames) {
     unrec <- names(rw.sd)[!names(rw.sd) %in% paramnames]
     pStop_("the following parameter(s), ",
       "given random walks in ",sQuote("rw.sd"),", are not present in ",
-      sQuote("params"),": ",paste(sapply(unrec,sQuote),collapse=","),".")
+      sQuote("params"),": ",paste(lapply(unrec,sQuote),collapse=","),".")
   }
   ivp <- function (sd, lag = 1L) {
     sd*(seq_along(time)==lag)

R/plot.R

@@ -136,7 +136,7 @@ plotpomp.internal <- function (x, variables,
     vars <- vars[-tpos]
     covnames <- unique(
       c(
-        lapply(x,function(p)get_covariate_names(p@covar)),
+        lapply(x,\(p)get_covariate_names(p@covar)),
         recursive=TRUE
       )
     )
@@ -248,11 +248,11 @@ abc.diagnostics <- function (z, pars, scatter = FALSE, ...) {
   if (missing(pars)) {
     pars <- unique(do.call(c,lapply(z,slot,"pars")))
     if (length(pars)<1)
-      pars <- unique(do.call(c,lapply(z,function(x)names(x@params))))
+      pars <- unique(do.call(c,lapply(z,\(x)names(x@params))))
   }
   if (scatter) {
-    x <- lapply(z,function(x)as.matrix(traces(x,pars)))
-    x <- lapply(seq_along(x),function(n)cbind(x[[n]],.num=n))
+    x <- lapply(z,\(x)as.matrix(traces(x,pars)))
+    x <- lapply(seq_along(x),\(n)cbind(x[[n]],.num=n))
     x <- do.call(rbind,x)
     if (ncol(x)<3) {
       pStop("plot","can't make a scatterplot with only one variable.")
@@ -350,7 +350,7 @@ mif2.diagnostics <- function (z, pars, transform) {
       matplot(
         y=sapply(
           z,
-          function (po, label) {
+          \(po, label) {
             traces(
               po,label,
               transform=(transform && label %in% estnames)

R/pomp.R

@@ -406,7 +406,7 @@ setMethod(
     if (missing(cfile)) cfile <- NULL
     if (!is.null(cfile)) {
       cfile <- as.character(cfile)
-      fnames <- unlist(sapply(data@solibs,getElement,"name"))
+      fnames <- unlist(lapply(data@solibs,getElement,"name"))
       if (any(cfile==fnames)) {
         pStop_("C file name ",dQuote(cfile)," cannot be re-used.")
       }

R/probe.R

@@ -177,9 +177,9 @@ probe.internal <- function (object, probes, nsim, seed, ...,
 
   if (is.null(probes)) pStop_(sQuote("probes")," must be furnished.")
   if (!is.list(probes)) probes <- list(probes)
-  if (!all(sapply(probes,is.function)))
+  if (!all(vapply(probes,is.function,logical(1L))))
     pStop_(sQuote("probes")," must be a function or a list of functions.")
-  if (!all(sapply(probes,function(f)length(formals(f))==1)))
+  if (!all(vapply(probes,\(f)length(formals(f))==1L,logical(1L))))
     pStop_("each probe must be a function of a single argument.")
 
   nsim <- as.integer(nsim)

R/rprocess_spec.R

@@ -305,8 +305,8 @@ gillespie_hl <- function (..., .pre = "", .post = "", hmax = Inf) {
 
   args <- list(...)
 
-  if (!all(sapply(args,inherits,what="list")) ||
-      !all(sapply(args,length) == 2L))
+  if (!all(vapply(args,inherits,what="list",logical(1L))) ||
+      !all(vapply(args,length,integer(1L)) == 2L))
     pStop(ep,"each event should be specified using a length-2 list.")
 
   codeChunks <- lapply(args,"[[",1)
@@ -328,8 +328,8 @@ gillespie_hl <- function (..., .pre = "", .post = "", hmax = Inf) {
   .pre <- paste(as(.pre,"character"),collapse="\n")
   .post <- paste(as(.post,"character"),collapse="\n")
 
-  if (!all(sapply(stoich,is.numeric)) ||
-      any(sapply(stoich,function(x)invalid_names(names(x)))))
+  if (!all(vapply(stoich,is.numeric,logical(1L))) ||
+      any(vapply(stoich,\(x)invalid_names(names(x)),logical(1L))))
     pStop(ep,"for each event, the second list-element should be ",
       "a named numeric vector (without duplicate names).")
 

R/slice_design.R

@@ -19,7 +19,7 @@ slice_design <- function (center, ...) {
     problems <- slnm[!(slnm%in%names(center))]
     pStop("slice_design",
       ngettext(length(problems),"variable ","variables "),
-      paste(sapply(problems,sQuote),collapse=","),
+      paste(lapply(problems,sQuote),collapse=","),
       ngettext(length(problems)," does "," do "),
       "not appear in ",sQuote("center"))
   }

R/sobol_design.R

@@ -29,7 +29,7 @@ sobol_design <- function (lower = numeric(0), upper = numeric(0), nseq) {
   if (!all(sort(lnames)==sort(names(upper))))
     pStop(ep,"names of ",sQuote("lower")," and ",sQuote("upper")," must match.")
   upper <- upper[lnames]
-  ranges <- lapply(seq_along(lnames),function(k)c(lower[k],upper[k]))
+  ranges <- lapply(seq_along(lnames),\(k)c(lower[k],upper[k]))
   names(ranges) <- lnames
   tryCatch(
     sobol(ranges,n=as.integer(nseq)),

R/spy.R

@@ -107,7 +107,7 @@ setMethod(
 
     if (length(object@userdata)>0) {
       cat("- extra user-defined variables: ",
-        paste(sapply(names(object@userdata),sQuote),collapse=", "),
+        paste(lapply(names(object@userdata),sQuote),collapse=", "),
         "\n")
     }