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