R/family.univariate.R
In VGAM: Vector Generalized Linear and Additive Models

Documented in better.exponential borel.tanner borel.tanner cauchy cauchy1 chisq dbetageom dbort dfelix dgengamma.stacy dgenpois dgenpois dgenpois0 dgenpois1 dgenpois2 dirichlet dirmul.old dirmultinomial dlevy dlgamma dlino dmaxwell dnaka dpareto dparetoI dparetoII dparetoIII dparetoIV dprentice74 drayleigh dsimplex dtruncpareto erlang expexpff expexpff1 exponential felix gamma1 gamma2 gammaR gengamma.stacy genpoisson0 genpoisson1 genpoisson2 geometric hypersecant hypersecant hypersecant01 hypersecant01 inv.binomial inv.binomial Kayfun.studentt leipnik levy lgamma1 lgamma3 lino logistic logistic logistic1 maxwell mccullagh89 nakagami paretoff paretoII paretoIII paretoIV pbetageom pgengamma.stacy pgenpois0 pgenpois1 pgenpois2 plevy plgamma plino pmaxwell pnaka ppareto pparetoI pparetoII pparetoIII pparetoIV prayleigh prentice74 ptruncpareto qgengamma.stacy qgenpois0 qgenpois1 qgenpois2 qlevy qlgamma qlino qmaxwell qnaka qpareto qparetoI qparetoII qparetoIII qparetoIV qrayleigh qtruncpareto rayleigh rbetageom rbort rdiric rgengamma.stacy rgenpois0 rgenpois1 rgenpois2 rigff rlevy rlgamma rlino rmaxwell rnaka rpareto rparetoI rparetoII rparetoIII rparetoIV rrayleigh rsimplex rtruncpareto simple.exponential simple.poisson simplex studentt studentt2 studentt3 truncpareto waldff

# These functions are
# Copyright (C) 1998-2023 T.W. Yee, University of Auckland.
# All rights reserved.





























 dgenpois0 <- function(x, theta, lambda = 0, log = FALSE) {
  if (!is.logical(log.arg <- log) || length(log) != 1)
    stop("bad input for argument 'log'")
  rm(log)

  LLL <- max(length(x), length(theta), length(lambda))
  if (length(x)      != LLL) x      <- rep_len(x,      LLL)
  if (length(theta)  != LLL) theta  <- rep_len(theta,  LLL)
  if (length(lambda) != LLL) lambda <- rep_len(lambda, LLL)
  
  bad0 <- !is.finite(theta) | !is.finite(lambda) |
          theta < 0 | lambda < 0 | 1 <= lambda
  bad <- bad0 | !is.finite(x) | !is.finite(lfactorial(x))

  logpdf <- x + lambda + theta
  
  if (any(!bad)) {
    logpdf[!bad] <- -x[!bad] * lambda[!bad] - theta[!bad] +
        (x[!bad] - 1) * log(theta[!bad] + x[!bad] * lambda[!bad]) +
           log(theta[!bad]) - lfactorial(x[!bad])
  }
  
  logpdf[!bad0 & is.infinite(x)] <- log(0)
  logpdf[!bad0 & is.infinite(lfactorial(x))] <- log(0)
  logpdf[!bad0 & x < 0         ] <- log(0)
  logpdf[!bad0 & x != round(x) ] <- log(0)
  logpdf[ bad0] <- NaN

  if (log.arg) logpdf else exp(logpdf)
}  # dgenpois0




 dgenpois <- function(x, lambda = 0, theta, log = FALSE) {

  .Deprecated("dgenpois0")
  
  if (!is.logical(log.arg <- log) || length(log) != 1)
    stop("bad input for argument 'log'")
  rm(log)

  LLL <- max(length(x), length(lambda), length(theta))
  if (length(x)      != LLL) x      <- rep_len(x,      LLL)
  if (length(lambda) != LLL) lambda <- rep_len(lambda, LLL)
  if (length(theta)  != LLL) theta  <- rep_len(theta,  LLL)

  llans <- -x*lambda - theta + (x-1) * log(theta + x*lambda) +
           log(theta) - lgamma(x+1)
  llans[x < 0] <- log(0)
  llans[x != round(x)] <- log(0)  # x should be integer-valued
  llans[lambda > 1] <- NaN
  if (any(ind1 <- (lambda < 0))) {
    epsilon <- 1.0e-9  # Needed to handle a "<" rather than a "<=".
    mmm <- pmax(4, floor(theta/abs(lambda) - epsilon))
    llans[ind1 & mmm < pmax(-1, -theta/mmm)] <- NaN
    llans[ind1 & mmm < x] <- log(0)  # probability 0, not NaN
  }
  if (log.arg) {
    llans
  } else {
    exp(llans)
  }
}  # dgenpois









if (FALSE)
 pgenpois0.CoFortran <-
  function(q, theta, lambda = 0, lower.tail = TRUE) {
  warning("not working 20211025")
  q <- floor(q)
  LLL <- max(length(q), length(theta), length(lambda))
  if (length(q)      != LLL) q      <- rep_len(q,      LLL)
  if (length(theta)  != LLL) theta  <- rep_len(theta,  LLL)
  if (length(lambda) != LLL) lambda <- rep_len(lambda, LLL)

  bad0 <- !is.finite(theta) | !is.finite(lambda) |
          theta < 0 | lambda < 0 | 1 <= lambda
  bad <- bad0 | !is.finite(q)

  if (all(is.finite(lambda)) && all(lambda == 0))
    return(ppois(q, theta, lower.tail = lower.tail))

  ans <- q + lambda + theta
  okay3 <- !bad & 0 <= q
  zzzzz  # Call C or FORTRAN here.
  zzzzz
  zzzzz

  ans[!bad0 & is.infinite(q)] <- 1
  ans[!bad0 & q < 0         ] <- 0
  ans[ bad0] <- NaN
  if (!lower.tail)
    ans <- 1 - ans
  ans
}  # pgenpois0.CorFORTRAN





 pgenpois0 <-
  function(q, theta, lambda = 0, lower.tail = TRUE) {
  q <- floor(q)
  LLL <- max(length(q), length(theta), length(lambda))
  if (length(q)      != LLL) q      <- rep_len(q,      LLL)
  if (length(theta)  != LLL) theta  <- rep_len(theta,  LLL)
  if (length(lambda) != LLL) lambda <- rep_len(lambda, LLL)

  bad0 <- !is.finite(theta) | !is.finite(lambda) |
          theta < 0 | lambda < 0 | 1 <= lambda
  bad <- bad0 | !is.finite(q)

  if (all(is.finite(lambda)) && all(lambda == 0))
    return(ppois(q, theta, lower.tail = lower.tail))

  ans <- q + lambda + theta
  okay3 <- !bad & 0 <= q
  if (any(okay3)) {
    ans[okay3] <- mapply(function(q, theta, lambda) {
      xx <- 0:q
      sum(exp(-xx * lambda - theta + log(theta) +
          (xx - 1) * log(theta + xx * lambda) - lfactorial(xx)))
      },
      q      =      q[okay3],
      theta  =  theta[okay3],
      lambda = lambda[okay3])
    ans <- unlist(ans)
  }
  ans[!bad0 & is.infinite(q)] <- 1
  ans[!bad0 & q < 0         ] <- 0
  ans[ bad0] <- NaN
  if (!lower.tail)
    ans <- 1 - ans
  ans
}  # pgenpois0
















qgenpois0 <- function(p, theta, lambda = 0) {
  LLL <- max(length(p), length(theta), length(lambda))
  if (length(p)      != LLL) p      <- rep_len(p,      LLL)
  if (length(theta)  != LLL) theta  <- rep_len(theta,  LLL)
  if (length(lambda) != LLL) lambda <- rep_len(lambda, LLL)

  ans <- p + lambda + theta

  bad0 <- !is.finite(theta) | !is.finite(lambda) |
          theta < 0 | lambda < 0 | 1 <= lambda
  bad <- bad0 | !is.finite(p) | p <= 0 | 1 <= p

  lo <- rep_len(0, LLL) - 0.5
  approx.ans <- lo  # True at lhs
  hi <- 2 * lo + 10.5
  dont.iterate <- bad
  done <- dont.iterate | p <= pgenpois0(hi, theta, lambda = lambda)
  iter <- 0
  max.iter <- round(log2(.Machine$double.xmax)) - 2
  max.iter <- round(log2(1e300)) - 2
  while (!all(done) && iter < max.iter) {
    lo[!done] <- hi[!done]
    hi[!done] <- 2 * hi[!done] + 10.5  # Bug fixed
    done[!done] <- (p[!done] <= pgenpois0(hi[!done],
                    theta[!done], lambda = lambda[!done]))
    iter <- iter + 1
  }

  foo <- function(q, theta, lambda, p)
    pgenpois0(q, theta, lambda = lambda) - p

  lhs <- dont.iterate |
         p <= dgenpois0(0, theta, lambda = lambda)
  
  approx.ans[!lhs] <-
    bisection.basic(foo, lo[!lhs], hi[!lhs], tol = 1/16,
                    theta = theta[!lhs],
                    lambda = lambda[!lhs], p = p[!lhs])
  faa <- floor(approx.ans[!lhs])
  tmp <-
    ifelse(pgenpois0(faa, theta[!lhs], lambda = lambda[!lhs]) < p[!lhs] &
           p[!lhs] <= pgenpois0(faa+1, theta[!lhs],
                                lambda = lambda[!lhs]),
           faa+1, faa)
  ans[!lhs] <- tmp

  vecTF <- !bad0 & !is.na(p) &
           p <= dgenpois0(0, theta, lambda = lambda)
  ans[vecTF] <- 0

  ans[!bad0 & !is.na(p) & p == 0] <- 0
  ans[!bad0 & !is.na(p) & p == 1] <- Inf
  ans[!bad0 & !is.na(p) & p <  0] <- NaN
  ans[!bad0 & !is.na(p) & p >  1] <- NaN
  ans[ bad0] <- NaN
  ans
}  # qgenpois0






rgenpois0 <-
  function(n, theta, lambda = 0,
           algorithm = c("qgenpois0",
                         "inv", "bup", "chdn", "napp", "bran")) {

  algorithm <- match.arg(algorithm, c("qgenpois0",
                         "inv", "bup", "chdn", "napp", "bran"))[1]
  use.n <- if ((length.n <- length(n)) > 1) length.n else
           if (!is.Numeric(n, integer.valued = TRUE,
                           length.arg = 1, positive = TRUE))
              stop("bad input for argument 'n'") else n
  if (length(theta) > use.n)
    warning("length of 'theta' exceeds 'n'. Truncating it.")
  if (length(lambda) > use.n)
    warning("length of 'lambda' exceeds 'n'. Truncating it.")
  theta  <- rep_len(theta,  use.n)
  lambda <- rep_len(lambda, use.n)


  bad0.a <- !is.finite(lambda) | !is.finite(theta)
  if (any(bad0.a))
    stop("cannot have NAs or NaNs in 'theta' or 'lambda'.")
  bad0.b <- theta <= 0 | lambda < 0 | 1 <= lambda  # zz theta < 0
  if (any(bad0.b))
    stop("some values of 'theta' or 'lambda' are out of range.")

  if (all(lambda == 0))
    return(rpois(use.n, theta))
  
  if (algorithm == "qgenpois0") {
    return(qgenpois0(runif(n), theta, lambda = lambda))
  }

  if (algorithm == "inv") {
    myset <- numeric(use.n) 
    w <- exp(-lambda)
    mys <- exp(-theta)
    myp <- mys
    x <- numeric(use.n)  # 0 
    u <- runif(use.n)
    while (any(vecTF <- u > mys)) {
      x[vecTF] <- x[vecTF] + 1 
      myc.T <- theta[vecTF] - lambda[vecTF] +
        lambda[vecTF] * x[vecTF]
      myp[vecTF] <- w[vecTF] * myc.T *
        (1 + lambda[vecTF] / myc.T)^(x[vecTF] - 1) *
        myp[vecTF] * (x[vecTF])^(-1)
      mys[vecTF] <- mys[vecTF] + myp[vecTF]
    }
    myset <- x
    return(myset)
  }

  if (algorithm == "bup") {
    mynumx <- numeric(use.n)
    tt <- exp(-theta)
    u <- runif(use.n)
    x <- numeric(use.n)  # 0 
    px <- tt
    s <- px
    while (any(vecTF <- u > s)) {
      x[vecTF] <- x[vecTF] + 1
      logpdf.T <- -x[vecTF] * lambda[vecTF] - theta[vecTF] +
        (x[vecTF] - 1) * log(theta[vecTF] + x[vecTF] * lambda[vecTF]) +
        log(theta[vecTF]) - lfactorial(x[vecTF])
      px.T <- exp(logpdf.T)
      s[vecTF] <- s[vecTF] + px.T
    }
    mynumx <- x
    return(mynumx)
  }

  if (algorithm == "chdn") {
    mynump <- numeric(use.n)
    tt <- exp(-theta)
    u <- runif(use.n)
    x <- numeric(use.n)  # 0 
    px <- tt
    while (any(vecTF <- u > px)) {
      u[vecTF] <- u[vecTF] - px[vecTF]
      x[vecTF] <- x[vecTF] + 1
      logpdf.T <- -x[vecTF] * lambda[vecTF] - theta[vecTF] +
        (x[vecTF] - 1) * log(theta[vecTF] + x[vecTF] * lambda[vecTF]) +
        log(theta[vecTF]) - lfactorial(x[vecTF])
      px[vecTF] <- exp(logpdf.T)
    }
    mynump <- x
    return(mynump)
  }

  if (algorithm == "napp") {
    mym <- theta / (1 - lambda) 
    myv <- sqrt(theta * (1 - lambda)^(-3))
    Y <- rnorm(use.n)
    X <- floor(mym + myv * Y + 0.5)
    if (any(vecTF <- X < 0)) {
      X[vecTF] <- 0
      warning("the value returned may be 0-inflated")
    }
    return(X)
  }

  if (algorithm == "bran") {
    if (any(lambda == 0))
      stop("argument 'lambda' must contain positive values")
    mynumb <- numeric(use.n)
    index <- 1:use.n
    y <- rpois(use.n, theta)
    x <- y
    ind0 <- which(y <= 0)
    if (length(ind0))
      mynumb[ind0] <- x[ind0]
    if (length(ind0) == use.n)
      return(mynumb)
    ind1 <- ind2 <- which(y > 0)
    n.todo <- length(ind1)
    n.done <- 0
    repeat {
      z.T <- rpois(length(ind2), lambda[ind2] * y[ind2])
      x[ind2] <- x[ind2] + z.T
      y.T <- z.T
      ind3 <- ind2[which(y.T <= 0)]
      n.done <- n.done + length(ind3)
      if (n.done == n.todo) {
        mynumb[ind1] <- x[ind1]
        break
      }
      ind2 <- setdiff(ind2, ind3)
    }  # repeat
    return(mynumb)
  }
}  # rgenpois0






dgenpois1 <- function(x, meanpar, dispind = 1,
                      log = FALSE) {
  dgenpois0(x, theta = meanpar / sqrt(dispind),
            lambda = 1 - 1 / sqrt(dispind),
            log = log)
}  # dgenpois1


pgenpois1 <- function(q, meanpar, dispind = 1, lower.tail = TRUE) {
  pgenpois0(q, theta = meanpar / sqrt(dispind),
            lambda = 1 - 1 / sqrt(dispind), lower.tail = lower.tail)
}  # pgenpois1


qgenpois1 <- function(p, meanpar, dispind = 1) {
  qgenpois0(p, theta = meanpar / sqrt(dispind),
            lambda = 1 - 1 / sqrt(dispind))
}  # qgenpois1


rgenpois1 <- function(n, meanpar, dispind = 1) {
  rgenpois0(n, theta = meanpar / sqrt(dispind),
            lambda = 1 - 1 / sqrt(dispind))
}  # rgenpois1






dgenpois2 <- function(x, meanpar, disppar = 0, log = FALSE) {
  dgenpois0(x, theta = meanpar / (1 + disppar * meanpar),
            lambda = disppar * meanpar / (1 + disppar * meanpar),
            log = log)
}  # dgenpois2


pgenpois2 <- function(q, meanpar, disppar = 0, lower.tail = TRUE) {
  pgenpois0(q, theta = meanpar / (1 + disppar * meanpar),
            lambda = disppar * meanpar / (1 + disppar * meanpar),
            lower.tail = lower.tail)
}  # pgenpois2


qgenpois2 <- function(p, meanpar, disppar = 0) {
  qgenpois0(p, theta = meanpar / (1 + disppar * meanpar),
            lambda = disppar * meanpar / (1 + disppar * meanpar))
}  # qgenpois2


rgenpois2 <- function(n, meanpar, disppar = 0) {
  rgenpois0(n, theta = meanpar / (1 + disppar * meanpar),
            lambda = disppar * meanpar / (1 + disppar * meanpar))
}  # rgenpois2





 genpoisson0 <-
  function(ltheta = "loglink",
           llambda = "logitlink",
           itheta = NULL, ilambda = NULL,  # use.approx = TRUE,
           imethod = c(1, 1),
           ishrinkage = 0.95,
           glambda = ppoints(5),  # -expm1(-ppoints(5)),
           parallel = FALSE,
           zero = "lambda") {



  ltheta <- as.list(substitute(ltheta))
  etheta <- link2list(ltheta)
  ltheta <- attr(etheta, "function.name")

  llambda <- as.list(substitute(llambda))
  elambda <- link2list(llambda)
  llambda <- attr(elambda, "function.name")

  if (!is.Numeric(ishrinkage, length.arg = 1) ||
     ishrinkage < 0 || 1 < ishrinkage)
    stop("bad input for argument 'ishrinkage'")

  if (!is.Numeric(glambda, positive = TRUE) || 1 <= max(glambda))
    stop("bad input for argument 'glambda'")

  imethod <- rep_len(imethod, 2)  # For the two parameters
  if (!is.Numeric(imethod, length.arg = 2,
                  integer.valued = TRUE, positive = TRUE) ||
     any(imethod > 3))
    stop("argument 'imethod' must have values from 1:3")

  if (is.logical(parallel) && parallel && length(zero))
    stop("set 'zero = NULL' if 'parallel = TRUE'")

  new("vglmff",
  blurb = c("Generalized Poisson distribution (GP-0)\n\n",
            "Links:    ",
            namesof("theta",  ltheta,  earg = etheta ), ", ",
            namesof("lambda", llambda, earg = elambda), "\n",
            "Mean:     theta / (1 - lambda)\n",
            "Variance: theta / (1 - lambda)^3"),
 constraints = eval(substitute(expression({
    constraints <-
      cm.VGAM(matrix(1, M, 1), x = x,
              bool = .parallel ,
              constraints = constraints,
              apply.int = FALSE )

    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 2,
                     predictors.names = predictors.names)
  }), list( .zero = zero,
            .parallel = parallel ))),

  infos = eval(substitute(function(...) {
    list(M1 = 2,
         Q1 = 1,
         dpqrfun = "genpois0",
         expected = TRUE,
         multipleResponses = TRUE,
         parameters.names = c("theta", "lambda"),
         imethod = .imethod ,
         zero = .zero )
  }, list( .zero = zero,
           .imethod = imethod ))),

  initialize = eval(substitute(expression({
    temp5 <-
    w.y.check(w = w, y = y,
              Is.nonnegative.y = TRUE,
              Is.integer.y = TRUE,
              ncol.w.max = Inf,  # 1,
              ncol.y.max = Inf,  # 1,
              out.wy = TRUE,
              colsyperw = 1,
              maximize = TRUE)
    w <- temp5$w
    y <- temp5$y

    extra$ncoly <- ncoly <- NOS <- ncol(y)
    extra$M1 <- M1 <- 2
    M <- M1 * ncoly
    mynames1 <- param.names("theta",  NOS, skip1 = TRUE)
    mynames2 <- param.names("lambda", NOS, skip1 = TRUE)

    predictors.names <-
       c(namesof(mynames1, .ltheta  , earg = .etheta  , tag = FALSE),
         namesof(mynames2, .llambda , earg = .elambda , tag = FALSE))
    predictors.names <- predictors.names[interleave.VGAM(M, M1 = M1)]

    imethod <- as.vector( .imethod )
    init.lambda <- init.theta <- matrix(0, n, NOS)
    for (spp. in 1: NOS) {
      meay.w <- weighted.mean(y[, spp.], w[, spp.])
      vary.w <- c(cov.wt(cbind(y[, spp.]), wt = w[, spp.])$cov)
      if ((disppar.index <- vary.w / meay.w) < 0.5)
        warning("Response ", spp. , " is underdispersed. ",
                "Numerical problems will probably arise.") else
      if (disppar.index < 0.875)
        warning("Response ", spp. , " appears underdispersed. ",
                "Numerical problems may arise.")
      init.theta[, spp.]  <- if (imethod[1] == 2) {
        meay.w + 0.125
      } else if (imethod[1] == 3) {
        (y[, spp.] + median(y[, spp.]) + 0.125) / 2
      } else {  # imethod[1] == 1
        (1 - .ishrinkage ) * y[, spp.] + .ishrinkage * meay.w
      }
      init.theta[, spp.] <- init.theta[, spp.] / (1 +
                            sqrt(vary.w / meay.w))

      init.lambda[, spp.] <- if (imethod[2] == 2) {  # Weighted MOM
        min(max(0.03, 1 - sqrt(meay.w / vary.w)), 0.97)
      } else if (imethod[2] == 1) {
        genpois0.Loglikfun <- function(lambda1, y, x, w, extraargs)
          sum(c(w) * dgenpois0(y, theta = extraargs$theta0,
                               lambda = lambda1, log = TRUE))
        lambda1.grid <- as.vector( .glambda )
        lambda1.init <- 
          grid.search(lambda1.grid, objfun = genpois0.Loglikfun,
                      y = y,  x = x, w = w,
                      extraargs = list(theta0 = init.theta[, spp.]))
        lambda1.init
      } else {  # imethod[2] == 3
        min(max(0.03, 1 - sqrt(meay.w / (0.25 * vary.w))), 0.97)
      }
    }  # for spp.

    if (!length(etastart)) {
      init.lambda <- if (length( .ilambda ))
                       matrix( .ilambda , n, NOS, byrow = TRUE) else
                       init.lambda
      init.theta  <- if (length( .itheta ))
                       matrix( .itheta  , n, NOS, byrow = TRUE) else
                       init.theta
      etastart <-
        cbind(theta2eta(init.theta,  .ltheta  , earg = .etheta  ),
              theta2eta(init.lambda, .llambda , earg = .elambda ))
      etastart <- etastart[, interleave.VGAM(M, M1 = M1), drop = FALSE]
    }
  }), list( .ltheta = ltheta, .llambda = llambda,
            .etheta = etheta, .elambda = elambda,
            .itheta = itheta, .ilambda = ilambda,
            .imethod = imethod, .ishrinkage = ishrinkage,
            .glambda = glambda)) ),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    theta  <- eta2theta(eta[, c(TRUE, FALSE)], .ltheta  ,
                        earg = .etheta  )
    lambda <- eta2theta(eta[, c(FALSE, TRUE)], .llambda ,
                        earg = .elambda )
    theta / (1 - lambda)
  }, list( .ltheta = ltheta, .llambda = llambda,
           .etheta = etheta, .elambda = elambda ))),
  last = eval(substitute(expression({
    M1 <- 2
    temp.names <- c(mynames1, mynames2)
    temp.names <- temp.names[interleave.VGAM(M1 * ncoly, M1 = M1)]

    misc$link <- rep_len( .llambda , M1 * ncoly)
    misc$earg <- vector("list", M1 * ncoly)
    names(misc$link) <-
    names(misc$earg) <- temp.names
    for (ii in 1:ncoly) {
      misc$link[ M1*ii-1 ] <- as.vector( .ltheta  )
      misc$link[ M1*ii   ] <- as.vector( .llambda )
      misc$earg[[M1*ii-1]] <- as.vector( .etheta  )
      misc$earg[[M1*ii  ]] <- as.vector( .elambda )
    }
  }), list( .ltheta = ltheta, .llambda = llambda,
            .etheta = etheta, .elambda = elambda,
            .imethod = imethod ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL, summation = TRUE) {
      theta  <- eta2theta(eta[, c(TRUE, FALSE)],
                          .ltheta  , earg = .etheta  )
      lambda <- eta2theta(eta[, c(FALSE, TRUE)],
                          .llambda , earg = .elambda )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <- dgenpois0(y, theta = theta, lambda = lambda,
                           log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .ltheta = ltheta, .llambda = llambda,
           .etheta = etheta, .elambda = elambda ))),
   vfamily = c("genpoisson0"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    theta  <- eta2theta(eta[, c(TRUE, FALSE)],
                        .ltheta  , earg = .etheta  )
    lambda <- eta2theta(eta[, c(FALSE, TRUE)],
                        .llambda , earg = .elambda )
    Lbnd <- 0  # pmax(-1, -theta / mmm)
    okay1 <- all(is.finite(lambda)) &&
             all(Lbnd < lambda & lambda < 1) &&
             all(is.finite(theta )) && all(0 < theta)
    okay1
  }, list( .ltheta = ltheta, .llambda = llambda,
           .etheta = etheta, .elambda = elambda ))),
  deriv = eval(substitute(expression({
    M1  <- 2
    NOS <- ncol(eta)/M1

    theta  <- eta2theta(eta[, c(TRUE, FALSE)],
                        .ltheta  , earg = .etheta  )
    lambda <- eta2theta(eta[, c(FALSE, TRUE)],
                        .llambda , earg = .elambda )
    dl.dtheta  <- -1 +   (y-1) / (theta+y*lambda) + 1/theta
    dl.dlambda <- -y + y*(y-1) / (theta+y*lambda)
    dTHETA.deta  <- dtheta.deta(theta,  .ltheta  , earg = .etheta  )
    dlambda.deta <- dtheta.deta(lambda, .llambda , earg = .elambda )
    myderiv <- c(w) * cbind(dl.dtheta  * dTHETA.deta ,
                            dl.dlambda * dlambda.deta)
    myderiv[, interleave.VGAM(M, M1 = M1)]
  }), list( .ltheta = ltheta, .llambda = llambda,
            .etheta = etheta, .elambda = elambda ))),
  weight = eval(substitute(expression({
    wz <- matrix(0, n, M + M-1)  # Tridiagonal
    ned2l.dlambda2 <- theta / (1 - lambda) +
                      2 * theta / (theta + 2 * lambda)
    ned2l.dtheta2 <- 1 / theta - lambda / (theta + 2 * lambda)
    ned2l.dthetalambda <- theta / (theta + 2 * lambda)
    wz[, M1*(1:NOS) - 1    ] <- ned2l.dtheta2 * dTHETA.deta^2
    wz[, M1*(1:NOS)        ] <- ned2l.dlambda2 * dlambda.deta^2
    wz[, M1*(1:NOS) + M - 1] <- ned2l.dthetalambda *
                                dTHETA.deta * dlambda.deta
    wz <- w.wz.merge(w = w, wz = wz, n = n, M = M + (M - 1),
                     ndepy = NOS)
    wz
  }), list( .ltheta = ltheta, .llambda = llambda,
            .etheta = etheta, .elambda = elambda ))))
}  # genpoisson0


      


 genpoisson2 <-
  function(lmeanpar = "loglink",
           ldisppar = "loglink",
           imeanpar = NULL, idisppar = NULL,
           imethod = c(1, 1),
           ishrinkage = 0.95,
           gdisppar = exp(1:5),
           parallel = FALSE,
           zero = "disppar") {
  lmeanpar <- as.list(substitute(lmeanpar))
  emeanpar <- link2list(lmeanpar)
  lmeanpar <- attr(emeanpar, "function.name")

  ldisppar <- as.list(substitute(ldisppar))
  edisppar <- link2list(ldisppar)
  ldisppar <- attr(edisppar, "function.name")

  if (!is.Numeric(ishrinkage, length.arg = 1) ||
     ishrinkage < 0 || 1 < ishrinkage)
    stop("bad input for argument 'ishrinkage'")

  if (!is.Numeric(gdisppar, positive = TRUE))
    stop("bad input for argument 'gdisppar'")

  imethod <- rep_len(imethod, 2)  # For the two parameters
  if (!is.Numeric(imethod, length.arg = 2,
                  integer.valued = TRUE, positive = TRUE) ||
     any(imethod > 3))
    stop("argument 'imethod' must have values from 1:3")

  if (is.logical(parallel) && parallel && length(zero))
    stop("set 'zero = NULL' if 'parallel = TRUE'")

  new("vglmff",
  blurb = c("Generalized Poisson distribution (GP-2)\n\n",
            "Links:    ",
            namesof("meanpar", lmeanpar, earg = emeanpar), ", ",
            namesof("disppar", ldisppar, earg = edisppar), "\n",
            "Mean:     meanpar\n",
            "Variance: meanpar * (1 + disppar * meanpar)^2"),
 constraints = eval(substitute(expression({
    constraints <-
      cm.VGAM(matrix(1, M, 1), x = x,
              bool = .parallel ,
              constraints = constraints,
              apply.int = FALSE )
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 2,
                     predictors.names = predictors.names)
  }), list( .zero = zero,
            .parallel = parallel ))),

  infos = eval(substitute(function(...) {
    list(M1 = 2,
         Q1 = 1,
         dpqrfun = "genpois2",
         expected = TRUE,
         multipleResponses = TRUE,
         parameters.names = c("meanpar", "disppar"),
         imethod = .imethod ,
         zero = .zero )
  }, list( .zero = zero,
           .imethod = imethod ))),

  initialize = eval(substitute(expression({
    temp5 <-
    w.y.check(w = w, y = y,
              Is.nonnegative.y = TRUE,
              Is.integer.y = TRUE,
              ncol.w.max = Inf,  # 1,
              ncol.y.max = Inf,  # 1,
              out.wy = TRUE,
              colsyperw = 1,
              maximize = TRUE)
    w <- temp5$w
    y <- temp5$y

    extra$ncoly <- ncoly <- NOS <- ncol(y)
    extra$M1 <- M1 <- 2
    M <- M1 * ncoly
    mynames1 <- param.names("meanpar",  NOS, skip1 = TRUE)
    mynames2 <- param.names("disppar", NOS, skip1 = TRUE)

    predictors.names <-
       c(namesof(mynames1, .lmeanpar , earg = .emeanpar , tag = FALSE),
         namesof(mynames2, .ldisppar , earg = .edisppar , tag = FALSE))
    predictors.names <- predictors.names[interleave.VGAM(M, M1 = M1)]

    imethod <- as.vector( .imethod )
    init.disppar <- init.meanpar <- matrix(0, n, NOS)
    for (spp. in 1: NOS) {
      meay.w <- weighted.mean(y[, spp.], w[, spp.]) + 0.5
      vary.w <- c(cov.wt(cbind(y[, spp.]), wt = w[, spp.])$cov) + 0.5
      if ((disppar.index <- vary.w / meay.w) < 0.5)
        warning("Response ", spp. , " is underdispersed. ",
                "Numerical problems will probably arise.") else
      if (disppar.index < 0.875)
        warning("Response ", spp. , " appears underdispersed. ",
                "Numerical problems may arise.")
      init.meanpar[, spp.]  <- if (imethod[1] == 2) {
        meay.w
      } else if (imethod[1] == 3) {
        (y[, spp.] + median(y[, spp.]) + 0.125) / 2
      } else {  # imethod[1] == 1
        (1 - .ishrinkage ) * y[, spp.] + .ishrinkage * meay.w
      }

      init.disppar[, spp.] <- if (imethod[2] == 1) {  # Weighted MOM
        max(0.03, (sqrt(vary.w / meay.w) - 1) / meay.w)
      } else if (imethod[2] == 2) {
        genpois2.Loglikfun <- function(disppar1, y, x, w, extraargs)
          sum(c(w) * dgenpois2(y, mean = extraargs$meanpar0,
                               disppar = disppar1, log = TRUE))
        disppar1.grid <- as.vector( .gdisppar )
        disppar1.init <- 
          grid.search(disppar1.grid, objfun = genpois2.Loglikfun,
                      y = y,  x = x, w = w,
              extraargs = list(meanpar0 = init.meanpar[, spp.]))
        disppar1.init
      } else {  # imethod[2] == 3
        max(0.03, (sqrt(0.25 * vary.w / meay.w) - 1) / meay.w)
      }
    }  # for spp.

    if (!length(etastart)) {
      init.meanpar  <- if (length( .imeanpar ))
                matrix( .imeanpar  , n, NOS, byrow = TRUE) else
                init.meanpar
      init.disppar <- if (length( .idisppar ))
                matrix( .idisppar , n, NOS, byrow = TRUE) else
                init.disppar
      etastart <-
        cbind(theta2eta(init.meanpar, .lmeanpar , .emeanpar ),
              theta2eta(init.disppar, .ldisppar , .edisppar ))
      etastart <- etastart[, interleave.VGAM(M, M1 = M1),
                           drop = FALSE]
    }
  }), list( .lmeanpar = lmeanpar, .ldisppar = ldisppar,
            .emeanpar = emeanpar, .edisppar = edisppar,
            .imeanpar = imeanpar, .idisppar = idisppar,
            .imethod = imethod, .ishrinkage = ishrinkage,
            .gdisppar = gdisppar)) ),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    meanpar <- eta2theta(eta[, c(TRUE, FALSE)], .lmeanpar ,
                         earg = .emeanpar )
    meanpar
  }, list( .lmeanpar = lmeanpar, .ldisppar = ldisppar,
           .emeanpar = emeanpar, .edisppar = edisppar ))),
  last = eval(substitute(expression({
    M1 <- 2
    temp.names <- c(mynames1, mynames2)
    temp.names <- temp.names[interleave.VGAM(M1 * ncoly, M1 = M1)]

    misc$link <- rep_len( .ldisppar , M1 * ncoly)
    misc$earg <- vector("list", M1 * ncoly)
    names(misc$link) <-
    names(misc$earg) <- temp.names
    for (ii in 1:ncoly) {
      misc$link[ M1*ii-1 ] <- as.vector( .lmeanpar )
      misc$link[ M1*ii   ] <- as.vector( .ldisppar )
      misc$earg[[M1*ii-1]] <- as.vector( .emeanpar )
      misc$earg[[M1*ii  ]] <- as.vector( .edisppar )
    }
  }), list( .lmeanpar = lmeanpar, .ldisppar = ldisppar,
            .emeanpar = emeanpar, .edisppar = edisppar,
            .imethod = imethod ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL, summation = TRUE) {
    meanpar <- eta2theta(eta[, c(TRUE, FALSE)], .lmeanpar ,
                         earg = .emeanpar )
    disppar <- eta2theta(eta[, c(FALSE, TRUE)], .ldisppar ,
                         earg = .edisppar )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <- dgenpois2(y, mean = meanpar, disppar = disppar,
                           log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .lmeanpar = lmeanpar, .ldisppar = ldisppar,
           .emeanpar = emeanpar, .edisppar = edisppar ))),
   vfamily = c("genpoisson2"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    meanpar <- eta2theta(eta[, c(TRUE, FALSE)], .lmeanpar ,
                         earg = .emeanpar  )
    disppar <- eta2theta(eta[, c(FALSE, TRUE)], .ldisppar ,
                         earg = .edisppar )
    Lbnd <- 0  # pmax(-1, -meanpar / mmm)
    okay1 <- all(is.finite(disppar)) && all(Lbnd < disppar) &&
             all(is.finite(meanpar)) && all(0 < meanpar)
    okay1
  }, list( .lmeanpar = lmeanpar, .ldisppar = ldisppar,
           .emeanpar = emeanpar, .edisppar = edisppar ))),
  deriv = eval(substitute(expression({
    M1  <- 2
    NOS <- ncol(eta) / M1
    meanpar <- eta2theta(eta[, c(TRUE, FALSE)], .lmeanpar ,
                         earg = .emeanpar  )
    disppar <- eta2theta(eta[, c(FALSE, TRUE)], .ldisppar ,
                         earg = .edisppar )
    tmp.y <- 1 + disppar * y
    tmp.m <- 1 + disppar * meanpar  # n x NOS
    dl.dmeanpar <- y / meanpar - y * disppar / tmp.m +
       disppar * meanpar * tmp.y / tmp.m^2 - tmp.y / tmp.m
    dl.ddisppar <- y * (y - 1) / tmp.y - meanpar * y / tmp.m -
                   meanpar * (y - meanpar) / tmp.m^2
    dmeanpar.deta <- dtheta.deta(meanpar, .lmeanpar , .emeanpar )
    ddisppar.deta <- dtheta.deta(disppar, .ldisppar , .edisppar )
    myderiv <- c(w) * cbind(dl.dmeanpar * dmeanpar.deta ,
                            dl.ddisppar * ddisppar.deta)
    myderiv[, interleave.VGAM(M, M1 = M1)]
  }), list( .lmeanpar = lmeanpar, .ldisppar = ldisppar,
            .emeanpar = emeanpar, .edisppar = edisppar ))),
  weight = eval(substitute(expression({
    wz <- matrix(0, n, M + M-1)  # Tridiagonal here but...


    lambda <- disppar * meanpar / tmp.m  # In the unit interval
    theta <- meanpar / tmp.m
    ned2l.dtheta2 <- 1 / theta - lambda / (theta + 2 * lambda)
    ned2l.dthetalambda <- theta / (theta + 2 * lambda)
    ned2l.dlambda2 <- theta / (1 - lambda) +
                      2 * theta / (theta + 2 * lambda)


    Manual <- FALSE
    Manual <- TRUE
    if (Manual) {
      ned2l.dmeanpar2 <- 1 / (meanpar * tmp.m^2)



      ned2l.ddisppar2 <- (2 * meanpar^2) / ((1 +
                          2 * disppar) * tmp.m^2)



      wz[, M1*(1:NOS) - 1    ] <- ned2l.dmeanpar2 * dmeanpar.deta^2
      wz[, M1*(1:NOS)        ] <- ned2l.ddisppar2 * ddisppar.deta^2
    } else {

      


      Nnn <- 5  # Any small integer > 1 will do.
      arwz1 <- array(c(matrix(1, Nnn, NOS),
                       matrix(2, Nnn, NOS),
                       matrix(3, Nnn, NOS)),
                     dim = c(Nnn, NOS, 3))
      wz.ind <- arwz2wz(arwz1, M = M, M1 = M1)
      

      Mie <- eiM <- matrix(0, n, M + (M - 1))  # Diagonal really
      eiM[, M1*(1:NOS) - 1    ] <- ned2l.dtheta2
      eiM[, M1*(1:NOS)        ] <- ned2l.dlambda2
      eiM[, M1*(1:NOS) + M - 1] <- ned2l.dthetalambda

      Tmp <- J02 <- array(0, c(n, NOS, M1, M1))
      J02[, , 1, 1] <- 1
      J02[, , 1, 2] <- disppar
      J02[, , 2, 1] <- (-meanpar^2)
      J02[, , 2, 2] <- meanpar
      J02 <- J02 / c(tmp.m^2)  # This works

      for (jay in 1:M1) {
        for (kay in 1:M1) {
          for (sss in 1:M1) {
          jk.indices <- which(wz.ind[1, ] == iam(jay, sss, M = M1))
          Tmp[, , jay, kay] <-
          Tmp[, , jay, kay] +  # t(J02):
                     eiM[, jk.indices] * J02[, , kay, sss]
          }  # sss
        }  # kay
      }  # jay


      for (jay in 1:M1) {
        for (kay in (jay):M1) {
          jk.indices <- which(wz.ind[1, ] == iam(jay, kay, M = M1))
          for (sss in 1:M1)
            Mie[, jk.indices] <- Mie[, jk.indices] +
                          J02[, , jay, sss] * Tmp[, , sss, kay]
        }  # kay
      }  # jay

      wz <- matrix(0, n, M + M-1)  # Tridiagonal but diagonal okay
       wz[, M1*(1:NOS) - 1    ] <-
      Mie[, M1*(1:NOS) - 1    ] * dmeanpar.deta^2
       wz[, M1*(1:NOS)        ] <-
      Mie[, M1*(1:NOS)        ] * ddisppar.deta^2
       wz[, M1*(1:NOS) + M - 1] <-
      Mie[, M1*(1:NOS) + M - 1] * dmeanpar.deta * ddisppar.deta
    }  # Manual TRUE/FALSE

    wz <- w.wz.merge(w = w, wz = wz, n = n, M = M + (M - 1),
                     ndepy = NOS)
    wz
  }), list( .lmeanpar = lmeanpar, .ldisppar = ldisppar,
            .emeanpar = emeanpar, .edisppar = edisppar ))))
}  # genpoisson2



      


 genpoisson1 <-
  function(lmeanpar = "loglink",
           ldispind = "logloglink",  # dispind is greater than 1
           imeanpar = NULL, idispind = NULL,
           imethod = c(1, 1),
           ishrinkage = 0.95,
           gdispind = exp(1:5),
           parallel = FALSE,
           zero = "dispind") {
  lmeanpar <- as.list(substitute(lmeanpar))
  emeanpar <- link2list(lmeanpar)
  lmeanpar <- attr(emeanpar, "function.name")

  ldispind <- as.list(substitute(ldispind))
  edispind <- link2list(ldispind)
  ldispind <- attr(edispind, "function.name")

  if (!is.Numeric(ishrinkage, length.arg = 1) ||
     ishrinkage < 0 || 1 < ishrinkage)
    stop("bad input for argument 'ishrinkage'")

  if (!is.Numeric(gdispind, positive = TRUE) ||
      any(gdispind <= 1))
    stop("bad input for argument 'gdispind'")

  imethod <- rep_len(imethod, 2)  # For the two parameters
  if (!is.Numeric(imethod, length.arg = 2,
                  integer.valued = TRUE, positive = TRUE) ||
     any(imethod > 3))
    stop("argument 'imethod' must have values from 1:3")

  if (is.logical(parallel) && parallel && length(zero))
    stop("set 'zero = NULL' if 'parallel = TRUE'")

  new("vglmff",
  blurb = c("Generalized Poisson distribution (GP-1)\n\n",
            "Links:    ",
            namesof("meanpar", lmeanpar, earg = emeanpar), ", ",
            namesof("dispind", ldispind, earg = edispind), "\n",
            "Mean:     meanpar\n",
            "Variance: meanpar * dispind"),
 constraints = eval(substitute(expression({
    constraints <-
      cm.VGAM(matrix(1, M, 1), x = x,
              bool = .parallel ,
              constraints = constraints,
              apply.int = FALSE )
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 2,
                     predictors.names = predictors.names)
  }), list( .zero = zero,
            .parallel = parallel ))),

  infos = eval(substitute(function(...) {
    list(M1 = 2,
         Q1 = 1,
         dpqrfun = "genpois1",
         expected = TRUE,
         multipleResponses = TRUE,
         parameters.names = c("meanpar", "dispind"),
         imethod = .imethod ,
         zero = .zero )
  }, list( .zero = zero,
           .imethod = imethod ))),

  initialize = eval(substitute(expression({
    temp5 <-
    w.y.check(w = w, y = y,
              Is.nonnegative.y = TRUE,
              Is.integer.y = TRUE,
              ncol.w.max = Inf,  # 1,
              ncol.y.max = Inf,  # 1,
              out.wy = TRUE,
              colsyperw = 1,
              maximize = TRUE)
    w <- temp5$w
    y <- temp5$y

    extra$ncoly <- ncoly <- NOS <- ncol(y)
    extra$M1 <- M1 <- 2
    M <- M1 * ncoly
    mynames1 <- param.names("meanpar",  NOS, skip1 = TRUE)
    mynames2 <- param.names("dispind", NOS, skip1 = TRUE)

    predictors.names <-
       c(namesof(mynames1, .lmeanpar , .emeanpar , tag = FALSE),
         namesof(mynames2, .ldispind , .edispind , tag = FALSE))
    predictors.names <- predictors.names[interleave.VGAM(M, M1 = M1)]

    imethod <- as.vector( .imethod )
    init.dispind <- init.meanpar <- matrix(0, n, NOS)
    for (spp. in 1: NOS) {
      meay.w <- weighted.mean(y[, spp.], w[, spp.]) + 0.5
      vary.w <- c(cov.wt(cbind(y[, spp.]), wt = w[, spp.])$cov) + 0.5
      if ((dispind.index <- vary.w / meay.w) < 0.5)
        warning("Response ", spp. , " is underdispersed. ",
                "Numerical problems will probably arise.") else
      if (dispind.index < 0.875)
        warning("Response ", spp. , " appears underdispersed. ",
                "Numerical problems may arise.")
      init.meanpar[, spp.]  <- if (imethod[1] == 2) {
        meay.w
      } else if (imethod[1] == 3) {
        (y[, spp.] + median(y[, spp.]) + 0.125) / 2
      } else {  # imethod[1] == 1
        (1 - .ishrinkage ) * y[, spp.] + .ishrinkage * meay.w
      }

      init.dispind[, spp.] <- if (imethod[2] == 1) {  # Weighted MOM
        max(1.0625, (vary.w / meay.w))
      } else if (imethod[2] == 2) {
        genpois1.Loglikfun <- function(dispind1, y, x, w, extraargs)
          sum(c(w) * dgenpois1(y, mean = extraargs$meanpar0,
                               dispind = dispind1, log = TRUE))
        dispind1.grid <- as.vector( .gdispind )
        dispind1.init <- 
          grid.search(dispind1.grid, objfun = genpois1.Loglikfun,
                      y = y,  x = x, w = w,
              extraargs = list(meanpar0 = init.meanpar[, spp.]))
        dispind1.init
      } else {  # imethod[2] == 3
        max(1.0625, (0.25 * vary.w / meay.w))
      }
    }  # for spp.

    if (!length(etastart)) {
      init.meanpar  <- if (length( .imeanpar ))
             matrix( .imeanpar  , n, NOS, byrow = TRUE) else
             init.meanpar
      init.dispind <- if (length( .idispind ))
             matrix( .idispind , n, NOS, byrow = TRUE) else
             init.dispind
      etastart <-
        cbind(theta2eta(init.meanpar, .lmeanpar , .emeanpar ),
              theta2eta(init.dispind, .ldispind , .edispind ))
      etastart <- etastart[, interleave.VGAM(M, M1 = M1),
                           drop = FALSE]
    }
  }), list( .lmeanpar = lmeanpar, .ldispind = ldispind,
            .emeanpar = emeanpar, .edispind = edispind,
            .imeanpar = imeanpar, .idispind = idispind,
            .imethod = imethod, .ishrinkage = ishrinkage,
            .gdispind = gdispind)) ),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    meanpar <- eta2theta(eta[, c(TRUE, FALSE)], .lmeanpar ,
                         earg = .emeanpar )
    meanpar
  }, list( .lmeanpar = lmeanpar, .ldispind = ldispind,
           .emeanpar = emeanpar, .edispind = edispind ))),
  last = eval(substitute(expression({
    M1 <- 2
    temp.names <- c(mynames1, mynames2)
    temp.names <- temp.names[interleave.VGAM(M1 * ncoly, M1 = M1)]

    misc$link <- rep_len( .ldispind , M1 * ncoly)
    misc$earg <- vector("list", M1 * ncoly)
    names(misc$link) <-
    names(misc$earg) <- temp.names
    for (ii in 1:ncoly) {
      misc$link[ M1*ii-1 ] <- as.vector( .lmeanpar )
      misc$link[ M1*ii   ] <- as.vector( .ldispind )
      misc$earg[[M1*ii-1]] <- as.vector( .emeanpar )
      misc$earg[[M1*ii  ]] <- as.vector( .edispind )
    }
  }), list( .lmeanpar = lmeanpar, .ldispind = ldispind,
            .emeanpar = emeanpar, .edispind = edispind,
            .imethod = imethod ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL, summation = TRUE) {
    meanpar <- eta2theta(eta[, c(TRUE, FALSE)], .lmeanpar ,
                         earg = .emeanpar )
    dispind <- eta2theta(eta[, c(FALSE, TRUE)], .ldispind ,
                         earg = .edispind )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <- dgenpois1(y, mean = meanpar, dispind = dispind,
                           log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .lmeanpar = lmeanpar, .ldispind = ldispind,
           .emeanpar = emeanpar, .edispind = edispind ))),
   vfamily = c("genpoisson1"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    meanpar <- eta2theta(eta[, c(TRUE, FALSE)], .lmeanpar ,
                         earg = .emeanpar  )
    dispind <- eta2theta(eta[, c(FALSE, TRUE)], .ldispind ,
                         earg = .edispind )
    Lbnd <- 1  # pmax(-1, -meanpar / mmm)
    okay1 <- all(is.finite(dispind)) && all(Lbnd < dispind) &&
             all(is.finite(meanpar)) && all(0 < meanpar)
    okay1
  }, list( .lmeanpar = lmeanpar, .ldispind = ldispind,
           .emeanpar = emeanpar, .edispind = edispind ))),
  deriv = eval(substitute(expression({
    M1  <- 2
    NOS <- ncol(eta) / M1
    meanpar <- eta2theta(eta[, c(TRUE, FALSE)], .lmeanpar ,
                         earg = .emeanpar  )
    dispind <- eta2theta(eta[, c(FALSE, TRUE)], .ldispind ,
                         earg = .edispind )
    Tmp.y <- meanpar + y * (sqrt(dispind) - 1)
    dl.dmeanpar <- 1 / meanpar - 1 / sqrt(dispind) + (y - 1) / Tmp.y
    dl.ddispind <- 0.5 * y * (y - 1) / (sqrt(dispind) * Tmp.y) -
                   0.5 * y / dispind -
                   0.5 * (y - meanpar) / dispind^1.5
    dmeanpar.deta <- dtheta.deta(meanpar, .lmeanpar , earg = .emeanpar )
    ddispind.deta <- dtheta.deta(dispind, .ldispind , earg = .edispind )
    myderiv <- c(w) * cbind(dl.dmeanpar * dmeanpar.deta ,
                            dl.ddispind * ddispind.deta)
    myderiv[, interleave.VGAM(M, M1 = M1)]
  }), list( .lmeanpar = lmeanpar, .ldispind = ldispind,
            .emeanpar = emeanpar, .edispind = edispind ))),
  weight = eval(substitute(expression({
    wz <- matrix(0, n, M + M-1)  # Tridiagonal here but...

    lambda <- 1 - 1 / sqrt(dispind)  # In the unit interval
    theta <- meanpar / sqrt(dispind)
    ned2l.dtheta2 <- 1 / theta - lambda / (theta + 2 * lambda)
    ned2l.dthetalambda <- theta / (theta + 2 * lambda)
    ned2l.dlambda2 <- theta / (1 - lambda) +
                      2 * theta / (theta + 2 * lambda)


    Manual <- FALSE  # okay 
    Manual <- TRUE   # okay 
    if (Manual) {




      calA.tmp <- meanpar + 2 * (sqrt(dispind) - 1)
      ned2l.dmeanpar2 <- (meanpar + 2 * sqrt(dispind) *
        (sqrt(dispind) - 1)) / (meanpar * dispind * calA.tmp)
      ned2l.ddispind2 <- meanpar / (2 * calA.tmp * dispind^2)
      ned2l.dmeanpardispind <-
        (1 - sqrt(dispind)) / (calA.tmp * dispind^1.5)


      wz[, M1*(1:NOS) - 1    ] <- ned2l.dmeanpar2 * dmeanpar.deta^2
      wz[, M1*(1:NOS)        ] <- ned2l.ddispind2 * ddispind.deta^2
      wz[, M1*(1:NOS) + M - 1] <- ned2l.dmeanpardispind *
                                  dmeanpar.deta * ddispind.deta
    } else {

      

      Nnn <- 5  # Any small integer > 1 will do.
      arwz1 <- array(c(matrix(1, Nnn, NOS),
                       matrix(2, Nnn, NOS),
                       matrix(3, Nnn, NOS)),
                     dim = c(Nnn, NOS, 3))
      wz.ind <- arwz2wz(arwz1, M = M, M1 = M1)
      

      Mie <- eiM <- matrix(0, n, M + (M - 1))  # Diagonal really
      eiM[, M1*(1:NOS) - 1    ] <- ned2l.dtheta2
      eiM[, M1*(1:NOS)        ] <- ned2l.dlambda2
      eiM[, M1*(1:NOS) + M - 1] <- ned2l.dthetalambda

      Tmp <- J01 <- array(0, c(n, NOS, M1, M1))
      J01[, , 1, 1] <- 1 / sqrt(dispind)
      J01[, , 1, 2] <- 0
      J01[, , 2, 1] <- (-0.5) * meanpar / dispind^1.5
      J01[, , 2, 2] <- 0.5 / dispind^1.5

      for (jay in 1:M1) {
        for (kay in 1:M1) {
          for (sss in 1:M1) {
            jk.indices <- which(wz.ind[1, ] ==
                                iam(jay, sss, M = M1))
            Tmp[, , jay, kay] <-
            Tmp[, , jay, kay] +  # t(J01):
                    eiM[, jk.indices] * J01[, , kay, sss]
          }  # sss
        }  # kay
      }  # jay


      for (jay in 1:M1) {
        for (kay in (jay):M1) {
          jk.indices <- which(wz.ind[1, ] == iam(jay, kay, M = M1))
          for (sss in 1:M1)
            Mie[, jk.indices] <- Mie[, jk.indices] +
                                 J01[, , jay, sss] * Tmp[, , sss, kay]
        }  # kay
      }  # jay

      wz <- matrix(0, n, M + M-1)  # Tridiagonal but diagonal okay
       wz[, M1*(1:NOS) - 1    ] <-
      Mie[, M1*(1:NOS) - 1    ] * dmeanpar.deta^2
       wz[, M1*(1:NOS)        ] <-
      Mie[, M1*(1:NOS)        ] * ddispind.deta^2
       wz[, M1*(1:NOS) + M - 1] <-
      Mie[, M1*(1:NOS) + M - 1] * dmeanpar.deta * ddispind.deta
    }  # Manual TRUE/FALSE

    wz <- w.wz.merge(w = w, wz = wz, n = n, M = M + (M - 1),
                     ndepy = NOS)
    wz
  }), list( .lmeanpar = lmeanpar, .ldispind = ldispind,
            .emeanpar = emeanpar, .edispind = edispind ))))
}  # genpoisson1






 mccullagh89 <-
  function(ltheta = "rhobitlink",
           lnu = logofflink(offset = 0.5),
           itheta = NULL, inu = NULL,
           zero = NULL) {



  ltheta <- as.list(substitute(ltheta))
  etheta <- link2list(ltheta)
  ltheta <- attr(etheta, "function.name")

  lnuvec <- as.list(substitute(lnu))
  enuvec <- link2list(lnuvec)
  lnuvec <- attr(enuvec, "function.name")


  inuvec <- inu



  new("vglmff",
  blurb = c("McCullagh (1989)'s distribution \n",
    "f(y) = (1-2*theta*y+theta^2)^(-nu) * [1 - y^2]^(nu-1/2) /\n",
            "       Beta[nu+1/2, 1/2], ",
            "  -1 < y < 1, -1 < theta < 1, nu > -1/2\n",
            "Links:     ",
            namesof("theta", ltheta, earg = etheta), ", ",
            namesof("nu",    lnuvec, earg = enuvec),
            "\n", "\n",
            "Mean:     nu*theta/(1+nu)"),
  constraints = eval(substitute(expression({
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 2,
                     predictors.names = predictors.names)
  }), list( .zero = zero ))),
  infos = eval(substitute(function(...) {
    list(M1 = 2,
         Q1 = 1,
         expected = TRUE,
         multipleResponses = FALSE,
         parameters.names = c("theta", "nu"),
         ltheta = .ltheta ,
         lnu    = .lnu ,
         zero = .zero )
  }, list( .zero = zero,
           .ltheta = ltheta,
           .lnu = lnuvec ))),

  initialize = eval(substitute(expression({
    w.y.check(w, y)

    y <- as.numeric(y)
    if (any(y <= -1 | y >= 1))
      stop("all y values must be in (-1, 1)")

    predictors.names <-
      c(namesof("theta", .ltheta , earg = .etheta , tag = FALSE),
        namesof("nu",    .lnuvec , earg = .enuvec , tag = FALSE))

    if (!length(etastart)) {
      theta.init <- if (length( .itheta )) {
        rep_len( .itheta , n)
      } else {
        mccullagh89.aux <- function(thetaval, y, x, w, extraargs)
          mean((y - thetaval) *
               (thetaval^2 - 1) / (1 - 2*thetaval*y + thetaval^2))
        theta.grid <- seq(-0.9, 0.9, by = 0.05)
        try.this <- grid.search(theta.grid, objfun = mccullagh89.aux,
                                y = y,  x = x, w = w,
                                maximize = FALSE, abs.arg = TRUE)
        try.this <- rep_len(try.this, n)
        try.this
      }
      tmp <- y / (theta.init - y)
      tmp[tmp < -0.4] <- -0.4
      tmp[tmp > 10.0] <- 10.0
      nuvec.init <- rep_len(if (length( .inuvec ))
                                .inuvec else tmp, n)
      nuvec.init[!is.finite(nuvec.init)] <- 0.4
      etastart <-
        cbind(theta2eta(theta.init, .ltheta , earg = .etheta ),
              theta2eta(nuvec.init, .lnuvec , earg = .enuvec ))
    }
  }), list( .ltheta = ltheta, .lnuvec = lnuvec,
            .etheta = etheta, .enuvec = enuvec,
            .inuvec = inuvec, .itheta = itheta ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    Theta <- eta2theta(eta[, 1], .ltheta , earg = .etheta )
    nuvec <- eta2theta(eta[, 2], .lnuvec , earg = .enuvec )
    nuvec * Theta / (1 + nuvec)
  }, list( .ltheta = ltheta, .lnuvec = lnuvec,
           .etheta = etheta, .enuvec = enuvec ))),
  last = eval(substitute(expression({
    misc$link <-    c("theta" = .ltheta , "nu" = .lnuvec )
    misc$earg <- list("theta" = .etheta , "nu" = .enuvec )
  }), list( .ltheta = ltheta, .lnuvec = lnuvec,
            .etheta = etheta, .enuvec = enuvec ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    Theta <- eta2theta(eta[, 1], .ltheta , earg = .etheta )
    nuvec <- eta2theta(eta[, 2], .lnuvec , earg = .enuvec )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * ((nuvec - 0.5) * log1p(-y^2) -
                 nuvec * log1p(-2*Theta*y + Theta^2) -
                 lbeta(nuvec + 0.5, 0.5))
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .ltheta = ltheta, .lnuvec = lnuvec,
           .etheta = etheta, .enuvec = enuvec ))),
  vfamily = c("mccullagh89"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    Theta <- eta2theta(eta[, 1], .ltheta , earg = .etheta )
    nuvec <- eta2theta(eta[, 2], .lnuvec , earg = .enuvec )
    okay1 <- all(is.finite(Theta)) && all(abs(Theta) < 1) &&
             all(is.finite(nuvec)) && all(-0.5 < nuvec)
    okay1
  }, list( .ltheta = ltheta, .lnuvec = lnuvec,
           .etheta = etheta, .enuvec = enuvec ))),


  deriv = eval(substitute(expression({
    Theta <- eta2theta(eta[, 1], .ltheta , earg = .etheta )
    nuvec <- eta2theta(eta[, 2], .lnuvec , earg = .enuvec )

    dTheta.deta <- dtheta.deta(Theta, .ltheta , earg = .etheta )
    dnuvec.deta <- dtheta.deta(nuvec, .lnuvec , earg = .enuvec )

    dl.dTheta <- 2 * nuvec * (y-Theta) / (1 -2*Theta*y + Theta^2)
    dl.dnuvec <- log1p(-y^2) - log1p(-2 * Theta * y + Theta^2) -
                 digamma(nuvec + 0.5) + digamma(nuvec + 1)

    c(w) * cbind(dl.dTheta * dTheta.deta,
                 dl.dnuvec * dnuvec.deta)
  }), list( .ltheta = ltheta, .lnuvec = lnuvec,
            .etheta = etheta, .enuvec = enuvec ))),
  weight = eval(substitute(expression({
    ned2l.dTheta2 <- (2 * nuvec^2 / (1+nuvec)) / (1-Theta^2)
    ned2l.dnuvec2 <- trigamma(nuvec+0.5) - trigamma(nuvec+1)

    wz <- matrix(NA_real_, n, M)  # diagonal matrix
    wz[, iam(1, 1, M)] <- ned2l.dTheta2 * dTheta.deta^2
    wz[, iam(2, 2, M)] <- ned2l.dnuvec2 * dnuvec.deta^2

    c(w) * wz
  }), list( .ltheta = ltheta, .lnuvec = lnuvec ))))
}






 dirmultinomial <-
  function(lphi = "logitlink",
           iphi = 0.10, parallel = FALSE, zero = "M") {




  lphi <- as.list(substitute(lphi))
  ephi <- link2list(lphi)
  lphi <- attr(ephi, "function.name")



  if (!is.Numeric(iphi, positive = TRUE) ||
      max(iphi) >= 1.0)
    stop("bad input for argument 'iphi'")




  new("vglmff",
  blurb = c("Dirichlet-multinomial distribution\n\n",
            "Links:    ",
            "log(prob[1]/prob[M]), ..., log(prob[M-1]/prob[M]), ",
            namesof("phi", lphi, earg = ephi), "\n", "\n",
            "Mean:     shape_j / sum_j(shape_j)"),
  constraints = eval(substitute(expression({
    .ZERO <- .zero
    if (is.character( .ZERO)) .ZERO <- eval(parse(text = .ZERO))
    .PARALLEL <- .parallel
    if (is.logical( .PARALLEL) && .PARALLEL) {
      mycmatrix <- if (length( .ZERO ))
        stop("can only handle parallel = TRUE when ",
             "zero = NULL") else
        cbind(rbind(matrix(1, M - 1, 1), 0),
              rbind(matrix(0, M - 1, 1), 1))
    } else {
      mycmatrix <- if (M == 1) diag(1) else diag(M)
    }
    constraints <- cm.VGAM(mycmatrix, x = x,
                           bool = .PARALLEL ,
                           constraints, apply.int = TRUE)
    constraints <- cm.zero.VGAM(constraints, x = x, .ZERO ,
                     M = M, M1 = NA,
                     predictors.names = predictors.names)
  }), list( .parallel = parallel, .zero = zero ))),
  infos = eval(substitute(function(...) {
    list(M1 = NA,
         Q1 = NA,
         expected = TRUE,
         multipleResponses = FALSE,
         parameters.names = c("phi"),
         lphi = .lphi ,
         zero = .zero )
  }, list( .zero = zero,
           .lphi = lphi ))),

  initialize = eval(substitute(expression({
    mustart.orig <- mustart

    delete.zero.colns <- TRUE
    eval(process.categorical.data.VGAM)

    if (length(mustart.orig))
      mustart <- mustart.orig

    y <- as.matrix(y)
    ycount <- as.matrix(y * c(w))
    M <- ncol(y)

    if (max(abs(ycount - round(ycount))) > 1.0e-6)
      warning("there appears to be non-integer responses")

    if (min(ycount) < 0)
      stop("all values of the response (matrix) must be non-negative")

    predictors.names <-
      c(paste("log(prob[,", 1:(M-1), "]/prob[,", M, "])", sep = ""),
        namesof("phi", .lphi , short = TRUE))

    extra$n2 <- w # aka omega, must be integer # as.vector(rowSums(y))

    if (!length(etastart)) {
      if (length(mustart.orig)) {
        prob.init <- mustart
      } else {
        prob.init <- colSums(ycount)
        prob.init <- prob.init / sum(prob.init)
        prob.init <- matrix(prob.init, n, M, byrow = TRUE)
      }

      phi.init <- rep_len( .iphi , n)
      etastart <-
        cbind(log(prob.init[, -M] / prob.init[, M]),
              theta2eta(phi.init, .lphi , earg = .ephi ))
    }

    mustart <- NULL # Since etastart has been computed.

  }), list( .lphi = lphi, .ephi = ephi, .iphi = iphi ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    M <- NCOL(eta)
    temp <- cbind(exp(eta[, -M, drop = FALSE]), 1)
    prop.table(temp, 1)
  }, list( .ephi = ephi, .lphi = lphi ))),
  last = eval(substitute(expression({

    misc$link <- c(rep_len("loglink", M-1), .lphi )
    names(misc$link) <- c(
      paste("prob[,", 1:(M-1), "]/prob[,", M, "])", sep = ""),
      "phi")

    misc$earg <- vector("list", M)
    names(misc$earg) <- names(misc$link)
    for (ii in 1:(M-1))
      misc$earg[[ii]] <- list()
    misc$earg[[M]] <- .ephi

    misc$expected <- TRUE

    if (intercept.only) {  # phi & probs computed in @deriv
      misc$shape <- probs[1, ] * (1 / phi[1] - 1) 
    }
  }), list( .ephi = ephi, .lphi = lphi ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    M <- NCOL(eta)
    probs <- cbind(exp(eta[, -M]), 1)
    probs <- prop.table(probs, 1)
    phi <- eta2theta(eta[, M], .lphi , earg = .ephi )
    n <- length(phi)
    ycount <- as.matrix(y * c(w))

    ycount <- round(ycount)

    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ans <- rep_len(0.0, n)
      omega <- extra$n2
      for (jay in 1:M) {
        maxyj <- max(ycount[, jay])
        loopOveri <- (n < maxyj)
        if (loopOveri) {
          for (iii in 1:n) {
              rrr <- 1:ycount[iii, jay]  # a vector
              if (ycount[iii, jay] > 0)
                ans[iii] <- ans[iii] + sum(log((1-phi[iii]) *
                            probs[iii, jay] + (rrr-1)*phi[iii]))
          }
        } else {
          for (rrr in 1:maxyj) {
              index <- (rrr <= ycount[, jay]) & (ycount[, jay] > 0)
              if (any(index))
                  ans[index] <- ans[index] + log((1-phi[index]) *
                                probs[index, jay] +
                                (rrr-1) * phi[index])
          }
        }
      }  # end of jay loop

      maxomega <- max(omega)
      loopOveri <- n < maxomega
      if (loopOveri) {
        for (iii in 1:n) {
          rrr <- 1:omega[iii]
          ans[iii]<- ans[iii] - sum(log1p(-phi[iii] +
                                          (rrr-1) * phi[iii]))
        }
      } else {
        for (rrr in 1:maxomega) {
          ind8 <- rrr <= omega
          ans[ind8] <- ans[ind8] - log1p(-phi[ind8] +
                                         (rrr-1) * phi[ind8])
        }
      }
      ll.elts <- ans
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .ephi = ephi, .lphi = lphi ))),
  vfamily = c("dirmultinomial"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    M <- NCOL(eta)
    probs <- cbind(exp(eta[, -M]), 1)
    probs <- prop.table(probs, 1)
    phi <- eta2theta(eta[, M], .lphi , earg = .ephi )
    okay1 <- all(is.finite(probs)) && all(0 < probs & probs < 1) &&
             all(is.finite(phi  )) && all(0 < phi   & phi   < 1)
    okay1
  }, list( .ephi = ephi, .lphi = lphi ))),

  deriv = eval(substitute(expression({
    probs <- cbind(exp(eta[, -M]), 1)
    probs <- prop.table(probs, 1)

    phi <- eta2theta(eta[, M], .lphi , earg = .ephi )

    dl.dprobs <- matrix(0.0, n, M-1)
    dl.dphi <- rep_len(0.0, n)

    omega <- extra$n2
    ycount <- as.matrix(y * c(w))

    ycount <- round(ycount)

    for (jay in 1:M) {
      maxyj <- max(ycount[, jay])
      loopOveri <- n < maxyj
      if (loopOveri) {
        for (iii in 1:n) {
          rrr <- 1:ycount[iii, jay]
          if (ycount[iii, jay] > 0) {
            PHI <- phi[iii]
            dl.dphi[iii] <- dl.dphi[iii] +
              sum((rrr-1-probs[iii, jay]) / (
                  (1-PHI)*probs[iii, jay] +
                  (rrr-1)*PHI))

            tmp9 <- (1-PHI) / ((1-PHI)*probs[iii, jay] + (rrr-1)*PHI)
            if (jay < M) {
              dl.dprobs[iii, jay] <- dl.dprobs[iii, jay] + sum(tmp9)
            } else {
              for (jay2 in 1:(M-1))
                dl.dprobs[iii, jay2]<-dl.dprobs[iii, jay2]-sum(tmp9)
            }
          }
        }
      } else {
        for (rrr in 1:maxyj) {
          index <- (rrr <= ycount[, jay]) & (ycount[, jay] > 0)
          PHI <- phi[index]
          dl.dphi[index] <- dl.dphi[index] +
            (rrr-1-probs[index, jay]) / ((1-PHI)*probs[index, jay] +
            (rrr-1)*PHI)
          tmp9 <- (1-PHI) / ((1-PHI)*probs[index, jay] + (rrr-1)*PHI)
          if (jay < M) {
            dl.dprobs[index, jay] <- dl.dprobs[index, jay] + tmp9
          } else {
            for (jay2 in 1:(M-1))
              dl.dprobs[index, jay2] <- dl.dprobs[index, jay2] - tmp9
          }
        }
      }
    }  # end of jay loop
    maxomega <- max(omega)
    loopOveri <- n < maxomega
    if (loopOveri) {
      for (iii in 1:n) {
        rrr <- 1:omega[iii]
        dl.dphi[iii]<- dl.dphi[iii] -
                       sum((rrr-2)/(1 + (rrr-2)*phi[iii]))
      }
    } else {
      for (rrr in 1:maxomega) {
        index <- rrr <= omega
        dl.dphi[index] <-
        dl.dphi[index] - (rrr-2)/(1 + (rrr-2)*phi[index])
      }
    }

    dprobs.deta <- probs[, -M] * (1 - probs[, -M])  # n x (M-1)
    dphi.deta <- dtheta.deta(phi, .lphi , earg = .ephi )

    ans <- cbind(dl.dprobs * dprobs.deta,
                 dl.dphi   * dphi.deta)
    ans
  }), list( .ephi = ephi, .lphi = lphi ))),
    weight = eval(substitute(expression({
      wz <- matrix(0, n, dimm(M))
      loopOveri <- (n < maxomega)
      if (loopOveri) {
        for (iii in 1:n) {
          rrr <- 1:omega[iii]  # A vector
          PHI <- phi[iii]
          pYiM.ge.rrr <- 1 - pbetabinom.ab(q = rrr-1,
                                           size = omega[iii],
          shape1 <- probs[iii, M]*(1/PHI-1),
          shape2 <- (1-probs[iii, M])*(1/PHI-1))  # A vector
          denomM <- ((1-PHI)*probs[iii, M] + (rrr-1)*PHI)^2  # A vector
          wz[iii, iam(M, M, M)] <- wz[iii, iam(M, M, M)] +
            sum(probs[iii, M]^2 * pYiM.ge.rrr / denomM) -
            sum(1 / (1 + (rrr-2)*PHI)^2)
          for (jay in 1:(M-1)) {
              denomj <- ((1-PHI)*probs[iii, jay] + (rrr-1)*PHI)^2
              pYij.ge.rrr <- 1 - pbetabinom.ab(q = rrr-1,
                                               size = omega[iii],
                  shape1<-probs[iii, jay]*(1/PHI-1),
                  shape2<-(1-probs[iii, jay])*(1/PHI-1))
              wz[iii, iam(jay, jay, M)] <- wz[iii, iam(jay, jay, M)] +
                  sum(pYij.ge.rrr / denomj) +
                  sum(pYiM.ge.rrr / denomM)
              for (kay in jay:(M-1)) if (kay > jay) {
                wz[iii, iam(jay, kay, M)] <-
                wz[iii, iam(jay, kay, M)] +
                    sum(pYiM.ge.rrr / denomM)
              }
              wz[iii, iam(jay, M, M)] <- wz[iii, iam(jay, M, M)] +
                      sum(probs[iii, jay] * pYij.ge.rrr / denomj) -
                      sum(probs[iii, M]   * pYiM.ge.rrr / denomM)
              wz[iii, iam(M, M, M)] <- wz[iii, iam(M, M, M)] +
                      sum(probs[iii, jay]^2 * pYij.ge.rrr / denomj)
          }  # end of jay loop
      }  # end of iii loop
  } else {
      for (rrr in 1:maxomega) {
          ind5 <- rrr <= omega
          PHI <- phi[ind5]
          pYiM.ge.rrr <- 1 - pbetabinom.ab(q = rrr-1,
                             size = omega[ind5],
                             shape1 <- probs[ind5, M]*(1/PHI-1),
                             shape2 <- (1-probs[ind5, M])*(1/PHI-1))
          denomM <- ((1-PHI)*probs[ind5, M] + (rrr-1)*PHI)^2
          wz[ind5, iam(M, M, M)] <- wz[ind5, iam(M, M, M)] +
              probs[ind5, M]^2 * pYiM.ge.rrr / denomM -
              1 / (1 + (rrr-2)*PHI)^2
          for (jay in 1:(M-1)) {
              denomj <- ((1-PHI)*probs[ind5, jay] + (rrr-1)*PHI)^2
              pYij.ge.rrr <- 1 - pbetabinom.ab(q = rrr-1,
                                               size = omega[ind5],
                  shape1<-probs[ind5, jay]*(1/PHI-1),
                  shape2<-(1-probs[ind5, jay])*(1/PHI-1))
              wz[ind5, iam(jay, jay, M)] <-
              wz[ind5, iam(jay, jay, M)] +
                  pYij.ge.rrr / denomj + pYiM.ge.rrr / denomM
              for (kay in jay:(M-1)) if (kay > jay) {
                wz[ind5, iam(jay, kay, M)] <-
                wz[ind5, iam(jay, kay, M)] +
                    pYiM.ge.rrr / denomM
              }
              wz[ind5, iam(jay, M, M)] <- wz[ind5, iam(jay, M, M)] +
                  probs[ind5, jay] * pYij.ge.rrr / denomj -
                  probs[ind5, M]   * pYiM.ge.rrr / denomM
              wz[ind5, iam(M, M, M)] <- wz[ind5, iam(M, M, M)] +
                  probs[ind5, jay]^2 * pYij.ge.rrr / denomj
          }  # end of jay loop
        }  # end of rrr loop
    }

    for (jay in 1:(M-1))
      for (kay in jay:(M-1))
        wz[, iam(jay, kay, M)] <- wz[, iam(jay, kay, M)] * (1-phi)^2
    for (jay in 1:(M-1))
      wz[, iam(jay, M, M)] <- wz[, iam(jay, M, M)] * (phi-1) / phi
    wz[, iam(M, M, M)] <- wz[, iam(M, M, M)] / phi^2

    d1Thetas.deta <- cbind(dprobs.deta,
                           dphi.deta)
    index <- iam(NA, NA, M, both = TRUE, diag = TRUE)
    wz <- wz * d1Thetas.deta[, index$row] *
               d1Thetas.deta[, index$col]
    wz
  }), list( .ephi = ephi, .lphi = lphi ))))
}  # dirmultinomial






dirmul.old <- function(link = "loglink", ialpha = 0.01,
                       parallel = FALSE, zero = NULL) {

  link <- as.list(substitute(link))
  earg <- link2list(link)
  link <- attr(earg, "function.name")



  if (!is.Numeric(ialpha, positive = TRUE))
    stop("'ialpha' must contain positive values only")


  new("vglmff",
  blurb = c("Dirichlet-Multinomial distribution\n\n",
            "Links:     ",
            namesof("shape1", link, earg = earg), ", ..., ",
            namesof("shapeM", link, earg = earg), "\n\n",
            "Posterior mean:    (n_j + shape_j)/(2*sum(n_j) + ",
                                "sum(shape_j))\n"),
  constraints = eval(substitute(expression({
    constraints <- cm.VGAM(matrix(1, M, 1), x = x,
                           bool = .parallel ,
                           constraints, apply.int = TRUE)
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = NA,
                     predictors.names = predictors.names)
  }), list( .parallel = parallel, .zero = zero ))),
  initialize = eval(substitute(expression({
    y <- as.matrix(y)
    M <- ncol(y)
      if (any(y != round(y )))
        stop("all y values must be integer-valued")

    predictors.names <-
      namesof(param.names("shape", M, skip1 = TRUE),
                          .link , earg = .earg , short = TRUE)

      extra$n2 <- rowSums(y)  # Nb. don't multiply by 2
      extra$y  <- y

      if (!length(etastart)) {
        yy <- if (is.numeric( .ialpha))
            matrix( .ialpha , n, M, byrow = TRUE) else
            matrix(runif(n*M), n, M)
        etastart <- theta2eta(yy, .link , earg = .earg )
    }
  }), list( .link = link, .earg = earg, .ialpha = ialpha ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    shape <- eta2theta(eta, .link , earg = .earg )
    M <- if (is.matrix(eta)) ncol(eta) else 1
    sumshape <- as.vector(shape %*% rep_len(1, M))
    (extra$y + shape) / (extra$n2 + sumshape)
  }, list( .link = link, .earg = earg ))),
  last = eval(substitute(expression({
    misc$link <- rep_len( .link , M)
    names(misc$link) <- param.names("shape", M, skip1 = TRUE)

    misc$earg <- vector("list", M)
    names(misc$earg) <- names(misc$link)
    for (ii in 1:M)
      misc$earg[[ii]] <- .earg

    misc$pooled.weight <- pooled.weight
  }), list( .link = link, .earg = earg ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    shape <- eta2theta(eta, .link , earg = .earg )
    M <- if (is.matrix(eta)) ncol(eta) else 1
    sumshape <- as.vector(shape %*% rep_len(1, M))
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * (lgamma(sumshape) - lgamma(extra$n2 + sumshape )) +
        c(w) * (lgamma(y + shape) - lgamma(shape ))
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .link = link, .earg = earg ))),
  vfamily = c("dirmul.old"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    shape <- eta2theta(eta, .link , earg = .earg )
    okay1 <- all(is.finite(shape)) && all(0 < shape)
    okay1
  }, list( .link = link, .earg = earg ))),
  deriv = eval(substitute(expression({
    shape <- eta2theta(eta, .link , earg = .earg )

    sumshape <- as.vector(shape %*% rep_len(1, M))
    dl.dsh <- digamma(sumshape) - digamma(extra$n2 + sumshape) +
             digamma(y + shape) - digamma(shape)

    dsh.deta <- dtheta.deta(shape, .link , earg = .earg )

    c(w) * dl.dsh * dsh.deta
  }), list( .link = link, .earg = earg ))),
  weight = eval(substitute(expression({
    index <- iam(NA, NA, M, both = TRUE, diag = TRUE)
    wz <- matrix(trigamma(sumshape) - trigamma(extra$n2 + sumshape),
                nrow = n, ncol = dimm(M))
    wz[, 1:M] <- wz[, 1:M] + trigamma(y + shape) - trigamma(shape)
    wz <- -wz * dsh.deta[, index$row] * dsh.deta[, index$col]


    if (TRUE && intercept.only) {
      sumw <- sum(w)
      for (ii in 1:ncol(wz))
        wz[, ii] <- sum(wz[, ii]) / sumw
      pooled.weight <- TRUE
      wz <- c(w) * wz # Put back the weights
    } else
        pooled.weight <- FALSE

    wz
  }), list( .link = link, .earg = earg ))))
}  # dirmul.old






rdiric <- function(n, shape, dimension = NULL,
                   is.matrix.shape = FALSE) {
  use.n <- if ((length.n <- length(n)) > 1) length.n else
           if (!is.Numeric(n, integer.valued = TRUE,
                           length.arg = 1, positive = TRUE))
              stop("bad input for argument 'n'") else n

  shape.orig <- shape


  if (is.matrix.shape) {

    if (!is.matrix(shape))
      stop("argument 'shape' is not a matrix")
    if (!is.numeric(dimension))
      dimension <- ncol(shape)

    n.shape <- nrow(shape)
    shape <- kronecker(matrix(1, use.n, 1), shape)

    ans <- rgamma(use.n * n.shape * dimension,
                  shape)
    dim(ans) <- c(use.n * n.shape, dimension)
  } else {
    if (!is.numeric(dimension))
      dimension <- length(shape)

    if (length(shape) != dimension)
      shape <- rep_len(shape, dimension)

    ans <- rgamma(use.n * dimension,
                  rep(shape, rep(use.n, dimension)))
    dim(ans) <- c(use.n, dimension)
  }


  ans <- ans / rowSums(ans)

  names.shape.orig <- names(shape.orig)
  if (is.character(names.shape.orig) && !is.matrix.shape)
    colnames(ans) <- names.shape.orig

  ans
}




 dirichlet <-
  function(link = "loglink", parallel = FALSE, zero = NULL,
           imethod = 1) {


  link <- as.list(substitute(link))
  earg <- link2list(link)
  link <- attr(earg, "function.name")


  if (!is.Numeric(imethod, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE) ||
     imethod > 2)
    stop("argument 'imethod' must be 1 or 2")





  new("vglmff",
  blurb = c("Dirichlet distribution\n\n",
            "Links:     ",
            namesof("shape_j", link, earg = earg), "\n\n",
        "Mean:     shape_j/(1 + sum(shape_j)), j = 1,..,ncol(y)"),
  constraints = eval(substitute(expression({
    constraints <- cm.VGAM(matrix(1, M, 1), x = x,
                           bool = .parallel ,
                           constraints, apply.int = TRUE)
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = NA,
                     predictors.names = predictors.names)
  }), list( .parallel = parallel, .zero = zero ))),
  infos = eval(substitute(function(...) {
    list(M1 = NA,
         Q1 = NA,
         expected = TRUE,
         multipleResponses = FALSE,
         parameters.names = c("shape"),
         link = .link ,
         zero = .zero )
  }, list( .zero = zero,
           .link = link ))),

  initialize = eval(substitute(expression({
    y <- as.matrix(y)
    M <- ncol(y)

    w.y.check(w = w, y = y,
              Is.positive.y = TRUE,
              ncol.w.max = 1,
              ncol.y.max = Inf,
              out.wy = FALSE,
              colsyperw = NULL,
              maximize = FALSE)

    if (any(y <= 0) || any(y >= 1))
      stop("all y values must be > 0 and < 1")

    mynames1 <- param.names("shape", M, skip1 = TRUE)
    predictors.names <-
      namesof(mynames1, .link , earg = .earg , short = TRUE)
    if (!length(etastart)) {
      yy <- if ( .imethod == 2) {
        matrix(colMeans(y), nrow(y), M, byrow = TRUE)
      } else {
        0.5 * (y + matrix(colMeans(y), nrow(y), M, byrow = TRUE))
      }

      etastart <- theta2eta(yy, .link , earg = .earg )
    }
  }), list( .link = link, .earg = earg,
            .imethod = imethod ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    shape <- eta2theta(eta, .link , earg = .earg )
    prop.table(shape, 1)
  }, list( .link = link, .earg = earg ))),
  last = eval(substitute(expression({
    misc$link <- rep_len( .link , M)
    names(misc$link) <- mynames1

    misc$earg <- vector("list", M)
    names(misc$earg) <- mynames1
    for (ii in 1:M)
      misc$earg[[ii]] <- .earg

    misc$imethod <- .imethod
  }), list( .link = link, .earg = earg,
            .imethod = imethod ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    shape <- eta2theta(eta, .link , earg = .earg )
    M <- if (is.matrix(eta)) ncol(eta) else 1
    sumshape <- as.vector(shape %*% rep_len(1, M))
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        (c(w) * lgamma(sumshape)) -
        (c(w) * lgamma(shape)) +
        (c(w) * (shape-1) * log(y))
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .link = link, .earg = earg ))),
  vfamily = c("dirichlet"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    shape <- eta2theta(eta, .link , earg = .earg )
    okay1 <- all(is.finite(shape)) && all(0 < shape)
    okay1
  }, list( .link = link, .earg = earg ))),


  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    M <- NCOL(eta)
    Shape <- eta2theta(eta, .link , earg = .earg )
    rdiric(nsim,  # has a different meaning;
           shape = as.matrix(Shape),
           dimension = M,
           is.matrix.shape = TRUE)  # 20140106; This is new
  }, list( .link = link, .earg = earg ))),



  deriv = eval(substitute(expression({
    shape <- eta2theta(eta, .link , earg = .earg )

    sumshape <- as.vector(shape %*% rep_len(1, M))
    dl.dsh <- digamma(sumshape) - digamma(shape) + log(y)

    dsh.deta <- dtheta.deta(shape, .link , earg = .earg )

    c(w) * dl.dsh * dsh.deta
  }), list( .link = link, .earg = earg ))),
  weight = expression({
    index <- iam(NA, NA, M, both = TRUE, diag = TRUE)
    wz <- matrix(-trigamma(sumshape), nrow = n, ncol = dimm(M))
    wz[, 1:M] <- trigamma(shape) + wz[, 1:M]
    wz <- c(w) * wz * dsh.deta[, index$row] * dsh.deta[, index$col]
    wz
  }))
}  # dirichlet






 cauchy <-
  function(llocation = "identitylink", lscale = "loglink",
           imethod = 1,
           ilocation = NULL, iscale = NULL,
           gprobs.y = ppoints(19),  # seq(0.2, 0.8, by = 0.2),
           gscale.mux = exp(-3:3),
           zero = "scale") {

  llocat <- as.list(substitute(llocation))
  elocat <- link2list(llocat)
  llocat <- attr(elocat, "function.name")
  ilocat <- ilocation

  lscale <- as.list(substitute(lscale))
  escale <- link2list(lscale)
  lscale <- attr(escale, "function.name")


  if (!is.Numeric(imethod, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE) ||
     imethod > 3)
    stop("argument 'imethod' must be 1 or 2 or 3")

  if (length(iscale) && !is.Numeric(iscale, positive = TRUE))
    stop("bad input for argument 'iscale'")
  if (!is.Numeric(gprobs.y, positive = TRUE) || max(gprobs.y) >= 1)
    stop("bad input for argument 'gprobs.y'")



  new("vglmff",
  blurb = c("Two-parameter Cauchy distribution ",
            "(location & scale to be estimated)\n\n",
            "Link:    ",
            namesof("location", llocat, earg = elocat), ", ",
            namesof("scale",    lscale, earg = escale), "\n\n",
            "Mean:     NA\n",
            "Variance: NA"),
  charfun = eval(substitute(function(x, eta, extra = NULL,
                                     varfun = FALSE) {
    Locat <- eta2theta(eta[, c(TRUE, FALSE)],
                       .llocat , earg = .elocat )
    Scale <- eta2theta(eta[, c(FALSE, TRUE)],
                       .lscale , earg = .escale )
    if (varfun) {
      Locat * Inf
    } else {
      exp(1i * x * Locat - Scale * abs(x))
    }
  }, list( .llocat = llocat, .lscale = lscale,
           .elocat = elocat, .escale = escale ))),

  constraints = eval(substitute(expression({
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 2,
                     predictors.names = predictors.names)
  }), list( .zero = zero ))),

  infos = eval(substitute(function(...) {
    list(M1 = 2,
         Q1 = 1,
         dpqrfun = "cauchy",  # cauchy2
         charfun = TRUE,
         expected = TRUE,
         multipleResponses = FALSE,
         parameters.names = c("location", "scale"),
         llocation = .llocat ,
         lscale    = .lscale ,
         zero = .zero )
  }, list( .zero   = zero,
           .llocat = llocat,
           .lscale = lscale ))),

  rqresslot = eval(substitute(
    function(mu, y, w, eta, extra = NULL) {
      Locat <- eta2theta(eta[, c(TRUE, FALSE)],
                         .llocat , earg = .elocat )
      Scale <- eta2theta(eta[, c(FALSE, TRUE)],
                         .lscale , earg = .escale )
    scrambleseed <- runif(1)  # To scramble the seed
      qnorm(pcauchy(y, location = Locat, scale = Scale))
  }, list( .llocat = llocat, .lscale = lscale,
           .elocat = elocat, .escale = escale ))),

  initialize = eval(substitute(expression({
    M1 <- 2

    temp5 <-
    w.y.check(w = w, y = y,
              ncol.w.max = Inf,
              ncol.y.max = Inf,
              out.wy = TRUE,
              colsyperw = 1,
              maximize = TRUE)
    w <- temp5$w
    y <- temp5$y

    M <- M1 * ncol(y)
    NOS <- ncoly <- ncol(y)  # Number of species

    mynames1 <- param.names("location",   NOS, skip1 = TRUE)
    mynames2 <- param.names("scale",      NOS, skip1 = TRUE)
    predictors.names <-
        c(namesof(mynames1, .llocat , earg = .elocat , tag = FALSE),
          namesof(mynames2, .lscale , earg = .escale , tag = FALSE))
    predictors.names <- predictors.names[interleave.VGAM(M, M1 = M1)]




    gprobs.y   <- .gprobs.y
    gscale.mux <- .gscale.mux

    ilocation <- .ilocat     # Default is NULL
    iscale <- .iscale  # Default is NULL

    if (!length(etastart)) {
      locat.init <-
      scale.init <- matrix(NA_real_, n, NOS)


      for (jay in 1:NOS) {  # For each response 'y_jay'... do:
        locat.init.jay <- if ( .imethod == 1) {
          unique(quantile(y[, jay], probs = .gprobs.y ))
        } else if ( .imethod == 2) {
          median(y[, jay])
        } else {
          weighted.mean(y[, jay], w = w[, jay])
        }
        if (length(ilocation))
          locat.init.jay <- ilocation  # [, jay]

         mad.est <- mad(y[, jay]) + 0.001
         scale.init.jay <- gscale.mux * mad.est
        if (length(iscale))
          scale.init.jay <- iscale  # [, jay]


        cauchy2.Loglikfun <- function(Locat, Scaleval,
                                      y, x = NULL, w, extraargs) {
          sum(c(w) * dcauchy(x = y, Locat, Scaleval, log = TRUE))
        }

        try.this <-
          grid.search2(locat.init.jay, scale.init.jay,
                       objfun = cauchy2.Loglikfun,
                       y = y[, jay], w = w[, jay],
                       ret.objfun = TRUE)  # Last value is the loglik

        locat.init[, jay] <- try.this["Value1"]
        scale.init[, jay] <- try.this["Value2"]

      }  # for (jay ...)



      etastart <-
        cbind(theta2eta(locat.init, link = .llocat , earg = .elocat ),
              theta2eta(scale.init, link = .lscale , earg = .escale ))


      if (M > M1)
      etastart <-
        etastart[, interleave.VGAM(M, M1 = M1), drop = FALSE]
    }  # !length(etastart)
  }), list( .llocat = llocat, .lscale = lscale,
            .elocat = elocat, .escale = escale,
            .ilocat = ilocat, .iscale = iscale,
            .gprobs.y = gprobs.y, .gscale.mux = gscale.mux,
            .imethod  = imethod ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    eta2theta(eta[, c(TRUE, FALSE), drop = FALSE],
              .llocat , earg = .elocat )
  }, list( .llocat = llocat,
           .elocat = elocat ))),
  last = eval(substitute(expression({
    misc$link <- c(rep_len( .llocat , NOS),
                   rep_len( .lscale , NOS))
    misc$link <- misc$link[interleave.VGAM(M, M1 = M1)]
    temp.names <- c(mynames1, mynames2)
    temp.names <- temp.names[interleave.VGAM(M, M1 = M1)]
    names(misc$link) <- temp.names

    misc$earg <- vector("list", M)
    names(misc$earg) <- temp.names
    for (ii in 1:ncoly) {
      misc$earg[[M1*ii-1]] <- .elocat
      misc$earg[[M1*ii  ]] <- .escale
    }

    misc$imethod <- .imethod
  }), list( .llocat = llocat, .lscale = lscale,
            .elocat = elocat, .escale = escale,
            .imethod = imethod ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
      Locat <- eta2theta(eta[, c(TRUE, FALSE)],
                         .llocat , earg = .elocat )
      Scale <- eta2theta(eta[, c(FALSE, TRUE)],
                         .lscale , earg = .escale )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * dcauchy(y, Locat, scale = Scale, log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .llocat = llocat, .lscale = lscale,
           .elocat = elocat, .escale = escale ))),
  vfamily = c("cauchy"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {#
    Locat <- eta2theta(eta[, c(TRUE, FALSE)],
                       .llocat , earg = .elocat )
    Scale <- eta2theta(eta[, c(FALSE, TRUE)],
                       .lscale , earg = .escale )
    okay1 <- all(is.finite(Locat)) &&
             all(is.finite(Scale)) && all(0 < Scale)
    okay1
  }, list( .llocat = llocat, .lscale = lscale,
           .elocat = elocat, .escale = escale ))),






  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    Locat <- eta2theta(eta[, c(TRUE, FALSE)],
                       .llocat , earg = .elocat )
    Scale <- eta2theta(eta[, c(FALSE, TRUE)],
                       .lscale , earg = .escale )
    rcauchy(nsim * length(Scale), location = Locat, scale = Scale)
  }, list( .llocat = llocat, .lscale = lscale,
           .elocat = elocat, .escale = escale ))),



  deriv = eval(substitute(expression({
    Locat <- eta2theta(eta[, c(TRUE, FALSE)],
                       .llocat , earg = .elocat )
    Scale <- eta2theta(eta[, c(FALSE, TRUE)],
                       .lscale , earg = .escale )
    dlocat.deta <- dtheta.deta(Locat, .llocat , earg = .elocat )
    dscale.deta <- dtheta.deta(Scale, .lscale , earg = .escale )
    Z <- (y - Locat) / Scale
    dl.dlocat <- 2 * Z / ((1 + Z^2) * Scale)
    dl.dscale <- (Z^2 - 1) / ((1 + Z^2) * Scale)
    myderiv <- c(w) * cbind(dl.dlocat * dlocat.deta,
                            dl.dscale * dscale.deta)
    myderiv[, interleave.VGAM(M, M1 = M1)]
  }), list( .escale = escale, .lscale = lscale,
            .elocat = elocat, .llocat = llocat ))),
  weight = eval(substitute(expression({
    wz <- cbind((0.5 / Scale^2) * dlocat.deta^2,
                (0.5 / Scale^2) * dscale.deta^2) * c(w)
    wz <- wz[, interleave.VGAM(M, M1 = M1)]
    wz
  }), list( .llocat = llocat, .lscale = lscale,
            .elocat = elocat, .escale = escale ))))
}  # cauchy









 cauchy1 <-
  function(scale.arg = 1, llocation = "identitylink",
           ilocation = NULL, imethod = 1,
           gprobs.y = ppoints(19),
           zero = NULL) {


  llocat <- as.list(substitute(llocation))
  elocat <- link2list(llocat)
  llocat <- attr(elocat, "function.name")
  ilocat <- ilocation



  if (!is.Numeric(scale.arg, positive = TRUE))
    stop("bad input for 'scale.arg'")
  if (!is.Numeric(imethod, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE) ||
     imethod > 3)
    stop("argument 'imethod' must be 1 or 2 or 3")



  new("vglmff",
  blurb = c("One-parameter Cauchy distribution ",
            "(location unknown, scale known)\n\n",
            "Link:    ",
            namesof("location", llocat, earg = elocat), "\n\n",
            "Mean:     NA\n",
            "Variance: NA"),
  charfun = eval(substitute(function(x, eta, extra = NULL,
                                     varfun = FALSE) {
    locat <- eta2theta(eta, .llocat , earg = .elocat )
    if (varfun) {
      locat * Inf
    } else {
      exp(1i * x * locat - .scale.arg * abs(x))
    }
  }, list( .elocat = elocat, .scale.arg = scale.arg,
           .llocat = llocat ))),
  constraints = eval(substitute(expression({
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 1,
                     predictors.names = predictors.names)
  }), list( .zero = zero ))),


  infos = eval(substitute(function(...) {
    list(M1 = 1,
         Q1 = 1,
         charfun = TRUE,
         expected = TRUE,
         multipleResponses = FALSE,  # zz
         parameters.names = c("location"),
         llocation = .llocat ,
         imethod = .imethod ,
         zero = .zero ,
         scale.arg = .scale.arg )
  }, list( .llocat = llocat, .scale.arg = scale.arg,
           .imethod = imethod,
           .zero = zero ))),

  rqresslot = eval(substitute(
    function(mu, y, w, eta, extra = NULL) {
      Locat <- eta2theta(eta, .llocat , earg = .elocat )
      Scale <- ( .scale.arg )
    scrambleseed <- runif(1)  # To scramble the seed
      qnorm(pcauchy(y, location = Locat, scale = Scale))
  }, list( .llocat = llocat, .scale.arg = scale.arg,
           .elocat = elocat ))),

  initialize = eval(substitute(expression({
    temp5 <-
    w.y.check(w = w, y = y,
              Is.positive.y = FALSE,
              ncol.w.max = Inf,
              ncol.y.max = Inf,
              out.wy = TRUE,
              colsyperw = 1,
              maximize = TRUE)
    w <- temp5$w
    y <- temp5$y


    ncoly <- ncol(y)
    M1 <- 1
    extra$ncoly <- ncoly
    extra$M1 <- M1
    M <- M1 * ncoly

    mynames1  <- param.names("location", ncoly, skip1 = TRUE)
    predictors.names <-
      namesof(mynames1, .llocat , earg = .elocat , tag = FALSE)


    if (!length(etastart)) {
      loc.init <- matrix(0, nrow(x), ncoly)
      cauchy1.Loglikfun <- function(loc, y, x = NULL,
                                    w, extraargs = NULL) {
        scal <- extraargs
        sum(c(w) * dcauchy(y, loc, scale = scal, log = TRUE))
      }

      for (jay in 1:ncoly) {
        loc.init[, jay] <-
          if ( .imethod == 2) median(y[, jay]) else
          if ( .imethod == 3) y[, jay] else {
          gloc <- unique(quantile(y[, jay], probs = .gprobs.y ))
          tmp1 <- grid.search(gloc,
                              objfun = cauchy1.Loglikfun,
                              y = y[, jay], w = w[, jay],
                              extraargs = .scale.arg )
          tmp1
        }
        if ( .llocat == "loglink")
          loc.init[, jay] <- pmax(min(abs(y[, jay])) +
                                  mad(y[, jay])/100,
                                  loc.init[, jay])
      }
      etastart <- theta2eta(loc.init, .llocat , earg = .elocat )
    }
    }), list( .scale.arg = scale.arg, .ilocat = ilocat,
              .elocat = elocat, .llocat = llocat,
              .imethod = imethod, .gprobs.y = gprobs.y ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    eta2theta(eta, .llocat , earg = .elocat )
  }, list( .llocat = llocat,
           .elocat = elocat ))),
  last = eval(substitute(expression({
    misc$earg <- vector("list", M)
    names(misc$earg) <- mynames1
    for (ilocal in 1:ncoly) {
      misc$earg[[ilocal]] <- .elocat
    }

    misc$link <- rep_len( .llocat , ncoly)
    names(misc$link) <- mynames1

    misc$scale.arg <- .scale.arg
  }), list( .elocat = elocat, .scale.arg = scale.arg, 
            .llocat = llocat ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    locat <- eta2theta(eta, .llocat , earg = .elocat )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * dcauchy(x = y, loc = locat, scale = .scale.arg ,
                       log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .elocat = elocat, .scale.arg = scale.arg,
           .llocat = llocat ))),
  vfamily = c("cauchy1"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    locat <- eta2theta(eta, .llocat , earg = .elocat )
    okay1 <- all(is.finite(locat))
    okay1
  }, list( .elocat = elocat, .scale.arg = scale.arg,
           .llocat = llocat ))),






  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    locat <- eta2theta(eta, .llocat , earg = .elocat )
    rcauchy(nsim * length(locat), location = locat,
            scale = .scale.arg )
  }, list( .elocat = elocat, .scale.arg = scale.arg,
           .llocat = llocat ))),


  deriv = eval(substitute(expression({
    locat <- eta2theta(eta, .llocat , earg = .elocat )
    temp <- (y - locat) / .scale.arg
    dl.dlocat <- 2 * temp / ((1 + temp^2) * .scale.arg )

    dlocation.deta <- dtheta.deta(locat, .llocat , earg = .elocat )

    c(w) * dl.dlocat * dlocation.deta
  }), list( .elocat = elocat, .scale.arg = scale.arg,
            .llocat = llocat ))),
  weight = eval(substitute(expression({
    wz <- c(w) * dlocation.deta^2 / ( .scale.arg^2 * 2)
    wz
  }), list( .elocat = elocat, .scale.arg = scale.arg,
            .llocat = llocat ))))
}  # cauchy1








 logistic1 <-
  function(llocation = "identitylink",
           scale.arg = 1, imethod = 1) {
  if (!is.Numeric(scale.arg, length.arg = 1, positive = TRUE))
    stop("'scale.arg' must be a single positive number")
  if (!is.Numeric(imethod, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE) ||
     imethod > 2)
    stop("argument 'imethod' must be 1 or 2")


  llocat <- as.list(substitute(llocation))
  elocat <- link2list(llocat)
  llocat <- attr(elocat, "function.name")



  new("vglmff",
  blurb = c("One-parameter logistic distribution ",
            "(location unknown, scale known)\n\n",
            "Link:    ",
            namesof("location", llocat, earg = elocat), "\n\n",
            "Mean:     location", "\n",
            "Variance: (pi*scale)^2 / 3"),
  infos = eval(substitute(function(...) {
    list(M1 = 2,
         Q1 = 1,
         expected = TRUE,
         multipleResponses = FALSE,
         parameters.names = c("location"),
         scale.arg = .scale.arg ,
         llocation = .llocation )
  }, list( .llocation = llocation,
           .scale.arg = scale.arg ))),

 # 20220521; untested:
 rqresslot = eval(substitute(
    function(mu, y, w, eta, extra = NULL) {
      Locat <- eta2theta(eta, .llocat , earg = .elocat )
      Scale <- ( .scale.arg )
    scrambleseed <- runif(1)  # To scramble the seed
      qnorm(plogis(y, location = Locat, scale = Scale))
  }, list( .llocat = llocat, .scale.arg = scale.arg,
           .elocat = elocat ))),

  initialize = eval(substitute(expression({

    w.y.check(w = w, y = y)


    predictors.names <- namesof("location", .llocat ,
                                earg = .elocat , tag = FALSE)


    if (!length(etastart)) {
      locat.init <- if ( .imethod == 1) y else median(y)
      locat.init <- rep_len(locat.init, n)
      if ( .llocat == "loglink")
        locat.init <- abs(locat.init) + 0.001
      etastart <-
        theta2eta(locat.init, .llocat , earg = .elocat )
    }
  }), list( .imethod = imethod, .llocat = llocat,
            .elocat = elocat ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    eta2theta(eta, .llocat , earg = .elocat )
  }, list( .llocat = llocat,
           .elocat = elocat ))),
  last = eval(substitute(expression({
    misc$link <-    c(location = .llocat)
    misc$earg <- list(location = .elocat )
    misc$scale.arg <- .scale.arg
  }), list( .llocat = llocat,
            .elocat = elocat, .scale.arg = scale.arg ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    locat <- eta2theta(eta, .llocat , earg = .elocat )
    zedd <- (y - locat) / .scale.arg
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * dlogis(x = y, locat = locat,
                      scale = .scale.arg , log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .llocat = llocat,
           .elocat = elocat, .scale.arg = scale.arg ))),
  vfamily = c("logistic1"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    locat <- eta2theta(eta, .llocat , earg = .elocat )
    okay1 <- all(is.finite(locat))
    okay1
  }, list( .elocat = elocat, .scale.arg = scale.arg,
           .llocat = llocat ))),



  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    locat <- eta2theta(eta, .llocat , earg = .elocat )
    rlogis(nsim * length(locat),
           location = locat, scale = .scale.arg )
  }, list( .llocat = llocat,
           .elocat = elocat, .scale.arg = scale.arg ))),



  deriv = eval(substitute(expression({
    locat <- eta2theta(eta, .llocat , earg = .elocat )

    ezedd <- exp(-(y-locat) / .scale.arg )
    dl.dlocat <- (1 - ezedd) / ((1 + ezedd) * .scale.arg)
    dlocat.deta <- dtheta.deta(locat, .llocat , earg = .elocat )

    c(w) * dl.dlocat * dlocat.deta
  }), list( .llocat = llocat,
            .elocat = elocat, .scale.arg = scale.arg ))),
  weight = eval(substitute(expression({
    wz <- c(w) * dlocat.deta^2 / ( .scale.arg^2 * 3)
    wz
  }), list( .scale.arg = scale.arg ))))
}  # logistic1






 erlang <-
  function(shape.arg, lscale = "loglink",
           imethod = 1, zero = NULL) {

  if (!is.Numeric(shape.arg,  # length.arg = 1,
                  integer.valued = TRUE, positive = TRUE))
      stop("'shape' must be a positive integer")
  if (!is.Numeric(imethod, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE) ||
     imethod > 3)
      stop("argument 'imethod' must be 1 or 2 or 3")


  lscale <- as.list(substitute(lscale))
  escale <- link2list(lscale)
  lscale <- attr(escale, "function.name")





  new("vglmff",
  blurb = c("Erlang distribution\n\n",
            "Link:    ",
            namesof("scale", lscale, earg = escale),
            "\n", "\n",
            "Mean:     shape * scale", "\n",
            "Variance: shape * scale^2"),
  constraints = eval(substitute(expression({
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 1,
                     predictors.names = predictors.names)




  }), list( .zero = zero ))),

  infos = eval(substitute(function(...) {
    list(M1 = 1,
         Q1 = 1,
         multipleResponses = TRUE,
         shape.arg = .shape.arg ,
         parameters.names = c("scale"),
         expected = TRUE,
         hadof = TRUE,
         zero = .zero )
  }, list( .zero = zero,
           .shape.arg = shape.arg ))),


  initialize = eval(substitute(expression({

    temp5 <-
    w.y.check(w = w, y = y,
              Is.nonnegative.y = TRUE,
              ncol.w.max = Inf,
              ncol.y.max = Inf,
              out.wy = TRUE,
              colsyperw = 1,
              maximize = TRUE)
    w <- temp5$w
    y <- temp5$y


    ncoly <- ncol(y)
    M1 <- 1
    extra$ncoly <- ncoly
    extra$M1 <- M1
    M <- M1 * ncoly


    parameters.names <- param.names("scale", ncoly, skip1 = TRUE)
    predictors.names <-
      namesof(parameters.names, .lscale , earg = .escale ,
              tag = FALSE)


    shape.mat <- matrix( .shape.arg , NROW(y), NCOL(y), byrow = TRUE)

    if (!length(etastart)) {
      sc.init <- if ( .imethod == 1) {
        y / shape.mat
      } else if ( .imethod == 2) {
        (colSums(y * w) / colSums(w)) / shape.mat
      } else if ( .imethod == 3) {
        matrix(apply(y, 2, median), n, ncoly,
               byrow = TRUE) / shape.mat
      }

      if ( !is.matrix(sc.init))
        sc.init <- matrix(sc.init, n, M, byrow = TRUE)

      etastart <- theta2eta(sc.init, .lscale , earg = .escale )
    }
  }), list( .lscale = lscale, .escale = escale,
            .shape.arg = shape.arg, .imethod = imethod ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    eta <- as.matrix(eta)
    SC <- eta2theta(eta, .lscale , earg = .escale )
    shape.mat <- matrix( .shape.arg , nrow(eta), ncol(eta),
                        byrow = TRUE)
    shape.mat * SC
  }, list( .lscale = lscale, .escale = escale,
          .shape.arg = shape.arg ))),
  last = eval(substitute(expression({
    misc$link <- c(rep_len( .lscale , ncoly))
    names(misc$link) <- parameters.names

    misc$earg <- vector("list", M)
    names(misc$earg) <- parameters.names
    for (ii in 1:ncoly) {
      misc$earg[[ii]] <- .escale
    }

    misc$shape.arg <- .shape.arg
  }), list( .lscale = lscale,
            .escale = escale,
            .shape.arg = shape.arg ))),

  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    sc <- eta2theta(eta, .lscale , earg = .escale )
    shape.mat <- matrix( .shape.arg , NROW(y), NCOL(y),
                        byrow = TRUE)
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * (( shape.mat - 1) * log(y) - y / sc -
                  shape.mat * log(sc) - lgamma( shape.mat ))
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
    }, list( .lscale = lscale, .escale = escale,
             .shape.arg = shape.arg ))),
  vfamily = c("erlang"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    sc <- eta2theta(eta, .lscale , earg = .escale )
    okay1 <- all(is.finite(sc)) && all(0 < sc)
    okay1
  }, list( .lscale = lscale, .escale = escale,
           .shape.arg = shape.arg ))),




  hadof = eval(substitute(
  function(eta, extra = list(),
           linpred.index = 1, w = 1,
           dim.wz = c(NROW(eta), NCOL(eta) * (NCOL(eta)+1)/2),
           deriv = 1, ...) {
    sc <- eta2theta(eta, .lscale , earg = .escale )
    shape.mat <- matrix( .shape.arg , NROW(eta), NCOL(eta),
                        byrow = TRUE)
    ans <- c(w) *
    switch(as.character(deriv),
    "0" =          shape.mat / sc^2,
    "1" =  ( -2) * shape.mat / sc^3,
    "2" =  ( +6) * shape.mat / sc^4,
    "3" =  (-24) * shape.mat / sc^5,
           stop("argument 'deriv' must be 0, 1, 2 or 3"))
    if (deriv == 0)
      ans else retain.col(ans, linpred.index)  # Since M1 = 1
  }, list( .lscale = lscale,
           .escale = escale, .shape.arg = shape.arg ))),




  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    Scale <- eta2theta(eta, .lscale , earg = .escale )
    shape.mat <- matrix( .shape.arg , NROW(eta),
                        NCOL(eta), byrow = TRUE)
    rgamma(nsim * length(Scale), shape = shape.mat ,
           scale = Scale )
  }, list( .lscale = lscale, .escale = escale,
           .shape.arg = shape.arg ))),





  deriv = eval(substitute(expression({
    sc <- eta2theta(eta, .lscale , earg = .escale )
    shape.mat <- matrix( .shape.arg , NROW(eta), NCOL(eta),
                        byrow = TRUE)
    dl.dsc <- (y / sc - shape.mat) / sc
    dsc.deta <- dtheta.deta(sc, .lscale , earg = .escale )
    c(w) * dl.dsc * dsc.deta
  }), list( .lscale = lscale,
            .escale = escale, .shape.arg = shape.arg ))),
  weight = eval(substitute(expression({
    ned2l.dsc2 <- shape.mat / sc^2
    wz <- c(w) * dsc.deta^2 * ned2l.dsc2
    wz
  }), list( .escale = escale, .shape.arg = shape.arg ))))
}  # erlang





dbort <- function(x, Qsize = 1, a = 0.5, log = FALSE) {
  if (!is.logical(log.arg <- log) || length(log) != 1)
    stop("bad input for argument 'log'")
  rm(log)

  if (!is.Numeric(x))
    stop("bad input for argument 'x'")
  if (!is.Numeric(Qsize, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE))
    stop("bad input for argument 'Qsize'")
  if (!is.Numeric(a, positive = TRUE) || max(a) >= 1)
    stop("bad input for argument 'a'")
  N <- max(length(x), length(Qsize), length(a))
  if (length(x)     != N) x     <- rep_len(x,     N)
  if (length(a)     != N) a     <- rep_len(a,     N)
  if (length(Qsize) != N) Qsize <- rep_len(Qsize, N)

  xok <- (x >= Qsize) & (x == round(x)) & (a > 0) & (a < 1)
  ans <- rep_len(if (log.arg) log(0) else 0, N)  # loglikelihood
  ans[xok] <- log(Qsize[xok]) - lgamma(x[xok] + 1 - Qsize[xok]) +
             (x[xok] - 1 - Qsize[xok]) * log(x[xok]) +
             (x[xok] - Qsize[xok]) * log(a[xok]) - a[xok] * x[xok]
  if (!log.arg) {
    ans[xok] <- exp(ans[xok])
  }
  ans
}  # dbort



rbort <- function(n, Qsize = 1, a = 0.5) {

  use.n <- if ((length.n <- length(n)) > 1) length.n else
           if (!is.Numeric(n, integer.valued = TRUE,
                           length.arg = 1, positive = TRUE))
              stop("bad input for argument 'n'") else n
  if (!is.Numeric(Qsize, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE))
    stop("bad input for argument 'Qsize'")
  if (!is.Numeric(a, positive = TRUE) ||
      max(a) >= 1)
    stop("bad input for argument 'a'")

  N <- use.n
  qsize <- rep_len(Qsize, N)
  a     <- rep_len(a,     N)
  totqsize <- qsize
  fini <- (qsize < 1)
  while (any(!fini)) {
    additions <- rpois(sum(!fini), a[!fini])
    qsize[!fini] <- qsize[!fini] + additions
    totqsize[!fini] <- totqsize[!fini] + additions
    qsize <- qsize - 1
    fini <- fini | (qsize < 1)
  }
  totqsize
}  # rbort



 borel.tanner <- function(Qsize = 1, link = "logitlink",
                          imethod = 1) {


  if (!is.Numeric(Qsize, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE))
    stop("bad input for argument 'Qsize'")

  link <- as.list(substitute(link))
  earg <- link2list(link)
  link <- attr(earg, "function.name")


  if (!is.Numeric(imethod, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE) ||
      imethod > 4)
    stop("argument 'imethod' must be 1 or 2, 3 or 4")




  new("vglmff",
  blurb = c("Borel-Tanner distribution\n\n",
            "Link:    ",
            namesof("a", link, earg = earg), "\n\n",
            "Mean:     Qsize / (1-a)",
            "\n",
            "Variance: Qsize * a / (1 - a)^3"),

  infos = eval(substitute(function(...) {
    list(M1 = 1,
         Q1 = 1,
         dpqrfun = "bort",
         Qsize = .Qsize ,
         hadof = TRUE,
         link = .link ,
         multipleResponses = FALSE )
  }, list( .Qsize  = Qsize,
           .link = link ))),

  initialize = eval(substitute(expression({
    if (any(y < .Qsize ))
      stop("all y values must be >= ", .Qsize )


    w.y.check(w = w, y = y,
              Is.positive.y = TRUE,
              Is.integer.y = TRUE)


    predictors.names <- namesof("a", .link , earg = .earg ,
                                tag = FALSE)

    if (!length(etastart)) {
      a.init <- switch(as.character( .imethod ),
              "1" = 1 - .Qsize / (y + 1/8),
              "2" = rep_len(1 - .Qsize / weighted.mean(y, w), n),
              "3" = rep_len(1 - .Qsize / median(y), n),
              "4" = rep_len(0.5, n))
      etastart <-
          theta2eta(a.init, .link , earg = .earg )
    }
  }), list( .link = link, .earg = earg, .Qsize = Qsize,
            .imethod = imethod ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    aa <- eta2theta(eta, .link , earg = .earg )
    .Qsize / (1 - aa)
  }, list( .link = link, .earg = earg, .Qsize = Qsize ))),
  last = eval(substitute(expression({
    misc$link <-    c(a = .link)

    misc$earg <- list(a = .earg )

    misc$expected <- TRUE
    misc$Qsize <- .Qsize
  }), list( .link = link, .earg = earg, .Qsize = Qsize ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    aa <- eta2theta(eta, .link , earg = .earg )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <- c(w) * dbort(y, Qsize = .Qsize , a = aa,
                              log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .link = link, .earg = earg, .Qsize = Qsize ))),
  vfamily = c("borel.tanner"),


  hadof = eval(substitute(
  function(eta, extra = list(), deriv = 1,
           linpred.index = 1, w = 1,
           dim.wz = c(NROW(eta), NCOL(eta) * (NCOL(eta)+1)/2),
           ...) {
    aa <- eta2theta(eta, .link , earg = .earg )
    ans <- c(w) *
    switch(as.character(deriv),
           "0" =   .Qsize / (aa * (1 - aa)),
           "1" =  -( .Qsize ) * (1 - 2 * aa) / (aa * (1 - aa))^2,
           "2" = NA * aa,
           "3" = NA * aa,
           stop("argument 'deriv' must be 0, 1, 2 or 3"))
    if (deriv == 0) ans else
      retain.col(ans, linpred.index)  # Since M1 = 1
  }, list( .link = link, .earg = earg, .Qsize = Qsize ))),

  validparams = eval(substitute(function(eta, y, extra = NULL) {
    aa <- eta2theta(eta, .link , earg = .earg )
    okay1 <- all(is.finite(aa)) && all(0 < aa)
    okay1
  }, list( .link = link, .earg = earg, .Qsize = Qsize ))),






  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    aa <- eta2theta(eta, .link , earg = .earg )
    rbort(nsim * length(aa), Qsize = .Qsize , a = aa)
  }, list( .link = link, .earg = earg, .Qsize = Qsize ))),




  deriv = eval(substitute(expression({
    aa <- eta2theta(eta, .link , earg = .earg )
    dl.da <- (y - .Qsize ) / aa - y
    da.deta <- dtheta.deta(aa, .link , earg = .earg )
    c(w) * dl.da * da.deta
  }), list( .link = link, .earg = earg, .Qsize = Qsize ))),
  weight = eval(substitute(expression({
    ned2l.da2 <- .Qsize / (aa * (1 - aa))
    wz <- c(w) * ned2l.da2 * da.deta^2
    wz
  }), list( .Qsize = Qsize ))))
}  # borel.tanner





dfelix <- function(x, rate = 0.25, log = FALSE) {
  if (!is.logical(log.arg <- log) || length(log) != 1)
    stop("bad input for argument 'log'")
  rm(log)

  if (!is.Numeric(x))
    stop("bad input for argument 'x'")
  if (!is.Numeric(rate, positive = TRUE))
    stop("bad input for argument 'rate'")
  N <- max(length(x), length(rate))
  if (length(x)    != N) x    <- rep_len(x,    N)
  if (length(rate) != N) rate <- rep_len(rate, N)

  xok <- (x %% 2 == 1) & (x == round(x)) & (x >= 1) &
         (rate > 0) & (rate < 0.5)
  ans <- rep_len(if (log.arg) log(0) else 0, N)  # loglikelihood
  ans[xok] <- ((x[xok]-3)/2) * log(x[xok]) +
              ((x[xok]-1)/2) * log(rate[xok]) -
              lgamma(x[xok]/2 + 0.5) - rate[xok] * x[xok]
  if (!log.arg) {
    ans[xok] <- exp(ans[xok])
  }
  ans
}  # dfelix



 felix <-
     function(lrate = extlogitlink(min = 0, max = 0.5),
              imethod = 1) {

  lrate <- as.list(substitute(lrate))
  erate <- link2list(lrate)
  lrate <- attr(erate, "function.name")


  if (!is.Numeric(imethod, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE) ||
     imethod > 4)
      stop("argument 'imethod' must be 1 or 2, 3 or 4")


  new("vglmff",
  blurb = c("Felix distribution\n\n",
            "Link:    ",
            namesof("rate", lrate, earg = erate), "\n\n",
            "Mean:     1/(1-2*rate)"),
  infos = eval(substitute(function(...) {
    list(M1 = 1,
         Q1 = 1,
         dpqrfun = "felix",
         expected = TRUE,
         hadof = TRUE,
         multipleResponses = FALSE,
         parameters.names = c("rate"),
         lrate    = .lrate ,
         imethod = .imethod )
  }, list( .imethod = imethod,
           .lrate = lrate ))),

  initialize = eval(substitute(expression({
    if (any(y < 1) ||
        any((y+1)/2 != round((y+1)/2)))
      warning("response should be positive, odd & integer-valued")

    w.y.check(w = w, y = y)



      predictors.names <-
        namesof("rate", .lrate , earg = .erate , tag = FALSE)

      if (!length(etastart)) {
          wymean <- weighted.mean(y, w)
          a.init <- switch(as.character( .imethod ),
            "1" = (y - 1 + 1/8) / (2 * (y + 1/8) + 1/8),
            "2" = rep_len((wymean-1+1/8) / (
                2*(wymean+1/8)+1/8), n),
            "3" = rep_len((median(y)-1+1/8) / (
                  2*(median(y)+1/8)+1/8), n),
            "4" = rep_len(0.25, n))
          etastart <-
            theta2eta(a.init, .lrate , earg = .erate )
      }
  }), list( .lrate = lrate, .erate = erate,
            .imethod = imethod ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    rate <- eta2theta(eta, .lrate , earg = .erate )
    1 / (1 - 2 * rate)
  }, list( .lrate = lrate, .erate = erate ))),
  last = eval(substitute(expression({
    misc$link <-    c(rate = .lrate )
    misc$earg <- list(rate = .erate )
  }), list( .lrate = lrate, .erate = erate ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    rate <- eta2theta(eta, .lrate , earg = .erate )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <- c(w) * dfelix(x = y, rate = rate, log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .lrate = lrate, .erate = erate ))),
  vfamily = c("felix"),


  hadof = eval(substitute(
  function(eta, extra = list(), deriv = 1,
           linpred.index = 1, w = 1,
           dim.wz = c(NROW(eta), NCOL(eta) * (NCOL(eta)+1)/2),
           ...) {
    rate <- eta2theta(eta, .lrate , earg = .erate )
    ans <- c(w) *
    switch(as.character(deriv),
           "0" = 1 / (rate * (1 - 2 * rate)),
           "1" =  -(1 - 4 * rate) / (rate * (1 - 2 * rate))^2,
           "2" = NA * rate,
           "3" = NA * rate,
           stop("argument 'deriv' must be 0, 1, 2 or 3"))
    if (deriv == 0) ans else
      retain.col(ans, linpred.index)  # Since M1 = 1
  }, list( .lrate = lrate, .erate = erate ))),


  deriv = eval(substitute(expression({
    rate <- eta2theta(eta, .lrate , earg = .erate )
    dl.da <- (y - 1) / (2 * rate) - y
    da.deta <- dtheta.deta(rate, .lrate , earg = .erate )
    c(w) * dl.da * da.deta
  }), list( .lrate = lrate, .erate = erate ))),
  weight = eval(substitute(expression({
    ned2l.da2 <- 1 / (rate * (1 - 2 * rate))
    wz <- c(w) * da.deta^2 * ned2l.da2
    wz
  }), list( .lrate = lrate ))))
}  # felix







simple.exponential <- function() {
  new("vglmff",
  blurb = c("Simple exponential distribution\n",
            "Link:    log(rate)\n"),
  deviance = function(mu, y, w, residuals = FALSE, eta,
                      extra = NULL, summation = TRUE) {
    devy <- -log(y) - 1
    devmu <- -log(mu) - y / mu
    devi <- 2 * (devy - devmu)
    if (residuals) {
      sign(y - mu) * sqrt(abs(devi) * c(w))
    } else {
      dev.elts <- c(w) * devi
      if (summation) sum(dev.elts) else dev.elts
    }
  },
  rqresslot = function(mu, y, w, eta, extra = NULL) {
    scrambleseed <- runif(1)  # To scramble the seed
    qnorm(pexp(y, rate = 1 / mu))
  },
  loglikelihood = function(mu, y, w, residuals = FALSE, eta,
                           extra = NULL,
                           summation = TRUE) {
    if (residuals) return(NULL)
    if (summation)
      sum(c(w) * dexp(y, rate  = 1 / mu, log = TRUE)) else
      c(w) * dexp(y, rate  = 1 / mu, log = TRUE)
  },
  initialize = expression({
    predictors.names <- "loglink(rate)"
    mustart <- y + (y == 0) / 8
  }),
  linkinv = function(eta, extra = NULL) exp(-eta),
  linkfun = function(mu,  extra = NULL) -log(mu),
  vfamily = "simple.exponential",
  deriv = expression({
    rate <- 1 / mu
    dl.drate <- mu - y
    drate.deta <- dtheta.deta(rate, "loglink")
    c(w) * dl.drate * drate.deta
  }),
  weight = expression({
    ned2l.drate2 <- 1 / rate^2  # EIM
    wz <- c(w) * drate.deta^2 * ned2l.drate2
    wz
  }))
}  # simple.exponential











 better.exponential <-
  function(link = "loglink", location = 0, expected = TRUE,
           ishrinkage = 0.95, parallel = FALSE, zero = NULL) {
  link <- as.list(substitute(link))
  earg <- link2list(link)
  link <- attr(earg, "function.name")

  new("vglmff",
  blurb = c("Exponential distribution\n\n",
            "Link:     ",
            namesof("rate", link, earg, tag = TRUE), "\n",
            "Mean:     ", "mu = ",
            if (all(location == 0)) "1 / rate" else
            if (length(unique(location)) == 1)
              paste(location[1],
                    "+ 1 / rate") else "location + 1 / rate"),
  constraints = eval(substitute(expression({
    constraints <-
      cm.VGAM(matrix(1, M, 1), x = x, bool = .parallel ,
              constraints = constraints, apply.int = TRUE)
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 1,
                     predictors.names = predictors.names)
  }), list( .parallel = parallel, .zero = zero ))),
  infos = eval(substitute(function(...) {
    list(M1 = 1,
         Q1 = 1,
         dpqrfun = "exp",
         multipleResponses = TRUE,
         zero = .zero )
  }, list( .zero = zero ))),
  deviance = function(mu, y, w, residuals = FALSE, eta,
                      extra = NULL, summation = TRUE) {
    location <- extra$location
    devy <- -log(y - location) - 1
    devmu <- -log(mu - location) - (y - location ) / (mu - location)
    devi <- 2 * (devy - devmu)
    if (residuals) sign(y - mu) * sqrt(abs(devi) * w) else {
      dev.elts <- c(w) * devi
      if (summation) sum(dev.elts) else dev.elts
    }
  },
  initialize = eval(substitute(expression({
    checklist <- w.y.check(w = w, y = y, ncol.w.max = Inf,
                           ncol.y.max = Inf,
                           out.wy = TRUE, colsyperw = 1,
                           maximize = TRUE)
    w <- checklist$w  # So ncol(w) == ncol(y)
    y <- checklist$y

    extra$ncoly <- ncoly <- ncol(y)
    extra$M1 <- M1 <- 1
    M <- M1 * ncoly

    extra$location <- matrix( .location , n, ncoly, byrow = TRUE)
    if (any(y <= extra$location))
      stop("all responses must be greater than argument 'location'")

    mynames1 <- param.names("rate", M, skip1 = TRUE)
    predictors.names <- namesof(mynames1, .link , earg = .earg ,
                                short = TRUE)

    if (length(mustart) + length(etastart) == 0)
      mustart <- matrix(colSums(y * w) / colSums(w), n, M,
                        byrow = TRUE) *
                 .ishrinkage + (1 - .ishrinkage ) * y + 1 / 8
    if (!length(etastart))
        etastart <- theta2eta(1 / (mustart - extra$location),
                              .link , .earg )
  }), list( .location = location, .link = link, .earg = earg,
            .ishrinkage = ishrinkage ))),
  linkinv = eval(substitute(function(eta, extra = NULL)
    extra$location + 1 / eta2theta(eta, .link , earg = .earg ),
  list( .link = link, .earg = earg ))),
  last = eval(substitute(expression({
    misc$link <- rep_len( .link , M)
    misc$earg <- vector("list", M)
    names(misc$link) <- names(misc$earg) <- mynames1
    for (ii in 1:M)
      misc$earg[[ii]] <- .earg
    misc$location <- .location
    misc$expected <- .expected
  }), list( .link = link, .earg = earg,
            .expected = expected, .location = location ))),
  linkfun = eval(substitute(function(mu, extra = NULL)
    theta2eta(1 / (mu - extra$location), .link , earg = .earg ),
  list( .link = link, .earg = earg ))),
  loglikelihood =
  function(mu, y, w, residuals = FALSE, eta, extra = NULL,
           summation = TRUE)
      if (residuals)
        stop("loglikelihood residuals not implemented yet") else {
      rate <- 1 / (mu - extra$location)
      ll.elts <- c(w) * dexp(y - extra$location, rate = rate,
                             log = TRUE)
      if (summation) sum(ll.elts) else ll.elts
    },
  vfamily = c("better.exponential"),
  simslot = eval(substitute(function(object, nsim) {
    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1)) warning("ignoring prior weights")
    mu <- fitted(object)
    rate <- 1 / (mu - object@extra$location)
    rexp(nsim * length(rate), rate = rate)
  }, list( .link = link, .earg = earg ))),
  deriv = eval(substitute(expression({
    rate <- 1 / (mu - extra$location)
    dl.drate <- mu - y
    drate.deta <- dtheta.deta(rate, .link , earg = .earg )
    c(w) * dl.drate * drate.deta
  }), list( .link = link, .earg = earg ))),
  weight = eval(substitute(expression({
    ned2l.drate2 <- (mu - extra$location)^2
    wz <- ned2l.drate2 * drate.deta^2  # EIM
    if (! .expected ) {  # Use the OIM, not the EIM
      d2rate.deta2 <- d2theta.deta2(rate, .link , earg = .earg )
      wz <- wz - dl.drate * d2rate.deta2
    }
    c(w) * wz
  }), list( .link = link, .expected = expected, .earg = earg ))))
}  # better.exponential







 exponential <-
  function(link = "loglink", location = 0, expected = TRUE,
           type.fitted = c("mean", "percentiles", "Qlink"),
           percentiles = 50,
           ishrinkage = 0.95, parallel = FALSE, zero = NULL) {

  type.fitted <- match.arg(type.fitted,
                           c("mean", "percentiles", "Qlink"))[1]

  if (!is.logical(expected) || length(expected) != 1)
    stop("bad input for argument 'expected'")

  link <- as.list(substitute(link))
  earg <- link2list(link)
  link <- attr(earg, "function.name")


  if (!is.Numeric(ishrinkage, length.arg = 1) ||
      ishrinkage < 0 || ishrinkage > 1)
    stop("bad input for argument 'ishrinkage'")


  new("vglmff",
  blurb = c("Exponential distribution\n\n",
            "Link:     ",
            namesof("rate", link, earg, tag = TRUE), "\n",
            "Mean:     ", "mu = ",
            if (all(location == 0)) "1 / rate" else
            if (length(unique(location)) == 1)
            paste(location[1], "+ 1 / rate") else
            "location + 1 / rate"),
  charfun = eval(substitute(function(x, eta, extra = NULL,
                                     varfun = FALSE) {
    if (length(extra$location) && !all(extra$location == 0))
      stop("need the location to be 0 for this slot to work")
    rate <- eta2theta(eta, .link , earg = .earg )
    if (varfun) {
      1 / rate^2
    } else {
      1 / (1 - 1i * x / rate)
    }
  }, list( .link = link, .earg = earg  ))),

  constraints = eval(substitute(expression({
    constraints <- cm.VGAM(matrix(1, M, 1), x = x,
                           bool = .parallel ,
                           constraints = constraints,
                   apply.int = FALSE)  # 20181121; was TRUE
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 1,
                     predictors.names = predictors.names)
  }), list( .parallel = parallel, .zero = zero ))),
  infos = eval(substitute(function(...) {
    list(M1 = 1,
         Q1 = 1,
         dpqrfun = "exp",
         charfun = TRUE,
         multipleResponses = TRUE,
         parallel = .parallel ,
         type.fitted = .type.fitted ,
         zero = .zero )
  }, list( .parallel = parallel,
           .type.fitted = type.fitted,
           .zero = zero ))),
  deviance = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL, summation = TRUE) {

    rate <- eta2theta(eta, .link , earg = .earg )
    mu <- extra$location + 1 / rate


    location <- extra$location
    devy <- -log(y - location) - 1
    devmu <- -log(mu - location) - (y - location ) / (mu - location)
    devi <- 2 * (devy - devmu)
    if (residuals) {
      sign(y - mu) * sqrt(abs(devi) * w)
    } else {
      dev.elts <- c(w) * devi
      if (summation) {
        sum(dev.elts)
      } else {
        dev.elts
      }
    }
  }, list( .location = location,
            .link = link, .earg = earg,
            .percentiles = percentiles,
            .type.fitted = type.fitted,
            .ishrinkage = ishrinkage ))),
    
  initialize = eval(substitute(expression({
    checklist <-
    w.y.check(w = w, y = y,
              ncol.w.max = Inf,
              ncol.y.max = Inf,
              out.wy = TRUE,
              colsyperw = 1,
              maximize = TRUE)
    w <- checklist$w
    y <- checklist$y

    ncoly <- ncol(y)
    M1 <- 1
    M <- M1 * ncoly
    extra$ncoly <- ncoly
    extra$type.fitted <- .type.fitted
    extra$colnames.y  <- colnames(y)
    extra$percentiles <- .percentiles
    extra$M1 <- M1

    if ((NOS <- M / M1) > 1 && length( .percentiles ) > 1)
      stop("can only have one response when 'percentiles' is a ",
           "vector longer than unity")



    extra$location <- matrix( .location , n, ncoly,
                             byrow = TRUE)  # By row!

    if (any(y <= extra$location))
      stop("all responses must be greater than ", extra$location)

    mynames1 <- param.names("rate", M, skip1 = TRUE)
    predictors.names <- namesof(mynames1, .link , earg = .earg ,
                                short = TRUE)

    if (length(mustart) + length(etastart) == 0)
        mustart <- matrix(colSums(y * w) / colSums(w),
                          n, M, byrow = TRUE) *
                 .ishrinkage + (1 - .ishrinkage ) * y + 1 / 8
    if (!length(etastart))
      etastart <- theta2eta(1 / (mustart - extra$location),
                            .link , earg = .earg )
  }), list( .location = location,
            .link = link, .earg = earg,
            .percentiles = percentiles,
            .type.fitted = type.fitted,
            .ishrinkage = ishrinkage ))),



  linkinv = eval(substitute(function(eta, extra = NULL) {
    type.fitted <-
      if (length(extra$type.fitted)) {
        extra$type.fitted
      } else {
        warning("cannot find 'type.fitted'. Returning the 'mean'.")
        "mean"
      }
    type.fitted <- match.arg(type.fitted,
                             c("mean", "percentiles", "Qlink"))[1]

    if (type.fitted == "Qlink") {
      eta2theta(eta, link = "loglink")
    } else {
      rate <- eta2theta(eta, .link , earg = .earg )

      pcent <- extra$percentiles
      perc.mat <- matrix(pcent, NROW(eta), length(pcent),
                         byrow = TRUE) / 100
      fv <-
        switch(type.fitted,
               "mean" = extra$location + 1 / rate,
               "percentiles" = qexp(perc.mat,
                          rate = matrix(rate, nrow(perc.mat),
                                              ncol(perc.mat))))
      if (type.fitted == "percentiles")
        fv <- label.cols.y(fv, colnames.y = extra$colnames.y,
                           NOS = NCOL(eta), percentiles = pcent,
                           one.on.one = FALSE)
      fv
    }
  }, list( .link = link, .earg = earg ))),

  last = eval(substitute(expression({
    misc$link <- rep_len( .link , M)
    names(misc$link) <- mynames1
    misc$earg <- vector("list", M)
    names(misc$earg) <- mynames1
    for (ii in 1:M)
      misc$earg[[ii]] <- .earg
    misc$location <- .location
    misc$expected <- .expected
  }), list( .link = link, .earg = earg,
            .expected = expected, .location = location ))),
  linkfun = eval(substitute(function(mu, extra = NULL)
    theta2eta(1 / (mu - extra$location), .link , earg = .earg ),
  list( .link = link, .earg = earg ))),

  loglikelihood =  eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
                           extra = NULL, summation = TRUE)
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {


    rate <- eta2theta(eta, .link , earg = .earg )
    proper.mu <- extra$location + 1 / rate


    rate <- 1 / (proper.mu - extra$location)
    ll.elts <- c(w) * dexp(y - extra$location,
                           rate, log = TRUE)
      if (summation) sum(ll.elts) else ll.elts
  }, list( .location = location,
            .link = link, .earg = earg,
            .percentiles = percentiles,
            .type.fitted = type.fitted,
            .ishrinkage = ishrinkage ))),
  vfamily = c("exponential"),


  simslot = eval(substitute(
  function(object, nsim) {
    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")


    eta <- predict(object)
    rate <- eta2theta(eta, .link , earg = .earg )
    proper.mu <- object@extra$location + 1 / rate
    rexp(nsim * length(rate), rate = rate)
  }, list( .link = link, .earg = earg ))),


  deriv = eval(substitute(expression({

    rate <- eta2theta(eta, .link , earg = .earg )
    proper.mu <- extra$location + 1 / rate

    dl.drate <- proper.mu - y
    drate.deta <- dtheta.deta(rate, .link , earg = .earg )
    c(w) * dl.drate * drate.deta
  }), list( .link = link, .earg = earg ))),
  weight = eval(substitute(expression({
    ned2l.drate2 <- (proper.mu - extra$location)^2
    wz <- ned2l.drate2 * drate.deta^2
    if (! .expected ) {  # Use the OIM, not the EIM
      d2rate.deta2 <- d2theta.deta2(rate, .link , earg = .earg )
      wz <- wz - dl.drate * d2rate.deta2
    }
    c(w) * wz
  }),
  list( .link = link, .expected = expected, .earg = earg ))))
}  # exponential






 gamma1 <-
  function(link = "loglink", zero = NULL, parallel = FALSE,
    type.fitted = c("mean", "percentiles", "Qlink"),
    percentiles = 50) {

  type.fitted <- match.arg(type.fitted,
                           c("mean", "percentiles", "Qlink"))[1]


  link <- as.list(substitute(link))
  earg <- link2list(link)
  link <- attr(earg, "function.name")





  new("vglmff",
  blurb = c("1-parameter Gamma distribution\n",
            "Link:     ",
            namesof("shape", link, earg, tag = TRUE), "\n",
            "Mean:       mu (=shape)\n",
            "Variance:   mu (=shape)"),
  constraints = eval(substitute(expression({
    constraints <- cm.VGAM(matrix(1, M, 1), x = x,
                           bool = .parallel ,
                           constraints, apply.int = FALSE)
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 1,
                     predictors.names = predictors.names)
  }), list( .parallel = parallel,
            .zero = zero ))),

  infos = eval(substitute(function(...) {
    list(M1 = 1,
         Q1 = 1,
         parallel = .parallel ,
         percentiles = .percentiles ,
         type.fitted = .type.fitted ,
         Q1 = 1,
         zero = .zero )
  }, list( .parallel = parallel,
           .percentiles = percentiles ,
           .type.fitted = type.fitted,
           .zero = zero ))),

  initialize = eval(substitute(expression({

    temp5 <-
    w.y.check(w = w, y = y,
              Is.positive.y = TRUE,
              ncol.w.max = Inf,
              ncol.y.max = Inf,
              out.wy = TRUE,
              colsyperw = 1,
              maximize = TRUE)
    w <- temp5$w
    y <- temp5$y


    ncoly <- ncol(y)
    M1 <- 1
    M <- M1 * ncoly
    extra$ncoly <- ncoly
    extra$type.fitted <- .type.fitted
    extra$colnames.y  <- colnames(y)
    extra$percentiles <- .percentiles
    extra$M1 <- M1



    mynames1 <- param.names("shape", M, skip1 = TRUE)
    predictors.names <- namesof(mynames1, .link , earg = .earg ,
                                short = TRUE)

    if (!length(etastart))
      etastart <- cbind(theta2eta(y + 1/8, .link , earg = .earg ))
  }), list( .link = link,
            .percentiles = percentiles,
            .type.fitted = type.fitted,
            .earg = earg ))),



  linkinv = eval(substitute(function(eta, extra = NULL) {
    type.fitted <-
      if (length(extra$type.fitted)) {
        extra$type.fitted
      } else {
        warning("cannot find 'type.fitted'. Returning the 'mean'.")
        "mean"
      }
    type.fitted <- match.arg(type.fitted,
                             c("mean", "percentiles", "Qlink"))[1]

    if (type.fitted == "Qlink") {
      eta2theta(eta, link = "loglink")
    } else {
      shape <- eta2theta(eta, .link , earg = .earg )
      pcent <- extra$percentiles
      perc.mat <- matrix(pcent, NROW(eta), length(pcent),
                         byrow = TRUE) / 100
      fv <-
        switch(type.fitted,
               "mean" = shape,
               "percentiles" = qgamma(perc.mat,
                shape = matrix(shape, nrow(perc.mat),
                                      ncol(perc.mat))))
      if (type.fitted == "percentiles")
        fv <- label.cols.y(fv, colnames.y = extra$colnames.y,
                           NOS = NCOL(eta), percentiles = pcent,
                           one.on.one = FALSE)
      fv
    }
  }, list( .link = link,
           .earg = earg ))),



  last = eval(substitute(expression({
    misc$link <- rep_len( .link , M)
    names(misc$link) <- mynames1

    misc$earg <- vector("list", M)
    names(misc$earg) <- names(misc$link)
    for (ii in 1:M)
      misc$earg[[ii]] <- .earg

    misc$expected <- TRUE
    misc$multipleResponses <- TRUE
    misc$M1 <- M1
  }), list( .link = link, .earg = earg ))),



  loglikelihood =
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE)
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <- c(w) * dgamma(y, shape = mu, scale = 1, log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
  },
  vfamily = c("gamma1"),




  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    shape <- eta2theta(eta, .link , earg = .earg )
    mu <- shape  # fitted(object)
    rgamma(nsim * length(shape), shape = mu, scale = 1)
  }, list( .link = link, .earg = earg ))),





  deriv = eval(substitute(expression({
    shape <- eta2theta(eta, .link , earg = .earg )

    dl.dshape <- log(y) - digamma(shape)
    dshape.deta <- dtheta.deta(shape, .link , earg = .earg )
    ans <- c(w) * dl.dshape * dshape.deta
    ans
    c(w) * dl.dshape * dshape.deta
  }), list( .link = link, .earg = earg ))),
  weight = expression({
    ned2l.dshape <- trigamma(shape)
    wz <- ned2l.dshape * dshape.deta^2
    c(w) * wz
  }))
}  # gamma1











 gammaR <-
  function(lrate = "loglink", lshape = "loglink",
           irate = NULL,   ishape = NULL,
           lss = TRUE,
           zero = "shape"
          ) {


  expected <- TRUE  # FALSE does not work well

  iratee <- irate

  lratee <- as.list(substitute(lrate))
  eratee <- link2list(lratee)
  lratee <- attr(eratee, "function.name")

  lshape <- as.list(substitute(lshape))
  eshape <- link2list(lshape)
  lshape <- attr(eshape, "function.name")


  if (length( iratee) && !is.Numeric(iratee, positive = TRUE))
    stop("bad input for argument 'irate'")
  if (length( ishape) && !is.Numeric(ishape, positive = TRUE))
    stop("bad input for argument 'ishape'")


  if (!is.logical(expected) || length(expected) != 1)
    stop("bad input for argument 'expected'")


  ratee.TF <- if (lss) c(TRUE, FALSE) else c(FALSE, TRUE)
  scale.12 <- if (lss) 1:2 else 2:1
  blurb.vec <- c(namesof("rate",  lratee, earg = eratee),
                 namesof("shape", lshape, earg = eshape))
  blurb.vec <- blurb.vec[scale.12]



  new("vglmff",
  blurb = c("2-parameter Gamma distribution\n",
            "Links:    ",
            blurb.vec[1], ", ",
            blurb.vec[2], "\n",
            "Mean:     mu = shape/rate\n",
            "Variance: (mu^2)/shape = shape/rate^2"),
  charfun = eval(substitute(function(x, eta, extra = NULL,
                                     varfun = FALSE) {
    Ratee <- eta2theta(eta[,    .ratee.TF  ], .lratee , .eratee )
    Shape <- eta2theta(eta[, !( .ratee.TF )], .lshape , .eshape )
    if (varfun) {
      Shape / Ratee^2
    } else {
      (1 - 1i * x / Ratee)^(-Shape)
    }
  }, list( .lratee = lratee, .lshape = lshape,
           .eratee = eratee, .eshape = eshape,
           .scale.12 = scale.12, .ratee.TF = ratee.TF,
           .lss = lss ))),

  constraints = eval(substitute(expression({
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 2,
                     predictors.names = predictors.names)
  }), list( .zero = zero ))),

  infos = eval(substitute(function(...) {
    list(M1 = 2,
         Q1 = 1,
         dpqrfun = "gamma",
         charfun = TRUE,
         expected = .expected ,
         multipleResponses = TRUE,
         zero = .zero )
  },
  list( .zero = zero, .scale.12 = scale.12,
        .ratee.TF = ratee.TF, .expected = expected ))),

  initialize = eval(substitute(expression({

    temp5 <-
    w.y.check(w = w, y = y,
              Is.positive.y = TRUE,
              ncol.w.max = Inf,
              ncol.y.max = Inf,
              out.wy = TRUE,
              colsyperw = 1,
              maximize = TRUE)
    w <- temp5$w
    y <- temp5$y

    ncoly <- ncol(y)
    M1 <- 2
    extra$ncoly <- ncoly
    extra$M1 <- M1
    M <- M1 * ncoly


    if ( .lss ) {
      mynames1 <- param.names("rate",  ncoly, skip1 = TRUE)
      mynames2 <- param.names("shape", ncoly, skip1 = TRUE)
      predictors.names <-
          c(namesof(mynames1, .lratee , .eratee , tag = FALSE),
            namesof(mynames2, .lshape , .eshape , tag = FALSE))

    } else {
      mynames1 <- param.names("shape", ncoly, skip1 = TRUE)
      mynames2 <- param.names("rate",  ncoly, skip1 = TRUE)
      predictors.names <-
          c(namesof(mynames1, .lshape , .eshape , tag = FALSE),
            namesof(mynames2, .lratee , .eratee , tag = FALSE))
    }
    parameters.names <- c(mynames1, mynames2)[interleave.VGAM(M,
                                                      M1 = M1)]
    predictors.names <- predictors.names[interleave.VGAM(M, M1 = M1)]



    Ratee.init <- matrix(if (length( .iratee )) .iratee else 0 + NA,
                         n, ncoly, byrow = TRUE)
    Shape.init <- matrix(if (length( .ishape )) .iscale else 0 + NA,
                         n, ncoly, byrow = TRUE)


    if (!length(etastart)) {
      mymu <- y + 0.167 * (y == 0)


      for (ilocal in 1:ncoly) {
        junk <- lsfit(x, y[, ilocal], wt = w[, ilocal],
                      intercept = FALSE)
        var.y.est <- sum(c(w[, ilocal]) * junk$resid^2) / (nrow(x) -
                     length(junk$coef))

        if (!is.Numeric(Shape.init[, ilocal]))
          Shape.init[, ilocal] <- (mymu[, ilocal])^2 / var.y.est

        if (!is.Numeric(Ratee.init[, ilocal]))
          Ratee.init[, ilocal] <-
            Shape.init[, ilocal] / mymu[, ilocal]
      }

      if ( .lshape == "logloglink")  # Hope the val is big enough:
        Shape.init[Shape.init <= 1] <- 3.1
      etastart <- if ( .lss )
        cbind(theta2eta(Ratee.init, .lratee , earg = .eratee ),
              theta2eta(Shape.init, .lshape , earg = .eshape ))[,
              interleave.VGAM(M, M1 = M1)] else
        cbind(theta2eta(Shape.init, .lshape , earg = .eshape ),
              theta2eta(Ratee.init, .lratee , earg = .eratee ))[,
              interleave.VGAM(M, M1 = M1)]
    }
  }),
  list( .lratee = lratee, .lshape = lshape,
        .iratee = iratee, .ishape = ishape,
        .eratee = eratee, .eshape = eshape,
        .scale.12 = scale.12, .ratee.TF = ratee.TF,
        .lss = lss ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    Ratee <- eta2theta(eta[,    .ratee.TF  ], .lratee , .eratee )
    Shape <- eta2theta(eta[, !( .ratee.TF )], .lshape , .eshape )
    Shape / Ratee
  },
  list( .lratee = lratee, .lshape = lshape,
        .eratee = eratee, .eshape = eshape,
        .scale.12 = scale.12, .ratee.TF = ratee.TF,
        .lss = lss ))),
  last = eval(substitute(expression({
    misc$multipleResponses <- TRUE

    M1 <- extra$M1
    avector <- if ( .lss ) c(rep_len( .lratee , ncoly),
                             rep_len( .lshape , ncoly)) else
                           c(rep_len( .lshape , ncoly),
                             rep_len( .lratee , ncoly))
    misc$link <- avector[interleave.VGAM(M, M1 = M1)]
    temp.names <- c(mynames1, mynames2)[interleave.VGAM(M, M1 = M1)]
    names(misc$link) <- temp.names

    misc$earg <- vector("list", M)
    names(misc$earg) <- temp.names
    for (ii in 1:ncoly) {
      misc$earg[[M1*ii-1]] <- if ( .lss ) .eratee else .eshape
      misc$earg[[M1*ii  ]] <- if ( .lss ) .eshape else .eratee
    }

    misc$M1 <- M1
  }),
  list( .lratee = lratee, .lshape = lshape,
        .eratee = eratee, .eshape = eshape,
        .scale.12 = scale.12,
        .ratee.TF = ratee.TF, .lss = lss ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    Ratee <- eta2theta(eta[,    .ratee.TF  ], .lratee , .eratee )
    Shape <- eta2theta(eta[, !( .ratee.TF )], .lshape , .eshape )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <- c(w) * dgamma(y, shape = Shape,
                               rate = Ratee, log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
    },
    list( .lratee = lratee, .lshape = lshape,
          .eratee = eratee, .eshape = eshape,
          .scale.12 = scale.12,
          .ratee.TF = ratee.TF, .lss = lss ))),
  vfamily = c("gammaR"),




  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    Ratee <- eta2theta(eta[,    .ratee.TF  ], .lratee , .eratee )
    Shape <- eta2theta(eta[, !( .ratee.TF )], .lshape , .eshape )
    rgamma(nsim * length(Shape), shape = Shape, rate = Ratee)
  },
  list( .lratee = lratee, .lshape = lshape,
        .eratee = eratee, .eshape = eshape,
        .scale.12 = scale.12,
        .ratee.TF = ratee.TF, .lss = lss ))),


  deriv = eval(substitute(expression({
    M1 <- 2
    Ratee <- eta2theta(eta[,    .ratee.TF  ], .lratee , .eratee )
    Shape <- eta2theta(eta[, !( .ratee.TF )], .lshape , .eshape )
    dl.dratee <- mu - y
    dl.dshape <- log(y * Ratee) - digamma(Shape)
    dratee.deta <- dtheta.deta(Ratee, .lratee , earg = .eratee )
    dshape.deta <- dtheta.deta(Shape, .lshape , earg = .eshape )

    myderiv <- if ( .lss )
                 c(w) * cbind(dl.dratee * dratee.deta,
                              dl.dshape * dshape.deta) else
                 c(w) * cbind(dl.dshape * dshape.deta,
                              dl.dratee * dratee.deta)
    myderiv[, interleave.VGAM(M, M1 = M1)]
  }), list( .lratee = lratee, .lshape = lshape,
            .eratee = eratee, .eshape = eshape,
           .scale.12 = scale.12,
           .ratee.TF = ratee.TF, .lss = lss ))),
  weight = eval(substitute(expression({
    ned2l.dratee2 <- Shape / (Ratee^2)
    ned2l.drateeshape <- -1/Ratee
    ned2l.dshape2 <- trigamma(Shape)

    if ( .expected ) {
     ratee.adjustment <-  0
     shape.adjustment <-  0
    } else {
      d2ratee.deta2 <- d2theta.deta2(Ratee, .lratee , .eratee )
      d2shape.deta2 <- d2theta.deta2(Shape, .lshape , .eshape )
      ratee.adjustment <- dl.dratee * d2ratee.deta2
      shape.adjustment <- dl.dshape * d2shape.deta2
    }

    wz <- if ( .lss )
            array(c(c(w) * (ned2l.dratee2 * dratee.deta^2 -
                            ratee.adjustment),
                    c(w) * (ned2l.dshape2 * dshape.deta^2 -
                            shape.adjustment),
                    c(w) * (ned2l.drateeshape * dratee.deta *
                            dshape.deta)),
                  dim = c(n, M / M1, 3)) else
            array(c(c(w) * (ned2l.dshape2 * dshape.deta^2 -
                            shape.adjustment),
                    c(w) * (ned2l.dratee2 * dratee.deta^2 -
                            ratee.adjustment),
                    c(w) * (ned2l.drateeshape * dratee.deta *
                            dshape.deta)),
                  dim = c(n, M / M1, 3))
    wz <- arwz2wz(wz, M = M, M1 = M1)
    wz
  }),
  list( .lratee = lratee, .lshape = lshape,
        .eratee = eratee, .eshape = eshape,
        .expected = expected,
        .scale.12 = scale.12,
        .ratee.TF = ratee.TF, .lss = lss  ))))
}  # gammaR 






 gamma2 <-
  function(lmu = "loglink", lshape = "loglink",
           imethod = 1,  ishape = NULL,
           parallel = FALSE,
           deviance.arg = FALSE,
           zero = "shape") {



  if (!is.logical( deviance.arg ) || length( deviance.arg ) != 1)
    stop("argument 'deviance.arg' must be TRUE or FALSE")


  apply.parint <- FALSE

  lmu <- as.list(substitute(lmu))
  emu <- link2list(lmu)
  lmu <- attr(emu, "function.name")

  lshape <- as.list(substitute(lshape))
  eshape <- link2list(lshape)
  lshape <- attr(eshape, "function.name")



  if (length( ishape) && !is.Numeric(ishape, positive = TRUE))
    stop("bad input for argument 'ishape'")
  if (!is.Numeric(imethod, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE) ||
     imethod > 2)
    stop("argument 'imethod' must be 1 or 2")


  if (!is.logical(apply.parint) ||
      length(apply.parint) != 1)
    stop("argument 'apply.parint' must be a single logical")


  if (is.logical(parallel) && parallel && length(zero))
    stop("set 'zero = NULL' if 'parallel = TRUE'")


    ans <-
    new("vglmff",
    blurb = c("2-parameter gamma distribution (McCullagh ",
              "and Nelder 1989 parameterization)\n",
              "Links:    ",
              namesof("mu",    lmu,    earg = emu), ", ",
              namesof("shape", lshape, earg = eshape), "\n",
              "Mean:     mu\n",
              "Variance: (mu^2)/shape"),
    constraints = eval(substitute(expression({

    constraints <- cm.VGAM(matrix(1, M, 1), x = x,
                           bool = .parallel ,
                           constraints = constraints,
                           apply.int = .apply.parint )

    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 2,
                     predictors.names = predictors.names)
  }), list( .zero = zero, .parallel = parallel,
            .apply.parint = apply.parint ))),

  infos = eval(substitute(function(...) {
    list(M1 = 2,
         Q1 = 1,
         dpqrfun = "gamma",
         apply.parint = .apply.parint ,
         expected = TRUE,
         multipleResponses = TRUE,
         parameters.names = c("mu", "shape"),
         parallel = .parallel ,
         zero = .zero )
  }, list( .apply.parint = apply.parint,
           .parallel = parallel,
           .zero = zero ))),


  initialize = eval(substitute(expression({
    M1 <- 2

    temp5 <-
    w.y.check(w = w, y = y,
              Is.positive.y = TRUE,
              ncol.w.max = Inf,
              ncol.y.max = Inf,
              out.wy = TRUE,
              colsyperw = 1,
              maximize = TRUE)
    w <- temp5$w
    y <- temp5$y


    assign("CQO.FastAlgorithm", ( .lmu == "loglink" &&
                                  .lshape == "loglink"),
           envir = VGAMenv)
    if (any(function.name == c("cqo", "cao")) &&
       is.Numeric( .zero , length.arg = 1) && .zero != -2)
      stop("argument zero = -2 is required")

    M <- M1 * ncol(y)
    NOS <- ncoly <- ncol(y)  # Number of species


    temp1.names <- param.names("mu",    NOS, skip1 = TRUE)
    temp2.names <- param.names("shape", NOS, skip1 = TRUE)
    predictors.names <-
        c(namesof(temp1.names, .lmu ,    .emu ,    tag = FALSE),
          namesof(temp2.names, .lshape , .eshape , tag = FALSE))
    predictors.names <- predictors.names[interleave.VGAM(M,
                                                         M1 = M1)]




    if (is.logical( .parallel ) & .parallel & ncoly > 1)
      warning("the constraint matrices may not be correct with ",
              "multiple responses")



      if (!length(etastart)) {
        init.shape <- matrix(1.0, n, NOS)
        mymu <- y  # + 0.167 * (y == 0)  # imethod == 1 (the default)
        if ( .imethod == 2) {
            for (ii in 1:ncol(y)) {
              mymu[, ii] <- weighted.mean(y[, ii], w = w[, ii])
            }
        }
        for (spp in 1:NOS) {
            junk <- lsfit(x, y[, spp], wt = w[, spp],
                          intercept = FALSE)
            var.y.est <- sum(w[, spp] * junk$resid^2) / (
                n - length(junk$coef))
          init.shape[, spp] <- if (length( .ishape )) .ishape else
              mymu[, spp]^2 / var.y.est
          if ( .lshape == "logloglink")
              init.shape[init.shape[, spp] <= 1, spp] <- 3.1
        }
        etastart <-
              cbind(theta2eta(mymu, .lmu , earg = .emu ),
                    theta2eta(init.shape, .lshape , earg = .eshape ))
        etastart <-
            etastart[, interleave.VGAM(M, M1 = M1), drop = FALSE]
      }
  }), list( .lmu = lmu, .lshape = lshape, .ishape = ishape,
            .emu = emu, .eshape = eshape,
            .parallel = parallel, .apply.parint = apply.parint,
            .zero = zero, .imethod = imethod ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
      eta2theta(eta[, c(TRUE, FALSE), drop = FALSE],
                .lmu , earg = .emu )
  }, list( .lmu = lmu, .emu = emu ))),
  last = eval(substitute(expression({
    if (exists("CQO.FastAlgorithm", envir = VGAMenv))
        rm("CQO.FastAlgorithm", envir = VGAMenv)



    misc$link <- setNames(c(rep_len( .lmu    , NOS),
                            rep_len( .lshape , NOS)),
    c(param.names("mu",    NOS, skip1 = TRUE),
      param.names("shape", NOS, skip1 = TRUE)))[interleave.VGAM(M,
                                                      M1 = M1)]




    misc$earg <- vector("list", M)
    names(misc$earg) <- names(misc$link)
    for (ii in 1:NOS) {
      misc$earg[[M1*ii-1]] <- .emu
      misc$earg[[M1*ii  ]] <- .eshape
    }
  }), list( .lmu = lmu, .lshape = lshape,
            .emu = emu, .eshape = eshape ))),
  linkfun = eval(substitute(function(mu, extra = NULL) {
    temp <- theta2eta(mu, .lmu , earg = .emu )
    temp <- cbind(temp, NA * temp)
    temp[, interleave.VGAM(ncol(temp), M1 = M1), drop = FALSE]
  }, list( .lmu = lmu, .emu = emu ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    mymu <- mu  # eta2theta(eta[, 2*(1:NOS)-1], .lmu , earg = .emu )
    shapemat <- eta2theta(eta[, c(FALSE, TRUE), drop = FALSE],
                         .lshape , earg = .eshape )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * dgamma(x = y, shape = c(shapemat),
                      scale = c(mymu / shapemat), log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .lmu = lmu, .lshape = lshape,
           .emu = emu, .eshape = eshape))),
  vfamily = c("gamma2"),




  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    mymu  <- eta2theta(eta[, c(TRUE, FALSE)], .lmu    , .emu    )
    shape <- eta2theta(eta[, c(FALSE, TRUE)], .lshape , .eshape )
    rgamma(nsim * length(shape), shape = c(shape),
           scale = c(mymu/shape))
  }, list( .lmu = lmu, .lshape = lshape,
           .emu = emu, .eshape = eshape))),



  deriv = eval(substitute(expression({
    M1 <- 2
    NOS <- ncol(eta) / M1
    vecTF <- c(TRUE, FALSE)

    mymu  <- eta2theta(eta[,  vecTF], .lmu ,    earg = .emu    )
    shape <- eta2theta(eta[, !vecTF], .lshape , earg = .eshape )

    dl.dmu <- shape * (y / mymu - 1) / mymu
    dl.dshape <- log(y) + log(shape) - log(mymu) + 1 -
                 digamma(shape) - y / mymu

    dmu.deta    <- dtheta.deta(mymu,  .lmu ,    earg = .emu )
    dshape.deta <- dtheta.deta(shape, .lshape , earg = .eshape )

    myderiv <- c(w) * cbind(dl.dmu    * dmu.deta,
                            dl.dshape * dshape.deta)
    myderiv[, interleave.VGAM(M, M1 = M1)]
  }), list( .lmu = lmu, .lshape = lshape,
            .emu = emu, .eshape = eshape))),
  weight = eval(substitute(expression({
    ned2l.dmu2 <- shape / (mymu^2)
    ned2l.dshape2 <- trigamma(shape) - 1 / shape
    wz <- matrix(NA_real_, n, M)  # 2 = M1; diagonal!

    wz[,  vecTF] <- ned2l.dmu2 * dmu.deta^2
    wz[, !vecTF] <- ned2l.dshape2 * dshape.deta^2

    w.wz.merge(w = w, wz = wz, n = n, M = M, ndepy = NOS)
  }), list( .lmu = lmu ))))



  if (deviance.arg)
    ans@deviance <- eval(substitute(
    function(mu, y, w, residuals = FALSE, eta, extra = NULL,
             summation = TRUE) {


    if (NCOL(y) > 1 && NCOL(w) > 1)
      stop("cannot handle matrix 'w' yet")


    M1 <- 2
    NOS <- ncol(eta) / 2
    temp300 <-  eta[, 2*(1:NOS), drop = FALSE]
    shape <-  eta2theta(temp300, .lshape , earg = .eshape )
    devi <- -2 * (log(y/mu) - y/mu + 1)
    if (residuals) {
      warning("not 100% sure about these deviance residuals!")
      sign(y - mu) * sqrt(abs(devi) * w)
    } else {
      dev.elts <- c(w) * devi
      if (summation) {
        sum(dev.elts)
      } else {
        dev.elts
      }
    }
  }, list( .lshape = lshape )))
  ans
}  # gamma2



 geometric <-
  function(link = "logitlink", expected = TRUE,
           imethod = 1, iprob = NULL, zero = NULL) {

  if (!is.logical(expected) || length(expected) != 1)
    stop("bad input for argument 'expected'")


  link <- as.list(substitute(link))
  earg <- link2list(link)
  link <- attr(earg, "function.name")


  if (!is.Numeric(imethod, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE) ||
     imethod > 3)
    stop("argument 'imethod' must be 1 or 2 or 3")





  new("vglmff",
  blurb = c("Geometric distribution ",
            "(P[Y=y] = prob * (1 - prob)^y, y = 0, 1, 2,...)\n",
            "Link:     ",
            namesof("prob", link, earg = earg), "\n",
            "Mean:     mu = (1 - prob) / prob\n",
            "Variance: mu * (1 + mu) = (1 - prob) / prob^2"),
  charfun = eval(substitute(function(x, eta, extra = NULL,
                                     varfun = FALSE) {
    prob <- eta2theta(eta, .link , earg = .earg )
    if (varfun) {
      (1 - prob) / prob^2
    } else {
      prob / (1 - (1 - prob) * exp(1i * x))
    }
  }, list( .link = link, .earg = earg  ))),

  constraints = eval(substitute(expression({
    dotzero <- .zero
    M1 <- 1
    eval(negzero.expression.VGAM)
  }), list( .zero = zero ))),

  infos = eval(substitute(function(...) {
    list(M1 = 1,
         Q1 = 1,
         dpqrfun = "geom",
         expected = TRUE,
         multipleResponses = TRUE,
         zero = .zero )
  }, list( .zero = zero ))),


  initialize = eval(substitute(expression({


    temp5 <-
    w.y.check(w = w, y = y,
              Is.nonnegative.y = TRUE,
              Is.integer.y = TRUE,
              ncol.w.max = Inf,
              ncol.y.max = Inf,
              out.wy = TRUE,
              colsyperw = 1,
              maximize = TRUE)
    w <- temp5$w
    y <- temp5$y


    ncoly <- ncol(y)
    M1 <- 1
    extra$ncoly <- ncoly
    extra$M1 <- M1
    M <- M1 * ncoly


    mynames1  <- param.names("prob", ncoly, skip1 = TRUE)
    predictors.names <-
      namesof(mynames1, .link , earg = .earg , tag = FALSE)


    if (!length(etastart)) {
      prob.init <- if ( .imethod == 2)
                      1 / (1 + y + 1/16) else
                  if ( .imethod == 3)
                      1 / (1 + apply(y, 2, median) + 1/16) else
                      1 / (1 + colSums(y * w) / colSums(w) + 1/16)

      if (!is.matrix(prob.init))
        prob.init <- matrix(prob.init, n, M, byrow = TRUE)


      if (length( .iprob ))
        prob.init <- matrix( .iprob , n, M, byrow = TRUE)


        etastart <- theta2eta(prob.init, .link , earg = .earg )
    }
  }), list( .link = link, .earg = earg,
            .imethod = imethod, .iprob = iprob ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    prob <- eta2theta(eta, .link , earg = .earg )
    (1 - prob) / prob
  }, list( .link = link, .earg = earg ))),

  last = eval(substitute(expression({
    M1 <- extra$M1
    misc$link <- c(rep_len( .link , ncoly))
    names(misc$link) <- mynames1

    misc$earg <- vector("list", M)
    names(misc$earg) <- mynames1
    for (ii in 1:ncoly) {
      misc$earg[[ii]] <- .earg
    }

    misc$expected <- .expected
    misc$imethod <- .imethod
    misc$iprob <- .iprob
  }), list( .link = link, .earg = earg,
            .iprob = iprob,
            .expected = expected, .imethod = imethod ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    prob <- eta2theta(eta, .link , earg = .earg )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <- c(w) * dgeom(x = y, prob = prob, log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .link = link, .earg = earg ))),
  vfamily = c("geometric"),


  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    prob <- eta2theta(eta, .link , earg = .earg )
    rgeom(nsim * length(prob), prob = prob)
  }, list( .link = link, .earg = earg ))),




  deriv = eval(substitute(expression({
    prob <- eta2theta(eta, .link , earg = .earg )

    dl.dprob <- -y / (1 - prob) + 1 / prob

    dprobdeta <- dtheta.deta(prob, .link , earg = .earg )
    c(w) * cbind(dl.dprob * dprobdeta)
  }), list( .link = link, .earg = earg, .expected = expected ))),
  weight = eval(substitute(expression({
    ned2l.dprob2 <- if ( .expected ) {
      1 / (prob^2 * (1 - prob))
    } else {
      y / (1 - prob)^2 + 1 / prob^2
    }
    wz <- ned2l.dprob2 * dprobdeta^2
    if ( !( .expected ))
      wz <- wz - dl.dprob * d2theta.deta2(prob, .link , .earg )
    c(w) * wz
  }), list( .link = link, .earg = earg,
            .expected = expected ))))
}  # geometric




dbetageom <- function(x, shape1, shape2, log = FALSE) {
  if (!is.logical(log.arg <- log) || length(log) != 1)
    stop("bad input for argument 'log'")
  rm(log)

  if (!is.Numeric(x))
    stop("bad input for argument 'x'")
  if (!is.Numeric(shape1, positive = TRUE))
    stop("bad input for argument 'shape1'")
  if (!is.Numeric(shape2, positive = TRUE))
    stop("bad input for argument 'shape2'")
  N <- max(length(x), length(shape1), length(shape2))
  if (length(x)      != N) x      <- rep_len(x,      N)
  if (length(shape1) != N) shape1 <- rep_len(shape1, N)
  if (length(shape2) != N) shape2 <- rep_len(shape2, N)

  loglik <- lbeta(1+shape1, shape2 + abs(x)) - lbeta(shape1, shape2)
  xok <- (x == round(x) & x >= 0)
  loglik[!xok] <- log(0)
  if (log.arg) {
    loglik
  } else {
    exp(loglik)
  }
}  # dbetageom


pbetageom <- function(q, shape1, shape2, log.p = FALSE) {
  if (!is.Numeric(q))
    stop("bad input for argument 'q'")
  if (!is.Numeric(shape1, positive = TRUE))
    stop("bad input for argument 'shape1'")
  if (!is.Numeric(shape2, positive = TRUE))
    stop("bad input for argument 'shape2'")
  N <- max(length(q), length(shape1), length(shape2))
  if (length(q)      != N) q      <- rep_len(q,      N)
  if (length(shape1) != N) shape1 <- rep_len(shape1, N)
  if (length(shape2) != N) shape2 <- rep_len(shape2, N)
  ans <- q * 0  # Retains names(q)
  if (max(abs(shape1-shape1[1])) < 1.0e-08 &&
     max(abs(shape2-shape2[1])) < 1.0e-08) {
      qstar <- floor(q)
      temp <- if (max(qstar) >= 0) dbetageom(x = 0:max(qstar),
             shape1 = shape1[1], shape2 = shape2[1]) else 0*qstar
      unq <- unique(qstar)
      for (ii in unq) {
        index <- (qstar == ii)
        ans[index] <- if (ii >= 0) sum(temp[1:(1+ii)]) else 0
      }
  } else {
    for (ii in 1:N) {
      qstar <- floor(q[ii])
      ans[ii] <- if (qstar >= 0) sum(dbetageom(x = 0:qstar,
                 shape1 = shape1[ii], shape2 = shape2[ii])) else 0
    }
  }
  if (log.p) log(ans) else ans
}  # pbetageom


rbetageom <- function(n, shape1, shape2) {
  rgeom(n, prob = rbeta(n, shape1, shape2))
}




 simple.poisson <- function() {
  new("vglmff",
  blurb = c("Poisson distribution\n\n",
            "Link:     log(lambda)",
            "\n",
            "Variance: lambda"),
  deviance = function(mu, y, w, residuals = FALSE, eta,
                      extra = NULL, summation = TRUE) {
    nz <- y > 0
    devi <-  - (y - mu)
    devi[nz] <- devi[nz] + y[nz] * log(y[nz]/mu[nz])
    if (residuals) {
      sign(y - mu) * sqrt(2 * abs(devi) * w)
    } else {
      dev.elts <- 2 * c(w) * devi
      if (summation) {
        sum(dev.elts)
      } else {
        dev.elts
      }
    }
  },
  initialize = expression({
    if (NCOL(w) != 1)
      stop("prior weight must be a vector or a one-column matrix")

    if (NCOL(y) != 1)
      stop("response must be a vector or a one-column matrix")

    predictors.names <- "loglink(lambda)"

    mu <- (weighted.mean(y, w) + y) / 2 + 1/8

    if (!length(etastart))
      etastart <- log(mu)
  }),
  linkinv = function(eta, extra = NULL)
    exp(eta),
  last = expression({
    misc$link <-    c(lambda = "loglink")
    misc$earg <- list(lambda = list())
  }),
  link = function(mu, extra = NULL)
    log(mu),
  vfamily = "simple.poisson",
  deriv = expression({
    lambda <- mu
    dl.dlambda <- -1 + y/lambda
    dlambda.deta <- dtheta.deta(theta = lambda, link = "loglink")
    c(w) * dl.dlambda * dlambda.deta
  }),
  weight = expression({
    d2l.dlambda2 <- 1 / lambda
    c(w) * d2l.dlambda2 * dlambda.deta^2
  }))
}  # simple.poisson






 studentt <-
  function(ldf = "logloglink", idf = NULL,
           tol1 = 0.1, imethod = 1) {





  ldof <- as.list(substitute(ldf))
  edof <- link2list(ldof)
  ldof <- attr(edof, "function.name")
  idof <- idf


  if (length(idof))
    if (!is.Numeric(idof) || any(idof <= 1))
      stop("argument 'idf' should be > 1")

  if (!is.Numeric(tol1, positive  = TRUE))
    stop("argument 'tol1' should be positive")

  if (!is.Numeric(imethod, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE) ||
     imethod > 3)
      stop("argument 'imethod' must be 1 or 2 or 3")


  new("vglmff",
  blurb = c("Student t-distribution\n\n",
            "Link:     ",
            namesof("df", ldof, earg = edof), "\n",
            "Variance: df / (df - 2) if df > 2\n"),
  infos = eval(substitute(function(...) {
    list(M1 = 1,
         Q1 = 1,
         dpqrfun = "t",
         tol1 = .tol1 )
  }, list( .tol1 = tol1 ))),

  rqresslot = eval(substitute(
    function(mu, y, w, eta, extra = NULL) {
      Dof <- eta2theta(eta, .ldof , earg = .edof )
    scrambleseed <- runif(1)  # To scramble the seed
      qnorm(pt(y, df = Dof))
  }, list( .ldof = ldof, .edof = edof))),

  initialize = eval(substitute(expression({

    w.y.check(w = w, y = y)


    predictors.names <- namesof("df", .ldof , .edof , tag = FALSE)

    if (!length(etastart)) {

      init.df <- if (length( .idof )) .idof else {
        VarY <- var(y)
        MadY <- mad(y)
        if (VarY <= (1 + .tol1 )) VarY <- 1.12
        if ( .imethod == 1) {
          2 * VarY / (VarY - 1)
        } else if ( .imethod == 2) {
          ifelse(MadY < 1.05, 30, ifelse(MadY > 1.2, 2, 5))
        } else
          10
      }


      etastart <- rep_len(theta2eta(init.df, .ldof , .edof ),
                          length(y))
    }
  }), list( .ldof = ldof, .edof = edof, .idof = idof,
            .tol1 = tol1, .imethod = imethod ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    Dof <- eta2theta(eta, .ldof , earg = .edof )
    ans <- 0 * eta
    ans[Dof <= 1] <- NA
    ans
  }, list( .ldof = ldof, .edof = edof ))),
  last = eval(substitute(expression({
    misc$link <-    c(df = .ldof )
    misc$earg <- list(df = .edof )
    misc$imethod <- .imethod
    misc$expected = TRUE
  }), list( .ldof = ldof,
            .edof = edof, .imethod = imethod ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    Dof <-  eta2theta(eta, .ldof , earg = .edof )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <- c(w) * dt(x = y, df = Dof, log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .ldof = ldof, .edof = edof ))),
  vfamily = c("studentt"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    Dof <- eta2theta(eta, .ldof , earg = .edof )
    okay1 <- all(is.finite(Dof)) && all(0 < Dof)
    okay1
  }, list( .ldof = ldof, .edof = edof ))),




  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    Dof <-  eta2theta(eta, .ldof , earg = .edof )
    rt(nsim * length(Dof), df = Dof)
  }, list( .ldof = ldof, .edof = edof ))),






  deriv = eval(substitute(expression({
    Dof <- eta2theta(eta, .ldof , earg = .edof )
    ddf.deta <-  dtheta.deta(Dof, .ldof , earg = .edof )

    DDS  <- function(df) digamma((df + 1) / 2) -  digamma(df / 2)
    DDSp <- function(df) 0.5 * (trigamma((df + 1) / 2) -
                                trigamma(df / 2))

    temp0 <- 1 / Dof
    temp1 <-  temp0 * y^2
    dl.ddf <- 0.5 * (-temp0 - log1p(temp1) +
              (Dof + 1) * y^2 / (Dof^2 * (1 + temp1)) + DDS(Dof))
    c(w) * dl.ddf * ddf.deta
  }), list( .ldof = ldof, .edof = edof ))),
  weight = eval(substitute(expression({




    const2 <- (Dof + 0) / (Dof + 3)
    const2[!is.finite(Dof)] <- 1  # Handles Inf

    tmp6 <- DDS(Dof)
    ned2l.dnu2 <- 0.5 * (tmp6 * (const2 * tmp6 -
                  2 / (Dof + 1)) - DDSp(Dof))








    wz <- c(w) * ned2l.dnu2 * ddf.deta^2
    wz
  }), list( .ldof = ldof, .edof = edof ))))
}  # studentt






 Kayfun.studentt <-
  function(df, bigno = .Machine$double.eps^(-0.46)) {
      ind1 <- is.finite(df)

      const4 <- dnorm(0)
      ans <- df

      if (any(ind1))
        ans[ind1] <- exp(lgamma((df[ind1] + 1) / 2) -
                         lgamma( df[ind1]      / 2)) / sqrt(
                     pi * df[ind1])
      ans[df <= 0] <- NaN
      ind2 <- (df >= bigno)
      if (any(ind2)) {
        dff <- df[ind2]
        ans[ind2] <- const4  # 1/const3  # for handling df=Inf
      }
      ans[!ind1] <- const4  # 1/const3  # for handling df=Inf

      ans
}  # Kayfun.studentt




 studentt3 <-
  function(llocation = "identitylink",
           lscale    = "loglink",
           ldf       = "logloglink",
           ilocation = NULL, iscale = NULL, idf = NULL,
           imethod = 1,
           zero = c("scale", "df")) {



  lloc <- as.list(substitute(llocation))
  eloc <- link2list(lloc)
  lloc <- attr(eloc, "function.name")

  lsca <- as.list(substitute(lscale))
  esca <- link2list(lsca)
  lsca <- attr(esca, "function.name")

  ldof <- as.list(substitute(ldf))
  edof <- link2list(ldof)
  ldof <- attr(edof, "function.name")


  iloc <- ilocation
  isca <- iscale
  idof <- idf


  if (!is.Numeric(imethod, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE) ||
     imethod > 3)
      stop("argument 'imethod' must be 1 or 2 or 3")

  if (length(iloc))
    if (!is.Numeric(iloc))
      stop("bad input in argument 'ilocation'")
  if (length(isca))
    if (!is.Numeric(isca, positive = TRUE))
      stop("argument 'iscale' should be positive")
  if (length(idof))
    if (!is.Numeric(idof) || any(idof <= 1))
      stop("argument 'idf' should be > 1")



  new("vglmff",
  blurb = c("Student t-distribution\n\n",
            "Link:     ",
            namesof("location", lloc, earg = eloc), ", ",
            namesof("scale",    lsca, earg = esca), ", ",
            namesof("df",       ldof, earg = edof), "\n",
            "Variance: scale^2 * df / (df - 2) if df > 2\n"),
  constraints = eval(substitute(expression({

    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 3,
                     predictors.names = predictors.names)
  }), list( .zero = zero ))),
  infos = eval(substitute(function(...) {
    list(M1 = 3,
         Q1 = 1,
         dpqrfun = "t",  # With modification zz
         expected = TRUE,
         multipleResponses = TRUE,
         parameters.names = c("location", "scale", "df"),
         zero = .zero)
  }, list( .zero = zero ))),

  rqresslot = eval(substitute(
    function(mu, y, w, eta, extra = NULL) {
      NOS <- extra$NOS
      M1 <- extra$M1
      Loc <-  eta2theta(eta[, M1*(1:NOS)-2], .lloc , .eloc )
      Sca <-  eta2theta(eta[, M1*(1:NOS)-1], .lsca , .esca )
      Dof <-  eta2theta(eta[, M1*(1:NOS)-0], .ldof , .edof )
      zedd <- (y - Loc) / Sca
    scrambleseed <- runif(1)  # To scramble the seed
      qnorm(pt(zedd, df = Dof))
  }, list( .lloc = lloc, .eloc = eloc,
           .lsca = lsca, .esca = esca,
           .ldof = ldof, .edof = edof ))),

  initialize = eval(substitute(expression({
    M1 <- 3



    temp5 <-
    w.y.check(w = w, y = y,
              ncol.w.max = Inf,
              ncol.y.max = Inf,
              out.wy = TRUE,
              maximize = TRUE)
    w <- temp5$w
    y <- temp5$y


    extra$NOS <- NOS <- ncoly <- ncol(y)  # Number of species
    extra$M1 <- M1
    M <- M1 * ncoly #

    mynames1 <- param.names("location", NOS, skip1 = TRUE)
    mynames2 <- param.names("scale",    NOS, skip1 = TRUE)
    mynames3 <- param.names("df",       NOS, skip1 = TRUE)
    predictors.names <-
        c(namesof(mynames1, .lloc , earg = .eloc , tag = FALSE),
          namesof(mynames2, .lsca , earg = .esca , tag = FALSE),
          namesof(mynames3, .ldof , earg = .edof , tag = FALSE))
    predictors.names <-
      predictors.names[interleave.VGAM(M1 * NOS, M1 = M1)]

    if (!length(etastart)) {
      init.loc <- if (length( .iloc )) .iloc else {
        if ( .imethod == 2) apply(y, 2, median) else
        if ( .imethod == 3) (colMeans(y) + t(y)) / 2 else {
           colSums(w * y) / colSums(w)
        }
      }

      sdvec <- apply(y, 2, sd)
      init.sca <- if (length( .isca )) .isca else
                  sdvec / 2.3

      sdvec    <- rep_len(sdvec,    max(length(sdvec),
                                        length(init.sca)))
      init.sca <- rep_len(init.sca, max(length(sdvec),
                                        length(init.sca)))
      ind9 <- (sdvec / init.sca <= (1 + 0.12))
      sdvec[ind9] <- sqrt(1.12) * init.sca[ind9]
      init.dof <- if (length( .idof )) .idof else
        (2 * (sdvec / init.sca)^2) / ((sdvec / init.sca)^2  - 1)
      if (!is.Numeric(init.dof) || any(init.dof <= 1))
        init.dof <- rep_len(3, ncoly)

      mat1 <- matrix(theta2eta(init.loc, .lloc , .eloc ), n, NOS,
                     byrow = TRUE)
      mat2 <- matrix(theta2eta(init.sca, .lsca , .esca ), n, NOS,
                     byrow = TRUE)
      mat3 <- matrix(theta2eta(init.dof, .ldof , .edof ), n, NOS,
                     byrow = TRUE)
      etastart <- cbind(mat1, mat2, mat3)
      etastart <- etastart[, interleave.VGAM(ncol(etastart),
                                             M1 = M1)]
    }
  }), list( .lloc = lloc, .eloc = eloc, .iloc = iloc,
            .lsca = lsca, .esca = esca, .isca = isca,
            .ldof = ldof, .edof = edof, .idof = idof,
            .imethod = imethod ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    NOS    <- extra$NOS
    M1 <- extra$M1
    Loc <-  eta2theta(eta[, M1*(1:NOS)-2], .lloc , earg = .eloc )
    Dof <-  eta2theta(eta[, M1*(1:NOS)-0], .ldof , earg = .edof )
    Loc[Dof <= 1] <- NA
    Loc
  }, list( .lloc = lloc, .eloc = eloc,
           .lsca = lsca, .esca = esca,
           .ldof = ldof, .edof = edof ))),
  last = eval(substitute(expression({
    M1 <- extra$M1
    misc$link <- c(rep_len( .lloc , NOS),
                   rep_len( .lsca , NOS),
                   rep_len( .ldof , NOS))
    misc$link <- misc$link[interleave.VGAM(M1 * NOS, M1 = M1)]
    temp.names <- c(mynames1, mynames2, mynames3)
    temp.names <- temp.names[interleave.VGAM(M1 * NOS, M1 = M1)]
    names(misc$link) <- temp.names

    misc$earg <- vector("list", M1 * NOS)
    names(misc$earg) <- temp.names
    for (ii in 1:NOS) {
      misc$earg[[M1*ii-2]] <- .eloc
      misc$earg[[M1*ii-1]] <- .esca
      misc$earg[[M1*ii  ]] <- .edof
    }

    misc$M1 <- M1
    misc$imethod <- .imethod
    misc$expected <- TRUE
    misc$multipleResponses <- TRUE
  }), list( .lloc = lloc, .eloc = eloc,
            .lsca = lsca, .esca = esca,
            .ldof = ldof, .edof = edof,
            .imethod = imethod ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    NOS <- extra$NOS
    M1 <- extra$M1
    Loc <-  eta2theta(eta[, M1*(1:NOS)-2], .lloc , earg = .eloc )
    Sca <-  eta2theta(eta[, M1*(1:NOS)-1], .lsca , earg = .esca )
    Dof <-  eta2theta(eta[, M1*(1:NOS)-0], .ldof , earg = .edof )
    zedd <- (y - Loc) / Sca
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <- c(w) * (dt(zedd, df = Dof, log = TRUE) - log(Sca))
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list(  .lloc = lloc, .eloc = eloc,
            .lsca = lsca, .esca = esca,
            .ldof = ldof, .edof = edof ))),
  vfamily = c("studentt3"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    M1 <- extra$M1
    NOS <- extra$NOS
    Loc <- eta2theta(eta[, M1*(1:NOS)-2], .lloc , earg = .eloc )
    Sca <- eta2theta(eta[, M1*(1:NOS)-1], .lsca , earg = .esca )
    Dof <- eta2theta(eta[, M1*(1:NOS)-0], .ldof , earg = .edof )
    okay1 <- all(is.finite(Loc)) &&
             all(is.finite(Sca)) && all(0 < Sca) &&
             all(is.finite(Dof)) && all(0 < Dof)
    okay1
  }, list(  .lloc = lloc, .eloc = eloc,
            .lsca = lsca, .esca = esca,
            .ldof = ldof, .edof = edof ))),






  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    Loc <-  eta2theta(eta[, c(TRUE, FALSE, FALSE)], .lloc , .eloc )
    Sca <-  eta2theta(eta[, c(FALSE, TRUE, FALSE)], .lsca , .esca )
    Dof <-  eta2theta(eta[, c(FALSE, FALSE, TRUE)], .ldof , .edof )

    Loc + Sca * rt(nsim * length(Dof), df = Dof)
  }, list(  .lloc = lloc, .eloc = eloc,
            .lsca = lsca, .esca = esca,
            .ldof = ldof, .edof = edof ))),





  deriv = eval(substitute(expression({
    M1 <- extra$M1
    NOS <- extra$NOS
    Loc <- eta2theta(eta[, M1*(1:NOS)-2], .lloc , earg = .eloc )
    Sca <- eta2theta(eta[, M1*(1:NOS)-1], .lsca , earg = .esca )
    Dof <- eta2theta(eta[, M1*(1:NOS)-0], .ldof , earg = .edof )

    dloc.deta <- cbind(dtheta.deta(theta = Loc, .lloc , .eloc ))
    dsca.deta <- cbind(dtheta.deta(theta = Sca, .lsca , .esca ))
    ddof.deta <- cbind(dtheta.deta(theta = Dof, .ldof , .edof ))

    zedd  <- (y - Loc) / Sca
    temp0 <- 1 / Dof
    temp1 <- temp0 * zedd^2
    dl.dloc <- (Dof + 1) * zedd / (Sca * (Dof + zedd^2))
    dl.dsca <- zedd * dl.dloc - 1 / Sca
    dl.ddof <- 0.5 * (-temp0 - log1p(temp1) +
                     (Dof+1) * zedd^2 / (Dof^2 * (1 + temp1)) +
                     digamma((Dof+1)/2) - digamma(Dof/2))

    ans <- c(w) * cbind(dl.dloc * dloc.deta,
                        dl.dsca * dsca.deta,
                        dl.ddof * ddof.deta)
    ans <- ans[, interleave.VGAM(ncol(ans), M1 = M1)]
    ans
  }), list( .lloc = lloc, .eloc = eloc,
            .lsca = lsca, .esca = esca,
            .ldof = ldof, .edof = edof ))),
  weight = eval(substitute(expression({

    const1 <- (Dof + 1) / (Dof + 3)
    const2 <- (Dof + 0) / (Dof + 3)
    const1[!is.finite(Dof)] <- 1  # Handles Inf
    const2[!is.finite(Dof)] <- 1  # Handles Inf

    const4 <- dnorm(0)
    ned2l.dlocat2 <- const1 / (Sca *
                     (Kayfun.studentt(Dof) / const4))^2
    ned2l.dscale2 <- 2  * const2 /  Sca^2

    DDS  <- function(df) digamma((df + 1) / 2) -  digamma(df/2)
    DDSp <- function(df) 0.5 * (trigamma((df + 1) / 2) -
                                trigamma(df/2))


    tmp6 <- DDS(Dof)
    edl2.dnu2 <- 0.5 * (tmp6 * (const2 * tmp6 - 2 / (Dof + 1)) -
                        DDSp(Dof))
    ned2l.dshape2 <- cbind(edl2.dnu2)  # cosmetic name change

    ned2l.dshape.dlocat <- cbind(0 * Sca)
    ned2l.dshape.dscale <- cbind((-1 / (Dof + 1) +
                                  const2 * DDS(Dof))/Sca)



    wz <- array(c(c(w) * ned2l.dlocat2 * dloc.deta^2,
                  c(w) * ned2l.dscale2 * dsca.deta^2,
                  c(w) * ned2l.dshape2 * ddof.deta^2,
                  c(w) * ned2l.dshape2 * 0,
              c(w) * ned2l.dshape.dscale * dsca.deta * ddof.deta,
              c(w) * ned2l.dshape.dlocat * dloc.deta * ddof.deta),
                dim = c(n, M / M1, 6))
    wz <- arwz2wz(wz, M = M, M1 = M1)



 if (FALSE) {
    wz <- matrix(0.0, n, dimm(M))
    wz[, M1*(1:NOS) - 2] <- ned2l.dlocat2 * dloc.deta^2
    wz[, M1*(1:NOS) - 1] <- ned2l.dscale2 * dsca.deta^2
    wz[, M1*(1:NOS) - 0] <- ned2l.dshape2 * ddof.deta^2

    for (ii in ((1:NOS) - 1)) {
      ind3 <- 1 + ii
      wz[, iam(ii*M1 + 1, ii*M1 + 3, M = M)] <-
           ned2l.dshape.dlocat[, ind3] *
           dloc.deta[, ind3] * ddof.deta[, ind3]
      wz[, iam(ii*M1 + 2, ii*M1 + 3, M = M)] <-
           ned2l.dshape.dscale[, ind3] *
           dsca.deta[, ind3] * ddof.deta[, ind3]
    }

  while (all(wz[, ncol(wz)] == 0))
    wz <- wz[, -ncol(wz)]
 }



    wz
  }), list( .lloc = lloc, .eloc = eloc,
            .lsca = lsca, .esca = esca,
            .ldof = ldof, .edof = edof ))))
}  # studentt3






 studentt2 <-
  function(df = Inf,
           llocation = "identitylink",
           lscale    = "loglink",
           ilocation = NULL, iscale = NULL,
           imethod = 1,
           zero = "scale") {

  lloc <- as.list(substitute(llocation))
  eloc <- link2list(lloc)
  lloc <- attr(eloc, "function.name")

  lsca <- as.list(substitute(lscale))
  esca <- link2list(lsca)
  lsca <- attr(esca, "function.name")



  iloc <- ilocation; isca <- iscale
  doff <- df


  if (is.finite(doff))
    if (!is.Numeric(doff, positive = TRUE))
    stop("argument 'df' must be positive")

  if (!is.Numeric(imethod, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE) ||
     imethod > 3)
      stop("argument 'imethod' must be 1 or 2 or 3")

  if (length(iloc))
    if (!is.Numeric(iloc))
      stop("bad input in argument 'ilocation'")
  if (length(isca))
    if (!is.Numeric(isca, positive = TRUE))
      stop("argument 'iscale' should be positive")


  new("vglmff",
  blurb = c("Student t-distribution (2-parameter)\n\n",
            "Link:     ",
            namesof("location", lloc, earg = eloc), ", ",
            namesof("scale",    lsca, earg = esca), "\n",
            "Variance: scale^2 * df / (df - 2) if df > 2\n"),
  constraints = eval(substitute(expression({

    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 2,
                     predictors.names = predictors.names)
  }), list( .zero = zero ))),
  infos = eval(substitute(function(...) {
    list(M1 = 2,
         Q1 = 1,
         dpqrfun = "t",  # With modification zz
         expected = TRUE,
         multipleResponses = TRUE,
         parameters.names = c("location", "scale"),
         zero = .zero )
    }, list( .zero = zero ))),

  rqresslot = eval(substitute(
    function(mu, y, w, eta, extra = NULL) {
      NOS <- extra$NOS
      M1 <- extra$M1
      Loc <- eta2theta(eta[, M1*(1:NOS)-1], .lloc , .eloc )
      Sca <- eta2theta(eta[, M1*(1:NOS)-0], .lsca , .esca )
      Dof <- matrix( .doff , NROW(Loc), NOS, byrow = TRUE)
      zedd <- (y - Loc) / Sca
    scrambleseed <- runif(1)  # To scramble the seed
      qnorm(pt(zedd, df = Dof))
  }, list( .lloc = lloc, .eloc = eloc,
           .lsca = lsca, .esca = esca,
           .doff = doff ))),

  initialize = eval(substitute(expression({
    M1 <- 2


    temp5 <-
    w.y.check(w = w, y = y,
              ncol.w.max = Inf,
              out.wy = TRUE,
              maximize = TRUE)
    w <- temp5$w
    y <- temp5$y



    extra$NOS <- NOS <- ncoly <- ncol(y)  # Number of species
    extra$M1 <- M1
    M <- M1 * ncoly #

    mynames1 <- param.names("location", NOS, skip1 = TRUE)
    mynames2 <- param.names("scale",    NOS, skip1 = TRUE)
    predictors.names <-
        c(namesof(mynames1, .lloc , earg = .eloc , tag = FALSE),
          namesof(mynames2, .lsca , earg = .esca , tag = FALSE))
    predictors.names <-
      predictors.names[interleave.VGAM(M1 * NOS, M1 = M1)]

    if (!length(etastart)) {

      init.loc <- if (length( .iloc )) .iloc else {
        if ( .imethod == 2) apply(y, 2, median) else
        if ( .imethod == 3) (colMeans(y) + t(y)) / 2 else {
           colSums(w * y) / colSums(w)
        }
      }

      sdvec <- apply(y, 2, sd)
      init.sca <- if (length( .isca )) .isca else
                  sdvec / 2.3

      mat1 <- matrix(theta2eta(init.loc, .lloc , .eloc ), n, NOS,
                     byrow = TRUE)
      mat2 <- matrix(theta2eta(init.sca, .lsca , .esca ), n, NOS,
                     byrow = TRUE)
      etastart <- cbind(mat1, mat2)
      etastart <- etastart[, interleave.VGAM(ncol(etastart),
                                             M1 = M1)]
    }
  }), list( .lloc = lloc, .eloc = eloc, .iloc = iloc,
            .lsca = lsca, .esca = esca, .isca = isca,
            .doff = doff,
            .imethod = imethod ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    NOS <- extra$NOS
    M1 <- extra$M1
    Loc <-  eta2theta(eta[, M1*(1:NOS) - 1], .lloc , earg = .eloc )
    Dof <- matrix( .doff , NROW(Loc), NOS, byrow = TRUE)
    Loc[Dof <= 1] <- NA
    Loc
  }, list( .lloc = lloc, .eloc = eloc,
           .lsca = lsca, .esca = esca,
           .doff = doff ))),
  last = eval(substitute(expression({
    M1 <- extra$M1
    misc$link <- c(rep_len( .lloc , NOS),
                   rep_len( .lsca , NOS))
    temp.names <- c(mynames1, mynames2)
    temp.names <- temp.names[interleave.VGAM(M1 * NOS, M1 = M1)]
    names(misc$link) <- temp.names
    misc$earg <- vector("list", M1 * NOS)
    names(misc$earg) <- temp.names
    for (ii in 1:NOS) {
      misc$earg[[M1*ii-1]] <- .eloc
      misc$earg[[M1*ii-0]] <- .esca
    }

    misc$M1 <- M1
    misc$simEIM <- TRUE
    misc$df <- .doff
    misc$imethod <- .imethod
    misc$expected = TRUE
    misc$multipleResponses <- TRUE
  }), list( .lloc = lloc, .eloc = eloc,
            .lsca = lsca, .esca = esca,
            .doff = doff,
            .imethod = imethod ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    NOS <- extra$NOS
    M1 <- extra$M1
    Loc <- eta2theta(eta[, M1*(1:NOS)-1], .lloc , earg = .eloc )
    Sca <- eta2theta(eta[, M1*(1:NOS)-0], .lsca , earg = .esca )
    Dof <- matrix( .doff , NROW(Loc), NOS, byrow = TRUE)
    zedd <- (y - Loc) / Sca
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <- c(w) * (dt(zedd, Dof, log = TRUE) - log(Sca))
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list(  .lloc = lloc, .eloc = eloc,
            .lsca = lsca, .esca = esca,
            .doff = doff ))),
  vfamily = c("studentt2"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    M1 <- extra$M1
    NOS <- extra$NOS
    Loc <- eta2theta(eta[, M1*(1:NOS)-1], .lloc , earg = .eloc )
    Sca <- eta2theta(eta[, M1*(1:NOS)-0], .lsca , earg = .esca )
    Dof <- .doff
    okay1 <- all(is.finite(Loc)) &&
             all(is.finite(Sca)) && all(0 < Sca) &&
             all(is.finite(Dof)) && all(0 < Dof)
    okay1
  }, list(  .lloc = lloc, .eloc = eloc,
            .lsca = lsca, .esca = esca,
            .doff = doff ))),





  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    extra <- object@extra
    NOS <- extra$NOS
    Loc <-  eta2theta(eta[, c(TRUE, FALSE)], .lloc , .eloc )
    Sca <-  eta2theta(eta[, c(FALSE, TRUE)], .lsca , .esca )
    Dof <- matrix( .doff , NROW(Loc), NOS, byrow = TRUE)

    Loc + Sca * rt(nsim * length(Sca), df = Dof)
  }, list(  .lloc = lloc, .eloc = eloc,
            .lsca = lsca, .esca = esca,
            .doff = doff ))),





  deriv = eval(substitute(expression({
    M1 <- extra$M1
    NOS <- extra$NOS
    Loc <- eta2theta(eta[, M1*(1:NOS)-1], .lloc , earg = .eloc )
    Sca <- eta2theta(eta[, M1*(1:NOS)-0], .lsca , earg = .esca )
    Dof <- matrix( .doff , n, NOS, byrow = TRUE)

    dlocat.deta <- dtheta.deta(theta = Loc, .lloc , earg = .eloc )
    dscale.deta <- dtheta.deta(theta = Sca, .lsca , earg = .esca )

    zedd  <- (y - Loc) / Sca
    temp0 <- 1 / Dof
    temp1 <- temp0 * zedd^2
    dl.dlocat <- (Dof + 1) * zedd / (Sca * (Dof + zedd^2))
    dl.dlocat[!is.finite(Dof)] <- zedd / Sca  # Adjust for df=Inf
    dl.dscale <- zedd * dl.dlocat - 1 / Sca

    ans <- c(w) * cbind(dl.dlocat * dlocat.deta,
                        dl.dscale * dscale.deta)
    ans <- ans[, interleave.VGAM(ncol(ans), M1 = M1)]
    ans
  }), list( .lloc = lloc, .eloc = eloc,
            .lsca = lsca, .esca = esca,
            .doff = doff ))),
  weight = eval(substitute(expression({

    const1 <- (Dof + 1) / (Dof + 3)
    const2 <- (Dof + 0) / (Dof + 3)
    const1[!is.finite( Dof )] <- 1  # Handles Inf
    const2[!is.finite( Dof )] <- 1  # Handles Inf

    const4 <- dnorm(0)
    ned2l.dlocat2 <-  const1 / (Sca * (
                      Kayfun.studentt(Dof) / const4))^2

    ned2l.dscale2 <- 2.0  * const2 /  Sca^2  # 2.0 seems to work

    wz <- matrix(NA_real_, n, M)  #2=M; diagonal!
    wz[, M1*(1:NOS) - 1] <- ned2l.dlocat2 * dlocat.deta^2
    wz[, M1*(1:NOS)    ] <- ned2l.dscale2 * dscale.deta^2

    w.wz.merge(w = w, wz = wz, n = n, M = M, ndepy = NOS)
  }), list( .lloc = lloc, .eloc = eloc,
            .lsca = lsca, .esca = esca,
            .doff = doff  ))))
}  # studentt2








 chisq <- function(link = "loglink", zero = NULL) {

  link <- as.list(substitute(link))
  earg <- link2list(link)
  link <- attr(earg, "function.name")





  new("vglmff",
  blurb = c("Chi-squared distribution\n\n",
            "Link:     ",
            namesof("df", link, earg = earg, tag = FALSE)),
  charfun = eval(substitute(function(x, eta, extra = NULL,
                                     varfun = FALSE) {
    mydf <- eta2theta(eta, .link , earg = .earg )
    if (varfun) {
      2 * mydf
    } else {
      (1 - 2 * 1i * x)^(-0.5 * mydf)
    }
  }, list( .link = link, .earg = earg  ))),

  constraints = eval(substitute(expression({
    dotzero <- .zero
    M1 <- 1
    eval(negzero.expression.VGAM)
  }), list( .zero = zero ))),

  infos = eval(substitute(function(...) {
    list(M1 = 1,
         Q1 = 1,
         dpqrfun = "chisq",
         charfun = TRUE,
         expected = TRUE,
         multipleResponses = TRUE,
         zero = .zero )
  }, list( .zero = zero ))),


  rqresslot = eval(substitute(
    function(mu, y, w, eta, extra = NULL) {
      Dof <- eta2theta(eta, .link , earg = .earg )
    scrambleseed <- runif(1)  # To scramble the seed
      qnorm(pchisq(y, df = Dof))
  }, list( .link = link, .earg = earg ))),


  initialize = eval(substitute(expression({

    temp5 <-
    w.y.check(w = w, y = y,
              Is.positive.y = TRUE,
              ncol.w.max = Inf,
              ncol.y.max = Inf,
              out.wy = TRUE,
              colsyperw = 1,
              maximize = TRUE)
    w <- temp5$w
    y <- temp5$y


    ncoly <- ncol(y)
    M1 <- 1
    extra$ncoly <- ncoly
    extra$M1 <- M1
    M <- M1 * ncoly

    extra$ncoly <- NOS <- ncoly # Number of species
    mynames1 <- param.names("df", NOS, skip1 = TRUE)
    predictors.names <- namesof(mynames1, .link , .earg ,
                                tag = FALSE)

    if (!length(mustart) && !length(etastart))
      mustart <- y + (1 / 8) * (y == 0)
  }), list( .link = link, .earg = earg ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    eta2theta(eta, .link , earg = .earg )
  }, list( .link = link, .earg = earg ))),

  last = eval(substitute(expression({
    misc$link <- c(rep_len( .link , ncoly))
    names(misc$link) <- mynames1

    misc$earg <- vector("list", M)
    names(misc$earg) <- mynames1
    for (ii in 1:ncoly) {
      misc$earg[[ii]] <- .earg
    }
  }), list( .link = link, .earg = earg ))),

  linkfun = eval(substitute(function(mu, extra = NULL) {
    theta2eta(mu, .link , earg = .earg )
  }, list( .link = link, .earg = earg ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    mydf <- eta2theta(eta, .link , earg = .earg )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <- c(w) * dchisq(y, df = mydf, ncp = 0,
                               log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .link = link, .earg = earg ))),
  vfamily = "chisq",
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    mydf <- eta2theta(eta, .link , earg = .earg )
    okay1 <- all(is.finite(mydf)) && all(0 < mydf)
    okay1
  }, list(  .link = link, .earg = earg ))),



  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    Dof <- eta2theta(eta, .link , earg = .earg )
    rchisq(nsim * length(Dof), df = Dof, ncp = 0)
  }, list( .link = link, .earg = earg ))),




  deriv = eval(substitute(expression({
    mydf <- eta2theta(eta, .link , earg = .earg )
    dl.dv <- (log(y / 2) - digamma(mydf / 2)) / 2
    dv.deta <- dtheta.deta(mydf, .link , earg = .earg )
    c(w) * dl.dv * dv.deta
  }), list( .link = link, .earg = earg ))),
  weight = eval(substitute(expression({
    ned2l.dv2 <- trigamma(mydf / 2) / 4
    wz <- ned2l.dv2 * dv.deta^2
    c(w) * wz
  }), list( .link = link, .earg = earg ))))
}  # chisq







dsimplex <- function(x, mu = 0.5, dispersion = 1, log = FALSE) {
  if (!is.logical(log.arg <- log) || length(log) != 1)
    stop("bad input for argument 'log'")
  rm(log)
  sigma <- dispersion

  deeFun <- function(y, mu)
      (((y - mu) / (mu * (1 - mu)))^2) / (y * (1 - y))
  logpdf <- (-0.5 * log(2 * pi) - log(sigma) - 1.5 * log(x) -
            1.5 * log1p(-x) - 0.5 * deeFun(x, mu) / sigma^2)
  logpdf[x     <= 0.0] <- -Inf  # log(0.0)
  logpdf[x     >= 1.0] <- -Inf  # log(0.0)
  logpdf[mu    <= 0.0] <- NaN
  logpdf[mu    >= 1.0] <- NaN
  logpdf[sigma <= 0.0] <- NaN
  if (log.arg) logpdf else exp(logpdf)
}  # dsimplex



rsimplex <- function(n, mu = 0.5, dispersion = 1) {
  use.n <- if ((length.n <- length(n)) > 1) length.n else
           if (!is.Numeric(n, integer.valued = TRUE,
                           length.arg = 1, positive = TRUE))
               stop("bad input for argument 'n'") else n

  oneval <- (length(mu) == 1 && length(dispersion) == 1)
  answer <- rep_len(0.0, use.n)
  mu <- rep_len(mu, use.n)
  dispersion <- rep_len(dispersion, use.n)
  Kay1 <- 3 * (dispersion * mu * (1-mu))^2

  if (oneval) {
    Kay1 <- Kay1[1]  # As oneval ==> there is only 1 unique value
    mymu <-   mu[1]
    myroots <- polyroot(c(-mymu^2, Kay1+2*mymu^2,
                          -3*Kay1+1-2*mymu, 2*Kay1))
    myroots <- myroots[abs(Im(myroots)) < 0.00001]
    myroots <- Re(myroots)
    myroots <- myroots[myroots >= 0.0]
    myroots <- myroots[myroots <= 1.0]
    pdfmax <- dsimplex(myroots, mymu, dispersion[1])
    pdfmax <- rep_len(max(pdfmax), use.n)  # For multiple peaks
  } else {
    pdfmax <- numeric(use.n)
    for (ii in 1:use.n) {
      myroots <- polyroot(c(-mu[ii]^2, Kay1[ii]+2*mu[ii]^2,
                           -3*Kay1[ii]+1-2*mu[ii], 2*Kay1[ii]))
      myroots <- myroots[abs(Im(myroots)) < 0.00001]
      myroots <- Re(myroots)
      myroots <- myroots[myroots >= 0.0]
      myroots <- myroots[myroots <= 1.0]
      pdfmax[ii] <- max(dsimplex(myroots, mu[ii], dispersion[ii]))
    }
  }

  index <- 1:use.n
  nleft <- length(index)
  while (nleft > 0) {
    xx <- runif(nleft)  # , 0, 1
    yy <- runif(nleft, max = pdfmax[index])
    newindex <- (1:nleft)[yy < dsimplex(xx, mu[index],
                                        dispersion[index])]
    if (length(newindex)) {
      answer[index[newindex]] <- xx[newindex]
      index <- setdiff(index, index[newindex])
      nleft <- nleft - length(newindex)
    }
  }
  answer
}  # rsimplex






 simplex <-
  function(lmu = "logitlink", lsigma = "loglink",
           imu = NULL, isigma = NULL,
           imethod = 1, ishrinkage = 0.95,
           zero = "sigma") {







  lmu <- as.list(substitute(lmu))
  emu <- link2list(lmu)
  lmu <- attr(emu, "function.name")

  lsigma <- as.list(substitute(lsigma))
  esigma <- link2list(lsigma)
  lsigma <- attr(esigma, "function.name")


  if (!is.Numeric(imethod, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE) ||
       imethod > 3)
    stop("argument 'imethod' must be 1 or 2 or 3")
  if (!is.Numeric(ishrinkage, length.arg = 1) ||
      ishrinkage < 0 ||
      ishrinkage > 1)
    stop("bad input for argument 'ishrinkage'")



  new("vglmff",
  blurb = c("Univariate simplex distribution\n\n",
            "f(y) = [2*pi*sigma^2*(y*(1-y))^3]^(-0.5) * \n",
            "       exp[-0.5*(y-mu)^2 / (sigma^2 * y * ",
            "(1-y) * mu^2 * (1-mu)^2)],\n",
            "   0 < y < 1, 0 < mu < 1, sigma > 0\n\n",
            "Links:     ",
            namesof("mu",    lmu,    earg = emu), ", ",
            namesof("sigma", lsigma, earg = esigma), "\n\n",
            "Mean:              mu\n",
            "Variance function: V(mu) = mu^3 * (1 - mu)^3"),
  constraints = eval(substitute(expression({
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 2,
                     predictors.names = predictors.names)
  }), list( .zero = zero ))),

  infos = eval(substitute(function(...) {
    list(M1 = 2,
         Q1 = 1,
         dpqrfun = "simplex",
         expected = TRUE,
         multipleResponses = FALSE,
         parameters.names = c("mu", "sigma"),
         lmu  = .lmu  ,
         lsigma = .lsigma ,
         zero = .zero )
  }, list( .zero = zero, .lsigma = lsigma, .lmu  = lmu
         ))),

  initialize = eval(substitute(expression({
    if (any(y <= 0.0 | y >= 1.0))
      stop("all 'y' values must be in (0,1)")


    w.y.check(w = w, y = y,
              Is.positive.y = TRUE)


    predictors.names <- c(
        namesof("mu",    .lmu ,    earg = .emu ,    tag = FALSE),
        namesof("sigma", .lsigma , earg = .esigma , tag = FALSE))

    deeFun <- function(y, mu)
        (((y - mu) / (mu * (1 - mu)))^2) / (y * (1 - y))

    if (!length(etastart)) {

        use.this <-
          if ( .imethod == 3) weighted.mean(y, w = w) else
          if ( .imethod == 1) median(y) else
                              mean(y, trim = 0.1)


        init.mu <- (1 - .ishrinkage ) *
            y + .ishrinkage * use.this
        mu.init <- rep_len(if (length( .imu ))
                               .imu else init.mu, n)
        sigma.init <- if (length( .isigma ))
                          rep_len( .isigma, n) else {
        use.this <- deeFun(y, mu = init.mu)
         rep_len(sqrt( if ( .imethod == 3)
                    weighted.mean(use.this, w) else
                  if ( .imethod == 1) median(use.this) else
                           mean(use.this, trim = 0.1)), n)
        }
        etastart <-
          cbind(theta2eta(mu.init,    .lmu ,    earg = .emu ),
                theta2eta(sigma.init, .lsigma , earg = .esigma ))
      }
  }), list( .lmu = lmu, .lsigma = lsigma,
            .emu = emu, .esigma = esigma,
            .imu = imu, .isigma = isigma,
            .ishrinkage = ishrinkage, .imethod = imethod ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    eta2theta(eta[, 1], .lmu , earg = .emu )
  }, list( .lmu = lmu, .emu = emu ))),
  last = eval(substitute(expression({
    misc$link <-    c(mu    = .lmu ,
                      sigma = .lsigma )
    misc$earg <- list(mu    = .emu ,
                      sigma = .esigma )
    misc$imu   <- .imu
    misc$isigma <- .isigma
    misc$imethod <- .imethod
    misc$ishrinkage <- .ishrinkage
  }), list( .lmu = lmu, .lsigma = lsigma,
            .imu = imu, .isigma = isigma,
            .emu = emu, .esigma = esigma,
            .ishrinkage = ishrinkage, .imethod = imethod ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    sigma <- eta2theta(eta[, 2], .lsigma , earg = .esigma )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * dsimplex(y, mu = mu, dispersion = sigma,
                        log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .lsigma = lsigma, .emu = emu,
           .esigma = esigma ))),
  vfamily = c("simplex"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    mymu  <- eta2theta(eta[, 1], .lmu    , earg = .emu )
    sigma <- eta2theta(eta[, 2], .lsigma , earg = .esigma )
    okay1 <- all(is.finite(mymu )) &&
             all(is.finite(sigma)) && all(0 < sigma)
    okay1
  }, list( .lmu = lmu, .lsigma = lsigma,
           .emu = emu, .esigma = esigma ))),



  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    mymu  <- eta2theta(eta[, 1], .lmu    , earg = .emu )
    sigma <- eta2theta(eta[, 2], .lsigma , earg = .esigma )
    rsimplex(nsim * length(sigma), mu = mymu, dispersion = sigma)
  }, list( .lmu = lmu, .lsigma = lsigma,
           .emu = emu, .esigma = esigma ))),




  deriv = eval(substitute(expression({
    deeFun <- function(y, mu)
      (((y - mu) / (mu * (1 - mu)))^2) / (y * (1 - y))
    sigma       <- eta2theta(eta[, 2], .lsigma , earg = .esigma )

    dmu.deta    <- dtheta.deta(mu,    .lmu ,    earg = .emu )
    dsigma.deta <- dtheta.deta(sigma, .lsigma , earg = .esigma )

    dl.dmu <- (y - mu) * (deeFun(y, mu) +
               1 / (mu * (1 - mu))^2) / (mu * (1 - mu) * sigma^2)

    dl.dsigma <- (deeFun(y, mu) / sigma^2 - 1) / sigma
    cbind(dl.dmu * dmu.deta,
          dl.dsigma * dsigma.deta)
  }), list( .lmu = lmu, .lsigma = lsigma,
            .emu = emu, .esigma = esigma ))),
  weight = eval(substitute(expression({
    wz <- matrix(0.0, n, M)  # Diagonal!!
    eim11 <- 3 / (mu * (1 - mu)) +
        1 / (sigma^2 * (mu * (1 - mu))^3)
    wz[, iam(1, 1, M)] <- eim11 * dmu.deta^2
    wz[, iam(2, 2, M)] <- (2 / sigma^2) * dsigma.deta^2
    c(w) * wz
  }), list( .lmu = lmu, .lsigma = lsigma,
            .emu = emu, .esigma = esigma ))))
}  # simplex



 rigff <-
  function(lmu = "identitylink", llambda = "loglink",
           imu = NULL, ilambda = 1) {


  if (!is.Numeric(ilambda, positive = TRUE))
    stop("bad input for 'ilambda'")


  lmu <- as.list(substitute(lmu))
  emu <- link2list(lmu)
  lmu <- attr(emu, "function.name")

  llambda <- as.list(substitute(llambda))
  elambda <- link2list(llambda)
  llambda <- attr(elambda, "function.name")


  new("vglmff",
  blurb = c("Reciprocal inverse Gaussian distribution \n",
            "f(y) = [lambda/(2*pi*y)]^(0.5) * \n",
            "       exp[-0.5*(lambda/y) * (y-mu)^2], ",
            "  0 < y,\n",
            "Links:     ",
            namesof("mu",     lmu, earg = emu), ", ",
            namesof("lambda", llambda, earg = elambda), "\n\n",
            "Mean:     mu"),
  initialize = eval(substitute(expression({


    w.y.check(w = w, y = y,
              Is.positive.y = TRUE,
              ncol.w.max = 1,
              ncol.y.max = 1)



    predictors.names <-
      c(namesof("mu",     .lmu ,     .emu ,     tag = FALSE),
        namesof("lambda", .llambda , .elambda , tag = FALSE))
    if (!length(etastart)) {
      mu.init <- rep_len(if (length( .imu )) .imu else median(y), n)
      lambda.init <- rep_len(if (length( .ilambda )) .ilambda else
                             sqrt(var(y)), n)
      etastart <-
        cbind(theta2eta(mu.init, .lmu , earg = .emu ),
              theta2eta(lambda.init, .llambda , earg = .elambda ))
    }
  }), list( .lmu = lmu, .llambda = llambda,
            .emu = emu, .elambda = elambda,
            .imu = imu, .ilambda = ilambda ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    eta2theta(eta[, 1], .lmu , earg = .emu )
  }, list( .lmu = lmu,
           .emu = emu, .elambda = elambda ))),
  last = eval(substitute(expression({
    misc$d3 <- d3  # because save.weights = FALSE
    misc$link <-    c(mu = .lmu , lambda = .llambda )
    misc$earg <- list(mu = .emu , lambda = .elambda )
    misc$pooled.weight <- pooled.weight
  }), list( .lmu = lmu, .llambda = llambda,
            .emu = emu, .elambda = elambda ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    lambda <- eta2theta(eta[, 2], .llambda , earg = .elambda )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * (-0.5 * log(y) + 0.5 * log(lambda) -
                (0.5 * lambda/y) * (y - mu)^2)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .llambda = llambda,
           .elambda = elambda,
           .emu = emu ))),
  vfamily = c("rigff"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    mymu   <- eta2theta(eta[, 1], .lmu    , earg = .emu )
    lambda <- eta2theta(eta[, 2], .llambda , earg = .elambda )
    okay1 <- all(is.finite(mymu ))  &&
             all(is.finite(lambda)) && all(0 < lambda)
    okay1
  }, list( .lmu = lmu, .llambda = llambda,
           .emu = emu, .elambda = elambda ))),

  deriv = eval(substitute(expression({
    if (iter == 1) {
      d3 <- deriv3( ~ w *
   (-0.5*log(y) + 0.5*log(lambda) - (0.5*lambda/y) * (y-mu)^2),
                  c("mu", "lambda"), hessian = TRUE)
    }

    lambda <- eta2theta(eta[, 2], .llambda , earg = .elambda )

    eval.d3 <- eval(d3)
    dl.dthetas <-  attr(eval.d3, "gradient")

    dmu.deta <- dtheta.deta(mu, .lmu , earg = .emu )
    dlambda.deta <- dtheta.deta(lambda, .llambda , .elambda )
    dtheta.detas <- cbind(dmu.deta, dlambda.deta)

    dl.dthetas * dtheta.detas
  }), list( .lmu = lmu, .llambda = llambda,
            .emu = emu, .elambda = elambda ))),
  weight = eval(substitute(expression({
    d2l.dthetas2 <- attr(eval.d3, "hessian")

    wz <- matrix(NA_real_, n, dimm(M))  #3=dimm(M)
    wz[, iam(1, 1, M)] <- -d2l.dthetas2[, 1, 1] *
        dtheta.detas[, 1]^2
    wz[, iam(2, 2, M)] <- -d2l.dthetas2[, 2, 2] *
        dtheta.detas[, 2]^2
    wz[, iam(1, 2, M)] <- -d2l.dthetas2[, 1, 2] *
        dtheta.detas[, 1] * dtheta.detas[, 2]
    if (! .expected ) {
      d2mudeta2 <- d2theta.deta2(mu, .lmu , .emu )
      d2lambda <- d2theta.deta2(lambda, .llambda , .elambda )
      wz[, iam(1, 1, M)] <- wz[, iam(1, 1, M)] -
          dl.dthetas[, 1] * d2mudeta2
      wz[, iam(2, 2, M)] <- wz[, iam(2, 2, M)] -
          dl.dthetas[, 2] * d2lambda
    }

    if (intercept.only) {
      sumw <- sum(w)
      for (ii in 1:ncol(wz))
        wz[, ii] <- sum(wz[, ii]) / sumw
      pooled.weight <- TRUE
      wz <- c(w) * wz   # Put back the weights
    } else {
      pooled.weight <- FALSE
    }

    wz
  }), list( .lmu = lmu, .llambda = llambda, .expected = FALSE,
            .emu = emu, .elambda = elambda ))))
}  # rigff



 hypersecant <-
  function(link.theta = extlogitlink(min = -pi/2, max = pi/2),
           init.theta = NULL) {


  link.theta <- as.list(substitute(link.theta))
  earg <- link2list(link.theta)
  link.theta <- attr(earg, "function.name")


  new("vglmff",
  blurb = c("Hyperbolic Secant distribution \n",
  "f(y) = exp(theta*y + log(cos(theta ))) / (2*cosh(pi*y/2))\n",
            "  for all y,\n",
            "Link:     ",
            namesof("theta", link.theta , earg = earg), "\n\n",
            "Mean:     tan(theta)"),
  initialize = eval(substitute(expression({

    w.y.check(w = w, y = y,
              ncol.w.max = 1,
              ncol.y.max = 1)




    predictors.names <-
      namesof("theta", .link.theta , earg = .earg , tag = FALSE)
    if (!length(etastart)) {
        theta.init <- rep_len(if (length( .init.theta ))
                                  .init.theta else
                            median(y), n)
      etastart <-
        theta2eta(theta.init, .link.theta , earg = .earg )
    }
  }), list( .link.theta = link.theta , .earg = earg,
            .init.theta = init.theta ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    theta <- eta2theta(eta, .link.theta , earg = .earg )
    tan(theta)
  }, list( .link.theta = link.theta , .earg = earg ))),
  last = eval(substitute(expression({
    misc$link <- c(theta = .link.theta )
    misc$earg <- list(theta = .earg )
    misc$expected <- TRUE
  }), list( .link.theta = link.theta , .earg = earg ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    theta <- eta2theta(eta, .link.theta , earg = .earg )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
        ll.elts <- c(w) * (theta*y + log(cos(theta)) -
                           log(cosh(pi*y/2 )))
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .link.theta = link.theta , .earg = earg ))),
  vfamily = c("hypersecant"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    theta <- eta2theta(eta, .link.theta , earg = .earg )
    okay1 <- all(is.finite(theta)) && all(abs(theta) < pi/2)
    okay1
  }, list( .link.theta = link.theta , .earg = earg ))),
  deriv = eval(substitute(expression({
    theta <- eta2theta(eta, .link.theta , earg = .earg )
    dl.dthetas <-  y - tan(theta)
    dparam.deta <- dtheta.deta(theta, .link.theta , earg = .earg )
    c(w) * dl.dthetas * dparam.deta
  }), list( .link.theta = link.theta , .earg = earg ))),
  weight = expression({
    d2l.dthetas2 <-  1 / cos(theta)^2
    wz <- c(w) * d2l.dthetas2 * dparam.deta^2
    wz
  }))
}  # hypersecant



 hypersecant01 <-
  function(link.theta = extlogitlink(min = -pi/2, max = pi/2),
           init.theta = NULL) {


  link.theta <- as.list(substitute(link.theta))
  earg <- link2list(link.theta)
  link.theta <- attr(earg, "function.name")


  new("vglmff",
  blurb = c("Hyperbolic secant distribution \n",
            "f(y) = (cos(theta)/pi) * y^(-0.5+theta/pi) * \n",
            "       (1-y)^(-0.5-theta/pi), ",
            "  0 < y < 1,\n",
            "Link:     ",
            namesof("theta", link.theta , earg = earg), "\n\n",
            "Mean:     0.5 + theta/pi", "\n",
            "Variance: (pi^2 - 4*theta^2) / (8*pi^2)"),
  initialize = eval(substitute(expression({
    if (any(y <= 0 | y >= 1))
      stop("all response 'y' values must be in (0,1)")


    w.y.check(w = w, y = y,
              Is.positive.y = TRUE,
              ncol.w.max = 1,
              ncol.y.max = 1)




    predictors.names <-
      namesof("theta", .link.theta , earg = .earg , tag = FALSE)

    if (!length(etastart)) {
        theta.init <- rep_len(if (length( .init.theta ))
                                  .init.theta else
                          median(y), n)

    etastart <-
        theta2eta(theta.init, .link.theta , earg = .earg )
    }
  }), list( .link.theta = link.theta , .earg = earg,
            .init.theta = init.theta ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    theta <- eta2theta(eta, .link.theta , earg = .earg )
    0.5 + theta / pi
  }, list( .link.theta = link.theta , .earg = earg ))),
  last = eval(substitute(expression({
    misc$link <- c(theta = .link.theta )
    misc$earg <- list(theta = .earg )
    misc$expected <- TRUE
  }), list( .link.theta = link.theta , .earg = earg ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    theta <- eta2theta(eta, .link.theta , earg = .earg )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * (log(cos(theta)) + (-0.5 + theta/pi) * log(y) +
               (-0.5 - theta/pi) * log1p(-y ))
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .link.theta = link.theta , .earg = earg ))),
  vfamily = c("hypersecant01"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    theta <- eta2theta(eta, .link.theta , earg = .earg )
    okay1 <- all(is.finite(theta)) && all(abs(theta) < pi/2)
    okay1
  }, list( .link.theta = link.theta , .earg = earg ))),
  deriv = eval(substitute(expression({
    theta <- eta2theta(eta, .link.theta , earg = .earg )
    dl.dthetas <-  -tan(theta) + logitlink(y) / pi
    dparam.deta <- dtheta.deta(theta, .link.theta , earg = .earg )
    c(w) * dl.dthetas * dparam.deta
  }), list( .link.theta = link.theta , .earg = earg ))),
  weight = expression({
    d2l.dthetas2 <-  1 / cos(theta)^2
    wz <- c(w) * d2l.dthetas2 * dparam.deta^2
    wz
  }))
}  # hypersecant01



 leipnik <-
  function(lmu = "logitlink", llambda = logofflink(offset = 1),
           imu = NULL,    ilambda = NULL) {



  lmu <- as.list(substitute(lmu))
  emu <- link2list(lmu)
  lmu <- attr(emu, "function.name")

  llambda <- as.list(substitute(llambda))
  elambda <- link2list(llambda)
  llambda <- attr(elambda, "function.name")


  if (is.Numeric(ilambda) && any(ilambda <= -1))
    stop("argument 'ilambda' must be > -1")



  new("vglmff",
  blurb = c("Leipnik's distribution \n",
            "f(y) = ",
  "(y(1-y))^(-1/2) * [1 + (y-mu)^2 / (y*(1-y))]^(-lambda/2) /\n",
            "       Beta[(lambda+1)/2, 1/2], ",
            "  0 < y < 1,  lambda > -1\n",
            "Links:     ",
            namesof("mu", lmu, earg = emu), ", ",
            namesof("lambda", llambda, earg = elambda), "\n\n",
            "Mean:     mu\n",
            "Variance: mu*(1-mu)"),
  initialize = eval(substitute(expression({
      if (any(y <= 0 | y >= 1))
        stop("all response 'y' values must be in (0,1)")


    w.y.check(w = w, y = y,
              Is.positive.y = TRUE,
              ncol.w.max = 1,
              ncol.y.max = 1)




      predictors.names <-
        c(namesof("mu",     .lmu ,     .emu ,     tag = FALSE),
          namesof("lambda", .llambda , .elambda , tag = FALSE))

    if (!length(etastart)) {
      mu.init <- rep_len(if (length( .imu )) .imu else (y), n)
      lambda.init <- rep_len(if (length( .ilambda )) .ilambda else
                             1/var(y), n)
      etastart <-
       cbind(theta2eta(mu.init,     .lmu ,     earg = .emu ),
             theta2eta(lambda.init, .llambda , earg = .elambda ))
    }
  }), list( .lmu = lmu, .llambda = llambda,
            .emu = emu, .elambda = elambda,
            .imu = imu, .ilambda = ilambda ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    eta2theta(eta[, 1], .lmu , earg = .emu )
  }, list( .lmu = lmu,
           .emu = emu, .elambda = elambda ))),
  last = eval(substitute(expression({
    misc$link <-    c(mu = .lmu , lambda = .llambda )
    misc$earg <- list(mu = .emu , lambda = .elambda )

    misc$pooled.weight <- pooled.weight
    misc$expected <- FALSE
  }), list( .lmu = lmu, .llambda = llambda,
            .emu = emu, .elambda = elambda ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    lambda <- eta2theta(eta[, 2], .llambda , earg = .elambda )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * (-0.5*log(y*(1-y)) - 0.5 * lambda *
                log1p((y-mu)^2 / (y*(1-y ))) -
                lgamma((lambda+1)/2) +
               lgamma(1+ lambda/2 ))
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .llambda = llambda,
           .emu = emu, .elambda = elambda ))),
  vfamily = c("leipnik"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    mymu   <- eta2theta(eta[, 1], .lmu ,     earg = .emu     )
    lambda <- eta2theta(eta[, 2], .llambda , earg = .elambda )
    okay1 <- all(is.finite(mymu  )) && all( 0 < mymu & mymu < 1) &&
             all(is.finite(lambda)) && all(-1 < lambda)
    okay1
  }, list( .lmu = lmu, .llambda = llambda,
           .emu = emu, .elambda = elambda ))),
  deriv = eval(substitute(expression({
    lambda <- eta2theta(eta[, 2], .llambda , earg = .elambda )
    dl.dthetas =
      cbind(dl.dmu = lambda*(y-mu) / (y*(1-y)+(y-mu)^2),
            dl.dlambda= -0.5 * log1p((y-mu)^2 / (y*(1-y))) -
            0.5*digamma((lambda+1)/2) +
            0.5*digamma(1+lambda/2))

    dmu.deta <- dtheta.deta(mu, .lmu , earg = .emu )
    dlambda.deta <- dtheta.deta(lambda, .llambda , earg = .elambda )
    dtheta.detas <- cbind(dmu.deta, dlambda.deta)

    c(w) * dl.dthetas * dtheta.detas
  }), list( .lmu = lmu, .llambda = llambda,
            .emu = emu, .elambda = elambda ))),
  weight = eval(substitute(expression({
    denominator <- y*(1-y) + (y-mu)^2
    d2l.dthetas2 <-  array(NA_real_, c(n, 2, 2))
    d2l.dthetas2[, 1, 1] <- c(w) * lambda *
               (-y * (1 - y) + (y - mu)^2) / denominator^2
    d2l.dthetas2[, 1, 2] <-
    d2l.dthetas2[, 2, 1] <- c(w) * (y-mu) / denominator
    d2l.dthetas2[, 2, 2] <- c(w) * (-0.25*trigamma((lambda+1)/2) +
                                 0.25*trigamma(1+lambda/2))

    wz <- matrix(NA_real_, n, dimm(M))  #3=dimm(M)
    wz[, iam(1, 1, M)] <- -d2l.dthetas2[, 1, 1] * dtheta.detas[, 1]^2
    wz[, iam(2, 2, M)] <- -d2l.dthetas2[, 2, 2] * dtheta.detas[, 2]^2
    wz[, iam(1, 2, M)] <- -d2l.dthetas2[, 1, 2] * dtheta.detas[, 1] *
                                                 dtheta.detas[, 2]
    if (!.expected) {
      d2mudeta2 <- d2theta.deta2(mu, .lmu , earg = .emu )
      d2lambda <- d2theta.deta2(lambda, .llambda , earg = .elambda )
      wz[, iam(1, 1, M)] <- wz[, iam(1, 1, M)] -
                            dl.dthetas[, 1] * d2mudeta2
      wz[, iam(2, 2, M)] <- wz[, iam(2, 2, M)] -
                            dl.dthetas[, 2] *d2lambda
    }

    if (intercept.only) {
    sumw <- sum(w)
    for (ii in 1:ncol(wz))
      wz[, ii] <- sum(wz[, ii]) / sumw
    pooled.weight <- TRUE
    wz <- c(w) * wz  # Put back the weights
  } else {
    pooled.weight <- FALSE
  }

    wz
  }), list( .lmu = lmu, .llambda = llambda, .expected = FALSE,
            .emu = emu, .elambda = elambda ))))
}  # leipnik



 inv.binomial <- function(lrho = extlogitlink(min = 0.5, max = 1),
                          llambda = "loglink",
                          irho = NULL,
                          ilambda = NULL,
                          zero = NULL) {






  lrho <- as.list(substitute(lrho))
  erho <- link2list(lrho)
  lrho <- attr(erho, "function.name")

  llambda <- as.list(substitute(llambda))
  elambda <- link2list(llambda)
  llambda <- attr(elambda, "function.name")


  new("vglmff",
  blurb = c("Inverse binomial distribution\n\n",
            "Links:    ",
            namesof("rho",    lrho,    earg = erho),    ", ",
            namesof("lambda", llambda, earg = elambda), "\n",
            "Mean:     lambda*(1-rho)/(2*rho-1)\n",
            "Variance: lambda*rho*(1-rho)/(2*rho-1)^3\n"),
  constraints = eval(substitute(expression({
    constraints <-
      cm.zero.VGAM(constraints, x = x, .zero , M = M, M1 = 2,
                   predictors.names = predictors.names)
  }), list( .zero = zero ))),
  initialize = eval(substitute(expression({

    w.y.check(w = w, y = y,
              ncol.w.max = 1,
              ncol.y.max = 1)



    predictors.names <-
    c(namesof("rho", .lrho, earg = .erho, tag = FALSE),
      namesof("lambda", .llambda , earg = .elambda , tag = FALSE))

    if (!length(etastart)) {
      covarn <- sd(c(y))^2 / weighted.mean(y, w)
      temp1 <- 0.5 + (1 + sqrt(1+8*covarn)) / (8*covarn)
      temp2 <- 0.5 + (1 - sqrt(1+8*covarn)) / (8*covarn)
      init.rho <- rep_len(if (length( .irho)) .irho else {
                  ifelse(temp1 > 0.5 && temp1 < 1, temp1, temp2) }, n)
      init.lambda <- rep_len(if (length( .ilambda)) .ilambda else {
                            (2*init.rho-1) *
                            weighted.mean(y, w) / (1-init.rho)}, n)
      etastart <-
        cbind(theta2eta(init.rho, .lrho, earg = .erho),
              theta2eta(init.lambda, .llambda , earg = .elambda ))
    }
  }), list( .llambda = llambda, .lrho = lrho,
            .elambda = elambda, .erho = erho,
            .ilambda = ilambda, .irho = irho ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    rho <- eta2theta(eta[, 1], .lrho, earg = .erho)
    lambda <- eta2theta(eta[, 2], .llambda , earg = .elambda )
    ifelse(rho > 0.5, lambda*(1-rho)/(2*rho-1), NA)
  }, list( .llambda = llambda, .lrho = lrho,
           .elambda = elambda, .erho = erho ))),
  last = eval(substitute(expression({
    misc$link <- c(rho= .lrho, lambda = .llambda )
    misc$earg <- list(rho= .erho, lambda = .elambda )
    misc$pooled.weight <- pooled.weight
  }), list( .llambda = llambda, .lrho = lrho,
            .elambda = elambda, .erho = erho ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    rho    <- eta2theta(eta[, 1], .lrho    , earg = .erho )
    lambda <- eta2theta(eta[, 2], .llambda , earg = .elambda )

    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * (log(lambda) - lgamma(2*y+lambda) - lgamma(y+1) -
        lgamma(y+lambda+1) + y*log(rho) + y*log1p(-rho) +
        lambda*log(rho))
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .llambda = llambda, .lrho = lrho,
           .elambda = elambda, .erho = erho ))),
  vfamily = c("inv.binomial"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    rho    <- eta2theta(eta[, 1], .lrho    , earg = .erho )
    lambda <- eta2theta(eta[, 2], .llambda , earg = .elambda )
    okay1 <- all(is.finite(rho   )) && all(0.5 < rho & rho < 1) &&
             all(is.finite(lambda)) && all(0   < lambda)
    okay1
  }, list( .llambda = llambda, .lrho = lrho,
           .elambda = elambda, .erho = erho ))),
  deriv = eval(substitute(expression({
    rho    <- eta2theta(eta[, 1], .lrho    , earg = .erho )
    lambda <- eta2theta(eta[, 2], .llambda , earg = .elambda )

    dl.drho <- (y + lambda)/rho - y/(1-rho)
    dl.dlambda <- 1/lambda - digamma(2*y+lambda) -
        digamma(y+lambda+1) +
                 log(rho)

    drho.deta    <- dtheta.deta(rho,    .lrho    , earg = .erho )
    dlambda.deta <- dtheta.deta(lambda, .llambda , earg = .elambda )

    c(w) * cbind(dl.drho * drho.deta,
                 dl.dlambda * dlambda.deta )
  }), list( .llambda = llambda, .lrho = lrho,
              .elambda = elambda, .erho = erho ))),
  weight = eval(substitute(expression({
    ned2l.drho2 <- (mu+lambda) / rho^2 + mu / (1-rho)^2
    d2l.dlambda2 <- 1/(lambda^2) + trigamma(2*y+lambda) +
                    trigamma(y+lambda+1)
    ned2l.dlambdarho <- -1/rho

    wz <- matrix(NA_real_, n, dimm(M))  #3=dimm(M)
    wz[, iam(1, 1, M)] <- ned2l.drho2 * drho.deta^2
    wz[, iam(1, 2, M)] <- ned2l.dlambdarho * dlambda.deta *
        drho.deta
    wz[, iam(2, 2, M)] <-  d2l.dlambda2 * dlambda.deta^2

    d2rhodeta2 <- d2theta.deta2(rho, .lrho, earg = .erho)
    d2lambda.deta2 <- d2theta.deta2(lambda, .llambda , .elambda )
    wz <- c(w) * wz

    if (intercept.only) {
      pooled.weight <- TRUE

      wz[, iam(2, 2, M)] <-  sum(wz[, iam(2, 2, M)]) / sum(w)

    } else {
      pooled.weight <- FALSE
    }

    wz
  }), list( .llambda = llambda, .lrho = lrho,
            .elambda = elambda, .erho = erho ))))
}  # inv.binomial






dlgamma <-
  function(x, location = 0, scale = 1, shape = 1, log = FALSE) {
  if (!is.logical(log.arg <- log) || length(log) != 1)
    stop("bad input for argument 'log'")
  rm(log)

  if (!is.Numeric(scale, positive = TRUE))
    stop("bad input for argument 'scale'")
  if (!is.Numeric(shape, positive = TRUE))
    stop("bad input for argument 'shape'")
  z <- (x-location) / scale
  logden <- shape * z - exp(z) - log(scale) - lgamma(shape)
  logden[is.infinite(x)] <- log(0)  # 20141210
  if (log.arg) logden else exp(logden)
}



plgamma <- function(q, location = 0, scale = 1, shape = 1,
                    lower.tail = TRUE, log.p = FALSE) {



  zedd <- (q - location) / scale
  ans <- pgamma(exp(zedd), shape, lower.tail = lower.tail,
                log.p = log.p)
  ans[scale <  0] <- NaN
  ans
}  # plgamma



qlgamma <- function(p, location = 0, scale = 1, shape = 1,
                    lower.tail = TRUE, log.p = FALSE) {


  ans <- location + scale * log(qgamma(p, shape, log.p = log.p,
                                       lower.tail = lower.tail))
  ans[scale <  0] <- NaN
  ans
}  # qlgamma



rlgamma <- function(n, location = 0, scale = 1, shape = 1) {
  ans <- location + scale * log(rgamma(n, shape))
  ans[scale < 0] <- NaN
  ans
}



 lgamma1 <-
  function(lshape = "loglink", ishape = NULL) {


  init.k <- ishape

  link <- as.list(substitute(lshape))
  earg <- link2list(link)
  link <- attr(earg, "function.name")


  new("vglmff",
  blurb = c("Log-gamma distribution ",
            "f(y) = exp(ky - e^y)/gamma(k)), k>0, ",
            "shape=k>0\n\n",
            "Link:    ",
            namesof("k", link, earg = earg), "\n", "\n",
            "Mean:    digamma(k)", "\n"),
  initialize = eval(substitute(expression({

    w.y.check(w = w, y = y,
              ncol.w.max = 1,
              ncol.y.max = 1)


    predictors.names <-
      namesof("shape", .link , earg = .earg , tag = FALSE)

    if (!length(etastart)) {
      k.init <- if (length( .init.k))
               rep_len( .init.k, length(y)) else {
               medy = median(y)
          if (medy < 2) 5 else if (medy < 4) 20 else exp(0.7 * medy)
        }
      etastart <- theta2eta(k.init, .link , earg = .earg )
    }
  }), list( .link = link, .earg = earg, .init.k = init.k ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    kay <- eta2theta(eta, .link , earg = .earg )
    digamma(kay)
  }, list( .link = link, .earg = earg ))),
  last = eval(substitute(expression({
    misc$link <-    c(shape = .link )
    misc$earg <- list(shape = .earg )
    misc$expected <- TRUE
  }), list( .link = link, .earg = earg ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    kay <- eta2theta(eta, .link , earg = .earg )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * dlgamma(y, location = 0, scale = 1,
                       shape = kay, log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .link = link, .earg = earg ))),
  vfamily = c("lgamma1"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    kk <- eta2theta(eta, .link , earg = .earg )
    okay1 <- all(is.finite(kk)) && all(0 < kk)
    okay1
  }, list( .link = link, .earg = earg ))),


  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    kay <- eta2theta(eta, .link , earg = .earg )
    rlgamma(nsim * length(kay), location = 0, sc = 1, sh = kay)
  }, list( .link = link, .earg = earg ))),



  deriv = eval(substitute(expression({
    kk <- eta2theta(eta, .link , earg = .earg )
    dl.dk <- y - digamma(kk)
    dk.deta <- dtheta.deta(kk, .link , earg = .earg )
    c(w) * dl.dk * dk.deta
  }), list( .link = link, .earg = earg ))),
  weight = eval(substitute(expression({
    ned2l.dk2 <- trigamma(kk)
    wz <- c(w) * dk.deta^2 * ned2l.dk2
    wz
  }), list( .link = link, .earg = earg ))))
}  # lgamma1



 lgamma3   <-
  function(llocation = "identitylink",
           lscale = "loglink",
           lshape = "loglink",
           ilocation = NULL, iscale = NULL, ishape = 1,
           zero = c("scale", "shape")) {


  if (length(iscale) &&
      !is.Numeric(iscale, positive = TRUE))
    stop("bad input for argument 'iscale'")


  llocat <- as.list(substitute(llocation))
  elocat <- link2list(llocat)
  llocat <- attr(elocat, "function.name")
  ilocat <- ilocation

  lscale <- as.list(substitute(lscale))
  escale <- link2list(lscale)
  lscale <- attr(escale, "function.name")

  lshape <- as.list(substitute(lshape))
  eshape <- link2list(lshape)
  lshape <- attr(eshape, "function.name")




  new("vglmff",
  blurb = c("Log-gamma distribution",
            " f(y) = exp(k(y-a)/b - e^((y-a)/b))/(b*gamma(k)), ",
            "location=a, scale=b>0, shape=k>0\n\n",
            "Links:    ",
            namesof("location", llocat, earg = elocat), ", ",
            namesof("scale",    lscale, earg = escale), ", ",
            namesof("shape",    lshape, earg = eshape), "\n\n",
            "Mean:     a + b * digamma(k)", "\n"),
 constraints = eval(substitute(expression({
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 3,
                     predictors.names = predictors.names)
  }), list( .zero = zero ))),

  infos = eval(substitute(function(...) {
    list(M1 = 2,
         Q1 = 1,
         dpqrfun = "lgamma",
         expected = TRUE,
         multipleResponses = FALSE,
         parameters.names = c("location", "scale", "shape"),
         llocation = .llocat ,
         lscale    = .lscale ,
         lshape    = .lshape ,
         zero = .zero )
  }, list( .zero = zero,
           .llocat    = llocat ,
           .lscale    = lscale ,
           .lshape    = lshape ))),


  rqresslot = eval(substitute(
    function(mu, y, w, eta, extra = NULL) {
      aa <- eta2theta(eta[, 1], .llocat , earg = .elocat )
      bb <- eta2theta(eta[, 2], .lscale , earg = .escale )
      kk <- eta2theta(eta[, 3], .lshape , earg = .eshape )
    scrambleseed <- runif(1)  # To scramble the seed
      qnorm(plgamma(y, location = aa, scale = bb, shape = kk))
  }, list( .llocat = llocat, .lscale = lscale, .lshape = lshape,
           .elocat = elocat, .escale = escale, .eshape = eshape))),

  initialize = eval(substitute(expression({

    w.y.check(w = w, y = y,
              ncol.w.max = 1,
              ncol.y.max = 1)



    predictors.names <-
      c(namesof("location", .llocat , .elocat , tag = FALSE),
        namesof("scale",    .lscale , .escale , tag = FALSE),
        namesof("shape",    .lshape , .eshape , tag = FALSE))


    if (!length(etastart)) {
      k.init <- if (length( .ishape ))
               rep_len( .ishape, length(y)) else {
          rep_len(exp(median(y)), length(y))
      }
      scale.init <- if (length( .iscale ))
          rep_len( .iscale , length(y)) else {
          rep_len(sqrt(var(y) / trigamma(k.init)), length(y))
      }
      loc.init <- if (length( .ilocat ))
          rep_len( .ilocat, length(y)) else {
          rep_len(median(y) - scale.init * digamma(k.init),
                  length(y))
      }
      etastart <-
        cbind(theta2eta(loc.init, .llocat , earg = .elocat ),
              theta2eta(scale.init, .lscale , earg = .escale ),
              theta2eta(k.init, .lshape , earg = .eshape ))
    }
  }), list( .llocat = llocat, .lscale = lscale, .lshape = lshape,
            .elocat = elocat, .escale = escale, .eshape = eshape,
            .ilocat = ilocat, .iscale = iscale, .ishape = ishape ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    eta2theta(eta[, 1], .llocat , earg = .elocat ) +
    eta2theta(eta[, 2], .lscale , earg = .escale ) *
    digamma(eta2theta(eta[, 3], .lshape , earg = .eshape ))
  }, list( .llocat = llocat, .lscale = lscale, .lshape = lshape,
           .elocat = elocat, .escale = escale, .eshape = eshape))),
  last = eval(substitute(expression({
    misc$link <-    c(location = .llocat ,
                      scale    = .lscale ,
                      shape    = .lshape)

    misc$earg <- list(location = .elocat ,
                      scale    = .escale ,
                      shape    = .eshape )

    misc$multipleResponses <- FALSE
  }), list( .llocat = llocat, .lscale = lscale, .lshape = lshape,
            .elocat = elocat, .escale = escale, .eshape = eshape))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    aa <- eta2theta(eta[, 1], .llocat , earg = .elocat )
    bb <- eta2theta(eta[, 2], .lscale , earg = .escale )
    kk <- eta2theta(eta[, 3], .lshape , earg = .eshape )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * dlgamma(x = y, locat = aa, scale = bb, shape = kk,
                       log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .llocat = llocat, .lscale = lscale, .lshape = lshape,
           .elocat = elocat, .escale = escale, .eshape = eshape))),
  vfamily = c("lgamma3"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    aa <- eta2theta(eta[, 1], .llocat , earg = .elocat )
    bb <- eta2theta(eta[, 2], .lscale , earg = .escale )
    kk <- eta2theta(eta[, 3], .lshape , earg = .eshape )
    okay1 <- all(is.finite(kk)) && all(0 < kk) &&
             all(is.finite(bb)) && all(0 < bb) &&
             all(is.finite(aa))
    okay1
  }, list( .llocat = llocat, .lscale = lscale, .lshape = lshape,
           .elocat = elocat, .escale = escale, .eshape = eshape))),






  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    aa <- eta2theta(eta[, 1], .llocat , earg = .elocat )
    bb <- eta2theta(eta[, 2], .lscale , earg = .escale )
    kk <- eta2theta(eta[, 3], .lshape , earg = .eshape )
    rlgamma(nsim * length(kk), aa, scale = bb, shape = kk)
  }, list( .llocat = llocat, .lscale = lscale, .lshape = lshape,
           .elocat = elocat, .escale = escale, .eshape = eshape))),




  deriv = eval(substitute(expression({
    a <- eta2theta(eta[, 1], .llocat , earg = .elocat )
    b <- eta2theta(eta[, 2], .lscale , earg = .escale )
    k <- eta2theta(eta[, 3], .lshape , earg = .eshape )

    zedd <- (y-a)/b
    dl.da <- (exp(zedd) - k) / b
    dl.db <- (zedd * (exp(zedd) - k) - 1) / b
    dl.dk <- zedd - digamma(k)

    da.deta <- dtheta.deta(a, .llocat , earg = .elocat )
    db.deta <- dtheta.deta(b, .lscale , earg = .escale )
    dk.deta <- dtheta.deta(k, .lshape , earg = .eshape )

    c(w) * cbind(dl.da * da.deta,
                 dl.db * db.deta,
                 dl.dk * dk.deta)
  }), list( .llocat = llocat, .lscale = lscale, .lshape = lshape,
            .elocat = elocat, .escale = escale, .eshape = eshape))),
  weight = eval(substitute(expression({
    ned2l.da2 <- k / b^2
    ned2l.db2 <- (1 + k*(trigamma(k+1) + (digamma(k+1))^2)) / b^2
    ned2l.dk2 <- trigamma(k)
    ned2l.dadb <- (1 + k*digamma(k)) / b^2
    ned2l.dadk <- 1 / b
    ned2l.dbdk <- digamma(k) / b

    wz <- matrix(NA_real_, n, dimm(M))
    wz[, iam(1, 1, M)] <- ned2l.da2 * da.deta^2
    wz[, iam(2, 2, M)] <- ned2l.db2 * db.deta^2
    wz[, iam(3, 3, M)] <- ned2l.dk2 * dk.deta^2
    wz[, iam(1, 2, M)] <- ned2l.dadb * da.deta * db.deta
    wz[, iam(1, 3, M)] <- ned2l.dadk * da.deta * dk.deta
    wz[, iam(2, 3, M)] <- ned2l.dbdk * db.deta * dk.deta
    wz <- c(w) * wz
    wz
  }), list( .llocat = llocat, .lscale = lscale, .lshape = lshape,
            .elocat = elocat, .escale = escale, .eshape = eshape))))
}  # lgamma3



dprentice74 <-
  function(x, location = 0, scale = 1, shape, log = FALSE,
           tol0 = 1e-4) {
  if (!is.logical(log.arg <- log) || length(log) != 1)
    stop("bad input for argument 'log'")
  rm(log)

  LLL <- max(length(x), length(location), length(scale),
             length(shape))
  if (length(x)        != LLL) x        <- rep_len(x,        LLL)
  if (length(location) != LLL) location <- rep_len(location, LLL)
  if (length(scale)    != LLL) scale    <- rep_len(scale,    LLL)
  if (length(shape)    != LLL) shape    <- rep_len(shape,    LLL)

  tmp55 <- shape^(-2)
  doubw <- (x - location) * shape / scale + digamma(tmp55)
  ll.elts <- log(abs(shape)) - log(scale) - lgamma(tmp55) +
      doubw * tmp55 - exp(doubw)

  if (any((shape0 <- abs(shape) < tol0), na.rm = TRUE))
    ll.elts[shape0] <- dnorm(x[shape0], location[shape0],
                             scale[shape0], log = TRUE)
  if (log.arg) ll.elts else exp(ll.elts)
}  # dprentice74



 prentice74 <-
  function(llocation = "identitylink", lscale = "loglink",
           lshape = "identitylink",
           ilocation = NULL, iscale = NULL, ishape = NULL,
           imethod = 1,
           glocation.mux = exp((-4:4)/2),
           gscale.mux = exp((-4:4)/2),
           gshape = qt(ppoints(6), df = 1),  # exp((-5:5)/2),
           probs.y = 0.3,
           zero = c("scale", "shape")) {


  if (length(iscale) &&
     !is.Numeric(iscale, positive = TRUE))
    stop("bad input for argument 'iscale'")


  llocat <- as.list(substitute(llocation))
  elocat <- link2list(llocat)
  llocat <- attr(elocat, "function.name")
  ilocat <- ilocation

  lscale <- as.list(substitute(lscale))
  escale <- link2list(lscale)
  lscale <- attr(escale, "function.name")

  lshape <- as.list(substitute(lshape))
  eshape <- link2list(lshape)
  lshape <- attr(eshape, "function.name")



  new("vglmff",
  blurb = c("Log-gamma distribution (Prentice, 1974)\n",
  "f(y; a, b, q) = |q| * exp(w/q^2 - e^w) / (b*gamma(1/q^2)),",
            "\n",
            "w = (y-a)*q/b + digamma(1/q^2),\n",
            "location = a, scale = b > 0, shape = q\n\n",
            "Links:    ",
            namesof("location", llocat, elocat), ", ",
            namesof("scale",    lscale, escale), ", ",
            namesof("shape",    lshape, eshape), "\n", "\n",
            "Mean:     a", "\n"),
  constraints = eval(substitute(expression({
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 3,
                     predictors.names = predictors.names)
  }), list( .zero = zero ))),

  infos = eval(substitute(function(...) {
    list(M1 = 3,
         Q1 = 1,
         dpqrfun = "prentice74",
         expected = TRUE,
         multipleResponses = TRUE,
         parameters.names = c("location", "scale", "shape"),
         imethod = .imethod ,
         llocation  = .llocat ,
         lscale     = .lscale ,
         lshape     = .lshape ,
         zero = .zero )
  }, list( .zero = zero,
           .imethod = imethod ,
           .llocat  = llocat ,
           .lscale  = lscale ,
           .lshape  = lshape ))),

  initialize = eval(substitute(expression({
    M1 <- 3
    Q1 <- 1

    temp5 <-
    w.y.check(w = w, y = y,
              Is.positive.y = FALSE,
              Is.integer.y = FALSE,
              ncol.w.max = Inf,
              ncol.y.max = Inf,
              out.wy = TRUE,
              colsyperw = 1,
              maximize = TRUE)
    w <- temp5$w
    y <- temp5$y


    NOS <- ncoly <- ncol(y)  # Number of species
    M <- M1 * ncoly


    temp1.names <- param.names("location", NOS, skip1 = TRUE)
    temp2.names <- param.names("scale",    NOS, skip1 = TRUE)
    temp3.names <- param.names("shape",    NOS, skip1 = TRUE)
    predictors.names <-
        c(namesof(temp1.names, .llocat , .elocat , tag = FALSE),
          namesof(temp2.names, .lscale , .escale , tag = FALSE),
          namesof(temp3.names, .lshape , .eshape , tag = FALSE))
    predictors.names <- predictors.names[interleave.VGAM(M, M1 = M1)]



    if (!length(etastart)) {
      lo.init <-
      sc.init <-
      sh.init <- matrix(NA_real_, n, NOS)
      if (length( .ilocat ))
        lo.init <-  matrix( .ilocat , n, NOS, byrow = TRUE)
      if (length( .iscale ))
        sc.init <-  matrix( .iscale , n, NOS, byrow = TRUE)
      if (length( .ishape ))
        sh.init <-  matrix( .ishape , n, NOS, byrow = TRUE)

      for (spp. in 1:NOS) {  # For each response 'y_spp.'... do:
        yvec <- y[, spp.]
        wvec <- w[, spp.]
        mu.init <- switch( .imethod ,
                          median(yvec),  # More reliable I think
                          weighted.mean(yvec, w = wvec),
                          quantile(yvec, prob = .probs.y ))



          glocat  <- .glocat.mux * mu.init
          gscale  <- .gscale.mux * abs(mu.init)
          gshape  <- .gshape
          if (length( .ilocat )) glocat  <- rep_len( .ilocat , NOS)
          if (length( .iscale )) gscale  <- rep_len( .iscale , NOS)
          if (length( .ishape )) gshape  <- rep_len( .ishape , NOS)


          ll.pren74 <- function(scaleval, locn, shape,
                                x = x, y = y, w = w, extraargs) {
            ans <- sum(c(w) * dprentice74(x = y,
                                          scale  = scaleval,
                                          locat  = locn,
                                          shape  = shape,
                                          log = TRUE))
            ans
          }
        try.this <-
          grid.search3(gscale, glocat, gshape,
                       objfun = ll.pren74,
                       y = yvec, w = wvec,
                       ret.objfun = TRUE)  # Last value is the loglik

          sc.init[, spp.] <- try.this["Value1" ]
          lo.init[, spp.] <- try.this["Value2" ]
          sh.init[, spp.] <- try.this["Value3" ]


if (FALSE) {
        sdy <- sqrt(var(yvec))
        if (!length( .ishape )) {
          skewness <- mean((yvec - mean(yvec))^3) / sdy^3
          sh.init[, spp.] <- (-skewness)
        }
        if (!length( .iscale ))
          sc.init[, spp.] <- sdy
        if (!length( .ilocat ))
          lo.init[, spp.] <- median(yvec)
}
      }  # End of for (spp. ...)


      etastart <-
        cbind(theta2eta(lo.init, .llocat , earg = .elocat ),
              theta2eta(sc.init, .lscale , earg = .escale ),
              theta2eta(sh.init, .lshape , earg = .eshape ))
      etastart <- etastart[, interleave.VGAM(M, M1 = M1)]
    }
  }), list( .llocat = llocat, .lscale = lscale, .lshape = lshape,
            .elocat = elocat, .escale = escale, .eshape = eshape,
            .ilocat = ilocat, .iscale = iscale, .ishape = ishape,
            .imethod = imethod ,
            .glocat.mux = glocation.mux,
            .gscale.mux = gscale.mux,
            .gshape     = gshape,
            .probs.y = probs.y
           ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    eta2theta(eta[, c(TRUE, FALSE, FALSE)], .llocat , .elocat )
  }, list( .llocat = llocat, .lscale = lscale, .lshape = lshape,
           .elocat = elocat, .escale = escale, .eshape = eshape))),
  last = eval(substitute(expression({
    tmp34 <- c(rep_len( .llocat , NOS),
               rep_len( .lscale , NOS),
               rep_len( .lshape , NOS))
    names(tmp34) <- c(temp1.names, temp2.names, temp3.names)
    tmp34 <- tmp34[interleave.VGAM(M, M1 = M1)]
    misc$link <- tmp34  # Already named

    misc$earg <- vector("list", M)
    names(misc$earg) <- names(misc$link)
    for (ii in 1:NOS) {
      misc$earg[[M1*ii-2]] <- .elocat
      misc$earg[[M1*ii-1]] <- .escale
      misc$earg[[M1*ii  ]] <- .eshape
    }
  }), list( .llocat = llocat, .lscale = lscale, .lshape = lshape,
            .elocat = elocat, .escale = escale, .eshape = eshape))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    TF1 <- c(TRUE, FALSE, FALSE)
    TF2 <- c(FALSE, TRUE, FALSE)
    TF3 <- c(FALSE, FALSE, TRUE)
    a <- eta2theta(eta[, TF1], .llocat , earg = .elocat )
    b <- eta2theta(eta[, TF2], .lscale , earg = .escale )
    k <- eta2theta(eta[, TF3], .lshape , earg = .eshape )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
          c(w) * dprentice74(y, loc = a, scale = b, shape = k,
                             log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .llocat = llocat, .lscale = lscale, .lshape = lshape,
           .elocat = elocat, .escale = escale, .eshape = eshape))),
  vfamily = c("prentice74"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    TF1 <- c(TRUE, FALSE, FALSE)
    TF2 <- c(FALSE, TRUE, FALSE)
    TF3 <- c(FALSE, FALSE, TRUE)
    aa <- eta2theta(eta[, TF1], .llocat , earg = .elocat )
    bb <- eta2theta(eta[, TF2], .lscale , earg = .escale )
    kk <- eta2theta(eta[, TF3], .lshape , earg = .eshape )
    okay1 <- all(is.finite(kk)) &&
             all(is.finite(bb)) && all(0 < bb) &&
             all(is.finite(aa))
    okay1
  }, list( .llocat = llocat, .lscale = lscale, .lshape = lshape,
           .elocat = elocat, .escale = escale, .eshape = eshape))),




  deriv = eval(substitute(expression({
    TF1 <- c(TRUE, FALSE, FALSE)
    TF2 <- c(FALSE, TRUE, FALSE)
    TF3 <- c(FALSE, FALSE, TRUE)
    a <- eta2theta(eta[, TF1], .llocat , earg = .elocat )
    b <- eta2theta(eta[, TF2], .lscale , earg = .escale )
    k <- eta2theta(eta[, TF3], .lshape , earg = .eshape )

    tmp55 <- k^(-2)
    mustar <- digamma(tmp55)
    doubw <- (y-a)*k/b + mustar
    sigmastar2 <- trigamma(tmp55)

    dl.da <- k*(exp(doubw) - tmp55) / b
    dl.db <- ((doubw - mustar) * (exp(doubw) - tmp55) - 1) / b
    dl.dk <- 1/k - 2 * (doubw - mustar) / k^3 -
            (exp(doubw) - tmp55) *
            ((doubw - mustar) / k - 2 * sigmastar2 / k^3)

    da.deta <- dtheta.deta(a, .llocat , earg = .elocat )
    db.deta <- dtheta.deta(b, .lscale , earg = .escale )
    dk.deta <- dtheta.deta(k, .lshape , earg = .eshape )

    myderiv <-
    c(w) * cbind(dl.da * da.deta,
                 dl.db * db.deta,
                 dl.dk * dk.deta)
    myderiv[, interleave.VGAM(M, M1 = M1)]
  }), list( .llocat = llocat, .lscale = lscale, .lshape = lshape,
            .elocat = elocat, .escale = escale, .eshape = eshape))),
  weight = eval(substitute(expression({
    ned2l.da2 <- 1 / b^2
    ned2l.db2 <- (1 + sigmastar2 * tmp55) / b^2
    ned2l.dk2 <- tmp55 - 3 * sigmastar2 * tmp55^2 +
                 4 * sigmastar2 * tmp55^4 * (sigmastar2 - k^2)
    ned2l.dadb <- k / b^2
    ned2l.dadk <- (2*(sigmastar2*tmp55^2 - tmp55) - 1) / b
    ned2l.dbdk <- (sigmastar2*tmp55 - 1) / (b*k)

    wz <-
      array(c(c(w) * ned2l.da2 * da.deta^2,
              c(w) * ned2l.db2 * db.deta^2,
              c(w) * ned2l.dk2 * dk.deta^2,
              c(w) * ned2l.dadb * da.deta * db.deta,
              c(w) * ned2l.dbdk * db.deta * dk.deta,
              c(w) * ned2l.dadk * da.deta * dk.deta),
                  dim = c(n, M / M1, 6))

    wz <- arwz2wz(wz, M = M, M1 = M1)
    wz
  }),
  list( .llocat = llocat, .lscale = lscale, .lshape = lshape,
        .elocat = elocat, .escale = escale, .eshape = eshape))))
}  # prentice74






dgengamma.stacy <- function(x, scale = 1, d, k, log = FALSE) {
  if (!is.logical(log.arg <- log) || length(log) != 1)
    stop("bad input for argument 'log'")
  rm(log)

  if (!is.Numeric(d, positive = TRUE))
    stop("bad input for argument 'd'")
  if (!is.Numeric(k, positive = TRUE))
    stop("bad input for argument 'k'")




  N     <- max(length(x), length(scale), length(d), length(k))
  if (length(x)     != N) x     <- rep_len(x,     N)
  if (length(d)     != N) d     <- rep_len(d,     N)
  if (length(k)     != N) k     <- rep_len(k,     N)
  if (length(scale) != N) scale <- rep_len(scale, N)

  Loglik <- rep_len(log(0), N)
  xok <- x > 0
  if (any(xok)) {
    zedd <- (x[xok]/scale[xok])^(d[xok])
    Loglik[xok] <- log(d[xok]) +
                   (-d[xok] * k[xok]) * log(scale[xok]) +
                   (d[xok] * k[xok]-1) * log(x[xok]) - zedd -
                   lgamma(k[xok])
  }


  Loglik[is.infinite(x)] <- log(0)  # 20141208; KaiH.


  
  answer <- if (log.arg) {
    Loglik
  } else {
    exp(Loglik)
  }


  answer[scale <  0] <- NaN
  answer[scale == 0] <- NaN  # Not strictly correct
  if (any(scale <= 0))
    warning("NaNs produced")

  answer
}  # dgengamma.stacy



pgengamma.stacy <- function(q, scale = 1, d, k,
                            lower.tail = TRUE, log.p = FALSE) {
  zedd <- (q / scale)^d
  ans <- pgamma(zedd, k, lower.tail = lower.tail, log.p = log.p)
  ans[scale <  0] <- NaN
  ans[d     <= 0] <- NaN
  ans
}



qgengamma.stacy <- function(p, scale = 1, d, k,
                            lower.tail = TRUE, log.p = FALSE) {
  ans <- scale * qgamma(p, k, lower.tail = lower.tail,
                        log.p = log.p)^(1/d)
  ans[scale <  0] <- NaN
  ans[d     <= 0] <- NaN
  ans
}



rgengamma.stacy <- function(n, scale = 1, d, k) {

  ans <- scale * rgamma(n, k)^(1/d)
  ans[scale <  0] <- NaN
  ans[d     <= 0] <- NaN
  ans
}



 gengamma.stacy <-
  function(lscale = "loglink", ld = "loglink", lk = "loglink",
           iscale = NULL, id = NULL, ik = NULL,
           imethod = 1,
           gscale.mux = exp((-4:4)/2),
           gshape1.d = exp((-5:5)/2),
           gshape2.k = exp((-5:5)/2),
           probs.y = 0.3,
           zero = c("d", "k")
          ) {


  lscale <- as.list(substitute(lscale))
  escale <- link2list(lscale)
  lscale <- attr(escale, "function.name")

  ld <- as.list(substitute(ld))
  ed <- link2list(ld)
  ld <- attr(ed, "function.name")

  lk <- as.list(substitute(lk))
  ek <- link2list(lk)
  lk <- attr(ek, "function.name")


  if (!is.Numeric(imethod, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE) ||
     imethod > 3)
      stop("argument 'imethod' must be 1 or 2 or 3")

  if (length(iscale) &&
      !is.Numeric(iscale, positive = TRUE))
    stop("bad input for argument 'iscale'")




  new("vglmff",
  blurb = c("Generalized gamma distribution ",
      "f(y; b, d, k) = \n",
      "d * b^(-d*k) * y^(d*k-1) * exp(-(y/b)^d)",
      " / gamma(k),\n",
            "scale=b>0, 0<d, 0<k, 0<y\n\n",
            "Links:    ",
            namesof("scale", lscale, earg = escale), ", ",
            namesof("d",     ld,     earg = ed), ", ",
            namesof("k",     lk,     earg = ek), "\n",
            "Mean:     b * gamma(k+1/d) / gamma(k)", "\n"),
  constraints = eval(substitute(expression({
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 3,
                     predictors.names = predictors.names)
  }), list( .zero = zero ))),
  infos = eval(substitute(function(...) {
    list(M1 = 3,
         Q1 = 1,
         dpqrfun = "gengamma.stacy",
         expected = TRUE,
         multipleResponses = TRUE,
         parameters.names = c("scale", "d", "k"),
         imethod = .imethod ,
         iscale = .iscale ,
         zero = .zero )
  }, list( .zero = zero,
           .imethod = imethod,
           .iscale = iscale ))),

  initialize = eval(substitute(expression({
    M1 <- 3
    Q1 <- 1

    temp5 <-
    w.y.check(w = w, y = y,
              Is.positive.y = TRUE,
              ncol.w.max = Inf,
              ncol.y.max = Inf,
              out.wy = TRUE,
              colsyperw = 1,
              maximize = TRUE)
    w <- temp5$w
    y <- temp5$y


    NOS <- ncoly <- ncol(y)  # Number of species
    M <- M1 * ncoly


    temp1.names <- param.names("scale", NOS, skip1 = TRUE)
    temp2.names <- param.names("d",     NOS, skip1 = TRUE)
    temp3.names <- param.names("k",     NOS, skip1 = TRUE)
    predictors.names <-
        c(namesof(temp1.names, .lscale , .escale , tag = FALSE),
          namesof(temp2.names, .ld     , .ed     , tag = FALSE),
          namesof(temp3.names, .lk     , .ek     , tag = FALSE))
    predictors.names <- predictors.names[interleave.VGAM(M, M1 = M1)]










    if (!length(etastart)) {
      sc.init <-
      dd.init <-
      kk.init <- matrix(NA_real_, n, NOS)

      for (spp. in 1:NOS) {  # For each response 'y_spp.'... do:
        yvec <- y[, spp.]
        wvec <- w[, spp.]
        mu.init <- switch( .imethod ,
                          median(yvec),  # More reliable I think
                          weighted.mean(yvec, w = wvec),
                          quantile(yvec, prob = .probs.y ))
                                                

          gscale     <- .gscale.mux * mu.init
          gshape1.d  <- .gshape1.d
          gshape2.k  <- .gshape2.k
          if (length( .iscale )) gscale    <- rep_len( .iscale , NOS)
          if (length( .id     )) gshape1.d <- rep_len( .id     , NOS)
          if (length( .ik     )) gshape2.p <- rep_len( .ik     , NOS)


          ll.gstacy3 <- function(scaleval, shape1.d, shape2.k,
                                 x = x, y = y, w = w, extraargs) {
            ans <- sum(c(w) * dgengamma.stacy(x = y,
                                              scale    = scaleval,
                                              d        = shape1.d,
                                              k        = shape2.k,
                                              log = TRUE))
            ans
          }
        try.this <-
          grid.search3(gscale, gshape1.d, gshape2.k,
                       objfun = ll.gstacy3,
                       y = yvec, w = wvec,
                       ret.objfun = TRUE)  # Last value is the loglik

          sc.init[, spp.] <- try.this["Value1" ]
          dd.init[, spp.] <- try.this["Value2" ]
          kk.init[, spp.] <- try.this["Value3" ]
      }  # End of for (spp. ...)


      etastart <-
        cbind(theta2eta(sc.init,  .lscale , earg = .escale  ),
              theta2eta(dd.init , .ld     , earg = .ed      ),
              theta2eta(kk.init , .lk     , earg = .ek      ))
     etastart <- etastart[, interleave.VGAM(M, M1 = M1)]
    }  # End of etastart.
  }), list( .lscale = lscale, .ld = ld, .lk = lk,
            .escale = escale, .ed = ed, .ek = ek,
            .iscale = iscale, .id = id, .ik = ik,
            .imethod = imethod,
            .gscale.mux = gscale.mux,
            .gshape1.d  = gshape1.d,
            .gshape2.k  = gshape2.k,
            .probs.y   = probs.y
           ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    TF1 <- c(TRUE, FALSE, FALSE)
    TF2 <- c(FALSE, TRUE, FALSE)
    TF3 <- c(FALSE, FALSE, TRUE)
    b <- eta2theta(eta[, TF1], .lscale , earg = .escale )
    d <- eta2theta(eta[, TF2], .ld     , earg = .ed )
    k <- eta2theta(eta[, TF3], .lk     , earg = .ek )
    b * gamma(k + 1 / d) / gamma(k)
  }, list( .lscale = lscale, .lk = lk, .ld = ld,
           .escale = escale, .ek = ek, .ed = ed ))),
  last = eval(substitute(expression({
    tmp34 <- c(rep_len( .lscale , NOS),
               rep_len( .ld     , NOS),
               rep_len( .lk     , NOS))
    names(tmp34) <- c(temp1.names, temp2.names, temp3.names)
    tmp34 <- tmp34[interleave.VGAM(M, M1 = M1)]
    misc$link <- tmp34  # Already named

    misc$earg <- vector("list", M)
    names(misc$earg) <- names(misc$link)
    for (ii in 1:NOS) {
      misc$earg[[M1*ii-2]] <- .escale
      misc$earg[[M1*ii-1]] <- .ed
      misc$earg[[M1*ii  ]] <- .ek
    }
  }), list( .lscale = lscale, .ld = ld, .lk = lk,
            .escale = escale, .ed = ed, .ek = ek ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    TF1 <- c(TRUE, FALSE, FALSE)
    TF2 <- c(FALSE, TRUE, FALSE)
    TF3 <- c(FALSE, FALSE, TRUE)
    b <- eta2theta(eta[, TF1], .lscale , earg = .escale )
    d <- eta2theta(eta[, TF2], .ld     , earg = .ed )
    k <- eta2theta(eta[, TF3], .lk     , earg = .ek )

    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * dgengamma.stacy(x = y, scale = b, d = d, k = k,
                               log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .lscale = lscale, .ld = ld, .lk = lk,
           .escale = escale, .ed = ed, .ek = ek ))),
  vfamily = c("gengamma.stacy"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    TF1 <- c(TRUE, FALSE, FALSE)
    TF2 <- c(FALSE, TRUE, FALSE)
    TF3 <- c(FALSE, FALSE, TRUE)
    bb <- eta2theta(eta[, TF1], .lscale , earg = .escale )
    dd <- eta2theta(eta[, TF2], .ld     , earg = .ed )
    kk <- eta2theta(eta[, TF3], .lk     , earg = .ek )
    okay1 <- all(is.finite(kk)) && all(0 < kk) &&
             all(is.finite(bb)) && all(0 < bb) &&
             all(is.finite(dd)) && all(0 < dd)
    okay1
  }, list( .lscale = lscale, .ld = ld, .lk = lk,
           .escale = escale, .ed = ed, .ek = ek ))),




  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    TF1 <- c(TRUE, FALSE, FALSE)
    TF2 <- c(FALSE, TRUE, FALSE)
    TF3 <- c(FALSE, FALSE, TRUE)
    bb <- eta2theta(eta[, TF1], .lscale , earg = .escale )
    dd <- eta2theta(eta[, TF2], .ld     , earg = .ed )
    kk <- eta2theta(eta[, TF3], .lk     , earg = .ek )
    rgengamma.stacy(nsim * length(kk), scale = bb, d = dd, k = kk)
  }, list( .lscale = lscale, .ld = ld, .lk = lk,
           .escale = escale, .ed = ed, .ek = ek ))),





  deriv = eval(substitute(expression({
    TF1 <- c(TRUE, FALSE, FALSE)
    TF2 <- c(FALSE, TRUE, FALSE)
    TF3 <- c(FALSE, FALSE, TRUE)
    b <- eta2theta(eta[, TF1], .lscale , earg = .escale )
    d <- eta2theta(eta[, TF2], .ld     , earg = .ed )
    k <- eta2theta(eta[, TF3], .lk     , earg = .ek )

    tmp22 <- (y/b)^d
    tmp33 <- log(y/b)
    dl.db <- d * (tmp22 - k) / b
    dl.dd <- 1/d + tmp33 * (k - tmp22)
    dl.dk <- d * tmp33 - digamma(k)

    db.deta <- dtheta.deta(b, .lscale , earg = .escale )
    dd.deta <- dtheta.deta(d, .ld     , earg = .ed )
    dk.deta <- dtheta.deta(k, .lk     , earg = .ek )

    myderiv <-
    c(w) * cbind(dl.db * db.deta,
                 dl.dd * dd.deta,
                 dl.dk * dk.deta)
    myderiv[, interleave.VGAM(M, M1 = M1)]
  }), list( .lscale = lscale, .ld = ld, .lk = lk,
            .escale = escale, .ed = ed, .ek = ek ))),
  weight = eval(substitute(expression({
    ned2l.db2 <- k * (d/b)^2
    ned2l.dd2 <- (1 + k * (trigamma(k+1) + (digamma(k+1))^2)) / d^2
    ned2l.dk2 <- trigamma(k)
    ned2l.dbdd <- -(1 + k*digamma(k)) / b
    ned2l.dbdk <- d / b
    ned2l.dddk <- -digamma(k) / d

    wz <-
      array(c(c(w) * ned2l.db2 * db.deta^2,
              c(w) * ned2l.dd2 * dd.deta^2,
              c(w) * ned2l.dk2 * dk.deta^2,
              c(w) * ned2l.dbdd * db.deta * dd.deta,
              c(w) * ned2l.dddk * dd.deta * dk.deta,
              c(w) * ned2l.dbdk * db.deta * dk.deta),
                  dim = c(n, M / M1, 6))

    wz <- arwz2wz(wz, M = M, M1 = M1)
    wz
  }), list( .lscale = lscale, .ld = ld, .lk = lk,
            .escale = escale, .ed = ed, .ek = ek ))))
}  # gengamma.stacy






dlevy <- function(x, location = 0, scale = 1, log.arg = FALSE) {
  logdensity <- 0.5 * log(scale / (2*pi)) - 1.5 * log(x - location) -
                      0.5 * scale / (x - location)
  if (log.arg) logdensity else exp(logdensity)
}



plevy <- function(q, location = 0, scale = 1) {

  erfc(sqrt(scale * 0.5 / (q - location)))
}




qlevy <- function(p, location = 0, scale = 1) {

  location + 0.5 * scale / (erfc(p, inverse = TRUE))^2
}


rlevy <- function(n, location = 0, scale = 1)
  qlevy(runif(n), location = location, scale = scale)



 levy <-
  function(location = 0, lscale = "loglink",
           iscale = NULL) {











  delta.known <- is.Numeric(location)  # , length.arg = 1

  if (!delta.known)
    stop("argument 'location' must be specified")
  idelta <- NULL
  delta <- location  # Lazy to change variable names below


  link.gamma <- as.list(substitute(lscale))
  earg <- link2list(link.gamma)
  link.gamma <- attr(earg, "function.name")



  new("vglmff",
  blurb = c("Levy distribution f(y) = sqrt(scale/(2*pi)) * ",
            "(y-location)^(-3/2) * \n",
            "          exp(-scale / (2*(y-location ))),\n",
            "          location < y < Inf, scale > 0",
            if (delta.known) "Link:    " else "Links:   ",
            namesof("scale", link.gamma, earg = earg),
            if (! delta.known)
       c(", ", namesof("delta", "identitylink", earg = list())),
            "\n\n",
            "Mean:    NA",
            "\n"),


  rqresslot = eval(substitute(
    function(mu, y, w, eta, extra = NULL) {
      eta <- as.matrix(eta)
      mygamma <- eta2theta(eta[, 1], .link.gamma , earg = .earg )
      delta <- if ( .delta.known ) .delta else eta[, 2]
    scrambleseed <- runif(1)  # To scramble the seed
      qnorm(plevy(y, location = delta, scale = mygamma))
  }, list( .link.gamma = link.gamma, .earg = earg,
            .delta.known = delta.known,
            .delta = delta))),

  initialize = eval(substitute(expression({

    w.y.check(w = w, y = y,
              ncol.w.max = 1,
              ncol.y.max = 1)




    predictors.names <-
      c(namesof("scale", .link.gamma , .earg , tag = FALSE),
        if ( .delta.known) NULL else
        namesof("delta", "identitylink", list(), tag = FALSE))


    if (!length(etastart)) {
      delta.init <- if ( .delta.known) {
                     if (min(y, na.rm = TRUE) <= .delta )
                         stop("'location' must be < min(y)")
                     .delta
                   } else {
                     if (length( .idelta )) .idelta else
                         min(y,na.rm = TRUE) - 1.0e-4 *
                         diff(range(y,na.rm = TRUE))
                   }
      gamma.init <- if (length( .iscale )) .iscale else
        median(y - delta.init)  # = 1/median(1/(y-delta.init))
      gamma.init <- rep_len(gamma.init, length(y))
      etastart <-
        cbind(theta2eta(gamma.init, .link.gamma , earg = .earg ),
                        if ( .delta.known ) NULL else delta.init)

    }
  }), list( .link.gamma = link.gamma, .earg = earg,
            .delta.known = delta.known,
            .delta = delta,
            .idelta = idelta,
            .iscale = iscale ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    eta <- as.matrix(eta)
    mygamma <- eta2theta(eta[, 1], .link.gamma , earg = .earg )
    delta <- if ( .delta.known) .delta else eta[, 2]


    qlevy(p = 0.5, location = delta, scale = mygamma)
  }, list( .link.gamma = link.gamma, .earg = earg,
           .delta.known = delta.known,
           .delta = delta ))),
  last = eval(substitute(expression({
    misc$link <- if ( .delta.known )
                 NULL else c(delta = "identitylink")
    misc$link <- c(scale = .link.gamma , misc$link)
    misc$earg <- if ( .delta.known ) list(scale = .earg ) else
                list(scale = .earg , delta = list())
    if ( .delta.known)
      misc$delta <- .delta
  }), list( .link.gamma = link.gamma, .earg = earg,
            .delta.known = delta.known,
            .delta = delta ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    eta <- as.matrix(eta)
    mygamma <- eta2theta(eta[, 1], .link.gamma , earg = .earg )
    delta <- if ( .delta.known) .delta else eta[, 2]
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * dlevy(x = y, location = delta, scale = mygamma,
                     log.arg = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .link.gamma = link.gamma, .earg = earg,
           .delta.known = delta.known,
           .delta = delta ))),
  vfamily = c("levy"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    eta <- as.matrix(eta)
    mygamma <- eta2theta(eta[, 1], .link.gamma , earg = .earg )
    okay1 <- all(is.finite(mygamma)) && all(0 < mygamma)
    okay1
  }, list( .link.gamma = link.gamma, .earg = earg,
           .delta.known = delta.known,
           .delta = delta ))),

  deriv = eval(substitute(expression({
    eta <- as.matrix(eta)
    mygamma <- eta2theta(eta[, 1], .link.gamma , earg = .earg )
    delta <- if ( .delta.known ) .delta else eta[, 2]
    if (! .delta.known)
      dl.ddelta  <- (3 - mygamma / (y-delta)) / (2 * (y-delta))
    dl.dgamma <- 0.5 * (1 / mygamma - 1 / (y-delta))
    dgamma.deta <- dtheta.deta(mygamma, .link.gamma , .earg )
    c(w) * cbind(dl.dgamma * dgamma.deta,
                 if ( .delta.known ) NULL else dl.ddelta)
  }), list( .link.gamma = link.gamma, .earg = earg,
            .delta.known = delta.known,
            .delta = delta ))),
  weight = eval(substitute(expression({
    wz <- matrix(NA_real_, n, dimm(M))
    wz[, iam(1, 1, M)] <- 1 * dgamma.deta^2
    if (! .delta.known ) {
      wz[, iam(1, 2, M)] <-  3 * dgamma.deta
      wz[, iam(2, 2, M)] <-  21
    }
    wz <- c(w) * wz / (2 * mygamma^2)
    wz
  }), list( .link.gamma = link.gamma, .earg = earg,
           .delta.known = delta.known,
           .delta = delta ))))
}  # levy








dlino <- function(x, shape1, shape2, lambda = 1, log = FALSE) {
  if (!is.logical(log.arg <- log) || length(log) != 1)
    stop("bad input for argument 'log'")
  rm(log)

  loglik <-  dbeta(x = x, shape1 = shape1, shape2 = shape2,
                   log = TRUE) +
             shape1 * log(lambda) -
            (shape1+shape2) * log1p(-(1-lambda) * x)
  loglik[is.infinite(x)] <- log(0)  # 20141208 KaiH
  if (log.arg) loglik else exp(loglik)
}



plino <- function(q, shape1, shape2, lambda = 1,
                  lower.tail = TRUE, log.p = FALSE) {
  ans <- pbeta(1/(1+(1/q-1)/lambda),
               # lambda * q / (1 - (1-lambda) * q),
               shape1 = shape1, shape2 = shape2,
               lower.tail = lower.tail, log.p = log.p)
  ans[lambda <= 0] <- NaN
  ans
}



qlino <- function(p, shape1, shape2, lambda = 1,
                  lower.tail = TRUE, log.p = FALSE) {
  Y <- qbeta(p = p, shape1 = shape1, shape2 = shape2,
             lower.tail = lower.tail, log.p = log.p)
  ans <- Y / (lambda + (1-lambda)*Y)
  ans[lambda <= 0] <- NaN
  ans
}



rlino <- function(n, shape1, shape2, lambda = 1) {
  Y <- rbeta(n = n, shape1 = shape1, shape2 = shape2)
  ans <- Y / (lambda + (1 - lambda) * Y)
  ans[lambda <= 0] <- NaN
  ans
}



 lino <-
  function(lshape1 = "loglink",
           lshape2 = "loglink",
           llambda = "loglink",
           ishape1 = NULL, ishape2 = NULL, ilambda = 1,
           zero = NULL) {

  if (!is.Numeric(ilambda, positive = TRUE))
    stop("bad input for argument 'ilambda'")



  lshape1 <- as.list(substitute(lshape1))
  eshape1 <- link2list(lshape1)
  lshape1 <- attr(eshape1, "function.name")

  lshape2 <- as.list(substitute(lshape2))
  eshape2 <- link2list(lshape2)
  lshape2 <- attr(eshape2, "function.name")

  llambda <- as.list(substitute(llambda))
  elambda <- link2list(llambda)
  llambda <- attr(elambda, "function.name")


  new("vglmff",
      blurb = c("Generalized Beta distribution ",
            "(Libby and Novick, 1982)\n\n",
            "Links:    ",
            namesof("shape1", lshape1, earg = eshape1), ", ",
            namesof("shape2", lshape2, earg = eshape2), ", ",
            namesof("lambda", llambda, earg = elambda), "\n",
            "Mean:     something complicated"),
  constraints = eval(substitute(expression({
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 3,
                     predictors.names = predictors.names)
  }), list( .zero = zero ))),


  rqresslot = eval(substitute(
    function(mu, y, w, eta, extra = NULL) {
      shape1 <- eta2theta(eta[, 1], .lshape1 , earg = .eshape1 )
      shape2 <- eta2theta(eta[, 2], .lshape2 , earg = .eshape2 )
      lambda <- eta2theta(eta[, 3], .llambda , earg = .elambda )
    scrambleseed <- runif(1)  # To scramble the seed
      qnorm(plino(y, shape1, shape2, lambda = lambda))
    }, 
  list( .lshape1 = lshape1, .lshape2 = lshape2, .llambda = llambda,
        .eshape1 = eshape1, .eshape2 = eshape2, .elambda = elambda
       ))),

  initialize = eval(substitute(expression({
    if (min(y) <= 0 || max(y) >= 1)
      stop("values of the response must be between 0 and 1 (0,1)")

    w.y.check(w = w, y = y,
              Is.positive.y = TRUE,
              ncol.w.max = 1,
              ncol.y.max = 1)




    predictors.names <-
      c(namesof("shape1", .lshape1 , earg = .eshape1 , tag = FALSE),
        namesof("shape2", .lshape2 , earg = .eshape2 , tag = FALSE),
        namesof("lambda", .llambda , earg = .elambda , tag = FALSE))




    if (!length(etastart)) {
      lambda.init <- rep_len(if (length( .ilambda ))
                             .ilambda else 1, n)
      sh1.init <- if (length( .ishape1 ))
                      rep_len( .ishape1 , n) else NULL
      sh2.init <- if (length( .ishape2 ))
                      rep_len( .ishape2 , n) else NULL
      txY.init <- lambda.init * y / (1+lambda.init*y - y)
      mean1 <- mean(txY.init)
      mean2 <- mean(1/txY.init)
      if (!is.Numeric(sh1.init))
        sh1.init <- rep_len((mean2 - 1) / (mean2 - 1/mean1), n)
      if (!is.Numeric(sh2.init))
        sh2.init <- rep_len(sh1.init * (1-mean1) / mean1, n)
      etastart <-
        cbind(theta2eta(sh1.init, .lshape1 , earg = .eshape1),
              theta2eta(sh2.init, .lshape2 , earg = .eshape2),
              theta2eta(lambda.init, .llambda , earg = .elambda ))
    }
  }),
list( .lshape1 = lshape1, .lshape2 = lshape2, .llambda = llambda,
      .eshape1 = eshape1, .eshape2 = eshape2, .elambda = elambda,
      .ishape1 = ishape1, .ishape2 = ishape2, .ilambda = ilambda
     ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    shape1 <- eta2theta(eta[, 1], .lshape1 , earg = .eshape1 )
    shape2 <- eta2theta(eta[, 2], .lshape2 , earg = .eshape2 )
    lambda <- eta2theta(eta[, 3], .llambda , earg = .elambda )


    qlino(0.5, shape1 = shape1, shape2 = shape2, lambda = lambda)
  },
  list( .lshape1 = lshape1, .lshape2 = lshape2, .llambda = llambda,
        .eshape1 = eshape1, .eshape2 = eshape2, .elambda = elambda
       ))),
  last = eval(substitute(expression({
    misc$link <-    c(shape1 = .lshape1 , shape2 = .lshape2 ,
                      lambda = .llambda )
    misc$earg <- list(shape1 = .eshape1 , shape2 = .eshape2 ,
                      lambda = .elambda )
  }),
  list( .lshape1 = lshape1, .lshape2 = lshape2, .llambda = llambda,
        .eshape1 = eshape1, .eshape2 = eshape2, .elambda = elambda
       ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    shape1 <- eta2theta(eta[, 1], .lshape1 , earg = .eshape1 )
    shape2 <- eta2theta(eta[, 2], .lshape2 , earg = .eshape2 )
    lambda <- eta2theta(eta[, 3], .llambda , earg = .elambda )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * dlino(y, shape1 = shape1, shape2 = shape2,
                     lambda = lambda, log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
    },
list( .lshape1 = lshape1, .lshape2 = lshape2, .llambda = llambda,
      .eshape1 = eshape1, .eshape2 = eshape2, .elambda = elambda
     ))),
  vfamily = c("lino"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    shape1 <- eta2theta(eta[, 1], .lshape1 , earg = .eshape1 )
    shape2 <- eta2theta(eta[, 2], .lshape2 , earg = .eshape2 )
    lambda <- eta2theta(eta[, 3], .llambda , earg = .elambda )
    okay1 <- all(is.finite(shape1)) && all(0 < shape1) &&
             all(is.finite(shape2)) && all(0 < shape2) &&
             all(is.finite(lambda)) && all(0 < lambda)
    okay1
  },
  list( .lshape1 = lshape1, .lshape2 = lshape2, .llambda = llambda,
        .eshape1 = eshape1, .eshape2 = eshape2, .elambda = elambda
       ))),


  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    shape1 <- eta2theta(eta[, 1], .lshape1 , earg = .eshape1 )
    shape2 <- eta2theta(eta[, 2], .lshape2 , earg = .eshape2 )
    lambda <- eta2theta(eta[, 3], .llambda , earg = .elambda )
    rlino(nsim * length(shape1),
          shape1 = shape1, shape2 = shape2, lambda = lambda)
  },
  list( .lshape1 = lshape1, .lshape2 = lshape2, .llambda = llambda,
        .eshape1 = eshape1, .eshape2 = eshape2, .elambda = elambda
       ))),




  deriv = eval(substitute(expression({
    sh1 <- eta2theta(eta[, 1], .lshape1 , earg = .eshape1 )
    sh2 <- eta2theta(eta[, 2], .lshape2 , earg = .eshape2 )
    lambda <- eta2theta(eta[, 3], .llambda , earg = .elambda )

    temp1 <- log1p(-(1-lambda) * y)
    temp2 <- digamma(sh1+sh2)

    dl.dsh1 <- log(lambda) + log(y) - digamma(sh1) + temp2 - temp1
    dl.dsh2 <- log1p(-y) - digamma(sh2) + temp2 - temp1
    dl.dlambda <- sh1/lambda - (sh1+sh2) * y / (1 - (1-lambda) * y)

    dsh1.deta <- dtheta.deta(sh1, .lshape1 , earg = .eshape1)
    dsh2.deta <- dtheta.deta(sh2, .lshape2 , earg = .eshape2)
    dlambda.deta <- dtheta.deta(lambda, .llambda , earg = .elambda )

    c(w) * cbind( dl.dsh1    * dsh1.deta,
                  dl.dsh2    * dsh2.deta,
                  dl.dlambda * dlambda.deta)
  }),
  list( .lshape1 = lshape1, .lshape2 = lshape2, .llambda = llambda,
        .eshape1 = eshape1, .eshape2 = eshape2, .elambda = elambda
       ))),
  weight = eval(substitute(expression({
    temp3 <- trigamma(sh1+sh2)

    ned2l.dsh1 <- trigamma(sh1) - temp3
    ned2l.dsh2 <- trigamma(sh2) - temp3
    ned2l.dlambda2 <- sh1 * sh2 / (lambda^2 * (sh1+sh2+1))
    ned2l.dsh1sh2 <- -temp3
    ned2l.dsh1lambda <- -sh2 / ((sh1+sh2)*lambda)
    ned2l.dsh2lambda <-  sh1 / ((sh1+sh2)*lambda)

    wz <- matrix(NA_real_, n, dimm(M))  #M==3 means 6=dimm(M)
    wz[, iam(1, 1, M)] <- ned2l.dsh1 * dsh1.deta^2
    wz[, iam(2, 2, M)] <- ned2l.dsh2 * dsh2.deta^2
    wz[, iam(3, 3, M)] <- ned2l.dlambda2 * dlambda.deta^2
    wz[, iam(1, 2, M)] <- ned2l.dsh1sh2 * dsh1.deta * dsh2.deta
    wz[, iam(1, 3, M)] <- ned2l.dsh1lambda*dsh1.deta*dlambda.deta
    wz[, iam(2, 3, M)] <- ned2l.dsh2lambda*dsh2.deta*dlambda.deta
    wz <- c(w) * wz
    wz
  }),
  list( .lshape1 = lshape1, .lshape2 = lshape2, .llambda = llambda,
        .eshape1 = eshape1, .eshape2 = eshape2, .elambda = elambda
       ))))
}  # lino





dmaxwell <- function(x, rate, log = FALSE) {
  if (!is.logical(log.arg <- log) || length(log) != 1)
    stop("bad input for argument 'log'")
  rm(log)

  L <- max(length(x), length(rate))
  if (length(x)    != L) x    <- rep_len(x,    L)
  if (length(rate) != L) rate <- rep_len(rate, L)
  logdensity <- rep_len(log(0), L)
  xok <- (x >= 0)
  logdensity[xok] <- 0.5 * log(2/pi) + 1.5 * log(rate[xok]) +
                     2 * log(x[xok]) - 0.5 * rate[xok] * x[xok]^2
  logdensity[rate <= 0] <- NaN
  logdensity[x == Inf] <- log(0)
  if (log.arg) logdensity else exp(logdensity)
}



pmaxwell <- function(q, rate, lower.tail = TRUE, log.p = FALSE) {
  if (!is.logical(lower.tail) || length(lower.tail ) != 1)
    stop("bad input for argument 'lower.tail'")

  if (!is.logical(log.p) || length(log.p) != 1)
    stop("bad input for argument 'log.p'")


  if (lower.tail) {
    if (log.p) {
      ans <- log(erf(q*sqrt(rate/2)) -
                 q*exp(-0.5*rate*q^2) * sqrt(2*rate/pi))
      ans[q <= 0 ] <- -Inf
      ans[q == Inf] <- 0
    } else {
      ans <- erf(q*sqrt(rate/2)) -
                 q*exp(-0.5*rate*q^2) * sqrt(2*rate/pi)
      ans[q <= 0] <- 0
      ans[q == Inf] <- 1
    }
  } else {
    if (log.p) {
      ans <- log1p(-erf(q*sqrt(rate/2)) +
                   q*exp(-0.5*rate*q^2) * sqrt(2*rate/pi))
      ans[q <= 0] <- 0
      ans[q == Inf] <- -Inf
    } else {
      ans <- exp(log1p(-erf(q*sqrt(rate/2)) +
                       q*exp(-0.5*rate*q^2) * sqrt(2*rate/pi)))
      ans[q <= 0] <- 1
      ans[q == Inf] <- 0
    }
  }
  ans
}  # pmaxwell



qmaxwell <- function(p, rate, lower.tail = TRUE, log.p = FALSE) {

  sqrt(2 * qgamma(p = p, 1.5, lower.tail = lower.tail,
                  log.p = log.p) / rate)
}  # qmaxwell



rmaxwell <- function(n, rate) {

  sqrt(2 * rgamma(n = n, 1.5) / rate)
}  # rmaxwell



 maxwell <-
  function(link = "loglink", zero = NULL,
           parallel = FALSE,
    type.fitted = c("mean", "percentiles", "Qlink"),
    percentiles = 50) {

  type.fitted <- match.arg(type.fitted,
                           c("mean", "percentiles", "Qlink"))[1]

  link <- as.list(substitute(link))  # orig
  earg <- link2list(link)
  link <- attr(earg, "function.name")

      




  new("vglmff",
  blurb = c("Maxwell distribution \n",
            "f(y; rate) = sqrt(2/pi) * rate^(3/2) * y^2 *",
            " exp(-0.5*rate*y^2), y>0, rate>0\n",
            "Link:    ",
            namesof("rate", link, earg = earg),
            "\n", "\n",
            "Mean:    sqrt(8 / (rate * pi))"),
  constraints = eval(substitute(expression({
    constraints <- cm.VGAM(matrix(1, M, 1), x = x,
                           bool = .parallel ,
                           constraints, apply.int = FALSE)
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 1,
                     predictors.names = predictors.names)
  }), list( .parallel = parallel, .zero = zero ))),

  infos = eval(substitute(function(...) {
    list(M1 = 1,
         Q1 = 1,
         dpqrfun = "maxwell",
         parallel = .parallel ,
         percentiles = .percentiles ,
         type.fitted = .type.fitted ,
         zero = .zero )
  }, list( .parallel = parallel,
           .percentiles = percentiles ,
           .type.fitted = type.fitted,
           .zero = zero ))),


  initialize = eval(substitute(expression({

    temp5 <-
    w.y.check(w = w, y = y,
              Is.positive.y = TRUE,
              ncol.w.max = Inf,
              ncol.y.max = Inf,
              out.wy = TRUE,
              colsyperw = 1,
              maximize = TRUE)
    w <- temp5$w
    y <- temp5$y


    ncoly <- ncol(y)
    M1 <- 1
    M <- M1 * ncoly
    extra$ncoly <- ncoly
    extra$type.fitted <- .type.fitted
    extra$colnames.y  <- colnames(y)
    extra$percentiles <- .percentiles
    extra$M1 <- M1



    if ((NOS <- M / M1) > 1 && length( .percentiles ) > 1)
      stop("can only have one response when 'percentiles' is a ",
           "vector longer than unity")



    mynames1  <- param.names("rate", ncoly, skip1 = TRUE)
    predictors.names <- namesof(mynames1, .link , earg = .earg ,
                                tag = FALSE)


    if (!length(etastart)) {
      a.init <- 8 / (pi * (y + 0.1)^2)
      etastart <- theta2eta(a.init, .link , earg = .earg )
    }
  }), list( .link = link,
            .percentiles = percentiles,
            .type.fitted = type.fitted,
            .earg = earg ))),


  linkinv = eval(substitute(function(eta, extra = NULL) {
    type.fitted <-
      if (length(extra$type.fitted)) {
        extra$type.fitted
      } else {
        warning("cannot find 'type.fitted'. Returning the 'mean'.")
        "mean"
      }
    type.fitted <- match.arg(type.fitted,
                             c("mean", "percentiles", "Qlink"))[1]

    if (type.fitted == "Qlink") {
      eta2theta(eta, link = "loglink")
    } else {
      aa <- eta2theta(eta, .link , earg = .earg )
      pcent <- extra$percentiles
      perc.mat <- matrix(pcent, NROW(eta), length(pcent),
                         byrow = TRUE) / 100
      fv <-
        switch(type.fitted,
               "mean" = sqrt(8 / (aa * pi)),
               "percentiles" = qmaxwell(perc.mat,
                         rate = matrix(aa, nrow(perc.mat),
                                       ncol(perc.mat))))
      if (type.fitted == "percentiles")
        fv <- label.cols.y(fv, colnames.y = extra$colnames.y,
                           NOS = NCOL(eta), percentiles = pcent,
                           one.on.one = FALSE)
      fv
    }
  }, list( .link = link,
           .earg = earg ))),
  last = eval(substitute(expression({
    M1 <- extra$M1

    misc$earg <- vector("list", M)
    names(misc$earg) <- mynames1
    for (ilocal in 1:ncoly) {
      misc$earg[[ilocal]] <- .earg
    }

    misc$link <- rep_len( .link , ncoly)
    names(misc$link) <- mynames1

    misc$M1 <- M1
    misc$expected <- TRUE
    misc$multipleResponses <- TRUE
  }), list( .link = link, .earg = earg ))),

  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    aa <- eta2theta(eta, .link , earg = .earg )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <- c(w) * dmaxwell(x = y, rate = aa, log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .link = link, .earg = earg ))),
  vfamily = c("maxwell"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    shape <- eta2theta(eta, .link , earg = .earg )
    okay1 <- all(is.finite(shape)) && all(0 < shape)
    okay1
  }, list( .link = link, .earg = earg ))),




  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    aa <- eta2theta(eta, .link , earg = .earg )
    rmaxwell(nsim * length(aa), a = c(aa))
  }, list( .link = link,
           .earg = earg ))),




  deriv = eval(substitute(expression({
    aa <- eta2theta(eta, .link , earg = .earg )

    dl.da <- 1.5 / aa - 0.5 * y^2

    da.deta <- dtheta.deta(aa, .link , earg = .earg )

    c(w) * dl.da * da.deta
  }), list( .link = link, .earg = earg ))),
  weight = eval(substitute(expression({
    ned2l.da2 <- 1.5 / aa^2
    wz <- c(w) * ned2l.da2 * da.deta^2
    wz
  }), list( .link = link, .earg = earg ))))
}  # maxwell







dnaka <- function(x, scale = 1, shape, log = FALSE) {
  if (!is.logical(log.arg <- log) || length(log) != 1)
    stop("bad input for argument 'log'")
  rm(log)

  L <- max(length(x), length(shape), length(scale))
  if (length(x)     != L) x     <- rep_len(x,     L)
  if (length(shape) != L) shape <- rep_len(shape, L)
  if (length(scale) != L) scale <- rep_len(scale, L)

  logdensity <- rep_len(log(0), L)
  xok <- (x > 0)
  logdensity[xok] <- log(2) + log(x[xok]) +
    dgamma(x[xok]^2, shape = shape[xok],
           scale = scale[xok] / shape[xok], log = TRUE)
  logdensity[is.infinite(x)] <- log(0)  # 20141208 KaiH

  if (log.arg) logdensity else exp(logdensity)
}



pnaka <-
  function(q, scale = 1, shape, lower.tail = TRUE, log.p = FALSE) {

  ans <- pgamma(shape * q^2 / scale, shape = shape,
                lower.tail = lower.tail, log.p = log.p)
  ans[scale <  0] <- NaN
  ans
}



qnaka <- function(p, scale = 1, shape, ...) {
  if (!is.Numeric(p, positive = TRUE) || max(p) >= 1)
    stop("bad input for argument 'p'")
  if (!is.Numeric(shape, positive = TRUE))
    stop("bad input for argument 'shape'")
  if (!is.Numeric(scale, positive = TRUE))
    stop("bad input for argument 'scale'")

  L <- max(length(p), length(shape), length(scale))
  if (length(p)     != L) p     <- rep_len(p,     L)
  if (length(shape) != L) shape <- rep_len(shape, L)
  if (length(scale) != L) scale <- rep_len(scale, L)
  ans   <- rep_len(0.0,   L)

  myfun <- function(x, shape, scale = 1, p)
    pnaka(q = x, shape = shape, scale = scale) - p
  for (ii in 1:L) {
    EY <- sqrt(scale[ii]/shape[ii]) *
          gamma(shape[ii] + 0.5) / gamma(shape[ii])
    Upper <- 5 * EY
    while (pnaka(q = Upper, shape = shape[ii],
                            scale = scale[ii]) < p[ii])
      Upper <- Upper + scale[ii]
    ans[ii] <- uniroot(f = myfun, lower = 0, upper = Upper,
                       shape = shape[ii], scale = scale[ii],
                       p = p[ii], ...)$root
  }
  ans
}  # qnaka


rnaka <- function(n, scale = 1, shape, Smallno = 1.0e-6) {

  use.n <- if ((length.n <- length(n)) > 1) length.n else
           if (!is.Numeric(n, integer.valued = TRUE,
                           length.arg = 1, positive = TRUE))
              stop("bad input for argument 'n'") else n

  if (!is.Numeric(scale, positive = TRUE, length.arg = 1))
    stop("bad input for argument 'scale'")
  if (!is.Numeric(shape, positive = TRUE, length.arg = 1))
    stop("bad input for argument 'shape'")
  if (!is.Numeric(Smallno, positive = TRUE, length.arg = 1) ||
      Smallno > 0.01 ||
      Smallno < 2 * .Machine$double.eps)
    stop("bad input for argument 'Smallno'")
  ans <- rep_len(0.0, use.n)

  ptr1 <- 1
  ptr2 <- 0
  ymax <- dnaka(x = sqrt(scale * (1 - 0.5 / shape)),
                shape = shape, scale = scale)
  while (ptr2 < use.n) {
    EY <- sqrt(scale / shape) * gamma(shape + 0.5) / gamma(shape)
    Upper <- EY + 5 * scale
    while (pnaka(q = Upper, shape = shape, scale = scale) <
           1 - Smallno)
      Upper <- Upper + scale
    x <- runif(2*use.n, min = 0, max = Upper)
    index <- runif(2*use.n, max = ymax) < dnaka(x, shape = shape,
                                                   scale = scale)
    sindex <- sum(index)
    if (sindex) {
      ptr2 <- min(use.n, ptr1 + sindex - 1)
      ans[ptr1:ptr2] <- (x[index])[1:(1+ptr2-ptr1)]
      ptr1 <- ptr2 + 1
    }
  }
  ans
}  # rnaka






 nakagami <-
  function(lscale = "loglink", lshape = "loglink",
           iscale = 1, ishape = NULL, nowarning = FALSE,
           zero = "shape") {

  if (!is.null(iscale) && !is.Numeric(iscale, positive = TRUE))
    stop("argument 'iscale' must be a positive number or NULL")


  lshape <- as.list(substitute(lshape))
  eshape <- link2list(lshape)
  lshape <- attr(eshape, "function.name")

  lscale <- as.list(substitute(lscale))
  escale <- link2list(lscale)
  lscale <- attr(escale, "function.name")



  new("vglmff",
  blurb = c("Nakagami distribution f(y) = ",
            "2 * (shape/scale)^shape *\n",
            "                             ",
            "y^(2*shape-1) * ",
            "exp(-shape*y^2/scale) / gamma(shape),\n",
            "                             ",
            "y>0, shape>0, scale>0\n",
            "Links:    ",
            namesof("scale", lscale, earg = escale), ", ",
            namesof("shape", lshape, earg = eshape),
            "\n", "\n",
        "Mean:    sqrt(scale/shape) * ",
        "gamma(shape+0.5) / gamma(shape)"),

  constraints = eval(substitute(expression({
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 2,
                     predictors.names = predictors.names)
  }), list( .zero = zero ))),

  infos = eval(substitute(function(...) {
    list(M1 = 2,
         Q1 = 1,
         dpqrfun = "nakagami",
         expected = TRUE,
         lscale = .lscale ,
         lshape = .lshape ,
         multipleResponses = FALSE,
         parameters.names = c("scale", "shape"),
         zero = .zero )
  }, list( .lscale = lscale, .zero = zero,
           .lshape = lshape ))),

  rqresslot = eval(substitute(
    function(mu, y, w, eta, extra = NULL) {
      Scale <- eta2theta(eta[, 1], .lscale , earg = .escale )
      Shape <- eta2theta(eta[, 2], .lshape , earg = .eshape )
    scrambleseed <- runif(1)  # To scramble the seed
      qnorm(pnakagami(y, scale = Scale, shape = Shape))
  }, list( .lscale = lscale, .lshape = lshape,
           .escale = escale, .eshape = eshape))),

  initialize = eval(substitute(expression({

    w.y.check(w = w, y = y,
              ncol.w.max = 1,
              ncol.y.max = 1)



    predictors.names <-
      c(namesof("scale", .lscale , earg = .escale , tag = FALSE),
        namesof("shape", .lshape , earg = .eshape , tag = FALSE))


    if (!length(etastart)) {
      init2 <- if (is.Numeric( .iscale , positive = TRUE))
                  rep_len( .iscale , n) else rep_len(1, n)
      init1 <- if (is.Numeric( .ishape, positive = TRUE))
               rep_len( .ishape , n) else
               rep_len(init2 / (y + 1 / 8)^2, n)
      etastart <-
        cbind(theta2eta(init2, .lscale , earg = .escale ),
              theta2eta(init1, .lshape , earg = .eshape ))
    }
  }), list( .lscale = lscale, .lshape = lshape,
            .escale = escale, .eshape = eshape,
            .ishape = ishape, .iscale = iscale ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    scale <- eta2theta(eta[, 1], .lscale , earg = .escale )
    shape <- eta2theta(eta[, 2], .lshape , earg = .eshape )
    sqrt(scale/shape) * gamma(shape+0.5) / gamma(shape)
  }, list( .lscale = lscale, .lshape = lshape,
           .escale = escale, .eshape = eshape))),
  last = eval(substitute(expression({
    misc$link <-    c(scale = .lscale , shape = .lshape )
    misc$earg <- list(scale = .escale , shape = .eshape )
    misc$expected = TRUE
  }), list( .lscale = lscale, .lshape = lshape,
            .escale = escale, .eshape = eshape))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    scale <- eta2theta(eta[, 1], .lscale , earg = .escale )
    shape <- eta2theta(eta[, 2], .lshape , earg = .eshape )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * dnaka(y, sh = shape, sc = scale, log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .lscale = lscale, .lshape = lshape,
           .escale = escale, .eshape = eshape))),
  vfamily = c("nakagami"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    Scale <- eta2theta(eta[, 1], .lscale , earg = .escale )
    shape <- eta2theta(eta[, 2], .lshape , earg = .eshape )
    okay1 <- all(is.finite(Scale)) && all(0 < Scale) &&
             all(is.finite(shape)) && all(0 < shape)
    okay1
  }, list( .lscale = lscale, .lshape = lshape,
           .escale = escale, .eshape = eshape))),









  deriv = eval(substitute(expression({
    Scale <- eta2theta(eta[, 1], .lscale , earg = .escale )
    shape <- eta2theta(eta[, 2], .lshape , earg = .eshape )

    dl.dshape <- 1 + log(shape/Scale) - digamma(shape) +
                2 * log(y) - y^2 / Scale
    dl.dscale <- -shape/Scale + shape * (y/Scale)^2
    dshape.deta <- dtheta.deta(shape, .lshape , earg = .eshape )
    dscale.deta <- dtheta.deta(Scale, .lscale , earg = .escale )
    c(w) * cbind(dl.dscale * dscale.deta,
                 dl.dshape * dshape.deta)
  }), list( .lscale = lscale, .lshape = lshape,
            .escale = escale, .eshape = eshape))),
  weight = eval(substitute(expression({
    d2l.dshape2 <- trigamma(shape) - 1/shape
    d2l.dscale2 <- shape / Scale^2
    wz <- matrix(NA_real_, n, M)  # diagonal
    wz[, iam(1, 1, M)] <- d2l.dscale2 * dscale.deta^2
    wz[, iam(2, 2, M)] <- d2l.dshape2 * dshape.deta^2
    c(w) * wz
  }), list( .lscale = lscale, .lshape = lshape,
            .escale = escale, .eshape = eshape))))
}  # nakagami






drayleigh <- function(x, scale = 1, log = FALSE) {
  if (!is.logical(log.arg <- log) || length(log) != 1)
    stop("bad input for argument 'log'")
  rm(log)

  L     <- max(length(x), length(scale))
  if (length(x)     != L) x     <- rep_len(x,     L)
  if (length(scale) != L) scale <- rep_len(scale, L)

  logdensity <- rep_len(log(0), L)
  xok <- (x > 0)
  logdensity[xok] <- log(x[xok]) - 0.5 * (x[xok]/scale[xok])^2 -
                     2 * log(scale[xok])
  logdensity[is.infinite(x)] <- log(0)  # 20141208 KaiH
  if (log.arg) logdensity else exp(logdensity)
}



 prayleigh <-
  function(q, scale = 1, lower.tail = TRUE, log.p = FALSE) {
  if (!is.logical(lower.tail) || length(lower.tail ) != 1)
    stop("bad input for argument 'lower.tail'")

  if (!is.logical(log.p) || length(log.p) != 1)
    stop("bad input for argument 'log.p'")


  if (lower.tail) {
    if (log.p) {
      ans <- log(-expm1(-0.5 * (q / scale)^2))
      ans[q <= 0 ] <- -Inf
    } else {
      ans <- -expm1(-0.5 * (q / scale)^2)
      ans[q <= 0] <- 0
    }
  } else {
      if (log.p) {
        ans <- -0.5 * (q / scale)^2
        ans[q <= 0] <- 0
      } else {
        ans <- exp(-0.5 * (q / scale)^2)
        ans[q <= 0] <- 1
      }
    }
  ans[scale <  0] <- NaN
  ans
}  # prayleigh



 qrayleigh <- function(p, scale = 1,
                       lower.tail = TRUE, log.p = FALSE) {

  if (!is.logical(lower.tail) || length(lower.tail ) != 1)
    stop("bad input for argument 'lower.tail'")

  if (!is.logical(log.p) || length(log.p) != 1)
    stop("bad input for argument 'log.p'")

  if (lower.tail) {
    if (log.p) {
      ln.p <- p
      ans <- scale * sqrt(-2 * log(-expm1(ln.p)))
      ans[ln.p > 0] <- NaN
    } else {
      ans <- scale * sqrt(-2 * log1p(-p))
      ans[p < 0] <- NaN
      ans[p == 0] <- 0
      ans[p == 1] <- Inf
    }
  } else {
    if (log.p) {
      ln.p <- p
      ans <- scale * sqrt(-2 * ln.p)
      ans[ln.p > 0] <- NaN
      ans
    } else {
      ans <- scale * sqrt(-2 * log(p))
      ans[p > 1] <- NaN
    }
  }
  ans[scale <= 0] <- NaN
  ans
}  # qrayleigh



 rrayleigh <- function(n, scale = 1) {
  ans <- scale * sqrt(-2 * log(runif(n)))
  ans[scale <= 0] <- NaN
  ans
}



 rayleigh <-
  function(lscale = "loglink",
           nrfs = 1 / 3 + 0.01,
           oim.mean = TRUE, zero = NULL,
           parallel = FALSE,
           type.fitted = c("mean", "percentiles", "Qlink"),
           percentiles = 50) {

  type.fitted <- match.arg(type.fitted,
                           c("mean", "percentiles", "Qlink"))[1]

  lscale <- as.list(substitute(lscale))
  escale <- link2list(lscale)
  lscale <- attr(escale, "function.name")


  if (!is.Numeric(nrfs, length.arg = 1) ||
      nrfs < 0 ||
      nrfs > 1)
    stop("bad input for 'nrfs'")

  if (!is.logical(oim.mean) || length(oim.mean) != 1)
    stop("bad input for argument 'oim.mean'")





  new("vglmff",
  blurb = c("Rayleigh distribution\n\n",
            "f(y) = y*exp(-0.5*(y/scale)^2)/scale^2, ",
            "y>0, scale>0\n\n",
            "Link:    ",
            namesof("scale", lscale, earg = escale), "\n\n",
            "Mean:    scale * sqrt(pi / 2)"),
  constraints = eval(substitute(expression({
    constraints <- cm.VGAM(matrix(1, M, 1), x = x,
                           bool = .parallel ,
                           constraints, apply.int = FALSE)
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 1,
                     predictors.names = predictors.names)
  }), list( .parallel = parallel,
            .zero = zero ))),

  infos = eval(substitute(function(...) {
    list(M1 = 1,
         Q1 = 1,
         dpqrfun = "rayleigh",
         expected = TRUE,
         multipleResponses = TRUE,
         parallel = .parallel ,
         parameters.names = c("scale"),
         percentiles = .percentiles ,
         type.fitted = .type.fitted ,
         zero = .zero )
  }, list( .parallel = parallel,
           .percentiles = percentiles ,
           .type.fitted = type.fitted,
           .zero = zero ))),

  rqresslot = eval(substitute(
    function(mu, y, w, eta, extra = NULL) {
      Scale <- eta2theta(eta, .lscale , earg = .escale )
    scrambleseed <- runif(1)  # To scramble the seed
      qnorm(prayleigh(y, scale = Scale))
  }, list( .lscale = lscale, .escale = escale ))),


  initialize = eval(substitute(expression({

    temp5 <-
    w.y.check(w = w, y = y,
              Is.positive.y = TRUE,
              ncol.w.max = Inf,
              ncol.y.max = Inf,
              out.wy = TRUE,
              colsyperw = 1,
              maximize = TRUE)
    w <- temp5$w
    y <- temp5$y


    ncoly <- ncol(y)
    M1 <- 1
    M <- M1 * ncoly
    extra$ncoly <- ncoly
    extra$type.fitted <- .type.fitted
    extra$colnames.y  <- colnames(y)
    extra$percentiles <- .percentiles
    extra$M1 <- M1


    if ((NOS <- M / M1) > 1 && length( .percentiles ) > 1)
      stop("can only have one response when 'percentiles' is a ",
           "vector longer than unity")



    mynames1  <- param.names("scale", ncoly, skip1 = TRUE)
    predictors.names <-
      namesof(mynames1, .lscale , earg = .escale , tag = FALSE)


    if (!length(etastart)) {
      Ymat <- matrix(colSums(y) / colSums(w), n, ncoly,
                     byrow = TRUE)
      b.init <- (Ymat + 1/8) / sqrt(pi/2)
      etastart <- theta2eta(b.init, .lscale , earg = .escale )
    }
  }), list( .lscale = lscale, .escale = escale,
            .percentiles = percentiles,
            .type.fitted = type.fitted
           ))),


  linkinv = eval(substitute(function(eta, extra = NULL) {
    type.fitted <-
      if (length(extra$type.fitted)) {
        extra$type.fitted
      } else {
        warning("cannot find 'type.fitted'. Returning the 'mean'.")
        "mean"
      }
    type.fitted <- match.arg(type.fitted,
                             c("mean", "percentiles", "Qlink"))[1]

    if (type.fitted == "Qlink") {
      eta2theta(eta, link = "loglink")
    } else {
      Scale <- eta2theta(eta, .lscale , earg = .escale )
      pcent <- extra$percentiles
      perc.mat <- matrix(pcent, NROW(eta), length(pcent),
                         byrow = TRUE) / 100
      fv <-
        switch(type.fitted,
               "mean" = Scale * sqrt(pi / 2),
               "percentiles" = qrayleigh(perc.mat,
               scale = matrix(Scale, nrow(perc.mat), ncol(perc.mat))))
      if (type.fitted == "percentiles")
        fv <- label.cols.y(fv, colnames.y = extra$colnames.y,
                           NOS = NCOL(eta), percentiles = pcent,
                           one.on.one = FALSE)
      fv
    }
  }, list( .lscale = lscale, .escale = escale))),





  last = eval(substitute(expression({
    M1 <- extra$M1
    misc$link <- c(rep_len( .lscale , ncoly))
    names(misc$link) <- mynames1

    misc$earg <- vector("list", M)
    names(misc$earg) <- mynames1
    for (ii in 1:ncoly) {
      misc$earg[[ii]] <- .escale
    }

    misc$M1 <- M1
    misc$multipleResponses <- TRUE
    misc$nrfs <- .nrfs
  }), list( .lscale = lscale,
            .escale = escale, .nrfs = nrfs  ))),

  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    Scale <- eta2theta(eta, .lscale , earg = .escale )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <- c(w) * drayleigh(y, sc = Scale, log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .lscale = lscale, .escale = escale))),

  vfamily = c("rayleigh"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    Scale <- eta2theta(eta, .lscale , earg = .escale )
    okay1 <- all(is.finite(Scale)) && all(0 < Scale)
    okay1
  }, list( .lscale = lscale, .escale = escale))),



  simslot =
    function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")

    Scale <- fitted(object) / sqrt(pi / 2)
    rrayleigh(nsim * length(Scale), scale = c(Scale))
  },



  deriv = eval(substitute(expression({
    Scale <- eta2theta(eta, .lscale , earg = .escale )

    dl.dScale <- ((y/Scale)^2 - 2) / Scale

    dScale.deta <- dtheta.deta(Scale, .lscale , earg = .escale )

    c(w) * dl.dScale * dScale.deta
  }), list( .lscale = lscale, .escale = escale))),

  weight = eval(substitute(expression({
    d2l.dScale2 <- (3 * (y/Scale)^2 - 2) / Scale^2
    ned2l.dScale2 <- 4 / Scale^2
    wz <- c(w) * dScale.deta^2 *
         ((1 - .nrfs) * d2l.dScale2 + .nrfs * ned2l.dScale2)




    if (intercept.only && .oim.mean ) {
      ave.oim <- weighted.mean(d2l.dScale2,
                               rep_len(c(w), length(d2l.dScale2)))
      if (ave.oim > 0) {
        wz <- c(w) * dScale.deta^2 * ave.oim
      }
    }

    wz
  }), list( .lscale = lscale,
            .escale = escale,
            .nrfs = nrfs, .oim.mean = oim.mean ))))
}  # rayleigh











 dparetoIV <-
    function(x, location = 0, scale = 1, inequality = 1,
             shape = 1, log = FALSE) {
  if (!is.logical(log.arg <- log) || length(log) != 1)
    stop("bad input for argument 'log'")
  rm(log)

  N <- max(length(x), length(location), length(scale),
          length(inequality), length(shape))
  if (length(x)          != N) x          <- rep_len(x,          N)
  if (length(location)   != N) location   <- rep_len(location,   N)
  if (length(inequality) != N) inequality <- rep_len(inequality, N)
  if (length(shape)      != N) shape      <- rep_len(shape,      N)
  if (length(scale)      != N) scale      <- rep_len(scale,      N)


  logdensity <- rep_len(log(0), N)
  xok <- (x > location)
  zedd <- (x - location) / scale
  logdensity[xok] <- log(shape[xok]) -
                    log(scale[xok]) -  log(inequality[xok]) +
                    (1/inequality[xok]-1) * log(zedd[xok]) -
                    (shape[xok]+1) *
                      log1p(zedd[xok]^(1/inequality[xok]))
  logdensity[is.infinite(x)] <- log(0)  # 20141208 KaiH
  if (log.arg) logdensity else exp(logdensity)
}  # dparetoIV



pparetoIV <-
  function(q, location = 0, scale = 1, inequality = 1, shape = 1,
           lower.tail = TRUE, log.p = FALSE) {

  if (!is.logical(lower.tail) || length(lower.tail ) != 1)
    stop("bad input for argument 'lower.tail'")
  if (!is.logical(log.p) || length(log.p) != 1)
    stop("bad input for argument 'log.p'")


  zedd <- (q - location) / scale

  if (lower.tail) {
    if (log.p) {
      answer <- log(-expm1(log1p(zedd^(1/inequality)) * (-shape)))
      answer[q <= 0 ] <- -Inf
      answer[q == Inf] <- 0
    } else {
      answer <- -expm1(log1p(zedd^(1/inequality)) * (-shape))
      answer[q <= 0] <- 0
      answer[q == Inf] <- 1
    }
  } else {
    if (log.p) {
      answer <- log1p(zedd^(1/inequality)) * (-shape)
      answer[q <= 0] <- 0
      answer[q == Inf] <- -Inf
    } else {
      answer <- exp(log1p(zedd^(1/inequality)) * (-shape))
      answer[q <= 0] <- 1
      answer[q == Inf] <- 0
    }
  }
  answer[scale <= 0 | shape <= 0 | inequality <= 0] <- NaN
  answer
}  # pparetoIV



qparetoIV <-
  function(p, location = 0, scale = 1, inequality = 1, shape = 1,
           lower.tail = TRUE, log.p = FALSE) {

  if (!is.logical(lower.tail) || length(lower.tail ) != 1)
    stop("bad input for argument 'lower.tail'")
  if (!is.logical(log.p) || length(log.p) != 1)
    stop("bad input for argument 'log.p'")

  if (lower.tail) {
    if (log.p) {
      ln.p <- p
      ans <- location + scale *
             (expm1((-1/shape)*log(-expm1(ln.p))))^inequality
      ans[ln.p > 0] <- NaN
    } else {
      ans <- location + scale *
             (expm1((-1/shape) * log1p(-p)))^inequality
      ans[p < 0] <- NaN
      ans[p == 0] <- 0
      ans[p == 1] <- Inf
      ans[p > 1] <- NaN
    }
  } else {
    if (log.p) {
      ln.p <- p
      ans <- location + scale * (expm1((-1/shape)*ln.p))^inequality
      ans[ln.p > 0] <- NaN
      ans
    } else {
      ans <- location + scale * (expm1((-1/shape)*log(p)))^inequality
      ans[p < 0] <- NaN
      ans[p == 0] <- Inf
      ans[p == 1] <- 0
      ans[p > 1] <- NaN
    }
  }
  ans[scale <= 0 | shape <= 0 | inequality <= 0] <- NaN
  ans
}  # qparetoIV



rparetoIV <-
  function(n, location = 0, scale = 1, inequality = 1, shape = 1) {
  if (!is.Numeric(inequality, positive = TRUE))
    stop("bad input for argument 'inequality'")
  ans <- location + scale * (-1 + runif(n)^(-1/shape))^inequality
  ans[scale <= 0] <- NaN
  ans[shape <= 0] <- NaN
  ans
}  # rparetoIV



dparetoIII <- function(x, location = 0, scale = 1, inequality = 1,
                       log = FALSE)
  dparetoIV(x = x, location = location, scale = scale,
            inequality = inequality, shape = 1, log = log)



pparetoIII <- function(q, location = 0, scale = 1, inequality = 1,
                       lower.tail = TRUE, log.p = FALSE)
  pparetoIV(q = q, location = location, scale = scale,
            inequality = inequality, shape = 1,
            lower.tail = lower.tail, log.p = log.p)



qparetoIII <- function(p, location = 0, scale = 1, inequality = 1,
                       lower.tail = TRUE, log.p = FALSE)
  qparetoIV(p = p, location = location, scale = scale,
            inequality = inequality, shape = 1,
            lower.tail = lower.tail, log.p = log.p)



rparetoIII <- function(n, location = 0, scale = 1, inequality = 1)
  rparetoIV(n = n, location= location, scale = scale,
            inequality = inequality, shape = 1)



dparetoII <-
  function(x, location = 0, scale = 1, shape = 1, log = FALSE)
  dparetoIV(x = x, location = location, scale = scale,
            inequality = 1, shape = shape, log = log)



pparetoII <- function(q, location = 0, scale = 1, shape = 1,
                      lower.tail = TRUE, log.p = FALSE)
  pparetoIV(q = q, location = location, scale = scale,
            inequality = 1, shape = shape,
            lower.tail = lower.tail, log.p = log.p)



qparetoII <- function(p, location = 0, scale = 1, shape = 1,
                      lower.tail = TRUE, log.p = FALSE)
  qparetoIV(p = p, location = location, scale = scale,
            inequality = 1, shape = shape,
            lower.tail = lower.tail, log.p = log.p)



rparetoII <- function(n, location = 0, scale = 1, shape = 1)
  rparetoIV(n = n, location = location, scale = scale,
            inequality = 1, shape = shape)




dparetoI <- function(x, scale = 1, shape = 1, log = FALSE)
  dparetoIV(x = x, location = scale, scale = scale, inequality = 1,
            shape = shape, log = log)


pparetoI <- function(q, scale = 1, shape = 1,
                     lower.tail = TRUE, log.p = FALSE)
  pparetoIV(q = q, location = scale, scale = scale, inequality = 1,
            shape = shape,
            lower.tail = lower.tail, log.p = log.p)


qparetoI <- function(p, scale = 1, shape = 1,
                     lower.tail = TRUE, log.p = FALSE)
  qparetoIV(p = p, location = scale, scale = scale, inequality = 1,
            shape = shape,
            lower.tail = lower.tail, log.p = log.p)


rparetoI <- function(n, scale = 1, shape = 1)
  rparetoIV(n = n, location = scale, scale = scale, inequality = 1,
            shape = shape)





 paretoIV <-
  function(location = 0,
           lscale = "loglink",
           linequality = "loglink",
           lshape = "loglink",
           iscale = 1, iinequality = 1, ishape = NULL,
           imethod = 1) {

  if (!is.Numeric(location))
    stop("argument 'location' must be numeric")
  if (is.Numeric(iscale) && any(iscale <= 0))
    stop("argument 'iscale' must be positive")
  if (is.Numeric(iinequality) && any(iinequality <= 0))
    stop("argument 'iinequality' must be positive")
  if (is.Numeric(ishape) && any(ishape <= 0))
    stop("argument 'ishape' must be positive")
  if (!is.Numeric(imethod, length.arg = 1,
                  integer.valued = TRUE) ||
      imethod > 2)
    stop("bad input for argument 'imethod'")

  if (linequality == "negloglink" && location != 0)
      warning("The Burr distribution has 'location = 0' and ",
              "'linequality = negloglink'")

  lscale <- as.list(substitute(lscale))
  escale <- link2list(lscale)
  lscale <- attr(escale, "function.name")

  linequ <- as.list(substitute(linequality))
  einequ <- link2list(linequ)
  linequ <- attr(einequ, "function.name")

  lshape <- as.list(substitute(lshape))
  eshape <- link2list(lshape)
  lshape <- attr(eshape, "function.name")

  iinequ <- iinequality


  new("vglmff",
  blurb = c("Pareto(IV) distribution F(y)=1-[1+((y - ", location,
            ")/scale)^(1/inequality)]^(-shape),",
            "\n",
            "         y > ",
            location,
            ", scale > 0, inequality > 0, shape > 0,\n",
            "Links:    ",
            namesof("scale", lscale, earg = escale), ", ",
            namesof("inequality", linequ, earg = einequ ),
            ", ",
            namesof("shape", lshape, earg = eshape), "\n",
            "Mean:    location + scale * NA"),
  initialize = eval(substitute(expression({

    w.y.check(w = w, y = y,
              ncol.w.max = 1,
              ncol.y.max = 1)



    predictors.names <-
     c(namesof("scale", .lscale , earg = .escale , tag = FALSE),
       namesof("inequality", .linequ ,
               earg = .einequ , tag = FALSE),
       namesof("shape", .lshape , earg = .eshape , tag = FALSE))



    extra$location <- location <- .location
    if (any(y <= location))
      stop("the response must have values > than ",
           "the 'location' argument")

    if (!length(etastart)) {
      inequ.init <- if (length( .iinequ )) .iinequ else  1
      scale.init <- if (length( .iscale )) .iscale else 1
      shape.init <- if (length( .ishape )) .ishape else NULL

      if (!length(shape.init)) {
        zedd <- (y - location) / scale.init
        if ( .imethod == 1) {
          A1 <- weighted.mean(1/(1 + zedd^(1/inequ.init)), w = w)
          A2 <- weighted.mean(1/(1 + zedd^(1/inequ.init))^2, w = w)
        } else {
          A1 <- median(1/(1 + zedd^(1/inequ.init )))
          A2 <- median(1/(1 + zedd^(1/inequ.init))^2)
        }
        shape.init <- max(0.01, (2*A2-A1)/(A1-A2))
      }

      etastart <- cbind(
        theta2eta(rep_len(scale.init, n), .lscale , earg = .escale ),
        theta2eta(rep_len(inequ.init, n), .linequ , earg = .einequ ),
        theta2eta(rep_len(shape.init, n), .lshape , earg = .eshape ))
      }
  }), list( .location = location, .lscale = lscale,
      .linequ = linequ, .lshape = lshape, .imethod = imethod,
      .escale = escale, .einequ = einequ, .eshape = eshape,
      .iscale = iscale, .iinequ = iinequ, .ishape = ishape ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    location <- extra$location
    Scale <- eta2theta(eta[, 1], .lscale , earg = .escale )
    inequ <- eta2theta(eta[, 2], .linequ, earg = .einequ)
    shape <- eta2theta(eta[, 3], .lshape , earg = .eshape )

    qparetoIV(p = 0.5, location = location, scale = Scale,
              inequality = inequ, shape = shape)
  }, list( .lscale = lscale, .linequ = linequ, .lshape = lshape,
           .escale = escale, .einequ = einequ, .eshape = eshape))),
  last = eval(substitute(expression({
    misc$link <-    c("scale"      = .lscale ,
                      "inequality" = .linequ,
                      "shape"      = .lshape)
    misc$earg <- list("scale"      = .escale ,
                      "inequality" = .einequ,
                      "shape"      = .eshape )
    misc$location = extra$location # Use this for prediction
  }), list( .lscale = lscale, .linequ = linequ,
            .escale = escale, .einequ = einequ,
            .lshape = lshape,
            .eshape = eshape))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    location <- extra$location
    Scale <- eta2theta(eta[, 1], .lscale , earg = .escale )
    inequ <- eta2theta(eta[, 2], .linequ, earg = .einequ)
    shape <- eta2theta(eta[, 3], .lshape , earg = .eshape )
    zedd <- (y - location) / Scale
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * dparetoIV(x = y, location = location, scale = Scale,
                         inequ = inequ, shape = shape,
                         log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .lscale = lscale, .linequ = linequ,
           .escale = escale, .einequ = einequ,
           .lshape = lshape,
           .eshape = eshape))),
  vfamily = c("paretoIV"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    location <- extra$location
    Scale <- eta2theta(eta[, 1], .lscale , earg = .escale )
    inequ <- eta2theta(eta[, 2], .linequ , earg = .einequ )
    shape <- eta2theta(eta[, 3], .lshape , earg = .eshape )
    okay1 <- all(is.finite(Scale)) && all(0 < Scale) &&
             all(is.finite(inequ)) && all(0 < inequ) &&
             all(is.finite(shape)) && all(0 < shape)
    okay1
  }, list( .lscale = lscale, .linequ = linequ,
           .escale = escale, .einequ = einequ,
           .lshape = lshape,
           .eshape = eshape))),

  deriv = eval(substitute(expression({
    location <- extra$location
    Scale <- eta2theta(eta[, 1], .lscale , earg = .escale )
    inequ <- eta2theta(eta[, 2], .linequ , earg = .einequ )
    shape <- eta2theta(eta[, 3], .lshape , earg = .eshape )
    zedd <- (y - location) / Scale
    temp100 <- 1 + zedd^(1/inequ)
    dl.dscale <- (shape  - (1+shape) / temp100) / (inequ * Scale)
    dl.dinequ <- ((log(zedd) * (shape - (1+shape)/temp100)) /
                     inequ - 1) / inequ
    dl.dshape <- -log(temp100) + 1/shape
    dscale.deta <- dtheta.deta(Scale, .lscale , earg = .escale )
    dinequ.deta <- dtheta.deta(inequ, .linequ, earg = .einequ)
    dshape.deta <- dtheta.deta(shape, .lshape , earg = .eshape )
    c(w) * cbind(dl.dscale * dscale.deta,
                 dl.dinequ * dinequ.deta,
                 dl.dshape * dshape.deta)
  }), list( .lscale = lscale, .linequ = linequ,
            .lshape = lshape,
            .escale = escale, .einequ = einequ,
            .eshape = eshape))),
  weight = eval(substitute(expression({
    temp200 <- digamma(shape) - digamma(1) - 1
    d2scale.deta2 <- shape / ((inequ*Scale)^2 * (shape+2))
    d2inequ.deta2 <- (shape * (temp200^2 +
                       trigamma(shape) + trigamma(1)
              ) + 2*(temp200+1)) / (inequ^2 * (shape+2))
    d2shape.deta2 <- 1 / shape^2
    d2si.deta2 <- (shape*(-temp200) -1) / (
        inequ^2 * Scale * (shape+2))
    d2ss.deta2 <- -1 / ((inequ*Scale) * (shape+1))
    d2is.deta2 <- temp200 / (inequ*(shape+1))
    wz <- matrix(0, n, dimm(M))
    wz[, iam(1, 1, M)] <- dscale.deta^2 * d2scale.deta2
    wz[, iam(2, 2, M)] <- dinequ.deta^2 * d2inequ.deta2
    wz[, iam(3, 3, M)] <- dshape.deta^2 * d2shape.deta2
    wz[, iam(1, 2, M)] <- dscale.deta * dinequ.deta * d2si.deta2
    wz[, iam(1, 3, M)] <- dscale.deta * dshape.deta * d2ss.deta2
    wz[, iam(2, 3, M)] <- dinequ.deta * dshape.deta * d2is.deta2
        c(w) * wz
  }),
  list( .lscale = lscale, .linequ = linequ, .lshape = lshape,
        .escale = escale, .einequ = einequ, .eshape = eshape))))
}  # paretoIV




 paretoIII <-
  function(location = 0,
           lscale = "loglink",
           linequality = "loglink",
           iscale = NULL, iinequality = NULL) {

  if (!is.Numeric(location))
      stop("argument 'location' must be numeric")
  if (is.Numeric(iscale) && any(iscale <= 0))
      stop("argument 'iscale' must be positive")
  if (is.Numeric(iinequality) && any(iinequality <= 0))
      stop("argument 'iinequality' must be positive")

  lscale <- as.list(substitute(lscale))
  escale <- link2list(lscale)
  lscale <- attr(escale, "function.name")

  linequ <- as.list(substitute(linequality))
  einequ <- link2list(linequ)
  linequ <- attr(einequ, "function.name")


  iinequ <- iinequality



  new("vglmff",
  blurb = c("Pareto(III) distribution F(y)=1-[1+((y - ", location,
            ")/scale)^(1/inequality)]^(-1),",
            "\n", "         y > ",
            location, ", scale > 0, inequality > 0, \n",
            "Links:    ",
            namesof("scale", lscale, earg = escale), ", ",
            namesof("inequality", linequ, earg = einequ ), "\n",
            "Mean:    location + scale * NA"),
  initialize = eval(substitute(expression({

    w.y.check(w = w, y = y,
              ncol.w.max = 1,
              ncol.y.max = 1)



    predictors.names <-
    c(namesof("scale", .lscale , earg = .escale , tag = FALSE),
      namesof("inequ", .linequ, earg = .einequ, tag = FALSE))
    extra$location = location = .location

    if (any(y <= location))
      stop("the response must have values > than ",
           "the 'location' argument")


    if (!length(etastart)) {
            inequ.init <- if (length( .iinequ)) .iinequ else  NULL
            scale.init <- if (length( .iscale )) .iscale else NULL
            if (!length(inequ.init) || !length(scale.init)) {
                probs <- (1:4)/5
                ytemp <- quantile(x = log(y-location),
                                  probs = probs)
                fittemp <- lsfit(logitlink(probs),
                                 ytemp, intercept = TRUE)
                if (!length(inequ.init))
                    inequ.init <- max(fittemp$coef["X"], 0.01)
                if (!length(scale.init))
                    scale.init <- exp(fittemp$coef["Intercept"])
            }
            etastart<- cbind(
            theta2eta(rep_len(scale.init, n), .lscale , .escale ),
            theta2eta(rep_len(inequ.init, n), .linequ , .einequ ))
        }
  }), list( .location = location, .lscale = lscale,
            .linequ = linequ,
            .escale = escale, .einequ = einequ,
            .iscale = iscale, .iinequ = iinequ ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    location <- extra$location
    Scale      <- eta2theta(eta[, 1], .lscale     , .escale )
    inequ <- eta2theta(eta[, 2], .linequ, earg = .einequ)

    qparetoIII(p = 0.5, location = location, scale = Scale,
              inequality = inequ)

  }, list( .lscale = lscale, .linequ = linequ,
           .escale = escale, .einequ = einequ ))),
  last = eval(substitute(expression({
    misc$link <-    c("scale" = .lscale , "inequality" = .linequ)
    misc$earg <- list("scale" = .escale , "inequality" = .einequ)

    misc$location <- extra$location # Use this for prediction
  }), list( .lscale = lscale, .linequ = linequ,
            .escale = escale, .einequ = einequ ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    location <- extra$location
    Scale <- eta2theta(eta[, 1], .lscale , earg = .escale )
    inequ <- eta2theta(eta[, 2], .linequ , earg = .einequ )
    zedd <- (y - location) / Scale
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * dparetoIII(x = y, location = location, scale = Scale,
                          inequ = inequ, log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
    }, list( .lscale = lscale, .linequ = linequ,
             .escale = escale, .einequ = einequ ))),
  vfamily = c("paretoIII"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    location <- extra$location
    Scale <- eta2theta(eta[, 1], .lscale , earg = .escale )
    inequ <- eta2theta(eta[, 2], .linequ, earg = .einequ)
    okay1 <- all(is.finite(Scale)) && all(0 < Scale) &&
             all(is.finite(inequ)) && all(0 < inequ)
    okay1
  }, list( .lscale = lscale, .linequ = linequ,
           .escale = escale, .einequ = einequ ))),
  deriv = eval(substitute(expression({
    location <- extra$location
    Scale <- eta2theta(eta[, 1], .lscale , earg = .escale )
    inequ <- eta2theta(eta[, 2], .linequ, earg = .einequ)
    shape <- 1
    zedd <- (y - location) / Scale
    temp100 <- 1 + zedd^(1/inequ)
    dl.dscale <- (shape  - (1+shape) / temp100) / (inequ * Scale)
    dl.dinequ <- ((log(zedd) * (shape - (1+shape)/temp100)) /
                     inequ - 1) / inequ
    dscale.deta <- dtheta.deta(Scale, .lscale , earg = .escale )
    dinequ.deta <- dtheta.deta(inequ, .linequ, earg = .einequ)
    c(w) * cbind(dl.dscale * dscale.deta,
                 dl.dinequ * dinequ.deta)
  }), list( .lscale = lscale, .linequ = linequ,
            .escale = escale, .einequ = einequ ))),
  weight = eval(substitute(expression({
    d2scale.deta2 <- 1 / ((inequ*Scale)^2 * 3)
    d2inequ.deta2 <- (1 + 2* trigamma(1)) / (inequ^2 * 3)
    wz <- matrix(0, n, M)  # It is diagonal
    wz[, iam(1, 1, M)] <- dscale.deta^2 * d2scale.deta2
    wz[, iam(2, 2, M)] <- dinequ.deta^2 * d2inequ.deta2
    c(w) * wz
  }), list( .lscale = lscale, .linequ = linequ,
            .escale = escale, .einequ = einequ ))))
}  # paretoIII



 paretoII <-
  function(location = 0,
           lscale = "loglink",
           lshape = "loglink",
           iscale = NULL, ishape = NULL) {

  if (!is.Numeric(location))
    stop("argument 'location' must be numeric")
  if (is.Numeric(iscale) && any(iscale <= 0))
    stop("argument 'iscale' must be positive")
  if (is.Numeric(ishape) && any(ishape <= 0))
    stop("argument 'ishape' must be positive")


  lscale <- as.list(substitute(lscale))
  escale <- link2list(lscale)
  lscale <- attr(escale, "function.name")

  lshape <- as.list(substitute(lshape))
  eshape <- link2list(lshape)
  lshape <- attr(eshape, "function.name")




  new("vglmff",
  blurb = c("Pareto(II) distribution F(y)=1-[1+(y - ", location,
            ")/scale]^(-shape),",
            "\n", "         y > ",
            location, ", scale > 0,  shape > 0,\n",
            "Links:    ", namesof("scale", lscale, escale), ", ",
                          namesof("shape", lshape, eshape), "\n",
            "Mean:    location + scale * NA"),
  initialize = eval(substitute(expression({

    w.y.check(w = w, y = y,
              ncol.w.max = 1,
              ncol.y.max = 1)



  predictors.names <-
    c(namesof("scale", .lscale , earg = .escale , tag = FALSE),
      namesof("shape", .lshape , earg = .eshape , tag = FALSE))

  extra$location <- location <- .location

  if (any(y <= location))
    stop("the response must have values > than ",
         "the 'location' argument")

  if (!length(etastart)) {
          scale.init <- if (length( .iscale )) .iscale else NULL
          shape.init <- if (length( .ishape )) .ishape else  NULL
          if (!length(shape.init) || !length(scale.init)) {
              probs <- (1:4)/5
              scale.init.0 <- 1
              ytemp <- quantile(x = log(y-location+scale.init.0),
                               probs = probs)
              fittemp <- lsfit(x = log1p(-probs), y = ytemp,
                              intercept = TRUE)
              if (!length(shape.init))
                  shape.init <- max(-1/fittemp$coef["X"], 0.01)
              if (!length(scale.init))
                  scale.init <- exp(fittemp$coef["Intercept"])
        }
        etastart <-
          cbind(theta2eta(rep_len(scale.init, n), .lscale ,
                          earg = .escale ),
                theta2eta(rep_len(shape.init, n), .lshape ,
                          earg = .eshape ))
    }
  }),
  list( .location = location, .lscale = lscale,
        .escale = escale, .eshape = eshape,
        .lshape = lshape, .iscale = iscale, .ishape = ishape ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    location <- extra$location
    Scale <- eta2theta(eta[, 1], .lscale , earg = .escale )
    shape <- eta2theta(eta[, 2], .lshape , earg = .eshape )


    qparetoII(p = 0.5, scale = Scale, shape = shape)
  }, list( .lscale = lscale, .lshape = lshape,
           .escale = escale, .eshape = eshape))),
  last = eval(substitute(expression({
    misc$link <-    c("scale" = .lscale , "shape" = .lshape)

    misc$earg <- list("scale" = .escale , "shape" = .eshape )

    misc$location <- extra$location # Use this for prediction
  }), list( .lscale = lscale, .lshape = lshape,
            .escale = escale, .eshape = eshape))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    location <- extra$location
    Scale <- eta2theta(eta[, 1], .lscale , earg = .escale )
    shape <- eta2theta(eta[, 2], .lshape , earg = .eshape )
    zedd <- (y - location) / Scale
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * dparetoII(y, loc = location, scale = Scale,
                         shape = shape, log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .lscale = lscale, .lshape = lshape,
           .escale = escale, .eshape = eshape))),
  vfamily = c("paretoII"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    location <- extra$location
    Scale <- eta2theta(eta[, 1], .lscale , earg = .escale )
    shape <- eta2theta(eta[, 2], .lshape , earg = .eshape )
    okay1 <- all(is.finite(Scale)) && all(0 < Scale) &&
             all(is.finite(shape)) && all(0 < shape)
    okay1
  }, list( .lscale = lscale, .lshape = lshape,
           .escale = escale, .eshape = eshape))),
  deriv = eval(substitute(expression({
    location <- extra$location
    Scale <- eta2theta(eta[, 1], .lscale , earg = .escale )
    shape <- eta2theta(eta[, 2], .lshape , earg = .eshape )
    zedd <- (y - location) / Scale
    temp100 <- 1 + zedd
    dl.dscale <- (shape  - (1+shape) / temp100) / (1 * Scale)
    dl.dshape <- -log(temp100) + 1/shape
    dscale.deta <- dtheta.deta(Scale, .lscale , earg = .escale )
    dshape.deta <- dtheta.deta(shape, .lshape , earg = .eshape )
    c(w) * cbind(dl.dscale * dscale.deta,
                 dl.dshape * dshape.deta)
  }), list( .lscale = lscale, .lshape = lshape,
            .escale = escale, .eshape = eshape))),
  weight = eval(substitute(expression({
    d2scale.deta2 <- shape / (Scale^2 * (shape+2))
    d2shape.deta2 <- 1 / shape^2
    d2ss.deta2 <- -1 / (Scale * (shape+1))
    wz <- matrix(0, n, dimm(M))
    wz[, iam(1, 1, M)] <- dscale.deta^2 * d2scale.deta2
    wz[, iam(2, 2, M)] <- dshape.deta^2 * d2shape.deta2
    wz[, iam(1, 2, M)] <- dscale.deta * dshape.deta * d2ss.deta2
    c(w) * wz
  }), list( .lscale = lscale, .lshape = lshape,
            .escale = escale, .eshape = eshape))))
}  # paretoII







dpareto <- function(x, scale = 1, shape, log = FALSE) {
  if (!is.logical(log.arg <- log) || length(log) != 1)
    stop("bad input for argument 'log'")
  rm(log)

  L <- max(length(x), length(scale), length(shape))
  if (length(x)     != L) x     <- rep_len(x,     L)
  if (length(scale) != L) scale <- rep_len(scale, L)
  if (length(shape) != L) shape <- rep_len(shape, L)



  logdensity <- rep_len(log(0), L)
  xok <- (x >= scale)  # 20141212 KaiH
  logdensity[xok] <- log(shape[xok]) +
                       shape[xok] * log(scale[xok]) -
                      (shape[xok] + 1) * log(x[xok])
  if (log.arg) logdensity else exp(logdensity)
}  # dpareto



ppareto <- function(q, scale = 1, shape,
                    lower.tail = TRUE, log.p = FALSE) {
  if (!is.logical(lower.tail) || length(lower.tail ) != 1)
    stop("bad input for argument 'lower.tail'")

  if (!is.logical(log.p) || length(log.p) != 1)
    stop("bad input for argument 'log.p'")


  if (lower.tail) {
    if (log.p) {
      ans <- log1p(-(scale/q)^shape)
      ans[q <= scale] <- -Inf
      ans[q == Inf] <- 0
    } else {
      ans <- exp(log1p(-(scale/q)^shape))
      ans[q <= scale] <- 0
      ans[q == Inf] <- 1
    }
  } else {
    if (log.p) {
      ans <- log((scale/q)^shape)
      ans[q <= scale] <- 0
      ans[q == Inf] <- -Inf
    } else {
      ans <- (scale/q)^shape
      ans[q <= scale] <- 1
      ans[q == Inf] <- 0
    }
  }

  ans[shape <= 0 | scale <= 0] <- NaN
  ans
}  # ppareto



qpareto <- function(p, scale = 1, shape,
                    lower.tail = TRUE, log.p = FALSE) {
  if (!is.logical(lower.tail) || length(lower.tail ) != 1)
    stop("bad input for argument 'lower.tail'")

  if (!is.logical(log.p) || length(log.p) != 1)
    stop("bad input for argument 'log.p'")

  if (lower.tail) {
    if (log.p) {
      ln.p <- p
      ans <- scale / (-expm1(ln.p))^(1/shape)
      ans[ln.p > 0] <- NaN
    } else {
      ans <- scale / exp(log1p(-p) * (1/shape))
      ans[p < 0] <- NaN
      ans[p == 0] <- scale
      ans[p == 1] <- Inf
      ans[p > 1] <- NaN
    }
  } else {
    if (log.p) {
      ln.p <- p
      ans <- scale / exp(ln.p)^(1/shape)
      ans[ln.p > 0] <- NaN
      ans
    } else {
      ans <- scale / p^(1/shape)
      ans[p < 0] <- NaN
      ans[p == 0] <- Inf
      ans[p == 1] <- scale
      ans[p > 1] <- NaN
    }
  }
  ans[shape <= 0 | scale <= 0] <- NaN
  ans
}  # qpareto



rpareto <- function(n, scale = 1, shape) {
  ans <- scale / runif(n)^(1/shape)
  ans[scale <= 0] <- NaN
  ans[shape <= 0] <- NaN
  ans
}  # rpareto



 paretoff <-
  function(scale = NULL, lshape = "loglink") {
  if (is.Numeric(scale) && scale <= 0)
    stop("argument 'scale' must be positive")

  lshape <- as.list(substitute(lshape))
  eshape <- link2list(lshape)
  lshape <- attr(eshape, "function.name")


  new("vglmff",
  blurb = c("Pareto distribution ",
            "f(y) = shape * scale^shape / y^(shape+1),",
            " 0<scale<y, 0<shape\n",
            "Link:    ", namesof("shape", lshape, earg = eshape),
            "\n", "\n",
            "Mean:    scale*shape/(shape-1) for shape>1"),
  initialize = eval(substitute(expression({

    w.y.check(w = w, y = y,
              ncol.w.max = 1,
              ncol.y.max = 1)


    predictors.names <-
      namesof("shape", .lshape , earg = .eshape , tag = FALSE)


    scalehat <- if (!length( .scale )) {
      scaleEstimated <- TRUE
      min(y)  # - .smallno
    } else {
      scaleEstimated <- FALSE
      .scale
    }
    if (any(y < scalehat))
      stop("the value of 'scale' is too high ",
           "(requires 0 < scale < min(y))")
    extra$scale <- scalehat
    extra$scaleEstimated <- scaleEstimated

    if (!length(etastart)) {
      k.init <- (y + 1/8) / (y - scalehat + 1/8)
      etastart <- theta2eta(k.init, .lshape , earg = .eshape )
    }
  }), list( .lshape = lshape, .eshape = eshape,
            .scale = scale ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    k <- eta2theta(eta, .lshape , earg = .eshape )
    scale <- extra$scale
    ifelse(k > 1, k * scale / (k-1), NA)
  }, list( .lshape = lshape, .eshape = eshape ))),
  last = eval(substitute(expression({
    misc$link <-    c(k = .lshape)

    misc$earg <- list(k = .eshape )

    misc$scale <- extra$scale # Use this for prediction
  }), list( .lshape = lshape, .eshape = eshape ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    shape <- eta2theta(eta, .lshape , earg = .eshape )
    scale <- extra$scale
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {


      ll.elts <- c(w) * dpareto(y, sc = scale, sh = shape,
                                log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .lshape = lshape, .eshape = eshape ))),
  vfamily = c("paretoff"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    Scale <- extra$scale
    shape <- eta2theta(eta, .lshape , earg = .eshape )
    okay1 <- all(is.finite(Scale)) &&
             all(0 < Scale & Scale <= y) &&
             all(is.finite(shape)) && all(0 < shape)
    okay1
  }, list( .lshape = lshape, .eshape = eshape ))),
  deriv = eval(substitute(expression({
    scale <- extra$scale
    k <- eta2theta(eta, .lshape , earg = .eshape )
    dl.dk <- 1/k + log(scale/y)
    dk.deta <- dtheta.deta(k, .lshape , earg = .eshape )
    c(w) * dl.dk * dk.deta
  }), list( .lshape = lshape, .eshape = eshape ))),
  weight = eval(substitute(expression({
    ned2l.dk2 <- 1 / k^2
    wz <- c(w) * dk.deta^2 * ned2l.dk2
    wz
  }), list( .lshape = lshape, .eshape = eshape ))))
}  #  paretoff






dtruncpareto <- function(x, lower, upper, shape, log = FALSE) {

  if (!is.logical(log.arg <- log) || length(log) != 1)
    stop("bad input for argument 'log'")
  rm(log)

  if (!is.Numeric(lower, positive = TRUE))
    stop("argument 'lower' must be positive")
  if (!is.Numeric(upper, positive = TRUE))
    stop("argument 'upper' must be positive")
  if (!is.Numeric(shape, positive = TRUE))
    stop("argument 'shape' must be positive")

  L <- max(length(x), length(lower), length(upper), length(shape))
  if (length(x)     != L) x     <- rep_len(x,     L)
  if (length(shape) != L) shape <- rep_len(shape, L)
  if (length(lower) != L) lower <- rep_len(lower, L)
  if (length(upper) != L) upper <- rep_len(upper, L)


  logdensity <- rep_len(log(0), L)
  xok <- (0 < lower) & (lower < x) & (x < upper) & (shape > 0)

  logdensity[xok] <- log(shape[xok]) +
                     shape[xok] * log(lower[xok]) -
                     (shape[xok] + 1) * log(x[xok]) -
                     log1p(-(lower[xok] / upper[xok])^(shape[xok]))

  logdensity[shape <= 0] <- NaN
  logdensity[upper < lower] <- NaN
  logdensity[0 > lower] <- NaN

  if (log.arg) logdensity else exp(logdensity)
}  # dtruncpareto



ptruncpareto <- function(q, lower, upper, shape,
                         lower.tail = TRUE, log.p = FALSE) {
  if (!is.Numeric(q))
    stop("bad input for argument 'q'")

  if (!is.logical(lower.tail) || length(lower.tail ) != 1)
    stop("bad input for argument 'lower.tail'")

 if (!is.logical(log.arg <- log.p) || length(log.p) != 1)
    stop("bad input for argument 'log.p'")
  rm(log.p)   # 20141231 KaiH

  L <- max(length(q), length(lower), length(upper), length(shape))
  if (length(q)     != L) q     <- rep_len(q,     L)
  if (length(shape) != L) shape <- rep_len(shape, L)
  if (length(lower) != L) lower <- rep_len(lower, L)
  if (length(upper) != L) upper <- rep_len(upper, L)

  ans <- q * 0
  xok <- (0 < lower) & (lower < q) & (q < upper) & (shape > 0)
  ans[xok] <- (1 - (lower[xok]/q[xok])^shape[xok]) / (1 -
                  (lower[xok]/upper[xok])^shape[xok])
  ans[q >= upper] <- 1

  ans[upper < lower] <- NaN
  ans[lower <= 0] <- NaN
  ans[upper <= 0] <- NaN
  ans[shape <= 0] <- NaN

  if (lower.tail) {
    if (log.arg) log(ans) else ans
  } else {
    if (log.arg) log1p(-ans) else exp(log1p(-ans))
  }
}  # ptruncpareto



qtruncpareto <- function(p, lower, upper, shape) {
  if (!is.Numeric(p, positive = TRUE))
    stop("bad input for argument 'p'")
  if (max(p) >= 1)
    stop("argument 'p' must be in (0, 1)")

  ans <- lower / (1 - p * (1 - (lower/upper)^shape))^(1/shape)
  ans[lower <= 0] <- NaN
  ans[upper <= 0] <- NaN
  ans[shape <= 0] <- NaN
  ans[upper <  lower] <- NaN
  ans
}  # qtruncpareto



rtruncpareto <- function(n, lower, upper, shape) {

  ans <- qtruncpareto(p = runif(n), lower = lower,
                      upper = upper, shape = shape)
  ans[lower <= 0] <- NaN
  ans[upper <= 0] <- NaN
  ans[shape <= 0] <- NaN
  ans
}  # rtruncpareto




 truncpareto <-
    function(lower, upper, lshape = "loglink",
             ishape = NULL, imethod = 1) {

  if (!is.Numeric(lower, positive = TRUE, length.arg = 1))
    stop("bad input for argument 'lower'")
  if (!is.Numeric(upper, positive = TRUE, length.arg = 1))
    stop("bad input for argument 'upper'")
  if (lower >= upper)
    stop("lower < upper is required")

  if (length(ishape) && !is.Numeric(ishape, positive = TRUE))
    stop("bad input for argument 'ishape'")



  lshape <- as.list(substitute(lshape))
  eshape <- link2list(lshape)
  lshape <- attr(eshape, "function.name")
  earg <- eshape


  if (!is.Numeric(imethod, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE) ||
     imethod > 2)
    stop("argument 'imethod' must be 1 or 2")


  new("vglmff",
  blurb = c("Truncated Pareto distribution f(y) = ",
            "shape * lower^shape /",
            "(y^(shape+1) * (1-(lower/upper)^shape)),",
            " 0 < lower < y < upper < Inf, shape>0\n",
            "Link:    ", namesof("shape", lshape, eshape),
            "\n", "\n",
"Mean:    shape*lower^shape*(upper^(1-shape)-lower^(1-shape)) /",
                      " ((1-shape) * (1-(lower/upper)^shape))"),
  initialize = eval(substitute(expression({

    w.y.check(w = w, y = y,
              ncol.w.max = 1,
              ncol.y.max = 1)




    predictors.names <- namesof("shape", .lshape , .eshape ,
                                tag = FALSE)
    if (any(y <= .lower))
      stop("the value of argument 'lower' is too high ",
           "(requires '0 < lower < min(y)')")

    extra$lower <- .lower
    if (any(y >= .upper))
        stop("the value of argument 'upper' is too low ",
             "(requires 'max(y) < upper')")
    extra$upper <- .upper

    if (!length(etastart)) {
      shape.init <- if (is.Numeric( .ishape )) 0 * y + .ishape else
      if ( .imethod == 2) {
          0 * y + median(rep((y + 1/8) / (y - .lower + 1/8),
                             times = w))
      } else {
          truncpareto.Loglikfun <-
              function(shape, y, x, w, extraargs) {
          myratio <- .lower / .upper
          sum(c(w) * (log(shape) + shape * log( .lower ) -
            (shape + 1) * log(y) - log1p(-myratio^shape)))
        }
        shape.grid <- 2^((-4):4)
        try.this <- grid.search(shape.grid, y = y,  x = x, w = w,
                                objfun = truncpareto.Loglikfun)
        try.this <- rep_len(try.this, n)
        try.this
      }
      etastart <- theta2eta(shape.init, .lshape , earg = .eshape )
    }
  }), list( .lshape = lshape, .eshape = eshape,
            .ishape = ishape,
            .imethod = imethod,
            .lower = lower, .upper = upper ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    shape <- eta2theta(eta, .lshape , earg = .eshape )
    myratio <- .lower / .upper
    constprop <- shape * .lower^shape / (1 - myratio^shape)
    constprop * ( .upper^(1-shape) - .lower^(1-shape)) / (1-shape)
  }, list( .lshape = lshape, .lower = lower,
           .eshape = eshape, .upper = upper ))),
  last = eval(substitute(expression({
    misc$link <-    c(shape = .lshape )

    misc$earg <- list(shape = .eshape )

    misc$lower <- extra$lower
    misc$upper <- extra$upper
    misc$expected <- TRUE
  }), list( .lshape = lshape, .lower = lower,
            .eshape = eshape, .upper = upper ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    shape <- eta2theta(eta, .lshape , earg = .eshape )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <- c(w) * dtruncpareto(x = y, lower = .lower ,
                                     upper = .upper ,
                                     shape = shape, log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .lshape = lshape, .lower = lower,
           .eshape = eshape, .upper = upper ))),
  vfamily = c("truncpareto"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    shape <- eta2theta(eta, .lshape , earg = .eshape )
    okay1 <- all(is.finite(shape)) && all(0 < shape)
    okay1
  }, list( .lshape = lshape, .lower = lower,
           .eshape = eshape, .upper = upper ))),
  deriv = eval(substitute(expression({
    shape <- eta2theta(eta, .lshape , earg = .eshape )
    myratio <- .lower / .upper
    myratio2 <-  myratio^shape
    tmp330 <- myratio2 * log(myratio) / (1 - myratio2)

    dl.dshape <- 1 / shape + log( .lower) - log(y) + tmp330

    dshape.deta <- dtheta.deta(shape, .lshape , earg = .eshape )

    c(w) * dl.dshape * dshape.deta
  }), list( .lshape = lshape, .lower = lower,
            .eshape = eshape, .upper = upper ))),
  weight = eval(substitute(expression({
    ned2l.dshape2 <- 1 / shape^2 - tmp330^2 / myratio2
    wz <- c(w) * dshape.deta^2 * ned2l.dshape2
    wz
  }), list( .lshape = lshape, .lower = lower,
            .eshape = eshape, .upper = upper ))))
}  # truncpareto






 waldff <-
  function(llambda = "loglink", ilambda = NULL) {

  llambda <- as.list(substitute(llambda))
  elambda <- link2list(llambda)
  llambda <- attr(elambda, "function.name")


  new("vglmff",
  blurb = c("Standard Wald distribution\n\n",
           "f(y) = sqrt(lambda/(2*pi*y^3)) * ",
           "exp(-lambda*(y-1)^2/(2*y)), y&lambda>0", "\n",
           "Link:     ",
           namesof("lambda", llambda, earg = elambda), "\n",
           "Mean:     ", "1\n",
           "Variance: 1 / lambda"),
  infos = eval(substitute(function(...) {
    list(M1 = 1,
         Q1 = 1,
         expected = TRUE,
         multipleResponses = FALSE,
         parameters.names = c("lambda"),
         llambda = .llambda )
  }, list( .llambda = llambda ))),

  initialize = eval(substitute(expression({

    w.y.check(w = w, y = y,
              Is.positive.y = TRUE,
              ncol.w.max = 1,
              ncol.y.max = 1)


    predictors.names <-
      namesof("lambda", .llambda , earg = .elambda , short = TRUE)


    if (!length(etastart)) {
      initlambda <- if (length( .ilambda )) .ilambda else
                    1 / (0.01 + (y-1)^2)
      initlambda <- rep_len(initlambda, n)
      etastart <-
        cbind(theta2eta(initlambda, link = .llambda ,
                        earg = .elambda ))
      }
  }), list( .llambda = llambda, .elambda = elambda,
            .ilambda = ilambda ))),
  linkinv = function(eta, extra = NULL) {
      0 * eta + 1
  },
  last = eval(substitute(expression({
    misc$link <-    c(lambda = .llambda )
    misc$earg <- list(lambda = .elambda )
  }), list( .llambda = llambda, .elambda = elambda ))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta, extra = NULL,
             summation = TRUE) {
    lambda <- eta2theta(eta, link = .llambda , earg = .elambda )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * (0.5 * log(lambda/(2*pi*y^3)) -
                lambda * (y-1)^2 / (2*y))
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .llambda = llambda, .elambda = elambda ))),
  vfamily = "waldff",
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    lambda <- eta2theta(eta, .llambda , earg = .elambda )
    okay1 <- all(is.finite(lambda)) && all(0 < lambda)
    okay1
  }, list( .llambda = llambda, .elambda = elambda ))),
  deriv = eval(substitute(expression({
    lambda <- eta2theta(eta, .llambda , earg = .elambda )
    dl.dlambda <- 0.5 / lambda + 1 - 0.5 * (y + 1/y)
    dlambda.deta <- dtheta.deta(lambda, .llambda , earg = .elambda )
    c(w) * cbind(dl.dlambda * dlambda.deta)
  }), list( .llambda = llambda, .elambda = elambda ))),
  weight = eval(substitute(expression({
    d2l.dlambda2 <- 0.5 / lambda^2
    c(w) * cbind(dlambda.deta^2 * d2l.dlambda2)
  }), list( .llambda = llambda, .elambda = elambda ))))
}  # waldff







 expexpff <-
  function(lrate = "loglink", lshape = "loglink",
           irate = NULL, ishape = 1.1,  # ishape cannot be 1
           tolerance = 1.0e-6,
           zero = NULL) {



  if (!is.Numeric(tolerance, positive = TRUE, length.arg = 1) ||
      tolerance > 1.0e-2)
    stop("bad input for argument 'tolerance'")
  if (!is.Numeric(ishape, positive = TRUE))
      stop("bad input for argument 'ishape'")

  if (length(irate) && !is.Numeric(irate, positive = TRUE))
      stop("bad input for argument 'irate'")

  ishape[ishape == 1] <- 1.1 # Fails in @deriv
  iratee <- irate


  lratee <- as.list(substitute(lrate))
  eratee <- link2list(lratee)
  lratee <- attr(eratee, "function.name")

  lshape <- as.list(substitute(lshape))
  eshape <- link2list(lshape)
  lshape <- attr(eshape, "function.name")



  new("vglmff",
  blurb = c("Exponentiated Exponential Distribution\n",
             "Links:    ",
             namesof("rate",  lratee, earg = eratee), ", ",
             namesof("shape", lshape, earg = eshape), "\n",
             "Mean:     (digamma(shape+1)-digamma(1)) / rate"),
  constraints = eval(substitute(expression({
    constraints <- cm.zero.VGAM(constraints, x = x, .zero ,
                     M = M, M1 = 2,
                     predictors.names = predictors.names)
  }), list( .zero = zero ))),
  initialize = eval(substitute(expression({

    w.y.check(w = w, y = y,
              ncol.w.max = 1,
              ncol.y.max = 1)



      predictors.names <-
        c(namesof("rate",  .lratee , earg = .eratee , short = TRUE),
          namesof("shape", .lshape , earg = .eshape , short = TRUE))


      if (!length(etastart)) {
        shape.init <- if (!is.Numeric( .ishape, positive = TRUE))
               stop("argument 'ishape' must be positive") else
               rep_len( .ishape, n)
        ratee.init <- if (length( .iratee ))
                      rep_len( .iratee , n) else
                      (digamma(shape.init+1) - digamma(1)) / (y+1/8)
        ratee.init <- rep_len(weighted.mean(ratee.init, w = w), n)
        etastart <-
          cbind(theta2eta(ratee.init, .lratee , earg = .eratee ),
                theta2eta(shape.init, .lshape , earg = .eshape ))

    }
  }), list( .lshape = lshape, .lratee = lratee,
            .iratee = iratee, .ishape = ishape,
            .eshape = eshape, .eratee = eratee))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    ratee <- eta2theta(eta[, 1], .lratee , earg = .eratee )
    shape <- eta2theta(eta[, 2], .lshape , earg = .eshape )
    (digamma(shape+1) - digamma(1)) / ratee
  }, list( .lshape = lshape, .lratee = lratee,
           .eshape = eshape, .eratee = eratee))),
  last = eval(substitute(expression({
    misc$link <-    c("rate" = .lratee , "shape" = .lshape )
    misc$earg <- list("rate" = .eratee , "shape" = .eshape )

    misc$expected <- TRUE
  }), list( .lshape = lshape, .lratee = lratee,
            .eshape = eshape, .eratee = eratee))),
  loglikelihood= eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    ratee <- eta2theta(eta[, 1], .lratee , earg = .eratee )
    shape <- eta2theta(eta[, 2], .lshape , earg = .eshape )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * (log(shape) + log(ratee) +
               (shape-1)*log1p(-exp(-ratee*y)) - ratee*y)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .lratee = lratee, .lshape = lshape,
           .eshape = eshape, .eratee = eratee))),
  vfamily = c("expexpff"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    ratee <- eta2theta(eta[, 1], .lratee , earg = .eratee )
    shape <- eta2theta(eta[, 2], .lshape , earg = .eshape )
    okay1 <- all(is.finite(ratee)) && all(0 < ratee) &&
             all(is.finite(shape)) && all(0 < shape)
    okay1
  }, list( .lratee = lratee, .lshape = lshape,
           .eshape = eshape, .eratee = eratee))),
  deriv = eval(substitute(expression({
    ratee <- eta2theta(eta[, 1], .lratee , earg = .eratee )
    shape <- eta2theta(eta[, 2], .lshape , earg = .eshape )

    dl.dratee <- 1/ratee +
                 (shape-1)*y*exp(-ratee*y)/(-expm1(-ratee*y))-y
    dl.dshape <- 1/shape + log1p(-exp(-ratee*y))

    dratee.deta <- dtheta.deta(ratee, .lratee , earg = .eratee )
    dshape.deta <- dtheta.deta(shape, .lshape , earg = .eshape )

    c(w) * cbind(dl.dratee * dratee.deta,
                 dl.dshape * dshape.deta)
  }), list( .lshape = lshape, .lratee = lratee,
            .eshape = eshape, .eratee = eratee))),
  weight = eval(substitute(expression({
    d11 <- 1 / shape^2  # True for all shape
    d22 <- d12 <- rep_len(NA_real_, n)
    index2 <- abs(shape - 2) > .tolerance  # index2 = shape != 1
    largeno <- 10000
    if (any(index2)) {
      Shape <- shape[index2]
      Shape[abs(Shape-1) < .tolerance] <- 1.001
      Scale <- ratee[index2]
      tmp200 <- trigamma(1) - trigamma(Shape-1) +
          (digamma(Shape-1)-
           digamma(1))^2  # Fails when Shape == 1
      tmp300 <- trigamma(1) - digamma(Shape)+
               (digamma(Shape)-digamma(1))^2
      d22[index2] <- (1 + Shape * (Shape - 1)*
                      tmp200 / (Shape - 2)) / Scale^2 +
                     Shape*tmp300 / Scale^2
    }
    if (any(!index2)) {
      Scale <- ratee[!index2]
      d22[!index2] <- (1 + 4 * sum(1 / (2 +
                      (0:largeno))^3)) / Scale^2
    }

    index1 <- abs(shape - 1) > .tolerance  # index1 <- shape != 1
    if (any(index1)) {
      Shape <- shape[index1]
      Scale <- ratee[index1]
      d12[index1] <- -(Shape * (digamma(Shape) -
                                digamma(1)) / (Shape - 1) -
                      digamma(Shape + 1) + digamma(1)) / Scale
    }
    if (any(!index1)) {
      Scale <- ratee[!index1]
      d12[!index1] <- -sum(1/(2 + (0:largeno))^2) / Scale
    }
    wz <- matrix(0, n, dimm(M))
    wz[, iam(1, 1, M)] <- dratee.deta^2 * d22
    wz[, iam(1, 2, M)] <- dratee.deta * dshape.deta * d12
    wz[, iam(2, 2, M)] <- dshape.deta^2 * d11
      c(w) * wz
  }), list( .tolerance = tolerance ))))
}  # expexpff






 expexpff1 <-
  function(lrate = "loglink",
           irate = NULL,
           ishape = 1) {

  lrate <- as.list(substitute(lrate))
  erate <- link2list(lrate)
  lrate <- attr(erate, "function.name")


  if (length(irate) && !is.Numeric(irate, positive = TRUE))
      stop("bad input for argument 'irate'")



  new("vglmff",
  blurb = c("Exponentiated Exponential Distribution",
            " (profile likelihood estimation)\n",
            "Links:    ",
            namesof("rate", lrate, earg = erate), "\n",
            "Mean:     (digamma(shape+1)-digamma(1)) / rate"),
  initialize = eval(substitute(expression({

    w.y.check(w = w, y = y,
              ncol.w.max = 1,
              ncol.y.max = 1)




    predictors.names <-
      namesof("rate", .lrate , earg = .erate , short = TRUE)

    if (length(w) != n ||
        !is.Numeric(w, integer.valued = TRUE, positive = TRUE))
      stop("argument 'weights' must be a vector ",
           "of positive integers")

    if (!intercept.only)
      stop("this family function only works for an ",
           "intercept-only, i.e., y ~ 1")
    extra$yvector <- y
    extra$sumw <- sum(w)
    extra$w <- w

    if (!length(etastart)) {
      shape.init <- if (!is.Numeric( .ishape, positive = TRUE))
             stop("argument 'ishape' must be positive") else
             rep_len( .ishape , n)
      rateinit <- if (length( .irate )) rep_len( .irate , n) else
                  (digamma(shape.init+1) - digamma(1)) / (y+1/8)
      etastart <- cbind(theta2eta(rateinit, .lrate , .erate ))
    }
  }), list( .lrate = lrate, .irate = irate, .ishape = ishape,
            .erate = erate))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    rate <- eta2theta(eta, .lrate , earg = .erate )
    temp7 <-  -expm1(-rate*extra$yvector)
    shape <- -extra$sumw / sum(extra$w*log(temp7))  # \gamma(\theta)
    (digamma(shape+1)-digamma(1)) / rate
  }, list( .lrate = lrate,
           .erate = erate))),
  last = eval(substitute(expression({
    misc$link <-    c("rate" = .lrate)
    misc$earg <- list("rate" = .erate )

    temp7 <-  -expm1(-rate*y)
    shape <- -extra$sumw / sum(w*log(temp7))  # \gamma(\theta)
    misc$shape <- shape   # Store the ML estimate here
    misc$pooled.weight <- pooled.weight
  }), list( .lrate = lrate, .erate = erate))),
  loglikelihood= eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    rate <- eta2theta(eta, .lrate , earg = .erate )
    temp7 <-  -expm1(-rate*y)
    shape <- -extra$sumw / sum(w*log(temp7))  # \gamma(\theta)
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <-
        c(w) * (log(shape) + log(rate) +
               (shape-1)*log1p(-exp(-rate*y)) - rate*y)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .lrate = lrate, .erate = erate))),
  vfamily = c("expexpff1"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    rate <- eta2theta(eta, .lrate , earg = .erate )
    okay1 <- all(is.finite(rate)) && all(0 < rate)
    okay1
  }, list( .lrate = lrate, .erate = erate))),
  deriv = eval(substitute(expression({
    rate <- eta2theta(eta, .lrate , earg = .erate )

    temp6 <- exp(-rate*y)
    temp7 <- 1-temp6  # Could use -expm1(-rate*y)
    shape <- -extra$sumw / sum(w*log(temp7))  # \gamma(\theta)
    d1 <- 1/rate + (shape-1)*y*temp6/temp7 - y

    c(w) * cbind(d1 * dtheta.deta(rate, .lrate , earg = .erate ))
  }), list( .lrate = lrate, .erate = erate))),
  weight = eval(substitute(expression({
    d11 <- 1/rate^2  + y*(temp6/temp7^2) * ((shape-1) *
           (y*temp7+temp6) - y*temp6 / (log(temp7))^2)

    wz <- matrix(0, n, dimm(M))
    wz[, iam(1, 1, M)] <-
      dtheta.deta(rate, .lrate , earg = .erate )^2 * d11 -
      d2theta.deta2(rate, .lrate , earg = .erate ) * d1

    if (FALSE && intercept.only) {
      sumw <- sum(w)
      for (ii in 1:ncol(wz))
          wz[, ii] <- sum(wz[, ii]) / sumw
      pooled.weight <- TRUE
      wz <- c(w) * wz   # Put back the weights
    } else
      pooled.weight <- FALSE
    c(w) * wz
  }), list( .lrate = lrate, .erate = erate))))
}  # expexpff1










 logistic <-
  function(llocation = "identitylink",
           lscale = "loglink",
           ilocation = NULL, iscale = NULL,
           imethod = 1, zero = "scale") {

  ilocat <- ilocation


  if (!is.Numeric(imethod, length.arg = 1,
                  integer.valued = TRUE, positive = TRUE) ||
      imethod > 2)
    stop("argument 'imethod' must be 1 or 2")


  if (length(iscale) && !is.Numeric(iscale, positive = TRUE))
    stop("bad input for argument 'iscale'")



  llocat <- as.list(substitute(llocation))
  elocat <- link2list(llocat)
  llocat <- attr(elocat, "function.name")

  lscale <- as.list(substitute(lscale))
  escale <- link2list(lscale)
  lscale <- attr(escale, "function.name")



  new("vglmff",
  blurb = c("Two-parameter logistic distribution\n\n",
            "Links:    ",
            namesof("location", llocat, earg = elocat), ", ",
            namesof("scale",    lscale, earg = escale),
            "\n", "\n",
            "Mean:     location", "\n",
            "Variance: (pi * scale)^2 / 3"),
  constraints = eval(substitute(expression({
    dotzero <- .zero
    M1 <- 2

    Q1 <- 1

    eval(negzero.expression.VGAM)
  }), list( .zero = zero ))),

  infos = eval(substitute(function(...) {
    list(M1 = 2,
         Q1 = 1,
         dpqrfun = "logis",
         multipleResponses = TRUE,
         expected = TRUE,
         zero = .zero )
  }, list( .zero = zero ))),

  rqresslot = eval(substitute(
    function(mu, y, w, eta, extra = NULL) {
      Locat <- eta2theta(eta[, c(TRUE, FALSE)], .llocat , .elocat )
      Scale <- eta2theta(eta[, c(FALSE, TRUE)], .lscale , .escale )
    scrambleseed <- runif(1)  # To scramble the seed
      qnorm(plogis(y, location = Locat, scale = Scale))
  }, list( .llocat = llocat, .lscale = lscale,
           .elocat = elocat, .escale = escale ))),

  initialize = eval(substitute(expression({


    temp5 <-
    w.y.check(w = w, y = y,
              ncol.w.max = Inf,
              ncol.y.max = Inf,
              out.wy = TRUE,
              colsyperw = 1,
              maximize = TRUE)
    w <- temp5$w
    y <- temp5$y


    ncoly <- ncol(y)
    M1 <- 2
    extra$ncoly <- ncoly
    extra$M1 <- M1
    M <- M1 * ncoly



    mynames1 <- param.names("location", ncoly, skip1 = TRUE)
    mynames2 <- param.names("scale",    ncoly, skip1 = TRUE)
    parameters.names <- c(mynames1, mynames2)[
      interleave.VGAM(M, M1 = M1)]
    predictors.names <-
      c(namesof(mynames1, .llocat , earg = .elocat , tag = FALSE),
        namesof(mynames2, .lscale , earg = .escale , tag = FALSE))[
        interleave.VGAM(M, M1 = M1)]


    if (!length(etastart)) {
      if ( .imethod == 1) {
        locat.init <- y
        scale.init <- sqrt(3) * apply(y, 2, sd) / pi
      } else {
        locat.init <- scale.init <- NULL
        for (ii in 1:ncoly) {
          locat.init <- c(locat.init, median(rep(y[, ii], w[, ii])))
          scale.init <- c(scale.init, sqrt(3) * sum(w[, ii] *
            (y[, ii] - locat.init[ii])^2) / (sum(w[, ii]) * pi))
        }
      }
      locat.init <- matrix(if (length( .ilocat )) .ilocat else
                          locat.init, n, ncoly, byrow = TRUE)
      if ( .llocat == "loglink")
        locat.init <- abs(locat.init) + 0.001


      scale.init <- matrix(if (length( .iscale )) .iscale else
                          scale.init, n, ncoly, byrow = TRUE)

      etastart <- cbind(
        theta2eta(locat.init, .llocat , earg = .elocat ),
        theta2eta(scale.init, .lscale , earg = .escale ))[,
                        interleave.VGAM(M, M1 = M1)]
    }
  }), list( .imethod = imethod,
            .elocat = elocat, .escale = escale,
            .llocat = llocat, .lscale = lscale,
            .ilocat = ilocat, .iscale = iscale ))),
  linkinv = eval(substitute(function(eta, extra = NULL) {
    M <- ncol(eta)
    M1 <- 2
    ncoly <- M / M1
    eta2theta(eta[, (1:ncoly) * M1 - 1], .llocat , earg = .elocat )
  }, list( .llocat = llocat,
           .elocat = elocat ))),

  last = eval(substitute(expression({
    M1 <- extra$M1
    misc$link <- c(rep_len( .llocat , ncoly),
                   rep_len( .lscale , ncoly))[
        interleave.VGAM(M, M1 = M1)]
    temp.names <- c(mynames1, mynames2)[
                    interleave.VGAM(M, M1 = M1)]
    names(misc$link) <- temp.names

    misc$earg <- vector("list", M)
    names(misc$earg) <- temp.names
    for (ii in 1:ncoly) {
      misc$earg[[M1*ii-1]] <- .elocat
      misc$earg[[M1*ii  ]] <- .escale
    }

    misc$M1 <- M1
    misc$imethod <- .imethod
    misc$expected <- TRUE
    misc$multipleResponses <- TRUE
  }), list( .imethod = imethod,
             .llocat = llocat, .lscale = lscale,
             .elocat = elocat, .escale = escale))),
  loglikelihood = eval(substitute(
    function(mu, y, w, residuals = FALSE, eta,
             extra = NULL,
             summation = TRUE) {
    M <- ncol(eta)
    M1 <- 2
    ncoly <- M / M1

    locat <- eta2theta(eta[, (1:ncoly)*M1-1], .llocat ,
                       earg = .elocat )
    Scale <- eta2theta(eta[, (1:ncoly)*M1  ], .lscale ,
                       earg = .escale )
    if (residuals) {
      stop("loglikelihood residuals not implemented yet")
    } else {
      ll.elts <- c(w) * dlogis(x = y, location = locat,
                               scale = Scale, log = TRUE)
      if (summation) {
        sum(ll.elts)
      } else {
        ll.elts
      }
    }
  }, list( .llocat = llocat, .lscale = lscale,
           .elocat = elocat, .escale = escale))),
  vfamily = c("logistic"),
  validparams = eval(substitute(function(eta, y, extra = NULL) {
    M1 <- 2; M <- NCOL(eta)
    ncoly <- M / M1
    locat <- eta2theta(eta[, (1:ncoly)*M1-1], .llocat ,
                       earg = .elocat )
    Scale <- eta2theta(eta[, (1:ncoly)*M1  ], .lscale ,
                       earg = .escale )
    okay1 <- all(is.finite(locat)) &&
             all(is.finite(Scale)) && all(0 < Scale)
    okay1
  }, list( .llocat = llocat, .lscale = lscale,
           .elocat = elocat, .escale = escale))),



  simslot = eval(substitute(
  function(object, nsim) {

    pwts <- if (length(pwts <- object@prior.weights) > 0)
              pwts else weights(object, type = "prior")
    if (any(pwts != 1))
      warning("ignoring prior weights")
    eta <- predict(object)
    locat <- eta2theta(eta[, c(TRUE, FALSE)], .llocat ,
                       earg = .elocat )
    Scale <- eta2theta(eta[, c(FALSE, TRUE)], .lscale ,
                       earg = .escale )
    rlogis(nsim * length(Scale),
           location = locat, scale = Scale)
  }, list( .llocat = llocat, .lscale = lscale,
           .elocat = elocat, .escale = escale))),



  deriv = eval(substitute(expression({
    M1 <- 2
    ncoly <- M / M1

    locat <- eta2theta(eta[, (1:ncoly)*M1-1], .llocat ,
                       earg = .elocat )
    Scale <- eta2theta(eta[, (1:ncoly)*M1  ], .lscale ,
                       earg = .escale )

    zedd <- (y - locat) / Scale
    ezedd <- exp(-zedd)
    dl.dlocat <- (-expm1(-zedd)) / ((1 + ezedd) * Scale)
    dl.dscale <-  zedd * (-expm1(-zedd)) / ((1 + ezedd) * Scale) -
                 1 / Scale

    dlocat.deta <- dtheta.deta(locat, .llocat , earg = .elocat )
    dscale.deta <- dtheta.deta(Scale, .lscale , earg = .escale )

    myderiv <-
    c(w) * cbind(dl.dlocat * dlocat.deta,
                 dl.dscale * dscale.deta)
    myderiv[, interleave.VGAM(M, M1 = M1)]
  }), list( .llocat = llocat, .lscale = lscale,
            .elocat = elocat, .escale = escale))),
  weight = eval(substitute(expression({
    ned2l.dlocat2 <- 1 / (3 * Scale^2)
    ned2l.dscale2 <- (3 + pi^2) / (9 * Scale^2)

    wz <- matrix(NA_real_, nrow = n, ncol = M)  # diagonal
    wz[, (1:ncoly) * M1 - 1] <- ned2l.dlocat2 * dlocat.deta^2
    wz[, (1:ncoly) * M1    ] <- ned2l.dscale2 * dscale.deta^2

    w.wz.merge(w = w, wz = wz, n = n, M = M, ndepy = ncoly)
  }), list( .llocat = llocat, .lscale = lscale,
            .elocat = elocat, .escale = escale))))
}  # logistic