Response Styles and Endpoint Responses in Visual Analogue Scales
Shiny App: Illustration of a Zero- and One-Inflated Beta Item Response Model With Response Styles
Shiny App
General Explanation
This app illustrates a possible extension of the Beta Item Response Model with Response Styles (BIRM-RS; Vollbracht et al., 2026). The BIRM-RS models responses between the two ends of a visual analogue scale with a beta distribution. Responses at exactly 0 or 1 have no density in this distribution and must be moved slightly inward before estimation. Zero- and one-inflated models instead treat responses at exactly 0 and 1 as outcomes of their own (Molenaar et al., 2022). In these models, the probability of an endpoint response depends only on the trait and the item. Yet a response at an end may itself result from an extreme or acquiescent response style. In the extension illustrated here, response styles therefore act on both parts of the model.
The app shows the model for a single person–item combination, denoted by the indices \(i\) (person) and \(j\) (item), and for a simulated sample of persons. It illustrates the statistical model only. The extension has not yet been tested in simulations or empirical data.
An illustration of the BIRM-RS without inflation is available in a separate app.
The Model
Both parts of the model depend on the same term. It combines the distance between trait and item location with the person’s response styles:
\[ z_{ij} = \exp(\eta^{ERS}_i) \cdot (\theta_i - \delta_j + x_j \cdot \eta^{ARS}_i). \]
Here, \(\theta_i\) is the trait of person \(i\), \(\delta_j\) the location of item \(j\), and \(x_j\) is \(1\) for regular and \(-1\) for reverse-scored items. \(\eta^{ERS}_i\) and \(\eta^{ARS}_i\) are the person’s ERS and ARS parameters. The probabilities of responses at exactly 0 and 1 are
\[ P(Y_{ij} = 0) = \text{logit}^{-1}(-\kappa_{0j} - z_{ij}), \qquad P(Y_{ij} = 1) = \text{logit}^{-1}(z_{ij} - \kappa_{1j}). \]
The item parameters \(\kappa_{0j}\) and \(\kappa_{1j}\) determine how far \(z_{ij}\) must fall below or rise above zero before endpoint responses become likely. Their sum must be positive, so that the two endpoint probabilities add up to less than one. Responses between the ends follow the beta distribution of the BIRM-RS:
\[ Y_{ij} \mid 0 < Y_{ij} < 1 \sim \text{Beta}(m_{ij}, n_{ij}), \quad m_{ij} = \exp\left(\frac{z_{ij} + \tau_j}{2}\right), \quad n_{ij} = \exp\left(\frac{-z_{ij} + \tau_j}{2}\right), \]
where \(\tau_j\) is the item’s dispersion parameter. The expected response between the ends is \(\text{logit}^{-1}(z_{ij})\). Because \(z_{ij}\) enters both parts of the model, ERS makes the end that the trait favors more likely and moves the responses between the ends toward it. MRS (negative values of \(\eta^{ERS}_i\)) has the opposite effect, and ARS shifts both parts toward agreement. If the trait equals the item location and there is no ARS, ERS and MRS have no effect. Without response styles, the model reduces to the zero- and one-inflated beta item response model of Molenaar et al. (2022) without its item discrimination parameter.
Tabs
Inflated BIRM: The model without response styles. This tab shows how the trait and the item parameters affect the probabilities of responses at 0 and 1 and the distribution of responses between the ends.
Inflated BIRM-RS: Adds the ERS and ARS parameters (\(\eta^{ERS}_i\), \(\eta^{ARS}_i\)) and the item direction (\(x_j\)). The grey curve and bars show the same person without response styles.
Simulation: Simulates responses of a sample of persons to one item. Person parameters are drawn from normal distributions. The plot shows the share of responses at exactly 0 and 1 and of responses between the ends. The number of persons can be changed, and a button draws a new sample.
In the plots of the first two tabs, the curve shows the density of responses between the ends, weighted by the probability of such a response. The bars show the probabilities of responses at exactly 0 and 1 on a separate scale (right axis). They are drawn just outside the line so that they do not overlap the curve.
App
It can take a few seconds (around 10s-30s) to load the app, please be patient.
#| '!! shinylive warning !!': |
#| shinylive does not work in self-contained HTML documents.
#| Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 1800
#| viewerWidth: 2000
# Zero- and One-Inflated Beta Item Response Model With Response Styles
# Shiny app illustrating how response styles could act on responses at exactly
# 0 and 1 of a visual analogue scale. The model extends the BIRM-RS
# (https://donvollb.github.io/birm-rs_shiny/) with the zero- and one-inflated
# framework of Molenaar, Curi, and Bazan (2022), without its item
# discrimination parameter.
#
# Run locally: shiny::runApp("app.R")
# Required packages: shiny, shinythemes
library(shiny)
library(shinythemes)
# ---- Model --------------------------------------------------------------------
# Term shared by the endpoint part and the beta part of the model
z_term <- function(theta, delta, ers = 0, ars = 0, x = 1) {
exp(ers) * (theta - delta + x * ars)
}
# Probabilities of responses at 0, between the ends, and at 1,
# beta shape parameters, and expected values
inflated_birm_rs <- function(theta, delta, tau, kappa0, kappa1,
ers = 0, ars = 0, x = 1) {
z <- z_term(theta, delta, ers, ars, x)
p0 <- plogis(-kappa0 - z)
p1 <- plogis(z - kappa1)
p_between <- 1 - p0 - p1
m <- exp((z + tau) / 2)
n <- exp((-z + tau) / 2)
list(
z = z, p0 = p0, p1 = p1, p_between = p_between, m = m, n = n,
mean_between = m / (m + n),
mean = p1 + p_between * m / (m + n)
)
}
# Draws responses for one item from a sample of persons
simulate_responses <- function(n_persons, theta_mu, theta_sd, ers_mu, ers_sd,
ars_mu, ars_sd, delta, tau, kappa0, kappa1, x) {
theta <- rnorm(n_persons, theta_mu, theta_sd)
ers <- rnorm(n_persons, ers_mu, ers_sd)
ars <- rnorm(n_persons, ars_mu, ars_sd)
r <- inflated_birm_rs(theta, delta, tau, kappa0, kappa1, ers, ars, x)
u <- runif(n_persons)
y <- rbeta(n_persons, r$m, r$n)
y[u < r$p0] <- 0
y[u > 1 - r$p1] <- 1
y
}
# ---- Plots --------------------------------------------------------------------
col_model <- "#cc4778"
col_ref <- "grey55"
grid_y <- seq(0.001, 0.999, length.out = 999)
# Curve: density between the ends, weighted by the probability of such a response.
# Bars: probabilities of responses at exactly 0 and 1 (right axis).
plot_inflated <- function(model, reference = NULL) {
dens_of <- function(r) r$p_between * dbeta(grid_y, r$m, r$n)
dens <- dens_of(model)
dens_ref <- if (!is.null(reference)) dens_of(reference)
inner <- grid_y >= 0.02 & grid_y <= 0.98
y_top <- max(c(dens[inner], dens_ref[inner], 0.1), na.rm = TRUE) * 1.15
p_all <- c(model$p0, model$p1, reference$p0, reference$p1)
p_top <- max(0.1, ceiling(max(p_all) * 1.15 * 10) / 10)
to_left <- function(p) p / p_top * y_top
par(mar = c(5.1, 4.6, 3.1, 4.6))
plot(
NA,
xlim = c(-0.1, 1.1), ylim = c(0, y_top), xaxs = "i", yaxs = "i", xaxt = "n",
xlab = expression(bold(Response ~ Y[ij])),
ylab = expression(bold(Density ~ between ~ the ~ ends ~ (curve))),
main = "Responses at 0, Between the Ends, and at 1"
)
axis(1, at = seq(0, 1, 0.25))
right_ticks <- pretty(c(0, p_top))
right_ticks <- right_ticks[right_ticks <= p_top]
axis(4, at = to_left(right_ticks), labels = right_ticks)
mtext(expression(bold(Probability ~ of ~ exactly ~ 0 ~ or ~ 1 ~ (bars))),
side = 4, line = 3)
abline(v = c(0, 1), col = "grey85")
if (!is.null(reference)) {
lines(grid_y, dens_ref, col = col_ref, lwd = 2, lty = 2)
segments(c(-0.065, 1.065), 0, c(-0.065, 1.065),
to_left(c(reference$p0, reference$p1)),
col = col_ref, lwd = 9, lend = 1)
}
lines(grid_y, dens, col = col_model, lwd = 2.5)
segments(c(-0.035, 1.035), 0, c(-0.035, 1.035),
to_left(c(model$p0, model$p1)),
col = col_model, lwd = 9, lend = 1)
if (!is.null(reference)) {
legend("top", legend = c("with response styles", "without response styles"),
col = c(col_model, col_ref), lty = c(1, 2), lwd = 2.5, bty = "n",
horiz = TRUE)
}
}
plot_simulation <- function(y) {
breaks <- seq(0, 1, by = 0.05)
between <- y[y > 0 & y < 1]
share <- hist(between, breaks = breaks, plot = FALSE)$counts / length(y)
share0 <- mean(y == 0)
share1 <- mean(y == 1)
y_top <- max(c(share, share0, share1, 0.05)) * 1.2
par(mar = c(5.1, 4.6, 3.1, 2.1))
plot(
NA,
xlim = c(-0.1, 1.1), ylim = c(0, y_top), xaxs = "i", yaxs = "i", xaxt = "n",
xlab = expression(bold(Response ~ Y[ij])),
ylab = expression(bold(Share ~ of ~ all ~ responses)),
main = paste0("Simulated Responses to One Item (n = ", length(y), ")")
)
axis(1, at = seq(0, 1, 0.25))
rect(breaks[-length(breaks)], 0, breaks[-1], share, col = "grey80",
border = "white")
rect(c(-0.07, 1.01), 0, c(-0.01, 1.07), c(share0, share1), col = col_model,
border = NA)
text(c(-0.04, 1.04), c(share0, share1),
labels = sprintf("%.1f%%", 100 * c(share0, share1)), pos = 3, cex = 0.9)
legend("top", legend = c("exactly 0 or 1", "between the ends (bins of .05)"),
fill = c(col_model, "grey80"), border = NA, bty = "n", horiz = TRUE)
}
# ---- Equations ----------------------------------------------------------------
# Numbers for the equations; negative values in parentheses
fmt <- function(v) {
s <- formatC(v, format = "f", digits = 2)
ifelse(v < 0, paste0("(", s, ")"), s)
}
z_general <- function(ers, ars) {
inner <- if (ars) {
"\\theta_i - \\delta_j + x_j \\cdot \\eta^{ARS}_i"
} else {
"\\theta_i - \\delta_j"
}
if (ers) paste0("\\exp(\\eta^{ERS}_i) \\cdot (", inner, ")") else inner
}
z_values <- function(p, ers, ars) {
inner <- paste0(fmt(p$theta), " - ", fmt(p$delta))
if (ars) inner <- paste0(inner, " + ", fmt(p$x), " \\cdot ", fmt(p$ars))
ers_value <- formatC(p$ers, format = "f", digits = 2)
if (ers) paste0("\\exp(", ers_value, ") \\cdot (", inner, ")") else inner
}
equations_general <- function(ers, ars) {
paste0(
"$$z_{ij} = ", z_general(ers, ars), "$$",
"$$P(Y_{ij} = 0) = \\text{logit}^{-1}(-\\kappa_{0j} - z_{ij}), \\qquad ",
"P(Y_{ij} = 1) = \\text{logit}^{-1}(z_{ij} - \\kappa_{1j})$$",
"$$Y_{ij} \\mid 0 < Y_{ij} < 1 \\sim \\text{Beta}(m_{ij}, n_{ij}), \\quad ",
"m_{ij} = \\exp\\left(\\frac{z_{ij} + \\tau_j}{2}\\right), \\quad ",
"n_{ij} = \\exp\\left(\\frac{-z_{ij} + \\tau_j}{2}\\right)$$"
)
}
equations_values <- function(p, r, ers, ars) {
paste0(
"$$z_{ij} = ", z_values(p, ers, ars), " = ", fmt(r$z), "$$",
"$$P(Y_{ij} = 0) = \\text{logit}^{-1}(-", fmt(p$kappa0), " - ", fmt(r$z),
") = ", formatC(r$p0, format = "f", digits = 3), ", \\qquad ",
"P(Y_{ij} = 1) = \\text{logit}^{-1}(", fmt(r$z), " - ", fmt(p$kappa1),
") = ", formatC(r$p1, format = "f", digits = 3), "$$",
"$$m_{ij} = \\exp\\left(\\frac{", fmt(r$z), " + ", fmt(p$tau), "}{2}\\right) = ",
fmt(r$m), ", \\quad ",
"n_{ij} = \\exp\\left(\\frac{-", fmt(r$z), " + ", fmt(p$tau), "}{2}\\right) = ",
fmt(r$n), "$$"
)
}
eq_title <- function(text) {
tags$div(
style = "font-weight: bold; font-size: 14px; font-family: sans-serif; text-align: center;",
tags$b(text)
)
}
# ---- Slider texts -------------------------------------------------------------
txt <- list(
theta = "\\(\\theta_{i}\\): latent trait. Higher values shift the response distribution to the right and make responses at 1 more likely.",
ers = "\\(\\eta_{i}^{ERS}\\): ERS parameter. Positive values (ERS) stretch the distance between trait and item location: the end that the trait favors becomes more likely, and responses between the ends move toward it. Negative values (MRS) shrink the distance. Without ARS, there is no effect if \\(\\theta_i = \\delta_j\\).",
ars = "\\(\\eta_{i}^{ARS}\\): ARS parameter. For \\(x_j = 1\\), positive values shift both parts of the model toward 1 (agreement); for \\(x_j = -1\\), toward 0. Negative values shift toward disagreement.",
delta = "\\(\\delta_{j}\\): item location. Higher values shift the response distribution to the left and make responses at 0 more likely.",
tau = "\\(\\tau_{j}\\): item dispersion parameter. Higher values give a narrower distribution between the ends. It does not affect the endpoints.",
kappa0 = "\\(\\kappa_{0j}\\): lower endpoint threshold. How far \\(z_{ij}\\) must fall below zero before responses at exactly 0 become likely.",
kappa1 = "\\(\\kappa_{1j}\\): upper endpoint threshold. How far \\(z_{ij}\\) must rise above zero before responses at exactly 1 become likely.",
x = "\\(x_{j}\\): item direction. Coded as 1 for regular items and -1 for reverse-scored items."
)
kappa_message <- "The sum of the two endpoint thresholds must be positive, so that the probabilities of responses at 0 and 1 add up to less than one."
# ---- Tabs for single person-item combinations (module) ------------------------
model_tab_ui <- function(id, title, ers = FALSE, ars = FALSE, theta = 0) {
ns <- NS(id)
person <- list(sliderInput(ns("theta"), HTML(txt$theta),
min = -3, max = 3, value = theta, step = 0.1))
if (ers) {
person <- c(person, list(sliderInput(ns("ers"), HTML(txt$ers),
min = -1, max = 1, value = 0, step = 0.1)))
}
if (ars) {
person <- c(person, list(sliderInput(ns("ars"), HTML(txt$ars),
min = -1, max = 1, value = 0, step = 0.1)))
}
item <- list(
sliderInput(ns("delta"), HTML(txt$delta), min = -3, max = 3, value = 0, step = 0.1),
sliderInput(ns("tau"), HTML(txt$tau), min = 0, max = 5, value = 2.5, step = 0.1),
sliderInput(ns("kappa0"), HTML(txt$kappa0), min = -2, max = 6, value = 3, step = 0.1),
sliderInput(ns("kappa1"), HTML(txt$kappa1), min = -2, max = 6, value = 3, step = 0.1)
)
if (ars) {
item <- c(item, list(radioButtons(
ns("x"), HTML(txt$x), selected = 1,
choiceNames = c("1: regular", "-1: reverse-scored"), choiceValues = c(1, -1)
)))
}
reference <- if (ers || ars) {
checkboxInput(ns("show_ref"),
"Show the same person without response styles (grey)", TRUE)
}
tabPanel(
title,
sidebarLayout(
sidebarPanel(
h4(tags$b("Person Parameters")), person,
tags$hr(style = "margin: 20px 0; border: 1px solid gray;"),
h4(tags$b("Item Parameters")), item,
reference
),
mainPanel(
eq_title("Equations"),
uiOutput(ns("eq_general")),
eq_title("Equations With Values"),
uiOutput(ns("eq_values")),
plotOutput(ns("plot"), height = "450px"),
eq_title("Probabilities and Expected Values"),
tableOutput(ns("summary"))
)
)
)
}
model_tab_server <- function(id, ers = FALSE, ars = FALSE) {
moduleServer(id, function(input, output, session) {
pars <- reactive({
list(
theta = input$theta, delta = input$delta, tau = input$tau,
kappa0 = input$kappa0, kappa1 = input$kappa1,
ers = if (ers) input$ers else 0,
ars = if (ars) input$ars else 0,
x = if (ars) as.numeric(input$x) else 1
)
})
model <- reactive({
p <- pars()
validate(need(p$kappa0 + p$kappa1 > 0, kappa_message))
do.call(inflated_birm_rs, p)
})
reference <- reactive({
if (!(ers || ars) || !isTRUE(input$show_ref)) return(NULL)
p <- pars()
p$ers <- 0
p$ars <- 0
do.call(inflated_birm_rs, p)
})
output$eq_general <- renderUI(withMathJax(equations_general(ers, ars)))
output$eq_values <- renderUI({
withMathJax(equations_values(pars(), model(), ers, ars))
})
output$plot <- renderPlot(plot_inflated(model(), reference()))
output$summary <- renderTable({
r <- model()
out <- data.frame(
Quantity = c("P(Y = 0)", "P(0 < Y < 1)", "P(Y = 1)",
"E(Y | 0 < Y < 1)", "E(Y)"),
Value = c(r$p0, r$p_between, r$p1, r$mean_between, r$mean)
)
ref <- reference()
if (!is.null(ref)) {
out[["Without response styles"]] <-
c(ref$p0, ref$p_between, ref$p1, ref$mean_between, ref$mean)
}
out
}, digits = 3, align = "l")
})
}
# ---- Simulation tab -----------------------------------------------------------
sim_slider <- function(id, label, min, max, value, step) {
sliderInput(id, withMathJax(HTML(label)), min = min, max = max, value = value,
step = step)
}
simulation_tab_ui <- tabPanel(
"Simulation",
sidebarLayout(
sidebarPanel(
h4(tags$b("Person Parameters")),
sim_slider("sim_theta_mu", "\\(E(\\theta_{i})\\): expected value of the latent trait", -3, 3, 0, 0.1),
sim_slider("sim_theta_sd", "\\(SD(\\theta_{i})\\): standard deviation of the latent trait", 0, 3, 1, 0.1),
sim_slider("sim_ers_mu", "\\(E(\\eta_{i}^{ERS})\\): expected value of the ERS parameter", -1, 1, 0, 0.1),
sim_slider("sim_ers_sd", "\\(SD(\\eta_{i}^{ERS})\\): standard deviation of the ERS parameter", 0, 1, 0.3, 0.1),
sim_slider("sim_ars_mu", "\\(E(\\eta_{i}^{ARS})\\): expected value of the ARS parameter", -1, 1, 0, 0.1),
sim_slider("sim_ars_sd", "\\(SD(\\eta_{i}^{ARS})\\): standard deviation of the ARS parameter", 0, 1, 0.3, 0.1),
tags$hr(style = "margin: 20px 0; border: 1px solid gray;"),
h4(tags$b("Item Parameters")),
sim_slider("sim_delta", "\\(\\delta_{j}\\): item location", -3, 3, 0, 0.1),
sim_slider("sim_tau", "\\(\\tau_{j}\\): item dispersion parameter", 0, 5, 2.5, 0.1),
sim_slider("sim_kappa0", "\\(\\kappa_{0j}\\): lower endpoint threshold", -2, 6, 3, 0.1),
sim_slider("sim_kappa1", "\\(\\kappa_{1j}\\): upper endpoint threshold", -2, 6, 3, 0.1),
radioButtons("sim_x", withMathJax(HTML(txt$x)), selected = 1,
choiceNames = c("1: regular", "-1: reverse-scored"),
choiceValues = c(1, -1)),
tags$hr(style = "margin: 20px 0; border: 1px solid gray;"),
sliderInput("sim_n", "Number of persons", min = 100, max = 5000,
value = 1000, step = 100),
actionButton("sim_resample", "Draw a new sample")
),
mainPanel(
eq_title("Equations for Data Simulation"),
uiOutput("sim_eq_general"),
eq_title("Parameter Distributions"),
uiOutput("sim_eq_distributions"),
plotOutput("sim_plot", height = "450px")
)
)
)
simulation_tab_server <- function(input, output) {
seed <- reactiveVal(1)
observeEvent(input$sim_resample, seed(seed() + 1))
responses <- reactive({
validate(need(input$sim_kappa0 + input$sim_kappa1 > 0, kappa_message))
set.seed(seed())
simulate_responses(
n_persons = input$sim_n,
theta_mu = input$sim_theta_mu, theta_sd = input$sim_theta_sd,
ers_mu = input$sim_ers_mu, ers_sd = input$sim_ers_sd,
ars_mu = input$sim_ars_mu, ars_sd = input$sim_ars_sd,
delta = input$sim_delta, tau = input$sim_tau,
kappa0 = input$sim_kappa0, kappa1 = input$sim_kappa1,
x = as.numeric(input$sim_x)
)
})
output$sim_eq_general <- renderUI(withMathJax(equations_general(TRUE, TRUE)))
output$sim_eq_distributions <- renderUI({
withMathJax(paste0(
"$$\\theta_i \\sim \\mathcal{N}(", fmt(input$sim_theta_mu), ", ",
fmt(input$sim_theta_sd), "), \\quad ",
"\\eta^{ERS}_i \\sim \\mathcal{N}(", fmt(input$sim_ers_mu), ", ",
fmt(input$sim_ers_sd), "), \\quad ",
"\\eta^{ARS}_i \\sim \\mathcal{N}(", fmt(input$sim_ars_mu), ", ",
fmt(input$sim_ars_sd), ")$$"
))
})
output$sim_plot <- renderPlot(plot_simulation(responses()))
}
# ---- App ----------------------------------------------------------------------
ui <- navbarPage(
title = "Zero- and One-Inflated BIRM With Response Styles: Illustration",
theme = shinytheme("cerulean"),
header = withMathJax(),
model_tab_ui("base", "Inflated BIRM"),
model_tab_ui("full", "Inflated BIRM-RS", ers = TRUE, ars = TRUE, theta = 1),
simulation_tab_ui
)
server <- function(input, output, session) {
model_tab_server("base")
model_tab_server("full", ers = TRUE, ars = TRUE)
simulation_tab_server(input, output)
}
shinyApp(ui = ui, server = server)
Running the App Locally
The app is also available as an R script (app.R). It requires the packages shiny and shinythemes and can be started with shiny::runApp("app.R").
References
Molenaar, D., Cúri, M., & Bazán, J. L. (2022). Zero and one inflated item response theory models for bounded continuous data. Journal of Educational and Behavioral Statistics, 47(6), 693–735. https://doi.org/10.3102/10769986221108455
Noel, Y., & Dauvier, B. (2007). A beta item response model for continuous bounded responses. Applied Psychological Measurement, 31(1), 47–73. https://doi.org/10.1177/0146621605287691
Vollbracht, D., Lischetzke, T., & Henninger, M. (2026). Detecting response styles in visual analogue scales [Preprint]. PsyArXiv. https://doi.org/10.31234/osf.io/xteku_v2