├── R ├── .Rhistory ├── .Rapp.history ├── qhist.R ├── phist.R ├── exponential.error.R ├── beta.error.R ├── lognormal.error.R ├── SHELF-package.R ├── gamma.error.R ├── logt.error.R ├── tError.R ├── dhist.R ├── histdensity.R ├── qlinearpool.R ├── normal.error.R ├── deprecatedFunctions.R ├── rlinearpool.R ├── makeQuartilePlot.R ├── makeTertilePlot.R ├── makeGroupPlot.R ├── multiplot.R ├── generateReport.R ├── feedbackgroup.R ├── checkJudgementsValid.R ├── expertquantiles.R ├── expertprobs.R ├── compareExperts.R ├── expertdensity.R ├── plotQuartiles.R ├── plotTertiles.R ├── plinearpool.R ├── cdfplot.R ├── feedback.R ├── linearPoolDensity.R ├── sampleFit.R ├── cdfHelperfunctions.R ├── makeSurvivalTable.R ├── elicitMarginalsModule.R ├── elicitCopula.R ├── pdfplots.R ├── cdffeedback.R └── makeLinearPoolPlot.R ├── tests ├── testthat.R └── testthat │ ├── test-copula-sampling.R │ ├── test-dirichlet.R │ ├── test-survival-extrapolation.R │ ├── _snaps │ └── plots │ │ ├── error-message-plot.svg │ │ └── compare-interval-plot.svg │ ├── test-extension-method.R │ ├── test-plots.R │ └── test-linearpool.R ├── inst ├── elicitationReportFile │ └── elicitationSummary.Rmd └── shinyAppFiles │ ├── elicitationShinySummary.Rmd │ ├── DirichletShinySummary.Rmd │ ├── helpBivariate.html │ ├── DirichletHelp.html │ ├── elicitationShinySummaryExtensionUploadedYsample.Rmd │ ├── elicitationShinySummaryExtension.Rmd │ ├── elicitationShinySummaryBivariate.Rmd │ └── help.html ├── man ├── elicitDirichlet.Rd ├── sampleFit.Rd ├── feedbackDirichlet.Rd ├── elicitMixture.Rd ├── elicitMultiple.Rd ├── elicitExtension.Rd ├── SHELF-package.Rd ├── elicitSurvivalExtrapolation.Rd ├── elicitBivariate.Rd ├── plotQuartiles.Rd ├── generateReport.Rd ├── plotTertiles.Rd ├── compareIntervals.Rd ├── plotConditionalMedianFunction.Rd ├── cdfplot.Rd ├── elicit.Rd ├── makeSurvivalTable.Rd ├── linearPoolDensity.Rd ├── sampleMarginalFit.Rd ├── pdfplots.Rd ├── plinearpool.Rd ├── compareGroupRIO.Rd ├── copulaSample.Rd ├── makeCDFPlot.Rd ├── plotConditionalDensities.Rd ├── survivalScenario.Rd ├── elicitHeterogen.Rd ├── feedback.Rd ├── fitDirichlet.Rd ├── cdffeedback.Rd ├── survivalModelExtrapolations.Rd ├── fitprecision.Rd ├── survivalExtrapolatePlot.Rd └── plotfit.Rd ├── NAMESPACE ├── DESCRIPTION └── vignettes ├── Dirichlet-elicitation.Rmd └── SHELF-overview.Rmd /R/.Rhistory: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /R/.Rapp.history: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /R/qhist.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | qhist<-function(q, z, pz){ 5 | approx(pz, z, q)$y 6 | } -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(SHELF) 3 | 4 | test_check("SHELF") 5 | 6 | -------------------------------------------------------------------------------- /R/phist.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | phist<-function(x, z, pz){ 4 | z<-c(-exp(100), z, exp(100)) 5 | pz<-c(0, pz, 1) 6 | approx(z, pz, x)$y 7 | } 8 | 9 | -------------------------------------------------------------------------------- /R/exponential.error.R: -------------------------------------------------------------------------------- 1 | exponential.error <- 2 | function(parameters, values, probabilities, weights){ 3 | sum(weights * (pexp(values, parameters) -probabilities)^2) 4 | } 5 | -------------------------------------------------------------------------------- /R/beta.error.R: -------------------------------------------------------------------------------- 1 | beta.error <- 2 | function(parameters, values, probabilities, weights){ 3 | sum(weights * (pbeta(values, exp(parameters[1]), exp(parameters[2])) - probabilities)^2) 4 | } 5 | -------------------------------------------------------------------------------- /R/lognormal.error.R: -------------------------------------------------------------------------------- 1 | lognormal.error <- 2 | function(parameters, values, probabilities, weights){ 3 | sum(weights * (plnorm(values, parameters[1], exp(parameters[2])) - probabilities)^2) 4 | } 5 | -------------------------------------------------------------------------------- /R/SHELF-package.R: -------------------------------------------------------------------------------- 1 | #' @keywords internal 2 | "_PACKAGE" 3 | 4 | ## usethis namespace: start 5 | #' @importFrom tidyr gather 6 | #' @importFrom utils read.table 7 | ## usethis namespace: end 8 | 9 | 10 | -------------------------------------------------------------------------------- /R/gamma.error.R: -------------------------------------------------------------------------------- 1 | #' @keywords internal 2 | 3 | gamma.error <- 4 | function(parameters, values, probabilities, weights){ 5 | sum(weights * (pgamma(values, exp(parameters[1]), exp(parameters[2])) -probabilities)^2) 6 | } 7 | -------------------------------------------------------------------------------- /R/logt.error.R: -------------------------------------------------------------------------------- 1 | logt.error <- 2 | function(parameters, values, probabilities, weights, degreesfreedom){ 3 | sum(weights * (pt((log(values) - parameters[1]) / exp(parameters[2]), degreesfreedom) - probabilities)^2) 4 | } 5 | -------------------------------------------------------------------------------- /R/tError.R: -------------------------------------------------------------------------------- 1 | tError <- 2 | function(parameters, values, probabilities, weights, degreesfreedom){ 3 | sum(weights * (pt((values-parameters[1]) / exp(parameters[2]), 4 | degreesfreedom) - probabilities)^2) 5 | 6 | } 7 | # sum(weights * ((qt(probabilities, degreesfreedom) * exp(parameters[2]) + 8 | # parameters[1]) - values)^2) -------------------------------------------------------------------------------- /R/dhist.R: -------------------------------------------------------------------------------- 1 | 2 | dhist<-function(x, z, pz){ 3 | fx<-rep(0,length(x)) 4 | 5 | h <- rep(0, length(z) -1) 6 | for(i in 1:length(h)){ 7 | h[i]<-(pz[i+1] - pz[i]) / (z[i+1]-z[i]) 8 | } 9 | 10 | nz<-length(z) 11 | 12 | for(i in 1:length(x)){ 13 | index<- (x[i]<=z[2:nz]) & (x[i]>z[1:(nz-1)]) 14 | if(sum(index)>0){ 15 | fx[i] <- h[index] 16 | } 17 | } 18 | fx 19 | } 20 | 21 | -------------------------------------------------------------------------------- /R/histdensity.R: -------------------------------------------------------------------------------- 1 | 2 | dhist<-function(x, z, pz){ 3 | fx<-rep(0,length(x)) 4 | 5 | h <- rep(0, length(z) -1) 6 | for(i in 1:length(h)){ 7 | h[i]<-(pz[i+1] - pz[i]) / (z[i+1]-z[i]) 8 | } 9 | 10 | nz<-length(z) 11 | 12 | for(i in 1:length(x)){ 13 | index<- (x[i]<=z[2:nz]) & (x[i]>z[1:(nz-1)]) 14 | if(sum(index)>0){ 15 | fx[i] <- h[index] 16 | } 17 | } 18 | fx 19 | } 20 | 21 | 22 | 23 | phist<-function(x,z,pz){ 24 | z<-c(-exp(100), z, exp(100)) 25 | pz<-c(0,pz,1) 26 | approx(z,pz,x)$y 27 | } 28 | 29 | qhist<-function(q,z,pz){ 30 | approx(pz,z,q)$y 31 | } -------------------------------------------------------------------------------- /tests/testthat/test-copula-sampling.R: -------------------------------------------------------------------------------- 1 | test_that("copula sampling ",{ 2 | skip_on_cran() 3 | set.seed(123) 4 | p <- c(0.25, 0.5, 0.75) 5 | m1 <- 0.3 6 | m2 <- 20 7 | 8 | myfit1 <- fitdist(vals = c(0.2, m1, 0.45), probs = p, lower = 0, upper = 1) 9 | myfit2 <- fitdist(vals = c(10, m2, 35), probs = p, lower = 0, upper = 100) 10 | 11 | cp <- matrix(0, 2, 2) 12 | cp[1, 2] <- 0.8 13 | 14 | x <- copulaSample(myfit1, myfit2, cp = cp, n = 100000) 15 | 16 | 17 | expect_equal(mean((x[, 1] > m1) & (x[, 2] > m2) | (x[, 1] < m1) & (x[, 2] < m2)), 18 | 0.8, 19 | tolerance = 3 * sqrt(0.8 * 0.2 / 100000)) 20 | }) 21 | -------------------------------------------------------------------------------- /R/qlinearpool.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | #' 3 | qlinearpool <- 4 | function(fit, q, d = "best", w = 1){ 5 | 6 | n.experts <- nrow(fit$vals) 7 | 8 | if(length(d) == 1){ 9 | d <- rep(d, n.experts) 10 | } 11 | 12 | qx.individual <- matrix(0, length(q), n.experts) 13 | 14 | for(i in 1:n.experts){ 15 | qx.individual[,i] <- expertquantiles(fit, q, d[i], ex = i) 16 | } 17 | 18 | n.q <- length(q) 19 | qx<-rep(0, n.q) 20 | 21 | for(i in 1:n.q){ 22 | x <- seq(from = min(qx.individual[i,]) - 23 | abs(0.001 * min(qx.individual[i,])), 24 | to = max(qx.individual[i,]) + 25 | abs(0.001 * max(qx.individual[i,])), length = 10000) 26 | px <- plinearpool(fit, x, d, w) 27 | qx[i] <- approx(x = px, y = x, xout = q[i], ties = min)$y 28 | } 29 | qx 30 | } 31 | -------------------------------------------------------------------------------- /R/normal.error.R: -------------------------------------------------------------------------------- 1 | normal.error <- 2 | function(parameters, values, probabilities, weights){ 3 | sum(weights * (pnorm(values, parameters[1], exp(parameters[2])) - probabilities)^2) 4 | } 5 | 6 | # Optimise for location and scale only 7 | skewnormal.error <- function(parameters, values, probabilities, weights, snAlpha){ 8 | sum(weights * (sn::psn(values, xi = parameters[1], 9 | omega = exp(parameters[2]), 10 | alpha = snAlpha) - probabilities)^2) 11 | } 12 | 13 | # Optimise for location, scale and shape 14 | skewnormal.error.joint <- function(parameters, values, probabilities, weights){ 15 | sum(weights * (sn::psn(values, xi = parameters[1], 16 | omega = exp(parameters[2]), 17 | alpha = parameters[3]) - probabilities)^2) 18 | } 19 | -------------------------------------------------------------------------------- /inst/elicitationReportFile/elicitationSummary.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Fitted distributions" 3 | output: 4 | html_document: default 5 | pdf_document: default 6 | word_document: default 7 | date: "`r format(Sys.time(), '%d %B %Y, %H:%M')`" 8 | fontsize: 11pt 9 | --- 10 | 11 | 12 | ```{r global_options, include=FALSE} 13 | knitr::opts_chunk$set(echo=FALSE, warning=FALSE, message=FALSE, 14 | fig.pos = 'h', 15 | fig.align = 'center', 16 | fig.height = 3, 17 | fig.width = 4) 18 | ``` 19 | 20 | 21 | ```{r, echo = FALSE} 22 | 23 | bin.left <- NA 24 | bin.right <- NA 25 | chips <- NA 26 | roulette <- FALSE 27 | filename <- system.file("shinyAppFiles", "distributionsChild.Rmd", package="SHELF") 28 | ``` 29 | 30 | ```{r child=filename} 31 | ``` -------------------------------------------------------------------------------- /tests/testthat/test-dirichlet.R: -------------------------------------------------------------------------------- 1 | test_that("Dirichlet distribution fitting and feedback works",{ 2 | skip_on_cran() 3 | a <- c(20, 10, 5) 4 | p1 <- c(0.25, 0.5, 0.75) 5 | v1 <- qbeta(p1, a[1], sum(a[2:3])) 6 | v2 <- qbeta(p1, a[2], sum(a[c(1, 3)])) 7 | v3 <- qbeta(p1, a[3], sum(a[1:2])) 8 | myfit1 <- fitdist(v1, p1, 0, 1) 9 | myfit2 <- fitdist(v2, p1, 0, 1) 10 | myfit3 <- fitdist(v3, p1, 0, 1) 11 | d <- fitDirichlet(myfit1, myfit2, myfit3, 12 | categories = c("A","B","C"), 13 | n.fitted = "opt", silent = TRUE, plotBeta = FALSE) 14 | expect_equal(a, as.numeric(round(d, 3))) 15 | fb <- feedbackDirichlet(d, 0.1, sf = 5) 16 | expect_equal(as.numeric(fb[, 2]), signif(qbeta(0.1, a, c(sum(a[2:3]), 17 | sum(a[c(1, 3)]), 18 | sum(a[1:2]))), 5)) 19 | }) -------------------------------------------------------------------------------- /R/deprecatedFunctions.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | 3 | roulette <- function(){ 4 | cat("roulette() has been removed\n") 5 | cat("the roulette method is now available within elicit()\n") 6 | 7 | } 8 | 9 | #' @export 10 | elicitQuartiles <- function(){ 11 | cat("elicitQuartiles() has been removed\n") 12 | cat("quartiles elicitation can be performed using elicit()\n") 13 | } 14 | 15 | #' @export 16 | elicitTertiles <- function(){ 17 | cat("elicitTertiles() has been removed\n") 18 | cat("tertiles elicitation can be performed using elicit()\n") 19 | } 20 | 21 | #' @export 22 | condDirichlet <- function(){ 23 | cat("condDirichlet() has been removed\n") 24 | cat("use elicitDirichlet() instead for eliciting a Dirichlet distribution\n") 25 | cat("and exploring conditional distribuitions.\n") 26 | } 27 | 28 | #' @export 29 | elicitConcProb <- function(){ 30 | cat("elicitConcProb() has been removed\n") 31 | cat("Use elicitBivariate() instead. \n") 32 | } -------------------------------------------------------------------------------- /man/elicitDirichlet.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/elicitDirichlet.R 3 | \name{elicitDirichlet} 4 | \alias{elicitDirichlet} 5 | \alias{condDirichlet} 6 | \title{Elicit a Dirichlet distribution interactively} 7 | \usage{ 8 | elicitDirichlet() 9 | } 10 | \value{ 11 | The parameters of the fitted Dirichlet distribution, which are 12 | returned once the Quit button has been clicked. 13 | } 14 | \description{ 15 | Opens up a web browser (using the shiny package), from which you can elicit a 16 | Dirichlet distribution 17 | } 18 | \details{ 19 | Click on the "Help" tab for instructions. Click the "Quit" button to exit the app and return 20 | the results from the \code{fitdist} command. Click "Download report" to generate a report 21 | of all the fitted distributions. 22 | } 23 | \examples{ 24 | 25 | \dontrun{ 26 | 27 | elicitDirichlet() 28 | 29 | } 30 | } 31 | \author{ 32 | Jeremy Oakley 33 | } 34 | -------------------------------------------------------------------------------- /man/sampleFit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/sampleFit.R 3 | \name{sampleFit} 4 | \alias{sampleFit} 5 | \title{Sample from the elicited distributions} 6 | \usage{ 7 | sampleFit(fit, n, expert = 1) 8 | } 9 | \arguments{ 10 | \item{fit}{An object of class elicitation} 11 | 12 | \item{n}{The required sample size for each elicitation} 13 | 14 | \item{expert}{Specify which expert's distributions to sample 15 | from, if multiple experts' judgements have been elicited.} 16 | } 17 | \value{ 18 | A matrix of sampled values, one column per distribution. 19 | Column names are given to label the distributions. 20 | } 21 | \description{ 22 | Generates a random sample from all distributions specified 23 | within an object of class \code{elicitation} 24 | } 25 | \examples{ 26 | \dontrun{ 27 | v <- c(20,30,50) 28 | p <- c(0.25,0.5,0.75) 29 | myfit <- fitdist(vals = v, probs = p, lower = 0, upper = 100) 30 | sampleFit(myfit, n = 10) 31 | } 32 | 33 | } 34 | -------------------------------------------------------------------------------- /man/feedbackDirichlet.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fitDirichlet.R 3 | \name{feedbackDirichlet} 4 | \alias{feedbackDirichlet} 5 | \title{Calculate quantiles for the marginal distributions of a Dirichlet distribution} 6 | \usage{ 7 | feedbackDirichlet(d, quantiles = c(0.1, 0.9), sf = 2) 8 | } 9 | \arguments{ 10 | \item{d}{A vector of parameters of the Dirichlet distribution} 11 | 12 | \item{quantiles}{The desired quantiles for feedback} 13 | 14 | \item{sf}{The number of significant figures displayed} 15 | } 16 | \value{ 17 | Quantiles for each marginal distribution 18 | } 19 | \description{ 20 | Given a (elicited) Dirichlet distribution, calculate quantiles for each marginal 21 | beta distribution corresponding to the elicited quantiles 22 | } 23 | \examples{ 24 | \dontrun{ 25 | feedbackDirichlet(d = c(20, 10, 5), 26 | quantiles = c(0.1, 0.33, 0.66, 0.9)) 27 | } 28 | } 29 | \author{ 30 | Jeremy Oakley 31 | } 32 | -------------------------------------------------------------------------------- /inst/shinyAppFiles/elicitationShinySummary.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Fitted distributions" 3 | output: 4 | html_document: default 5 | pdf_document: default 6 | word_document: default 7 | date: "`r format(Sys.time(), '%d %B %Y, %H:%M')`" 8 | fontsize: 11pt 9 | params: 10 | fit: NA 11 | bin.left: NA 12 | bin.right: NA 13 | chips: NA 14 | roulette: NA 15 | --- 16 | 17 | 18 | ```{r global_options, include=FALSE} 19 | knitr::opts_chunk$set(echo=FALSE, warning=FALSE, message=FALSE, 20 | fig.pos = 'h', 21 | fig.align = 'center', 22 | fig.height = 3, 23 | fig.width = 4) 24 | showplots <- FALSE 25 | ``` 26 | 27 | 28 | 29 | 30 | ```{r, echo = FALSE} 31 | fit <- params$fit 32 | bin.left <- params$bin.left 33 | bin.right <- params$bin.right 34 | chips <- params$chips 35 | roulette <- params$roulette 36 | filename <- system.file("shinyAppFiles", "distributionsChild.Rmd", package="SHELF") 37 | ``` 38 | 39 | ```{r child=filename} 40 | ``` 41 | 42 | -------------------------------------------------------------------------------- /R/rlinearpool.R: -------------------------------------------------------------------------------- 1 | 2 | #' @export 3 | rlinearpool <- 4 | function(fit, n, d = "best", w = 1){ 5 | 6 | if(min(w)<0 | max(w)<=0){stop("expert weights must be non-negative, and at least one weight must be greater than 0.")} 7 | 8 | n.experts <- nrow(fit$vals) 9 | 10 | if(length(d) == 1){ 11 | d <- rep(d, n.experts) 12 | } 13 | 14 | if(length(w) == 1){ 15 | w <- rep(w, n.experts) 16 | } 17 | 18 | x <- rep(0, n * n.experts) 19 | 20 | # Sample n values per expert, then make a stack of the n samples 21 | 22 | for(i in 1:n.experts){ 23 | xExpert <- sampleFit(fit, n, expert = i) 24 | if(d[i] == "best"){ 25 | d[i] <- fit$best.fitting[i, "best.fit"] 26 | } 27 | x[(1 + (i - 1) * n):(i * n)] <- xExpert[, d[i]] 28 | } 29 | 30 | # for i=1,...,n, sample which expert's sample of values 31 | # provides the i-th value in the linear pool sample 32 | 33 | index <- n * sample(0:(n.experts-1), size = n, 34 | replace = TRUE, 35 | prob = w / sum(w)) 36 | x[index + 1:n] 37 | 38 | } 39 | -------------------------------------------------------------------------------- /man/elicitMixture.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/elicitMixture.R 3 | \name{elicitMixture} 4 | \alias{elicitMixture} 5 | \title{Elicit a mixture distribution using the extension method} 6 | \usage{ 7 | elicitMixture() 8 | } 9 | \value{ 10 | When the Quit button is clicked, a list, with elements 11 | \item{fit}{an object of class \code{elicitation}. See \code{\link{fitdist}} for details.} 12 | \item{extensionProbs}{the probability mass function for the extension variable.} 13 | } 14 | \description{ 15 | Opens up a web browser (using the shiny package), from which you can specify 16 | judgements, fit distributions and plot the fitted density function. 17 | } 18 | \details{ 19 | Click the "Quit" button to exit the app and return 20 | the fitted distributions. Click "Download report" to generate a report 21 | of all the fitted distributions. 22 | } 23 | \examples{ 24 | 25 | \dontrun{ 26 | 27 | elicitMixture() 28 | 29 | } 30 | } 31 | \author{ 32 | Jeremy Oakley 33 | } 34 | -------------------------------------------------------------------------------- /man/elicitMultiple.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/elicitMultipleExperts.R 3 | \name{elicitMultiple} 4 | \alias{elicitMultiple} 5 | \title{Elicit individual judgements and fit distributions for multiple experts} 6 | \usage{ 7 | elicitMultiple() 8 | } 9 | \value{ 10 | An object of class \code{elicitation}, which is returned once the 11 | Finish button has been clicked. See \code{\link{fitdist}} for details. 12 | } 13 | \description{ 14 | Opens up a web browser (using the shiny package), from which you can specify 15 | judgements, fit distributions and plot the fitted density functions and a 16 | (weighted) linear pool with additional feedback. 17 | } 18 | \details{ 19 | Click the "Quit" button to exit the app and return 20 | the results from the \code{fitdist} command. Click "Download report" to generate a report 21 | of all the fitted distributions. 22 | } 23 | \examples{ 24 | 25 | \dontrun{ 26 | 27 | elicitMultiple() 28 | 29 | } 30 | } 31 | \author{ 32 | Jeremy Oakley 33 | } 34 | -------------------------------------------------------------------------------- /R/makeQuartilePlot.R: -------------------------------------------------------------------------------- 1 | # Display four equally likely intervals as coloured bars 2 | # This is used in the elicit() app to plot a single set of judgements 3 | # Different to plotQuartiles() for comparing quartiles from multiple experts 4 | 5 | makeQuartilePlot <- function(lower, Q1, m, Q3, upper, fontsize=12, xlab = "x"){ 6 | ggplot()+ 7 | annotate("rect", xmin = lower, 8 | xmax = Q1, ymin=0.2, ymax = 0.8, fill = "#a6cee3")+ 9 | annotate("rect", xmin = Q1, xmax = m, 10 | ymin=0.2, ymax = 0.8, fill = "#1f78b4")+ 11 | annotate("rect", xmin = m, xmax = Q3, ymin=0.2, ymax = 0.8, fill = "#b2df8a")+ 12 | annotate("rect", xmin = Q3, xmax = upper, ymin=0.2, ymax = 0.8, fill = "#33a02c")+ 13 | xlim(lower, upper)+ 14 | theme(axis.ticks.y = element_blank(), axis.text.y = element_blank())+ 15 | scale_y_continuous(breaks = NULL, limits = c(0, 1))+ 16 | labs(title = "Quartiles", y = expression(f[X](x)), x = xlab) + 17 | theme(plot.title = element_text(hjust = 0.5), 18 | axis.title.y = element_text(colour = "white"), 19 | text = element_text(size = fontsize)) 20 | 21 | } 22 | 23 | -------------------------------------------------------------------------------- /tests/testthat/test-survival-extrapolation.R: -------------------------------------------------------------------------------- 1 | test_that("makeSurvivalTable works",{ 2 | skip_on_cran() 3 | set.seed(123) 4 | expDf <- data.frame(time = c(rexp(10000, rate = 0.2), 5 | rexp(10000, rate = 0.1)), 6 | event = rep(2, 1000), 7 | treatment = rep(c("drug", "placebo"), each = 10000)) 8 | 9 | t1 <- makeSurvivalTable(expDf, breakTime = 1, truncationTime = 10, 10 | timeUnit = "years") 11 | expect_equal(t1[, 2], 1-pexp(1:10, 0.2) , tolerance = 5e-3) 12 | expect_equal(t1[, 4], rep(0.2, 10) , tolerance = 5e-2) 13 | expect_equal(t1[, 5], 1-pexp(1:10, 0.1) , tolerance = 5e-3) 14 | expect_equal(t1[, 7], rep(0.1, 10) , tolerance = 5e-2) 15 | 16 | }) 17 | 18 | test_that("ScenarioTest works",{ 19 | set.seed(123) 20 | n <- 100 21 | expDf <- data.frame(time = rexp(100, rate = 0.2), event = rep(1, n), 22 | treatment = "drug") 23 | sScen <- survivalScenario(0, 10, 4, 5, 10, expDf, showPlot = FALSE) 24 | expect_lt(sScen$interval[1], 1-pexp(10, 0.2)) 25 | expect_gt(sScen$interval[2], 1-pexp(10, 0.2)) 26 | 27 | }) -------------------------------------------------------------------------------- /R/makeTertilePlot.R: -------------------------------------------------------------------------------- 1 | # Display three equally likely intervals as coloured bars, and 2 | # add the median as a dashed line 3 | # This is used in the elicit() app to plot a single set of judgements 4 | # Different to plotTertiles() for comparing tertiles from multiple experts 5 | 6 | makeTertilePlot <- function(lower, t1, m, t2, upper, fontsize=12, xlab = "x"){ 7 | ggplot()+ 8 | annotate("rect", xmin = lower, 9 | xmax = t1, ymin=0.2, ymax = 0.8, fill = "#66c2a5")+ 10 | annotate("rect", xmin = t1, xmax = t2, 11 | ymin=0.2, ymax = 0.8, fill = "#fc8d62")+ 12 | annotate("rect", xmin = t2, xmax = upper, 13 | ymin=0.2, ymax = 0.8, fill = "#8da0cb")+ 14 | xlim(lower, upper)+ 15 | geom_vline(xintercept = m, linetype = "dashed")+ 16 | theme(axis.ticks.y = element_blank(), axis.text.y = element_blank())+ 17 | scale_y_continuous(breaks = NULL, limits = c(0, 1))+ 18 | labs(title = "Tertiles and median", y = expression(f[X](x)), 19 | x = xlab) + 20 | theme(plot.title = element_text(hjust = 0.5), 21 | axis.title.y = element_text(colour = "white"), 22 | text = element_text(size = fontsize)) 23 | } -------------------------------------------------------------------------------- /R/makeGroupPlot.R: -------------------------------------------------------------------------------- 1 | makeGroupPlot <- 2 | function(fit, pl, pu, d = "best", lwd, xlab, ylab, fs = 12, 3 | expertnames = NULL){ 4 | 5 | expert <- NULL # hack to avoid R CMD check NOTE 6 | 7 | n.experts <- nrow(fit$vals) 8 | 9 | if(is.null(expertnames)){ 10 | 11 | if(n.experts < 27){ 12 | expertnames <- LETTERS[1:n.experts] 13 | } 14 | 15 | if(n.experts > 26){ 16 | expertnames <- factor(1:n.experts) 17 | } 18 | 19 | } 20 | 21 | x <- matrix(0, 200 * n.experts, 1) 22 | fx <- x 23 | 24 | 25 | for(i in 1:n.experts){ 26 | densitydata <- expertdensity(fit, d, ex = i, pl, pu) 27 | x[(1+(i-1)*200):(i*200), 1] <- densitydata$x 28 | fx[(1+(i-1)*200):(i*200), 1] <-densitydata$fx 29 | } 30 | df1 <- data.frame(x = x, fx = fx, 31 | expert = factor(rep(expertnames, each =200), 32 | levels = expertnames)) 33 | p1 <- ggplot(df1, aes(x = x, y = fx, colour = expert)) + 34 | labs(x = xlab, y = ylab) + 35 | theme(text = element_text(size = fs)) 36 | 37 | if(d == "hist"){ 38 | p1 <- p1 + geom_step(size=lwd) 39 | }else{ 40 | p1 <- p1 + geom_line(size=lwd) 41 | } 42 | 43 | 44 | p1 45 | } 46 | -------------------------------------------------------------------------------- /man/elicitExtension.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/elicitExtension.R 3 | \name{elicitExtension} 4 | \alias{elicitExtension} 5 | \title{Elicitation with the extension method} 6 | \usage{ 7 | elicitExtension() 8 | } 9 | \value{ 10 | A list, with two objects of class \code{elicitation}. 11 | See \code{\link{fitdist}} for details. 12 | } 13 | \description{ 14 | Opens up a web browser (using the shiny package), from which you can specify 15 | judgements, fit distributions, and produce various plots. Judgements are 16 | specified for the distribution of the conditioning variable Y, the median 17 | function (median of X given Y), and the distribution of X given that Y takes 18 | its median value. Plots are provided for the two elicited distributions, the 19 | median function, the conditional distribution of X for any specified Y, and 20 | the marginal distribution of X. 21 | } 22 | \details{ 23 | Click the "Quit" button to exit the app and return 24 | the results from the \code{fitdist} command. Click "Download report" to generate a report 25 | of all the fitted distributions for each uncertain quantity, and "Download sample" to 26 | generate a csv file with a sample from the marginal distribution of X. 27 | } 28 | \examples{ 29 | 30 | \dontrun{ 31 | 32 | elicitExtension() 33 | 34 | } 35 | } 36 | \author{ 37 | Jeremy Oakley 38 | } 39 | -------------------------------------------------------------------------------- /man/SHELF-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/SHELF-package.R 3 | \docType{package} 4 | \name{SHELF-package} 5 | \alias{SHELF} 6 | \alias{SHELF-package} 7 | \title{SHELF: Tools to Support the Sheffield Elicitation Framework} 8 | \description{ 9 | Implements various methods for eliciting a probability distribution for a single parameter from an expert or a group of experts. The expert provides a small number of probability judgements, corresponding to points on his or her cumulative distribution function. A range of parametric distributions can then be fitted and displayed, with feedback provided in the form of fitted probabilities and percentiles. For multiple experts, a weighted linear pool can be calculated. Also includes functions for eliciting beliefs about population distributions; eliciting multivariate distributions using a Gaussian copula; eliciting a Dirichlet distribution; eliciting distributions for variance parameters in a random effects meta-analysis model; survival extrapolation. R Shiny apps for most of the methods are included. 10 | } 11 | \seealso{ 12 | Useful links: 13 | \itemize{ 14 | \item \url{https://github.com/OakleyJ/SHELF} 15 | \item Report bugs at \url{https://github.com/OakleyJ/SHELF/issues} 16 | } 17 | 18 | } 19 | \author{ 20 | \strong{Maintainer}: Jeremy Oakley \email{j.oakley@sheffield.ac.uk} 21 | 22 | } 23 | \keyword{internal} 24 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(cdffeedback) 4 | export(cdfplot) 5 | export(compareGroupRIO) 6 | export(compareIntervals) 7 | export(condDirichlet) 8 | export(copulaSample) 9 | export(elicit) 10 | export(elicitBivariate) 11 | export(elicitConcProb) 12 | export(elicitDirichlet) 13 | export(elicitExtension) 14 | export(elicitHeterogen) 15 | export(elicitMixture) 16 | export(elicitMultiple) 17 | export(elicitQuartiles) 18 | export(elicitSurvivalExtrapolation) 19 | export(elicitTertiles) 20 | export(feedback) 21 | export(feedbackDirichlet) 22 | export(fitDirichlet) 23 | export(fitdist) 24 | export(fitprecision) 25 | export(generateReport) 26 | export(linearPoolDensity) 27 | export(makeCDFPlot) 28 | export(makeSurvivalTable) 29 | export(pdfplots) 30 | export(plinearpool) 31 | export(plotConditionalDensities) 32 | export(plotConditionalMedianFunction) 33 | export(plotQuartiles) 34 | export(plotTertiles) 35 | export(plotfit) 36 | export(qlinearpool) 37 | export(rlinearpool) 38 | export(roulette) 39 | export(sampleFit) 40 | export(sampleMarginalFit) 41 | export(survivalExtrapolatePlot) 42 | export(survivalModelExtrapolations) 43 | export(survivalScenario) 44 | import(ggplot2) 45 | import(graphics) 46 | import(shiny) 47 | import(stats) 48 | import(survival) 49 | importFrom(flexsurv,flexsurvreg) 50 | importFrom(survminer,ggsurvplot) 51 | importFrom(tidyr,gather) 52 | importFrom(utils,read.table) 53 | -------------------------------------------------------------------------------- /man/elicitSurvivalExtrapolation.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/elicitSurvivalExtrapolation.R 3 | \name{elicitSurvivalExtrapolation} 4 | \alias{elicitSurvivalExtrapolation} 5 | \title{Elicitation for survival extrapolation} 6 | \usage{ 7 | elicitSurvivalExtrapolation() 8 | } 9 | \description{ 10 | Opens up a web browser in which you can implement the SHELF protocol for survival extrapolation. 11 | Start with uploading a .csv file of individual patient survival data (time, event to indicate censoring, and 12 | treatment group). Then elicit individual judgements, perform scenario testing as required, and elicit a RIO distribution. 13 | Judgements for two treatment groups can be elicited in the same session. 14 | } 15 | \examples{ 16 | 17 | \dontrun{ 18 | 19 | # make a suitable csv file using a built in data set from the survival package 20 | sdf <- survival::veteran[, c("time", "status", "trt")] 21 | colnames(sdf) <- c("time", "event", "treatment") 22 | sdf$treatment <- factor(sdf$treatment, labels = c("standard", "test")) 23 | 24 | # write the data frame sdf to a .csv file in the current working directory 25 | write.csv(sdf, file = "testFile.csv", row.names = FALSE) 26 | 27 | # Run the app and upload testFile.csv in the first tab, and change unit of time to "days" 28 | 29 | elicitSurvivalExtrapolation() 30 | 31 | } 32 | } 33 | \author{ 34 | Jeremy Oakley 35 | } 36 | -------------------------------------------------------------------------------- /man/elicitBivariate.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/elicitBivariate.R 3 | \name{elicitBivariate} 4 | \alias{elicitBivariate} 5 | \alias{elicitConcProb} 6 | \title{Elicit a bivariate distribution using a Gaussian copula} 7 | \usage{ 8 | elicitBivariate() 9 | } 10 | \value{ 11 | A list, with two objects of class \code{elicitation}, and the 12 | elicited concordance probability. See \code{\link{fitdist}} for details. 13 | } 14 | \description{ 15 | Opens up a web browser (using the shiny package), from which you can specify 16 | judgements, fit distributions, plot the fitted density functions, and plot samples 17 | from the joint distributions. A joint distribution is constructed using a Gaussian 18 | copula, whereby the correlation parameter is determined via the elicitation of a 19 | concordance probability (a probability that the two uncertain quantities are either 20 | both greater than their medians, or both less than their medians.) 21 | } 22 | \details{ 23 | Click on the "Help" tab for instructions. Click the "Quit" button to exit the app and return 24 | the results from the \code{fitdist} command. Click "Download report" to generate a report 25 | of all the fitted distributions for each uncertain quantity, and "Download sample" to 26 | generate a csv file with a sample from the joint distribution. 27 | } 28 | \examples{ 29 | 30 | \dontrun{ 31 | 32 | elicitBivariate() 33 | 34 | } 35 | } 36 | \author{ 37 | Jeremy Oakley 38 | } 39 | -------------------------------------------------------------------------------- /man/plotQuartiles.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plotQuartiles.R 3 | \name{plotQuartiles} 4 | \alias{plotQuartiles} 5 | \title{Plot elicited quartiles, median and plausible range for each expert} 6 | \usage{ 7 | plotQuartiles( 8 | vals, 9 | lower, 10 | upper, 11 | fs = 12, 12 | expertnames = NULL, 13 | xl = NULL, 14 | xlabel = "X" 15 | ) 16 | } 17 | \arguments{ 18 | \item{vals}{a matrix of elicited quartiles and medians: one column per expert, first 19 | row is the 25th percentile, 2nd row is the median, last row is the 75th percentile.} 20 | 21 | \item{lower}{a vector of lower plausible limits: one per expert} 22 | 23 | \item{upper}{a vector of upper plausible limits: one per expert} 24 | 25 | \item{fs}{font size to be used in the plot} 26 | 27 | \item{expertnames}{vector of experts' names} 28 | 29 | \item{xl}{vector of limits for x-axis} 30 | 31 | \item{xlabel}{x-axis label} 32 | } 33 | \description{ 34 | Displays a horizontal bar for each expert, to represent the expert's plausible range. 35 | The coloured sections indicate the experts' quartiles: four intervals judged by the expert 36 | to be equally likely. The experts' medians are shown as dashed lines. 37 | } 38 | \examples{ 39 | \dontrun{ 40 | l <- c(2, 1, 5, 1) 41 | u <- c(95, 90, 65, 40) 42 | v <- matrix(c(15, 25, 40, 43 | 10, 20, 40, 44 | 10, 15, 25, 45 | 5, 10, 20), 46 | 3, 4) 47 | plotQuartiles(vals = v, lower = l, upper = u) 48 | } 49 | } 50 | \author{ 51 | Jeremy Oakley 52 | } 53 | -------------------------------------------------------------------------------- /inst/shinyAppFiles/DirichletShinySummary.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Fitted Dirichlet Distribution" 3 | output: 4 | html_document: default 5 | pdf_document: default 6 | word_document: default 7 | date: "`r format(Sys.time(), '%d %B %Y, %H:%M')`" 8 | fontsize: 11pt 9 | params: 10 | allFits: NA 11 | categories: NA 12 | n: NA 13 | quantiles: NA 14 | thetaMatrix: NA 15 | --- 16 | 17 | ## Elicited judgements 18 | 19 | ```{r global_options, include=FALSE} 20 | knitr::opts_chunk$set(echo=FALSE, warning=FALSE, message=FALSE) 21 | ``` 22 | 23 | ```{r} 24 | mydf <- data.frame(params$quantiles, params$thetaMatrix) 25 | colnames(mydf) <- c("quantiles", params$categories) 26 | rownames(mydf) <- NULL 27 | knitr::kable(mydf) 28 | ``` 29 | 30 | 31 | ### Dirichlet density function and parameters 32 | 33 | Define the vector of unknown population proportions as 34 | $$\theta := (\theta_1,\ldots,\theta_k),$$ 35 | with $k = `r length(params$categories)`$ . We write 36 | $$\theta \sim Dirichlet(a_1,\ldots,a_k),$$ 37 | with 38 | $$ 39 | f(\theta)=\frac{\Gamma(a_1+\ldots +a_k)}{\Gamma(a_1)\ldots \Gamma(a_k)}\prod_{i=1}^k \theta_i^{a_i-1}. 40 | $$ 41 | The fitted parameter values $a_1,\ldots,a_k$ are as follows: 42 | 43 | ```{r} 44 | fitDirichlet(params$allFits, categories = params$categories, 45 | n.fitted = params$n, silent = TRUE, 46 | plotBeta = FALSE) 47 | ``` 48 | 49 | ## Comparing the elicited marginals with the marginals from the Dirichlet fit 50 | 51 | ```{r} 52 | d <- fitDirichlet(params$allFits, categories = params$categories, 53 | n.fitted = params$n) 54 | ``` 55 | 56 | 57 | 58 | -------------------------------------------------------------------------------- /man/generateReport.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/generateReport.R 3 | \name{generateReport} 4 | \alias{generateReport} 5 | \title{Generate a report to show the fitted distributions} 6 | \usage{ 7 | generateReport( 8 | fit, 9 | output_format = "html_document", 10 | sf = 3, 11 | expert = 1, 12 | view = TRUE, 13 | clean = TRUE 14 | ) 15 | } 16 | \arguments{ 17 | \item{fit}{An object of class \code{'elicitation'}.} 18 | 19 | \item{output_format}{the output format for the document. One of \code{"html_document"}, 20 | \code{"pdf_document"} (requires LaTeX to be installed), or \code{"word_document"} 21 | (requires Word to be installed).} 22 | 23 | \item{sf}{number of significant figures to be displayed for the fitted parameters.} 24 | 25 | \item{expert}{if the \code{fit} object contains judgements from multiple experts, the 26 | single expert's distributions to be displayed.} 27 | 28 | \item{view}{set to \code{TRUE} to open the document after it has been compiled.} 29 | 30 | \item{clean}{set to \code{TRUE} to clean intermediate files that are created during rendering.} 31 | } 32 | \description{ 33 | Renders an Rmarkdown document to display the density function of each fitted distribution, 34 | the parameter values, and the R command required to sample from each distribution. 35 | } 36 | \examples{ 37 | \dontrun{ 38 | # One expert, with elicited probabilities 39 | # P(X<20)=0.25, P(X<30)=0.5, P(X<50)=0.75 40 | # and X>0. 41 | v <- c(20,30,50) 42 | p <- c(0.25,0.5,0.75) 43 | myfit <- fitdist(vals=v, probs=p, lower=0) 44 | 45 | generateReport(myfit) 46 | } 47 | } 48 | -------------------------------------------------------------------------------- /man/plotTertiles.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plotTertiles.R 3 | \name{plotTertiles} 4 | \alias{plotTertiles} 5 | \title{Plot elicted tertiles, median and plausible range for each expert} 6 | \usage{ 7 | plotTertiles( 8 | vals, 9 | lower, 10 | upper, 11 | fs = 12, 12 | percentages = FALSE, 13 | expertnames = NULL, 14 | xl = NULL, 15 | xlabel = "X" 16 | ) 17 | } 18 | \arguments{ 19 | \item{vals}{a matrix of elicited tertiles and medians: one column per expert, first 20 | row is the 33rd percentile, 2nd row is the median, last row is the 66th percentile.} 21 | 22 | \item{lower}{a vector of lower plausible limits: one per expert} 23 | 24 | \item{upper}{a vector of upper plausible limits: one per expert} 25 | 26 | \item{fs}{font size to be used in the plot} 27 | 28 | \item{percentages}{set to \code{TRUE} to use percentages on the x-axis} 29 | 30 | \item{expertnames}{vector of experts' names} 31 | 32 | \item{xl}{vector of limits for x-axis} 33 | 34 | \item{xlabel}{x-axis label} 35 | } 36 | \description{ 37 | Displays a horizontal bar for each expert, to represent the expert's plausible range. 38 | The coloured sections indicate the experts' tertiles: three intervals judged by the expert 39 | to be equally likely. The experts' medians are shown as dashed lines. 40 | } 41 | \examples{ 42 | \dontrun{ 43 | l <- c(-5, 0, 5, -10) 44 | u <- c(15, 35, 50, 35) 45 | v <- matrix(c(5, 8, 10, 46 | 10, 15, 20, 47 | 15, 18, 25, 48 | 10, 20, 30), 49 | 3, 4) 50 | plotTertiles(vals = v, lower = l, upper = u) 51 | } 52 | } 53 | \author{ 54 | Jeremy Oakley 55 | } 56 | -------------------------------------------------------------------------------- /R/multiplot.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | # Multiple plot function 4 | # 5 | # ggplot objects can be passed in ..., or to plotlist (as a list of ggplot objects) 6 | # - cols: Number of columns in layout 7 | # - layout: A matrix specifying the layout. If present, 'cols' is ignored. 8 | # 9 | # If the layout is something like matrix(c(1,2,3,3), nrow=2, byrow=TRUE), 10 | # then plot 1 will go in the upper left, 2 will go in the upper right, and 11 | # 3 will go all the way across the bottom. 12 | # 13 | 14 | 15 | multiplot <- function(..., plotlist=NULL, file, cols=1, layout=NULL) { 16 | 17 | 18 | # Make a list from the ... arguments and plotlist 19 | plots <- c(list(...), plotlist) 20 | 21 | numPlots = length(plots) 22 | 23 | # If layout is NULL, then use 'cols' to determine layout 24 | if (is.null(layout)) { 25 | # Make the panel 26 | # ncol: Number of columns of plots 27 | # nrow: Number of rows needed, calculated from # of cols 28 | layout <- matrix(seq(1, cols * ceiling(numPlots/cols)), 29 | ncol = cols, nrow = ceiling(numPlots/cols)) 30 | } 31 | 32 | if (numPlots==1) { 33 | print(plots[[1]]) 34 | 35 | } else { 36 | # Set up the page 37 | grid::grid.newpage() 38 | grid::pushViewport(grid::viewport(layout = grid::grid.layout(nrow(layout), ncol(layout)))) 39 | 40 | # Make each plot, in the correct location 41 | for (i in 1:numPlots) { 42 | # Get the i,j matrix positions of the regions that contain this subplot 43 | matchidx <- as.data.frame(which(layout == i, arr.ind = TRUE)) 44 | 45 | print(plots[[i]], vp = grid::viewport(layout.pos.row = matchidx$row, 46 | layout.pos.col = matchidx$col)) 47 | } 48 | } 49 | } -------------------------------------------------------------------------------- /man/compareIntervals.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/compareExperts.R 3 | \name{compareIntervals} 4 | \alias{compareIntervals} 5 | \title{Plot fitted intervals for each expert} 6 | \usage{ 7 | compareIntervals( 8 | fit, 9 | interval = 0.95, 10 | dist = "best", 11 | fs = 12, 12 | xlab = "x", 13 | ylab = "expert", 14 | showDist = TRUE 15 | ) 16 | } 17 | \arguments{ 18 | \item{fit}{An object of class \code{elicitation}} 19 | 20 | \item{interval}{The probability p for each interval (i.e. the fitted probability for each expert 21 | that the displayed interval contains the uncertain quantity will be p)} 22 | 23 | \item{dist}{The distribution fitted to each expert's probabilities. Options are 24 | \code{"normal"}, \code{"t"}, \code{"skewnormal"}, \code{"gamma"}, \code{"lognormal"}, 25 | \code{"logt"},\code{"beta"}, \code{"mirrorgamma"}, 26 | \code{"mirrorlognormal"}, \code{"mirrorlogt"} \code{"hist"} (for a histogram fit), and 27 | \code{"best"} (for best fitting). Can be a vector if different distributions are desired for each expert.} 28 | 29 | \item{fs}{font size used in the plot.} 30 | 31 | \item{xlab}{A string or expression giving the x-axis label.} 32 | 33 | \item{ylab}{A string or expression giving the y-axis label.} 34 | 35 | \item{showDist}{TRUE/FALSE for reporting distributions used for each expert} 36 | } 37 | \description{ 38 | Following elicitation of distributions from individual experts, plot fitted probability 39 | intervals for each expert. 40 | } 41 | \examples{ 42 | 43 | \dontrun{ 44 | v <- matrix(c(30, 40, 50, 20, 25, 35, 40, 50, 60, 35, 40, 50), 3, 4) 45 | p <- c(0.25, 0.5, 0.75) 46 | myfit <- fitdist(vals = v, probs = p, lower = 0, upper = 100) 47 | compareIntervals(myfit, interval = 0.5) 48 | } 49 | } 50 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Type: Package 2 | Package: SHELF 3 | Title: Tools to Support the Sheffield Elicitation Framework 4 | Version: 1.12.1 5 | Date: 2025-11-17 6 | Authors@R: person(given = "Jeremy", 7 | family = "Oakley", 8 | role = c("aut", "cre"), 9 | email = "j.oakley@sheffield.ac.uk") 10 | Description: Implements various methods for eliciting a probability 11 | distribution for a single parameter from an expert or a group of 12 | experts. The expert provides a small number of probability judgements, 13 | corresponding to points on his or her cumulative distribution 14 | function. A range of parametric distributions can then be fitted and 15 | displayed, with feedback provided in the form of fitted probabilities 16 | and percentiles. For multiple experts, a weighted linear pool can be 17 | calculated. Also includes functions for eliciting beliefs about 18 | population distributions; eliciting multivariate distributions using a 19 | Gaussian copula; eliciting a Dirichlet distribution; eliciting 20 | distributions for variance parameters in a random effects 21 | meta-analysis model; survival extrapolation. R Shiny apps for most of the methods are 22 | included. 23 | License: GPL-2 | GPL-3 24 | URL: https://github.com/OakleyJ/SHELF 25 | BugReports: https://github.com/OakleyJ/SHELF/issues 26 | Depends: 27 | R (>= 3.5.0) 28 | Imports: 29 | flexsurv, 30 | ggExtra, 31 | ggplot2, 32 | ggridges, 33 | graphics, 34 | grDevices, 35 | grid, 36 | Hmisc, 37 | rmarkdown, 38 | scales, 39 | shiny, 40 | shinyMatrix, 41 | sn, 42 | stats, 43 | survival, 44 | survminer, 45 | tidyr, 46 | utils 47 | Suggests: 48 | GGally, 49 | knitr, 50 | testthat, 51 | vdiffr 52 | VignetteBuilder: 53 | knitr 54 | Encoding: UTF-8 55 | RoxygenNote: 7.3.3 56 | -------------------------------------------------------------------------------- /R/generateReport.R: -------------------------------------------------------------------------------- 1 | #' Generate a report to show the fitted distributions 2 | #' 3 | #' Renders an Rmarkdown document to display the density function of each fitted distribution, 4 | #' the parameter values, and the R command required to sample from each distribution. 5 | #' 6 | #' @param fit An object of class \code{'elicitation'}. 7 | #' @param output_format the output format for the document. One of \code{"html_document"}, 8 | #' \code{"pdf_document"} (requires LaTeX to be installed), or \code{"word_document"} 9 | #' (requires Word to be installed). 10 | #' @param sf number of significant figures to be displayed for the fitted parameters. 11 | #' @param expert if the \code{fit} object contains judgements from multiple experts, the 12 | #' single expert's distributions to be displayed. 13 | #' @param view set to \code{TRUE} to open the document after it has been compiled. 14 | #' @param clean set to \code{TRUE} to clean intermediate files that are created during rendering. 15 | #' @examples 16 | #' \dontrun{ 17 | #' # One expert, with elicited probabilities 18 | #' # P(X<20)=0.25, P(X<30)=0.5, P(X<50)=0.75 19 | #' # and X>0. 20 | #' v <- c(20,30,50) 21 | #' p <- c(0.25,0.5,0.75) 22 | #' myfit <- fitdist(vals=v, probs=p, lower=0) 23 | #' 24 | #' generateReport(myfit) 25 | #' } 26 | #' @export 27 | generateReport <- function(fit, output_format = "html_document", 28 | sf = 3, expert = 1, view = TRUE, 29 | clean = TRUE){ 30 | 31 | path <- rmarkdown::render(input = 32 | system.file("elicitationReportFile", "elicitationSummary.Rmd", 33 | package="SHELF"), 34 | output_format = output_format, 35 | output_dir = getwd(), 36 | clean = clean) 37 | message("File saved to ", path) 38 | 39 | if(view){system2("open", shQuote(path))} 40 | 41 | } -------------------------------------------------------------------------------- /inst/shinyAppFiles/helpBivariate.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Title 5 | 6 | 7 | 8 | 9 | 10 |

