summary.lm输出定制

Question

我希望我的lm摘要输出比平时更紧凑一些。我想删除一些新行，“残差”部分，与“系数”一词的行。积极的一面是，summary.lm是作为一个本机R函数编写的，所以我可以将它复制到一个文件中，修改它，然后通过我的.Rprofile来获取它。消极的一面是，当我尝试第一步(复制到emacs并将其源化)时，它会抱怨没有找到qr.lm。有魔法吗，还是我遗漏了什么？

我该如何重新定义它？

summary.lm <- function(object, correlation = FALSE, symbolic.cor = FALSE,
      print.residstable = TRUE, succinct = FALSE, ...)

我得到的一切都不是理想的。如果上游的人对summary.lm做了更改，我将不得不重做我的代码。但是，在没有参数来控制打印的冗长性的情况下，我不知道如何做到这一点。

Answer 1

实际上，重新定义summary.lm是实现您想要做的事情的方法。

您所缺少的是R.中命名空间的概念，summary.lm是一个来自stats包的函数，因此可以访问该包的内部函数。在加载包后，只导出来自包的某些函数并使其可用。

qr.lm正是这样一个内部函数。可以使用三重:::操作符访问它(参见?/：)：

> qr.lm
Error: object 'qr.lm' not found

> stats::qr.lm
Error: 'qr.lm' is not an exported object from 'namespace:stats'

> stats:::qr.lm
function (x, ...) 
{
    if (is.null(r <- x$qr)) 
        stop("lm object does not have a proper 'qr' component.\n Rank zero or should not have used lm(.., qr=FALSE).")
    r
}
<bytecode: 0x0000000017983b68>
<environment: namespace:stats>

如您所见，它只提取lm对象的qr组件。您可以直接粘贴代码，而不是调用函数。

Answer 2

需要更改的是print.summary.lm函数，而不是summary.lm。下面是一个添加了“简明”选项的版本，注意不要在简明错误的情况下更改任何内容：

print.summary.lm <- 
function (x, digits = max(3L, getOption("digits") - 3L), symbolic.cor = x$symbolic.cor,
          signif.stars = getOption("show.signif.stars"), concise = FALSE, ...)
    {
        cat("\nCall:", if(!concise) "\n" else " ", paste(deparse(x$call), sep = "\n", collapse = "\n"),
            if (!concise) "\n\n", sep = "")
        resid <- x$residuals
        df <- x$df
        rdf <- df[2L]
        if (!concise) {
            cat(if (!is.null(x$weights) && diff(range(x$weights)))
                    "Weighted ", "Residuals:\n", sep = "")
        }
        if (rdf > 5L) {
            nam <- c("Min", "1Q", "Median", "3Q", "Max")
            rq <- if (length(dim(resid)) == 2L)
                      structure(apply(t(resid), 1L, quantile), dimnames = list(nam,
                                                                   dimnames(resid)[[2L]]))
                  else {
                      zz <- zapsmall(quantile(resid), digits + 1L)
                      structure(zz, names = nam)
                  }
            if (!concise) print(rq, digits = digits, ...)
        }
        else if (rdf > 0L) {
            print(resid, digits = digits, ...)
        }
        else {
            cat("ALL", df[1L], "residuals are 0: no residual degrees of freedom!")
            cat("\n")
        }
        if (length(x$aliased) == 0L) {
            cat("\nNo Coefficients\n")
        }
        else {
            if (nsingular <- df[3L] - df[1L])
                cat("\nCoefficients: (", nsingular, " not defined because of singularities)\n",
                    sep = "")
            else { cat("\n"); if (!concise) cat("Coefficients:\n")  }
            coefs <- x$coefficients
            if (!is.null(aliased <- x$aliased) && any(aliased)) {
                cn <- names(aliased)
                coefs <- matrix(NA, length(aliased), 4, dimnames = list(cn,
                                                            colnames(coefs)))
                coefs[!aliased, ] <- x$coefficients
            }
            printCoefmat(coefs, digits = digits, signif.stars = signif.stars, signif.legend = (!concise),
                         na.print = "NA", eps.Pvalue = if (!concise) .Machine$double.eps else 1e-4, ...)
        }
        cat("\nResidual standard error:", format(signif(x$sigma,
                                                        digits)), "on", rdf, "degrees of freedom")
        cat("\n")
        if (nzchar(mess <- naprint(x$na.action)))
            cat("  (", mess, ")\n", sep = "")
        if (!is.null(x$fstatistic)) {
            cat("Multiple R-squared: ", formatC(x$r.squared, digits = digits))
            cat(",\tAdjusted R-squared: ", formatC(x$adj.r.squared,
                                                   digits = digits), "\nF-statistic:", formatC(x$fstatistic[1L],
                                                       digits = digits), "on", x$fstatistic[2L], "and",
                x$fstatistic[3L], "DF,  p-value:", format.pval(pf(x$fstatistic[1L],
                                                                  x$fstatistic[2L], x$fstatistic[3L], lower.tail = FALSE),
                                                               digits = digits, if (!concise) .Machine$double.eps else 1e-4))
            cat("\n")
        }
        correl <- x$correlation
        if (!is.null(correl)) {
            p <- NCOL(correl)
            if (p > 1L) {
                cat("\nCorrelation of Coefficients:\n")
                if (is.logical(symbolic.cor) && symbolic.cor) {
                    print(symnum(correl, abbr.colnames = NULL))
                }
                else {
                    correl <- format(round(correl, 2), nsmall = 2,
                                     digits = digits)
                    correl[!lower.tri(correl)] <- ""
                    print(correl[-1, -p, drop = FALSE], quote = FALSE)
                }
            }
        }
        cat("\n")
        invisible(x)
    }

