Identifiability of a BLIM: Trade-off between parameters \(\beta_c\) and \(\pi_{ab}\)

The item set consists of three items, \(Q = \{a, b, c\}\), and the knowledge structure is \(\mathcal{K}^{02} = \{\emptyset, \{a, b\}, Q\}\). The parameter vector is \(\theta' = (\beta_a, \beta_b, \beta_c, \pi_\emptyset, \pi_{ab})\), not allowing for guessing.

For the BLIM with knowledge structure \(\mathcal{K}^{02}\) and parameter vector \(\theta\) the parameters \(\beta_c\) and \(\pi_{ab}\) are not identifiable. Therefore, different pairs of values for these parameters predict the same response frequencies (plot on the right). The relation of \(\beta_c\) and \(\pi_{ab}\) is described by the indifference curve in the plot below.

The values for the identifiable parameters are \(\beta_a = 0.2\), \(\beta_b = 0.2\), and \(\pi_{\emptyset}= 0.4\).

Choose indifference curve

Change parameter value

Relation of \(\beta_c\) and \(\pi_{ab}\)

Predicted response frequencies (N = 100)
show with app 
# calculate beta_c from pi_ab
calc_beta_c <- function(pi.ab, pi.ab.0, beta.c.0, pi.empty) {
    (-pi.ab + pi.ab.0 + beta.c.0 * (1 - pi.empty - pi.ab.0)) /
    (-pi.ab - pi.empty + 1)
}

# calculate pi_ab from beta_c
calc_pi_ab <- function(beta.c, pi.ab.0, beta.c.0, pi.empty) {
    ((beta.c.0 - beta.c) * (1 - pi.empty) + (1 - beta.c.0) *
    pi.ab.0) / (1 - beta.c)
}

# Outer product with vector function
# expand.outer joins functionality of "expand.grid" and "outer", so that
# a vector function can be applied, values of which are then stored in columns.
# Combinations of "x" and "y" are expanded into vectors of length n*m, where
# n = length(x), m = length(y) and this ordering is preserved also in 'values'.
# Matrix of values (list item 'values') and expanded variables (list items 'x','y') are returned.
expand.outer <- function(x, y, vecfun) {
    xy.pairs <- expand.grid(x=x, y=y, KEEP.OUT.ATTRS = FALSE)
    x.exp    <- xy.pairs$x
    y.exp    <- xy.pairs$y
    list(values=matrix(vecfun(x.exp,y.exp), nrow=2, byrow=TRUE),
	 x=x.exp, y=y.exp)
}

# vector field plot function
# grid.points can be defined for both axes at once or separately
plotVectorField <- function(vecfun, xlim, ylim, grid.points) {
    gp <- if (length(grid.points) > 1) grid.points else rep(grid.points, 2)
    maxlength <- c(diff(xlim), diff(ylim)) / (gp - 1) * 0.9

    # prepare data
    x0 <- seq(xlim[1], xlim[2], length=gp[1])
    y0 <- seq(ylim[1], ylim[2], length=gp[2])
    xy.data <- expand.outer(x0, y0, vecfun)
    x0 <- xy.data$x
    y0 <- xy.data$y
    dx <- xy.data$values[1,]
    dy <- xy.data$values[2,]

    # scale
    k <- min(maxlength / c(max(abs(dx)), max(abs(dy))))
    x1 <- x0 + k * dx
    y1 <- y0 + k * dy

    # plot
    plot.default(extendrange(r=range(x0, x1), f=0.067),
		 extendrange(r=range(y0, y1), f=0.12),
                 xlab=expression(beta[c]), ylab=expression(pi[ab]),
		 type="n", frame.plot=FALSE)
    arrows(x0,y0,x1,y1,length = 0.05, angle = 20, code = 2)
}

# prediction function of example K^02
# calculate predictions for response pattern frequencies from BLIM parameters
# see Heller, J. (2016) Identifiability in probabilistic knowledge structures,
# Journal of Mathematical Psychology,
# http://dx.doi.org/10.1016/j.jmp.2016.07.008, p. 5
predictionFunction <- function(beta.a, beta.b, beta.c, pi.empty, pi.ab) {
    pi.abc <- 1 - pi.ab - pi.empty
    c(phi.empty = pi.empty + beta.a*beta.b*beta.c*pi.abc + beta.a*beta.b*pi.ab,
      phi.a     = (1 - beta.a)*beta.b*beta.c*pi.abc +
                  (1 - beta.a)*beta.b*pi.ab,
      phi.b     = beta.a*(1 - beta.b)*beta.c*pi.abc +
                  beta.a*(1 - beta.b)*pi.ab,
      phi.c     = beta.a*beta.b*(1 - beta.c)*pi.abc,
      phi.ab    = (1 - beta.a)*(1 - beta.b)*beta.c*pi.abc +
                  (1 - beta.a)*(1 - beta.b)*pi.ab,
      phi.ac    = (1 - beta.a)*beta.b*(1 - beta.c)*pi.abc,
      phi.bc    = beta.a*(1 - beta.b)*(1 - beta.c)*pi.abc
     )
}
library(shiny)

source("helpers.R")

shinyServer(function(input, output) {
  # set fixed parameters
  pi.ab.0 <- 0
  pi.empty <- .4
  beta.a <- .2
  beta.b <-  .2
  beta.c.default <- .33
  pi.ab.default <- .51

  output$ui_slider_beta_c <- renderUI({
    pi.ab <- ifelse(is.null(input$pi_ab), pi.ab.default, input$pi_ab)
    beta.c.0 <- input$beta_c_0
    beta.c.start <- calc_beta_c(pi.ab, pi.ab.0, beta.c.0, pi.empty)
    sliderInput("beta_c", label="", min=0, max=beta.c.0,
                value=beta.c.start, step=.01, animate=animationOptions(200))
  })

  output$ui_slider_pi_ab <- renderUI({
    beta.c <- ifelse(is.null(input$beta_c), beta.c.default, input$beta_c)
    beta.c.0 <- input$beta_c_0
    max <- round(beta.c.0 * (1 - pi.empty) + (1 - beta.c.0) * pi.ab.0,
                 digits=3)
    pi.ab.start <- calc_pi_ab(beta.c, pi.ab.0, beta.c.0, pi.empty)
    sliderInput("pi_ab", label="", min=0, max=max, step=.01,
                value=pi.ab.start)
  })

  parInput <- reactive({
    beta.c.0 <- input$beta_c_0
    if (input$tabs == "beta_c") {
        beta.c <- ifelse(is.null(input$beta_c),
                         beta.c.default,
                         input$beta_c)
        pi.ab <- round(calc_pi_ab(beta.c, pi.ab.0, beta.c.0, pi.empty),
                       digits=2)
    } else if (input$tabs == "pi_ab") {
        pi.ab <- ifelse(is.null(input$pi_ab),
                        calc_pi_ab(input$beta_c, pi.ab.0, beta.c.0, pi.empty),
                        input$pi_ab)
        beta.c <- round(calc_beta_c(pi.ab, pi.ab.0, beta.c.0, pi.empty),
                        digits=2)
    }
    list(beta.c=beta.c, pi.ab=pi.ab, beta.c.0=beta.c.0)
  })

  output$text_beta_pi <- renderUI({
    HTML("<i>&beta;<sub>c</sub></i> = ", parInput()$beta.c, " and ",
         "<i>&pi;<sub>ab</sub></i> = ", parInput()$pi.ab)
  })

  output$note <- renderUI({
    if (parInput()$beta.c >= .5) {
        note <- "Note that <i>&beta;<sub>c</sub></i> &le; 0.5 is not reasonable."
    } else note <- ""
    HTML(note)
  })

  # set parameters for plotting indifference curve
  ngp <- c(10, 10)
  xoffset <- 0.05
  yoffset <- 0.05 * (1 - pi.empty)
  xstep <- (1 - 2 * xoffset) / (ngp[1] - 1)

  output$plot <- renderPlot({
    par(cex.lab=1.2, mar=c(4.1, 4.0, 0, 0), pty="s")
    plotVectorField(
                    vecfun = function(x1, x2) {
                      c(-(1 - x1) / (1 - pi.empty - x2), 1 + 0 * x2)
                    },
                    xlim = c(0 + xoffset, 1 - xoffset),
                    ylim = c(0 + yoffset, 1 - pi.empty - yoffset),
                    grid.points = ngp
                    )
    axis(1, seq(0.0, 1.0, 0.1))
    axis(2, seq(0.0, 1 - pi.empty, 0.1))
    # insert curves into plot
    beta.c.0 <- parInput()$beta.c.0
    curve(calc_pi_ab(x, pi.ab.0, beta.c.0, pi.empty),
            xlim=c(0, (pi.ab.0 + beta.c.0 * (1 - pi.empty - pi.ab.0)) /
            (1 - pi.empty)),
            col="blue", add=TRUE)

    # Draw point
    points(parInput()$beta.c, parInput()$pi.ab, pch=16, cex=2, col="blue")
  })

  output$predictions_plot <- renderPlot({
    pred <- predictionFunction(beta.a, beta.b, parInput()$beta.c, pi.empty,
                               parInput()$pi.ab)
    pred <- c(pred, phi.abc = 1 - sum(pred)) * 100
    barplot(pred,
            horiz = TRUE,
            names.arg = c("0", "a", "b", "c", "ab", "ac", "bc", "abc"),
            cex.names = 1.3,
            las = 2,
            axes = FALSE,
            col = "lightblue",
            xlim = c(0, max(pred)),
            border = NA
            )
    axis(side = 3, cex.axis = 1.3)
  })

})

# TO DOs
library(shiny)

shinyUI(fluidPage(
  titlePanel("Identifiability of a BLIM: Trade-off between parameters
             \\(\\beta_c\\) and \\(\\pi_{ab}\\)"),
  withMathJax(),

  p("The item set consists of three items, \\(Q = \\{a, b, c\\}\\), and the
    knowledge structure is \\(\\mathcal{K}^{02} = \\{\\emptyset, \\{a, b\\},
    Q\\}\\). The parameter vector is \\(\\theta' = (\\beta_a, \\beta_b,
    \\beta_c, \\pi_\\emptyset, \\pi_{ab})\\), not allowing for guessing."),

  p("For the BLIM with knowledge structure \\(\\mathcal{K}^{02}\\) and
    parameter vector \\(\\theta\\) the parameters \\(\\beta_c\\) and
    \\(\\pi_{ab}\\) are not identifiable.  Therefore, different pairs of
    values for these parameters predict the same response frequencies
    (plot on the right).  The relation of \\(\\beta_c\\) and \\(\\pi_{ab}\\)
    is described by the indifference curve in the plot below."),

  p("The values for the identifiable parameters are
    \\(\\beta_a         = 0.2\\),
    \\(\\beta_b         = 0.2\\), and
    \\(\\pi_{\\emptyset}= 0.4\\)."
    ),

  fluidRow(
    column(3,
          h4("Choose indifference curve"),
          sliderInput("beta_c_0", label="",
                      min=0, max=.99, value=.9, step=.05),
          h4("Change parameter value"),
          tabsetPanel(id="tabs",
                      tabPanel(title=HTML("$$\\beta_c$$"),
                               value="beta_c",
                               uiOutput("ui_slider_beta_c")
                      ),
                      tabPanel(title=HTML("$$\\pi_{ab}$$"),
                               value="pi_ab",
                               uiOutput("ui_slider_pi_ab")
                      )),
	  htmlOutput("note"),
	  tags$head(tags$style("#note{color: gray; font-size: 12px;
			       font-style: italic;}"))
    ),
    column(4,
          h4("Relation of \\(\\beta_c\\) and \\(\\pi_{ab}\\)"),
	  htmlOutput("text_beta_pi"),
          plotOutput("plot")
    ),
    column(4,
           h4("Predicted response frequencies (N = 100)"),
           plotOutput("predictions_plot")
    )
  )
))