Parameter limits

11 |

Specify a lower and upper limit, with a comma in between. The limits will set the range on the x-axis in the various plots, and the range covered by the bins in the roulette method. The limits will also affect the fitted distributions: the gamma, log normal and log Student-t will all be shifted to have support over the range [lower, infinity), and the beta distributed will be shifted and scaled to have support over the range [lower, upper].

12 | 13 |

Specifying probability judgements

14 |
  • Specify values x1, x2,... in the Parameter values box, in increasing order, separated by commas. 15 |
  • Specify the corresponding probabilities P(X<=x1), P(X<=x2),... in the Cumulative probabilities box, separated by commas. The smallest probability needs to be less than 0.4, and the largest probability needs to be greater than 0.6. 16 | 17 | 18 | 19 |

    Concordance probability

    20 | Specify your probability that either both parameters are above their elicited median values, or both parameters are below their elicited medians. For two independent parameters, your probability will be 0.5. For positively correlated parameters, your probability will be greater than 0.5, and for negatively correlated parameters, your probability will be less than 0.5. 21 | 22 |

    Download report

    23 | This will generate a pdf file, with each fitted distribution specified. 24 | 25 |

    Download sample

    26 | This will generate a csv file with a random sample from the joint distribution of the two inputs, obtained using a Gaussian copula, with correletion determined from the elicited concordance probability. Each marginal distribution will be the distribution you have selected on the corresponding tab. 27 | 28 |

    29 | 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /R/feedbackgroup.R: -------------------------------------------------------------------------------- 1 | feedbackgroup <- 2 | function(fit, quantiles = NA, values = NA, dist = "best", sfg ){ 3 | 4 | 5 | n.experts <- nrow(fit$limits) 6 | expertnames <- paste("expert.", LETTERS[1:n.experts], sep="") 7 | 8 | distributions <- data.frame(matrix(0, nrow = 1, ncol = n.experts)) 9 | names(distributions) <- expertnames 10 | 11 | 12 | if(is.na(quantiles[1]) == T ){ 13 | quantiles <- fit$probs[1,] 14 | } 15 | expert.quantiles <- data.frame(matrix(0, nrow = length(quantiles), 16 | ncol = n.experts), 17 | row.names = quantiles) 18 | names(expert.quantiles) <- expertnames 19 | 20 | if(is.na(values[1]) == T ){ 21 | values <- fit$vals[1,] 22 | } 23 | expert.probs <- data.frame(matrix(0, nrow = length(values), 24 | ncol = n.experts), 25 | row.names = values) 26 | names(expert.probs) <- expertnames 27 | 28 | for(i in 1:n.experts){ 29 | 30 | if(dist == "best"){ 31 | expertDist <- fit$best.fitting[i, 1] 32 | }else{ 33 | expertDist <- dist 34 | } 35 | 36 | 37 | distributions[1, i] <- expertDist 38 | 39 | temp <- feedbacksingle(fit, quantiles, values, ex = i, sf = sfg) 40 | expert.quantiles[, i] <- temp$fitted.quantiles[, expertDist] 41 | expert.probs[, i] <- temp$fitted.probabilities[, expertDist] 42 | } 43 | 44 | 45 | # 18/1/23: have just spotted that outputs are "expert.quantiles" and "expert.probs" 46 | # if multiple experts, but "fitted.quantiles" and "fitted.probabilities" 47 | # if a single expert. I need the naming to be consistent - will use the 48 | # single expert case. 49 | 50 | # list(expert.quantiles = signif(expert.quantiles, sfg), expert.probs = signif(expert.probs, sfg), distributions = distributions) 51 | list(fitted.quantiles = expert.quantiles, 52 | fitted.probabilities = expert.probs, 53 | distributions = distributions) 54 | 55 | } 56 | -------------------------------------------------------------------------------- /man/plotConditionalMedianFunction.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/extensionScripts.R 3 | \name{plotConditionalMedianFunction} 4 | \alias{plotConditionalMedianFunction} 5 | \title{Plot the conditional median function} 6 | \usage{ 7 | plotConditionalMedianFunction( 8 | yCP, 9 | xMed, 10 | yLimits = NULL, 11 | link = "identity", 12 | xlab = "Y", 13 | ylab = "median of X given Y", 14 | fs = 12, 15 | ybreaks = NULL, 16 | xbreaks = NULL 17 | ) 18 | } 19 | \arguments{ 20 | \item{yCP}{vector of conditioning points for the extension variable.} 21 | 22 | \item{xMed}{vector of medians of the target variable, corresponding to 23 | each value of the extension variable in \code{yCP}.} 24 | 25 | \item{yLimits}{limits for the extension variable, used to set the axis limits 26 | in the plot} 27 | 28 | \item{link}{link in the median function. One of \code{"identity"}, 29 | \code{"log"} or \code{"logit"}.} 30 | 31 | \item{xlab}{x-axis label} 32 | 33 | \item{ylab}{y-axis label} 34 | 35 | \item{fs}{font size} 36 | 37 | \item{ybreaks}{tick marks on the y-axis} 38 | 39 | \item{xbreaks}{tick marks on the axis} 40 | } 41 | \description{ 42 | Produces a plot of the conditional median function, given a set of 43 | conditioning points for the extension variable, a set of corresponding 44 | medians of the target variable, given the extension variable, and a choice 45 | of link. The identity link is the default, a log link can be used for 46 | non-negative target variables, and a logit link can be used for target 47 | variables constrained to lie between 0 and 1. 48 | } 49 | \examples{ 50 | \dontrun{ 51 | plotConditionalMedianFunction(yCP = c(3, 5, 7, 9.5, 13.5), 52 | xMed = c(2, 6.5, 9, 13, 20), 53 | yLimits = c(0, 20), 54 | link = "log") 55 | 56 | plotConditionalMedianFunction(yCP = c(2, 4, 6, 8, 10), 57 | xMed = c(0.1, 0.3, 0.5, 0.7, 0.9), 58 | yLimits = c(0, 15), 59 | link = "logit") 60 | 61 | } 62 | 63 | } 64 | \author{ 65 | Jeremy Oakley 66 | } 67 | -------------------------------------------------------------------------------- /man/cdfplot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/cdfplot.R 3 | \name{cdfplot} 4 | \alias{cdfplot} 5 | \title{Plot distribution of CDF} 6 | \usage{ 7 | cdfplot( 8 | medianfit, 9 | precisionfit, 10 | lower = NA, 11 | upper = NA, 12 | ql = 0.025, 13 | qu = 0.975, 14 | median.dist = "best", 15 | precision.dist = "gamma", 16 | n.rep = 10000, 17 | n.X = 100, 18 | fontsize = 18 19 | ) 20 | } 21 | \arguments{ 22 | \item{medianfit}{The output of a \code{fitdist} command following elicitation 23 | of the expert's beliefs about the population median.} 24 | 25 | \item{precisionfit}{The output of a \code{fitdist} command following elicitation 26 | of the expert's beliefs about the population precision.} 27 | 28 | \item{lower}{lower limit on the x-axis for plotting.} 29 | 30 | \item{upper}{upper limit on the x-axis for plotting.} 31 | 32 | \item{ql}{lower quantile for the plotted pointwise credible interval.} 33 | 34 | \item{qu}{upper quantile for the plotted pointwise credible interval.} 35 | 36 | \item{median.dist}{The fitted distribution for the population median. Can be one of \code{"normal"}, 37 | \code{"lognormal"} or \code{"best"}, where \code{"best"} will select the best fitting out of 38 | normal and lognormal.} 39 | 40 | \item{precision.dist}{The fitted distribution for the population precision. Can either be \code{"gamma"} 41 | or \code{"lognormal"}.} 42 | 43 | \item{n.rep}{The number of randomly sampled CDFs used to estimated the median 44 | and credible interval.} 45 | 46 | \item{n.X}{The number of points on the x-axis at which the CDF is evaluated.} 47 | 48 | \item{fontsize}{Font size used in the plots.} 49 | } 50 | \description{ 51 | Plot the elicited pointwise median and credible interval for an uncertain population CDF 52 | } 53 | \examples{ 54 | \dontrun{ 55 | prfit <- fitprecision(interval = c(60, 70), propvals = c(0.2, 0.4), trans = "log") 56 | medianfit <- fitdist(vals = c(50, 60, 70), probs = c(0.05, 0.5, 0.95), lower = 0) 57 | cdfplot(medianfit, prfit) 58 | } 59 | } 60 | -------------------------------------------------------------------------------- /R/checkJudgementsValid.R: -------------------------------------------------------------------------------- 1 | checkJudgementsValid <- function(probs, vals, tdf, lower, upper, silent = TRUE, 2 | excludeExponential = FALSE){ 3 | valid <- TRUE 4 | error <- NULL 5 | 6 | if(any(is.na(probs)) | any(is.na(vals)) ){ 7 | valid <- FALSE 8 | error <- "missing values in probs/vals" 9 | }else{ 10 | 11 | if (length(probs) < 1){ 12 | valid <- FALSE 13 | error <- "need at least one elicited probability" 14 | } 15 | if (min(probs) < 0 | max(probs) > 1 ){ 16 | valid <- FALSE 17 | error <- "probabilities must be between 0 and 1" 18 | } 19 | if (min(vals) < lower){ 20 | valid <- FALSE 21 | error <- "elicited parameter values cannot be smaller than lower parameter limit" 22 | } 23 | if (max(vals) > upper){ 24 | valid <- FALSE 25 | error <- "elicited parameter values cannot be greater than upper parameter limit"} 26 | if (tdf <= 0 ){ 27 | valid <- FALSE 28 | error <- "Student-t degrees of freedom must be greater than 0" 29 | } 30 | if (any(diff(probs) <= 0)){ 31 | valid <- FALSE 32 | error <- "probabilities must be specified in ascending order" 33 | } 34 | if (any(diff(vals) <= 0)){ 35 | valid <- FALSE 36 | error <- "values must be specified in ascending order" 37 | } 38 | if (length(probs) != length(vals)){ 39 | valid <- FALSE 40 | error <- "number of vals must equal number of probs" 41 | } 42 | if (setequal(unique(probs), c(0, 1))){ 43 | valid <- FALSE 44 | error <- "Cannot fit with only elicited probabilities of 0 or 1" 45 | } 46 | if (excludeExponential == TRUE){ 47 | # only use this check if want to exclude option to fit exponential only 48 | if(min(probs[probs>0]) > 0.4 | max(probs[probs <1]) < 0.6){ 49 | valid <- FALSE 50 | error <- "smallest elicited probability must be < 0.4; largest must be > 0.6\n 51 | (Exclude probabilities equalling 0 or 1)." 52 | } 53 | 54 | } 55 | } 56 | list(valid = valid, error = error) 57 | 58 | } -------------------------------------------------------------------------------- /man/elicit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/elicit.R 3 | \name{elicit} 4 | \alias{elicit} 5 | \alias{roulette} 6 | \alias{elicitQuartiles} 7 | \alias{elicitTertiles} 8 | \title{Elicit judgements and fit distributions interactively} 9 | \usage{ 10 | elicit(lower = 0, upper = 100, gridheight = 10, nbins = 10, method = "general") 11 | } 12 | \arguments{ 13 | \item{lower}{A lower limit for the uncertain quantity X. 14 | Will be ignored when fitting distributions that are not bounded below. Also sets 15 | the lower limit for the grid in the roulette method.} 16 | 17 | \item{upper}{An upper limit for the uncertain quantity X. 18 | Will be ignored when fitting distributions that are not bounded above. Also sets 19 | the upper limit for the grid in the roulette method.} 20 | 21 | \item{gridheight}{The number of grid cells for each bin in the roulette method.} 22 | 23 | \item{nbins}{The number of bins used in the rouletted method.} 24 | 25 | \item{method}{Set to "roulette" for the app to display the roulette method by default. 26 | Any other string will display the general method by default.} 27 | } 28 | \value{ 29 | An object of class \code{elicitation}, which is returned once the 30 | Quit button has been clicked. See \code{\link{fitdist}} for details. 31 | } 32 | \description{ 33 | Opens up a web browser (using the shiny package), from which you can specify 34 | judgements, fit distributions and plot the fitted density functions with 35 | additional feedback. Probabilities can be specified directly, or the roulette 36 | elicitation method can be used. 37 | } 38 | \details{ 39 | All input arguments are optional, and can be set/changed within the app itself. 40 | Click on the "Help" tab for instructions. Click the "Quit" button to exit the app and return 41 | the results from the \code{fitdist} command. Click "Download report" to generate a report 42 | of all the fitted distributions. 43 | } 44 | \examples{ 45 | 46 | \dontrun{ 47 | 48 | elicit() 49 | 50 | } 51 | } 52 | \author{ 53 | Jeremy Oakley 54 | } 55 | -------------------------------------------------------------------------------- /R/expertquantiles.R: -------------------------------------------------------------------------------- 1 | expertquantiles <- 2 | function(fit, q, d = "best", ex = 1){ 3 | 4 | if(d == "best"){ 5 | d <- fit$best.fitting[ex, 1] 6 | } 7 | 8 | if(d == "normal"){ 9 | qx <- qnorm(q, fit$Normal[ex,1], fit$Normal[ex,2]) 10 | } 11 | 12 | if(d == "skewnormal"){ 13 | qx <- sn::qsn(q, xi = fit$Skewnormal[ex,1], 14 | omega = fit$Skewnormal[ex,2], 15 | alpha = fit$Skewnormal[ex,3]) 16 | } 17 | 18 | if(d == "t"){ 19 | qx <- fit$Student.t[ex,1] + fit$Student.t[ex,2] * qt(q, fit$Student.t[ex,3]) 20 | } 21 | 22 | if(d == "gamma"){ 23 | xl <- fit$limits[ex,1] 24 | if(xl == -Inf){xl <- 0} 25 | qx <- xl + qgamma(q, fit$Gamma[ex,1], fit$Gamma[ex,2]) 26 | } 27 | 28 | if(d == "mirrorgamma"){ 29 | xu <- fit$limits[ex, 2] 30 | qx <- xu - qgamma(1 - q, fit$mirrorgamma[ex,1], 31 | fit$mirrorgamma[ex,2]) 32 | } 33 | 34 | if(d == "lognormal"){ 35 | xl <- fit$limits[ex,1] 36 | if(xl == -Inf){xl <- 0} 37 | qx <- xl + qlnorm(q, fit$Log.normal[ex,1], fit$Log.normal[ex,2]) 38 | } 39 | 40 | if(d == "mirrorlognormal"){ 41 | xu <- fit$limits[ex, 2] 42 | qx <- xu - qlnorm(1 - q, fit$mirrorlognormal[ex,1], 43 | fit$mirrorlognormal[ex,2]) 44 | } 45 | 46 | if(d == "logt"){ 47 | xl <- fit$limits[ex,1] 48 | if(xl == -Inf){xl <- 0} 49 | qx <- xl + exp(fit$Log.Student.t[ex,1] + fit$Log.Student.t[ex,2] * qt( q , fit$Log.Student.t[ex,3])) 50 | } 51 | 52 | if(d == "mirrorlogt"){ 53 | xu <- fit$limits[ex, 2] 54 | qx <- xu - exp(fit$mirrorlogt[ex,1] + fit$mirrorlogt[ex,2] * qt(1- q , fit$mirrorlogt[ex,3])) 55 | } 56 | 57 | if(d == "beta"){ 58 | xl <- fit$limits[ex,1] 59 | xu <- fit$limits[ex,2] 60 | if(xl == -Inf){xl <- 0} 61 | if(xu == Inf){xu <- 1} 62 | qx <- xl + (xu - xl) * qbeta(q, fit$Beta[ex,1], fit$Beta[ex,2]) 63 | } 64 | 65 | if(d == "hist"){ 66 | qx <- approx(c(0, fit$probs[ex, ], 1), 67 | c(fit$limits[ex, 1], 68 | fit$vals[ex, ], 69 | fit$limits[ex, 2]), 70 | xout = q)$y 71 | } 72 | 73 | qx 74 | 75 | } 76 | -------------------------------------------------------------------------------- /man/makeSurvivalTable.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/makeSurvivalTable.R 3 | \name{makeSurvivalTable} 4 | \alias{makeSurvivalTable} 5 | \title{Tabulate Summary Data for Survival Extrapolation} 6 | \usage{ 7 | makeSurvivalTable( 8 | survDf, 9 | breakTime, 10 | truncationTime, 11 | timeUnit, 12 | useWeights = FALSE, 13 | dp = 2 14 | ) 15 | } 16 | \arguments{ 17 | \item{survDf}{data frame with individual patient data. Needs three columns with names 18 | "time", "event" and "treatment" (in that order). For weighted observations (e.g. 19 | using propensity scores), include a fourth column "weights". 20 | Values in the "event" column should be 0 for a censored observation, and 1 otherwise. 21 | The "treatment" column should be included even if there is only one treatment group.} 22 | 23 | \item{breakTime}{duration of each time interval} 24 | 25 | \item{truncationTime}{time point for the end of the last interval} 26 | 27 | \item{timeUnit}{string variable to give unit of time} 28 | 29 | \item{useWeights}{set to TRUE if survDf includes column of weights, as described in specification 30 | of survDf. This column is passed on to survival::survfit() as the case weights.} 31 | 32 | \item{dp}{number of decimal places to display} 33 | } 34 | \value{ 35 | a data frame with survivor function estimates, 95% confidence intervals, 36 | and within interval hazard estimates for each time interval. 37 | } 38 | \description{ 39 | Tabulates the Kaplan Meier survivor function and within interval hazard at discrete equally spaced time points t_1,...,t_n 40 | "Within interval hazard" is defined as (1-S(t_[n+1])) / S_(t_n), using the Kaplan Meier estimate of S(). 41 | The table is intended to be included on a summary sheet provided to experts when eliciting judgements about 42 | extrapolated survival probabilities. 43 | } 44 | \examples{ 45 | \dontrun{ 46 | sdf <- survival::veteran[, c("time", "status", "trt")] 47 | colnames(sdf) <- c("time", "event", "treatment") 48 | sdf$treatment <- factor(sdf$treatment, labels = c("standard", "test")) 49 | makeSurvivalTable(sdf, breakTime = 50, truncationTime = 250, timeUnit = "months") 50 | } 51 | } 52 | -------------------------------------------------------------------------------- /man/linearPoolDensity.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/linearPoolDensity.R 3 | \name{linearPoolDensity} 4 | \alias{linearPoolDensity} 5 | \title{Obtain points on the density function of a linear pool} 6 | \usage{ 7 | linearPoolDensity(fit, xl = -Inf, xu = Inf, d = "best", lpw = 1, nx = 200) 8 | } 9 | \arguments{ 10 | \item{fit}{An object of class \code{elicitation}.} 11 | 12 | \item{xl}{The lower limit in the sequence of parameter values. The default is the 0.001 quantile 13 | of the fitted distribution (or the 0.001 quantile of a fitted normal 14 | distribution, if a histogram fit is chosen).} 15 | 16 | \item{xu}{The upper limit in the sequence of parameter values. The default is the 0.999 quantile 17 | of the fitted distribution (or the 0.999 quantile of a fitted normal 18 | distribution, if a histogram fit is chosen).} 19 | 20 | \item{d}{The distribution fitted to each expert's probabilities. Options are 21 | \code{"normal"}, \code{"t"}, \code{"gamma"}, \code{"lognormal"}, 22 | \code{"logt"},\code{"beta"}, \code{"hist"} (for a histogram fit), and 23 | \code{"best"} (for best fitting)} 24 | 25 | \item{lpw}{A vector of weights to be used in linear pool, if unequal 26 | weighting is desired.} 27 | 28 | \item{nx}{The number of points in the sequence from \code{xl} to \code{xu}.} 29 | } 30 | \value{ 31 | A list, with elements 32 | \item{x}{a sequence of values for the uncertain parameter} 33 | \item{fx}{the density function of the linear pool, evaluated at each element in \code{x}.} 34 | } 35 | \description{ 36 | Takes an object of class \code{elicitation}, evaluates a (weighted) linear pool, 37 | and returns points on the density function at a sequence of values of the elicited 38 | parameter 39 | } 40 | \examples{ 41 | 42 | \dontrun{ 43 | # Two experts 44 | # Expert 1 states P(X<30)=0.25, P(X<40)=0.5, P(X<50)=0.75 45 | # Expert 2 states P(X<20)=0.25, P(X<25)=0.5, P(X<35)=0.75 46 | # Both experts state 0 56 | } 57 | -------------------------------------------------------------------------------- /man/sampleMarginalFit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/extensionScripts.R 3 | \name{sampleMarginalFit} 4 | \alias{sampleMarginalFit} 5 | \title{Sample from the marginal distribution of the target variable} 6 | \usage{ 7 | sampleMarginalFit( 8 | fitX, 9 | sampleY, 10 | medianY, 11 | yCP, 12 | xMed, 13 | dist = "best", 14 | link = "identity" 15 | ) 16 | } 17 | \arguments{ 18 | \item{fitX}{an object of class \code{elicitation} specifying the 19 | c-distribution: the distribution of the target variable, conditional on the 20 | extension variable taking its median value.} 21 | 22 | \item{sampleY}{a sample from the marginal distribution of the extension 23 | variable.} 24 | 25 | \item{medianY}{the median value of the extension variable.} 26 | 27 | \item{yCP}{vector of conditioning points for the extension variable.} 28 | 29 | \item{xMed}{vector of medians of the target variable, corresponding to 30 | each value of the extension variable in \code{yCP}.} 31 | 32 | \item{dist}{choice of parametric distribution for the c-distribution. Options are 33 | \code{"normal"}, \code{"t"}, \code{"gamma"}, \code{"lognormal"}, 34 | \code{"logt"},\code{"beta"}, \code{"hist"} (for a histogram fit), and 35 | \code{"best"} (for best fitting).} 36 | 37 | \item{link}{link in the median function. One of \code{"identity"}, 38 | \code{"log"} or \code{"logit"}} 39 | } 40 | \value{ 41 | a vector containing a sample from the marginal distribution of 42 | the target variable. 43 | } 44 | \description{ 45 | As part of the Extension Method, this function will generate a random 46 | sample from the marginal distribution of the target variable, using 47 | a sample from the marginal distribution of the extension variable, 48 | the specified c-distribution, and the appropriate judgements used to 49 | construct the median model. 50 | } 51 | \examples{ 52 | \dontrun{ 53 | 54 | myfitX <- fitdist(vals = c(5.5, 9, 14), 55 | probs = c(0.25, 0.5, 0.75), 56 | lower = 0) 57 | ry <- rgamma(10, 5.19, 0.694) 58 | sampleMarginalFit(fitX = myfitX, 59 | sampleY = ry, 60 | medianY = 7, 61 | yCP = c(3, 5, 7, 9.5, 13.5), 62 | xMed = c(2, 6.5, 9, 13, 20), 63 | dist = "lognormal", 64 | link = "log") 65 | } 66 | } 67 | -------------------------------------------------------------------------------- /man/pdfplots.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pdfplots.R 3 | \name{pdfplots} 4 | \alias{pdfplots} 5 | \title{Plot fitted population pdfs} 6 | \usage{ 7 | pdfplots( 8 | medianfit, 9 | precisionfit, 10 | alpha = 0.05, 11 | tails = 0.05, 12 | lower = NA, 13 | upper = NA, 14 | n.x = 100, 15 | d = "best", 16 | fontsize = 18 17 | ) 18 | } 19 | \arguments{ 20 | \item{medianfit}{The output of a \code{fitdist} command following elicitation 21 | of the expert's beliefs about the population median.} 22 | 23 | \item{precisionfit}{The output of a \code{fitdist} command following elicitation 24 | of the expert's beliefs about the population precision.} 25 | 26 | \item{alpha}{Value between 0 and 1 to determine choice of means and variances used in plots} 27 | 28 | \item{tails}{Value between 0 and 1 to determine the tail area shown in the pdf plots} 29 | 30 | \item{lower}{lower limit on the x-axis for plotting.} 31 | 32 | \item{upper}{upper limit on the x-axis for plotting.} 33 | 34 | \item{n.x}{The number of points on the x-axis at which the pdf is plotted.} 35 | 36 | \item{d}{The fitted distribution for the population median. Can be one of "normal", 37 | "lognormal" or "best", where "best" will select the best fitting out of 38 | normal and lognormal.} 39 | 40 | \item{fontsize}{Font size used in the plots.} 41 | } 42 | \value{ 43 | A plot and a list, containing 44 | \item{mu}{The two population mean values used in the plots.} 45 | \item{sigma}{The two population standard deviation values used in the plots.} 46 | } 47 | \description{ 48 | Plot fitted population pdfs at combinations of two different values of the population mean and variance. 49 | } 50 | \details{ 51 | Four pdfs are plotted, using each combination of the \code{alpha}/2 and 1-\code{alpha}/2 52 | quantiles of the fitted distributions for the population median and standard deviation 53 | } 54 | \examples{ 55 | \dontrun{ 56 | prfit <- fitprecision(interval = c(60, 70), propvals = c(0.2, 0.4), trans = "log") 57 | medianfit <- fitdist(vals = c(50, 60, 70), probs = c(0.05, 0.5, 0.95), lower = 0) 58 | pdfplots(medianfit, prfit, alpha = 0.01) 59 | } 60 | } 61 | \references{ 62 | \code{multiplot} function obtained from 63 | \url{http://www.cookbook-r.com/Graphs/Multiple_graphs_on_one_page_(ggplot2)/} 64 | } 65 | -------------------------------------------------------------------------------- /inst/shinyAppFiles/DirichletHelp.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Title 5 | 6 | 7 | 8 | 9 | 10 | 11 |

    Elicitation method

    12 |

    This app implements the method for eliciting a Dirichlet distribution presented in Zapata-Vazquez, R., O'Hagan, A. and Bastos, L. S. (2014). Eliciting expert judgements about a set of proportions. Journal of Applied Statistics 41, 1919-1933.

    13 |
      14 |
    • First, elicit separately a marginal distribution for the population proportion in each category: specify the quantiles ("Cumulative probabilities") to be provided, and then enter these quantile values in the table. Beta distributions will be fitted to each set of judgements.
      • 15 |
    • On the "Fitted Dirichlet" tab, a Dirichlet distribution will be constructed from the elicited marginals, and a plot is shown to compare the marginal distributions implied by the fitted Dirichlet against the original elicited marginals.
      • 16 |
    17 | 18 | 19 |

    Method for fitting the Dirichlet

    20 |

    21 | There are four available methods for determining the sum of the Dirichlet distribution, which result in different fits (though these may be fairly similar):

    22 |
      23 |
    • "best fitting": matching standard deviations from the elicited marginals and the fitted Dirichlet;
      • 24 |
    • "conservative": based on the smallest equivalent sample size (sum of the beta parameters) from the elicited marginals;
      • 25 |
    • median of the smallest and largest largest equivalent sample size from the elicited marginals;
      • 26 |
    • mean of all the equivalent sample sizes from the elicited marginals.
      • 27 |
    28 | See Zapata-Vazquez et al. for more details. 29 | 30 |

    Conditional distributions

    31 |

    In addition to comparing the elicited and fitted marginals, you can also inspect the behaviour of the conditional distributions, as a diagnostic for the choice of the Dirichlet family of distributions. Choose one category, and then specify a hypothetical value for the true population proportion in that category. The marginals from the conditional distribution will be plotted, together with the unconditional marginal distributions. Consider how you might actually revise your marginal distributions given the hypothetical observation, and compare with conditional distributions implied by the Dirichlet.

    32 | 33 | 34 | 35 | -------------------------------------------------------------------------------- /R/expertprobs.R: -------------------------------------------------------------------------------- 1 | expertprobs <- 2 | function(fit, x, d = "best", ex = 1){ 3 | 4 | if(d == "best"){ 5 | d <- fit$best.fitting[ex, 1] 6 | } 7 | 8 | 9 | 10 | if(d == "normal"){ 11 | px <- pnorm(x, fit$Normal[ex,1], fit$Normal[ex,2]) 12 | } 13 | 14 | if(d == "skewnormal"){ 15 | px <- sn::psn(x, xi = fit$Skewnormal[ex,1], 16 | omega = fit$Skewnormal[ex,2], 17 | alpha = fit$Skewnormal[ex,3]) 18 | } 19 | 20 | if(d == "t"){ 21 | px <- pt((x - fit$Student.t[ex,1])/fit$Student.t[ex,2], fit$Student.t[ex,3]) 22 | } 23 | 24 | if(d == "gamma"){ 25 | xl <- fit$limits[ex,1] 26 | if(xl == -Inf){xl <- 0} 27 | px <- pgamma(x - xl, fit$Gamma[ex,1], fit$Gamma[ex,2]) 28 | } 29 | 30 | if(d == "mirrorgamma"){ 31 | xu <- fit$limits[ex, 2] 32 | px <- 1 - pgamma(xu - x, fit$mirrorgamma[ex,1], fit$mirrorgamma[ex,2]) 33 | } 34 | 35 | if(d == "lognormal"){ 36 | xl <- fit$limits[ex,1] 37 | if(xl == -Inf){xl <- 0} 38 | px <- plnorm(x - xl, fit$Log.normal[ex,1], fit$Log.normal[ex,2]) 39 | } 40 | 41 | if(d == "mirrorlognormal"){ 42 | xu <- fit$limits[ex, 2] 43 | px <- 1 - plnorm(xu - x, fit$mirrorlognormal[ex,1], fit$mirrorlognormal[ex,2]) 44 | } 45 | 46 | if(d == "logt"){ 47 | xl <- fit$limits[ex,1] 48 | if(xl == -Inf){xl <- 0} 49 | # Avoid NaN 50 | px <- pt( (log(abs(x - xl)) - fit$Log.Student.t[ex,1]) 51 | / fit$Log.Student.t[ex,2], fit$Log.Student.t[ex,3]) 52 | px[x <= xl] <- 0 # Set to 0 for x < lower limit 53 | } 54 | 55 | if(d == "mirrorlogt"){ 56 | xu <- fit$limits[ex, 2] 57 | # Avoid NaN 58 | px <- 1 - pt( (log(abs(xu - x)) - fit$mirrorlogt[ex,1]) 59 | / fit$mirrorlogt[ex,2], fit$mirrorlogt[ex,3]) 60 | px[x >= xu] <- 1 # Set to 1 for x > upper limit 61 | } 62 | 63 | if(d == "beta"){ 64 | xl <- fit$limits[ex,1] 65 | xu <- fit$limits[ex,2] 66 | if(xl == -Inf){xl <- 0} 67 | if(xu == Inf){xu <- 1} 68 | px <- pbeta( (x - xl) / (xu - xl), fit$Beta[ex,1], fit$Beta[ex,2]) 69 | } 70 | 71 | if(d == "hist"){ 72 | px <- approx(c(fit$limits[ex, 1], 73 | fit$vals[ex, ], 74 | fit$limits[ex, 2]), 75 | c(0, fit$probs[ex, ], 1), 76 | xout = x, 77 | yleft = 0, 78 | yright = 1)$y 79 | } 80 | 81 | px 82 | 83 | } 84 | -------------------------------------------------------------------------------- /R/compareExperts.R: -------------------------------------------------------------------------------- 1 | #' Plot fitted intervals for each expert 2 | #' 3 | #' Following elicitation of distributions from individual experts, plot fitted probability 4 | #' intervals for each expert. 5 | #' 6 | #' @param fit An object of class \code{elicitation} 7 | #' @param interval The probability p for each interval (i.e. the fitted probability for each expert 8 | #' that the displayed interval contains the uncertain quantity will be p) 9 | #' @param dist The distribution fitted to each expert's probabilities. Options are 10 | #' \code{"normal"}, \code{"t"}, \code{"skewnormal"}, \code{"gamma"}, \code{"lognormal"}, 11 | #' \code{"logt"},\code{"beta"}, \code{"mirrorgamma"}, 12 | #' \code{"mirrorlognormal"}, \code{"mirrorlogt"} \code{"hist"} (for a histogram fit), and 13 | #' \code{"best"} (for best fitting). Can be a vector if different distributions are desired for each expert. 14 | #' @param fs font size used in the plot. 15 | #' @param xlab A string or expression giving the x-axis label. 16 | #' @param ylab A string or expression giving the y-axis label. 17 | #' @param showDist TRUE/FALSE for reporting distributions used for each expert 18 | #' 19 | #' @examples 20 | #' 21 | #' \dontrun{ 22 | #' v <- matrix(c(30, 40, 50, 20, 25, 35, 40, 50, 60, 35, 40, 50), 3, 4) 23 | #' p <- c(0.25, 0.5, 0.75) 24 | #' myfit <- fitdist(vals = v, probs = p, lower = 0, upper = 100) 25 | #' compareIntervals(myfit, interval = 0.5) 26 | #' } 27 | #' @export 28 | compareIntervals <- function(fit, interval = 0.95, dist = "best", fs = 12, 29 | xlab = "x", ylab = "expert", showDist = TRUE){ 30 | 31 | low <- med <- up <- NULL # hack to avoid R CMD check NOTE 32 | 33 | n.experts <- nrow(fit$limits) 34 | fb <- feedback(fit, quantiles = c((1 - interval) / 2, 0.5, 0.5 + interval /2), 35 | dist = dist) 36 | df1<-t(fb$fitted.quantiles) 37 | colnames(df1) <- c("low", "med", "up") 38 | expert <-factor(LETTERS[1 : n.experts], levels = LETTERS[n.experts : 1]) 39 | df1<-data.frame(df1, expert) 40 | theme_set(theme_grey(base_size = fs)) 41 | p1<-ggplot(df1, aes(x = low, y = expert)) + 42 | geom_segment(aes(yend = expert, xend = up)) + 43 | geom_point(aes(x = med), colour = "red", size = 3) + 44 | labs(x = xlab, y = ylab) 45 | 46 | if(showDist){ 47 | print(fb$distributions) 48 | } 49 | p1 50 | 51 | } 52 | 53 | 54 | 55 | 56 | -------------------------------------------------------------------------------- /man/plinearpool.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plinearpool.R 3 | \name{plinearpool} 4 | \alias{plinearpool} 5 | \alias{qlinearpool} 6 | \alias{rlinearpool} 7 | \title{Probabilities quantiles and samples from a (weighted) linear pool} 8 | \usage{ 9 | plinearpool(fit, x, d = "best", w = 1) 10 | qlinearpool(fit, q, d = "best", w = 1) 11 | rlinearpool(fit, n, d = "best", w = 1) 12 | } 13 | \arguments{ 14 | \item{fit}{The output of a \code{fitdist} command.} 15 | 16 | \item{x}{A vector of required cumulative probabilities P(X<=x)} 17 | 18 | \item{d}{Scalar or vector of distributions to use for each expert. 19 | Options for each vector element are \code{"hist"}, \code{"normal"}, \code{"t"}, 20 | \code{"gamma"}, \code{"lognormal"}, \code{"logt"},\code{"beta"}, 21 | \code{"best"}. If given as a scalar, same choice is used for all experts.} 22 | 23 | \item{w}{A vector of weights to be used in the weighted linear pool.} 24 | 25 | \item{q}{A vector of required quantiles} 26 | 27 | \item{n}{Number of random samples from the linear pool} 28 | } 29 | \value{ 30 | A probability or quantile, calculate from a (weighted) linear pool 31 | (arithmetic mean) of the experts' individual fitted probability. 32 | } 33 | \description{ 34 | Calculates a linear pool given a set of elicited judgements in a \code{fit} 35 | object. Then calculates required probabilities or quantiles from the pooled 36 | cumulative distribution function, or generates a random sample. 37 | } 38 | \details{ 39 | Quantiles are calculate by first calculating the pooled cumulative 40 | distribution function at 100 points, and then using linear interpolation to 41 | invert the CDF. 42 | } 43 | \examples{ 44 | \dontrun{ 45 | # Expert 1 states P(X<30)=0.25, P(X<40)=0.5, P(X<50)=0.75 46 | # Expert 2 states P(X<20)=0.25, P(X<25)=0.5, P(X<35)=0.75 47 | # Both experts state 0 65 | } 66 | -------------------------------------------------------------------------------- /man/compareGroupRIO.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/compareGroupRIO.R 3 | \name{compareGroupRIO} 4 | \alias{compareGroupRIO} 5 | \title{Compare individual elicited distributions with linear pool and RIO distribution} 6 | \usage{ 7 | compareGroupRIO( 8 | groupFit, 9 | RIOFit, 10 | type = "density", 11 | dLP = "best", 12 | dRIO = "best", 13 | xlab = "x", 14 | ylab = expression(f[X](x)), 15 | fs = 12 16 | ) 17 | } 18 | \arguments{ 19 | \item{groupFit}{either an object of class \code{elicitation}, or the file path 20 | for a .csv file exported from the elicitMultiple() app. This should contain 21 | the individually elicited judgements from the experts} 22 | 23 | \item{RIOFit}{an object of class \code{elicitation} containing a single set of 24 | of probability judgements corresponding to the "Rational Impartial Observer (RIO)".} 25 | 26 | \item{type}{the plot used to show the comparison: one of "quartiles", "tertiles" or "density".} 27 | 28 | \item{dLP}{the distribution fitted to each expert's judgements and to the linear pool. Options are 29 | Options are "normal", "t", "gamma", "lognormal", "logt","beta", "mirrorgamma", 30 | "mirrorlognormal", "mirrorlogt" "hist" (for a histogram fit), and "best" (for best fitting).} 31 | 32 | \item{dRIO}{the distribution fitted to RIO's judgements. Options are the same as for \code{dLP}.} 33 | 34 | \item{xlab}{x-axis label in plot} 35 | 36 | \item{ylab}{y-axis label in plot} 37 | 38 | \item{fs}{font size used in plot} 39 | } 40 | \description{ 41 | Produce one of three plots to compare the individual elicited judgements with the final 42 | elicited distribution, chosen to represent the views of a "Rational Impartatial Observer" (RIO) 43 | as part of the SHELF process. A linear pool of fitted distributions from the individually elicited 44 | judgements is also obtained. The plot choices are a display of the quartiles, a display of the tertiles, 45 | and a plot of the various density functions. 46 | } 47 | \examples{ 48 | \dontrun{ 49 | l <- c(2, 1, 5, 1) 50 | u <- c(95, 90, 65, 40) 51 | v <- matrix(c(15, 25, 40, 52 | 10, 20, 40, 53 | 10, 15, 25, 54 | 5, 10, 20), 55 | 3, 4) 56 | p <- c(0.25, 0.5, 0.75) 57 | group <- fitdist(vals = v, probs = p, lower = l, upper = u) 58 | rio <- fitdist(vals = c(12, 20, 25), probs = p, lower = 1, upper = 100) 59 | compareGroupRIO(groupFit = group, RIOFit = rio, dRIO = "gamma") 60 | } 61 | } 62 | \author{ 63 | Jeremy Oakley 64 | } 65 | -------------------------------------------------------------------------------- /man/copulaSample.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/elicitCopula.R 3 | \name{copulaSample} 4 | \alias{copulaSample} 5 | \title{Generate correlated samples from elicited marginal distributions using a multivariate normal copula} 6 | \usage{ 7 | copulaSample(..., cp, n, d = NULL, ex = 1) 8 | } 9 | \arguments{ 10 | \item{...}{A list of objects of class \code{elicitation}. 11 | command, one per marginal distribution, separated by commas.} 12 | 13 | \item{cp}{A matrix of pairwise concordance probabilities, with element i,j the elicited probability 14 | P(X_i > m_i, X_j > m_j or X_i < m_i, X_j < m_j), where m_i and m_j are the elicited medians of the uncertain quantities X_i and X_j. 15 | Only the upper triangular elements in the matrix need to be specified; the remaining elements can be set at 0.} 16 | 17 | \item{n}{The sample size to be generated} 18 | 19 | \item{d}{A vector of distributions to be used for each elicited quantity: a string with elements chosen from 20 | \code{"normal", "t", "gamma", "lognormal", "logt", "beta", "mirrorgamma", "mirrorlognormal", "mirrorlogt"}. The default is to use 21 | the best fitting distribution in each case.} 22 | 23 | \item{ex}{If separate judgements have been elicited from multiple experts and stored 24 | in the \code{elicitation} objects, use this argument to select a single expert's judgements 25 | for sampling. Note that this function will not simultaneously generate samples for all experts.} 26 | } 27 | \value{ 28 | A matrix of sampled values, one row per sample. 29 | } 30 | \description{ 31 | Takes elicited marginal distributions and elicited concordance probabilities: pairwise 32 | probabilities of two uncertain quantities being greater than their medians, and generates 33 | a correlated sample, assuming the elicited marginal distributions and a multivariate 34 | normal copula. A vignette explaining this method is available at \url{https://oakleyj.github.io/SHELF/Multivariate-normal-copula.html} 35 | } 36 | \examples{ 37 | \dontrun{ 38 | p1 <- c(0.25, 0.5, 0.75) 39 | v1 <- c(0.5, 0.55, 0.6) 40 | v2 <- c(0.22, 0.3, 0.35) 41 | v3 <- c(0.11, 0.15, 0.2) 42 | myfit1 <- fitdist(v1, p1, 0, 1) 43 | myfit2 <- fitdist(v2, p1, 0, 1) 44 | myfit3 <- fitdist(v3, p1, 0, 1) 45 | quad.probs <- matrix(0, 3, 3) 46 | quad.probs[1, 2] <- 0.4 47 | quad.probs[1, 3] <- 0.4 48 | quad.probs[2, 3] <- 0.3 49 | copulaSample(myfit1, myfit2, myfit3, cp=quad.probs, n=100, d=NULL) 50 | } 51 | } 52 | \author{ 53 | Jeremy Oakley \href{mailto:j.oakley@sheffield.ac.uk}{j.oakley@sheffield.ac.uk} 54 | } 55 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/plots/error-message-plot.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | Distribution has not been fitted. Requirements are 30 | - smallest elicited probability < 0.4 31 | - largest elicited probability > 0.6 32 | - at least three elicited probabilties 33 | Available fitted distributions are: 34 | histogram, gamma, mirror gamma 35 | 36 | 37 | error message plot 38 | 39 | 40 | -------------------------------------------------------------------------------- /R/expertdensity.R: -------------------------------------------------------------------------------- 1 | expertdensity <- 2 | function(fit, d = "best", ex = 1, pl, pu, ql = NULL, qu = NULL, nx = 200){ 3 | 4 | if(pl == -Inf){pl <- qnorm(0.001, fit$Normal[ex,1], fit$Normal[ex,2])} 5 | if(pu == Inf){pu <- qnorm(0.999, fit$Normal[ex,1], fit$Normal[ex,2])} 6 | 7 | x <- unique(sort(c(seq(from = pl, to = pu, length = nx), ql, qu))) 8 | 9 | 10 | if(d == "best"){ 11 | d <- fit$best.fitting[ex, 1] 12 | } 13 | 14 | if(d == "normal"){ 15 | fx <- dnorm(x, fit$Normal[ex,1], fit$Normal[ex,2]) 16 | } 17 | 18 | if(d == "t"){ 19 | fx <- dt((x - fit$Student.t[ex,1])/fit$Student.t[ex,2], fit$Student.t[ex,3])/fit$Student.t[ex,2] 20 | } 21 | 22 | if(d == "skewnormal"){ 23 | fx <- sn::dsn(x, fit$Skewnormal[ex, 1], 24 | fit$Skewnormal[ex, 2], 25 | fit$Skewnormal[ex, 3]) 26 | } 27 | 28 | if(d == "gamma"){ 29 | xl <- fit$limits[ex,1] 30 | if(xl == -Inf){xl <- 0} 31 | fx <- dgamma(x - xl, fit$Gamma[ex,1], fit$Gamma[ex,2]) 32 | } 33 | 34 | if(d == "mirrorgamma"){ 35 | xu <- fit$limits[ex, 2] 36 | fx <- dgamma(xu - x, fit$mirrorgamma[ex,1], fit$mirrorgamma[ex,2]) 37 | } 38 | 39 | if(d == "lognormal"){ 40 | xl <- fit$limits[ex,1] 41 | if(xl == -Inf){xl <- 0} 42 | fx <- dlnorm(x - xl, fit$Log.normal[ex,1], fit$Log.normal[ex,2]) 43 | } 44 | 45 | if(d == "mirrorlognormal"){ 46 | xu <- fit$limits[ex, 2] 47 | fx <- dlnorm(xu - x, fit$mirrorlognormal[ex,1], fit$mirrorlognormal[ex,2]) 48 | } 49 | 50 | if(d == "logt"){ 51 | xl <- fit$limits[ex,1] 52 | if(xl == -Inf){xl <- 0} 53 | fx <- dt( (log(abs(x - xl)) - fit$Log.Student.t[ex,1]) / fit$Log.Student.t[ex,2], fit$Log.Student.t[ex,3]) / ((x - xl) * fit$Log.Student.t[ex,2]) 54 | fx[x<= xl] <- 0 # Hack to avoid NaN 55 | 56 | } 57 | 58 | if(d == "mirrorlogt"){ 59 | xu <- fit$limits[ex,2] 60 | fx <- dt( (log(abs(xu - x)) - fit$mirrorlogt[ex,1]) / 61 | fit$mirrorlogt[ex,2], fit$mirrorlogt[ex,3]) / ((xu - x) * fit$mirrorlogt[ex,2]) 62 | fx[x>= xu] <- 0 # Hack to avoid NaN 63 | 64 | } 65 | 66 | 67 | 68 | if(d == "beta"){ 69 | xl <- fit$limits[ex,1] 70 | xu <- fit$limits[ex,2] 71 | if(xl == -Inf){xl <- 0} 72 | if(xu == Inf){xu <- 1} 73 | fx <- 1/(xu - xl) * dbeta( (x - xl) / (xu - xl), fit$Beta[ex,1], fit$Beta[ex,2]) 74 | } 75 | 76 | if(d == "hist"){ 77 | 78 | fx <- dhist(x, c(fit$limits[ex, 1], 79 | fit$vals[ex,], 80 | fit$limits[ex, 2]), 81 | c(0, fit$probs[ex, ],1)) 82 | fx[length(fx)] <- 0 83 | } 84 | 85 | 86 | list(x = x, fx = fx) 87 | 88 | } 89 | -------------------------------------------------------------------------------- /R/plotQuartiles.R: -------------------------------------------------------------------------------- 1 | #' Plot elicited quartiles, median and plausible range for each expert 2 | #' 3 | #' Displays a horizontal bar for each expert, to represent the expert's plausible range. 4 | #' The coloured sections indicate the experts' quartiles: four intervals judged by the expert 5 | #' to be equally likely. The experts' medians are shown as dashed lines. 6 | #' 7 | #' 8 | #' @param vals a matrix of elicited quartiles and medians: one column per expert, first 9 | #' row is the 25th percentile, 2nd row is the median, last row is the 75th percentile. 10 | #' @param lower a vector of lower plausible limits: one per expert 11 | #' @param upper a vector of upper plausible limits: one per expert 12 | #' @param fs font size to be used in the plot 13 | #' @param expertnames vector of experts' names 14 | #' @param xl vector of limits for x-axis 15 | #' @param xlabel x-axis label 16 | # 17 | 18 | #' @author Jeremy Oakley 19 | #' @examples 20 | #' \dontrun{ 21 | #' l <- c(2, 1, 5, 1) 22 | #' u <- c(95, 90, 65, 40) 23 | #' v <- matrix(c(15, 25, 40, 24 | #' 10, 20, 40, 25 | #' 10, 15, 25, 26 | #' 5, 10, 20), 27 | #' 3, 4) 28 | #' plotQuartiles(vals = v, lower = l, upper = u) 29 | #' } 30 | #' @export 31 | 32 | plotQuartiles <- function(vals, lower, upper, fs = 12, 33 | expertnames = NULL, 34 | xl = NULL, 35 | xlabel = "X"){ 36 | 37 | low <- L <- Q1 <- M <- Q2 <- U <- enumber <- NULL # hack to pass CRAN check 38 | 39 | n.experts <- ncol(vals) 40 | if(is.null(expertnames)){ 41 | expert <-factor(LETTERS[1 : n.experts], levels = LETTERS[n.experts : 1]) 42 | }else{ 43 | expert <- factor(expertnames, levels = expertnames) 44 | } 45 | cols <- gg_color_hue(4) 46 | 47 | df1 <- data.frame(cbind(lower, t(vals), upper)) 48 | colnames(df1) <- c("L", "Q1", "M", "Q2", "U") 49 | df1$expert <- expert 50 | df1$enumber <- n.experts:1 51 | p1 <- ggplot(df1, aes(x = low, y = expert)) + 52 | geom_segment(aes(yend = expert, x=L, xend = Q1), lwd = 10, col = cols[1])+ 53 | geom_segment(aes(yend = expert, x=Q1, xend = M), lwd = 10, col = cols[2])+ 54 | geom_segment(aes(yend = expert, x=M, xend = Q2), lwd = 10, col = cols[3])+ 55 | geom_segment(aes(yend = expert, x=Q2, xend = U), lwd = 10, col = cols[4])+ 56 | labs(x = xlabel) + 57 | theme(text = element_text(size = fs)) 58 | if(!is.null(xl)){ 59 | p1 <- p1 + xlim(xl) 60 | } 61 | p1 62 | } 63 | 64 | 65 | gg_color_hue <- function(n) { 66 | hues = seq(15, 375, length = n + 1) 67 | grDevices::hcl(h = hues, l = 65, c = 100)[1:n] 68 | } 69 | -------------------------------------------------------------------------------- /tests/testthat/test-extension-method.R: -------------------------------------------------------------------------------- 1 | test_that("extension: normal Y, normal X | Y ",{ 2 | skip_on_cran() 3 | mY <- 5 4 | sY <- 2 5 | # c-distribution X| Y = 5 ~ N(3, 3^2) 6 | a <- 1 7 | b <- 2 8 | mX <- a + b * mY 9 | sX <- 3 10 | myfit <- fitdist(qnorm(c(0.25, 0.5, 0.75), mX, sX), 11 | c(0.25, 0.5, 0.75)) 12 | N <- 100000 13 | rY <- rnorm(N, mY, sY) 14 | yHyp <- c(0, 5, 10) 15 | x <- sampleMarginalFit(fitX = myfit, 16 | sampleY = rY, 17 | medianY = mY, 18 | yCP = yHyp, 19 | xMed = a + b * yHyp) 20 | se <- sqrt(var(x) / N) 21 | expect_equal(mean(x), a+ b * mY, tolerance = 4 * se) 22 | expect_equal(var(x)^0.5, sqrt(b^2 *sY^2 + sX^2), tolerance = 0.1) 23 | 24 | }) 25 | 26 | test_that("extension: normal Y, lognormal X | Y ",{ 27 | skip_on_cran() 28 | mY <- 2 29 | sY <- 1 30 | # c-distribution log X | Y = 5 ~ N(3, 3^2) 31 | a <- 1 32 | b <- -2 33 | mX <- a + b * mY 34 | sX <- 0.5 35 | myfit <- fitdist(qlnorm(c(0.25, 0.5, 0.75), mX, sX), 36 | c(0.25, 0.5, 0.75), 37 | lower = 0) 38 | N <- 100000 39 | rY <- rnorm(N, mY, sY) 40 | yHyp <- c(0, 2, 4) 41 | x <- sampleMarginalFit(fitX = myfit, 42 | sampleY = rY, 43 | medianY = mY, 44 | yCP = yHyp, 45 | xMed = exp(a + b * yHyp), 46 | link = "log") 47 | se <- sqrt(var(log(x)) / N) 48 | expect_equal(mean(log(x)), a+ b * mY, tolerance = 4 * se) 49 | expect_equal(var(log(x))^0.5, sqrt(b^2 *sY^2 + sX^2), tolerance = 0.1) 50 | 51 | }) 52 | 53 | test_that("extension: sum of Gamma random variables ",{ 54 | skip_on_cran() 55 | a <- 2 56 | b <- 3 57 | theta <- 4 58 | # c-distribution log X | Y = 5 ~ N(3, 3^2) 59 | mY <- qgamma(0.5, b, theta) 60 | myfit <- fitdist(mY + qgamma(c(0.25, 0.5, 0.75), a, theta), 61 | c(0.25, 0.5, 0.75), 62 | lower = mY) 63 | N <- 100000 64 | rY <- rgamma(N, b, theta) 65 | yHyp <- qgamma(c(0.05, 0.5, 0.95), b, theta) 66 | x <- sampleMarginalFit(fitX = myfit, 67 | sampleY = rY, 68 | medianY = mY, 69 | yCP = yHyp, 70 | xMed = yHyp + qgamma(0.5, a, theta), 71 | link = "identity") 72 | se <- sqrt(var(x) / N) 73 | expect_equal(mean(x), a/theta + b/theta, tolerance = 4 * se) 74 | expect_equal(var(x)^0.5, (a/theta^2 + b/theta^2)^0.5, tolerance = 0.1) 75 | 76 | 77 | }) -------------------------------------------------------------------------------- /man/makeCDFPlot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/makeCDFPlot.R 3 | \name{makeCDFPlot} 4 | \alias{makeCDFPlot} 5 | \title{Plot the elicited cumulative probabilities} 6 | \usage{ 7 | makeCDFPlot( 8 | lower, 9 | v, 10 | p, 11 | upper, 12 | fontsize = 12, 13 | fit = NULL, 14 | dist = NULL, 15 | showFittedCDF = FALSE, 16 | showQuantiles = FALSE, 17 | ql = 0.05, 18 | qu = 0.95, 19 | ex = 1, 20 | sf = 3, 21 | xaxisLower = lower, 22 | xaxisUpper = upper, 23 | xlab = "x", 24 | ylab = expression(P(X <= x)) 25 | ) 26 | } 27 | \arguments{ 28 | \item{lower}{lower limit for the uncertain quantity} 29 | 30 | \item{v}{vector of values, for each value x in Pr(X<=x) = p 31 | in the set of elicited probabilities} 32 | 33 | \item{p}{vector of probabilities, for each value p in Pr(X<=x) = p 34 | in the set of elicited probabilities} 35 | 36 | \item{upper}{upper limit for the uncertain quantity} 37 | 38 | \item{fontsize}{font size to be used in the plot} 39 | 40 | \item{fit}{object of class \code{elicitation}} 41 | 42 | \item{dist}{the fitted distribution to be plotted. Options are 43 | \code{"normal"}, \code{"t"}, \code{"skewnormal"}, \code{"gamma"}, \code{"lognormal"}, 44 | \code{"logt"},\code{"beta"}, \code{"mirrorgamma"}, 45 | \code{"mirrorlognormal"}, \code{"mirrorlogt"} \code{"hist"} (for a histogram fit)} 46 | 47 | \item{showFittedCDF}{logical. Should a fitted distribution function 48 | be displayed?} 49 | 50 | \item{showQuantiles}{logical. Should quantiles from the fitted distribution function 51 | be displayed?} 52 | 53 | \item{ql}{a lower quantile to be displayed.} 54 | 55 | \item{qu}{an upper quantile to be displayed.} 56 | 57 | \item{ex}{if the object \code{fit} contains judgements from multiple experts, 58 | which (single) expert's judgements to show.} 59 | 60 | \item{sf}{number of significant figures to be displayed.} 61 | 62 | \item{xaxisLower}{lower limit for the x-axis.} 63 | 64 | \item{xaxisUpper}{upper limit for the x-axis.} 65 | 66 | \item{xlab}{x-axis label.} 67 | 68 | \item{ylab}{y-axis label.} 69 | } 70 | \description{ 71 | Plots the elicited cumulative probabilities and, optionally, 72 | a fitted CDF. Elicited are shown as filled circles, and 73 | limits are shown as clear circles. 74 | } 75 | \examples{ 76 | 77 | \dontrun{ 78 | vQuartiles <- c(30, 35, 45) 79 | pQuartiles<- c(0.25, 0.5, 0.75) 80 | myfit <- fitdist(vals = vQuartiles, probs = pQuartiles, lower = 0) 81 | makeCDFPlot(lower = 0, v = vQuartiles, p = pQuartiles, 82 | upper = 100, fit = myfit, dist = "gamma", 83 | showFittedCDF = TRUE, showQuantiles = TRUE) 84 | 85 | 86 | } 87 | 88 | } 89 | -------------------------------------------------------------------------------- /man/plotConditionalDensities.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/extensionScripts.R 3 | \name{plotConditionalDensities} 4 | \alias{plotConditionalDensities} 5 | \title{Plot density of the target variable, conditional on the extension variable} 6 | \usage{ 7 | plotConditionalDensities( 8 | y, 9 | fitX, 10 | yCP, 11 | xMed, 12 | medianY, 13 | link = "identity", 14 | dist = "best", 15 | N = 1e+05, 16 | xLimits = NULL, 17 | fs = 12 18 | ) 19 | } 20 | \arguments{ 21 | \item{y}{vector of values for the extension variable 22 | at which to condition on.} 23 | 24 | \item{fitX}{an object of class \code{elicitation} specifying the 25 | c-distribution: the distribution of the target variable, conditional on the 26 | extension variable taking its median value.} 27 | 28 | \item{yCP}{vector of conditioning points for the extension variable.} 29 | 30 | \item{xMed}{vector of medians of the target variable, corresponding to 31 | each value of the extension variable in \code{yCP}.} 32 | 33 | \item{medianY}{the median value of the extension variable.} 34 | 35 | \item{link}{link in the median function. One of \code{"identity"}, 36 | \code{"log"} or \code{"logit"}} 37 | 38 | \item{dist}{choice of parametric distribution for the c-distribution. Options are 39 | \code{"normal"}, \code{"t"}, \code{"gamma"}, \code{"lognormal"}, 40 | \code{"logt"},\code{"beta"}, \code{"hist"} (for a histogram fit), and 41 | \code{"best"} (for best fitting).} 42 | 43 | \item{N}{sample size used in the kernel density estimate} 44 | 45 | \item{xLimits}{x-axis limits} 46 | 47 | \item{fs}{font size} 48 | } 49 | \description{ 50 | Plots kernel density estimates of the target variable, conditional on 51 | each of a set of specified values of the extension variable. The plot 52 | makes use of the function \code{ggridges::geom_density_ridges()}, and so 53 | uses kernel density estimates rather than the exact conditional density 54 | function. 55 | } 56 | \examples{ 57 | \dontrun{ 58 | 59 | myfitX <- fitdist(vals = c(5.5, 9, 14), 60 | probs = c(0.25, 0.5, 0.75), 61 | lower = 0) 62 | 63 | plotConditionalDensities(y = c(2, 6, 10), 64 | fitX = myfitX, 65 | yCP = c(3, 5, 7, 9.5, 13.5), 66 | xMed = c(2, 6.5, 9, 13, 20), 67 | medianY = 7, 68 | link = "log", 69 | dist = "lognormal", 70 | xLimits = c(0, 60)) 71 | 72 | 73 | # Example with the logit link 74 | 75 | myfitXlogit <- fitdist(vals = c(0.2, 0.25, 0.3), 76 | probs = c(0.25, 0.5, 0.75), 77 | lower = 0, 78 | upper = 1) 79 | 80 | plotConditionalDensities(y = c(2, 6, 10), 81 | fitX = myfitXlogit, 82 | yCP = c(2, 4, 6, 8, 10), 83 | xMed = c(0.1, 0.3, 0.5, 0.7, 0.9), 84 | medianY = 6, 85 | link = "logit", 86 | dist = "beta") 87 | 88 | } 89 | 90 | } 91 | -------------------------------------------------------------------------------- /man/survivalScenario.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/survivalScenario.R 3 | \name{survivalScenario} 4 | \alias{survivalScenario} 5 | \title{Scenario Testing for Survival Extrapolation} 6 | \usage{ 7 | survivalScenario( 8 | tLower = 0, 9 | tUpper, 10 | expLower, 11 | expUpper, 12 | tTarget, 13 | survDf, 14 | groups = unique(survDf$treatment), 15 | expGroup = unique(survDf$treatment)[1], 16 | useWeights = FALSE, 17 | xl = "Time", 18 | fontsize = 12, 19 | showPlot = TRUE 20 | ) 21 | } 22 | \arguments{ 23 | \item{tLower}{lower limit for x-axis.} 24 | 25 | \item{tUpper}{upper limit for x-axis.} 26 | 27 | \item{expLower}{start time at which constant hazard is assumed.} 28 | 29 | \item{expUpper}{end time for using data to estimate constant hazard; 30 | data after this time will be censored.} 31 | 32 | \item{tTarget}{target extrapolation time.} 33 | 34 | \item{survDf}{data frame with individual patient data. Needs three columns with names 35 | "time", "event" and "treatment" (in that order). For weighted observations (e.g. 36 | using propensity scores), include a fourth column "weights". 37 | Values in the "event" column should be 0 for a censored observation, and 1 otherwise. 38 | The "treatment" column should be included even if there is only one treatment group.} 39 | 40 | \item{groups}{character vector of names of the treatment group. Extracted from survDF by default.} 41 | 42 | \item{expGroup}{selected treatment group for extrapolating} 43 | 44 | \item{useWeights}{set to TRUE if survDf includes column of weights, as described in specification 45 | of survDf. This column is passed on to survival::survreg() and survival::survfit() as the case weights.} 46 | 47 | \item{xl}{x-axis label} 48 | 49 | \item{fontsize}{plot fontsize} 50 | 51 | \item{showPlot}{whether to display the plot} 52 | } 53 | \value{ 54 | A list containing the elements 55 | \item{KMplot}{a ggplot2 plot object;} 56 | \item{interval}{an approximate 95% credible interval for the survival proportion 57 | at the target extrapolation time.} 58 | } 59 | \description{ 60 | Provides a plot and approximate 95 percent credible interval for an 61 | extrapolated survival time, based on a assumption of constant hazard 62 | after some specified time. Intended to be used as part of the SHELF protocol 63 | for elicitation for survival extrapolation. 64 | } 65 | \examples{ 66 | \dontrun{ 67 | sdf <- survival::veteran[, c("time", "status", "trt")] 68 | colnames(sdf) <- c("time", "event", "treatment") 69 | sdf$treatment <- factor(sdf$treatment, labels = c("standard", "test")) 70 | survivalScenario(tLower = 0,tUpper = 150, expLower = 100, expUpper = 150, 71 | tTarget = 250, survDf = sdf, 72 | expGroup = "standard") 73 | } 74 | } 75 | -------------------------------------------------------------------------------- /R/plotTertiles.R: -------------------------------------------------------------------------------- 1 | #' Plot elicted tertiles, median and plausible range for each expert 2 | #' 3 | #' Displays a horizontal bar for each expert, to represent the expert's plausible range. 4 | #' The coloured sections indicate the experts' tertiles: three intervals judged by the expert 5 | #' to be equally likely. The experts' medians are shown as dashed lines. 6 | #' 7 | #' 8 | #' @param vals a matrix of elicited tertiles and medians: one column per expert, first 9 | #' row is the 33rd percentile, 2nd row is the median, last row is the 66th percentile. 10 | #' @param lower a vector of lower plausible limits: one per expert 11 | #' @param upper a vector of upper plausible limits: one per expert 12 | #' @param fs font size to be used in the plot 13 | #' @param percentages set to \code{TRUE} to use percentages on the x-axis 14 | #' @param expertnames vector of experts' names 15 | #' @param xl vector of limits for x-axis 16 | #' @param xlabel x-axis label 17 | # 18 | 19 | #' @author Jeremy Oakley 20 | #' @examples 21 | #' \dontrun{ 22 | #' l <- c(-5, 0, 5, -10) 23 | #' u <- c(15, 35, 50, 35) 24 | #' v <- matrix(c(5, 8, 10, 25 | #' 10, 15, 20, 26 | #' 15, 18, 25, 27 | #' 10, 20, 30), 28 | #' 3, 4) 29 | #' plotTertiles(vals = v, lower = l, upper = u) 30 | #' } 31 | #' @export 32 | 33 | plotTertiles <- function(vals, lower, upper, fs = 12, 34 | percentages = FALSE, 35 | expertnames = NULL, 36 | xl = NULL, 37 | xlabel = "X"){ 38 | 39 | low <- L <- T1 <- M <- T2 <- U <- enumber <- NULL # hack to pass CRAN check 40 | 41 | 42 | n.experts <- ncol(vals) 43 | 44 | if(is.null(expertnames)){ 45 | expert <-factor(LETTERS[1 : n.experts], levels = LETTERS[n.experts : 1]) 46 | }else{ 47 | expert <- factor(expertnames, levels = expertnames) 48 | } 49 | cols <- gg_color_hue(3) 50 | 51 | df1 <- data.frame(cbind(lower, t(vals), upper)) 52 | colnames(df1) <- c("L", "T1", "M", "T2", "U") 53 | df1$expert <- expert 54 | df1$enumber <- as.numeric(df1$expert) 55 | p1 <- ggplot(df1, aes(x = low, y = expert)) + 56 | geom_segment(aes(yend = expert, x=L, xend = T1), lwd = 10, col = cols[1])+ 57 | geom_segment(aes(yend = expert, x=T1, xend = T2), lwd = 10, col = cols[2])+ 58 | geom_segment(aes(yend = expert, x=T2, xend = U), lwd = 10, col = cols[3])+ 59 | geom_segment(aes(y = enumber -0.15, yend = enumber + 0.15, x = M, xend =M), 60 | lwd = 1, linetype = "dashed")+ 61 | labs(x = xlabel) + 62 | theme(text = element_text(size = fs)) 63 | if(percentages){ 64 | p1 <- p1 + scale_x_continuous(labels = scales::percent) 65 | } 66 | if(!is.null(xl)){ 67 | p1 <- p1 + xlim(xl) 68 | } 69 | p1 70 | } 71 | 72 | 73 | 74 | -------------------------------------------------------------------------------- /man/elicitHeterogen.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/elicitHeterogeneity.R 3 | \name{elicitHeterogen} 4 | \alias{elicitHeterogen} 5 | \title{Elicit a prior distribution for a random effects variance parameter} 6 | \usage{ 7 | elicitHeterogen( 8 | lower = 1, 9 | upper = 10, 10 | gridheight = 10, 11 | nbins = 9, 12 | scale.free = TRUE, 13 | sigma = 1 14 | ) 15 | } 16 | \arguments{ 17 | \item{lower}{The lower limit on the x-axis of the roulette grid.} 18 | 19 | \item{upper}{The upper limit on the x-axis of the roulette grid.} 20 | 21 | \item{gridheight}{The maximum number of probs that can be allocated to a 22 | single bin.} 23 | 24 | \item{nbins}{The number of equally sized bins drawn between \code{lower} and 25 | \code{upper}.} 26 | 27 | \item{scale.free}{Logical. Default is \code{TRUE} for a scale free treatment effect, 28 | such as an odds ratio, hazard ratio or relative risk. Set to \code{FALSE} for a treatment effect 29 | that is scale dependent, or is on the probit scale. An approximation to the treatment effect 30 | on the logit scale will be used (assuming a dichotomised response).} 31 | 32 | \item{sigma}{Individual observation standard deviation, required if \code{scale.free} is 33 | \code{FALSE}.} 34 | } 35 | \value{ 36 | BUGS code for incorporating the prior within a BUGS model. Additionally, a list with outputs 37 | \item{allocation }{table of bins, with number of probs allocated to each bin.} 38 | \item{Gamma }{parameters of the fitted gamma distribution.} 39 | \item{Log.normal }{parameters of the fitted lognormal distribution.} 40 | \item{sumsq }{sum of squares of elicited - fitted probabilities for each distribution.} 41 | \item{best.fitting}{the distribution with the lowest sum of squares.} 42 | } 43 | \description{ 44 | Opens a shiny app for the roulette elicitation method. The user clicks in the 45 | grid to allocate 'probs' to 'bins'. The elicited probability inside each 46 | bin is the proportion of probs in each bin. This will fit a distribution to the ratio R 47 | of the 'largest' (97.5th percentile) to 'smallest' (2.5th percentile) treatment effect. 48 | A distribution for the variance effects variance parameter is inferred from the distribution 49 | of R, assuming that the random effects are normally distributed. 50 | } 51 | \note{ 52 | Regarding the option ``spread end probs over empty bins'' 53 | (unchecked as the default): suppose for example, the leftmost and rightmost non-empty 54 | bins are [10,20] and [70,80], and each contain one prob, with 20 probs used in total. If the option 55 | is unchecked, it is assumed P(X<20) = P(X>70) = 0.05 and P(X<10) = P(X>80) = 0. If the option 56 | is checked, it is assumed P(X<20) = P(X>70) = 0.05 only. 57 | } 58 | \examples{ 59 | 60 | \dontrun{ 61 | elicitHeterogen() 62 | } 63 | } 64 | \author{ 65 | Jeremy Oakley 66 | } 67 | -------------------------------------------------------------------------------- /R/plinearpool.R: -------------------------------------------------------------------------------- 1 | #' Probabilities quantiles and samples from a (weighted) linear pool 2 | #' 3 | #' Calculates a linear pool given a set of elicited judgements in a \code{fit} 4 | #' object. Then calculates required probabilities or quantiles from the pooled 5 | #' cumulative distribution function, or generates a random sample. 6 | #' 7 | #' Quantiles are calculate by first calculating the pooled cumulative 8 | #' distribution function at 100 points, and then using linear interpolation to 9 | #' invert the CDF. 10 | #' 11 | #' @usage plinearpool(fit, x, d = "best", w = 1) 12 | #' qlinearpool(fit, q, d = "best", w = 1) 13 | #' rlinearpool(fit, n, d = "best", w = 1) 14 | #' @aliases plinearpool qlinearpool rlinearpool 15 | #' @param fit The output of a \code{fitdist} command. 16 | #' @param x A vector of required cumulative probabilities P(X<=x) 17 | #' @param q A vector of required quantiles 18 | #' @param n Number of random samples from the linear pool 19 | #' @param d Scalar or vector of distributions to use for each expert. 20 | #' Options for each vector element are \code{"hist"}, \code{"normal"}, \code{"t"}, 21 | #' \code{"gamma"}, \code{"lognormal"}, \code{"logt"},\code{"beta"}, 22 | #' \code{"best"}. If given as a scalar, same choice is used for all experts. 23 | #' @param w A vector of weights to be used in the weighted linear pool. 24 | #' @return A probability or quantile, calculate from a (weighted) linear pool 25 | #' (arithmetic mean) of the experts' individual fitted probability. 26 | #' @author Jeremy Oakley 27 | #' @examples 28 | #' \dontrun{ 29 | #' # Expert 1 states P(X<30)=0.25, P(X<40)=0.5, P(X<50)=0.75 30 | #' # Expert 2 states P(X<20)=0.25, P(X<25)=0.5, P(X<35)=0.75 31 | #' # Both experts state 0 72 | } 73 | -------------------------------------------------------------------------------- /inst/shinyAppFiles/elicitationShinySummaryExtensionUploadedYsample.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Fitted distributions (extension method)" 3 | output: 4 | html_document: default 5 | pdf_document: default 6 | word_document: default 7 | date: "`r format(Sys.time(), '%d %B %Y, %H:%M')`" 8 | fontsize: 11pt 9 | params: 10 | fit1: NA 11 | fit2: NA 12 | cp: NA 13 | d: NA 14 | m1: NA 15 | m2: NA 16 | yLimits: NA 17 | link: NA 18 | yCP: NA 19 | xMed: NA 20 | df1: NA 21 | ry: NA 22 | 23 | --- 24 | 25 | # Marginal distribution of $Y$ 26 | 27 | ```{r global_options, include=FALSE} 28 | knitr::opts_chunk$set(echo=FALSE, warning=FALSE, message=FALSE) 29 | showplots <- FALSE 30 | ``` 31 | 32 | A sample was uploaded for the marginal distibution of the extension variable. Summary statistics and a histogram plot are as follows 33 | 34 | ```{r, echo = FALSE, fig.align = "center", message = FALSE} 35 | options(digits = 4) 36 | summary(params$ry) 37 | library(ggplot2) 38 | df1 <- data.frame(Y = params$ry) 39 | ggplot(df1, aes(x = Y))+ 40 | geom_histogram(colour = "blue", fill = "white", bins = 30) + 41 | labs(title = "Histogram of sampled extension variable values") + 42 | theme_grey(base_size = 12) 43 | ``` 44 | 45 | 46 | 47 | 48 | 49 | 50 | # Conditional distribution of $X$, given $Y$ takes its median value $y_{0.5}$ 51 | 52 | ```{r, echo = FALSE} 53 | fit <- params$fit2 54 | bin.left <- NA 55 | bin.right <- NA 56 | chips <- NA 57 | roulette <- FALSE 58 | filename <- system.file("shinyAppFiles", "distributionsChild.Rmd", package="SHELF") 59 | ``` 60 | 61 | ```{r child=filename} 62 | ``` 63 | 64 | # Median function 65 | 66 | ```{r, echo = FALSE, fig.align = "center"} 67 | plotConditionalMedianFunction(yCP = params$yCP, xMed = params$xMed, 68 | yLimits = range(params$ry), 69 | link = params$link) 70 | ``` 71 | 72 | 73 | # Marginal distribution of X 74 | 75 | ```{r} 76 | 77 | 78 | d2 <- switch(params$d[2],"normal" = "normal", 79 | "t" = "Student-t", 80 | "skewnormal" = "Skew normal", 81 | "gamma" = "gamma", 82 | "lognormal" = "log normal", 83 | "logt" = "log Student-t", 84 | "beta" = "beta", 85 | "hist" = "histogram", 86 | "best" = as.character(params$fit2$best.fitting[1, 1]), 87 | "mirrorgamma" = "mirror gamma", 88 | "mirrorlognormal" = "mirror log normal", 89 | "mirrorlogt" = "mirror log Student-t") 90 | ``` 91 | 92 | 93 | 94 | Marginal distribution of $X$, obtained using the uploaded sample for $Y$ and a `r paste(d2)` distribution for $X|Y$: 95 | 96 | ```{r, echo = FALSE, fig.align = "center", message = FALSE} 97 | library(ggplot2) 98 | 99 | ggplot(params$df1, aes(x = X, y = ..density..))+ 100 | geom_density(fill = "steelblue")+ 101 | theme_grey(base_size = 12) 102 | 103 | 104 | ``` 105 | 106 | -------------------------------------------------------------------------------- /man/fitDirichlet.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fitDirichlet.R 3 | \name{fitDirichlet} 4 | \alias{fitDirichlet} 5 | \title{Fit a Dirichlet distribution to elicited marginal distributions for proportions} 6 | \usage{ 7 | fitDirichlet( 8 | ..., 9 | categories = NULL, 10 | n.fitted = "opt", 11 | plotBeta = TRUE, 12 | xlab = "x", 13 | ylab = expression(f[X](x)), 14 | fs = 12, 15 | silent = FALSE 16 | ) 17 | } 18 | \arguments{ 19 | \item{...}{Multiple arguments, each an objects of class \code{elicitation}, 20 | one per marginal proportion, separated by commas. The sequence can be 21 | specified as a single argument by containing all the \code{elicitation} 22 | objects within a single \code{list} object.} 23 | 24 | \item{categories}{A vector of strings labelling the marginal proportions.} 25 | 26 | \item{n.fitted}{The method used to determine the sum of the Dirichlet parameters. 27 | Use \code{"opt"} for best fitting, derived by matching standard deviations from the elicited marginals 28 | and the fitted Dirichlet; \code{"min"} for a conservative choice based 29 | on the smallest equivalent sample size (sum of the beta parameters) from the 30 | elicited marginals; \code{"med"} for the median of the smallest and largest largest equivalent sample size 31 | from the 32 | elicited marginals; \code{"mean"} for the mean of all the equivalent sample sizes 33 | from the 34 | elicited marginals.} 35 | 36 | \item{plotBeta}{logical. Plot the original elicited marginals and the fitted marginals from the 37 | Dirichlet fit.} 38 | 39 | \item{xlab}{x-axis label on the marginal distribution plot.} 40 | 41 | \item{ylab}{y-axis label on the marginal distribution plot.} 42 | 43 | \item{fs}{The font size used in the plot.} 44 | 45 | \item{silent}{Set to \code{TRUE} to suppress printing of results to the console.} 46 | } 47 | \value{ 48 | The parameters of the fitted Dirichlet distribution. 49 | } 50 | \description{ 51 | Takes elicited beta distributions for a set of proportions as inputs, 52 | and fits a Dirichlet distribution. The beta parameters are adjusted 53 | so that the expectations sum to 1, and then the sum of the Dirichlet 54 | parameters is chosen based on the sums of the beta parameters for each elicited marginal 55 | } 56 | \examples{ 57 | \dontrun{ 58 | p1 <- c(0.25, 0.5, 0.75) 59 | v1 <- c(0.5, 0.55, 0.6) 60 | v2 <- c(0.22, 0.3, 0.35) 61 | v3 <- c(0.11, 0.15, 0.2) 62 | myfit1 <- fitdist(v1, p1, 0, 1) 63 | myfit2 <- fitdist(v2, p1, 0, 1) 64 | myfit3 <- fitdist(v3, p1, 0, 1) 65 | d <- fitDirichlet(myfit1, myfit2, myfit3, 66 | categories = c("A","B","C"), 67 | n.fitted = "opt") 68 | 69 | # Note that this will also work: 70 | d <- fitDirichlet(list(myfit1, myfit2, myfit3), 71 | categories = c("A","B","C"), 72 | n.fitted = "opt") 73 | 74 | } 75 | } 76 | \references{ 77 | Zapata-Vazquez, R., O'Hagan, A. and Bastos, L. S. (2014). Eliciting expert judgements about a set of proportions. Journal of Applied Statistics 41, 1919-1933. 78 | } 79 | \author{ 80 | Jeremy Oakley 81 | } 82 | -------------------------------------------------------------------------------- /R/feedback.R: -------------------------------------------------------------------------------- 1 | #' Report quantiles and probabilities from the fitted probability distributions 2 | #' 3 | #' Having fitted appropriate distributions to one or more expert's judgements 4 | #' individually using the \code{\link{fitdist}} command, use this command to 5 | #' get quantiles and probabilities from the fitted distributions 6 | #' 7 | #' 8 | #' @param fit An object of class \code{elicitation}. 9 | #' @param quantiles A vector of desired quantiles for feedback. If this 10 | #' argument is left out, the default is to use the same quantiles that were 11 | #' elicited from the experts. 12 | #' @param values A vector of desired probabilities; desired values of a for 13 | #' reporting back fitted values of P(X 35 | #' @examples 36 | #' \dontrun{ 37 | #' # Two experts 38 | #' # Expert 1 states P(X<30)=0.25, P(X<40)=0.5, P(X<50)=0.75 39 | #' # Expert 2 states P(X<20)=0.25, P(X<25)=0.5, P(X<35)=0.75 40 | #' # Both experts state 01 & is.na(ex)==T){ 58 | return(feedbackgroup(fit, quantiles, values, dist, sfg = sf)) 59 | } 60 | 61 | if(nrow(fit$vals)>1 & is.na(ex)==F){ 62 | return(feedbacksingle(fit, quantiles, values, sf, ex)) 63 | } 64 | 65 | if(nrow(fit$vals)==1){ 66 | return(feedbacksingle(fit, quantiles, values, sf)) 67 | } 68 | } 69 | -------------------------------------------------------------------------------- /R/linearPoolDensity.R: -------------------------------------------------------------------------------- 1 | #' Obtain points on the density function of a linear pool 2 | #' 3 | #' Takes an object of class \code{elicitation}, evaluates a (weighted) linear pool, 4 | #' and returns points on the density function at a sequence of values of the elicited 5 | #' parameter 6 | #' 7 | #' 8 | #' 9 | #' @param fit An object of class \code{elicitation}. 10 | #' @param d The distribution fitted to each expert's probabilities. Options are 11 | #' \code{"normal"}, \code{"t"}, \code{"gamma"}, \code{"lognormal"}, 12 | #' \code{"logt"},\code{"beta"}, \code{"hist"} (for a histogram fit), and 13 | #' \code{"best"} (for best fitting) 14 | #' @param xl The lower limit in the sequence of parameter values. The default is the 0.001 quantile 15 | #' of the fitted distribution (or the 0.001 quantile of a fitted normal 16 | #' distribution, if a histogram fit is chosen). 17 | #' @param xu The upper limit in the sequence of parameter values. The default is the 0.999 quantile 18 | #' of the fitted distribution (or the 0.999 quantile of a fitted normal 19 | #' distribution, if a histogram fit is chosen). 20 | #' @param lpw A vector of weights to be used in linear pool, if unequal 21 | #' weighting is desired. 22 | #' @param nx The number of points in the sequence from \code{xl} to \code{xu}. 23 | #' @return A list, with elements 24 | #' \item{x}{a sequence of values for the uncertain parameter} 25 | #' \item{fx}{the density function of the linear pool, evaluated at each element in \code{x}.} 26 | #' @author Jeremy Oakley 27 | #' @examples 28 | #' 29 | #' \dontrun{ 30 | #' # Two experts 31 | #' # Expert 1 states P(X<30)=0.25, P(X<40)=0.5, P(X<50)=0.75 32 | #' # Expert 2 states P(X<20)=0.25, P(X<25)=0.5, P(X<35)=0.75 33 | #' # Both experts state 0 -Inf){xl <- min(fit$limits[,1]) } 45 | if(xl == -Inf & min(fit$limits[,1]) == -Inf){ 46 | f1 <- feedback(fit, quantiles=0.01, dist=d) 47 | xl <- min(f1$expert.quantiles) 48 | } 49 | 50 | if(xu == Inf & max(fit$limits[,2]) < Inf){xu <- max(fit$limits[,2]) } 51 | 52 | if(xu == Inf & max(fit$limits[,2]) == Inf){ 53 | f2 <- feedback(fit, quantiles=0.99, dist=d) 54 | xu <- max(f2$expert.quantiles) 55 | } 56 | # end get axes limits 57 | 58 | n.experts <- nrow(fit$vals) 59 | x <- matrix(0, nx, n.experts) 60 | fx <- x 61 | if(min(lpw)<0 | max(lpw)<=0){stop("expert weights must be non-negative, and at least one weight must be greater than 0.")} 62 | 63 | if(length(lpw)==1){ 64 | lpw <- rep(lpw, n.experts) 65 | } 66 | 67 | weight <- matrix(lpw/sum(lpw), nx, n.experts, byrow = T) 68 | 69 | for(i in 1:n.experts){ 70 | densitydata <- expertdensity(fit, d, ex = i, pl = xl, pu = xu, nx = nx) 71 | x[, i] <- densitydata$x 72 | fx[, i] <-densitydata$fx 73 | } 74 | 75 | fx.lp <- apply(fx * weight, 1, sum) 76 | list(x = x[, 1], f = fx.lp) 77 | } 78 | -------------------------------------------------------------------------------- /man/cdffeedback.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/cdffeedback.R 3 | \name{cdffeedback} 4 | \alias{cdffeedback} 5 | \title{Feedback for the elicited distribution of the population CDF} 6 | \usage{ 7 | cdffeedback( 8 | medianfit, 9 | precisionfit, 10 | quantiles = c(0.05, 0.95), 11 | vals = NA, 12 | alpha = 0.05, 13 | median.dist = "best", 14 | precision.dist = "gamma", 15 | n.rep = 10000 16 | ) 17 | } 18 | \arguments{ 19 | \item{medianfit}{The output of a \link{fitdist} command following elicitation 20 | of the expert's beliefs about the population median.} 21 | 22 | \item{precisionfit}{The output of a \link{fitprecision} command following elicitation 23 | of the expert's beliefs about the population precision.} 24 | 25 | \item{quantiles}{A vector of quantiles \eqn{q_1, \ldots,q_n} required for feedback} 26 | 27 | \item{vals}{A vector of population values \eqn{x_1,\ldots,x_n} required for feedback} 28 | 29 | \item{alpha}{The size of the 100(1-alpha)\% credible interval} 30 | 31 | \item{median.dist}{The fitted distribution for the population median. Can be one of \code{"normal"}, 32 | \code{"lognormal"} or \code{"best"}, where \code{"best"} will select the best fitting out of 33 | normal and lognormal.} 34 | 35 | \item{precision.dist}{The fitted distribution for the population precision. Can either be \code{"gamma"} 36 | or \code{"lognormal"}.} 37 | 38 | \item{n.rep}{The number of randomly sampled CDFs used to estimated the median 39 | and credible interval.} 40 | } 41 | \value{ 42 | Fitted median and 100(1-alpha)\% credible interval for population 43 | quantiles and probabilities. 44 | 45 | \item{$quantiles}{Each row gives the fitted median 46 | and 100(1-alpha)\% credible interval for each uncertain population quantile 47 | specified in \code{quantiles}: the fitted median 48 | and 100(1-alpha)\% credible interval for the value of \eqn{x_{q_i}} where 49 | \eqn{P(X\le x_{q_i} | \mu, \sigma^2) = q_i.}} 50 | \item{$probs}{Each row gives the fitted median 51 | and 100(1-alpha)\% credible interval for each uncertain population probability 52 | specified in \code{probs}: the fitted median 53 | and 100(1-alpha)\% credible interval for the value of 54 | \eqn{P(X\le x_i | \mu, \sigma^2).} } 55 | } 56 | \description{ 57 | Report the median and 100(1-alpha)\% credible interval for point on the population CDF 58 | } 59 | \details{ 60 | Denote the uncertain population CDF by \deqn{P(X \le x | \mu, \sigma^2),}where \eqn{\mu} 61 | is the uncertain population median and \eqn{\sigma^(-2)} is the uncertain population precision. 62 | Feedback can be reported in the form of the median and 100(1-alpha)\% credible interval for 63 | (a) an uncertain probability \eqn{P(X \le x | \mu, \sigma^2)}, where \eqn{x} is a specified 64 | population value and (b) an uncertain quantile \eqn{x_q} defined by \eqn{P(X \le x_q | \mu, \sigma^2) = q}, where \eqn{q} is a specified 65 | population probability. 66 | } 67 | \examples{ 68 | \dontrun{ 69 | prfit <- fitprecision(interval = c(60, 70), propvals = c(0.2, 0.4), trans = "log") 70 | medianfit <- fitdist(vals = c(50, 60, 70), probs = c(0.05, 0.5, 0.95), lower = 0) 71 | cdffeedback(medianfit, prfit, quantiles = c(0.01, 0.99), 72 | vals = c(65, 75), alpha = 0.05, n.rep = 10000) 73 | } 74 | } 75 | -------------------------------------------------------------------------------- /man/survivalModelExtrapolations.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/survivalModelExtrapolations.R 3 | \name{survivalModelExtrapolations} 4 | \alias{survivalModelExtrapolations} 5 | \title{Compare Multiple Fitted Models for Survival Extrapolation} 6 | \usage{ 7 | survivalModelExtrapolations( 8 | survDf, 9 | tOffset = 0, 10 | tEnd, 11 | group, 12 | tTruncate = NULL, 13 | dists = c("exp", "weibull", "gamma", "gompertz", "llogis", "lnorm", "gengamma"), 14 | nModels = length(dists), 15 | showPlot = TRUE 16 | ) 17 | } 18 | \arguments{ 19 | \item{survDf}{data frame with individual patient data. Require to be a .csv file with 20 | three columns: "time", "event" and "treatment" (in that order). 21 | Values in the "event" column should be 0 for a censored observation, and 1 otherwise. 22 | The"treatment" column should be included even if there is only one treatment group.'} 23 | 24 | \item{tOffset}{discard observations with time less than this value, and fit survival 25 | distributions to \code{survDf$time - tOffset}.} 26 | 27 | \item{tEnd}{the maximum time point for extrapolation} 28 | 29 | \item{group}{character variable to select treatment group: one of the levels in the 30 | factor variable survDf$treatment} 31 | 32 | \item{tTruncate}{optional argument: time point at which to censor all observations} 33 | 34 | \item{dists}{character vector of distributions to fit. Default is \code{c("exp", "weibull", 35 | "gamma", "gompertz", "llogis", "lnorm", "gengamma")} corresponding to the distributions listed 36 | above; can choose a subset of this.} 37 | 38 | \item{nModels}{how many fitted models to plot, up to a maximum of 7, chosen by lowest AIC 39 | value. Default is \code{length(dists)}.} 40 | 41 | \item{showPlot}{whether to display the plot} 42 | } 43 | \value{ 44 | A list containing the elements 45 | \item{KMplot}{a ggplot2 plot object;} 46 | \item{tMaxRange}{the time point at which there is the greatest difference between the largest 47 | and smallest extrapolated survival probability (if more than one distribution fitted);} 48 | \item{modelAIC}{the AIC for each fitted model.} 49 | \item{lclExtrapolate; uclExtrapolate}{pointwise 95 percent confidence interval for extrapolated survivor functions. 50 | Note that if \code{tOffset > 0 }, these intervals do not account for uncertainty in 51 | the survivor function at time t = tOffset.} 52 | } 53 | \description{ 54 | Fits seven parametric models to an individual patient survival data set (using the \code{flexsurv} 55 | package), 56 | displays extrapolations, and report the time point at which there is the 57 | widest range in estimated extrapolated survival probabilities. This function is intended to be used 58 | only as an informal exploratory tool to support elicitation for survival extrapolation, 59 | specifically, to inform the choice of target extrapolation time. The fitted models 60 | are exponential, weibull, gamma, gompertz, log logistic, log normal and geneneralised gamma. 61 | } 62 | \examples{ 63 | \dontrun{ 64 | 65 | # Make a data frame using the survival::veteran data frame 66 | sdf <- survival::veteran[, c("time", "status", "trt")] 67 | colnames(sdf) <- c("time", "event", "treatment") 68 | sdf$treatment <- factor(sdf$treatment, labels = c("standard", "test")) 69 | 70 | survivalModelExtrapolations(sdf, tEnd = 1000, group = "test", tTruncate = 100) 71 | } 72 | } 73 | -------------------------------------------------------------------------------- /man/fitprecision.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fitprecision.R 3 | \name{fitprecision} 4 | \alias{fitprecision} 5 | \title{Fit a distribution to judgements about a population precision} 6 | \usage{ 7 | fitprecision( 8 | interval, 9 | propvals, 10 | propprobs = c(0.05, 0.95), 11 | med = interval[1], 12 | trans = "identity", 13 | pplot = TRUE, 14 | tdf = 3, 15 | fontsize = 12 16 | ) 17 | } 18 | \arguments{ 19 | \item{interval}{A vector specifying the endpoints of an interval \eqn{[k_1, k_2]}.} 20 | 21 | \item{propvals}{A vector specifying two values \eqn{\theta_1, \theta_2} for the proportion.} 22 | 23 | \item{propprobs}{A vector specifying two probabilities \eqn{p_1, p_2}.} 24 | 25 | \item{med}{The hypothetical value of the population median.} 26 | 27 | \item{trans}{A string variable taking the value \code{"identity"}, \code{"log"} or 28 | \code{"logit"} corresponding to whether the population distribution is normal, lognormal 29 | or logit-normal respectively.} 30 | 31 | \item{pplot}{Plot the population distributions with median set at \eqn{k_1} 32 | and precision fixed at the two elicited quantiles implied by \code{propvals} 33 | and \code{propprobs}.} 34 | 35 | \item{tdf}{Degrees of freedom in the fitted log Student-t distribution.} 36 | 37 | \item{fontsize}{Font size used in the plots.} 38 | } 39 | \value{ 40 | \item{Gamma}{Parameters of the fitted gamma distribution. Note that E(precision) = 41 | shape / rate.} 42 | \item{Log.normal}{Parameters of the fitted log normal 43 | distribution: the mean and standard deviation of log precision.} 44 | \item{Log.Student.t}{Parameters of the fitted log student t distributions. 45 | Note that (log(X- \code{lower}) - location) / scale has a standard t distribution. The 46 | degrees of freedom is not fitted: it is specified as an input argument.} 47 | \item{vals}{The elicited values \eqn{\theta_1, \theta_2}} 48 | \item{probs}{The elicited probabilities \eqn{p_1, p_2}} 49 | \item{limits}{The lower and upper limits specified by each expert (+/- Inf 50 | if not specified).} 51 | \item{transform}{Transformation used for a normal population distribution.} 52 | } 53 | \description{ 54 | Takes elicited probabilities about proportion of a population 55 | lying in a specfied interval as inputs, converts the judgements into probability 56 | judgements about the population precision, and fits gamma and lognormal distributions 57 | to these judgements using the \link{fitdist} function. 58 | } 59 | \details{ 60 | The expert provides a pair of probability judgements 61 | \deqn{P(\theta < \theta_1 ) = p_1,} and \deqn{P(\theta < \theta_2) = p_2,} 62 | where \eqn{\theta} is the proportion of the population that lies in the interval 63 | \eqn{[k_1, k_2]}, conditional on the population median taking some hypothetical value (\eqn{k_1} 64 | by default). \eqn{k_1} can be set to \code{-Inf}, or \eqn{k_2} can be set to \code{Inf}; 65 | in either case, the hypothetical median value must be specified. If both \eqn{k_1} 66 | and \eqn{k_2} are finite, the hypothetical median must be one of the interval endpoints. 67 | Note that, unlike the \link{fitdist} command, a 'best fitting' 68 | distribution is not reported, as the distributions are fitted to two elicited 69 | probabilities only. 70 | } 71 | \examples{ 72 | \dontrun{ 73 | fitprecision(interval=c(60, 70), propvals=c(0.2, 0.4), trans = "log") 74 | } 75 | } 76 | -------------------------------------------------------------------------------- /inst/shinyAppFiles/elicitationShinySummaryExtension.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Fitted distributions (extension method)" 3 | output: 4 | html_document: default 5 | pdf_document: default 6 | word_document: default 7 | date: "`r format(Sys.time(), '%d %B %Y, %H:%M')`" 8 | fontsize: 11pt 9 | params: 10 | fit1: NA 11 | fit2: NA 12 | cp: NA 13 | d: NA 14 | m1: NA 15 | m2: NA 16 | yLimits: NA 17 | link: NA 18 | yCP: NA 19 | xMed: NA 20 | df1: NA 21 | ry: NA 22 | 23 | --- 24 | 25 | # Marginal distribution of $Y$ 26 | 27 | ```{r global_options, include=FALSE} 28 | knitr::opts_chunk$set(echo=FALSE, warning=FALSE, message=FALSE, 29 | fig.pos = 'h', 30 | fig.align = 'center', 31 | fig.height = 3, 32 | fig.width = 4) 33 | ``` 34 | 35 | 36 | ```{r, echo = FALSE} 37 | fit <- params$fit1 38 | bin.left <- NA 39 | bin.right <- NA 40 | chips <- NA 41 | roulette <- FALSE 42 | filename <- system.file("shinyAppFiles", "distributionsChild.Rmd", package="SHELF") 43 | ``` 44 | 45 | ```{r child=filename} 46 | ``` 47 | 48 | # Conditional distribution of $X$, given $Y$ takes its median value $y_{0.5}$ 49 | 50 | 51 | ```{r, echo = FALSE} 52 | fit <- params$fit2 53 | ``` 54 | 55 | ```{r child=filename} 56 | ``` 57 | 58 | # Median function 59 | 60 | ```{r, echo = FALSE, fig.align = "center"} 61 | plotConditionalMedianFunction(yCP = params$yCP, xMed = params$xMed, 62 | yLimits = params$yLimits, 63 | link = params$link) 64 | ``` 65 | 66 | 67 | # Marginal distribution of X 68 | 69 | ```{r} 70 | d1 <- switch(params$d[1], 71 | "normal" = "normal", 72 | "t" = "Student-t", 73 | "skewnormal" = "Skew normal", 74 | "gamma" = "gamma", 75 | "lognormal" = "log normal", 76 | "beta" = "beta", 77 | "hist" = "histogram", 78 | "logt" = "log Student-t", 79 | "best" = as.character(params$fit1$best.fitting[1, 1]), 80 | "mirrorgamma" = "mirror gamma", 81 | "mirrorlognormal" = "mirror log normal", 82 | "mirrorlogt" = "mirror log Student-t") 83 | 84 | d2 <- switch(params$d[2], 85 | "normal" = "normal", 86 | "t" = "Student-t", 87 | "skewnormal" = "Skew normal", 88 | "gamma" = "gamma", 89 | "lognormal" = "log normal", 90 | "logt" = "log Student-t", 91 | "beta" = "beta", 92 | "hist" = "histogram", 93 | "best" = as.character(params$fit2$best.fitting[1, 1]), 94 | "mirrorgamma" = "mirror gamma", 95 | "mirrorlognormal" = "mirror log normal", 96 | "mirrorlogt" = "mirror log Student-t") 97 | ``` 98 | 99 | 100 | 101 | Marginal distribution of $X$, obtained using a `r paste(d1)` distribution for $Y$ and a `r paste(d2)` distribution for $X|Y$: 102 | 103 | ```{r, echo = FALSE, fig.align = "center", message = FALSE} 104 | library(ggplot2) 105 | ggplot(params$df1, aes(x = X, y = ..density..))+ 106 | geom_density(fill = "steelblue") + 107 | theme_grey(base_size = 12) 108 | 109 | 110 | ``` 111 | 112 | -------------------------------------------------------------------------------- /R/sampleFit.R: -------------------------------------------------------------------------------- 1 | #' Sample from the elicited distributions 2 | #' 3 | #' Generates a random sample from all distributions specified 4 | #' within an object of class \code{elicitation} 5 | #' 6 | 7 | #' @param fit An object of class elicitation 8 | #' 9 | #' @param n The required sample size for each elicitation 10 | #' @param expert Specify which expert's distributions to sample 11 | #' from, if multiple experts' judgements have been elicited. 12 | #' 13 | #' @return A matrix of sampled values, one column per distribution. 14 | #' Column names are given to label the distributions. 15 | #' 16 | #' @examples 17 | #' \dontrun{ 18 | #' v <- c(20,30,50) 19 | #' p <- c(0.25,0.5,0.75) 20 | #' myfit <- fitdist(vals = v, probs = p, lower = 0, upper = 100) 21 | #' sampleFit(myfit, n = 10) 22 | #' } 23 | #' 24 | #' @export 25 | 26 | sampleFit <- function(fit, n, expert = 1){ 27 | x <- matrix(NA, nrow = n, ncol = 11) 28 | colnames(x) <- c("normal", "t", "skewnormal", 29 | "gamma", "lognormal", "logt", "beta", "hist", 30 | "mirrorgamma", "mirrorlognormal", "mirrorlogt") 31 | 32 | if(all(is.finite(unlist(fit$limits[expert, ])))){ 33 | u <- runif(n) 34 | x[, "hist"] <- qhist(u, c(fit$limits[expert, 1], 35 | fit$vals[expert,], 36 | fit$limits[expert, 2]), 37 | c(0, fit$probs[expert, ], 1)) 38 | 39 | 40 | } 41 | 42 | if(!is.na(fit$ssq[expert, "normal"])){ 43 | x[, "normal"] <- rnorm(n, fit$Normal[expert, 1], fit$Normal[expert, 2]) 44 | } 45 | 46 | if(!is.na(fit$ssq[expert, "t"])){ 47 | x[, "t"] <- fit$Student.t[expert, 1] + 48 | fit$Student.t[expert, 2] * rt(n, fit$Student.t[expert, 3]) 49 | } 50 | 51 | if(!is.na(fit$ssq[expert, "skewnormal"])){ 52 | x[, "skewnormal"] <- sn::rsn(n, xi = fit$Skewnormal[expert, 1], 53 | omega = fit$Skewnormal[expert, 2], 54 | alpha = fit$Skewnormal[expert, 3]) 55 | } 56 | 57 | if(!is.na(fit$ssq[expert, "beta"])){ 58 | x[, "beta"] <- fit$limits[expert, 1] + (fit$limits[expert, 2] - fit$limits[expert, 1]) * 59 | rbeta(n, fit$Beta[expert, 1], fit$Beta[expert, 2]) 60 | } 61 | 62 | if(!is.na(fit$ssq[expert, "lognormal"])){ 63 | x[, "lognormal"] <- fit$limits[expert, 1] + 64 | rlnorm(n, fit$Log.normal[expert, 1], fit$Log.normal[expert, 2]) 65 | } 66 | 67 | if(!is.na(fit$ssq[expert, "gamma"])){ 68 | x[, "gamma"] <- fit$limits[expert, 1] + 69 | rgamma(n, fit$Gamma[expert, 1], fit$Gamma[expert, 2]) 70 | } 71 | 72 | if(!is.na(fit$ssq[expert, "logt"])){ 73 | x[, "logt"] <- fit$limits[expert, 1] + 74 | exp(fit$Log.Student.t[expert, 1] + 75 | fit$Log.Student.t[expert, 2] * rt(n, fit$Log.Student.t[expert, 3])) 76 | } 77 | 78 | if(!is.na(fit$ssq[expert, "mirrorlognormal"])){ 79 | x[, "mirrorlognormal"] <- fit$limits[expert, 2] - 80 | rlnorm(n, fit$mirrorlognormal[expert, 1], 81 | fit$mirrorlognormal[expert, 2]) 82 | } 83 | 84 | if(!is.na(fit$ssq[expert, "mirrorgamma"])){ 85 | x[, "mirrorgamma"] <- fit$limits[expert, 2] - 86 | rgamma(n, fit$mirrorgamma[expert, 1], fit$mirrorgamma[expert, 2]) 87 | } 88 | 89 | if(!is.na(fit$ssq[expert, "mirrorlogt"])){ 90 | x[, "mirrorlogt"] <- fit$limits[expert, 2] - 91 | exp(fit$mirrorlogt[expert, 1] + 92 | fit$mirrorlogt[expert, 2] * rt(n, fit$mirrorlogt[expert, 3])) 93 | 94 | 95 | } 96 | 97 | 98 | x 99 | 100 | } -------------------------------------------------------------------------------- /R/cdfHelperfunctions.R: -------------------------------------------------------------------------------- 1 | logit <- function(x){ 2 | log(x/(1-x)) 3 | } 4 | 5 | plogit <- function(x, m, s){ 6 | pnorm(log(x/(1-x)), m ,s) 7 | } 8 | 9 | qlogit <- function(x, m, s){ 10 | z <- qnorm(x, m, s) 11 | exp(z) / (1 + exp(z)) 12 | } 13 | 14 | dlogit <- function(x, m, s){ 15 | 1 / (x * (1 - x)) * dnorm(log(x / (1 - x)), m, s) 16 | } 17 | 18 | 19 | 20 | 21 | psample <- function(medianfit, precisionfit, lower = NA, upper = NA, 22 | median.dist, precision.dist, n.rep = 10000, n.X = 100){ 23 | 24 | mediandist <- getmediandist(medianfit, median.dist) 25 | 26 | f <- getdists(precisionfit$transform) 27 | lim <- getlimits(lower, upper, f, mediandist, precisionfit) 28 | 29 | X <- seq(from = lim$lower, to = lim$upper, length = n.X) 30 | Xmat <- matrix(X, n.rep, n.X, byrow=T) 31 | 32 | mu <- matrix(mediandist$rand(n.rep, mediandist$m, mediandist$s), n.rep, n.X) 33 | 34 | if(precision.dist == "gamma"){ 35 | sigma <- matrix(sqrt(1 / rgamma(n.rep, precisionfit$Gamma[[1]], 36 | precisionfit$Gamma[[2]])), 37 | n.rep, n.X) 38 | } 39 | 40 | if(precision.dist == "lognormal"){ 41 | sigma <- matrix(sqrt(1 / rlnorm(n.rep, precisionfit$Log.normal[[1]], 42 | precisionfit$Log.normal[[2]])), 43 | n.rep, n.X) 44 | } 45 | 46 | pX <- f$cdf(Xmat, f$trans(mu), sigma) 47 | 48 | list(X=X, pX=pX) 49 | } 50 | 51 | 52 | 53 | taildensities <- function(m, s, tails, n.x, lower, upper, dens, quan, trans){ 54 | xl <- seq(from = lower, to = quan(tails/2, m, s), 55 | length = n.x) 56 | dl <- dens(xl, m, s) 57 | xu <- seq(from = quan(1-tails/2, m, s), to = upper, 58 | length = n.x) 59 | du <- dens(xu, m, s) 60 | data.frame(xl = xl, dl = dl, xu = xu, du = du) 61 | } 62 | 63 | getdists <- function(transform){ 64 | if (transform == "identity"){ 65 | dens <- dnorm 66 | quan <- qnorm 67 | cdf <- pnorm 68 | trans <- identity 69 | } 70 | 71 | if (transform == "log"){ 72 | dens <- dlnorm 73 | quan <- qlnorm 74 | cdf <- plnorm 75 | trans <- log 76 | } 77 | 78 | if (transform == "logit"){ 79 | dens <- dlogit 80 | quan <- qlogit 81 | cdf <- plogit 82 | trans <- logit 83 | } 84 | 85 | list(dens = dens, quan = quan, trans = trans, cdf = cdf) 86 | } 87 | 88 | getlimits <- function(lower, upper, f, mediandist, precisionfit){ 89 | 90 | a<-precisionfit$Gamma[[1]] 91 | b<-precisionfit$Gamma[[2]] 92 | 93 | if(is.na(lower)) lower <- f$quan(0.001, 94 | f$trans(mediandist$quan(0.001, mediandist$m, mediandist$s)), 95 | 1/qgamma(0.001, a, b)^0.5) 96 | if(is.na(upper)) upper <- f$quan(0.999, 97 | f$trans(mediandist$quan(0.999, mediandist$m, mediandist$s)), 98 | 1/qgamma(0.001, a, b)^0.5) 99 | list(lower = lower, upper = upper) 100 | } 101 | 102 | getmediandist <- function(medianfit, d){ 103 | if(d == "best"){ 104 | ssq <- medianfit$ssq 105 | ssq[is.na(ssq)] <- Inf 106 | if(ssq[1,1] < ssq[1,4]){d <- "normal"}else{d <- "lognormal"} 107 | } 108 | 109 | if(d == "normal"){ 110 | rand <- rnorm 111 | quan <- qnorm 112 | m <- medianfit$Normal[[1]] 113 | s <- medianfit$Normal[[2]] 114 | } 115 | 116 | if(d == "lognormal"){ 117 | rand <- rlnorm 118 | quan <- qlnorm 119 | m <- medianfit$Log.normal[[1]] 120 | s <- medianfit$Log.normal[[2]] 121 | } 122 | list(rand = rand, quan = quan, m = m, s=s) 123 | } 124 | 125 | addQuantileCDF <- function(lower, x1, q1, upper){ 126 | # Function to add a fitted quantile to a CDF plot 127 | # P(X <= x1) = q1 128 | if(lower < x1 & x1 < upper){return( 129 | annotate("segment", x = c(lower, x1), 130 | y = c(q1, q1), 131 | xend = c(x1, x1), 132 | yend = c(q1, 0), 133 | linetype = 2))}else{ 134 | return(NULL) 135 | } 136 | } -------------------------------------------------------------------------------- /R/makeSurvivalTable.R: -------------------------------------------------------------------------------- 1 | 2 | #' Tabulate Summary Data for Survival Extrapolation 3 | #' 4 | #' Tabulates the Kaplan Meier survivor function and within interval hazard at discrete equally spaced time points t_1,...,t_n 5 | #' "Within interval hazard" is defined as (1-S(t_[n+1])) / S_(t_n), using the Kaplan Meier estimate of S(). 6 | #' The table is intended to be included on a summary sheet provided to experts when eliciting judgements about 7 | #' extrapolated survival probabilities. 8 | #' 9 | #' @param survDf data frame with individual patient data. Needs three columns with names 10 | #' "time", "event" and "treatment" (in that order). For weighted observations (e.g. 11 | #' using propensity scores), include a fourth column "weights". 12 | #' Values in the "event" column should be 0 for a censored observation, and 1 otherwise. 13 | #' The "treatment" column should be included even if there is only one treatment group. 14 | #' @param breakTime duration of each time interval 15 | #' @param truncationTime time point for the end of the last interval 16 | #' @param timeUnit string variable to give unit of time 17 | #' @param dp number of decimal places to display 18 | #' @param useWeights set to TRUE if survDf includes column of weights, as described in specification 19 | #' of survDf. This column is passed on to survival::survfit() as the case weights. 20 | #' 21 | #' @returns a data frame with survivor function estimates, 95% confidence intervals, 22 | #' and within interval hazard estimates for each time interval. 23 | #' 24 | #' @import survival 25 | #' @export 26 | #' 27 | #' @examples 28 | #' \dontrun{ 29 | #' sdf <- survival::veteran[, c("time", "status", "trt")] 30 | #' colnames(sdf) <- c("time", "event", "treatment") 31 | #' sdf$treatment <- factor(sdf$treatment, labels = c("standard", "test")) 32 | #' makeSurvivalTable(sdf, breakTime = 50, truncationTime = 250, timeUnit = "months") 33 | #' } 34 | makeSurvivalTable <- function(survDf, breakTime, truncationTime, timeUnit, useWeights = FALSE, dp = 2){ 35 | 36 | survDf$treatment <- as.factor(survDf$treatment) 37 | 38 | if(useWeights == TRUE){ 39 | sv <- survival::survfit(survival::Surv(time, event) ~ treatment, weights = weights, 40 | data = survDf) 41 | }else{ 42 | sv <- survival::survfit(survival::Surv(time, event) ~ treatment, 43 | data = survDf) 44 | } 45 | 46 | 47 | truncationTime <- min(truncationTime, min(tapply(survDf$time, survDf$treatment, max))) 48 | sTimes <- seq(from = breakTime, to = truncationTime, by = breakTime) 49 | nTimes <- length(sTimes) 50 | nTreatments <- length(levels(survDf$treatment)) 51 | tNames <- levels(survDf$treatment) 52 | 53 | pt <- matrix(round(summary(sv, times = sTimes)$surv , dp), 54 | nrow = nTimes, ncol = nTreatments) 55 | wt <- pt 56 | wt[1, ] <- 1 - wt[1, ] 57 | if(nrow(wt) > 1){ 58 | wt[-1, ] <- 1 - round(pt[2:nTimes, ]/pt[1:(nTimes - 1), ], dp) 59 | } 60 | 61 | ciLower <- matrix(round(summary(sv, times = sTimes)$lower , dp), 62 | nrow = nTimes, ncol = nTreatments) 63 | ciUpper <- matrix(round(summary(sv, times = sTimes)$upper , dp), 64 | nrow = nTimes, ncol = nTreatments) 65 | ci95 <- matrix (paste0("(", ciLower, ", ", ciUpper,")"), 66 | nrow = nTimes, ncol = nTreatments) 67 | sTable <- data.frame(paste0("[", c(0, sTimes[1:(nTimes -1)]), ",", sTimes, ")"), 68 | pt[, 1], ci95[, 1], wt[, 1]) 69 | colnames(sTable) <- c(paste0("time interval (", timeUnit,")"), 70 | paste0("survivor (", tNames[1], ")"), 71 | paste0("survivor 95% CI (", tNames[1], ")"), 72 | paste0("hazard (", tNames[1], ")")) 73 | 74 | if(nTreatments > 1){ 75 | for(i in 2:nTreatments){ 76 | dfTemp <- data.frame(pt[, i], ci95[, i], wt[, i]) 77 | colnames(dfTemp) <- c(paste0("survivor (", tNames[i], ")"), 78 | paste0("survivor 95% CI (", tNames[i], ")"), 79 | paste0("hazard (", tNames[i], ")")) 80 | sTable <- cbind(sTable, dfTemp) 81 | } 82 | } 83 | 84 | sTable 85 | } -------------------------------------------------------------------------------- /inst/shinyAppFiles/elicitationShinySummaryBivariate.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Fitted distributions (bivariate elicitation)" 3 | output: 4 | html_document: default 5 | pdf_document: default 6 | word_document: default 7 | date: "`r format(Sys.time(), '%d %B %Y, %H:%M')`" 8 | fontsize: 11pt 9 | params: 10 | fit1: NA 11 | fit2: NA 12 | cp: NA 13 | d: NA 14 | m1: NA 15 | m2: NA 16 | --- 17 | 18 | # Parameter 1 19 | 20 | ```{r global_options, include=FALSE} 21 | knitr::opts_chunk$set(echo=FALSE, warning=FALSE, message=FALSE, 22 | fig.pos = 'h', 23 | fig.align = 'center', 24 | fig.height = 3, 25 | fig.width = 4) 26 | ``` 27 | 28 | ```{r, echo = FALSE} 29 | fit <- params$fit1 30 | bin.left <- NA 31 | bin.right <- NA 32 | chips <- NA 33 | roulette <- FALSE 34 | filename <- system.file("shinyAppFiles", "distributionsChild.Rmd", package="SHELF") 35 | ``` 36 | 37 | ```{r child=filename} 38 | ``` 39 | 40 | 41 | # Parameter 2 42 | 43 | ```{r, echo = FALSE} 44 | fit <- params$fit2 45 | ``` 46 | 47 | ```{r child=filename} 48 | ``` 49 | 50 | # Joint distribution 51 | 52 | ```{r} 53 | d1 <- switch(params$d[1], 54 | "normal" = "normal", 55 | "t" = "Student-t", 56 | "skewnormal" = "Skew normal", 57 | "gamma" = "gamma", 58 | "lognormal" = "log normal", 59 | "logt" = "log Student-t", 60 | "beta" = "beta", 61 | "hist" = "histogram", 62 | "best" = as.character(params$fit1$best.fitting[1, 1])) 63 | 64 | d2 <- switch(params$d[2], 65 | "normal" = "normal", 66 | "t" = "Student-t", 67 | "skewnormal" = "Skew normal", 68 | "gamma" = "gamma", 69 | "lognormal" = "log normal", 70 | "logt" = "log Student-t", 71 | "beta" = "beta", 72 | "hist" = "histogram", 73 | "best" = as.character(params$fit2$best.fitting[1, 1])) 74 | ``` 75 | 76 | 77 | Elicited concordance probability: 78 | 79 | $$ 80 | P(\{X_1 < m_1,\, X_2 < m_2\} \cup\{ X_1>m_1, \, X_2 > m_2\}) = `r params$cp` 81 | $$ 82 | Joint sample, obtained using a `r paste(d1)` distribution for $X_1$ and a `r paste(d2)` distribution for $X_2$: 83 | 84 | ```{r, echo = FALSE, fig.align = "center"} 85 | library(ggplot2) 86 | conc.probs <- matrix(0, 2, 2) 87 | conc.probs[1, 2] <- params$cp 88 | df1<-data.frame(copulaSample(params$fit1, params$fit2, cp=conc.probs, n=10000, 89 | d=params$d)) 90 | 91 | 92 | annotations <- data.frame( 93 | xpos = c(Inf,Inf,-Inf,-Inf), 94 | ypos = c(Inf, -Inf,-Inf,Inf), 95 | annotateText = as.character(c(params$cp / 2, 0.5 - params$cp /2, 96 | params$cp / 2, 97 | 0.5 - params$cp /2)), 98 | hjustvar = c(1.5, 1.5, -0.5, -0.5) , 99 | vjustvar = c(1.5, -0.5, -0.5, 1.5)) 100 | 101 | 102 | p1<-ggplot(data=df1,aes(x=X1, y=X2))+ 103 | geom_point(alpha=0.15, colour = "red") + 104 | geom_hline(yintercept = params$m2)+ 105 | geom_vline(xintercept = params$m1)+ 106 | labs(x=expression(X[1]), y = expression(X[2]))+ 107 | geom_text(data = annotations, aes(x = xpos, 108 | y = ypos, 109 | hjust = hjustvar, 110 | vjust = vjustvar, 111 | label = annotateText), 112 | size =10) + 113 | xlim(0.95*params$fit1$limits[1, 1], 1.05*params$fit1$limits[1, 2])+ 114 | ylim(0.95*params$fit2$limits[1, 1], 1.05*params$fit2$limits[1, 2]) 115 | suppressWarnings(suppressMessages(ggExtra::ggMarginal(p1, type = "histogram", 116 | fill = "red"))) 117 | ``` 118 | 119 | -------------------------------------------------------------------------------- /R/elicitMarginalsModule.R: -------------------------------------------------------------------------------- 1 | # Module UI function 2 | elicitMarginalsInput <- function(id) { 3 | # Create a namespace function using the provided id 4 | ns <- NS(id) 5 | 6 | tagList( 7 | sidebarLayout( 8 | sidebarPanel( 9 | numericInput(ns("nTheta"), h5("Number of categories"), 10 | value = 3, min = 3, step = 1), 11 | uiOutput(ns("enterThetaLabels")), 12 | textInput(ns("probs"), label = h5("Cumulative probabilities"), 13 | value = "0.25, 0.5, 0.75"), 14 | uiOutput(ns("categoryToDisplay")) 15 | ), 16 | mainPanel( 17 | helpText("Enter the percentiles of your marginal distributions 18 | in the table below, one column per category. The values in each column 19 | should correspond to the cumulative probabilities on the left, e.g., in 20 | the first column (with the default probabilities), enter the 21 | 25th, 50th and 75th percentiles of your marginal distribution 22 | for the population proportion in the first category."), 23 | uiOutput(ns("EnterJudgements")), 24 | plotOutput(ns("betaPlot")) 25 | ) 26 | ) 27 | ) 28 | 29 | } 30 | 31 | elicitMarginals <- function(input, output, session, fs){ 32 | 33 | 34 | 35 | thetaNames <- reactive({ 36 | req(input$thetaLabels) 37 | temp <- unlist(strsplit(input$thetaLabels, ",")) 38 | trimws(temp) 39 | }) 40 | 41 | p <- reactive({ 42 | tryCatch(eval(parse(text = paste("c(", input$probs, ")"))), 43 | error = function(e){NULL}) 44 | }) 45 | 46 | output$enterThetaLabels <- renderUI({ 47 | ns <- session$ns 48 | textInput(ns("thetaLabels"), h5("Category labels"), 49 | value = paste(LETTERS[1:input$nTheta], collapse = ", ")) 50 | }) 51 | 52 | output$categoryToDisplay <- renderUI({ 53 | ns <- session$ns 54 | selectInput(ns("categoryDisplay"), label = h5("Category to display"), 55 | choices = c("No display", thetaNames()), 56 | selected = "No display") 57 | }) 58 | 59 | 60 | 61 | 62 | output$EnterJudgements <- renderUI({ 63 | req(thetaNames(), p(), input$nTheta) 64 | pvec <- (1 / input$nTheta) * p() / 0.5 65 | pvec[pvec>=1] <- 0.999 66 | pvec[pvec<=0] <- 0.001 67 | initialdf <- matrix(pvec, 68 | length(p()), 69 | input$nTheta) 70 | if(length(thetaNames()) == input$nTheta){ 71 | colnames(initialdf) <- thetaNames()} 72 | rownames(initialdf) <- p() 73 | ns <- session$ns 74 | shinyMatrix::matrixInput(inputId = ns("myvals"), value = initialdf, 75 | class = "numeric", 76 | cols = list(names = TRUE), 77 | rows = list(names = TRUE)) 78 | }) 79 | 80 | allValid <- reactive({ 81 | req(allFits()) 82 | validVector <- rep(NA, length = input$nTheta ) 83 | for(i in seq_along(allFits())){ 84 | validVector[i] <- !is.na(allFits()[[i]]$ssq[1, "beta"]) 85 | 86 | } 87 | validVector 88 | }) 89 | 90 | allFits <- reactive({ 91 | req(p(), input$nTheta > 0) 92 | marginalFits <- vector("list", length = input$nTheta) 93 | for(i in seq_along(marginalFits)){ 94 | 95 | marginalFits[[i]] <- fitdist(vals = input$myvals[, i], 96 | probs = p(), 97 | lower = 0, 98 | upper = 1) 99 | } 100 | marginalFits 101 | }) 102 | 103 | output$betaPlot <- renderPlot({ 104 | req(input$categoryDisplay) 105 | if(input$categoryDisplay != "No display"){ 106 | index <- which(input$categoryDisplay == thetaNames()) 107 | plotfit(allFits()[[index]], d = "beta", ql = 0.05, qu = 0.95, 108 | xlab = paste0('Proportion in category "', 109 | input$categoryDisplay, 110 | '"'), 111 | ylab = "density", 112 | fs = fs()) 113 | } 114 | }) 115 | 116 | 117 | 118 | 119 | list(allFits = reactive({allFits()}), 120 | categoryLabels = reactive({thetaNames()}), 121 | thetaMatrix = reactive({input$myvals}), 122 | quantiles = reactive({p()}), 123 | allValid = reactive({allValid()})) 124 | } -------------------------------------------------------------------------------- /inst/shinyAppFiles/help.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Title 5 | 6 | 7 | 8 | 9 | 10 |

    Parameter limits

    11 |

    Specify a lower and upper limit, with a comma in between. The limits will set the range on the x-axis in the various plots, and the range covered by the bins in the roulette method. The limits will also affect the fitted distributions: the gamma, log normal and log Student-t will all be shifted to have support over the range [lower, infinity), and the beta distributed will be shifted and scaled to have support over the range [lower, upper].

    12 | 13 |

    Elicitation method

    14 |

    For the General method, specify (any number of) cumulative probabilities P(X<=x).

    15 |
      16 |
    • Specify values x1, x2,... in the Parameter values box, in increasing order, separated by commas. 17 |
    • Specify the corresponding probabilities P(X<=x1), P(X<=x2),... in the Cumulative probabilities box, separated by commas. The requirements for each distribution to be fitted are as follows: 18 |
        19 |
      • Normal: smallest elicited probability less than 0.4; largest elicited probablity greater than 0.6. 20 |
      • Student-t : smallest elicited probability less than 0.4; largest elicited probablity greater than 0.6. 21 |
      • Gamma : finite lower limit and at least one elicited probability greater than 0 and less than 1. 22 |
      • Log normal : finite lower limit; smallest elicited probability less than 0.4; largest elicited probablity greater than 0.6. 23 |
      • Log Student-t : finite lower limit; smallest elicited probability less than 0.4; largest elicited probablity greater than 0.6. 24 |
      • Beta : finite lower limit; finite upper limit; smallest elicited probability less than 0.4; largest elicited probablity greater than 0.6. 25 |
      • Mirror gamma : finite upper limit and at least one elicited probability greater than 0 and less than 1. 26 |
      • Mirror log normal : finite upper limit; smallest elicited probability less than 0.4; largest elicited probablity greater than 0.6. 27 |
      • Mirror Student-t : finite upper limit; smallest elicited probability less than 0.4; largest elicited probablity greater than 0.6. 28 |
      29 |
    30 | If the Roulette method is selected, click on the Roulette tab and click directly in the plot to allocate probs. Click just below the line at 0 on the y-axis to clear a column. 31 | 32 |

    Output tabs

    33 |
      34 |
    • PDF. A display of the fitted density function, if show fitted PDF is selected, using the selected Distribution. Fitted quantiles are displayed using the red shaded areas, if the quantiles are within the displayed range set by Parameter limits 35 |
    • CDF. A display of the fitted distribution function, if show fitted CDF is selected, using the selected Distribution. Fitted quantiles are indicated, and the quantiles are within the displayed range set by Parameter limits 36 |
    • Tertiles. Shows three equally likely regions, as specified by the tertiles, and the median (indicated by the dashed line). The tertiles displayed will either be the elicited tertiles, if they have been provided, or estimates obtained by linear interpolation of the elicited probabilities, with the Parameter limits assumed to have cumulative probabilities of 0 and 1. 37 |
    • Quartiles. Shows four equally likely regions, as specified by the quartiles. The quartiles displayed will either be the elicited quartiles, if they have been provided, or estimates obtained by linear interpolation of the elicited probabilities, with the Parameter limits assumed to have cumulative probabilities of 0 and 1. 38 |
    • Roulette. If the Roulette elicitation method is selected, this will display the roulette grid in which probability judgements can be specified. 39 |
    • Compare group/RIO. If you have separately elicited probabilities from experts individually using the multiple experts app, and you are using this app to obtain the consensus distribution (the "Rational Impartial Observer's" distribution), you can compare the result in this tab. In the multiple experts app, you need to download the judgements as a .csv file. You can upload the .csv file here, and then see a comparison between the RIO distribution, the experts' individual distributions, and a linear pool of the experts' distributions. 40 |
    41 | 42 |

    Download report

    43 | This will generate a pdf file, with each fitted distribution specified. 44 |

    45 | 46 | 47 | 48 | 49 | -------------------------------------------------------------------------------- /R/elicitCopula.R: -------------------------------------------------------------------------------- 1 | #' Generate correlated samples from elicited marginal distributions using a multivariate normal copula 2 | #' 3 | #' Takes elicited marginal distributions and elicited concordance probabilities: pairwise 4 | #' probabilities of two uncertain quantities being greater than their medians, and generates 5 | #' a correlated sample, assuming the elicited marginal distributions and a multivariate 6 | #' normal copula. A vignette explaining this method is available at [https://oakleyj.github.io/SHELF/Multivariate-normal-copula.html](https://oakleyj.github.io/SHELF/Multivariate-normal-copula.html) 7 | #' 8 | #' 9 | #' @param ... A list of objects of class \code{elicitation}. 10 | #' command, one per marginal distribution, separated by commas. 11 | #' @param cp A matrix of pairwise concordance probabilities, with element i,j the elicited probability 12 | #' P(X_i > m_i, X_j > m_j or X_i < m_i, X_j < m_j), where m_i and m_j are the elicited medians of the uncertain quantities X_i and X_j. 13 | #' Only the upper triangular elements in the matrix need to be specified; the remaining elements can be set at 0. 14 | #' @param n The sample size to be generated 15 | #' @param d A vector of distributions to be used for each elicited quantity: a string with elements chosen from 16 | #' \code{"normal", "t", "gamma", "lognormal", "logt", "beta", "mirrorgamma", "mirrorlognormal", "mirrorlogt"}. The default is to use 17 | #' the best fitting distribution in each case. 18 | #' @param ex If separate judgements have been elicited from multiple experts and stored 19 | #' in the \code{elicitation} objects, use this argument to select a single expert's judgements 20 | #' for sampling. Note that this function will not simultaneously generate samples for all experts. 21 | # 22 | 23 | #' @return A matrix of sampled values, one row per sample. 24 | #' @author Jeremy Oakley 25 | #' @examples 26 | #' \dontrun{ 27 | #' p1 <- c(0.25, 0.5, 0.75) 28 | #' v1 <- c(0.5, 0.55, 0.6) 29 | #' v2 <- c(0.22, 0.3, 0.35) 30 | #' v3 <- c(0.11, 0.15, 0.2) 31 | #' myfit1 <- fitdist(v1, p1, 0, 1) 32 | #' myfit2 <- fitdist(v2, p1, 0, 1) 33 | #' myfit3 <- fitdist(v3, p1, 0, 1) 34 | #' quad.probs <- matrix(0, 3, 3) 35 | #' quad.probs[1, 2] <- 0.4 36 | #' quad.probs[1, 3] <- 0.4 37 | #' quad.probs[2, 3] <- 0.3 38 | #' copulaSample(myfit1, myfit2, myfit3, cp=quad.probs, n=100, d=NULL) 39 | #' } 40 | #' @export 41 | #' @md 42 | 43 | copulaSample <- function(..., cp, n, d = NULL, ex = 1) { 44 | elicitation.fits <- list(...) 45 | n.vars <- length(elicitation.fits) 46 | 47 | if (is.null(d)) { 48 | d <- sapply(elicitation.fits, function(x) { 49 | unlist(x$best.fitting[ex, 1]) 50 | }) 51 | } 52 | 53 | r <- sin(2 * pi * cp / 2 - pi / 2) 54 | diag(r) <- 1 55 | r[lower.tri(r)] <- r[upper.tri(r)] 56 | 57 | r.check <- try(chol(r), silent = TRUE) 58 | if (inherits(r.check, "try-error")) { 59 | cat("Elicited correlation matrix is not positive definite.") 60 | if (nrow(r) == 3) { 61 | cat( 62 | "\nConsider adjusting one of the concordance probabilities\nto be within the following limits.\n\n" 63 | ) 64 | limits <- sapply(3:1, getConcordanceLimits, cor.mat = r) 65 | rownames(limits) <- c("lower", "upper") 66 | colnames(limits) <- c(" p_{1,2}", " p_{1,3}", " p_{2,3}") 67 | print(limits) 68 | return(NULL) 69 | } 70 | } else{ 71 | 72 | 73 | # Change from eigendecomposition to Cholesky. Problems 74 | # reported with reproducibility: some machines flip the signs of the eigenvectors 75 | #z <- MASS::mvrnorm(n, mu = rep(0, n.vars), r) 76 | z <- matrix(rnorm(n.vars * n), n, n.vars) %*% chol(r) 77 | 78 | p <- pnorm(z) 79 | 80 | theta <- matrix(0, n, n.vars) 81 | for (i in 1:n.vars) { 82 | 83 | if(d[i] == "best"){ 84 | d[i] <- as.character(elicitation.fits[[i]]$best.fitting[ex, 1]) 85 | 86 | } 87 | 88 | 89 | theta[, i] <- feedback(elicitation.fits[[i]], 90 | quantiles = p[, i], 91 | sf = 8, ex = ex)$fitted.quantiles[d[i]][, 1] 92 | } 93 | return(theta) 94 | } 95 | } 96 | 97 | 98 | 99 | getConcordanceLimits <- function(i, cor.mat) { 100 | index <- c(i, (1:3)[-i]) 101 | r <- cor.mat[index, index] 102 | m <- solve(r[1:2, 1:2]) 103 | a <- m[2, 2] 104 | b <- 2 * r[1, 3] * m[1, 2] 105 | k <- r[1, 3] ^ 2 * m[1, 1] - 1 106 | 107 | l1 <- (-b - sqrt(b ^ 2 - 4 * a * k)) / (2 * a) 108 | l2 <- (-b + sqrt(b ^ 2 - 4 * a * k)) / (2 * a) 109 | 2 * (asin(c(l1, l2)) + pi / 2) / (2 * pi) 110 | } 111 | -------------------------------------------------------------------------------- /man/survivalExtrapolatePlot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/survivalExtrapolatePlot.R 3 | \name{survivalExtrapolatePlot} 4 | \alias{survivalExtrapolatePlot} 5 | \title{Plot survival data and elicited extrapolated intervals} 6 | \usage{ 7 | survivalExtrapolatePlot( 8 | survDf, 9 | myfit1, 10 | myfit2 = NULL, 11 | fqDist1 = "best", 12 | fqDist2 = NULL, 13 | tTruncate = max(survDf$time), 14 | tTarget, 15 | alpha = 0.95, 16 | useWeights = FALSE, 17 | groups = levels(survDf$treatment), 18 | xl = "Time (t)", 19 | fontsize = 12, 20 | breakTime = NULL, 21 | showPlot = TRUE, 22 | returnPlot = FALSE 23 | ) 24 | } 25 | \arguments{ 26 | \item{survDf}{data frame with individual patient data. Needs three columns with names 27 | "time", "event" and "treatment" (in that order). For weighted observations (e.g. 28 | using propensity scores), include a fourth column "weights". 29 | Values in the "event" column should be 0 for a censored observation, and 1 otherwise. 30 | The "treatment" column should be included even if there is only one treatment group, and defined 31 | as a factor variable.} 32 | 33 | \item{myfit1}{object of class \code{elicitation}, obtained from \code{fitdist} function with 34 | elicited judgements for the first treatment group.} 35 | 36 | \item{myfit2}{object of class \code{elicitation}, obtained from \code{fitdist} function with 37 | elicited judgements for the second treatment group, if there is on.} 38 | 39 | \item{fqDist1}{fitted distribution family for first treatment group. Options are 40 | \code{"normal"}, \code{"t"}, \code{"skewnormal"}, \code{"gamma"}, \code{"lognormal"}, 41 | \code{"logt"},\code{"beta"}, \code{"mirrorgamma"}, 42 | \code{"mirrorlognormal"}, \code{"mirrorlogt"} \code{"hist"} (for a histogram fit), and 43 | \code{"best"} (for best fitting)} 44 | 45 | \item{fqDist2}{fitted distribution family for second treatment group if there is one. Options are 46 | \code{"normal"}, \code{"t"}, \code{"skewnormal"}, \code{"gamma"}, \code{"lognormal"}, 47 | \code{"logt"},\code{"beta"}, \code{"mirrorgamma"}, 48 | \code{"mirrorlognormal"}, \code{"mirrorlogt"} \code{"hist"} (for a histogram fit), and 49 | \code{"best"} (for best fitting)} 50 | 51 | \item{tTruncate}{Optional argument to censor all observations at this time point.} 52 | 53 | \item{tTarget}{Target time for extrapolation: judgements are elicited at S(t = tTarget)} 54 | 55 | \item{alpha}{Size of probability interval to plot (100*\code{alpha}\% interval).} 56 | 57 | \item{useWeights}{set to TRUE if survDf includes column of weights, as described in specification 58 | of survDf. This column is passed on to survival::survfit() as the case weights.} 59 | 60 | \item{groups}{Vector of strings for the group labels. Will be extracted from factor levels of 61 | \code{treatment} column in \code{survDf}.} 62 | 63 | \item{xl}{x-axis label in plot} 64 | 65 | \item{fontsize}{font size in plot} 66 | 67 | \item{breakTime}{Optional argument to specify tick mark spacing on x-axis} 68 | 69 | \item{showPlot}{set to TRUE to display the plot} 70 | 71 | \item{returnPlot}{set to TRUE to return the plot as a ggplot object.} 72 | } 73 | \value{ 74 | a ggplot object, if returnPlot is TRUE 75 | } 76 | \description{ 77 | Show Kaplan-Meier plot of available data, and credible 78 | interval for extrapolated survivor function value S(T) 79 | } 80 | \examples{ 81 | \dontrun{ 82 | sdf <- survival::veteran[, c("time", "status", "trt")] 83 | colnames(sdf) <- c("time", "event", "treatment") 84 | sdf$treatment <- factor(sdf$treatment, labels = c("standard", "test")) 85 | 86 | sdf <- survival::veteran[, c("time", "status", "trt")] 87 | colnames(sdf) <- c("time", "event", "treatment") 88 | sdf$treatment <- factor(sdf$treatment, labels = c("standard", "test")) 89 | groupStandardElicitation <- fitdist(vals = c(0.15, 0.2, 0.25), 90 | probs = c(0.25, 0.5, 0.75), 91 | lower = 0, 92 | upper = 1) 93 | 94 | groupTestElicitation <- fitdist(vals = c(0.1, 0.15, 0.2), 95 | probs = c(0.25, 0.5, 0.75), 96 | lower = 0, 97 | upper = 1) 98 | 99 | survivalExtrapolatePlot(sdf, 100 | myfit1 = groupStandardElicitation, 101 | myfit2 = groupTestElicitation, 102 | fqDist1 = "beta", 103 | fqDist2 = "beta", 104 | tTruncate = 150, 105 | tTarget=200, 106 | alpha = 0.95) 107 | } 108 | } 109 | -------------------------------------------------------------------------------- /man/plotfit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plotfit.R 3 | \name{plotfit} 4 | \alias{plotfit} 5 | \title{Plot the fitted density function for one or more experts} 6 | \usage{ 7 | plotfit( 8 | fit, 9 | d = "best", 10 | xl = -Inf, 11 | xu = Inf, 12 | yl = 0, 13 | yu = NA, 14 | ql = NA, 15 | qu = NA, 16 | lp = FALSE, 17 | ex = NA, 18 | sf = 3, 19 | ind = TRUE, 20 | lpw = 1, 21 | fs = 12, 22 | lwd = 1, 23 | xlab = "x", 24 | ylab = expression(f[X](x)), 25 | legend_full = TRUE, 26 | percentages = FALSE, 27 | returnPlot = FALSE, 28 | showPlot = TRUE 29 | ) 30 | } 31 | \arguments{ 32 | \item{fit}{An object of class \code{elicitation}.} 33 | 34 | \item{d}{The distribution fitted to each expert's probabilities. Options are 35 | \code{"normal"}, \code{"t"}, \code{"skewnormal"}, \code{"gamma"}, \code{"lognormal"}, 36 | \code{"logt"},\code{"beta"}, \code{"mirrorgamma"}, 37 | \code{"mirrorlognormal"}, \code{"mirrorlogt"} \code{"hist"} (for a histogram fit), and 38 | \code{"best"} (for best fitting)} 39 | 40 | \item{xl}{The lower limit for the x-axis. The default is the 0.001 quantile 41 | of the fitted distribution (or the 0.001 quantile of a fitted normal 42 | distribution, if a histogram fit is chosen).} 43 | 44 | \item{xu}{The upper limit for the x-axis. The default is the 0.999 quantile 45 | of the fitted distribution (or the 0.999 quantile of a fitted normal 46 | distribution, if a histogram fit is chosen).} 47 | 48 | \item{yl}{The lower limit for the y-axis. Default value is 0.} 49 | 50 | \item{yu}{The upper limit for the y-axis. Will be set automatically if not specified.} 51 | 52 | \item{ql}{A lower quantile to be indicated on the density function plot. 53 | Only displayed when plotting the density function for a single expert.} 54 | 55 | \item{qu}{An upper quantile to be indicated on the density function plot. 56 | Only displayed when plotting the density function for a single expert.} 57 | 58 | \item{lp}{For multiple experts, set \code{lp = TRUE} to plot a linear pool.} 59 | 60 | \item{ex}{If judgements have been elicited from multiple experts, but a 61 | density plot for one expert only is required, the expert to be used in the 62 | plot.} 63 | 64 | \item{sf}{The number of significant figures to be displayed for the 65 | parameter values.} 66 | 67 | \item{ind}{If plotting a linear pool, set \code{ind = FALSE} to suppress 68 | plotting of the individual density functions.} 69 | 70 | \item{lpw}{A vector of weights to be used in linear pool, if unequal 71 | weighting is desired.} 72 | 73 | \item{fs}{The font size used in the plot.} 74 | 75 | \item{lwd}{The line width used in the plot.} 76 | 77 | \item{xlab}{A string or expression giving the x-axis label.} 78 | 79 | \item{ylab}{A string or expression giving the y-axis label.} 80 | 81 | \item{legend_full}{If plotting a linear pool, set \code{ind = TRUE} for each expert 82 | to be plotted with a different colour, and \code{ind = FALSE} for each expert to be 83 | plotted with the same colour, reducing the legend size.} 84 | 85 | \item{percentages}{Set to \code{TRUE} to use percentages on the x-axis.} 86 | 87 | \item{returnPlot}{Set to \code{TRUE} to return the plot as a ggplot object.} 88 | 89 | \item{showPlot}{Set to \code{FALSE} to suppress displaying the plot.} 90 | } 91 | \description{ 92 | Plots the fitted density function for one or more experts. Can also plot a 93 | fitted linear pool if more than one expert. If plotting the density function 94 | of one expert, or the linear pool only, can also indicated desired lower and 95 | upper fitted quantiles. 96 | } 97 | \examples{ 98 | 99 | \dontrun{ 100 | # Two experts 101 | # Expert 1 states P(X<30)=0.25, P(X<40)=0.5, P(X<50)=0.75 102 | # Expert 2 states P(X<20)=0.25, P(X<25)=0.5, P(X<35)=0.75 103 | # Both experts state 0 128 | } 129 | -------------------------------------------------------------------------------- /vignettes/Dirichlet-elicitation.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Eliciting a Dirichlet Distribution" 3 | output: rmarkdown::html_vignette 4 | vignette: > 5 | %\VignetteIndexEntry{Eliciting a Dirichlet Distribution} 6 | %\VignetteEngine{knitr::rmarkdown} 7 | %\VignetteEncoding{UTF-8} 8 | --- 9 | 10 | ```{r setup, include=FALSE} 11 | knitr::opts_chunk$set(echo = TRUE, 12 | collapse = TRUE) 13 | ``` 14 | 15 | We illustrate the process of eliciting a Dirichlet distribution using the methodology and case study in Zapata-Vazquez, R., O'Hagan, A. and Bastos, L. S. (2014). Eliciting expert judgements about a set of proportions. Journal of Applied Statistics 41, 1919-1933. Quoting from their Section 3.4, 16 | 17 | > This example concerns the efficacy of a new antibiotic in patients who are hospitalised in the Pediatric Intensive Care Unit (PICU) and who are severely infected by pneumococci (which is associated with pneumonia, meningitis, and septicaemia, among other conditions). The possible results after the infection are: to survive in good condition, to have a sequel, or to die. An expert is asked to provide judgements about the proportions of patients who will have each of these possible results. Denoting these proportions by $\pi_1$, $\pi_2$, $\pi_3$, these form a set of proportions that must sum to 1. 18 | 19 | The Dirichlet distribution is parameterised by 20 | $$ 21 | f(\pi_1,\pi_2,\pi_3)\propto \prod_{i=1}^3\pi_i^{d_i-1}, 22 | $$ 23 | with $n=\sum_{i=1}^3 d_i$. 24 | 25 | The elicited judgements for the three marginal proportions were 26 | 27 | | | Good outcome | Sequel | Dead | 28 | |----------------|--------------|--------|------| 29 | | Lower quartile | 0.50 | 0.22 | 0.11 | 30 | | Median | 0.55 | 0.30 | 0.15 | 31 | | Upper quartile | 0.60 | 0.35 | 0.20 | 32 | 33 | 34 | For each marginal proportion $\pi_i$, the expert has provided a lower quartile, a median and an upper quartile, so we define a single vector of probabilities, specifying which quantiles have been elicited. 35 | ```{r} 36 | p1 <- c(0.25, 0.5, 0.75) 37 | ``` 38 | We then define one vector for each marginal proportion, giving the values of the elicited quantiles. 39 | ```{r} 40 | v.good <- c(0.5, 0.55, 0.6) 41 | v.seql <- c(0.22, 0.3, 0.35) 42 | v.dead <- c(0.11, 0.15, 0.2) 43 | ``` 44 | Next we fit probability distributions to each set of elicited quantiles. 45 | ```{r } 46 | library(SHELF) 47 | fit.good <- fitdist(vals = v.good, probs = p1, lower = 0, upper = 1) 48 | fit.seql <- fitdist(vals = v.seql, probs = p1, lower = 0, upper = 1) 49 | fit.dead <- fitdist(vals = v.dead, probs = p1, lower = 0, upper = 1) 50 | ``` 51 | The objects \texttt{fit.good, fit.seql} and \texttt{fit.dead} all include parameters of fitted beta distributions, for example, 52 | 53 | ```{r} 54 | fit.good$Beta 55 | ``` 56 | 57 | 58 | 59 | We can now fit the Dirichlet distribution to the elicited marginals. 60 | 61 | ```{r, , fig.height = 4, fig.width = 5, fig.pos="h", fig.align="center" } 62 | d.fit <- fitDirichlet(fit.good, fit.seql, fit.dead, 63 | categories = c("Good outcome","Sequel","Dead"), 64 | n.fitted = "opt") 65 | ``` 66 | 67 | The above plot shows both the marginal distributions that were elicited directly, and the the marginal distributions resulting from the Dirichlet fit. Parameters and summaries from these two sets of distributions are shown as output. We see that the marginal distribution for the 'Dead' proportion hasn't changed appreciably, but that the Dirichlet fit has resulted in a little more uncertainty for the 'Good outcome' proportion, and a little less uncertainty for the 'Sequel' proportion. 68 | 69 | The Dirichlet parameters are stored in \texttt{d.fit}, but can be read off from the \texttt{shape1} row: we have $d_1=16.6, d_2=8.96, d_3=4.8$ (the values have been rounded for display purposes). 70 | 71 | 72 | We can report feedback from the marginal distributions of the fitted Dirichlet: 73 | 74 | ```{r} 75 | feedbackDirichlet(d.fit, quantiles = c(0.1, 0.5, 0.9)) 76 | ``` 77 | so, for example, after fitting the Dirichlet distribution, the fitted median and 90th percentile for the proportion of 'good outcomes' are 0.55 and 0.66 respectively. 78 | 79 | 80 | The parameter $n$ was chosen by minimising the sum of squared differences between the marginal standard deviations in the elicited marginal beta distributions and the marginals from the fitted Dirichlet. An alternative, more conservative choice is to set $n$ as the minimum of the sum of the beta parameters in each elicited marginal. From the output above, we can see that this will correspond to the 'Sequel' proportion. 81 | 82 | 83 | ```{r, fig.height = 4, fig.width = 5, fig.pos="h", fig.align="center" } 84 | d.fit <- fitDirichlet(fit.good, fit.seql, fit.dead, 85 | categories = c("Good outcome","Sequel","Dead"), 86 | n.fitted = "min") 87 | ``` 88 | We see that there is almost no change between the elicited and fitted marginal for the 'Sequel' proportion, barring a minor adjustment to ensure the fitted marginal means sum to 1. -------------------------------------------------------------------------------- /R/pdfplots.R: -------------------------------------------------------------------------------- 1 | #' Plot fitted population pdfs 2 | #' 3 | #' Plot fitted population pdfs at combinations of two different values of the population mean and variance. 4 | #' 5 | #' Four pdfs are plotted, using each combination of the \code{alpha}/2 and 1-\code{alpha}/2 6 | #' quantiles of the fitted distributions for the population median and standard deviation 7 | #' 8 | #' @param medianfit The output of a \code{fitdist} command following elicitation 9 | #' of the expert's beliefs about the population median. 10 | #' @param precisionfit The output of a \code{fitdist} command following elicitation 11 | #' of the expert's beliefs about the population precision. 12 | #' 13 | #' @param alpha Value between 0 and 1 to determine choice of means and variances used in plots 14 | #' @param tails Value between 0 and 1 to determine the tail area shown in the pdf plots 15 | #' @param lower lower limit on the x-axis for plotting. 16 | #' @param upper upper limit on the x-axis for plotting. 17 | #' @param d The fitted distribution for the population median. Can be one of "normal", 18 | #' "lognormal" or "best", where "best" will select the best fitting out of 19 | #' normal and lognormal. 20 | #' @param n.x The number of points on the x-axis at which the pdf is plotted. 21 | #' @param fontsize Font size used in the plots. 22 | #' 23 | #' @return A plot and a list, containing 24 | #' \item{mu}{The two population mean values used in the plots.} 25 | #' \item{sigma}{The two population standard deviation values used in the plots.} 26 | #' 27 | #' 28 | #' @references \code{multiplot} function obtained from 29 | #' \url{http://www.cookbook-r.com/Graphs/Multiple_graphs_on_one_page_(ggplot2)/} 30 | #' 31 | #' @examples 32 | #' \dontrun{ 33 | #' prfit <- fitprecision(interval = c(60, 70), propvals = c(0.2, 0.4), trans = "log") 34 | #' medianfit <- fitdist(vals = c(50, 60, 70), probs = c(0.05, 0.5, 0.95), lower = 0) 35 | #' pdfplots(medianfit, prfit, alpha = 0.01) 36 | #' } 37 | #' @import ggplot2 38 | #' @export 39 | 40 | pdfplots <- function(medianfit, precisionfit, 41 | alpha = 0.05, tails = 0.05, 42 | lower = NA, upper = NA, n.x = 100, 43 | d = "best", 44 | fontsize = 18){ 45 | 46 | mediandist <- getmediandist(medianfit, d) 47 | 48 | a<-precisionfit$Gamma[[1]] 49 | b<-precisionfit$Gamma[[2]] 50 | 51 | quantiles <- c(alpha / 2, 1 - alpha /2) 52 | 53 | f <- getdists(precisionfit$transform) 54 | 55 | lim <- getlimits(lower, upper, f, mediandist, precisionfit) 56 | 57 | mu <- f$trans(mediandist$quan(quantiles, mediandist$m ,mediandist$s)) 58 | sigma <- sort(sqrt(1 / qgamma(quantiles, a, b))) 59 | 60 | X <- seq(from = lim$lower, to = lim$upper, length = n.x) 61 | 62 | f11 <- f12 <- f21 <- f22 <- NULL # hack to avoid R CMD check NOTE 63 | 64 | df <- data.frame(X, f11 = f$dens(X, mu[1], sigma[1]), 65 | f12 = f$dens(X, mu[1], sigma[2]), 66 | f21 = f$dens(X, mu[2], sigma[1]), 67 | f22 = f$dens(X, mu[2], sigma[2])) 68 | 69 | dmax <- max(df[,2:5]) 70 | 71 | theme_set(theme_grey(base_size = fontsize)) 72 | 73 | pcore <- ggplot(df, aes(x=X, y=f11)) + expand_limits(y = c(0, dmax)) + 74 | labs(y = "") 75 | p1 <- pcore + geom_line() + labs (title = bquote(list(mu[.(alpha/2)], ~ sigma[.(alpha/2)]))) 76 | p2 <- pcore + geom_line(aes(x=X, y=f12)) + labs (title = bquote(list(mu[.(alpha/2)], ~ sigma[.(1 - alpha/2)]))) 77 | p3 <- pcore + geom_line(aes(x=X, y=f21)) + labs (title = bquote(list(mu[.(1 - alpha/2)], ~ sigma[.(alpha/2)]))) 78 | p4 <- pcore + geom_line(aes(x=X, y=f22)) + labs (title = bquote(list(mu[.(1 - alpha/2)], ~ sigma[.(1 - alpha/2)]))) 79 | 80 | if(!is.na(tails)){ 81 | 82 | xl <- dl <- xu <- du <- NULL # hack to avoid R CMD check NOTE 83 | 84 | df <- taildensities(mu[1], sigma[1], tails, n.x, lim$lower, lim$upper, f$dens, f$quan) 85 | p1 <- p1 + geom_area(data = df, aes(x=xl, y = dl), fill="red", alpha=0.5) + 86 | geom_area(data = df, aes(x=xu, y = du), fill="red", alpha=0.5) 87 | 88 | df <- taildensities(mu[1], sigma[2], tails, n.x, lim$lower, lim$upper, f$dens, f$quan) 89 | p2 <- p2 + geom_area(data = df, aes(x=xl, y = dl), fill="red", alpha=0.5) + 90 | geom_area(data = df, aes(x=xu, y = du), fill="red", alpha=0.5) 91 | 92 | df <- taildensities(mu[2], sigma[1], tails, n.x, lim$lower, lim$upper, f$dens, f$quan) 93 | p3 <- p3 + geom_area(data = df, aes(x=xl, y = dl), fill="red", alpha=0.5) + 94 | geom_area(data = df, aes(x=xu, y = du), fill="red", alpha=0.5) 95 | 96 | df <- taildensities(mu[2], sigma[2], tails, n.x, lim$lower, lim$upper, f$dens, f$quan) 97 | p4 <- p4 + geom_area(data = df, aes(x=xl, y = dl), fill="red", alpha=0.5) + 98 | geom_area(data = df, aes(x=xu, y = du), fill="red", alpha=0.5) 99 | 100 | } 101 | multiplot(p1, p2, p3, p4, cols = 2) 102 | 103 | list(mu = mu, sigma = sigma) 104 | } -------------------------------------------------------------------------------- /vignettes/SHELF-overview.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Getting Started with SHELF" 3 | output: rmarkdown::html_vignette 4 | vignette: > 5 | %\VignetteIndexEntry{Getting Started with SHELF} 6 | %\VignetteEngine{knitr::rmarkdown} 7 | %\VignetteEncoding{UTF-8} 8 | --- 9 | 10 | ```{r, include = FALSE} 11 | knitr::opts_chunk$set( 12 | collapse = TRUE, 13 | comment = "#>" 14 | ) 15 | ``` 16 | 17 | # Introduction 18 | 19 | We illustrate the process of fitting a probabilty distribution to an expert's judgements, and obtaining feedback. 20 | 21 | Various elicitation methods are suggested in SHELF, but they all involve either asking for probability or quantile judgements: the expert is either asked questions of the form, 'What is your probability $P(X\le10)$?' or, 'Provide a value $x$ such that you think $P(X\le x)=0.5.$'' Either way, we think of the expert as providing points on his/her cumulative distribution function (CDF). 22 | 23 | As an example, suppose the uncertain quantity is the percentage $X$ of voters who will vote for a particular candidate in an upcoming leadership election. 24 | 25 | # Eliciting individual distributions from multiple experts 26 | 27 | Suppose we have two experts, who first consider their judgements independently. Expert A states $$P(X\le25)=0.25, P(X\le30)=0.5, P(X\le35)=0.75,$$ and 28 | Expert B states $$P(X\le30)=0.25, P(X\le35)=0.5, P(X<50)=0.75.$$ 29 | 30 | 31 | 32 | The values of the quantiles are arranged in a matrix, with one column per expert 33 | ```{r define v} 34 | v <- matrix(c(25, 30, 35, 30, 35, 50), nrow = 3, ncol = 2) 35 | ``` 36 | ```{r show v, echo = F} 37 | v 38 | ``` 39 | 40 | The probabilities should be arranged in matrix if they are different for the two experts (for example, if one expert had specified tertiles instead of lower and upper quartiles), otherwise they are stored in a vector 41 | 42 | ```{r define p} 43 | p <- c(0.25, 0.5, 0.75) 44 | ``` 45 | 46 | We now fit probability distributions to these judgements with the `fitdist` command. Without specifying any limits (`lower` and `upper`), only normal and Student-$t$ distributions (with 3 degrees of freedom used as a default) will be fitted. Including a `lower` limit will result in log-normal, log Student-$t$ and gamma distributions also being fitted, and including both a `lower` and `upper` limit will result in a beta distribution fit, scaled to the interval [`lower`, `upper`]. 47 | ```{r use myfit} 48 | library(SHELF) 49 | myfit <- fitdist(vals = v, probs = p, lower = 0, upper = 100) 50 | ``` 51 | 52 | The object `myfit` includes parameters of the fitted distributions for each expert, sums of squared errors (elicited - fitted probabilities) for each distribution and expert, and the original elicited judgements: 53 | ```{r show myfit} 54 | names(myfit) 55 | ``` 56 | For example, the parameters of the fitted beta distributions are 57 | ```{r show beta} 58 | myfit$Beta 59 | ``` 60 | 61 | Inspecting `myfit$ssq` (sum of squared differences between elicited and fitted probabilities), we see that the normal distribution fits best for Expert 1, and the log Student-$t_3$ distribution fits best for Expert 2 (although the fit would probably be judged adequate for any the distributions, in this case). These best-fitting distributions are used as defaults in the `plotfit` function, and the `feedback` function when used with multiple experts 62 | 63 | ```{r show ssq} 64 | myfit$ssq 65 | ``` 66 | 67 | We plot the fitted distributions, including a linear pool. 68 | ```{r plot-fitted-distributions, fig.height = 4, fig.width = 5, fig.pos="h", fig.align="center", fig.cap = "The two fitted distributions and an equal-weighted linear pool."} 69 | plotfit(myfit, lp = TRUE) 70 | ``` 71 | 72 | # Eliciting a single distribution from an individual or a group of experts 73 | 74 | Now we elicit a single a single 'consensus' distribution from the two experts. 75 | Suppose they agree $$P(X\le 25)=0.25, P(X\le30)=0.5, P(X\le40)=0.75.$$ 76 | We fit a single set of distributions to these judgements. 77 | ```{r define single set} 78 | v <-c(25, 30, 40) 79 | p <-c(0.25, 0.5, 0.75) 80 | consensus <- fitdist(vals = v, probs = p, lower = 0, upper = 100) 81 | ``` 82 | 83 | The best fitting distribution is the log Student-$t_3$ distribution, but the (scaled) beta distribution would likely be adequate at this stage, and we may choose to use the beta instead, given it has the appropriate bounds. 84 | 85 | We plot the fitted density, and mark the 86 | fitted 5th and 95th percentiles 87 | ```{r plot-RIO, fig.height = 4, fig.width = 5, fig.pos="h", fig.align="center", fig.cap = "The fitted consensus distribution, with the lower and upper 5\\% tail areas shown as feedback."} 88 | plotfit(consensus, ql = 0.05, qu = 0.95, d = "beta") 89 | ``` 90 | 91 | We can obtain values of fitted percentiles and probabilities with the `feedback` function. This will show fitted values for all the fitted distributions 92 | ```{r show feedback} 93 | feedback(consensus, quantiles = c(0.05, 0.95)) 94 | ``` 95 | For the fitted beta distribution, we have $P(X<15.2)=0.05$, and we can also compare, for example, the fitted probability $P(X<25)=0.283$ with elicited probability $P(X<25)=0.25$. -------------------------------------------------------------------------------- /R/cdffeedback.R: -------------------------------------------------------------------------------- 1 | #' Feedback for the elicited distribution of the population CDF 2 | #' 3 | #' Report the median and 100(1-alpha)\% credible interval for point on the population CDF 4 | #' 5 | #' Denote the uncertain population CDF by \deqn{P(X \le x | \mu, \sigma^2),}where \eqn{\mu} 6 | #' is the uncertain population median and \eqn{\sigma^(-2)} is the uncertain population precision. 7 | #' Feedback can be reported in the form of the median and 100(1-alpha)\% credible interval for 8 | #' (a) an uncertain probability \eqn{P(X \le x | \mu, \sigma^2)}, where \eqn{x} is a specified 9 | #' population value and (b) an uncertain quantile \eqn{x_q} defined by \eqn{P(X \le x_q | \mu, \sigma^2) = q}, where \eqn{q} is a specified 10 | #' population probability. 11 | #' 12 | #' @param medianfit The output of a \link{fitdist} command following elicitation 13 | #' of the expert's beliefs about the population median. 14 | #' @param precisionfit The output of a \link{fitprecision} command following elicitation 15 | #' of the expert's beliefs about the population precision. 16 | #' @param quantiles A vector of quantiles \eqn{q_1, \ldots,q_n} required for feedback 17 | #' @param vals A vector of population values \eqn{x_1,\ldots,x_n} required for feedback 18 | #' @param alpha The size of the 100(1-alpha)\% credible interval 19 | #' @param median.dist The fitted distribution for the population median. Can be one of \code{"normal"}, 20 | #' \code{"lognormal"} or \code{"best"}, where \code{"best"} will select the best fitting out of 21 | #' normal and lognormal. 22 | #' @param precision.dist The fitted distribution for the population precision. Can either be \code{"gamma"} 23 | #' or \code{"lognormal"}. 24 | #' @param n.rep The number of randomly sampled CDFs used to estimated the median 25 | #' and credible interval. 26 | #' 27 | #' @return Fitted median and 100(1-alpha)\% credible interval for population 28 | #' quantiles and probabilities. 29 | #' 30 | #' \item{$quantiles}{Each row gives the fitted median 31 | #' and 100(1-alpha)\% credible interval for each uncertain population quantile 32 | #' specified in \code{quantiles}: the fitted median 33 | #' and 100(1-alpha)\% credible interval for the value of \eqn{x_{q_i}} where 34 | #' \eqn{P(X\le x_{q_i} | \mu, \sigma^2) = q_i.}} 35 | #' \item{$probs}{Each row gives the fitted median 36 | #' and 100(1-alpha)\% credible interval for each uncertain population probability 37 | #' specified in \code{probs}: the fitted median 38 | #' and 100(1-alpha)\% credible interval for the value of 39 | #' \eqn{P(X\le x_i | \mu, \sigma^2).} } 40 | #' 41 | #' @examples 42 | #' \dontrun{ 43 | #' prfit <- fitprecision(interval = c(60, 70), propvals = c(0.2, 0.4), trans = "log") 44 | #' medianfit <- fitdist(vals = c(50, 60, 70), probs = c(0.05, 0.5, 0.95), lower = 0) 45 | #' cdffeedback(medianfit, prfit, quantiles = c(0.01, 0.99), 46 | #' vals = c(65, 75), alpha = 0.05, n.rep = 10000) 47 | #' } 48 | #' @export 49 | 50 | cdffeedback <- function(medianfit, precisionfit, quantiles = c(0.05, 0.95), 51 | vals = NA, alpha = 0.05, median.dist = "best", 52 | precision.dist = "gamma", n.rep = 10000){ 53 | 54 | if(precision.dist!="gamma" & precision.dist!="lognormal"){ 55 | stop('precision.dist must equal one of "gamma" or "lognormal"') 56 | } 57 | 58 | f <- getdists(precisionfit$transform) 59 | mediandist <- getmediandist(medianfit, median.dist) 60 | 61 | musample <- mediandist$rand(n.rep, mediandist$m, mediandist$s) 62 | mumatrix <- matrix(musample, n.rep, length(quantiles)) 63 | 64 | if(precision.dist == "gamma"){ 65 | sigmasample <- sqrt(1 / rgamma(n.rep, precisionfit$Gamma[[1]], 66 | precisionfit$Gamma[[2]])) 67 | } 68 | 69 | if(precision.dist == "lognormal"){ 70 | sigmasample <- sqrt(1 / rlnorm(n.rep, precisionfit$Log.normal[[1]], 71 | precisionfit$Log.normal[[2]])) 72 | } 73 | 74 | sigmamatrix <- matrix(sigmasample, n.rep, length(quantiles)) 75 | 76 | quantilematrix <- matrix(quantiles, n.rep, length(quantiles), byrow = T) 77 | quantilesample <- f$quan(quantilematrix, f$trans(mumatrix), sigmamatrix) 78 | quantilesample <- apply(quantilesample, 2, sort) 79 | 80 | index <- c(ceiling(alpha / 2 * n.rep), round(0.5 * n.rep), floor((1 - alpha / 2)*n.rep)) 81 | quantileinterval <- quantilesample[index, ] 82 | 83 | rownames(quantileinterval) <- c(alpha / 2, 0.5, 1 - alpha/2) 84 | colnames(quantileinterval) <- quantiles 85 | 86 | if(!is.na(vals[1])){ 87 | mumatrix <- matrix(musample, n.rep, length(vals)) 88 | sigmamatrix <- matrix(sigmasample, n.rep, length(vals)) 89 | valmatrix <- matrix(vals, n.rep, length(vals), byrow = T) 90 | probsample <- f$cdf(valmatrix, f$trans(mumatrix), sigmamatrix) 91 | probsample <- apply(probsample, 2, sort) 92 | probinterval <- probsample[index, ] 93 | rownames(probinterval) <- c(alpha / 2, 0.5, 1 - alpha/2) 94 | colnames(probinterval) <- vals 95 | return(list(quantiles = t(quantileinterval), probs = t(probinterval)))}else{ 96 | return(list(quantiles = t(quantileinterval))) 97 | } 98 | } 99 | -------------------------------------------------------------------------------- /R/makeLinearPoolPlot.R: -------------------------------------------------------------------------------- 1 | makeLinearPoolPlot <- 2 | function(fit, xl, xu, d = "best", w = 1, lwd, xlab, ylab, 3 | legend_full = TRUE, ql = NULL, qu = NULL, 4 | nx = 200, addquantile = FALSE, fs = 12, 5 | expertnames = NULL, 6 | lpname = "linear pool"){ 7 | 8 | expert <- ftype <- NULL # hack to avoid R CMD check NOTE 9 | 10 | n.experts <- nrow(fit$vals) 11 | 12 | if(length(d) == 1){ 13 | d <- rep(d, n.experts) 14 | } 15 | 16 | 17 | if(is.null(expertnames)){ 18 | 19 | if(n.experts < 27){ 20 | expertnames <- LETTERS[1:n.experts] 21 | } 22 | 23 | if(n.experts > 26){ 24 | expertnames <- 1:n.experts 25 | } 26 | 27 | } 28 | 29 | nxTotal <- nx + length(c(ql, qu)) 30 | 31 | x <- matrix(0, nxTotal, n.experts) 32 | fx <- x 33 | if(min(w)<0 | max(w)<=0){stop("expert weights must be non-negative, and at least one weight must be greater than 0.")} 34 | 35 | if(length(w)==1){ 36 | w <- rep(w, n.experts) 37 | } 38 | 39 | weight <- matrix(w/sum(w), nxTotal, n.experts, byrow = T) 40 | 41 | 42 | for(i in 1:n.experts){ 43 | densitydata <- expertdensity(fit, d[i], ex = i, xl, xu, ql, qu, nx) 44 | x[, i] <- densitydata$x 45 | fx[, i] <-densitydata$fx 46 | } 47 | 48 | fx.lp <- apply(fx * weight, 1, sum) 49 | df1 <- data.frame(x = rep(x[, 1], n.experts + 1), 50 | fx = c(as.numeric(fx), fx.lp), 51 | expert = factor(c(rep(expertnames, 52 | each = nxTotal), 53 | rep(lpname, nxTotal)), 54 | levels = c(expertnames, 55 | lpname)), 56 | ftype = factor(c(rep("individual", 57 | nxTotal * n.experts), 58 | rep(lpname, nxTotal)), 59 | levels = c("individual", 60 | lpname)) 61 | ) 62 | df1$expert <- factor(df1$expert, 63 | levels = c(expertnames, lpname)) 64 | 65 | if(legend_full){ 66 | 67 | cols <- scales::hue_pal()(n.experts + 1) 68 | linetypes <- c(rep("dashed", n.experts), "solid") 69 | sizes <- lwd * c(rep(0.5, n.experts), 1.5) 70 | names(cols) <- names(linetypes) <- 71 | names(sizes) <- c(expertnames, lpname ) 72 | 73 | p1 <- ggplot(df1, aes(x = x, y = fx, 74 | colour = expert, 75 | linetype = expert, 76 | size = expert)) + 77 | scale_colour_manual(values = cols, 78 | breaks = c(expertnames, lpname )) + 79 | scale_linetype_manual(values = linetypes, 80 | breaks = c(expertnames, lpname )) + 81 | scale_size_manual(values = sizes, 82 | breaks = c(expertnames, lpname ))}else{ 83 | 84 | p1 <- ggplot(df1, aes(x = x, y = fx, 85 | colour = ftype, 86 | linetype=ftype, size =ftype)) + 87 | scale_linetype_manual(name = "distribution", values = c("dashed", "solid"))+ 88 | scale_size_manual(name = "distribution", values = lwd * c(.5, 1.5)) + 89 | scale_color_manual(name = "distribution", values = c("black", "red")) 90 | } 91 | 92 | if(legend_full){ 93 | 94 | for(i in 1:n.experts){ 95 | if(d[i] == "hist"){ 96 | p1 <- p1 + geom_step(data = subset(df1, expert == expertnames[i]), 97 | aes(colour = expert)) 98 | }else{ 99 | p1 <- p1 + geom_line(data = subset(df1, expert == expertnames[i]), 100 | aes(colour = expert)) 101 | } 102 | } 103 | }else{ 104 | for(i in 1:n.experts){ 105 | if(d[i] == "hist"){ 106 | p1 <- p1 + geom_step(data = subset(df1, expert == expertnames[i]), 107 | aes(colour = ftype)) 108 | }else{ 109 | p1 <- p1 + geom_line(data = subset(df1, expert == expertnames[i]), 110 | aes(colour = ftype)) 111 | } 112 | } 113 | } 114 | 115 | if(length(unique(d)) == 1 & d[1] == "hist"){ 116 | p1 <- p1 + geom_step(data = subset(df1, expert == lpname), 117 | aes(colour = expert)) 118 | }else{ 119 | p1 <- p1 + geom_line(data = subset(df1, expert == lpname), 120 | aes(colour = expert)) 121 | } 122 | 123 | 124 | p1 <- p1 + labs(x = xlab, y = ylab) 125 | 126 | if((!is.null(ql)) & (!is.null(qu)) & addquantile){ 127 | if(legend_full){ 128 | ribbon_col <- scales::hue_pal()(n.experts + 1)[n.experts + 1]}else{ 129 | ribbon_col <- "red" 130 | } 131 | p1 <- p1 + geom_ribbon(data = with(df1, subset(df1, x <= ql &expert == lpname)), 132 | aes(ymax = fx, ymin = 0), 133 | alpha = 0.2, show.legend = FALSE, colour = NA, fill =ribbon_col ) + 134 | geom_ribbon(data = with(df1, subset(df1, x >=qu &expert == lpname)), 135 | aes(ymax = fx, ymin = 0), 136 | alpha = 0.2, show.legend = FALSE, colour = NA, fill =ribbon_col ) 137 | 138 | 139 | } 140 | 141 | if(lpname == "marginal"){ 142 | p1 <- p1 + theme(legend.title = element_blank()) 143 | } 144 | 145 | p1 + theme(text = element_text(size = fs)) 146 | } 147 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/plots/compare-interval-plot.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | D 42 | C 43 | B 44 | A 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 20 55 | 30 56 | 40 57 | 50 58 | 60 59 | x 60 | expert 61 | compare interval plot 62 | 63 | 64 | -------------------------------------------------------------------------------- /tests/testthat/test-plots.R: -------------------------------------------------------------------------------- 1 | test_that("multiple expert plot works", { 2 | skip_on_cran() 3 | v <- matrix(c(30, 40, 50, 20, 25, 35), 3, 2) 4 | p <- c(0.25, 0.5, 0.75) 5 | myfit <- fitdist(vals = v, probs = p, lower = 0, upper = 100) 6 | p <- plotfit(myfit, showPlot = FALSE, returnPlot = TRUE) 7 | vdiffr::expect_doppelganger("multiple expert plot", p) 8 | }) 9 | 10 | test_that("multiple expert linear pool plot works", { 11 | skip_on_cran() 12 | v <- matrix(c(30, 40, 50, 20, 25, 35), 3, 2) 13 | p <- c(0.25, 0.5, 0.75) 14 | myfit <- fitdist(vals = v, probs = p, lower = 0, upper = 100) 15 | p <- plotfit(myfit, d = "gamma", lp = T, lpw = c(2,1), ql = 0.05, qu = 0.95, ind=FALSE, 16 | showPlot = FALSE, returnPlot = TRUE) 17 | vdiffr::expect_doppelganger("multiple expert linear pool plot", p) 18 | }) 19 | 20 | 21 | test_that("single expert plot works", { 22 | skip_on_cran() 23 | v <- matrix(c(30, 40, 50, 20, 25, 35), 3, 2) 24 | p <- c(0.25, 0.5, 0.75) 25 | myfit <- fitdist(vals = v, probs = p, lower = 0, upper = 100) 26 | p <- plotfit(myfit, d = "beta", ql = 0.05, qu = 0.95, ex = 2, showPlot = FALSE, 27 | returnPlot = TRUE) 28 | vdiffr::expect_doppelganger("single expert plot", p) 29 | }) 30 | 31 | test_that("exponential plot handling works", { 32 | skip_on_cran() 33 | v <- 1 34 | p <- 0.5 35 | myfit <- fitdist(vals = v, probs = p, lower = 0, upper = 100) 36 | p <- plotfit(myfit, d = "skewnormal", returnPlot = TRUE, showPlot = FALSE) 37 | vdiffr::expect_doppelganger("error message plot", p) 38 | p <- plotfit(myfit, d = "gamma", returnPlot = TRUE, showPlot = FALSE) 39 | vdiffr::expect_doppelganger("exponential distribution plot", p) 40 | }) 41 | 42 | test_that("single expert plot works - histogram", { 43 | skip_on_cran() 44 | v <- matrix(c(30, 40, 50, 20, 25, 35), 3, 2) 45 | p <- c(0.25, 0.5, 0.75) 46 | myfit <- fitdist(vals = v, probs = p, lower = 0, upper = 100) 47 | p <- plotfit(myfit, d = "hist", ql = 0.05, qu = 0.95, ex = 2, showPlot = FALSE, 48 | returnPlot = TRUE) 49 | vdiffr::expect_doppelganger("single expert histogram plot", p) 50 | }) 51 | 52 | test_that("CDF plot works", { 53 | skip_on_cran() 54 | vQuartiles <- c(30, 35, 45) 55 | pQuartiles<- c(0.25, 0.5, 0.75) 56 | myfit <- fitdist(vals = vQuartiles, probs = pQuartiles, lower = 0) 57 | p <- makeCDFPlot(lower = 0, v = vQuartiles, p = pQuartiles, 58 | upper = 100, fit = myfit, dist = "lognormal", 59 | showFittedCDF = TRUE, showQuantiles = TRUE) 60 | 61 | vdiffr::expect_doppelganger("CDF plot", p) 62 | }) 63 | 64 | test_that("quartile plot works", { 65 | skip_on_cran() 66 | l <- c(2, 1, 5, 1) 67 | u <- c(95, 90, 65, 40) 68 | v <- matrix(c(15, 25, 40, 69 | 10, 20, 40, 70 | 10, 15, 25, 71 | 5, 10, 20), 72 | 3, 4) 73 | p <- plotQuartiles(vals = v, lower = l, upper = u) 74 | 75 | vdiffr::expect_doppelganger("quartile plot", p) 76 | }) 77 | 78 | test_that("tertile plot works", { 79 | skip_on_cran() 80 | l <- c(-5, 0, 5, -10) 81 | u <- c(15, 35, 50, 35) 82 | v <- matrix(c(5, 8, 10, 83 | 10, 15, 20, 84 | 15, 18, 25, 85 | 10, 20, 30), 86 | 3, 4) 87 | p <- plotTertiles(vals = v, lower = l, upper = u) 88 | vdiffr::expect_doppelganger("tertile plot", p) 89 | }) 90 | 91 | 92 | test_that("distributions CDF plot works", { 93 | skip_on_cran() 94 | prfit <- fitprecision(interval = c(60, 70), propvals = c(0.2, 0.4), trans = "log", 95 | pplot = FALSE) 96 | medianfit <- fitdist(vals = c(50, 60, 70), probs = c(0.05, 0.5, 0.95), lower = 0) 97 | p <- cdfplot(medianfit, prfit) 98 | vdiffr::expect_doppelganger("distributions CDF plot", p) 99 | }) 100 | 101 | # test_that("compare group RIO plot works", { 102 | # skip_on_cran() 103 | # l <- c(2, 1, 5, 1) 104 | # u <- c(95, 90, 65, 40) 105 | # v <- matrix(c(15, 25, 40, 106 | # 10, 20, 40, 107 | # 10, 15, 25, 108 | # 5, 10, 20), 109 | # 3, 4) 110 | # p <- c(0.25, 0.5, 0.75) 111 | # group <- fitdist(vals = v, probs = p, lower = l, upper = u) 112 | # rio <- fitdist(vals = c(12, 20, 25), probs = p, lower = 1, upper = 100) 113 | # p <- compareGroupRIO(groupFit = group, RIOFit = rio, dRIO = "skewnormal") 114 | # vdiffr::expect_doppelganger("group RIO CDF plot", p) 115 | # }) 116 | 117 | test_that("compare interval plot works", { 118 | skip_on_cran() 119 | v <- matrix(c(30, 40, 50, 20, 25, 35, 40, 50, 60, 35, 40, 50), 3, 4) 120 | p <- c(0.25, 0.5, 0.75) 121 | myfit <- fitdist(vals = v, probs = p, lower = 0, upper = 100) 122 | p <- compareIntervals(myfit, interval = 0.5, showDist = FALSE) 123 | vdiffr::expect_doppelganger("compare interval plot", p) 124 | }) 125 | 126 | test_that("survival model extrapolations works", { 127 | skip_on_cran() 128 | sdf <- survival::veteran[, c("time", "status", "trt")] 129 | colnames(sdf) <- c("time", "event", "treatment") 130 | sdf$treatment <- factor(sdf$treatment, labels = c("standard", "test")) 131 | 132 | p <- survivalModelExtrapolations(sdf, tEnd = 1000, 133 | group = "test", 134 | tTruncate = 100, 135 | showPlot = FALSE) 136 | 137 | vdiffr::expect_doppelganger("survival extrapolations plot", p$KMplot) 138 | }) 139 | 140 | test_that("survival scenario testing works", { 141 | skip_on_cran() 142 | sdf <- survival::veteran[, c("time", "status", "trt")] 143 | colnames(sdf) <- c("time", "event", "treatment") 144 | sdf$treatment <- factor(sdf$treatment, labels = c("standard", "test")) 145 | p <- survivalScenario(tLower = 0,tUpper = 150, expLower = 100, expUpper = 150, 146 | tTarget = 250, survDf = sdf, 147 | expGroup = "standard", 148 | showPlot = FALSE) 149 | 150 | 151 | vdiffr::expect_doppelganger("survival scenario plot", p$KMplot) 152 | }) 153 | -------------------------------------------------------------------------------- /tests/testthat/test-linearpool.R: -------------------------------------------------------------------------------- 1 | test_that("linear pooling works",{ 2 | skip_on_cran() 3 | #p1 <- c(runif(1, 0.1, 0.4), 0.5, runif(1, 0.6, 0.9)) 4 | p1 <- c(0.25, 0.5, 0.75) 5 | a <- 10; b <- 4 6 | v1 <- qgamma(p1, a, b) 7 | mu <- 3 ; sigma <- 2 8 | v2 <- qnorm(p1, mu, sigma) 9 | v3 <- qlnorm(p1, log(mu), sigma) 10 | V <- matrix(c(v1, v2, v3), 3, 3) 11 | myfit <- fitdist(vals = V, probs = p1, lower = 0) 12 | 13 | w1 <- 1/6; w2 <- 2/6; w3 <- 3/6 14 | xtest <- 1.5 15 | qu <- 0.95 16 | 17 | qlp <- qlinearpool(myfit, qu, w = c(w1, w2, w3)) 18 | qcheck <- w1 * pgamma(qlp, a, b) + 19 | w2 * pnorm(qlp, mu, sigma) + 20 | w3 * plnorm(qlp, log(mu), sigma) 21 | expect_equal(qcheck, qu , tolerance = 1e-4) 22 | 23 | expect_equal(plinearpool(myfit, qlp, w = c(w1, w2, w3)), 24 | qu , tolerance = 1e-4) 25 | 26 | plp <- plinearpool(myfit, x = xtest, w = c(w1, w2, w3)) 27 | pcheck <- w1 * pgamma(xtest, a, b) + 28 | w2 * pnorm(xtest, mu, sigma) + 29 | w3 * plnorm(xtest, log(mu), sigma) 30 | expect_equal(plp, pcheck , tolerance = 1e-4) 31 | }) 32 | 33 | test_that("linear pooling works - different lower limits",{ 34 | skip_on_cran() 35 | llimits <- c(-2, 1, -4) 36 | p1 <- c(0.25, 0.5, 0.6, 0.75) 37 | a <- 10; b <- 4 38 | v1 <- llimits[1] + qgamma(p1, a, b) 39 | mu <- 3 ; sigma <- 2 40 | v2 <- llimits[2] + qlnorm(p1, log(mu), sigma) 41 | v3 <- llimits[3] + exp(1 + 2 * qt(p1, 3)) 42 | V <- matrix(c(v1, v2, v3), length(p1), 3) 43 | myfit <- fitdist(vals = V, probs = p1, lower = llimits) 44 | 45 | w1 <- 1/6; w2 <- 2/6; w3 <- 3/6 46 | xtest <- 3 47 | qu <- 0.03 48 | 49 | qlp <- qlinearpool(myfit, qu, w = c(w1, w2, w3)) 50 | qcheck <- w1 * pgamma(qlp - llimits[1], a, b) + 51 | w2 * plnorm(qlp - llimits[2], log(mu), sigma) + 52 | w3 * pt((log(qlp - llimits[3]) - 1) / 2 , 3) 53 | expect_equal(qcheck, qu , tolerance = 1e-4) 54 | 55 | expect_equal(plinearpool(myfit, qlp, w = c(w1, w2, w3)), 56 | qu , tolerance = 1e-4) 57 | 58 | plp <- plinearpool(myfit, x = xtest, w = c(w1, w2, w3)) 59 | pcheck <- w1 * pgamma(xtest - llimits[1], a, b) + 60 | w2 * plnorm(xtest - llimits[2], log(mu), sigma) + 61 | w3 * pt((log(xtest - llimits[3]) - 1) / 2, 3) 62 | expect_equal(plp, pcheck , tolerance = 1e-4) 63 | }) 64 | 65 | test_that("linear pool sampling ",{ 66 | skip_on_cran() 67 | set.seed(123) 68 | m1 <- 10; m2 <- 20; m3 <- 40 69 | s1 <- 1; s2<- 2; s3 <- 3 70 | p <- c(0.25, 0.5, 0.75) 71 | N <- 1000 72 | v <- matrix(c(qnorm(p, m1, s1), 73 | qnorm(p, m2, s2), 74 | qnorm(p, m3, s3)), 75 | nrow = 3, ncol = 3) 76 | myfit <- fitdist(vals = v, probs = p, lower = 0, upper = 100) 77 | 78 | x <- rlinearpool(myfit, n = N) 79 | se <- sqrt(var(x) / N) 80 | expect_equal(mean(x), mean(c(m1, m2, m3)), tolerance = 4 * se) 81 | 82 | weights <- c(0.1, 0.1, 0.8) 83 | x <- rlinearpool(myfit, n = N, w = weights) 84 | se <- sqrt(var(x) / N) 85 | expect_equal(mean(x), 86 | sum(weights * c(m1, m2, m3)), 87 | tolerance = 4 * se) 88 | }) 89 | 90 | test_that("feedback for multiple experts works",{ 91 | skip_on_cran() 92 | p1 <- c(0.33, 0.5, 0.66, 0.75) 93 | a <- 5; b <- 5 94 | v1 <- qgamma(p1, a, b) 95 | mu <- 10 ; sigma <- 2 96 | v2 <- qnorm(p1, mu, sigma) 97 | v3 <- qlnorm(p1, log(mu), sigma) 98 | V <- matrix(c(v1, v2, v3), 4, 3) 99 | myfit <- fitdist(vals = V, probs = p1, lower = 0) 100 | 101 | fb <- feedback(myfit, quantiles = c(0.1, 0.9), 102 | values = c(1, 2), sf = 6) 103 | 104 | expect_equal(fb$fitted.quantiles[, 1], qgamma(c(0.1, 0.9), a, b), 105 | tolerance = 1e-3) 106 | expect_equal(fb$fitted.quantiles[, 2], qnorm(c(0.1, 0.9), mu, sigma), 107 | tolerance = 1e-3) 108 | expect_equal(fb$fitted.quantiles[, 3], qlnorm(c(0.1, 0.9), log(mu), sigma), 109 | tolerance = 1e-3) 110 | 111 | expect_equal(fb$fitted.probabilities[, 1], pgamma(1:2, a, b), 112 | tolerance = 1e-4) 113 | expect_equal(fb$fitted.probabilities[, 2], pnorm(1:2, mu, sigma), 114 | tolerance = 1e-4) 115 | expect_equal(fb$fitted.probabilities[, 3], plnorm(1:2, log(mu), sigma), 116 | tolerance = 1e-4) 117 | }) 118 | 119 | 120 | test_that("feedback for multiple experts works",{ 121 | skip_on_cran() 122 | p1 <- c(0.33, 0.5, 0.66, 0.75) 123 | a <- 5; b <- 5 124 | v1 <- qgamma(p1, a, b) 125 | mu <- 10 ; sigma <- 2 126 | v2 <- qnorm(p1, mu, sigma) 127 | v3 <- qlnorm(p1, log(mu), sigma) 128 | V <- matrix(c(v1, v2, v3), 4, 3) 129 | myfit <- fitdist(vals = V, probs = p1, lower = 0) 130 | 131 | fb <- feedback(myfit, quantiles = c(0.1, 0.9), 132 | values = c(1, 2), sf = 6) 133 | 134 | expect_equal(fb$fitted.quantiles[, 1], qgamma(c(0.1, 0.9), a, b), 135 | tolerance = 1e-3) 136 | expect_equal(fb$fitted.quantiles[, 2], qnorm(c(0.1, 0.9), mu, sigma), 137 | tolerance = 1e-3) 138 | expect_equal(fb$fitted.quantiles[, 3], qlnorm(c(0.1, 0.9), log(mu), sigma), 139 | tolerance = 1e-3) 140 | 141 | expect_equal(fb$fitted.probabilities[, 1], pgamma(1:2, a, b), 142 | tolerance = 1e-4) 143 | expect_equal(fb$fitted.probabilities[, 2], pnorm(1:2, mu, sigma), 144 | tolerance = 1e-4) 145 | expect_equal(fb$fitted.probabilities[, 3], plnorm(1:2, log(mu), sigma), 146 | tolerance = 1e-4) 147 | }) 148 | 149 | 150 | test_that("linear pool density works",{ 151 | skip_on_cran() 152 | p1 <- c(0.1, 0.5, 0.66, 0.9) 153 | a <- 20; b <- 2 154 | v1 <- qgamma(p1, a, b) 155 | mu <- 9 ; sigma <- 3 156 | v2 <- qnorm(p1, mu, sigma) 157 | V <- matrix(c(v1, v2), 4, 2) 158 | myfit <- fitdist(vals = V, probs = p1, lower = 0) 159 | fx <- linearPoolDensity(myfit, xl = 0, xu = 20, lpw = c(2, 1)) 160 | x <- seq(from = 0, to = 20, length = 200) 161 | expect_equal(fx$f, 1/3*dnorm(x, mu, sigma) + 2/3 * dgamma(x, a, b), tolerance = 1e-6) 162 | }) 163 | --------------------------------------------------------------------------------