修改glm函数以采用R中的用户指定链接函数

在R中的

glm

中，

Gamma

系列的默认链接函数是

inverse

、

identity

和

log

。现在，对于我的特定问题，我需要使用gamma回归和响应

Y

以及一个修改的链接函数，其形式为

log（E（Y）-1））

。因此，我认为在R.修改一些<代码> GLM< /代码>相关函数有几个可能相关的函数，我正在为有经验的人寻求帮助。

例如，函数

Gamma

定义为

function (link = "inverse") 
{
  linktemp <- substitute(link)
  if (!is.character(linktemp)) 
    linktemp <- deparse(linktemp)
  okLinks <- c("inverse", "log", "identity")
  if (linktemp %in% okLinks) 
    stats <- make.link(linktemp)
  else if (is.character(link)) 
    stats <- make.link(link)
  else {
    if (inherits(link, "link-glm")) {
      stats <- link
      if (!is.null(stats$name)) 
        linktemp <- stats$name
    }
    else {
      stop(gettextf("link \"%s\" not available for gamma family; available links are %s", 
                    linktemp, paste(sQuote(okLinks), collapse = ", ")), 
           domain = NA)
    }
  }
  variance <- function(mu) mu^2
  validmu <- function(mu) all(mu > 0)
  dev.resids <- function(y, mu, wt) -2 * wt * (log(ifelse(y == 
                                                            0, 1, y/mu)) - (y - mu)/mu)
  aic <- function(y, n, mu, wt, dev) {
    n <- sum(wt)
    disp <- dev/n
    -2 * sum(dgamma(y, 1/disp, scale = mu * disp, log = TRUE) * 
               wt) + 2
  }
  initialize <- expression({
    if (any(y <= 0)) stop("non-positive values not allowed for the 'gamma' family")
    n <- rep.int(1, nobs)
    mustart <- y
  })
  simfun <- function(object, nsim) {
    wts <- object$prior.weights
    if (any(wts != 1)) 
      message("using weights as shape parameters")
    ftd <- fitted(object)
    shape <- MASS::gamma.shape(object)$alpha * wts
    rgamma(nsim * length(ftd), shape = shape, rate = shape/ftd)
  }
  structure(list(family = "Gamma", link = linktemp, linkfun = stats$linkfun, 
                 linkinv = stats$linkinv, variance = variance, dev.resids = dev.resids, 
                 aic = aic, mu.eta = stats$mu.eta, initialize = initialize, 
                 validmu = validmu, valideta = stats$valideta, simulate = simfun), 
            class = "family")
}

function (link) 
{
  switch(link, logit = {
    linkfun <- function(mu) .Call(C_logit_link, mu)
    linkinv <- function(eta) .Call(C_logit_linkinv, eta)
    mu.eta <- function(eta) .Call(C_logit_mu_eta, eta)
    valideta <- function(eta) TRUE
  }, 

  ...

  }, log = {
    linkfun <- function(mu) log(mu)
    linkinv <- function(eta) pmax(exp(eta), .Machine$double.eps)
    mu.eta <- function(eta) pmax(exp(eta), .Machine$double.eps)
    valideta <- function(eta) TRUE
  }, 

  ...

  structure(list(linkfun = linkfun, linkinv = linkinv, mu.eta = mu.eta, 
                 valideta = valideta, name = link), class = "link-glm")
}

function (link = "inverse") 
{
  linktemp <- substitute(link)
  if (!is.character(linktemp)) 
    linktemp <- deparse(linktemp)
  okLinks <- c("inverse", "log", "identity")
  if (linktemp %in% okLinks) 
    stats <- make.link(linktemp)
  else if (is.character(link)) 
    stats <- make.link(link)
  else {
    if (inherits(link, "link-glm")) {
      stats <- link
      if (!is.null(stats$name)) 
        linktemp <- stats$name
    }
    else {
      stop(gettextf("link \"%s\" not available for gamma family; available links are %s", 
                    linktemp, paste(sQuote(okLinks), collapse = ", ")), 
           domain = NA)
    }
  }
  variance <- function(mu) mu^2
  validmu <- function(mu) all(mu > 0)
  dev.resids <- function(y, mu, wt) -2 * wt * (log(ifelse(y == 
                                                            0, 1, y/mu)) - (y - mu)/mu)
  aic <- function(y, n, mu, wt, dev) {
    n <- sum(wt)
    disp <- dev/n
    -2 * sum(dgamma(y, 1/disp, scale = mu * disp, log = TRUE) * 
               wt) + 2
  }
  initialize <- expression({
    if (any(y <= 0)) stop("non-positive values not allowed for the 'gamma' family")
    n <- rep.int(1, nobs)
    mustart <- y
  })
  simfun <- function(object, nsim) {
    wts <- object$prior.weights
    if (any(wts != 1)) 
      message("using weights as shape parameters")
    ftd <- fitted(object)
    shape <- MASS::gamma.shape(object)$alpha * wts
    rgamma(nsim * length(ftd), shape = shape, rate = shape/ftd)
  }
  structure(list(family = "Gamma", link = linktemp, linkfun = stats$linkfun, 
                 linkinv = stats$linkinv, variance = variance, dev.resids = dev.resids, 
                 aic = aic, mu.eta = stats$mu.eta, initialize = initialize, 
                 validmu = validmu, valideta = stats$valideta, simulate = simfun), 
            class = "family")
}

