version 1.4.0

ChangeLog

@@ -1,3 +1,8 @@
+Changes in version 1.4.0
+  * Refactored the code to better align generic function names with responsibilities.
+  * Revised the vignette.
+  * Edited the description file.
+
 Changes in version 1.3.0
   * Added the coef function for producing context-dependent, pseudo-coefficient plots.
   * Added utility function coda_wrapper to allow easier use of the MCMC diagnostic functions in coda.

DESCRIPTION

@@ -1,10 +1,10 @@
 Package: DBR
 Type: Package
 Title: Discrete Beta Regression
-Version: 1.3.0
-Date: 2022-07-17
+Version: 1.4.0
+Date: 2022-08-06
 Authors@R: c(person("Alireza", "Mahani", email = "alireza.s.mahani@gmail.com", role = c("cre", "aut"))
-  , person("Mansour", "Sharabiani", role = "aut")) 
+  , person("Mansour", "Sharabiani", role = "aut"), person("Alex", "Bottle", role = "aut"), person("Cathy", "Price", role = "aut")) 
 Description: Bayesian Beta Regression, adapted for bounded discrete responses, commonly seen in survey responses.
   Estimation is done via Markov Chain Monte Carlo sampling, using a Gibbs wrapper around univariate slice sampler 
   (Neal (2003) <DOI:10.1214/aos/1056562461>), as implemented in the R package MfUSampler 
@@ -13,9 +13,11 @@ License: GPL (>= 2)
 Depends: R (>= 3.5.0)
 Imports: MfUSampler, methods, coda
 NeedsCompilation: no
-Packaged: 2022-07-18 02:21:43 UTC; ubuntu
+Packaged: 2022-08-06 19:50:16 UTC; ubuntu
 Author: Alireza Mahani [cre, aut],
-  Mansour Sharabiani [aut]
+  Mansour Sharabiani [aut],
+  Alex Bottle [aut],
+  Cathy Price [aut]
 Maintainer: Alireza Mahani <alireza.s.mahani@gmail.com>
 Repository: CRAN
-Date/Publication: 2022-07-18 13:10:17 UTC
+Date/Publication: 2022-08-06 20:20:02 UTC

MD5

@@ -1,30 +1,23 @@
-d9d06e4b5377d9f83159a659250a4443 *ChangeLog
-e6eeed5f588d0ebfcef4ddf7f1d9c960 *DESCRIPTION
-23fcf9945b1533a13c4cf53f30a4c19c *NAMESPACE
-8ec7d0d781401f0302aa47d765127b36 *R/aaa.R
-ee1c01b9123146be0765930f2e7bbf11 *R/dbr.R
+b71dd974276708c00416566755bda18c *ChangeLog
+49abe3c989f1295686c0e7cfcdf9a69f *DESCRIPTION
+2a42e77c382436e705fff6279b03323f *NAMESPACE
+b4f6a9742aad2fdaee9f3b125f7afdae *R/aaa.R
+b8206ffc8876ce1fe2cb977008eb981f *R/dbr.R
+8f13b327a88263316cac7d0722fb1cc1 *R/dbr2.R
 1afb452c834312440542bb2dc706bbc7 *R/util.R
-2ac330aadbe273ffee255f639ee3af1a *build/vignette.rds
+eef0e2da75ec2ec7f28f706e79b3e9a6 *build/vignette.rds
 e68e4d13b55b0e0b9491a22b018a647a *data/pain.csv.gz
-ee3591d186e43f947467680c8c1b29e9 *inst/doc/DBR.R
-58fa16b2206fcca215113b06cdbcb88b *inst/doc/DBR.Rnw
-1f57dddfae28f421d5cd4e615f8e8b29 *inst/doc/DBR.pdf
+32d1a8afc79fb543539676e0c1c3b19c *inst/doc/DBR.R
+275a05c96b164ce76ad7c9302145c713 *inst/doc/DBR.Rnw
+95d1771b496a2fe5bfe7766b81973391 *inst/doc/DBR.pdf
 f4619284db8f57ae5664c38c4daa2eee *man/coda_wrapper.Rd
 84213146f6846fcf763bf9a8fe408a3f *man/dbr.Rd
 f6c3125a351dbe8a57fb39789541c7a8 *man/pain.Rd
 297dc6aff931714849634ee9bb790020 *man/predict_dbr.Rd
