在R中绘制轮廓似然曲线

Question

我试图弄清楚如何绘制GLM的轮廓似然曲线 在同一图上具有95％pLCI的参数。我一直在尝试的例子 以下是。我得到的情节不是我的可能性曲线 期待着。图的y轴是tau，我想要那个轴 是一种可能性，以便我有一个最大值参数的曲线 估计。我不确定在哪里找到这些可能性值？我可能只是 误解了这背后的理论。感谢您提供任何帮助。

最高

clotting <- data.frame(
u = c(5,10,15,20,30,40,60,80,100),
lot1 = c(118,58,42,35,27,25,21,19,18),
lot2 = c(69,35,26,21,18,16,13,12,12))
glm2<-glm(lot2 ~ log(u), data=clotting, family=Gamma)
prof<-profile(glm2)
plot(prof) 

Answer 1

重新生成您的示例：

clotting <- data.frame(
                       u = c(5,10,15,20,30,40,60,80,100),
                       lot1 = c(118,58,42,35,27,25,21,19,18),
                       lot2 = c(69,35,26,21,18,16,13,12,12))
glm2 <- glm(lot2 ~ log(u), data=clotting, family=Gamma)

profile.glm函数实际上存在于MASS包中：

library(MASS)
prof<-profile(glm2)

要了解profile.glm和plot.profile正在做什么，请参阅?profile.glm和?plot.profile。但是，为了深入研究profile对象，检查MASS:::profile.glm和MASS:::plot.profile的代码也很有用......基本上，这些代码告诉你的是{{1} }返回带符号的平方根，它由偏差和最小偏差之差，由色散参数缩放。完成这一操作的原因是，完美二次曲线的轮廓将显示为一条直线（从直线检测偏差比通过眼睛检测抛物线更容易）。

可能有用的另一件事是如何存储配置文件。基本上，它是一个数据帧列表（每个参数配置一个），除了单个数据帧有点奇怪（包含一个矢量组件和一个矩阵组件）。

profile

它还包含可用于恢复分散和最小偏差的属性> str(prof) List of 2 $ (Intercept):'data.frame': 12 obs. of 3 variables: ..$ tau : num [1:12] -3.557 -2.836 -2.12 -1.409 -0.702 ... ..$ par.vals: num [1:12, 1:2] -0.0286 -0.0276 -0.0267 -0.0258 -0.0248 ... .. ..- attr(*, "dimnames")=List of 2 .. .. ..$ : NULL .. .. ..$ : chr [1:2] "(Intercept)" "log(u)" ..$ dev : num [1:12] 0.00622 0.00753 0.00883 0.01012 0.0114 ... $ log(u) :'data.frame': 12 obs. of 2 variables: ..$ tau : num [1:12] -3.516 -2.811 -2.106 -1.403 -0.701 ... ..$ par.vals: num [1:12, 1:2] -0.0195 -0.0204 -0.0213 -0.0222 -0.023 ... .. ..- attr(*, "dimnames")=List of 2 和summary：

original.fit

现在反转参数1的转换：

disp <- attr(prof,"summary")$dispersion
mindev <- attr(prof,"original.fit")$deviance

简介：

dev1 <- prof[[1]]$tau^2
dev2 <- dev1*disp+mindev

（这是偏差的图。您可以乘以0.5得到负对数似然，或者-0.5得到对数似然...）

修改：一些更通用的功能，可将配置文件转换为plot(prof[[1]][,1],dev2,type="b") / lattice绘图的有用格式......

ggplot

现在用格子绘制它：

tmpf <- function(x,n) {
    data.frame(par=n,tau=x$tau,
               deviance=x$tau^2*disp+mindev,
               x$par.vals,check.names=FALSE)
}
pp <- do.call(rbind,mapply(tmpf,prof,names(prof),SIMPLIFY=FALSE))
library(reshape2)
pp2 <- melt(pp,id.var=1:3)
pp3 <- subset(pp2,par==variable,select=-variable)

或者使用ggplot2：

library(lattice)
xyplot(deviance~value|par,type="b",data=pp3,
       scales=list(x=list(relation="free")))

Answer 2

仅供参考，出于娱乐性考虑，我发现了上述内容，并使用get_profile_glm <- function(aglm){ prof <- MASS:::profile.glm(aglm) disp <- attr(prof,"summary")$dispersion purrr::imap_dfr(prof, .f = ~data.frame(par = .y, deviance=.x$z^2*disp+aglm$deviance, values = as.data.frame(.x$par.vals)[[.y]], stringsAsFactors = FALSE)) } 将其合并为一个函数，因为我找不到实现上述功能的程序包。

counts <- c(18,17,15,20,10,20,25,13,12)
outcome <- gl(3,1,9)
treatment <- gl(3,3)
print(d.AD <- data.frame(treatment, outcome, counts))
glm.D93 <- glm(counts ~ outcome + treatment, family = poisson())

ggplot(get_profile_glm(aglm), aes(x = values, y = deviance)) +
  geom_point() +
  geom_line() +
  facet_wrap(~par, scale = "free_x")

太棒了！

: