# 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(pks)
N.R1<-c(6,23,0,3,0,0,9,21,1,1,2,0,2,0,1,0,23,15,10,1,0,2,5,1,2,0,35,17,24,6,3,132)
N.R2<-c(10,9,0,3,1,1,7,10,2,0,0,0,0,2,0,1,4,8,7,0,2,0,5,0,1,0,34,10,32,4,1,191)
#plothelper
{
#data(probability)
## "Completer" sample
#pb <- probability[!is.na(probability$b201), ]
## Response frequencies for 5 items at the second measurement
#items <- c(3,4,9,10,11)
#N.R2 <- as.pattern(pb[, sprintf("b2%.2i", items)], freq = TRUE)
## Conjunctive skill function, one-to-one problem function
## for five items
#sf1 <- read.table(header = TRUE, text = "
# item cp id pb un
# 1 0 0 1 0
# 2 1 0 0 0
# 3 0 0 0 1
# 4 0 1 0 0
# 5 1 0 1 0
# 6 1 0 1 0
# 7 0 0 1 1
# 8 0 0 1 1
# 9 0 1 1 0
# 10 1 1 0 0
# 11 1 1 1 0
# 12 0 1 1 1")
#sf1 <- sf1[items,]
## Delineated knowledge structure
#K1 <- delineate(sf1)$K
## Blim for calibration sample
#blim.c <- blim(K1, N.R2, method="MDML")
#beta.c <- blim.c$beta
#eta.c <- blim.c$eta
#piK <- blim.c$P.K
## Calculate P(R|K)
## based on pks::blim
## added functionality of handling missing data:
## Missing data do *not* change P(R|K)
## This is done by assigning the probability 1 to the occurence of each NA
## Reasoning: any item which has not been presented to the subject yet
## will result in a missing value with probability 1
myP.R.K <- function(K, R, eta, beta){
# Which items were not answered and need to be ignored in the
# calculation of P(R|K)?
# These items are assigned the value 0
ignore <- t(!is.na(R))
# Fill in missing data so that matrix multiplication
# between R and K does not produce any NA
R[is.na(R)] <- 1
# Calculate P(R|K)
apply(
K, 1,
function(k) apply(
# multiply with ignore vector so that, for
# each missing item, the exponent is 0:
#
# beta^0 = 1
# (1 - beta)^0 = 1
# and so on
beta^(((1 - t(R))*k)*ignore)
* (1 - beta)^((t(R)*k)*ignore)
* eta^((t(R)*(1 - k))*ignore)
* (1 - eta)^(((1 - t(R))*(1 - k))*ignore),
2, prod
)
)
}
## Calculate P(R) and P(K|R)
## Taken from blim()
P.R <- function(PRK, piK) {as.numeric(PRK %*% piK)} # P(R)
P.K.R <- function(PRK, PR, piK) {PRK * outer(1/PR, piK)} # P(K|R)
}
#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)")
}
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=30)
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")
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")
############### UI ###############
ui <- dashboardPage(
skin="purple",
#dashboardHeader
{dashboardHeader(
title = "Estimation of Knowledge Structures",
titleWidth = "100%"
)},
#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
br(),
br(),
br(),
br(),
br(),
actionButton("clearans", "Clear all answers")
)
)},
#dashboardBody
{dashboardBody(skin="blue",
includeScript("../../../Matomo-tquant.js"),
tabItems(
#tabItems
{tabItem(tabName = "theory",
tabsetPanel(
#tabPanel
{tabPanel("Welcome to the World of Knowledge",br(),br(),
fluidPage(
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 = '12',
h4(img(src="https://i2.wp.com/tquant.eu/wp-content/uploads/2016/08/amsterdam_logo.png?resize=100%2C100&ssl=1", width = "50"),
" Jessica Loke"),
h4(img(src="https://i2.wp.com/tquant.eu/wp-content/uploads/2016/08/tuebingen_logo.png?resize=56%2C100&ssl=1", width = "50", height = "55"),
" Martin Losert"),
h4(img(src="https://i1.wp.com/tquant.eu/wp-content/uploads/2016/08/madrid_logo.png?resize=87%2C100&ssl=1", width = "50"),
" David de Segovia"),
h4(img(src="https://i2.wp.com/tquant.eu/wp-content/uploads/2016/08/leuven_logo.png?resize=150%2C100&ssl=1", width="50",height="45"),
" Wai Wong"),
h4(img(src="https://dev.go.unideb.hu/sites/default/files/styles/sc_news_main/public/sc-internal/default-logo.png?itok=cBDBy0-b", width = "50",height="50"),
" Chris Yndgaard")
))
)
)
)},
#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</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="https://i.ytimg.com/vi/ynT2ivvYJnc/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 data observed from a previous sample and the corresponding knowledge structure, or </li>
<br>
<li>building your own dataset and the corresponding 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 RESPONSE FREQUENCIES
{tabPanel("Response frequencies",
br(), HTML(
"<h5 align='left'>
Our complete knowledge domain consists of five items: {a}, {b}, {c}, {d}, {e}.
<br><br>
With five items, there are 32 possible response pattern.
As an example, if a student only answers item {a} and {c} correctly, his/her response pattern is {a,c}.
<br><br>
The numbers shown here are the frequencies of response patterns observed from a previous classroom sample.
You can choose to use this sample or you can create your own sample by changing the response frequencies.
<br><br>
Once you are done, proceed to the Your Structure tab.
<br><br>
</h5>"),
br(),
fluidRow(
#column
{column(2,
numericInput("NR2", "{a}", value = N.R1[2],
min = 0, max = 100, step = 1),
numericInput("NR3", "{b}", value = N.R1[3],
min = 0, max = 100, step = 1),
numericInput("NR4", "{c}", value = N.R1[4],
min = 0, max = 100, step = 1),
numericInput("NR5", "{d}", value = N.R1[5],
min = 0, max = 100, step = 1),
numericInput("NR6", "{e}", value = N.R1[6],
min = 0, max = 100, step = 1))},
#column
{column(2,
numericInput("NR7", "{a,b}", value = N.R1[7],
min = 0, max = 100, step = 1),
numericInput("NR8", "{a,c}", value = N.R1[8],
min = 0, max = 100, step = 1),
numericInput("NR9", "{a,d}", value = N.R1[9],
min = 0, max = 100, step = 1),
numericInput("NR10", "{a,e}", value = N.R1[10],
min = 0, max = 100, step = 1),
numericInput("NR11", "{b,c}", value = N.R1[11],
min = 0, max = 100, step = 1))},
#column
{column(2,
numericInput("NR12", "{b,d}", value = N.R1[12],
min = 0, max = 100, step = 1),
numericInput("NR13", "{b,e}", value = N.R1[13],
min = 0, max = 100, step = 1),
numericInput("NR14", "{c,d}", value = N.R1[14],
min = 0, max = 100, step = 1),
numericInput("NR15", "{c,e}", value = N.R1[15],
min = 0, max = 100, step = 1),
numericInput("NR16", "{d,e}", value = N.R1[16],
min = 0, max = 100, step = 1))},
#colummn
{column(2,
numericInput("NR17", "{a,b,c}", value = N.R1[17],
min = 0, max = 100, step = 1),
numericInput("NR18", "{a,b,d}", value = N.R1[18],
min = 0, max = 100, step = 1),
numericInput("NR19", "{a,b,e}", value = N.R1[19],
min = 0, max = 100, step = 1),
numericInput("NR20", "{a,c,d}", value = N.R1[20],
min = 0, max = 100, step = 1),
numericInput("NR21", "{a,c,e}", value = N.R1[21],
min = 0, max = 100, step = 1))},
#column
{column(2,
numericInput("NR22", "{a,d,e}", value = N.R1[22],
min = 0, max = 100, step = 1),
numericInput("NR23", "{b,c,d}", value = N.R1[23],
min = 0, max = 100, step = 1),
numericInput("NR24", "{b,c,e}", value = N.R1[24],
min = 0, max = 100, step = 1),
numericInput("NR25", "{b,d,e}", value = N.R1[25],
min = 0, max = 100, step = 1),
numericInput("NR26", "{c,d,e}", value = N.R1[26],
min = 0, max = 100, step = 1))},
#column
{column(2,
numericInput("NR27", "{a,b,c,d}", value = N.R1[27],
min = 0, max = 100, step = 1),
numericInput("NR28", "{a,b,c,e}", value = N.R1[28],
min = 0, max = 100, step = 1),
numericInput("NR29", "{a,b,d,e}", value = N.R1[29],
min = 0, max = 100, step = 1),
numericInput("NR30", "{a,c,d,e}", value = N.R1[30],
min = 0, max = 100, step = 1),
numericInput("NR31", "{b,c,d,e}", value = N.R1[31],
min = 0, max = 100, step = 1))}
#column
),
fluidRow(
column(2,
numericInput("NR1", HTML("∅"), value = N.R1[1],
min = 0, max = 100, step = 1)
),
column(2,
numericInput("NR32", "Q={a,b,c,d,e}", value = N.R1[32],
min = 0, max = 100, step = 1)
),
column(3,br(),
actionButton("data1", "Original Dataset")
),
# column(3,br(),
# actionButton("data2", "Dataset after learning")
# ),
column(2,br(),
actionButton("allzero", "Clear Data")
)
),
fluidRow(
column(12,
plotOutput("plot.NR")
)
)
)},
#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>"),
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
{fluidRow(
column(2,
br(),
actionButton("clearall", "Clear all")
),
column(2,
br(),
actionButton("selectall", "Select all")
),
column(2,
br(),
actionButton("defaultmodel", "Default model")
)
)}
)}
)
),
tabItem(tabName = "quiz",
tabsetPanel(
#Question a
{tabPanel("Question a",
fluidPage(
fluidRow(
column(4,
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%'),
fluidRow(
column(4,tableOutput("tablePKR1")),
column(4,tableOutput("table.etabeta1"),textOutput("text.etabeta1"))
)),
column(8,h3(plotheadline),plotOutput("outplot.1")
)
)
))},
#Question b
{tabPanel("Question b",
fluidPage(
fluidRow(
column(4,
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%'),
fluidRow(
column(4,tableOutput("tablePKR2")),
column(4,tableOutput("table.etabeta2"),textOutput("text.etabeta2"))
)
),
column(8,
h3(plotheadline),
plotOutput("outplot.2"))
)))},
#Question c
{tabPanel("Question c",
fluidPage(
fluidRow(
column(4,
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%'),
fluidRow(
column(4,tableOutput("tablePKR3")),
column(4,tableOutput("table.etabeta3"),textOutput("text.etabeta3"))
)
),
column(8,
h3(plotheadline),
plotOutput("outplot.3"))
)))},
#Question d
{tabPanel("Question d",
fluidPage(
fluidRow(
column(4,
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%'),
fluidRow(
column(4,tableOutput("tablePKR4")),
column(4,tableOutput("table.etabeta4"),textOutput("text.etabeta4"))
)
),
column(8,
h3(plotheadline),
plotOutput("outplot.4")))
))},
#Question e
{tabPanel("Question e",
fluidPage(
fluidRow(
column(4,
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%'),
fluidRow(
column(4,tableOutput("tablePKR5")),
column(4,tableOutput("table.etabeta5"),textOutput("text.etabeta5"))
)
),
column(8,
h3(plotheadline),
plotOutput("outplot.5")))
))}
)
)
)
)}
)
############### SERVER ###############
server <- function(input, output, session){
#### NR input & plot ####
temp1 <- N.R1
temp2 <- N.R2
observeEvent(input$data1,
for (i in 1:32) updateNumericInput(session, paste("NR",i,sep=""), value = temp1[i]))
observeEvent(input$data2,
for (i in 1:32) updateNumericInput(session, paste("NR",i,sep=""), value = temp2[i]))
observeEvent(input$allzero,
for (i in 1:32) updateNumericInput(session, paste("NR",i,sep=""), value = 0))
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)
})
observeEvent(input$clearans,{
updateSelectInput(session,"q1", questions$q1, # question b1
choices = c(' ' = 'empty',
'0.55' = 'correct',
'0.33' = 'choice1',
'0.45' = 'choice2',
'0.65' = 'choice3'))
updateSelectInput(session,"q2", questions$q2, # question b1
choices = c(' ' = 'empty',
'0.38' = 'choice2',
'0.27' = 'choice1',
'0.32' = 'correct',
'0.25' = 'choice3'))
updateSelectInput(session,"q3", questions$q3, # question b1
choices = c(' ' = 'empty',
'6/32' = 'choice1',
'4/32' = 'choice2',
'1/32' = 'choice3',
'2/32' = 'correct'))
updateSelectInput(session,"q4", questions$q4, # question b1
choices = c(' ' = 'empty',
'0.12' = 'correct',
'0.09' = 'choice1',
'0.22' = 'choice2',
'0.18' = 'choice3'))
updateSelectInput(session,"q5", questions$q5, # question b1
choices = c(' ' = 'empty',
'0.08' = 'choice1',
'0.12' = 'correct',
'0.16' = 'choice2',
'0.04' = 'choice3'))
})
sets2 <- as.pattern(as.binmat(sets1), as.letters = TRUE)
# creates table with N.R values and the corresponding sets
# N.R <- eventReactive(input$go.plot, {
N.R <- reactive({
nr <- c(input$NR1, input$NR2, input$NR3, input$NR4, input$NR5, input$NR6,
input$NR7, input$NR8, input$NR9, input$NR10, input$NR11,
input$NR12, input$NR13, input$NR14, input$NR15, input$NR16,
input$NR17, input$NR18, input$NR19, input$NR20, input$NR21, input$NR22,
input$NR23, input$NR24, input$NR25, input$NR26, input$NR27,
input$NR28, input$NR29, input$NR30, input$NR31, input$NR32)
setNames(nr, sets1)
})
# function for the barplot of the N.R frequencies
NRplot <- function(NR){
par(mar = c(0, 4, 3, 1))
barplot(NR,
horiz = TRUE,
names.arg = sets2,
axes = FALSE,
cex.names = 0.8,
las = 2,
col = "lightblue",
xlim = c(0, max(NR) + 2),
border = NA,
width = 1.4,
space = .2
)
# include axis
axis(side = 3,
cex.axis = 1.3)
}
output$plot.NR <- renderPlot({
NRplot(NR = N.R())
})
output$plot.KS <- renderPlot({
waiplot(t(as.binmat(c("00000",input$Ks1,input$Ks2,"11111"))))
})
#output-block1
{
K1 <- reactive(as.binmat(c("00000",input$Ks1,input$Ks2,"11111")))
## Blim for calibration sample
blim.c <- reactive(blim(K1(), N.R(), method="MDML"))
beta.c <- reactive(blim.c()$beta)
eta.c <- reactive(blim.c()$eta)
piK <- reactive(blim.c()$P.K)
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)
})
PRK <- reactive({
as.matrix(t(myP.R.K(K=K1(), R=R(), eta=eta.c(), beta=beta.c())))
})
PR <- reactive(P.R(PRK(), piK()))
PKR <- reactive(P.K.R(PRK(), PR(), piK()))
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()), PKR()))
output$outplot.2 <- renderPlot(waiplot_p(t(K1()), PKR()))
output$outplot.3 <- renderPlot(waiplot_p(t(K1()), PKR()))
output$outplot.4 <- renderPlot(waiplot_p(t(K1()), PKR()))
output$outplot.5 <- renderPlot(waiplot_p(t(K1()), PKR()))
output$tablePKR1 <- renderTable(matrix(c(cbind(as.pattern(as.binmat(rownames(t(PKR()))), as.letters = TRUE),round(t(PKR()),2))),ncol=2,dimnames=list(NULL,c("State","p"))))
output$table.etabeta1 <- renderTable(as.matrix(data.frame(beta=beta.c(), eta=eta.c())))
output$text.etabeta1 <- renderText("Beta is the probability of a careless error and eta is the probability of a lucky guess")
output$tablePKR2 <- renderTable(matrix(c(cbind(as.pattern(as.binmat(rownames(t(PKR()))), as.letters = TRUE),round(t(PKR()),2))),ncol=2,dimnames=list(NULL,c("State","p"))))
output$table.etabeta2 <- renderTable(as.matrix(data.frame(beta=beta.c(), eta=eta.c())))
output$text.etabeta2 <- renderText("Beta is the probability of a careless error and eta is the probability of a lucky guess")
output$tablePKR3 <- renderTable(matrix(c(cbind(as.pattern(as.binmat(rownames(t(PKR()))), as.letters = TRUE),round(t(PKR()),2))),ncol=2,dimnames=list(NULL,c("State","p"))))
output$table.etabeta3 <- renderTable(as.matrix(data.frame(beta=beta.c(), eta=eta.c())))
output$text.etabeta3 <- renderText("Beta is the probability of a careless error and eta is the probability of a lucky guess")
output$tablePKR4 <- renderTable(matrix(c(cbind(as.pattern(as.binmat(rownames(t(PKR()))), as.letters = TRUE),round(t(PKR()),2))),ncol=2,dimnames=list(NULL,c("State","p"))))
output$table.etabeta4 <- renderTable(as.matrix(data.frame(beta=beta.c(), eta=eta.c())))
output$text.etabeta4 <- renderText("Beta is the probability of a careless error and eta is the probability of a lucky guess")
output$tablePKR5 <- renderTable(matrix(c(cbind(as.pattern(as.binmat(rownames(t(PKR()))), as.letters = TRUE),round(t(PKR()),2))),ncol=2,dimnames=list(NULL,c("State","p"))))
output$table.etabeta5 <- renderTable(as.matrix(data.frame(beta=beta.c(), eta=eta.c())))
output$text.etabeta5 <- renderText("Beta is the probability of a careless error and eta is the probability of a lucky guess")
#
}
}
shinyApp(ui = ui, server = server)
Jessica Loke
Martin Losert
David de Segovia
Wai Wong
Chris Yndgaard
