# app.R
# Visualisation of Parameter Estimation
#
# Enter response frequencies and visualize parameter estimates
#
# Claudia Glemser, last edited: 26/Jan/17
library(shiny)
library(shinydashboard)
library(pks)
library(xtable)
library(igraph)
library(markdown)
#question
{# 10 11 9 3 4
questions <- data.frame(
q1 = c("A bag contains 5-cent, 10-cent, and 20-cent coins. The probability of drawing a 5-cent coin is 0.20, that of drawing a 10-cent coin is 0.45, and that of drawing a 20-cent coin is 0.35. What is the probability that the coin randomly drawn is a 5-cent coin or a 20-cent coin?"),
q2 = c("In a school, 40% of the pupils are boys and 80% of the pupils are right-handed. Suppose that gender and handedness are independent. What is the probability of randomly selecting a right-handed boy?"),
q3 = c("Given a standard deck containing 32 different cards, what is the probability of drawing a 4 in a black suit?"),
q4 = c("A box contains marbles that are red or yellow, small or large. The probability of drawing a red marble is 0.70, the probability of drawing a small marble is 0.40. Suppose that the color of the marbles is independent of their size. What is the probability of randomly drawing a small marble that is not red?"),
q5 = c("In a garage there are 50 cars. 20 are black and 10 are diesel powered. Suppose that the color of the cars is independent of the kind of fuel. What is the probability that a randomly selected car is not black and it is diesel powered?"))
plotheadline <- c("Your probabilites of knowledge states: P(K|R)")
}
eta <- 0.25
beta <- 0.10
waiplot_p <- function(a,p){
n <- ncol(a)
b = diag(0,n)
for(i in 1:n){
for(j in 1:n){
if(sum(a[,i]*a[,j])==sum(a[,i])) b[i,j]=1
}
}
diag(b)<-0
d <- b
for(i in 1:n){
for(j in c(1:n)[-i]){
if(b[j,i]==1) d[j,]=d[j,]*(1-b[i,])
}
}
ed <- NULL
for(i in 1:n) for(j in 1:n) if(d[i,j]==1) ed <- c(ed,i,j)
g1 <- graph( edges=ed, n=n, directed=T )
l <- list("0")
for(i in 2:(n-1)) l[[i]] <- paste(c(c("a","b","c","d","e")[a[,i]*c(1:5)]),collapse = '')
l[[n]] <- c("Q")
V(g1)$label <- l
coord = layout_with_sugiyama(g1)$layout
E(g1)$color <- 'black'
V(g1)$color <- terrain.colors(1001)[1001-1000*p]
plot(g1,layout=-coord,vertex.frame.color="white",vertex.size=35)
legend( x="right",
legend=c(10:0)/10,
col=terrain.colors(1001)[c(1+100*c(0:10))],
pch = rep(15,11))
}
waiplot <- function(a){
n <- ncol(a)
b = diag(0,n)
for(i in 1:n){
for(j in 1:n){
if(sum(a[,i]*a[,j])==sum(a[,i])) b[i,j]=1
}
}
diag(b)<-0
d <- b
for(i in 1:n){
for(j in c(1:n)[-i]){
if(b[j,i]==1) d[j,]=d[j,]*(1-b[i,])
}
}
ed <- NULL
for(i in 1:n) for(j in 1:n) if(d[i,j]==1) ed <- c(ed,i,j)
g1 <- graph( edges=ed, n=n, directed=T )
l <- list("0")
for(i in 2:(n-1)) l[[i]] <- paste(c(c("a","b","c","d","e")[a[,i]*c(1:5)]),collapse = '')
l[[n]] <- c("Q")
V(g1)$label <- l
coord = layout_with_sugiyama(g1)$layout
E(g1)$color <- 'black'
V(g1)$color <- 'orange'
plot(g1,layout=-coord,vertex.frame.color="white",vertex.size=30)
}
Ks1.list <- c("{a}" = "10000", "{b}" = "01000",
"{c}" = "00100", "{d}" = "00010",
"{e}" = "00001", "{a,b}" = "11000",
"{a,c}" = "10100", "{a,d}" = "10010",
"{a,e}" = "10001", "{b,c}" = "01100",
"{b,d}" = "01010", "{b,e}" = "01001",
"{c,d}" = "00110", "{c,e}" = "00101",
"{d,e}" = "00011")
Ks2.list <- c("{a,b,c}" = "11100","{a,b,d}" = "11010","{a,b,e}" = "11001",
"{a,c,d}" = "10110","{a,c,e}" = "10101","{a,d,e}" = "10011",
"{b,c,d}" = "01110","{b,c,e}" = "01101","{b,d,e}" = "01011",
"{c,d,e}" = "00111","{a,b,c,d}" = "11110","{a,b,c,e}" = "11101",
"{a,b,d,e}" = "11011","{a,c,d,e}" = "10111",
"{b,c,d,e}" = "01111"
)
Ks1.model.list <- c("01000", "10000", "01010", "01100",
"11000")
Ks2.model.list <- c("11100", "11010", "01111")
prob.model1 <- c(1.0, 1.0, 1.0, 0.0, 0.0, 0.0, 1.0, 0.0,
0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 0.0, 0.0,
1.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,
0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 1.0)
prob.model <- prob.model1 / sum(prob.model1)
sets1 <- c("00000", "10000", "01000", "00100", "00010", "00001", "11000", "10100",
"10010", "10001", "01100", "01010", "01001", "00110", "00101", "00011",
"11100", "11010", "11001", "10110", "10101", "10011", "01110", "01101",
"01011", "00111", "11110", "11101", "11011", "10111", "01111", "11111")
sets2 <- c("{}", "{a}", "{b}", "{c}", "{d}", "{e}", "{a, b}", "{a, c}",
"{a, d}", "a, e}", "{b, c}", "b, d}", "{b, e}", "{c, d}", "{c, e}", "{d, e}",
"{a, b, c}", "{a, b, d}", "{a, b, e}", "{a, c, d}", "{a, c, e}", "{a, d, e}", "{b, c, d}", "{b, c, e}",
"{b, d, e}", "{c, d, e}", "{a, b, c, d}", "{a, b, c, e}", "{a, b, d, e}", "{a, c, d, e}", "{b, c, d, e}", "{a, b, c, d, e}")
############### UI ###############
ui <- dashboardPage(
skin="green",
#dashboardHeader
{dashboardHeader(
title = "Probabilistic Knowledge Assessment",
tags$li(a(href = 'https://tquant.eu/',
img(src = 'logo_TquanT.jpg',
title = "TquanT Home", height = "30px"),
style = "padding-top:10px; padding-bottom:10px;"),
class = "dropdown"),
titleWidth = "45%"
)},
#dashboardSidebar
{dashboardSidebar(
sidebarMenu(
menuItem("Introduction", tabName = "theory",
icon = icon("info-circle")),
menuItem("Choose your Structure", tabName = "turn", icon = icon("pencil-square-o")),
menuItem("Questions", tabName = "quiz", icon = icon("check-square-o")) # question-circle-o
)
)},
#dashboardBody
{dashboardBody(skin="blue",
tabItems(
#tabItems
{tabItem(tabName = "theory",
tabsetPanel(
#tabPanel
{tabPanel("Welcome to the World of Knowledge",br(),br(),
fluidPage(
# includeScript("../../../Matomo-tquant.js"),
fluidRow(
column(7,
img(src="webhomes-brain-gear-470x371.png", height = "430", width="500"),
br(),
br(),
br()
),
column(5,
box(title=h4("Development Team:"),
solidHeader = TRUE,
status = "info",
width = '13',
h4(img(src="amsterdam_logo.png", width = "50"),
" Jessica Loke"),
h4(img(src="tuebingen_logo.png", width = "50"),
" Martin Losert"),
h4(img(src="madrid_logo.png", width = "50"),
" David de Segovia"),
h4(img(src="leuven_logo.png", width="50"),
" Wai Wong"),
h4(img(src="debrecen-logo.png", width = "50"),
" Chris Yndgaard"),
h4("Extended by:"),
h4(img(src="LogoUniGraz.png", width = "50"),
" Cord Hockemeyer")
))
)
)
)},
#66tabPanel
{tabPanel("Knowledge Space Theory",
#HTML
{HTML(
"<h3 align ='center'><b>Knowledge Space Theory:
<br>
Estimating Knowledge Structure</b></h3>
<br>
<div style=\"text-indent: 40px\">
In mathematical psychology, a <i><b>knowledge space</b></i> is a combinatorial structure
describing the possible <i><b>states of knowledge</i></b> of a human learner.
</div>
<br><ul>
Let's look at a simple analogy -
<br>
<br>"
)},
div(tags$img(src="township.jpg", width="300px", height="300px"), style="text-align:center;"),
tags$br(),
tags$br(),
{HTML("Imagine the town you live in as a complete domain of knowledge, if you know every part of the town,
you have a <i><b>knowledge state</b></i> which covers the complete domain of knowledge. But, if you only know the street where you live in;
then, you have a <i><b>knowledge state</i></b> which only covers a part of the complete domain - highlighted in yellow now.
<br>
<br>
")},
div(tags$img(src="townshiphighlight.jpg", width="300px", height="300px"), style="text-align:center;"),
tags$br(),
tags$br(),
{HTML("By identifying the user's <b><i>knowledge states</b></i>, we can understand his/her knowledge boundaries.
In the illustration above, you can imagine the boundary to be the yellow circle.
Within educational settings, this is helpful because we can then find out what the user knows
and does not know.
<br>
<br>
To estimate the user's <b><i>knowledge state</b></i>, we use a probabilistic approach by relating
(1) the observed data to (2) all the possible <b><i>knowledge states</b></i>.
<br>
<br>
In this application, we want to demonstrate this process by allowing you to
(1) build a <b><i>knowledge structure on elementary probability theory</b></i>, and (2) complete a quiz to estimate your probable <b><i>knowledge states</b></i>.
")},
tags$head(tags$style(HTML(
"table, th, td {
border: 1px solid black;
border-collapse: collapse;
}
th {
text-align: center;
}
th, td {
padding: 10px;
}
table#t01 th {
background-color: #367fa9;
color: white;
}")))
)}
)
)},
tabItem(tabName = "turn",
tabsetPanel(
# TABPANEL OUTLINE
{tabPanel("Outline",
div(tags$img(src="maxresdefault.jpg", width="600px", height="300px"), style="text-align:left;"),
HTML(
"<h5 align='left'>
<br>
<br>
In this application, you have two options:
<br><br>
<li>using a knowledge structure observed from a previous sample, or </li>
<br>
<li>building your own knowledge structure.</li>
<br><br>
Then, you can simulate being a new student by answering a quiz.
<br><br>
After each of your answers, we will update the probabilities of your possible knowledge states.
</h5>")
)},
#TABPANEL YOUR FREAKING STRUCTURE
{tabPanel("Your Structure",
br(), HTML(
"<h5 align='left'>
These are all the possible response patterns.
<br><br>
As a default structure, we have checked the patterns which belong the knowledge structure observed from a previous
classroom sample. Both the empty set and the Q (full) set states have already been included.
<br><br>
You can use the one available, or create your own.
</h5>
<h4>Don't forget to press the 'Done' button when you
are finished</h4>"),
br(),
#fluidRow
{fluidRow(
#column
{column(4,
#fluidRow
{fluidRow(
#column
{column(3,checkboxGroupInput("Ks1", NULL, Ks1.list, selected = Ks1.model.list))},
#column
{column(3,checkboxGroupInput("Ks2", NULL, Ks2.list, selected = Ks2.model.list))}
)}
)},
#column
{column(8,
plotOutput("plot.KS")
)}
)},
fluidRow(
column(10,
HTML("Please note that the empty set (marked by 0) and the full item set Q are always contained."),
offset = 1
)
),
#fluidRow
{fluidRow(
column(2,
br(),
actionButton("clearall", "Clear all")
),
column(2,
br(),
actionButton("selectall", "Select all")
),
column(2,
br(),
actionButton("defaultmodel", "Default model")
)
)},
column(2,
br(),
actionButton("KSdone", "Done", #icon("paper-plane"),
style="color: #ffffff; background-color: #003399; border-color: #001133")
)
)}
)
),
tabItem(tabName = "quiz",
tabsetPanel(
tabPanel("Outline",
includeHTML("www/quizOutline.html")),
tabPanel("Quiz",
fluidRow(
"Select the probabilities for careless errors and lucky guesses
which influence the strength of the probability update.",
style = "background-color: #f4fff4;"
),
fluidRow(
column(6, sliderInput("beta",
HTML("Careless error probability β"),
0, 0.49, beta, 0.01)),
column(6, sliderInput("eta",
HTML("Lucky guess probabilty η"),
0, 0.49, eta, 0.01)),
style = "background-color: #f4fff4;"
),
conditionalPanel(condition = "output.maxProbK <= 0.5", h3(textOutput("question"))),
#Question a
{conditionalPanel(condition = "output.question == 'Question a'",
fluidPage(
fluidRow(
column(4,
conditionalPanel(condition = "output.maxProbK <= 0.5",
h4("Please answer the following questions"), br(),
selectInput("q1", questions$q1, # question b1
choices = c(' ' = 'empty',
'0.55' = 'correct',
'0.33' = 'choice1',
'0.45' = 'choice2',
'0.65' = 'choice3'),
width = '100%')
),
conditionalPanel(condition = "output.maxProbK > 0.5",
h3("The Assessment is completed."))
),
column(8,h3(plotheadline),plotOutput("outplot.1"))
))
)},
#Question b
{conditionalPanel(condition = "output.question == 'Question b'",
fluidPage(
fluidRow(
column(4,
conditionalPanel(condition = "output.maxProbK <= 0.5",
br(), br(), br(),
selectInput("q2", questions$q2, # question b1
choices = c(' ' = 'empty',
'0.38' = 'choice2',
'0.27' = 'choice1',
'0.32' = 'correct',
'0.25' = 'choice3'),
width = '100%')
),
conditionalPanel(condition = "output.maxProbK > 0.5",
h3("The Assessment is completed."))
),
column(8,
h3(plotheadline),
plotOutput("outplot.2"))
)))},
#Question c
{conditionalPanel(condition = "output.question == 'Question c'",
fluidPage(
fluidRow(
column(4,
conditionalPanel(condition = "output.maxProbK <= 0.5",
br(), br(), br(),
selectInput("q3", questions$q3, # question b1
choices = c(' ' = 'empty',
'6/32' = 'choice1',
'4/32' = 'choice2',
'1/32' = 'choice3',
'2/32' = 'correct'),
width = '100%')
),
conditionalPanel(condition = "output.maxProbK > 0.5",
h3("The Assessment is completed."))
),
column(8,
h3(plotheadline),
plotOutput("outplot.3"))
)))},
#Question d
{conditionalPanel(condition = "output.question == 'Question d'",
fluidPage(
fluidRow(
column(4,
conditionalPanel(condition = "output.maxProbK <= 0.5",
br(), br(), br(),
selectInput("q4", questions$q4, # question b1
choices = c(' ' = 'empty',
'0.12' = 'correct',
'0.09' = 'choice1',
'0.22' = 'choice2',
'0.18' = 'choice3'),
width = '100%')
),
conditionalPanel(condition = "output.maxProbK > 0.5",
h3("The Assessment is completed."))
),
column(8,
h3(plotheadline),
plotOutput("outplot.4")))
))},
#Question e
{conditionalPanel(condition = "output.question == 'Question e'",
fluidPage(
fluidRow(
column(4,
conditionalPanel(condition = "output.maxProbK <= 0.5",
br(), br(), br(),
selectInput("q5", questions$q5, # question b1
choices = c(' ' = 'empty',
'0.08' = 'choice1',
'0.12' = 'correct',
'0.16' = 'choice2',
'0.04' = 'choice3'),
width = '100%')
),
conditionalPanel(condition = "output.maxProbK > 0.5",
h3("The Assessment is completed."))
),
column(8,
h3(plotheadline),
plotOutput("outplot.5")))
))},
fluidRow(
column(8, offset = 4,
h4(textOutput("assessment")),
h4(textOutput("assessmentlist"))
)
)
)
))
))}
)
############### SERVER ###############
server <- function(input, output, session){
probac <- reactiveValues(val = c(eta, 1-beta, eta, eta, eta, eta, 1-beta, 1-beta,
1-beta, 1-beta, eta, eta, eta, eta, eta, eta,
1-beta, 1-beta, 1-beta, 1-beta, 1-beta, 1-beta, eta, eta,
eta, eta, 1-beta, 1-beta, 1-beta, 1-beta, eta, 1-beta))
probaf <- reactiveValues(val = 1-c(eta, 1-beta, eta, eta, eta, eta, 1-beta, 1-beta,
1-beta, 1-beta, eta, eta, eta, eta, eta, eta,
1-beta, 1-beta, 1-beta, 1-beta, 1-beta, 1-beta, eta, eta,
eta, eta, 1-beta, 1-beta, 1-beta, 1-beta, eta, 1-beta))
probbc <- reactiveValues(val = c(eta, eta, 1-beta, eta, eta, eta, 1-beta, eta,
eta, eta, 1-beta, 1-beta, 1-beta, eta, eta, eta,
1-beta, 1-beta, 1-beta, eta, eta, eta, 1-beta, 1-beta,
1-beta, eta, 1-beta, 1-beta, 1-beta, eta, 1-beta, 1-beta))
probbf <- reactiveValues(val = 1-c(eta, eta, 1-beta, eta, eta, eta, 1-beta, eta,
eta, eta, 1-beta, 1-beta, 1-beta, eta, eta, eta,
1-beta, 1-beta, 1-beta, eta, eta, eta, 1-beta, 1-beta,
1-beta, eta, 1-beta, 1-beta, 1-beta, eta, 1-beta, 1-beta))
probcc <- reactiveValues(val = c(eta, eta, eta, 1-beta, eta, eta, eta, 1-beta,
eta, eta, 1-beta, eta, eta, 1-beta, 1-beta, eta,
1-beta, eta, eta, 1-beta, 1-beta, eta, 1-beta, 1-beta,
eta, 1-beta, 1-beta, 1-beta, eta, 1-beta, 1-beta, 1-beta))
probcf <- reactiveValues(val = 1-c(eta, eta, eta, 1-beta, eta, eta, eta, 1-beta,
eta, eta, 1-beta, eta, eta, 1-beta, 1-beta, eta,
1-beta, eta, eta, 1-beta, 1-beta, eta, 1-beta, 1-beta,
eta, 1-beta, 1-beta, 1-beta, eta, 1-beta, 1-beta, 1-beta))
probdc <- reactiveValues(val = c(eta, eta, eta, eta, 1-beta, eta, eta, eta,
1-beta, eta, eta, 1-beta, eta, 1-beta, eta, 1-beta,
eta, 1-beta, eta, 1-beta, eta, 1-beta, 1-beta, eta,
1-beta, 1-beta, 1-beta, eta, 1-beta, 1-beta, 1-beta, 1-beta))
probdf <- reactiveValues(val = 1-c(eta, eta, eta, eta, 1-beta, eta, eta, eta,
1-beta, eta, eta, 1-beta, eta, 1-beta, eta, 1-beta,
eta, 1-beta, eta, 1-beta, eta, 1-beta, 1-beta, eta,
1-beta, 1-beta, 1-beta, eta, 1-beta, 1-beta, 1-beta, 1-beta))
probec <- reactiveValues(val = c(eta, eta, eta, eta, eta, 1-beta, eta, eta,
eta, 1-beta, eta, eta, 1-beta, eta, 1-beta, 1-beta,
eta, eta, 1-beta, eta, 1-beta, 1-beta, eta, 1-beta,
1-beta, 1-beta, eta, 1-beta, 1-beta, 1-beta, 1-beta, 1-beta))
probef <- reactiveValues(val = 1-c(eta, eta, eta, eta, eta, 1-beta, eta, eta,
eta, 1-beta, eta, eta, 1-beta, eta, 1-beta, 1-beta,
eta, eta, 1-beta, eta, 1-beta, 1-beta, eta, 1-beta,
1-beta, 1-beta, eta, 1-beta, 1-beta, 1-beta, 1-beta, 1-beta))
observeEvent(input$beta, {
probac$val <- c(input$eta, 1-input$beta, input$eta, input$eta, input$eta,
input$eta, 1-input$beta, 1-input$beta,
1-input$beta, 1-input$beta, input$eta, input$eta, input$eta,
input$eta, input$eta, input$eta,
1-input$beta, 1-input$beta, 1-input$beta, 1-input$beta, 1-input$beta,
1-input$beta, input$eta, input$eta,
input$eta, input$eta, 1-input$beta, 1-input$beta, 1-input$beta,
1-input$beta, input$eta, 1-input$beta)
probaf$val <- 1-probac$val
probbc$val <- c(input$eta, input$eta, 1-input$beta, input$eta, input$eta,
input$eta, 1-input$beta, input$eta,
input$eta, input$eta, 1-input$beta, 1-input$beta, 1-input$beta,
input$eta, input$eta, input$eta,
1-input$beta, 1-input$beta, 1-input$beta, input$eta, input$eta,
input$eta, 1-input$beta, 1-input$beta,
1-input$beta, input$eta, 1-input$beta, 1-input$beta, 1-input$beta,
input$eta, 1-input$beta, 1-input$beta)
probbf$val <- 1-probbc$val
probcc$val <- c(input$eta, input$eta, input$eta, 1-input$beta, input$eta,
input$eta, input$eta, 1-input$beta,
input$eta, input$eta, 1-input$beta, input$eta, input$eta,
1-input$beta, 1-input$beta, input$eta,
1-input$beta, input$eta, input$eta, 1-input$beta, 1-input$beta,
input$eta, 1-input$beta, 1-input$beta,
input$eta, 1-input$beta, 1-input$beta, 1-input$beta, input$eta,
1-input$beta, 1-input$beta, 1-input$beta)
probcf$val <- 1-probcc$val
probdc$val <- c(input$eta, input$eta, input$eta, input$eta, 1-input$beta,
input$eta, input$eta, input$eta,
1-input$beta, input$eta, input$eta, 1-input$beta, input$eta,
1-input$beta, input$eta, 1-input$beta,
input$eta, 1-input$beta, input$eta, 1-input$beta, input$eta,
1-input$beta, 1-input$beta, input$eta,
1-input$beta, 1-input$beta, 1-input$beta, input$eta, 1-input$beta,
1-input$beta, 1-input$beta, 1-input$beta)
probdf$val <- 1-probdc$val
probec$val <- c(input$eta, input$eta, input$eta, input$eta, input$eta,
1-input$beta, input$eta, input$eta,
input$eta, 1-input$beta, input$eta, input$eta, 1-input$beta,
input$eta, 1-input$beta, 1-input$beta,
input$eta, input$eta, 1-input$beta, input$eta, 1-input$beta,
1-input$beta, input$eta, 1-input$beta,
1-input$beta, 1-input$beta, input$eta, 1-input$beta,
1-input$beta, 1-input$beta, 1-input$beta, 1-input$beta)
probef$val <- 1-probec$val
})
observeEvent(input$eta, {
probac$val <- c(input$eta, 1-input$beta, input$eta, input$eta, input$eta,
input$eta, 1-input$beta, 1-input$beta,
1-input$beta, 1-input$beta, input$eta, input$eta, input$eta,
input$eta, input$eta, input$eta,
1-input$beta, 1-input$beta, 1-input$beta, 1-input$beta, 1-input$beta,
1-input$beta, input$eta, input$eta,
input$eta, input$eta, 1-input$beta, 1-input$beta, 1-input$beta,
1-input$beta, input$eta, 1-input$beta)
probaf$val <- 1-probac$val
probbc$val <- c(input$eta, input$eta, 1-input$beta, input$eta, input$eta,
input$eta, 1-input$beta, input$eta,
input$eta, input$eta, 1-input$beta, 1-input$beta, 1-input$beta,
input$eta, input$eta, input$eta,
1-input$beta, 1-input$beta, 1-input$beta, input$eta, input$eta,
input$eta, 1-input$beta, 1-input$beta,
1-input$beta, input$eta, 1-input$beta, 1-input$beta, 1-input$beta,
input$eta, 1-input$beta, 1-input$beta)
probbf$val <- 1-probbc$val
probcc$val <- c(input$eta, input$eta, input$eta, 1-input$beta, input$eta,
input$eta, input$eta, 1-input$beta,
input$eta, input$eta, 1-input$beta, input$eta, input$eta,
1-input$beta, 1-input$beta, input$eta,
1-input$beta, input$eta, input$eta, 1-input$beta, 1-input$beta,
input$eta, 1-input$beta, 1-input$beta,
input$eta, 1-input$beta, 1-input$beta, 1-input$beta, input$eta,
1-input$beta, 1-input$beta, 1-input$beta)
probcf$val <- 1-probcc$val
probdc$val <- c(input$eta, input$eta, input$eta, input$eta, 1-input$beta,
input$eta, input$eta, input$eta,
1-input$beta, input$eta, input$eta, 1-input$beta, input$eta,
1-input$beta, input$eta, 1-input$beta,
input$eta, 1-input$beta, input$eta, 1-input$beta, input$eta,
1-input$beta, 1-input$beta, input$eta,
1-input$beta, 1-input$beta, 1-input$beta, input$eta, 1-input$beta,
1-input$beta, 1-input$beta, 1-input$beta)
probdf$val <- 1-probdc$val
probec$val <- c(input$eta, input$eta, input$eta, input$eta, input$eta,
1-input$beta, input$eta, input$eta,
input$eta, 1-input$beta, input$eta, input$eta, 1-input$beta,
input$eta, 1-input$beta, 1-input$beta,
input$eta, input$eta, 1-input$beta, input$eta, 1-input$beta,
1-input$beta, input$eta, 1-input$beta,
1-input$beta, 1-input$beta, input$eta, 1-input$beta,
1-input$beta, 1-input$beta, 1-input$beta, 1-input$beta)
probef$val <- 1-probec$val
})
probK <- reactiveValues(val = prob.model)
probMaxK <- reactiveValues(val = max(prob.model))
probQ <- reactiveValues(val = rep(0.0, 5))
observeEvent(probK$val, {
t1 <- sum(probK$val[c(2, 7, 8, 9, 10, 17, 18, 19, 20, 21, 22, 27, 28, 29, 30, 32)])
t2 <- sum(probK$val[c(3, 7, 11, 12, 13, 17, 18, 19, 23, 24, 25, 27, 28, 29, 31, 32)])
t3 <- sum(probK$val[c(4, 8, 11, 14, 15, 17, 20, 21, 23, 24, 26, 27, 28, 30, 31, 32)])
t4 <- sum(probK$val[c(5, 9, 12, 14, 16, 18, 20, 22, 23, 25, 26, 27, 29, 30, 31, 32)])
t5 <- sum(probK$val[c(6, 10, 13, 15, 16, 19, 21, 22, 24, 25, 26, 28, 29, 30, 31, 32)])
probQ$val <- c(t1, t2, t3, t4, t5)
probMaxK$val <- max(probK$val)
statelist <- which(probK$val == probMaxK$val)
statelisttext <- sets2[statelist]
output$assessment <- renderText(paste(
"Most likely knowledge states (probability ",
sprintf("%5.3f", probMaxK$val),
"):"
))
output$assessmentlist <- renderText(statelisttext)
})
output$maxProbK <- renderText(sprintf("%f", probMaxK$val))
problist <- reactiveValues(val = c(1, 2, 3, 7, 11, 12, 17, 18, 31, 32))
item <- reactiveValues(val=6)
observeEvent(probQ$val, {
cert <- abs(probQ$val - 0.5)
q <- which(cert == min(cert))
item$val <<- q[sample(1:length(q), 1)]
})
output$question <- renderText(paste("Question", letters[item$val]))
observeEvent(input$clearall,{
updateCheckboxGroupInput(session,"Ks1", NULL, choices = Ks1.list, selected = NULL)
updateCheckboxGroupInput(session,"Ks2", NULL, choices = Ks2.list, selected = NULL)
})
observeEvent(input$selectall,{
updateCheckboxGroupInput(session,"Ks1", NULL, choices = Ks1.list, selected = sets1[1:16])
updateCheckboxGroupInput(session,"Ks2", NULL, choices = Ks2.list, selected = sets1[17:32])
})
observeEvent(input$defaultmodel,{
updateCheckboxGroupInput(session,"Ks1", NULL, choices = Ks1.list, selected = Ks1.model.list)
updateCheckboxGroupInput(session,"Ks2", NULL, choices = Ks2.list, selected = Ks2.model.list)
})
output$plot.KS <- renderPlot({
waiplot(t(as.binmat(c("00000",input$Ks1,input$Ks2,"11111"))))
})
observeEvent(input$KSdone, {
problist = c(1, match(input$Ks1,sets1), match(input$Ks2, sets1), 32)
cat(problist, file=stderr())
tempp <- rep(0.0,32)
tempp[problist] <- 1.0
probK$val <- tempp / sum(tempp)
})
#output-block1
{
K1 <- reactive(as.binmat(c("00000",input$Ks1,input$Ks2,"11111")))
## Blim for calibration sample
# R <- reactive({
# matrix(c(ifelse(input$q1=="empty", NA, as.numeric(input$q1 == "correct")),
# ifelse(input$q2=="empty", NA, as.numeric(input$q2 == "correct")),
# ifelse(input$q3=="empty", NA, as.numeric(input$q3 == "correct")),
# ifelse(input$q4=="empty", NA, as.numeric(input$q4 == "correct")),
# ifelse(input$q5=="empty", NA, as.numeric(input$q5 == "correct"))),
# nrow=1, byrow=T)
# })
# output$block1 <- renderTable(R())
# output$block2 <- renderTable(R())
# output$block3 <- renderTable(R())
# output$block4 <- renderTable(R())
# output$block5 <- renderTable(R())
output$outplot.1 <- renderPlot(waiplot_p(t(K1()), probK$val[problist$val]))
output$outplot.2 <- renderPlot(waiplot_p(t(K1()), probK$val[problist$val]))
output$outplot.3 <- renderPlot(waiplot_p(t(K1()), probK$val[problist$val]))
output$outplot.4 <- renderPlot(waiplot_p(t(K1()), probK$val[problist$val]))
output$outplot.5 <- renderPlot(waiplot_p(t(K1()), probK$val[problist$val]))
# output$outplot.1 <- renderPlot(waiplot(t(K1())))
# output$outplot.2 <- renderPlot(waiplot(t(K1())))
# output$outplot.3 <- renderPlot(waiplot(t(K1())))
# output$outplot.4 <- renderPlot(waiplot(t(K1())))
# output$outplot.5 <- renderPlot(waiplot(t(K1())))
observeEvent(input$q1,{
if (input$q1 != "empty") {
if (input$q1 == "correct") {
tempu <- probK$val * probac$val
} else {
tempu <- probK$val * probaf$val
}
probK$val <- tempu / sum(tempu)
updateSelectInput(session,"q1", questions$q1, # question b1
choices = c(' ' = 'empty',
'0.55' = 'correct',
'0.33' = 'choice1',
'0.45' = 'choice2',
'0.65' = 'choice3'))
}})
observeEvent(input$q2,{
if (input$q2 != "empty") {
if (input$q2 == "correct") {
tempu <- probK$val * probbc$val
} else {
tempu <- probK$val * probbf$val
}
probK$val <- tempu / sum(tempu)
updateSelectInput(session,"q2", questions$q2, # question b1
choices = c(' ' = 'empty',
'0.38' = 'choice2',
'0.27' = 'choice1',
'0.32' = 'correct',
'0.25' = 'choice3'))
}})
observeEvent(input$q3,{
if (input$q3 != "empty") {
if (input$q3 == "correct") {
tempu <- probK$val * probcc$val
} else {
tempu <- probK$val * probcf$val
}
probK$val <- tempu / sum(tempu)
updateSelectInput(session,"q3", questions$q3, # question b1
choices = c(' ' = 'empty',
'6/32' = 'choice1',
'4/32' = 'choice2',
'1/32' = 'choice3',
'2/32' = 'correct'))
}})
observeEvent(input$q4,{
if (input$q4 != "empty") {
if (input$q4 == "correct") {
tempu <- probK$val * probdc$val
} else {
tempu <- probK$val * probdf$val
}
probK$val <- tempu / sum(tempu)
updateSelectInput(session,"q4", questions$q4, # question b1
choices = c(' ' = 'empty',
'0.12' = 'correct',
'0.09' = 'choice1',
'0.22' = 'choice2',
'0.18' = 'choice3'))
}})
observeEvent(input$q5,{
if (input$q5 != "empty") {
if (input$q5 == "correct") {
tempu <- probK$val * probec$val
} else {
tempu <- probK$val * probef$val
}
probK$val <- tempu / sum(tempu)
updateSelectInput(session,"q5", questions$q5, # question b1
choices = c(' ' = 'empty',
'0.08' = 'choice1',
'0.12' = 'correct',
'0.16' = 'choice2',
'0.04' = 'choice3'))
}})
}
# outputOptions(output)
outputOptions(output, "question", suspendWhenHidden = FALSE)
outputOptions(output, "maxProbK", suspendWhenHidden = FALSE)
}
shinyApp(ui = ui, server = server)
Jessica Loke
Martin Losert
David de Segovia
Wai Wong
Chris Yndgaard
Cord Hockemeyer
