Nothing
inst/sabirt/server.R
In bairt: Bayesian Analysis of Item Response Theory Models
#SABIRT
#Shiny App for Bayesian Item Response Theory
#By Javier Martinez and Irene Garcia Mosquera
#
#Maintainer: Javier Martinez <martinezjavier243@gmail.com>
#
#SERVER
#
shiny::shinyServer(function(input, output, session) {
####RESET =============================================================
observeEvent(input$changeData,{
action <- input[[paste0("goButton",
input$changeData - 1, input$changeModel)]]
if(paste0("initialValues", action, ".RData") %in% list.files()){
file.remove(paste0("initialValues", action, ".RData"))
}
div(
shinyjs::reset("reset"),
shinyjs::reset("fileIn"),
shinyjs::reset("dataTest")
)
})#==================================================================
observeEvent(input$changeModel,{
action <- input[[paste0("goButton",
input$changeData, input$changeModel - 1)]]
if(paste0("initialValues", action, ".RData") %in% list.files()){
file.remove(paste0("initialValues", action, ".RData"))
}
shinyjs::reset("reset")
})#====================================================================
####OBSERVER ==========================================================
observe({
action <- input[[paste0("goButton",
input$changeData, input$changeModel)]]
##
if (input$close > 0){
if( paste0("initialValues", action, ".RData") %in% list.files()){
file.remove(paste0("initialValues", action, ".RData"))
}
stopApp()
}##
##
if ( is.null(data()) || ncol(data()) < 2 || nrow(data()) < 2 ){
shinyjs::disable("dataOk")
}else {
shinyjs::enable("dataOk")
}##
##
if(input$model == ""){
shinyjs::disable(paste0("goButton",
input$changeData, input$changeModel))
shinyjs::disable("iiter")
shinyjs::disable("burnin")
}else{
shinyjs::enable(paste0("goButton",
input$changeData, input$changeModel))
shinyjs::enable("iiter")
shinyjs::enable("burnin")
}##
##
if( !is.null( action )){
if(action > 0){
shinyjs::disable("model")
}else{shinyjs::enable("model")}
if( (action == 0) ){
shinyjs::disable("thin")
}else{
shinyjs::enable("thin")
}
}##
##
if(input$iiter %in% 6:100000 && input$burnin %in% 0:100000
&& input$thin %in% 1:100 && input$model != ""){
k <- (input$iiter - input$burnin)/(input$thin)
if( k > 0 && .whole(k) ){
shinyjs::enable( paste0("goButton",
input$changeData, input$changeModel) )
}else {
shinyjs::disable( paste0("goButton",
input$changeData, input$changeModel) )
}
} else {
shinyjs::disable( paste0("goButton",
input$changeData, input$changeModel) )
}##
##
if(!(input$itemRespon %in% 0:100)){
shinyjs::disable( paste0("goButton",
input$changeData, input$changeModel) )
}##
##
if(input$dataTest){
shinyjs::disable("tipo")
shinyjs::disable("fileIn")
shinyjs::disable("header")
}else{
shinyjs::enable("tipo")
shinyjs::enable("fileIn")
shinyjs::enable("header")
}##
})#====================================================================
####MCMC PANEL ========================================================
output$mcmcPanel <- renderUI({
action <- input[[paste0("goButton",
input$changeData, input$changeModel)]]
####
if(!is.null(action)){
##
if(input$model == ""){
return( .modelSelect() )
}##
##
if(input$model == "2pno" && action == 0){
return( .mcmc2pnoInfo() )
}##
##
if(input$model == "3pno" && action == 0){
return(.mcmc3pnoInfo())
}##
##
if( action > 0){
####
tabsetPanel(
#
tabPanel("Overview and Diagnostic",
plotOutput( "checkPlot" ),
fluidRow(
column(12, .rhat_text())
)
),#
#
tabPanel("Chain",
br(), br(),
plotOutput( "chainPlot" ),
h3( "Chain" ),
tags$hr(),
fluidRow(
column(5,
uiOutput("datasetInput"),
uiOutput("nchainInput")
),
column(7, .chain_text())
)
),#
#
tabPanel("IRC",
br(), br(),
plotOutput( "IRCPlot" ),
h3( "IRC" ),
tags$hr(),
fluidRow(
column(5,
numericInput( "ItemIRC", "Item:", 1, min = 1,
max = ncol(datamcmc()) ),
p("Please remember that only exist",
code(paste(ncol(datamcmc()), "Items")), ".")
),
column(7, .irc_text())
)
),#
#
tabPanel("Posterior Densities",
br(), br(),
plotOutput( "converPlot" ),
h3( "Posterior Densities" ),
tags$hr(),
fluidRow(
column(5,
selectInput("ParaPosterior", "Choose a Parameter:",
choices = c("Item Parameters",
names(infoParameters()))
),
textInput("ItemsPosterior", "Item or ability:", "",
width = "50%"),
p("Please remember that only exist",
code(paste(ncol(datamcmc()), "Items")), "and",
code(paste(nrow(datamcmc()), "Examinees")), "."),
.ItemsPosterior_text()
),
column(7, .parameter_text())
)
),#
#
tabPanel("Summary",
br(), br(),
dataTableOutput( "contents" ),
h3( "Download" ),
tags$hr(),
fluidRow(
column(5,
selectInput( "dtipo", "Select Data Type:",
choices = c(".csv",".csv2",".txt" ) ),
downloadButton( "downloadData", "Download Table" )),
column(7, .download_text())
)
),#
#
tabPanel("Model Info", br(), br(), uiOutput("modelInfo") )
)####
}##
}#####
})#====================================================================
####CHANGE BUTTON =====================================================
output$changeButton <- renderUI({
actionButton( paste0("goButton", input$changeData, input$changeModel),
"Start MCMC!", style = "color:green" )
})#====================================================================
####DATA ==============================================================
data <- reactive({
##
if (input$dataTest){
inFile <- load("www/MathTest.rda")
inFile <- MathTest
}else {
inFile <- input$fileIn$datapath
}##
##
if ( is.null( inFile ) ){
NULL
} else {
dat <- .readData( inFile, input$tipo, input$header, input$dataTest )
if(is.null(dat) ){
NULL
}else{dat}
}##
})#====================================================================
####RENDER DATA =======================================================
output$dataFile <- renderDataTable({
if(!is.null( data() )){
data() }else{ NULL }
})#====================================================================
####DATA PANEL ========================================================
output$dataPanel <- renderUI({
if(is.null(data()) ){
return( .modelData() )
}else{
return( dataTableOutput( "dataFile" ) )
}
})#====================================================================
#############################MCMC FUNCTION#############################
####DATA MCMC =========================================================
datamcmc <- reactive({
if(!is.null( data() )){
as.data.frame( data() )
#as.data.frame( data()[ , -1 ])
}else{
NULL
}
})#====================================================================
####MCMCLIST ==========================================================
mcmclist <- reactive({
action <- input[[paste0("goButton",
input$changeData, input$changeModel)]]
if(!is.null( datamcmc() ) && !is.null( action )){
if(action == 0) {out <- NULL} else {
isolate({
action
shinyjs::disable(paste0("goButton",
input$changeData, input$changeModel))
shinyjs::disable("model")
shinyjs::disable("itemRespon")
shinyjs::disable("iiter")
shinyjs::disable("burnin")
shinyjs::disable("thin")
shinyjs::disable("changeData")
shinyjs::disable("changeModel")
shinyjs::disable("close")
shinyjs::disable("mcmcPanel")
shinyjs::disable("downloadData")
if(action == 1){
initial <- NULL
} else {
env <- reactiveFileReader(1000, session,
paste0("initialValues",
action - 1, ".RData"),
function( RData,
env = new.env() ) {
load(RData, env)
return(env)
})
initial <- env()[[names(env())[1]]]
if ( is.null(initial) ){
stop( "Error initial.value")
}
}
out <- .mcmc.function( data = datamcmc(), initial.value = initial,
c.prior = prior(),
iter = input$iiter, burning = input$burnin,
thin = input$thin, studyTheta = TRUE,
model = input$model)
vi <- out$information$final.values
save( vi, file = paste0("initialValues", action, ".RData"))
if (action > 1){
file.remove(paste0("initialValues", action - 1, ".RData"))
}
shinyjs::enable(paste0("goButton",
input$changeData, input$changeModel))
shinyjs::enable("itemRespon")
shinyjs::enable("iiter")
shinyjs::enable("burnin")
shinyjs::enable("thin")
shinyjs::enable("changeData")
shinyjs::enable("changeModel")
shinyjs::enable("close")
shinyjs::enable("mcmcPanel")
shinyjs::enable("downloadData")
})
}
return( out )
}else{
NULL
}
})#====================================================================
####INFO PARAMETERS===================================================
infoParameters <- reactive({ table(mcmclist()$diagnostic$diag$Parameter) })
####DIAG ==============================================================
diagn <- reactive({
diag <- mcmclist()$diagnostic$diag
if ( is.null( diag ) ){
return( NULL )
} else {
return( diag )
}
})#====================================================================
####CHECK PLOT ========================================================
output$checkPlot <- renderPlot({
if(is.null( mcmclist() )){
0
} else {
bairt::check.plot( mcmclist(), converg.test = TRUE)
}
})#====================================================================
#DIAGNOSTIC TABLE
output$contents <- renderDataTable({ diagn() })
####IRC PLOT ==========================================================
output$IRCPlot <- renderPlot({
if( is.null( mcmclist() ) ){
0
} else {
if(input$ItemIRC %in% 1:ncol(datamcmc())){
bairt::irc( mcmclist(), item = input$ItemIRC,
main = paste( "IRC Item", input$ItemIRC ) )
}else{
0
}
}
})#====================================================================
####PARAMETER =========================================================
output$converPlot <- renderPlot({
if( is.null( mcmclist() ) ){
0
} else {
parameter <- input$ParaPosterior
if (parameter %in% names(infoParameters())){
items <- .texToNumber(input$ItemsPosterior, infoParameters(), parameter)
if(!is.null(items) && (items %in% 1:infoParameters()[parameter])){
bairt::parameter.plot(mcmclist(),
items, parameter)
}
}else {
bairt::parameter.plot(mcmclist())
}
}
})#====================================================================
####CHAIN PLOT ========================================================
output$chainPlot <- renderPlot({
##
if( is.null( input$dataset ) || is.null(mcmclist())
|| is.null(input$nchain) ){
0
} else {
#
if (input$dataset != "theta"){
if( input$nchain %in% 1:ncol(datamcmc()) ){
bairt::chain.study(mcmclist(), parameter = input$dataset,
chain = input$nchain, line = TRUE)
}else{ 0 }
}#
#
if (input$dataset == "theta"){
if( input$nchain %in% 1:nrow(datamcmc()) ){
bairt::chain.study(mcmclist(), parameter = input$dataset,
chain = input$nchain, line = TRUE)
}else{ 0 }
}#
}##
})#====================================================================
####MODEL INFO ========================================================
output$modelInfo <- renderUI({
if(input$model == "2pno" ){
return( .mcmc2pnoInfo() )
}
if(input$model == "3pno" ){
return(.mcmc3pnoInfo())
}
})#====================================================================
####PRIOR =============================================================
prior <- reactive({
if( input$itemRespon == 0 ){
prior <- c( 1, 1) } else {
alpha <- ( 20 *( 1 / input$itemRespon ) ) + 1
alpha <- round( alpha, digits = 2 )
beta <- ( 20 * ( 1 - ( 1 / input$itemRespon ) ) ) + 1
beta <- round( beta, digits = 2)
prior <- c( alpha, beta )
}
return( prior )
})#====================================================================
####PRIOR TEXT ========================================================
output$priorText <- renderUI({
if (input$itemRespon %in% 0:100){
return( h5(paste( "c Prior Beta (",
prior()[ 1 ], ",", prior()[ 2 ], ")" ) ))
} else {
return( h5( "ERROR: Value", style = "color:red" ) )
}
})#====================================================================
####MCMC TEXT =========================================================
output$mcmctex <- renderUI({
k <- (input$iiter - input$burnin)/(input$thin)
##
if(input$iiter %in% 6:100000 && input$burnin %in% 0:100000
&& input$thin %in% 1:100){
#
if( k > 0 && .whole(k) ){
return( h5("OK!") )
}else{
if(input$iiter < input$burnin){
return( h5("ERROR: Iter < Burnin", style = "color:red") )
}
if(input$iiter == input$burnin){
return( h5("ERROR: Iter = Burnin", style = "color:red") )
}
if(!(input$iiter == input$burnin) && !(input$iiter < input$burnin)){
return( h5("ERROR: (Iter-Burnin)/Thin is not a whole number",
style = "color:red") )
}
}#
} else { h5("ERROR: Value", style = "color:red") }##
})#=====================================================================
####CHAIN DATASET ======================================================
output$datasetInput <- renderUI({
selectInput( "dataset", "Choose a Parameter:",
choices = names(infoParameters()) )
})#=====================================================================
####CHAIN INPUT ========================================================
output$nchainInput <- renderUI({
##
if(!is.null(input$dataset)){
#
if(input$dataset == "theta"){
nameBUtton <- "Examiner's Ability"
name <- "Examinees"
maxValue <- nrow(datamcmc())
}else{
nameBUtton <- "Item"
name <- "Items"
maxValue <- ncol(datamcmc())
}#
}else{
nameBUtton <- "Item"
name <- "Items"
maxValue <- 1
}##
div(
numericInput( "nchain",
paste0(nameBUtton, ":"), 1, min = 1, max = maxValue),
p("Please remember that only exist",
code(paste(maxValue, name)), ".")
)
})#=====================================================================
####TEXT GO ============================================================
output$textGo <- renderUI({
if(!is.null(mcmclist()) &&
input[[paste0("goButton", input$changeData, input$changeModel)]] > 0){
div(
br(),
"Press",code("Start MCMC!"), "to continue MCMC."
)
} else {""}
})#====================================================================
####DOWNLOAD DATA =====================================================
output$downloadData <- downloadHandler(
filename = function() { paste( "Summary-", Sys.Date(),
.csvf( input$dtipo ), sep = '' ) },
content = function( file ) {
.dataWrite( diagn(), input$dtipo,file )
}
)#=====================================================================
####DATA TEST =========================================================
output$testData <- renderUI({
if(is.null(data())){
div(
p("No Data")
)
}else{
if(ncol(data()) < 2 || nrow(data()) < 2){
div( p("ERROR: Data is incorrect"), style = "color:red" )
}else{
div(
p("Please note that:"),
p(code("Number of Items:"), paste( ncol(data()) ) ),
p(code("Number of Examinees:"), paste( nrow(data()) ) )
)
}
}
})#====================================================================
####DATA CONTINUE =====================================================
output$dataContinue <- renderUI({
if(is.null(data())){
div("")
}else{
if(ncol(data()) < 2 || nrow(data()) < 2){
div( "" )
}else{
div(
p("Press",code("Data is Ok!"), "to continue.")
)
}
}
})#====================================================================
####DATA INFO =========================================================
output$dataInfo <- renderUI({
if( !is.null(data()) ){
if(is.null(input$fileIn)){
name <- "MathTest"
}else{
name <- input$fileIn$name
}
div(
column(4, p( strong("Data:"), name)),
column(4, p( strong("Items:"), paste( ncol(datamcmc()) ) )),
column(4, p( strong("Examinees:"), paste( nrow(datamcmc()) ) ))
)
}else{div("")}
})#=====================================================================
})
Try the bairt package in your browser
Any scripts or data that you put into this service are public.
bairt documentation built on May 1, 2019, 10:56 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#SABIRT
#Shiny App for Bayesian Item Response Theory
#By Javier Martinez and Irene Garcia Mosquera
#
#Maintainer: Javier Martinez <martinezjavier243@gmail.com>
#
#SERVER
#
shiny::shinyServer(function(input, output, session) {
####RESET =============================================================
observeEvent(input$changeData,{
action <- input[[paste0("goButton",
input$changeData - 1, input$changeModel)]]
if(paste0("initialValues", action, ".RData") %in% list.files()){
file.remove(paste0("initialValues", action, ".RData"))
}
div(
shinyjs::reset("reset"),
shinyjs::reset("fileIn"),
shinyjs::reset("dataTest")
)
})#==================================================================
observeEvent(input$changeModel,{
action <- input[[paste0("goButton",
input$changeData, input$changeModel - 1)]]
if(paste0("initialValues", action, ".RData") %in% list.files()){
file.remove(paste0("initialValues", action, ".RData"))
}
shinyjs::reset("reset")
})#====================================================================
####OBSERVER ==========================================================
observe({
action <- input[[paste0("goButton",
input$changeData, input$changeModel)]]
##
if (input$close > 0){
if( paste0("initialValues", action, ".RData") %in% list.files()){
file.remove(paste0("initialValues", action, ".RData"))
}
stopApp()
}##
##
if ( is.null(data()) || ncol(data()) < 2 || nrow(data()) < 2 ){
shinyjs::disable("dataOk")
}else {
shinyjs::enable("dataOk")
}##
##
if(input$model == ""){
shinyjs::disable(paste0("goButton",
input$changeData, input$changeModel))
shinyjs::disable("iiter")
shinyjs::disable("burnin")
}else{
shinyjs::enable(paste0("goButton",
input$changeData, input$changeModel))
shinyjs::enable("iiter")
shinyjs::enable("burnin")
}##
##
if( !is.null( action )){
if(action > 0){
shinyjs::disable("model")
}else{shinyjs::enable("model")}
if( (action == 0) ){
shinyjs::disable("thin")
}else{
shinyjs::enable("thin")
}
}##
##
if(input$iiter %in% 6:100000 && input$burnin %in% 0:100000
&& input$thin %in% 1:100 && input$model != ""){
k <- (input$iiter - input$burnin)/(input$thin)
if( k > 0 && .whole(k) ){
shinyjs::enable( paste0("goButton",
input$changeData, input$changeModel) )
}else {
shinyjs::disable( paste0("goButton",
input$changeData, input$changeModel) )
}
} else {
shinyjs::disable( paste0("goButton",
input$changeData, input$changeModel) )
}##
##
if(!(input$itemRespon %in% 0:100)){
shinyjs::disable( paste0("goButton",
input$changeData, input$changeModel) )
}##
##
if(input$dataTest){
shinyjs::disable("tipo")
shinyjs::disable("fileIn")
shinyjs::disable("header")
}else{
shinyjs::enable("tipo")
shinyjs::enable("fileIn")
shinyjs::enable("header")
}##
})#====================================================================
####MCMC PANEL ========================================================
output$mcmcPanel <- renderUI({
action <- input[[paste0("goButton",
input$changeData, input$changeModel)]]
####
if(!is.null(action)){
##
if(input$model == ""){
return( .modelSelect() )
}##
##
if(input$model == "2pno" && action == 0){
return( .mcmc2pnoInfo() )
}##
##
if(input$model == "3pno" && action == 0){
return(.mcmc3pnoInfo())
}##
##
if( action > 0){
####
tabsetPanel(
#
tabPanel("Overview and Diagnostic",
plotOutput( "checkPlot" ),
fluidRow(
column(12, .rhat_text())
)
),#
#
tabPanel("Chain",
br(), br(),
plotOutput( "chainPlot" ),
h3( "Chain" ),
tags$hr(),
fluidRow(
column(5,
uiOutput("datasetInput"),
uiOutput("nchainInput")
),
column(7, .chain_text())
)
),#
#
tabPanel("IRC",
br(), br(),
plotOutput( "IRCPlot" ),
h3( "IRC" ),
tags$hr(),
fluidRow(
column(5,
numericInput( "ItemIRC", "Item:", 1, min = 1,
max = ncol(datamcmc()) ),
p("Please remember that only exist",
code(paste(ncol(datamcmc()), "Items")), ".")
),
column(7, .irc_text())
)
),#
#
tabPanel("Posterior Densities",
br(), br(),
plotOutput( "converPlot" ),
h3( "Posterior Densities" ),
tags$hr(),
fluidRow(
column(5,
selectInput("ParaPosterior", "Choose a Parameter:",
choices = c("Item Parameters",
names(infoParameters()))
),
textInput("ItemsPosterior", "Item or ability:", "",
width = "50%"),
p("Please remember that only exist",
code(paste(ncol(datamcmc()), "Items")), "and",
code(paste(nrow(datamcmc()), "Examinees")), "."),
.ItemsPosterior_text()
),
column(7, .parameter_text())
)
),#
#
tabPanel("Summary",
br(), br(),
dataTableOutput( "contents" ),
h3( "Download" ),
tags$hr(),
fluidRow(
column(5,
selectInput( "dtipo", "Select Data Type:",
choices = c(".csv",".csv2",".txt" ) ),
downloadButton( "downloadData", "Download Table" )),
column(7, .download_text())
)
),#
#
tabPanel("Model Info", br(), br(), uiOutput("modelInfo") )
)####
}##
}#####
})#====================================================================
####CHANGE BUTTON =====================================================
output$changeButton <- renderUI({
actionButton( paste0("goButton", input$changeData, input$changeModel),
"Start MCMC!", style = "color:green" )
})#====================================================================
####DATA ==============================================================
data <- reactive({
##
if (input$dataTest){
inFile <- load("www/MathTest.rda")
inFile <- MathTest
}else {
inFile <- input$fileIn$datapath
}##
##
if ( is.null( inFile ) ){
NULL
} else {
dat <- .readData( inFile, input$tipo, input$header, input$dataTest )
if(is.null(dat) ){
NULL
}else{dat}
}##
})#====================================================================
####RENDER DATA =======================================================
output$dataFile <- renderDataTable({
if(!is.null( data() )){
data() }else{ NULL }
})#====================================================================
####DATA PANEL ========================================================
output$dataPanel <- renderUI({
if(is.null(data()) ){
return( .modelData() )
}else{
return( dataTableOutput( "dataFile" ) )
}
})#====================================================================
#############################MCMC FUNCTION#############################
####DATA MCMC =========================================================
datamcmc <- reactive({
if(!is.null( data() )){
as.data.frame( data() )
#as.data.frame( data()[ , -1 ])
}else{
NULL
}
})#====================================================================
####MCMCLIST ==========================================================
mcmclist <- reactive({
action <- input[[paste0("goButton",
input$changeData, input$changeModel)]]
if(!is.null( datamcmc() ) && !is.null( action )){
if(action == 0) {out <- NULL} else {
isolate({
action
shinyjs::disable(paste0("goButton",
input$changeData, input$changeModel))
shinyjs::disable("model")
shinyjs::disable("itemRespon")
shinyjs::disable("iiter")
shinyjs::disable("burnin")
shinyjs::disable("thin")
shinyjs::disable("changeData")
shinyjs::disable("changeModel")
shinyjs::disable("close")
shinyjs::disable("mcmcPanel")
shinyjs::disable("downloadData")
if(action == 1){
initial <- NULL
} else {
env <- reactiveFileReader(1000, session,
paste0("initialValues",
action - 1, ".RData"),
function( RData,
env = new.env() ) {
load(RData, env)
return(env)
})
initial <- env()[[names(env())[1]]]
if ( is.null(initial) ){
stop( "Error initial.value")
}
}
out <- .mcmc.function( data = datamcmc(), initial.value = initial,
c.prior = prior(),
iter = input$iiter, burning = input$burnin,
thin = input$thin, studyTheta = TRUE,
model = input$model)
vi <- out$information$final.values
save( vi, file = paste0("initialValues", action, ".RData"))
if (action > 1){
file.remove(paste0("initialValues", action - 1, ".RData"))
}
shinyjs::enable(paste0("goButton",
input$changeData, input$changeModel))
shinyjs::enable("itemRespon")
shinyjs::enable("iiter")
shinyjs::enable("burnin")
shinyjs::enable("thin")
shinyjs::enable("changeData")
shinyjs::enable("changeModel")
shinyjs::enable("close")
shinyjs::enable("mcmcPanel")
shinyjs::enable("downloadData")
})
}
return( out )
}else{
NULL
}
})#====================================================================
####INFO PARAMETERS===================================================
infoParameters <- reactive({ table(mcmclist()$diagnostic$diag$Parameter) })
####DIAG ==============================================================
diagn <- reactive({
diag <- mcmclist()$diagnostic$diag
if ( is.null( diag ) ){
return( NULL )
} else {
return( diag )
}
})#====================================================================
####CHECK PLOT ========================================================
output$checkPlot <- renderPlot({
if(is.null( mcmclist() )){
0
} else {
bairt::check.plot( mcmclist(), converg.test = TRUE)
}
})#====================================================================
#DIAGNOSTIC TABLE
output$contents <- renderDataTable({ diagn() })
####IRC PLOT ==========================================================
output$IRCPlot <- renderPlot({
if( is.null( mcmclist() ) ){
0
} else {
if(input$ItemIRC %in% 1:ncol(datamcmc())){
bairt::irc( mcmclist(), item = input$ItemIRC,
main = paste( "IRC Item", input$ItemIRC ) )
}else{
0
}
}
})#====================================================================
####PARAMETER =========================================================
output$converPlot <- renderPlot({
if( is.null( mcmclist() ) ){
0
} else {
parameter <- input$ParaPosterior
if (parameter %in% names(infoParameters())){
items <- .texToNumber(input$ItemsPosterior, infoParameters(), parameter)
if(!is.null(items) && (items %in% 1:infoParameters()[parameter])){
bairt::parameter.plot(mcmclist(),
items, parameter)
}
}else {
bairt::parameter.plot(mcmclist())
}
}
})#====================================================================
####CHAIN PLOT ========================================================
output$chainPlot <- renderPlot({
##
if( is.null( input$dataset ) || is.null(mcmclist())
|| is.null(input$nchain) ){
0
} else {
#
if (input$dataset != "theta"){
if( input$nchain %in% 1:ncol(datamcmc()) ){
bairt::chain.study(mcmclist(), parameter = input$dataset,
chain = input$nchain, line = TRUE)
}else{ 0 }
}#
#
if (input$dataset == "theta"){
if( input$nchain %in% 1:nrow(datamcmc()) ){
bairt::chain.study(mcmclist(), parameter = input$dataset,
chain = input$nchain, line = TRUE)
}else{ 0 }
}#
}##
})#====================================================================
####MODEL INFO ========================================================
output$modelInfo <- renderUI({
if(input$model == "2pno" ){
return( .mcmc2pnoInfo() )
}
if(input$model == "3pno" ){
return(.mcmc3pnoInfo())
}
})#====================================================================
####PRIOR =============================================================
prior <- reactive({
if( input$itemRespon == 0 ){
prior <- c( 1, 1) } else {
alpha <- ( 20 *( 1 / input$itemRespon ) ) + 1
alpha <- round( alpha, digits = 2 )
beta <- ( 20 * ( 1 - ( 1 / input$itemRespon ) ) ) + 1
beta <- round( beta, digits = 2)
prior <- c( alpha, beta )
}
return( prior )
})#====================================================================
####PRIOR TEXT ========================================================
output$priorText <- renderUI({
if (input$itemRespon %in% 0:100){
return( h5(paste( "c Prior Beta (",
prior()[ 1 ], ",", prior()[ 2 ], ")" ) ))
} else {
return( h5( "ERROR: Value", style = "color:red" ) )
}
})#====================================================================
####MCMC TEXT =========================================================
output$mcmctex <- renderUI({
k <- (input$iiter - input$burnin)/(input$thin)
##
if(input$iiter %in% 6:100000 && input$burnin %in% 0:100000
&& input$thin %in% 1:100){
#
if( k > 0 && .whole(k) ){
return( h5("OK!") )
}else{
if(input$iiter < input$burnin){
return( h5("ERROR: Iter < Burnin", style = "color:red") )
}
if(input$iiter == input$burnin){
return( h5("ERROR: Iter = Burnin", style = "color:red") )
}
if(!(input$iiter == input$burnin) && !(input$iiter < input$burnin)){
return( h5("ERROR: (Iter-Burnin)/Thin is not a whole number",
style = "color:red") )
}
}#
} else { h5("ERROR: Value", style = "color:red") }##
})#=====================================================================
####CHAIN DATASET ======================================================
output$datasetInput <- renderUI({
selectInput( "dataset", "Choose a Parameter:",
choices = names(infoParameters()) )
})#=====================================================================
####CHAIN INPUT ========================================================
output$nchainInput <- renderUI({
##
if(!is.null(input$dataset)){
#
if(input$dataset == "theta"){
nameBUtton <- "Examiner's Ability"
name <- "Examinees"
maxValue <- nrow(datamcmc())
}else{
nameBUtton <- "Item"
name <- "Items"
maxValue <- ncol(datamcmc())
}#
}else{
nameBUtton <- "Item"
name <- "Items"
maxValue <- 1
}##
div(
numericInput( "nchain",
paste0(nameBUtton, ":"), 1, min = 1, max = maxValue),
p("Please remember that only exist",
code(paste(maxValue, name)), ".")
)
})#=====================================================================
####TEXT GO ============================================================
output$textGo <- renderUI({
if(!is.null(mcmclist()) &&
input[[paste0("goButton", input$changeData, input$changeModel)]] > 0){
div(
br(),
"Press",code("Start MCMC!"), "to continue MCMC."
)
} else {""}
})#====================================================================
####DOWNLOAD DATA =====================================================
output$downloadData <- downloadHandler(
filename = function() { paste( "Summary-", Sys.Date(),
.csvf( input$dtipo ), sep = '' ) },
content = function( file ) {
.dataWrite( diagn(), input$dtipo,file )
}
)#=====================================================================
####DATA TEST =========================================================
output$testData <- renderUI({
if(is.null(data())){
div(
p("No Data")
)
}else{
if(ncol(data()) < 2 || nrow(data()) < 2){
div( p("ERROR: Data is incorrect"), style = "color:red" )
}else{
div(
p("Please note that:"),
p(code("Number of Items:"), paste( ncol(data()) ) ),
p(code("Number of Examinees:"), paste( nrow(data()) ) )
)
}
}
})#====================================================================
####DATA CONTINUE =====================================================
output$dataContinue <- renderUI({
if(is.null(data())){
div("")
}else{
if(ncol(data()) < 2 || nrow(data()) < 2){
div( "" )
}else{
div(
p("Press",code("Data is Ok!"), "to continue.")
)
}
}
})#====================================================================
####DATA INFO =========================================================
output$dataInfo <- renderUI({
if( !is.null(data()) ){
if(is.null(input$fileIn)){
name <- "MathTest"
}else{
name <- input$fileIn$name
}
div(
column(4, p( strong("Data:"), name)),
column(4, p( strong("Items:"), paste( ncol(datamcmc()) ) )),
column(4, p( strong("Examinees:"), paste( nrow(datamcmc()) ) ))
)
}else{div("")}
})#=====================================================================
})
Try the bairt package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.