Merge branch 'issue-112' into develop

* issue-112:
  Updated NEWS.md (#112)
  Increment version number to 1.1.1.9024
  Using implicit return behavior (#112)

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: TruncExpFam
 Title: Truncated Exponential Family
-Version: 1.1.1.9023
+Version: 1.1.1.9024
 Date: 2024-02-26
 Authors@R:
 	c(

NEWS.md

@@ -1,7 +1,7 @@
 # TruncExpFam (development version)
 
 * Implemented `ptrunc()` and `qtrunc()` for all distributions (issue #54)
-* Refactoring (issue #104)
+* Refactoring (issue #104, #112)
 * Fixed bugs related to using the Negative Binomial with `mu` instead of `prob` (issue #107)
 * Fixed domain validation on Negative Binomial and Inverse Gamma
 * Added domain validation to `rtrunc(..., faster = TRUE)` (issue #109)

R/attachDistroAttributes.R

@@ -5,5 +5,5 @@ attachDistroAttributes <- function(sample, family, parms) {
     attr(sample, "truncation_limits") <- parms[c("a", "b")]
     attr(sample, "continuous") <- family_attributes$cont
   }
-  return(sample)
+  sample
 }

R/averageT.R

@@ -10,5 +10,4 @@ averageT <- function(y) {
   } else {
     out <- colMeans(Ty)
   }
-  return(out)
 }

R/beta.R

@@ -45,13 +45,13 @@ empiricalParameters.trunc_beta <- function(y, ...) {
   beta <- alpha * (1 / amean - 1)
   parms <- c(shape1 = alpha, shape2 = beta)
   class(parms) <- "parms_beta"
-  return(parms)
+  parms
 }
 
 #' @method sufficientT trunc_beta
 sufficientT.trunc_beta <- function(y) {
   # Calculates the sufficient statistic T(y)
-  return(suff.T = cbind(log(y), log(1 - y)))
+  suff.T <- cbind(log(y), log(1 - y))
 }
 
 #' @export
@@ -61,15 +61,14 @@ natural2parameters.parms_beta <- function(eta, ...) {
   if (length(eta) != 2) stop("Eta must be a vector of two elements")
   parms <- c(shape1 = eta[[1]], shape2 = eta[[2]])
   class(parms) <- class(eta)
-  return(parms)
+  parms
 }
 
 #' @export
 parameters2natural.parms_beta <- function(parms, ...) {
   # parms: The parameters shape and rate in a beta distribution
   # returns the natural parameters
   eta <- prepEta(c(parms[1], parms[2]), class(parms))
-  return(eta)
 }
 
 #' @method getYseq trunc_beta
@@ -82,7 +81,7 @@ getYseq.trunc_beta <- function(y, y.min = 0, y.max = 1, n = 100) {
   out <- seq(lo, hi, length = n)
   out <- out[out > 0 & out < 1] # prevents NaN as sufficient statistics
   class(out) <- class(y)
-  return(out)
+  out
 }
 
 #' @method getGradETinv parms_beta
@@ -98,5 +97,5 @@ getGradETinv.parms_beta <- function(eta, ...) {
   term.12 <- -(1 + 2 * (x + y)) / (2 * (x + y) ^ 2)
   term.2 <- (x * (x + 2 * x * y + 2 * y * (1 + y))) / (2 * y ^ 2 * (x + y) ^ 2)
   A_inv <- matrix(c(term.1, term.12, term.12, term.2), ncol = 2)
-  return(A = solve(A_inv))
+  solve(A_inv)
 }

R/binomial.R

@@ -49,12 +49,12 @@ empiricalParameters.trunc_binomial <- function(y, size, ...) {
   }
   parms <- c("size" = size, "prob" = mean(y) / size)
   class(parms) <- "parms_binomial"
-  return(parms)
+  parms
 }
 
 #' @method sufficientT trunc_binomial
 sufficientT.trunc_binomial <- function(y) {
-  return(suff.T = y)
+  suff.T <- y
 }
 
 #' @export
@@ -64,7 +64,7 @@ natural2parameters.parms_binomial <- function(eta, ...) {
   if (length(eta) != 1) stop("Eta must be one single number")
   p <- c(prob = 1 / (1 + exp(-eta[[1]])))
   class(p) <- class(eta)
-  return(p)
+  p
 }
 
 #' @export
@@ -74,7 +74,7 @@ parameters2natural.parms_binomial <- function(parms, ...) {
   prob <- parms[["prob"]]
   eta <- prepEta(log(prob / (1 - prob)), class(parms))
   attr(eta, "nsize") <- parms[["size"]]
-  return(eta)
+  eta
 }
 
 #' @method getGradETinv parms_binomial
@@ -83,7 +83,7 @@ getGradETinv.parms_binomial <- function(eta, ...) {
   # return the inverse of E.T differentiated with respect to eta
   nsize <- attr(eta, "nsize")
   exp.eta <- exp(eta)
-  return(A = ((1 + exp.eta)^2 / exp.eta) / nsize)
+  ((1 + exp.eta)^2 / exp.eta) / nsize
 }
 
 #' @method getYseq trunc_binomial

R/chisq.R

@@ -36,12 +36,12 @@ empiricalParameters.trunc_chisq <- function(y, ...) {
   # Returns empirical parameter estimate for df
   parms <- c("df" = mean(y))
   class(parms) <- "parms_chisq"
-  return(parms)
+  parms
 }
 
 #' @method sufficientT trunc_chisq
 sufficientT.trunc_chisq <- function(y) {
-  return(suff.T = log(y))
+  log(y)
 }
 
 #' @export
@@ -51,22 +51,21 @@ natural2parameters.parms_chisq <- function(eta, ...) {
   if (length(eta) != 1) stop("Eta must be one single number")
   df <- c(df = 2 * (eta[[1]] + 1))
   class(df) <- class(eta)
-  return(df)
+  df
 }
 
 #' @export
 parameters2natural.parms_chisq <- function(parms, ...) {
   # parms: The parameter lambda in a Chi Square distribution
   # returns the natural parameters
   eta <- prepEta(parms / 2 - 1, class(parms))
-  return(eta)
 }
 
 #' @method getGradETinv parms_chisq
 getGradETinv.parms_chisq <- function(eta, ...) {
   # eta: Natural parameter
   # return the inverse of E.T differentiated with respect to eta
-  return(A = 1 / sum(1 / (as.vector(eta) + (1:1e6))^2))
+  1 / sum(1 / (as.vector(eta) + (1:1e6))^2)
 }
 
 #' @method getYseq trunc_chisq

R/contbernoulli.R

@@ -17,7 +17,6 @@ rcontbern <- function(n, lambda) {
   # The inverse of the CDF for a cont. bernoulli distribution
   x <- log(1 + (2 * lambda - 1) * u / (1 - lambda)) /
     log(lambda / (1 - lambda))
-  return(x)
 }
 
 #' @param lambda mean of "parent" distribution
@@ -48,24 +47,22 @@ dcontbern <- function(x, lambda) {
   )
   d <- norm.const * (lambda^x) * (1 - lambda) ^ (1 - x)
   class(d) <- class(x)
-  return(d)
+  d
 }
 
 qcontbern <- function(p, lambda) {
   if (lambda == .5) {
     return(p)
-  } else {
-    term1 <- log(2 * lambda * p - p + 1 - lambda)
-    term2 <- log(1 - lambda)
-    term3 <- log(lambda)
-    return((term1 - term2) / (term3 - term2))
   }
+  term1 <- log(2 * lambda * p - p + 1 - lambda)
+  term2 <- log(1 - lambda)
+  term3 <- log(lambda)
+  (term1 - term2) / (term3 - term2)
 }
 
 # untruncated version (not implemented in base R)
 pcontbern <- function(x, lambda) {
   p <- ((lambda^x) * (1 - lambda) ^ (1 - x) + lambda - 1) / (2 * lambda - 1)
-  return(p)
 }
 
 #' @export
@@ -95,12 +92,12 @@ empiricalParameters.trunc_contbern <- function(y, ...) {
   # Note: lambda cannot be expressed in closed form as a function of the mean
   parms <- c("lambda" = mean(y))
   class(parms) <- "parms_contbern"
-  return(parms)
+  parms
 }
 
 #' @method sufficientT trunc_contbern
 sufficientT.trunc_contbern <- function(y) {
-  return(suff.T = y)
+  suff.T <- y
 }
 
 #' @export
@@ -110,15 +107,14 @@ natural2parameters.parms_contbern <- function(eta, ...) {
   if (length(eta) != 1) stop("Eta must be one single number")
   rate <- c(lambda = 1 / (1 + exp(-eta[[1]])))
   class(rate) <- class(eta)
-  return(rate)
+  rate
 }
 
 #' @export
 parameters2natural.parms_contbern <- function(parms, ...) {
   # parms: The parameter lambda in a continuous bernoulli distribution
   # returns the natural parameters
   eta <- prepEta(log(parms / (1 - parms)), class(parms))
-  return(eta)
 }
 
 #' @method getYseq trunc_contbern
@@ -137,5 +133,5 @@ getGradETinv.parms_contbern <- function(eta, ...) {
   # eta: Natural parameter
   # return the inverse of E.T differentiated with respect to eta
   exp.eta <- exp(eta)
-  return(A = ((exp.eta - 1) * eta)^2 / (exp.eta * (exp.eta - eta^2 + eta - 1)))
+  ((exp.eta - 1) * eta)^2 / (exp.eta * (exp.eta - eta^2 + eta - 1))
 }

R/exponential.R

@@ -37,12 +37,12 @@ empiricalParameters.trunc_exp <- function(y, ...) {
   # Returns empirical parameter estimate for the rate parameter
   parms <- c("rate" = mean(y))
   class(parms) <- "parms_exp"
-  return(parms)
+  parms
 }
 
 #' @method sufficientT trunc_exp
 sufficientT.trunc_exp <- function(y) {
-  return(suff.T = y)
+  y
 }
 
 #' @export
@@ -52,7 +52,7 @@ natural2parameters.parms_exp <- function(eta, ...) {
   if (length(eta) != 1) stop("Eta must be one single number")
   lambda <- c(rate = -eta[[1]])
   class(lambda) <- class(eta)
-  return(lambda)
+  lambda
 }
 
 #' @export
@@ -61,14 +61,14 @@ parameters2natural.parms_exp <- function(parms, ...) {
   # returns the natural parameters
   eta <- c("eta" = -parms[["rate"]])
   class(eta) <- class(parms)
-  return(eta)
+  eta
 }
 
 #' @method getGradETinv parms_exp
 getGradETinv.parms_exp <- function(eta, ...) {
   # eta: Natural parameter
   # return the inverse of E.T differentiated with respect to eta
-  return(A = eta^2)
+  eta^2
 }
 
 #' @method getYseq trunc_exp

R/gamma.R

@@ -53,12 +53,12 @@ empiricalParameters.trunc_gamma <- function(y, ...) {
   shp <- amean^2 / avar
   parms <- c(shape = shp, rate = shp / amean)
   class(parms) <- "parms_gamma"
-  return(parms)
+  parms
 }
 
 #' @method sufficientT trunc_gamma
 sufficientT.trunc_gamma <- function(y) {
-  return(suff.T = cbind(log(y), y))
+  suff.T <- cbind(log(y), y)
 }
 
 #' @export
@@ -68,7 +68,7 @@ natural2parameters.parms_gamma <- function(eta, ...) {
   if (length(eta) != 2) stop("Eta must be a vector of two elements")
   parms <- c("shape" = eta[[1]] + 1, "rate" = -eta[[2]])
   class(parms) <- class(eta)
-  return(parms)
+  parms
 }
 
 #' @export
@@ -81,7 +81,7 @@ parameters2natural.parms_gamma <- function(parms, ...) {
     eta <- c(eta1 = parms[["shape"]] - 1, eta2 = -1 / parms[["scale"]])
   }
   class(eta) <- class(parms)
-  return(eta)
+  eta
 }
 
 #' @method getYseq trunc_gamma
@@ -112,5 +112,5 @@ getGradETinv.parms_gamma <- function(eta, ...) {
     ),
     ncol = 2
   )
-  return(A = solve(A_inv))
+  A <- solve(A_inv)
 }

R/inverse-gamma.R

@@ -50,12 +50,12 @@ empiricalParameters.trunc_invgamma <- function(y, ...) {
   beta <- (alpha - 1) * amean
   parms <- c(shape = alpha, rate = beta)
   class(parms) <- "parms_invgamma"
-  return(parms)
+  parms
 }
 
 #' @method sufficientT trunc_invgamma
 sufficientT.trunc_invgamma <- function(y) {
-  return(suff.T = cbind(log(y), 1 / y))
+  cbind(log(y), 1 / y)
 }
 
 #' @export
@@ -65,7 +65,7 @@ natural2parameters.parms_invgamma <- function(eta, ...) {
   if (length(eta) != 2) stop("Eta must be a vector of two elements")
   parms <- c("shape" = -eta[[1]] - 1, "rate" = -eta[[2]])
   class(parms) <- class(eta)
-  return(parms)
+  parms
 }
 
 #' @export
@@ -74,7 +74,7 @@ parameters2natural.parms_invgamma <- function(parms, ...) {
   # returns the natural parameters
   eta <- c(eta1 = -parms[[1]] - 1, eta2 = -parms[[2]])
   class(eta) <- class(parms)
-  return(eta)
+  eta
 }
 
 #' @method getYseq trunc_invgamma
@@ -97,5 +97,5 @@ getGradETinv.parms_invgamma <- function(eta, ...) {
   A.22 <- sum((0:10000 + eta[1] + 1) / eta[2]^2)
   A.12 <- -1 / eta[2]
   inv_A <- matrix(c(A.11, A.12, A.12, A.22), ncol = 2)
-  return(A = solve(inv_A))
+  solve(inv_A)
 }

R/inverse-gaussian.R

@@ -41,12 +41,12 @@ empiricalParameters.trunc_invgauss <- function(y, ...) {
   lambda <- mean ^ 3 / sd ^ 2
   parms <- c(m = mean, s = 1 / lambda)
   class(parms) <- "parms_invgauss"
-  return(parms)
+  parms
 }
 
 #' @method sufficientT trunc_invgauss
 sufficientT.trunc_invgauss <- function(y) {
-  return(suff.T = cbind(y, 1 / y))
+  cbind(y, 1 / y)
 }
 
 #' @export
@@ -57,7 +57,7 @@ parameters2natural.parms_invgauss <- function(parms, ...) {
   lambda <- 1 / parms[["s"]]
   eta <- c(eta1 = -lambda / (2 * mu ^ 2), eta2 = -lambda / 2)
   class(eta) <- class(parms)
-  return(eta)
+  eta
 }
 
 #' @export
@@ -69,7 +69,7 @@ natural2parameters.parms_invgauss <- function(eta, ...) {
   lambda <- -2 * eta[[2]]
   parms <- c(m = mu, s = 1 / lambda)
   class(parms) <- class(eta)
-  return(parms)
+  parms
 }
 
 #' @method getYseq trunc_invgauss
@@ -93,5 +93,5 @@ getGradETinv.parms_invgauss <- function(eta, ...) {
   mx_21 <- mx_12
   mx_22 <- (1 - eta[1] * sqrt(eta[2] / eta[1])) / (eta[2] ^ 2)
   A_inv <- 0.5 * matrix(c(mx_11, mx_12, mx_21, mx_22), ncol = 2)
-  return(A = solve(A_inv))
+  A <- solve(A_inv)
 }