-faec97909fa40259a33ecf70f5be16a2 *man/summary_dbr.Rd
-58fa16b2206fcca215113b06cdbcb88b *vignettes/DBR.Rnw
-a4683bdd5e74db57c67131665551abf5 *vignettes/DBR.bib
-f23878b317aef1f1d3bc891ef3d56b5f *vignettes/coef_dbr_long.pdf
-b2dc7b437f1af8af1eb8d737ce1aa95e *vignettes/coef_dbr_long.rds
-d5249be25b8d0d558d98ca4305e46547 *vignettes/est_dbr_long.rds
-b183c51a4f58db8ce2b69f6d8ca6e575 *vignettes/est_dbr_short.rds
-fc32d3500ea569d80bad8acc076d7b41 *vignettes/hist_interference.pdf
-b39d815f578f6ac9f65b556629ebf8e0 *vignettes/pred_dbr_point_hist.pdf
-7998b0f58a4079dce3406d1fd257c18d *vignettes/pred_point.rds
-14d08f422d83eaac7d421a2270f09475 *vignettes/pred_sample.rds
-d4c5a6ef979fe89c9762534e7e652ae7 *vignettes/summary_dbr_long.pdf
-47ee5b31ec2cb477f7a825fccb59476e *vignettes/summary_dbr_long.txt
-3e3748cf83ec973f59c456548e2b0fba *vignettes/summary_dbr_short.pdf
-cd244b27a308e755f6900aaca59a99f9 *vignettes/summary_dbr_short.txt
+414afcf14aaf040753cd9b39b58fc3c7 *man/summary_dbr.Rd
+275a05c96b164ce76ad7c9302145c713 *vignettes/DBR.Rnw
+0d7c675bcff3d975ed1f9df02607636b *vignettes/DBR.bib
+5b3bfb60a4fb8025d4f15081af56293d *vignettes/est_2.rds
+a5a2aa316dc8efc5a6966d7a39d04cdd *vignettes/plot_1.pdf
+efdc5aee40e5c80884772affee13069a *vignettes/plot_2.pdf
+2b65a35ae30f00bf95aa5c341ff8ede1 *vignettes/summary_est_2.pdf

NAMESPACE

@@ -5,6 +5,7 @@ S3method("summary", "dbr")
 S3method("predict", "dbr")
 S3method("print", "dbr")
 S3method("coef", "dbr")
+S3method("plot", "dbr")
 
 importFrom("MfUSampler", "MfU.Sample.Run", "MfU.Control")
 importFrom("methods", "new")

R/aaa.R

@@ -2,5 +2,5 @@
   RFver <- read.dcf(file=system.file("DESCRIPTION", package=pkgname),
                     fields="Version")
   packageStartupMessage(paste(pkgname, RFver))
-  packageStartupMessage("Discretized Beta Regression for Survey-Response Analysis")
+  packageStartupMessage("Bayesian Discretized Beta Regression for the Analysis of Ratings Data")
 }

R/dbr.R

@@ -357,12 +357,13 @@ dbr <- function(
     , data = data
   )
   class(ret) <- c("dbr", class(ret))
+  #class(ret) <- c("dbr2", class(ret))
 
   return (ret)
 
 }
 