我的问题是：如果我们想永久地将这个链接函数

vlog

添加到

glm

，这样在每个R会话中，我们可以直接使用

glm（y~x，family=Gamma（link=“log（exp（y）-1）”

，我们是否应该使用

fix（make.link）

然后将

vlog

的定义添加到其主体中？或者

fix（）

只能在当前R会话中执行此操作？再次感谢

还有一件事：我意识到可能需要修改另一个函数。它是

Gamma

，定义为

function (link = "inverse") 
{
  linktemp <- substitute(link)
  if (!is.character(linktemp)) 
    linktemp <- deparse(linktemp)
  okLinks <- c("inverse", "log", "identity")
  if (linktemp %in% okLinks) 
    stats <- make.link(linktemp)
  else if (is.character(link)) 
    stats <- make.link(link)
  else {
    if (inherits(link, "link-glm")) {
      stats <- link
      if (!is.null(stats$name)) 
        linktemp <- stats$name
    }
    else {
      stop(gettextf("link \"%s\" not available for gamma family; available links are %s", 
                    linktemp, paste(sQuote(okLinks), collapse = ", ")), 
           domain = NA)
    }
  }
  variance <- function(mu) mu^2
  validmu <- function(mu) all(mu > 0)
  dev.resids <- function(y, mu, wt) -2 * wt * (log(ifelse(y == 
                                                            0, 1, y/mu)) - (y - mu)/mu)
  aic <- function(y, n, mu, wt, dev) {
    n <- sum(wt)
    disp <- dev/n
    -2 * sum(dgamma(y, 1/disp, scale = mu * disp, log = TRUE) * 
               wt) + 2
  }
  initialize <- expression({
    if (any(y <= 0)) stop("non-positive values not allowed for the 'gamma' family")
    n <- rep.int(1, nobs)
    mustart <- y
  })
  simfun <- function(object, nsim) {
    wts <- object$prior.weights
    if (any(wts != 1)) 
      message("using weights as shape parameters")
    ftd <- fitted(object)
    shape <- MASS::gamma.shape(object)$alpha * wts
    rgamma(nsim * length(ftd), shape = shape, rate = shape/ftd)
  }
  structure(list(family = "Gamma", link = linktemp, linkfun = stats$linkfun, 
                 linkinv = stats$linkinv, variance = variance, dev.resids = dev.resids, 
                 aic = aic, mu.eta = stats$mu.eta, initialize = initialize, 
                 validmu = validmu, valideta = stats$valideta, simulate = simfun), 
            class = "family")
}

function (link) 
{
  switch(link, logit = {
    linkfun <- function(mu) .Call(C_logit_link, mu)
    linkinv <- function(eta) .Call(C_logit_linkinv, eta)
    mu.eta <- function(eta) .Call(C_logit_mu_eta, eta)
    valideta <- function(eta) TRUE
  }, 

  ...

  }, log = {
    linkfun <- function(mu) log(mu)
    linkinv <- function(eta) pmax(exp(eta), .Machine$double.eps)
    mu.eta <- function(eta) pmax(exp(eta), .Machine$double.eps)
    valideta <- function(eta) TRUE
  }, 

  ...

  structure(list(linkfun = linkfun, linkinv = linkinv, mu.eta = mu.eta, 
                 valideta = valideta, name = link), class = "link-glm")
}

