library('shiny')
library('kst')
library('DAKS')
library('pks')
library('shinyBS')
library('shinyjs')
library('hasseDiagram')
library('htmltools')
library('sweetalertR') # install with devtools::install_github("timelyportfolio/sweetalertR")
ui <- fluidPage( # theme = "bootstrap.css",
includeScript("../../../Matomo-tquant.js"),
navbarPage(
a(href = 'https://tquant.eu/',
img(src = 'logo_TquanT.jpg', height = 30)),
selected = "Simulation",
tabPanel("Introduction", includeHTML("www/intro.html")),
tabPanel(
"Simulation",
h2("BLIM Simulation", align = "center"),
useShinyjs(),
hr(),
tags$p(),
sidebarLayout(
sidebarPanel(
width = 3,
fluidRow(
sliderInput(
"beta",
"Careless error rate",
min = 0.02,
max = 0.5,
value = 0.07
)
),
fluidRow(
sliderInput(
"eta",
"Lucky guess rate",
min = 0.02,
max = 0.5,
value = 0.05
)
),
fluidRow(
numericInput(
"n",
"Number of respondents",
min = 10,
max = 5000,
value = 500
)
,
bsTooltip(
"n",
HTML("Choose a number between 10 and 5000"),
"right",
trigger = "hover",
options = list(container = "body")
)
),
fluidRow(
column(
width = 1,
offset = 0,
actionButton(
"itemselect",
label = "",
icon = icon("file-text-o"),
style = "color: #fff; background-color: #147847; border-color: #147847"
),
bsTooltip(
"itemselect",
HTML("Select the items to be included in the test"),
"right",
trigger = "hover",
options = list(container = "body")
)
),
column(
width = 1,
offset = 1,
actionButton(
"infoT",
label = "",
icon = icon("info-circle"),
style = "color: #fff; background-color: #337ab7; border-color: #2e6da4"
)
)
,
column(
width = 2,
offset = 1,
HTML(
'
<button id="runT" type="button" class="btn btn-primary action-button">
<i class="glyphicon glyphicon-triangle-right"></i>
Go!
</button>
'
)
)
)
),
mainPanel(
fluidRow(
column(width = 6,
plotOutput(outputId = "plot.diagram", height = "500px")),
column(
width = 6,
plotOutput(outputId = "plotHistograms", height = "500px")
)
,
bsModal(
"modalI",
"Select the items to include in the test",
"itemselect",
size = "small",
uiOutput("itemselectT")
),
bsModal(
"infoM",
"Glossary of terms",
"infoT",
size = "large",
htmlOutput("infoOutput")
)
,
htmlOutput("alertC")
,
sweetalert()
)
)
)
),
tabPanel("About", includeHTML("www/about.html"))
))
server <- function(input, output, session) {
output$itemselectT <- renderUI({
checkboxGroupInput(
"selectitems",
"Select at least three items and always include either item a) or item b)",
choices = c("a) 3 + 8 = ?", "b) 9 + 1 = ?", "c) 2 * 5 = ?", "d) -5 + 7 = ?", "e) 4^3 = ?"),
selected = c("a) 3 + 8 = ?", "b) 9 + 1 = ?", "c) 2 * 5 = ?")
)
})
output$infoOutput <- renderUI({
HTML(
'<p> <b> Knowledge domain</b>: an either finite or infinite set Q of questions <br>
<br> <b>Knowledge state</b>: the subset K ⊆ Q of all questions that an individual is capable of answering correctly <br>
<br> <b>Knowledge structure</b>: a pair (Q, K ), where K is a collection of subsets of Q, containing at least the empty set and Q. The smallest possible knowledge structure has only two elements: K = {∅, Q}, the largest possible knowledge structure has: K = 2Q elements.
<br> <br> <b>Surmise relation</b>: Denoted by ≤, a surmise relation is a quasi-order on the set Q of questions. Given any two problems q, r ∈ Q, we say that r is a predecessor of q if r is never mastered after q. In that case we write r ≤ q.
<br> <br> <b>Closure Under Union</b>: A (finite) knowledge structure (Q, K) is said to be closed under union if
K ∪ L ∈ K
holds true for all pairs K, L ∈ K.
<br> In other words: A knowledge structure is closed under union, if all subsets formed by unions of subsets are still in the knowledge structure.
<br> <br> <b>Closure Under Intersection</b>: A (finite) knowledge structure (Q, K) is said to be closed under intersection if K ∩ L ∈ K holds true for all pairs K, L ∈ K.
<br> In other words: A knowledge structure is closed under intersection, if all subsets formed by intersections of subsets are still in the knowledge structure.
<br> <br><b>Basis of a Knowledge Space</b>: The collection B of all those states in K that cannot be obtained as unions of other states in K is called the basis of the knowledge space K.
<br> <br><b>Clauses</b>: The minimal states containing a certain item.
<br> <br> <b>βq </b>: A careless error for a problem q.
<br> <br> <b>ηq </b>: A lucky guess for a problem q.
</p>'
)
})
default.diagram <- function() {
par(pty = "s")
plot(
c(-10, 10),
c(-10, 10),
type = "n",
axes = F,
ylab = " ",
xlab = " ",
main = " "
)
pos0 <- 7
text(0, pos0, labels = "1. Select the items\n to be included in the test.", cex = 1.2)
text(0, pos0 - 4, labels = "2. Select the careless error\n and lucky guess rates.", cex = 1.2)
text(0, pos0 - 8, labels = "3. Select the number of\n respondents.", cex = 1.2)
text(0, pos0 - 11, labels = "4. Click Go! to see the results.", cex = 1.2)
}
default.histogram <- function() {
par(mfrow = c(2, 1))
plot(
c(0, 10),
c(0, 100),
type = "n",
xlab = "Response patterns",
ylab = "Frequency",
axes = F
)
axis(
1,
at = 1:7,
labels = c("1000", "0100", "0010", "0001", "1100", "1010", "1001")
)
axis(2)
}
output$plot.diagram <- renderPlot({
default.diagram()
})
output$plotHistograms <- renderPlot({
default.histogram()
})
maxitems <- 7
ninputs <- 3 # Number of inputs allowed by the user
OS <-
c("a) 3 + 8 = ?", "b) 9 + 1 = ?", "c) 2 * 5 = ?", "d) -5 + 7 = ?", "e) 4^3 = ?")
NEC <- OS[1]
warnings_input <- rep(FALSE, ninputs)
############## INPUTS ##############
IS <- OS
observeEvent(input$runT, ignoreNULL = TRUE, {
beta <- input$beta # Guessing rate
eta <- input$eta # Lapsing rate
if (is.null(input$n) | input$n > 5000 | input$n < 10) {
n <- 100
warnings_input[1] <- T
} else {
n <- input$n
}
if (is.null(input$selectitems) |
length(input$selectitems) < 3) {
IS <- OS
warnings_input[2] <- T
} else if ((input$selectitems[1] == OS[1] |
input$selectitems[1] == OS[2]) == FALSE) {
IS <- OS
warnings_input[2] <- T
} else {
IS <- input$selectitems
}
if (input$beta < 0 |
input$beta > 1 | input$eta > 1 | input$eta < 0) {
warnings_input[3] <- T
}
J <- vector("numeric", length = length(IS))
for (i in 1:length(IS)) {
J[i] <- which(IS[i] == OS)
}
choice.name <- c("11100")
if (length(IS) == 4) {
choice.name <- c("1100")
} else if (length(IS) == 3) {
choice.name <- c("100")
} else if (length(IS) <= 2) {
choice.name <- c("10")
} # else choice.name <- c("11100")
################################################################################################
######################################## ERROR MESSAGE #######################################
if (any(warnings_input == T)) {
output$alertC <-
renderUI(
HTML(
'<script> sweetAlert(\'Simulation failed!\',\' It appears you have entered at least one incorrect input. Remember to select at least three items to be included in the test! \',\'error\') </script>'
)
)
output$plot.diagram <- renderPlot({
default.diagram()
})
return()
}
######################################## ERROR MESSAGE #######################################
################################################################################################
data(DoignonFalmagne7) # Load default dataset
K <- DoignonFalmagne7$K[, J] # Knowledge Structure
K <- as.binmat(as.pattern(K, freq = TRUE))
I <- state2imp(K) # Get implications from KS
# Simulate the responses
X <-
simu(
items = ncol(K),
size = n,
ce = beta,
lg = eta,
imp = I
)
R <- X$dataset
P <- as.pattern(R, freq = T)
response.p.names <- apply(R, 1, paste, collapse = "")
model <- blim(K = K,
N.R = P,
method = "MDML")
P.K <- model$P.K # Probability of the KS
P.R.K <- apply(K, 1, function(k)
apply(
# P(R|K)
beta ^ ((1 - t(R)) * k) * (1 - beta) ^ (t(R) * k) *
eta ^ (t(R) * (1 - k)) * (1 - eta) ^ ((1 - t(R)) * (1 - k)),
2,
prod
))
rownames(P.R.K) <- response.p.names
colnames(P.R.K) <- names(P.K)
output$plot.diagram <- renderPlot({
MA <-
matrix(as.logical(relation_incidence(endorelation(graph = I))), nrow = length(J))
hasseDiagram::hasse(MA, labels = IS)
})
output$plotHistograms <- renderPlot({
par(mfrow = c(2, 1))
barplot(
P,
border = "lightgray",
col = "indianred",
xlab = "Response patterns",
ylab = "Frequency"
)
})
output$alertC <-
renderUI(HTML(
'<script> sweetAlert(\'Done!\',\' \',\'success\') </script>'
))
})
}
shinyApp(ui = ui, server = server)