而现在

x <- rnorm(100); y <- rnorm(100)+x
print(summary(lm(y ~ x)))
print(summary(lm(y ~ x)), concise=TRUE)

通过第一次打印传递标准R打印结果，而后一次传递

Call: lm(formula = y ~ x)
            Estimate Std. Error t value Pr(>|t|)
(Intercept)   -0.010      0.102   -0.10     0.92
x              1.009      0.112    9.02  <0.0001 ***

Residual standard error: 1.02 on 98 degrees of freedom
Multiple R-squared:  0.454, Adjusted R-squared:  0.448
F-statistic: 81.4 on 1 and 98 DF,  p-value: <0.0001

PS:对于实际数据，这需要更严重的统计:单个系数的p值现在限制在0.0001，而不限于机器的精度。

如果R团队正在听，IMHO这应该是一个标准的R功能。

Answer 3

这更像是一个旁白，而不是你的问题。

在包中经常使用(我认为)编辑函数的一种方法是edit，它不仅是很好地获得源代码格式化的好方法，而且它还使用名称空间，这样您就不必搜索qr.lm并在全局中重新定义它，或者为函数找到它需要做的任何事情。

我把它放进去，做一个总结，它非常冗长。

(tmp <- summary(fit <- lm(mpg ~ disp, data = mtcars)))

# Call:
#   lm(formula = mpg ~ disp, data = mtcars)
# 
# Residuals:
#   Min      1Q  Median      3Q     Max 
# -4.8922 -2.2022 -0.9631  1.6272  7.2305 
# 
# Coefficients:
#   Estimate Std. Error t value Pr(>|t|)    
# (Intercept) 29.599855   1.229720  24.070  < 2e-16 ***
#   disp        -0.041215   0.004712  -8.747 9.38e-10 ***
#   ---
#   Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
# 
# Residual standard error: 3.251 on 30 degrees of freedom
# Multiple R-squared:  0.7183,  Adjusted R-squared:  0.709 
# F-statistic: 76.51 on 1 and 30 DF,  p-value: 9.38e-10

edit，并基本上将所有代码替换为function (x) qr.lm(x)，并注意到qr.lm不是导出的，这意味着您需要显式地告诉r在哪里查找，否则它将无法工作，如下所示，在my_summ2中

下面是新的定义，注意我不需要使用stats:::qr.lm和这个新函数所在的环境

(my_summ <- edit(stats:::print.summary.lm))
# function (x) qr.lm(x)
# <environment: namespace:stats>

这就是你可能会尝试做同样的事情，但现在环境是全球性的。

(my_summ2 <- function (x) qr.lm(x))
# function (x) qr.lm(x)

因此，我可以尝试使用这两种方法，但只能使用第一种方法。

my_summ(fit)
# $qr
# (Intercept)          disp
# Mazda RX4            -5.6568542 -1.305160e+03
# Mazda RX4 Wag         0.1767767  6.900614e+02
# Datsun 710            0.1767767  1.624463e-01
# Hornet 4 Drive        0.1767767 -5.492561e-02
# Hornet Sportabout     0.1767767 -2.027385e-01
# Valiant               0.1767767 -7.103778e-03
# ...

my_summ2(fit)
# Error in my_summ2(fit) : could not find function "qr.lm"

但两者都是全球的

ls()
# [1] "fit"      "my_summ"  "my_summ2" "tmp"