function (link = "inverse") 
{
  linktemp <- substitute(link)
  if (!is.character(linktemp)) 
    linktemp <- deparse(linktemp)
  okLinks <- c("inverse", "log", "identity")
  if (linktemp %in% okLinks) 
    stats <- make.link(linktemp)
  else if (is.character(link)) 
    stats <- make.link(link)
  else {
    if (inherits(link, "link-glm")) {
      stats <- link
      if (!is.null(stats$name)) 
        linktemp <- stats$name
    }
    else {
      stop(gettextf("link \"%s\" not available for gamma family; available links are %s", 
                    linktemp, paste(sQuote(okLinks), collapse = ", ")), 
           domain = NA)
    }
  }
  variance <- function(mu) mu^2
  validmu <- function(mu) all(mu > 0)
  dev.resids <- function(y, mu, wt) -2 * wt * (log(ifelse(y == 
                                                            0, 1, y/mu)) - (y - mu)/mu)
  aic <- function(y, n, mu, wt, dev) {
    n <- sum(wt)
    disp <- dev/n
    -2 * sum(dgamma(y, 1/disp, scale = mu * disp, log = TRUE) * 
               wt) + 2
  }
  initialize <- expression({
    if (any(y <= 0)) stop("non-positive values not allowed for the 'gamma' family")
    n <- rep.int(1, nobs)
    mustart <- y
  })
  simfun <- function(object, nsim) {
    wts <- object$prior.weights
    if (any(wts != 1)) 
      message("using weights as shape parameters")
    ftd <- fitted(object)
    shape <- MASS::gamma.shape(object)$alpha * wts
    rgamma(nsim * length(ftd), shape = shape, rate = shape/ftd)
  }
  structure(list(family = "Gamma", link = linktemp, linkfun = stats$linkfun, 
                 linkinv = stats$linkinv, variance = variance, dev.resids = dev.resids, 
                 aic = aic, mu.eta = stats$mu.eta, initialize = initialize, 
                 validmu = validmu, valideta = stats$valideta, simulate = simfun), 
            class = "family")
}

函数（link=“inverse”）
{
linktemp我基本上遵循了
？family
中示例的形式，它显示了用户指定的链接形式
qlogis（mu^（1/days））

我们需要一个形式为
eta=log（exp（y）-1）
（因此反向链接是
y=log（exp（eta）+1）
，并且
mu.eta=dy/d（eta）=1/（1+exp（-eta））

vlog尝试
gnlm:：gnlr（）
。使用Ben Bolker示例中的
x
，
y
，
sh
：

library(gnlm)
# custom link / inverse 
custom_inv <- function(eta)  log(exp(eta)+1)
library(gnlm)
gnlr(y=y,
     distribution = "gamma",
     mu = ~ custom_inv(beta0 + beta1*x),
     pmu = list(beta0=0, beta1=0),
     pshape=sh
)
# Location parameters:
#        estimate      se
# beta0     1.956  0.1334
# beta1     3.083  0.2919
# 
# Shape parameters:
#       estimate       se
# p[1]     0.625  0.04133

库（gnlm）
#自定义链接/反向
custom_inv非常感谢您的评论！我还有一个问题并更新了我的原始帖子。希望您也能帮助我解决这个问题；-）如果其他人还在寻找这个问题，我已经创建了一个小要点，根据Ben Bolker的答案进行约束逻辑回归。我不确定起始值，但也许它可以帮助某人：你能帮帮忙吗？我不理解所有这些额外的复杂性。我在下面的示例中展示了替代链接模型的位置通过
glm（…，family=Gamma（link=vlog（））
安装，只要定义了
vlog
。您可以将
vlog
放入
.R
文件和
源（）
在每个会话中使用它，或者创建一个定义函数的小程序包。如果您愿意，也可以将它放在您的R配置文件中，但它可能对您要使用它的每个R脚本中的
源代码（“vlog.R”）
更加透明。我认为
Gamma（）
不需要修改（再次，请参见我的答案）.我想如果你坚持按名称调用link函数，你就必须进行上面描述的所有额外的黑客操作，但我看不出
family=Gamma（link=vlog（））有什么问题
…@BenBolker:是的，我尝试了你的代码，它们工作得很好！也许我的额外问题更一般，关于
修复
使用R函数永久包含用户定义的选项。我将在我的软件包中包含
vlog
函数。再次感谢你的帮助；-）我想说的是，您应该从R源代码中复制该函数（这样您就可以得到任何相关的注释），并将其合并到您加载的包中，这将屏蔽基本版本。这是一个完全不同的任务，您可能应该将其作为一个单独的问题提出。@BenBolker:是的--我将作为一个单独的问题发布；-）
set.seed(101)
n <- 1000                       
x <- runif(n)
sh <- 2                        
y <- rgamma(n,scale=vv$linkinv(2+3*x)/sh,shape=sh)
glm(y~x,family=Gamma(link=vv))                       
## 
## Call:  glm(formula = y ~ x, family = Gamma(link = vv))
## 
## Coefficients:
## (Intercept)            x  
##       1.956        3.083  
## 
## Degrees of Freedom: 999 Total (i.e. Null);  998 Residual
## Null Deviance:       642.2 
## Residual Deviance: 581.8     AIC: 4268 
## 

library(gnlm)
# custom link / inverse 
custom_inv <- function(eta)  log(exp(eta)+1)
library(gnlm)
gnlr(y=y,
     distribution = "gamma",
     mu = ~ custom_inv(beta0 + beta1*x),
     pmu = list(beta0=0, beta1=0),
     pshape=sh
)
# Location parameters:
#        estimate      se
# beta0     1.956  0.1334
# beta1     3.083  0.2919
# 
# Shape parameters:
#       estimate       se
# p[1]     0.625  0.04133