inst/Shiny/server.R
In kylehamilton/CTTShiny: Classical Test Theory via Shiny
library(shiny)
library(shinyAce)
library(psych)
library(ltm)
library(CTT)
shinyServer(function(input, output) {
options(warn=-1)
check <- reactive({
if (input$colname == 0) {
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
} else {
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
}
})
bs <- reactive({
if (input$colname == 0) {
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
total <- rowSums(dat, na.rm=T)
result <- describe(total)[2:13]
row.names(result) <- "Total "
result
} else {
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
total <- rowSums(dat, na.rm=T)
result <- describe(total)[2:13]
row.names(result) <- "Total "
result
}
})
alpha.result <- reactive({
if (input$colname == 0) {
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
result1 <- cronbach.alpha(dat)
result2 <- alpha(dat, check.keys=F)
result2 <- round(result2$alpha.drop,3)
list(result1, "Reliability if the item is dropped/deleted"=result2)
} else {
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
result1 <- cronbach.alpha(dat)
result2 <- alpha(dat, check.keys=F)
result2 <- round(result2$alpha.drop,3)
list(result1, "Reliability if the item is dropped/deleted"=result2)
}
})
item.analysis <- reactive({
if (input$colname == 0) {
# Item disctimination
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
dat <- as.data.frame(dat)
itemd <- function(data) {
alphaRes <- alpha(data, cumulative=T, check.keys=F, delete=F)
item.mean <- round(alphaRes$item.stats$mean,3)
r.drop <- round(ifelse(is.na(alphaRes$item.stats$r.drop), 0, alphaRes$item.stats$r.drop),3) #
m <- mean(rowSums(data))
sd <- sd(rowSums(data))
totalDat <- cbind(data,rowSums(data))
sortDat <- totalDat[order(-totalDat[,length(totalDat)]),]
pbi <- c()
itemD <- c()
rownames(sortDat) <- c(1:nrow(sortDat))
highDat <- head(sortDat,nrow(sortDat) %/% 3)
lowDat <- tail(sortDat,nrow(sortDat) %/% 3)
for (i in 1:length(data)) {
mhigh <- mean(subset(totalDat[,length(totalDat)],(data[,i] == 1)))
mlow <- mean(subset(totalDat[,length(totalDat)],(data[,i] == 0)))
imean <- mean(data[,i])
itemD[i] <- round((mean(highDat[,i]) - mean(lowDat[,i])),3)
if (imean == 1 || imean == 0) {
pbi[i] <- 0
} else {
pbi[i] <- round(((mhigh - mlow) / sd) * sqrt(imean * (1 - imean)),3)
}
}
colid <- data.frame(colnames(dat), item.mean, r.drop, pbi, itemD)
colnames(colid) <- c("Item","Item_Mean","I-R_Correl","I-T_Correl","U-L_DISC")
return(colid)
}
result1 <- itemd(dat)
# AENO
x <- read.table(text=input$text1, sep="\t")
dat <- as.data.frame(x)
aeno.ind <- function(data) {
aeno.ind <- c()
for (i in 1:ncol(data)) {
x <- table(data[,i])/nrow(data)
ctgr <- c()
for (j in 1:length(x)) {
ctgr[j] <- x[j]*(log10(x[j])/log10(2))
}
aeno.ind[i] <- round(2^(abs((sum(ctgr[1:length(x)])))),3)
}
aenos <- data.frame(colnames(dat), aeno.ind)
colnames(aenos) <- c("Item","AENO")
return(aenos)
}
result2 <- aeno.ind(dat)
merge(result1, result2)
} else {
# Item disctimination
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
dat <- as.data.frame(dat)
itemd <- function(data) {
alphaRes <- alpha(data, cumulative=T, check.keys=F, delete=F)
item.mean <- round(alphaRes$item.stats$mean,3)
r.drop <- round(ifelse(is.na(alphaRes$item.stats$r.drop), 0, alphaRes$item.stats$r.drop),3)
m <- mean(rowSums(data))
sd <- sd(rowSums(data))
totalDat <- cbind(data,rowSums(data))
sortDat <- totalDat[order(-totalDat[,length(totalDat)]),]
pbi <- c()
itemD <- c()
rownames(sortDat) <- c(1:nrow(sortDat))
highDat <- head(sortDat,nrow(sortDat) %/% 3)
lowDat <- tail(sortDat,nrow(sortDat) %/% 3)
for (i in 1:length(data)) {
mhigh <- mean(subset(totalDat[,length(totalDat)],(data[,i] == 1)))
mlow <- mean(subset(totalDat[,length(totalDat)],(data[,i] == 0)))
imean <- mean(data[,i])
itemD[i] <- round((mean(highDat[,i]) - mean(lowDat[,i])),3)
if (imean == 1 || imean == 0) {
pbi[i] <- 0
} else {
pbi[i] <- round(((mhigh - mlow) / sd) * sqrt(imean * (1 - imean)),3)
}
}
colid <- data.frame(colnames(dat), item.mean, r.drop, pbi, itemD)
colnames(colid) <- c("Item","Item_Mean","I-R_Correl","I-T_Correl","U-L_DISC")
return(colid)
}
result1 <- itemd(dat)
# AENO
x <- read.csv(text=input$text1, sep="\t")
dat <- as.data.frame(x)
aeno.ind <- function(data) {
aeno.ind <- c()
for (i in 1:ncol(data)) {
x <- table(data[,i])/nrow(data)
ctgr <- c()
for (j in 1:length(x)) {
ctgr[j] <- x[j]*(log10(x[j])/log10(2))
}
aeno.ind[i] <- round(2^(abs((sum(ctgr[1:length(x)])))),3)
}
aenos <- data.frame(colnames(dat), aeno.ind)
colnames(aenos) <- c("Item","AENO")
return(aenos)
}
result2 <- aeno.ind(dat)
merge(result1, result2)
}
})
distractor <- reactive({
if (input$type == "frequency") {
if (input$colname == 0) {
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
distractor.analysis(x, ans)
} else {
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
distractor.analysis(x, ans)
}
} else {
if (input$colname == 0) {
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
distractor.analysis(x, ans, p.table = T)
} else {
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
distractor.analysis(x, ans, p.table = T)
}
}
})
makedistPlot <- function(){
if (input$colname == 0) {
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
x <- score(x, ans, output.scored=TRUE)$scored
x <- rowSums(x, na.rm=T)
} else {
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
x <- score(x, ans, output.scored=TRUE)$scored
x <- rowSums(x, na.rm=T)
}
simple.bincount <- function(x, breaks) {
nx <- length(x)
nbreaks <- length(breaks)
counts <- integer(nbreaks - 1)
for (i in 1:nx) {
lo <- 1
hi <- nbreaks
if (breaks[lo] <= x[i] && x[i] <= breaks[hi]) {
while (hi - lo >= 2) {
new <- (hi + lo) %/% 2
if(x[i] > breaks[new])
lo <- new
else
hi <- new
}
counts[lo] <- counts[lo] + 1
}
}
return(counts)
}
nclass <- nclass.FD(x)
breaks <- pretty(x, nclass)
counts <- simple.bincount(x, breaks)
counts.max <- max(counts)
h <- hist(x, na.rm= T, las=1, breaks="FD", xlab= "Red vertical line shows the mean.",
ylim=c(0, counts.max*1.2), main="", col = "cyan")
rug(x)
abline(v = mean(x, na.rm=T), col = "red", lwd = 2)
xfit <- seq(min(x, na.rm=T), max(x, na.rm=T))
yfit <- dnorm(xfit, mean = mean(x, na.rm=T), sd = sd(x, na.rm=T))
yfit <- yfit * diff(h$mids[1:2]) * length(x)
lines(xfit, yfit, col = "blue", lwd = 2)
}
output$distPlot <- renderPlot({
print(makedistPlot())
})
makeboxPlot <- function(){
if (input$colname == 0) {
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
x <- score(x, ans, output.scored=TRUE)$scored
x <- rowSums(x, na.rm=T)
} else {
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
x <- score(x, ans, output.scored=TRUE)$scored
x <- rowSums(x, na.rm=T)
}
boxplot(x, horizontal=TRUE, xlab= "Mean and +/-1 SD are displayed in red.")
stripchart(x, pch = 16, add = TRUE)
points(mean(x, na.rm=T), 0.9, pch = 18, col = "red", cex = 2)
arrows(mean(x, na.rm=T), 0.9, mean(x, na.rm=T) + sd(x, na.rm=T), length = 0.1, angle = 45, col = "red")
arrows(mean(x, na.rm=T), 0.9, mean(x, na.rm=T) - sd(x, na.rm=T), length = 0.1, angle = 45, col = "red")
}
output$boxPlot <- renderPlot({
print(makeboxPlot())
})
testnorm <- reactive({
if (input$colname == 0) {
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
x <- score(x, ans, output.scored=TRUE)$scored
x <- rowSums(x, na.rm=T)
} else {
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
x <- score(x, ans, output.scored=TRUE)$scored
x <- rowSums(x, na.rm=T)
}
list(ks.test(scale(x), "pnorm"), shapiro.test(x))
})
makeqqPlot <- function(){
if (input$colname == 0) {
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
x <- score(x, ans, output.scored=TRUE)$scored
x <- rowSums(x, na.rm=T)
} else {
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
x <- score(x, ans, output.scored=TRUE)$scored
x <- rowSums(x, na.rm=T)
}
qqnorm(x, las=1)
qqline(x, col=2)
}
output$qqPlot <- renderPlot({
print(makeqqPlot())
})
info <- reactive({
info1 <- paste("This analysis was performed on ", format(Sys.time(), "%A, %B %d %Y at %I:%M:%S %p"), ".", sep = "")
info2 <- paste(strsplit(R.version$version.string, " \\(")[[1]][1], " was used for this session.", sep = "")
info3 <- paste("Package version infomation for this session:")
info4 <- paste("shiny", packageVersion("shiny"))
info5 <- paste("shinyAce", packageVersion("shinyAce"))
info6 <- paste("psych", packageVersion("psych"))
info7 <- paste("CTT", packageVersion("CTT"))
info8 <- paste("ltm", packageVersion("ltm"))
cat(sprintf(info1), "\n")
cat(sprintf(info2), "\n")
cat(sprintf(info3), "\n")
cat(sprintf(info4), "\n")
cat(sprintf(info5), "\n")
cat(sprintf(info6), "\n")
cat(sprintf(info7), "\n")
cat(sprintf(info8), "\n")
})
output$info.out <- renderPrint({
info()
})
output$check <- renderTable({
head(check(), n = 10)
}, digits = 0)
output$textarea.out <- renderPrint({
bs()
})
output$alpha.result.out <- renderPrint({
alpha.result()
})
output$item.analysis.out <- renderPrint({
item.analysis()
})
output$distractor.out <- renderPrint({
distractor()
})
output$testnorm.out <- renderPrint({
testnorm()
})
})
kylehamilton/CTTShiny documentation built on May 20, 2019, 7:31 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.
library(shiny)
library(shinyAce)
library(psych)
library(ltm)
library(CTT)
shinyServer(function(input, output) {
options(warn=-1)
check <- reactive({
if (input$colname == 0) {
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
} else {
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
}
})
bs <- reactive({
if (input$colname == 0) {
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
total <- rowSums(dat, na.rm=T)
result <- describe(total)[2:13]
row.names(result) <- "Total "
result
} else {
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
total <- rowSums(dat, na.rm=T)
result <- describe(total)[2:13]
row.names(result) <- "Total "
result
}
})
alpha.result <- reactive({
if (input$colname == 0) {
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
result1 <- cronbach.alpha(dat)
result2 <- alpha(dat, check.keys=F)
result2 <- round(result2$alpha.drop,3)
list(result1, "Reliability if the item is dropped/deleted"=result2)
} else {
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
result1 <- cronbach.alpha(dat)
result2 <- alpha(dat, check.keys=F)
result2 <- round(result2$alpha.drop,3)
list(result1, "Reliability if the item is dropped/deleted"=result2)
}
})
item.analysis <- reactive({
if (input$colname == 0) {
# Item disctimination
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
dat <- as.data.frame(dat)
itemd <- function(data) {
alphaRes <- alpha(data, cumulative=T, check.keys=F, delete=F)
item.mean <- round(alphaRes$item.stats$mean,3)
r.drop <- round(ifelse(is.na(alphaRes$item.stats$r.drop), 0, alphaRes$item.stats$r.drop),3) #
m <- mean(rowSums(data))
sd <- sd(rowSums(data))
totalDat <- cbind(data,rowSums(data))
sortDat <- totalDat[order(-totalDat[,length(totalDat)]),]
pbi <- c()
itemD <- c()
rownames(sortDat) <- c(1:nrow(sortDat))
highDat <- head(sortDat,nrow(sortDat) %/% 3)
lowDat <- tail(sortDat,nrow(sortDat) %/% 3)
for (i in 1:length(data)) {
mhigh <- mean(subset(totalDat[,length(totalDat)],(data[,i] == 1)))
mlow <- mean(subset(totalDat[,length(totalDat)],(data[,i] == 0)))
imean <- mean(data[,i])
itemD[i] <- round((mean(highDat[,i]) - mean(lowDat[,i])),3)
if (imean == 1 || imean == 0) {
pbi[i] <- 0
} else {
pbi[i] <- round(((mhigh - mlow) / sd) * sqrt(imean * (1 - imean)),3)
}
}
colid <- data.frame(colnames(dat), item.mean, r.drop, pbi, itemD)
colnames(colid) <- c("Item","Item_Mean","I-R_Correl","I-T_Correl","U-L_DISC")
return(colid)
}
result1 <- itemd(dat)
# AENO
x <- read.table(text=input$text1, sep="\t")
dat <- as.data.frame(x)
aeno.ind <- function(data) {
aeno.ind <- c()
for (i in 1:ncol(data)) {
x <- table(data[,i])/nrow(data)
ctgr <- c()
for (j in 1:length(x)) {
ctgr[j] <- x[j]*(log10(x[j])/log10(2))
}
aeno.ind[i] <- round(2^(abs((sum(ctgr[1:length(x)])))),3)
}
aenos <- data.frame(colnames(dat), aeno.ind)
colnames(aenos) <- c("Item","AENO")
return(aenos)
}
result2 <- aeno.ind(dat)
merge(result1, result2)
} else {
# Item disctimination
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
dat <- as.data.frame(dat)
itemd <- function(data) {
alphaRes <- alpha(data, cumulative=T, check.keys=F, delete=F)
item.mean <- round(alphaRes$item.stats$mean,3)
r.drop <- round(ifelse(is.na(alphaRes$item.stats$r.drop), 0, alphaRes$item.stats$r.drop),3)
m <- mean(rowSums(data))
sd <- sd(rowSums(data))
totalDat <- cbind(data,rowSums(data))
sortDat <- totalDat[order(-totalDat[,length(totalDat)]),]
pbi <- c()
itemD <- c()
rownames(sortDat) <- c(1:nrow(sortDat))
highDat <- head(sortDat,nrow(sortDat) %/% 3)
lowDat <- tail(sortDat,nrow(sortDat) %/% 3)
for (i in 1:length(data)) {
mhigh <- mean(subset(totalDat[,length(totalDat)],(data[,i] == 1)))
mlow <- mean(subset(totalDat[,length(totalDat)],(data[,i] == 0)))
imean <- mean(data[,i])
itemD[i] <- round((mean(highDat[,i]) - mean(lowDat[,i])),3)
if (imean == 1 || imean == 0) {
pbi[i] <- 0
} else {
pbi[i] <- round(((mhigh - mlow) / sd) * sqrt(imean * (1 - imean)),3)
}
}
colid <- data.frame(colnames(dat), item.mean, r.drop, pbi, itemD)
colnames(colid) <- c("Item","Item_Mean","I-R_Correl","I-T_Correl","U-L_DISC")
return(colid)
}
result1 <- itemd(dat)
# AENO
x <- read.csv(text=input$text1, sep="\t")
dat <- as.data.frame(x)
aeno.ind <- function(data) {
aeno.ind <- c()
for (i in 1:ncol(data)) {
x <- table(data[,i])/nrow(data)
ctgr <- c()
for (j in 1:length(x)) {
ctgr[j] <- x[j]*(log10(x[j])/log10(2))
}
aeno.ind[i] <- round(2^(abs((sum(ctgr[1:length(x)])))),3)
}
aenos <- data.frame(colnames(dat), aeno.ind)
colnames(aenos) <- c("Item","AENO")
return(aenos)
}
result2 <- aeno.ind(dat)
merge(result1, result2)
}
})
distractor <- reactive({
if (input$type == "frequency") {
if (input$colname == 0) {
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
distractor.analysis(x, ans)
} else {
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
distractor.analysis(x, ans)
}
} else {
if (input$colname == 0) {
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
distractor.analysis(x, ans, p.table = T)
} else {
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
dat <- score(x, ans, output.scored=TRUE)$scored
distractor.analysis(x, ans, p.table = T)
}
}
})
makedistPlot <- function(){
if (input$colname == 0) {
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
x <- score(x, ans, output.scored=TRUE)$scored
x <- rowSums(x, na.rm=T)
} else {
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
x <- score(x, ans, output.scored=TRUE)$scored
x <- rowSums(x, na.rm=T)
}
simple.bincount <- function(x, breaks) {
nx <- length(x)
nbreaks <- length(breaks)
counts <- integer(nbreaks - 1)
for (i in 1:nx) {
lo <- 1
hi <- nbreaks
if (breaks[lo] <= x[i] && x[i] <= breaks[hi]) {
while (hi - lo >= 2) {
new <- (hi + lo) %/% 2
if(x[i] > breaks[new])
lo <- new
else
hi <- new
}
counts[lo] <- counts[lo] + 1
}
}
return(counts)
}
nclass <- nclass.FD(x)
breaks <- pretty(x, nclass)
counts <- simple.bincount(x, breaks)
counts.max <- max(counts)
h <- hist(x, na.rm= T, las=1, breaks="FD", xlab= "Red vertical line shows the mean.",
ylim=c(0, counts.max*1.2), main="", col = "cyan")
rug(x)
abline(v = mean(x, na.rm=T), col = "red", lwd = 2)
xfit <- seq(min(x, na.rm=T), max(x, na.rm=T))
yfit <- dnorm(xfit, mean = mean(x, na.rm=T), sd = sd(x, na.rm=T))
yfit <- yfit * diff(h$mids[1:2]) * length(x)
lines(xfit, yfit, col = "blue", lwd = 2)
}
output$distPlot <- renderPlot({
print(makedistPlot())
})
makeboxPlot <- function(){
if (input$colname == 0) {
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
x <- score(x, ans, output.scored=TRUE)$scored
x <- rowSums(x, na.rm=T)
} else {
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
x <- score(x, ans, output.scored=TRUE)$scored
x <- rowSums(x, na.rm=T)
}
boxplot(x, horizontal=TRUE, xlab= "Mean and +/-1 SD are displayed in red.")
stripchart(x, pch = 16, add = TRUE)
points(mean(x, na.rm=T), 0.9, pch = 18, col = "red", cex = 2)
arrows(mean(x, na.rm=T), 0.9, mean(x, na.rm=T) + sd(x, na.rm=T), length = 0.1, angle = 45, col = "red")
arrows(mean(x, na.rm=T), 0.9, mean(x, na.rm=T) - sd(x, na.rm=T), length = 0.1, angle = 45, col = "red")
}
output$boxPlot <- renderPlot({
print(makeboxPlot())
})
testnorm <- reactive({
if (input$colname == 0) {
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
x <- score(x, ans, output.scored=TRUE)$scored
x <- rowSums(x, na.rm=T)
} else {
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
x <- score(x, ans, output.scored=TRUE)$scored
x <- rowSums(x, na.rm=T)
}
list(ks.test(scale(x), "pnorm"), shapiro.test(x))
})
makeqqPlot <- function(){
if (input$colname == 0) {
x <- read.table(text=input$text1, sep="\t")
x <- as.matrix(x)
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
x <- score(x, ans, output.scored=TRUE)$scored
x <- rowSums(x, na.rm=T)
} else {
x <- read.csv(text=input$text1, sep="\t")
ans <- read.delim(text=input$text2, sep="\t", fill=TRUE, header=FALSE, stringsAsFactors=FALSE)
ans <- as.character(ans)
x <- score(x, ans, output.scored=TRUE)$scored
x <- rowSums(x, na.rm=T)
}
qqnorm(x, las=1)
qqline(x, col=2)
}
output$qqPlot <- renderPlot({
print(makeqqPlot())
})
info <- reactive({
info1 <- paste("This analysis was performed on ", format(Sys.time(), "%A, %B %d %Y at %I:%M:%S %p"), ".", sep = "")
info2 <- paste(strsplit(R.version$version.string, " \\(")[[1]][1], " was used for this session.", sep = "")
info3 <- paste("Package version infomation for this session:")
info4 <- paste("shiny", packageVersion("shiny"))
info5 <- paste("shinyAce", packageVersion("shinyAce"))
info6 <- paste("psych", packageVersion("psych"))
info7 <- paste("CTT", packageVersion("CTT"))
info8 <- paste("ltm", packageVersion("ltm"))
cat(sprintf(info1), "\n")
cat(sprintf(info2), "\n")
cat(sprintf(info3), "\n")
cat(sprintf(info4), "\n")
cat(sprintf(info5), "\n")
cat(sprintf(info6), "\n")
cat(sprintf(info7), "\n")
cat(sprintf(info8), "\n")
})
output$info.out <- renderPrint({
info()
})
output$check <- renderTable({
head(check(), n = 10)
}, digits = 0)
output$textarea.out <- renderPrint({
bs()
})
output$alpha.result.out <- renderPrint({
alpha.result()
})
output$item.analysis.out <- renderPrint({
item.analysis()
})
output$distractor.out <- renderPrint({
distractor()
})
output$testnorm.out <- renderPrint({
testnorm()
})
})
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.