-predict.dbr <- function(
+predict.dbr2 <- function(
   object
   , newdata = NULL
   , type = c("sample", "point")
@@ -378,7 +379,7 @@ predict.dbr <- function(
           , ...)
 }
 
-summary.dbr <- function(
+summary.dbr2 <- function(
   object
   , prob = c(0.025, 0.5, 0.975)
   , make_plot = TRUE
@@ -398,14 +399,14 @@ summary.dbr <- function(
   return(ret)
 }
 
-print.dbr <- function(x, make_plot = FALSE, ...) {
+print.dbr2 <- function(x, make_plot = FALSE, ...) {
   cat("formula:\n")
   print(x$formula)
   cat("coefficient estimates:\n")
   print(summary(x, make_plot = make_plot, ...))
 }
 
-coef.dbr <- function(object, context, make_plot = TRUE, ...) {
+coef.dbr2 <- function(object, context, make_plot = TRUE, ...) {
   # if context not specified, designate first row in training data as context
   if (missing(context)) {
     context <- object$data[1, ]
@@ -415,7 +416,7 @@ coef.dbr <- function(object, context, make_plot = TRUE, ...) {
   response <- all.vars(object$formula)[1]
   unique_predictors <- all.vars(object$formula)[-1]
   predictor_classes <- sapply(unique_predictors, function(x) {
-    class(object$data[, x])
+    class(object$data[[x]])
   })
   nPred <- length(unique_predictors)
 
@@ -450,11 +451,13 @@ coef.dbr <- function(object, context, make_plot = TRUE, ...) {
       predDF <- context[rep(1, nx), unique_predictors]
       predDF[, my_predictor] <- xvec
       yvec <- predict(object = object, newdata = predDF, type = "point")
-      plot(xvec, yvec
-           , main = paste0("mean predicted ", response, " vs. ", my_predictor)
-           , ylab = response
-           , xlab = my_predictor, type = "l", pch = 4
-           , ylim = range(object$yunique))
+      if (make_plot) {
+        plot(xvec, yvec
+             , main = paste0("mean predicted ", response, " vs. ", my_predictor)
+             , ylab = response
+             , xlab = my_predictor, type = "l", pch = 4
+             , ylim = range(object$yunique))
+      }
       return (list(X = predDF, y = yvec))
     } else {
       return (NULL)

R/dbr2.R

@@ -0,0 +1,100 @@
+predict.dbr <- function(
+  object
+  , newdata = NULL
+  , type = c("sample", "point")
+  , ...) {
+  type <- match.arg(type)
+
+  if (is.null(newdata)) newdata <- object$data
+  predict(object$est, newdata = newdata, type = type
+          , ...)
+}
+
+print.dbr <- function(x, ...) {
+  cat("formula:\n")
+  print(x$formula)
+}
+
+plot.dbr <- function(x, ...) {
+  est <- x$est@learners[[2]]@est
+  plot(est$smp, ask = FALSE)
+  plot(est$loglike, type = "l", xlab = "iteration", ylab = "log-like")
+
+  return (NULL)
+}
+
+coef.dbr <- function(
+  object
+  , prob = c(0.025, 0.5, 0.975)
+  , ...) {
+  est <- object$est@learners[[2]]@est
+  nsmp <- object$control$nsmp
+  nburnin <- object$control$nburnin
+  ret <- apply(est$smp[nburnin + 1:(nsmp - nburnin), ], 2, quantile, prob = prob)
+  return(ret)
+}
+
+summary.dbr <- function(object, context, make_plot = TRUE, ...) {
+  if (missing(context)) {
+    context <- object$data[1, ]
+  }
+
+  # get list of unique predictors and their classes
+  response <- all.vars(object$formula)[1]
+  unique_predictors <- all.vars(object$formula)[-1]
+  predictor_classes <- sapply(unique_predictors, function(x) {
+    class(object$data[[x]])
+  })
+  nPred <- length(unique_predictors)
+
+  # for each unique predictor:
+  # create vector of values --> prediction dataframe
+  # plot results
+  # logic for creating vector of values:
+  # numeric: use min/max from training data, resolution from default
+  # integer: use min/max from training data, use increment of 1
+  # logical: T/F
+  # factor: training data, get levels
+  ret <- lapply(1:nPred, function(n) {
+    my_predictor <- unique_predictors[n]
+    my_class <- predictor_classes[n]
+    x_data <- object$data[, my_predictor]
+    if (my_class == "numeric") {
+      xvec <- seq(from = min(x_data), to = max(x_data), length.out = 10)
+    } else if (my_class == "integer") {
+      xvec <- seq(from = min(x_data), to = max(x_data), by = 1)
+    } else if (my_class == "logical") {
+      xvec <- c(FALSE, TRUE)
+    } else if (my_class == "factor") {
+      warning("support for factor predictors in 'coef' coming soon")
+      xvec <- NULL
+    } else {
+      warning("unexpected predictor class: ", my_class)
+      xvec <- NULL
+    }
+
+    nx <- length(xvec)
+    if (nx > 0) {
+      predDF <- context[rep(1, nx), unique_predictors]
+      predDF[, my_predictor] <- xvec
+      yvec <- predict(object = object, newdata = predDF, type = "point")
+      if (make_plot) {
+        plot(xvec, yvec
+             , main = paste0("mean predicted ", response, " vs. ", my_predictor)
+             , ylab = response
+             , xlab = my_predictor, type = "l", pch = 4
+             , ylim = range(object$yunique))
+      }
+      return (list(X = predDF, y = yvec))
+    } else {
+      return (NULL)
+    }
+
+  })
+
+  names(ret) <- unique_predictors
+
+  ret
+
+}
+