1#  File src/library/utils/R/modifyList.R
2#  Part of the R package, https://www.R-project.org
3#
4#  Copyright (C) 1995-2019 The R Core Team
5#
6#  This program is free software; you can redistribute it and/or modify
7#  it under the terms of the GNU General Public License as published by
8#  the Free Software Foundation; either version 2 of the License, or
9#  (at your option) any later version.
10#
11#  This program is distributed in the hope that it will be useful,
12#  but WITHOUT ANY WARRANTY; without even the implied warranty of
13#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14#  GNU General Public License for more details.
15#
16#  A copy of the GNU General Public License is available at
17#  https://www.R-project.org/Licenses/
18
19### Originates from Deepayan Sarkar as  updateList() from 'lattice' package
20
21modifyList <- function(x, val, keep.null = FALSE)
22{
23    stopifnot(is.list(x), is.list(val))
24    xnames <- names(x)
25    vnames <- names(val)
26    ## Will not update unnamed components.  FIXME: What if names are repeated? Warn?
27    vnames <- vnames[nzchar(vnames)]
28    if (keep.null) {
29        for (v in vnames) {
30            x[v] <-
31                if (v %in% xnames && is.list(x[[v]]) && is.list(val[[v]]))
32                    list(modifyList(x[[v]], val[[v]], keep.null = keep.null))
33                else val[v]
34        }
35    }
36    else {
37        for (v in vnames) {
38            x[[v]] <-
39                if (v %in% xnames && is.list(x[[v]]) && is.list(val[[v]]))
40                    modifyList(x[[v]], val[[v]], keep.null = keep.null)
41                else val[[v]]
42        }
43    }
44    x
45}
46
47
48## Originally from package 'nlme' -- used in its lmList() and nlsList():
49
50## Collect errors from a list 'x',
51## produce a "summary warning" and keep that as "warningMsg" attribute
52warnErrList <- function(x, warn = TRUE, errValue = NULL) {
53    errs <- vapply(x, inherits, NA, what = "error")
54    if(any(errs)) {
55        v.err <- x[errs]
56        e.call <- deparse1(conditionCall(v.err[[1]]), collapse = "\n")
57        tt <- table(vapply(v.err, conditionMessage, ""))
58        msg <-
59            if(length(tt) == 1L)
60                sprintf(ngettext(tt[[1L]],
61                                 "%d error caught in %s: %s",
62                                 "%d times caught the same error in %s: %s"),
63                        tt[[1L]], e.call, names(tt)[[1L]])
64            else ## at least two different errors caught
65                paste(gettextf(
66                    "%d errors caught in %s.  The error messages and their frequencies are",
67                    sum(tt), e.call),
68                    paste(capture.output(sort(tt)), collapse="\n"), sep="\n")
69
70        if(warn)
71            warning(msg, call. = FALSE, domain = NA)
72        x[errs] <- list(errValue)
73        attr(x, "warningMsg") <- msg
74    }
75    x
76}
77