R/facet.b.R
In hyunsooseol/snowIRT: Item Response Theory for jamovi
# This file is a generated template, your changes will not be overwritten
#' @importFrom R6 R6Class
#' @import jmvcore
#' @importFrom jmvcore toB64
#' @importFrom TAM tam.mml.mfr
#' @importFrom TAM tam.personfit
#' @importFrom TAM tam.wle
#' @importFrom TAM tam.threshold
#' @importFrom TAM msq.itemfit
#' @importFrom TAM tam.wle
#' @importFrom ShinyItemAnalysis ggWrightMap
#' @importFrom gtheory gstudy
#' @importFrom gtheory dstudy
#' @import ggplot2
#' @export
facetClass <- if (requireNamespace('jmvcore', quietly=TRUE)) R6::R6Class(
"facetClass",
inherit = facetBase,
private = list(
.init = function() {
if (is.null(self$data) | is.null(self$options$facet)) {
self$results$instructions$setVisible(visible = TRUE)
}
self$results$instructions$setContent(
"<html>
<head>
</head>
<body>
<div class='instructions'>
<p>____________________________________________________________________________________</p>
<p>1. If your data format is in wide, you need to convert it to <b>long format</b> in order to run analysis.</p>
<p>2. The variables should be named <b>'subject'</b>,<b>'rater'</b> and <b>'task'</b> respectively. Any other variable name will result in an error message.</b>
<p>3. In the Facet variable box, you must put the variable <b>'rater'</b> first.</p>
<p>4. You can currently only put <b>two variables</b> in the Facet variable box.</p>
<p>5. We recommend using <a href='https://www.winsteps.com' target = '_blank'>Facet software</a> for analyzing various experimental designs.</p>
<p>6. Feature requests and bug reports can be made on my <a href='https://github.com/hyunsooseol/snowIRT/issues' target = '_blank'>GitHub</a>.</p>
<p>____________________________________________________________________________________</p>
</div>
</body>
</html>"
)
if (self$options$ifit)
self$results$ifit$setNote(
"Note",
"Display 'X' when both Infit and Outfit values exceed 1.5."
)
if (self$options$pfit)
self$results$pfit$setNote(
"Note",
"Display 'X' when both Infit and Outfit values exceed 1.5."
)
if(isTRUE(self$options$plot1)){
width <- self$options$width1
height <- self$options$height1
self$results$plot1$setSize(width, height)
}
if(isTRUE(self$options$plot2)){
width <- self$options$width2
height <- self$options$height2
self$results$plot2$setSize(width, height)
}
if(isTRUE(self$options$plot3)){
width <- self$options$width3
height <- self$options$height3
self$results$plot3$setSize(width, height)
}
if(isTRUE(self$options$plot4)){
width <- self$options$width4
height <- self$options$height4
self$results$plot4$setSize(width, height)
}
if(isTRUE(self$options$plot5)){
width <- self$options$width5
height <- self$options$height5
self$results$plot5$setSize(width, height)
}
if(isTRUE(self$options$plot6)){
width <- self$options$width6
height <- self$options$height6
self$results$plot6$setSize(width, height)
}
if(isTRUE(self$options$plot7)){
width <- self$options$width7
height <- self$options$height7
self$results$plot7$setSize(width, height)
}
if(isTRUE(self$options$plot8)){
width <- self$options$width8
height <- self$options$height8
self$results$plot8$setSize(width, height)
}
},
.run = function() {
# Example------------------------------
# Wide to long for dataset using reshape packate
# data <- read.csv("guilford.csv")
# attach(data)
# long<- reshape::melt(data, id.vars =c("subject","rater"),
# variable_name = "task")
#-----------------------------------------
# facet<- read.csv("long.csv")
# attach(facet)
# formula <- ~ rater*task+step
# facets = dplyr::select(facet, rater:task)
#
# res <- TAM::tam.mml.mfr(value,
# facets = facets,
# formulaA = formula,
# pid=subject)
# res1 <- res$xsi.facets
#---------------------------------------------
if (is.null(self$options$dep) ||
is.null(self$options$id) ||
is.null(self$options$facet)) return()
dep <- self$options$dep
id <- self$options$id
facets <- self$options$facet
data <- self$data
data <- na.omit(data)
data <- as.data.frame(data)
# Formula---------------
facets <- vapply(facets, function(x) jmvcore::composeTerm(x), '')
facets <- paste0(facets, collapse='*')
formula <- as.formula(paste0('~ step+', facets))
facets = dplyr::select(data, self$options$facet)
#self$results$text$setContent(formula)
res <- TAM::tam.mml.mfr(resp = data[[self$options$dep]],
facets = facets,
pid = data[[self$options$id]],
formulaA = formula)
#self$results$text1$setContent(res)
#self$results$text1$setContent(res$xsi.facets)
if(isTRUE(self$options$plot5)){
image <- self$results$plot5
image$setState(res)
}
if(isTRUE(self$options$plot6)){
image <- self$results$plot6
image$setState(res)
}
# Facet estimates--------------------------
res1 <- res$xsi.facets # Whole estimates
# Rater X Subject measure table (Not running with large subjects now)--------------
# if(isTRUE(self$options$rs | self$options$plot5)){
#
# facets = dplyr::select(data, subject:task)
# formula <- ~ rater*subject+task +step
#
# out <- TAM::tam.mml.mfr(resp = data[[self$options$dep]],
# facets = facets,
# pid = data[[self$options$id]],
# formulaA = formula)
# out1 <- out$xsi.facets
#
# if(isTRUE(self$options$sifit))
# {
#
# sifit <- TAM::msq.itemfit(out)
# sifit <- as.data.frame(sifit$itemfit)
#
# sifit<- dplyr::select(sifit, c("item", "Outfit_t","Outfit_p"))
#
# # THe order !!!(rater * item), otherwise table will be empty!!!
# sifit$item <- gsub("-rater", "rater", sifit$item)
# sifit$item <- gsub("task", "", sifit$item)
#
# sifit<- sifit |> tidyr::separate(item, c("rater","subject", "task"), "-")
#
# sifit<- data.frame(sifit)
# #self$results$text1$setContent(sifit)
# # Item fit table------------
#
# table <- self$results$sifit
#
# names <- dimnames(sifit)[[1]]
#
#
# for (name in names) {
#
# row <- list()
#
# row[["rater"]] <- sifit[name, 1]
# row[["subject"]] <- sifit[name, 2]
# row[["task"]] <- sifit[name, 3]
# row[["outfit"]] <- sifit[name, 4]
# row[["p"]] <- sifit[name, 5]
#
# table$addRow(rowKey=name, values=row)
#
# }
#
#
# }
#
# #---------------------------
# rs <- subset(out1, out1$facet == "rater:subject")
#
# rs<- rs |> tidyr::separate(parameter, c("rater", "subject"), ":")
# # inter$task <- gsub("task", "", inter$task)
# rs <- data.frame(rs$rater, rs$subject, rs$xsi, rs$se.xsi)
# colnames(rs) <- c("Rater", "Subject","Measure","SE")
#
# # Rater X subject measure table----------------
#
# table<- self$results$rs
#
# rs<- as.data.frame(rs)
#
# self$results$text1$setContent(rs)
#
# names <- dimnames(rs)[[1]]
#
#
# for (name in names) {
#
# row <- list()
#
# row[["rater"]] <- rs[name, 1]
# row[["subject"]] <- rs[name, 2]
# row[["measure"]] <- rs[name, 3]
# row[["se"]] <- rs[name, 4]
#
# table$addRow(rowKey=name, values=row)
#
# }
#
# image <- self$results$plot5
# image$setState(rs)
#
# }
#
# Task measure----------------------------
im <- subset(res1, res1$facet == "task")
im$parameter <- gsub("task", "", im$parameter)
# rater measure----------
rm <- subset(res1, res1$facet == "rater")
#interaction(Raw score)-----------------
if(isTRUE(self$options$raw)){
para<- res$item$item
score<- res$item$M
raw <- data.frame(para, score)
raw$para <- gsub("task", "", raw$para)
raw$para <- gsub("-rater", "rater", raw$para)
raw<- raw |> tidyr::separate(para, c("rater", "item"), "-")
table <- self$results$raw
names <- dimnames(raw)[[1]]
for (name in names) {
row <- list()
row[["rater"]] <- raw[name, 1]
row[["task"]] <- raw[name, 2]
row[["score"]] <- raw[name, 3]
table$addRow(rowKey=name, values=row)
}
}
# interaction measure-------
inter <- subset(res1, res1$facet == "rater:task")
inter<- inter |> tidyr::separate(parameter, c("rater", "task"), ":")
inter$task <- gsub("task", "", inter$task)
inter <- data.frame(inter$rater, inter$task, inter$xsi, inter$se.xsi)
colnames(inter) <- c("Rater", "Task","Measure","SE")
# step measure-----------
sm <- subset(res1, res1$facet == "step")
#---------------------------------------------------------------------
# Person ability----------
persons <- TAM::tam.wle(res)
per <-data.frame(persons$pid, persons$PersonScores,
persons$theta, persons$error,
persons$WLE.rel)
# WLE Reliability-------
pw<- as.vector(per[[5]])[1]
self$results$text$setContent(pw)
# Wrightmap plot---------
if(isTRUE(self$options$plot4)){
itemm<- data.frame(im$parameter, im$xsi)
# added rater measure into item-------
rmm <- subset(res1, res1$facet == "rater")
rmm<- data.frame(rmm$parameter, rmm$xsi)
colnames(rmm) <- c("im.parameter", "im.xsi")
itemm <- rbind(itemm, rmm)
#---------------------------------
colnames(itemm) <- c("vars", "measure")
itemm$vars <- gsub("task", "", itemm$vars)
#self$results$text1$setContent(itemm)
vars <- as.vector(itemm[[1]])
ime <- as.vector(itemm[[2]])
pme <- as.vector(per[[3]])
image <- self$results$plot4
state <- list(pme, ime, vars)
image$setState(state)
}
# Task measure table----------------
table<- self$results$im
im<- as.data.frame(im)
dif<- as.vector(im[[3]])
se<- as.vector(im[[4]])
items <- as.vector(im[[1]])
for (i in seq_along(items)) {
row <- list()
row[["measure"]] <-dif[i]
row[["se"]] <- se[i]
table$addRow(rowKey = items[i], values = row)
}
# Item bar plot----------
if(isTRUE(self$options$plot2)){
im <- as.data.frame(im)
colnames(im) <- c("Task", "facet", "Value", "SE")
# Rater bar plot--------
image <- self$results$plot2
image$setState(im)
}
# Rater measure table----------------
table<- self$results$rm
rm<- as.data.frame(rm)
dif<- as.vector(rm[[3]])
se<- as.vector(rm[[4]])
items <- as.vector(rm[[1]])
for (i in seq_along(items)) {
row <- list()
row[["measure"]] <-dif[i]
row[["se"]] <- se[i]
table$addRow(rowKey = items[i], values = row)
}
# Rater bar plot----------
if(isTRUE(self$options$plot1)){
rm<- as.data.frame(rm)
colnames(rm) <- c("Rater", "facet", "Value", "SE")
# Rater bar plot--------
image <- self$results$plot1
image$setState(rm)
}
# Interaction measure table----------------
table<- self$results$inter
inter<- as.data.frame(inter)
names <- dimnames(inter)[[1]]
# rater <- as.vector(inter[[1]])
# task <- as.vector(inter[[2]])
# dif<- as.vector(inter[[3]])
# se<- as.vector(inter[[4]])
#items <- as.vector(inter[[1]])
# for (i in seq_along(items)) {
#
# row <- list()
#
# row[["task"]] <- task[i]
# row[["measure"]] <-dif[i]
# row[["se"]] <- se[i]
#
# table$addRow(rowKey = items[i], values = row)
# }
for (name in names) {
row <- list()
row[["rater"]] <- inter[name, 1]
row[["task"]] <- inter[name, 2]
row[["measure"]] <- inter[name, 3]
row[["se"]] <- inter[name, 4]
table$addRow(rowKey=name, values=row)
}
# Interaction plot--------------
image <- self$results$plot3
image$setState(inter)
# Step measure table----------------
table<- self$results$sm
sm<- as.data.frame(sm)
dif<- as.vector(sm[[3]])
se<- as.vector(sm[[4]])
items <- as.vector(sm[[1]])
for (i in seq_along(items)) {
row <- list()
row[["measure"]] <-dif[i]
row[["se"]] <- se[i]
table$addRow(rowKey = items[i], values = row)
}
# Interaction fit table------------
# fit is shown for the rater*item combinations
ifit <- TAM::msq.itemfit(res)
ifit <- as.data.frame(ifit$itemfit)
ifit<- dplyr::select(ifit, c("item", "Outfit","Infit"))
# THe order !!!(rater * item), otherwise table will be empty!!!
ifit$item <- gsub("-rater", "rater", ifit$item)
ifit$item <- gsub("task", "", ifit$item)
ifit<- ifit |> tidyr::separate(item, c("rater", "task"), "-")
ifit<- data.frame(ifit)
# Display '*' when both infit and outfit values exceed 1.5
ifit$marker <- ifelse(ifit$Outfit > 1.5 &
ifit$Infit > 1.5, 'X', '')
# Item fit table------------
table <- self$results$ifit
names <- dimnames(ifit)[[1]]
for (name in names) {
row <- list()
row[["rater"]] <- ifit[name, 1]
row[["task"]] <- ifit[name, 2]
row[["outfit"]] <- ifit[name, 3]
row[["infit"]] <- ifit[name, 4]
row[["marker"]] <- ifit[name, 5]
table$addRow(rowKey=name, values=row)
}
if(isTRUE(self$options$plot7)){
ifit <- TAM::msq.itemfit(res)
ifit <- as.data.frame(ifit$itemfit)
ifit<- dplyr::select(ifit, c("item", "Outfit","Infit"))
Index<- dimnames(ifit)[[1]]
ifit$Index <- Index
ifit<- dplyr::select(ifit, c("Outfit","Infit","Index"))
ifit.plot<- reshape2::melt(ifit,
id.vars='Index',
variable.name="Fit",
value.name='Value')
image <- self$results$plot7
image$setState(ifit.plot)
}
# Person measure table-------------
table <- self$results$pm
# ps<- as.vector(per[[2]])
# pt<- as.vector(per[[3]])
# pe<- as.vector(per[[4]])
# pw<- as.vector(per[[5]])
#
# self$results$text$setContent(pw)
#
# items <- as.vector(per[[1]])
#
# for (i in seq_along(items)) {
#
# row <- list()
#
# row[["ps"]] <- ps[i]
# row[["pt"]] <- pt[i]
# row[["pe"]] <- pe[i]
# row[["pw"]] <- pw[i]
#
# table$addRow(rowKey = items[i], values = row)
# }
#
names<- dimnames(per)[[1]]
for (name in names) {
row <- list()
row[["ps"]] <- per[name, 2]
row[["pt"]] <- per[name, 3]
row[["pe"]] <- per[name, 4]
table$addRow(rowKey=name, values=row)
}
# Person fit table-----------
pfit <- TAM::tam.personfit(res)
pfit <- data.frame(pfit$outfitPerson,
pfit$infitPerson)
names(pfit) <- c("outfit", "infit")
# Display '*' when both infit and outfit values exceed 1.5
pfit$marker <- ifelse(pfit$outfit > 1.5 &
pfit$infit > 1.5, 'X', '')
table <- self$results$pfit
names<- dimnames(pfit)[[1]]
for (name in names) {
row <- list()
row[["outfit"]] <- pfit[name, 1]
row[["infit"]] <- pfit[name, 2]
row[["marker"]] <- pfit[name, 3]
table$addRow(rowKey=name, values=row)
}
# Person fit plot------------------
# Person ability----------
# persons <- TAM::tam.wle(res)
#
# per <-data.frame(persons$pid, persons$PersonScores,
# persons$theta, persons$error,
# persons$WLE.rel)
if(isTRUE(self$options$plot8)){
pfit <- TAM::tam.personfit(res)
pfit <- data.frame(pfit$outfitPerson,
pfit$infitPerson)
names(pfit) <- c("outfit", "infit")
pfit$Measure <- per$persons.theta
pf<- reshape2::melt(pfit,
id.vars='Measure',
variable.name="Fit",
value.name='Value')
image <- self$results$plot8
image$setState(pf)
}
###### Generalizability theory--------------------
if(isTRUE(self$options$g || self$options$d) || self$options$mea || self$options$error){
dep <- self$options$dep
id <- self$options$id
formula <- self$options$formula
# facet <- self$options$facet
# Example----------------------
# formula <- "value ~ (1 | subject) +(1 | rater) + (1 | task) +
# (1 | subject:rater) +
# (1 | rater:task) +
# (1 | subject:task)"
# Example----------
# vars <- c('A', 'B', 'C') # you'll populate this from self$options$...
# response <- 'bruce'
# fmla <- as.formula(paste0(jmvcore::composeTerm(response), '~', paste(jmvcore::composeTerms(vars), collapse='*')))
# trms <- attr(terms(fmla), 'term.labels')
# trms[1:6] #example---
# funnyTerms <- paste0('(1|', trms, ')')
# finalFmla <- paste0(jmvcore::composeTerm(response), '~', paste(funnyTerms, collapse='+'))
# finalFmla
#
#
# vars <- c(self$options$id, self$options$facet)
# response <- self$options$dep
# fmla <- as.formula(paste0(jmvcore::composeTerm(response), '~', paste(jmvcore::composeTerms(vars), collapse='*')))
# trms <- attr(terms(fmla), 'term.labels')
# funnyTerms <- paste0('(1|', trms, ')')
# formula <- paste0(jmvcore::composeTerm(response), '~', paste(funnyTerms, collapse='+'))
#
#
# self$results$text1$setContent(formula)
#
gstudy.out<- gtheory::gstudy(data = data, formula = formula)
ds<- gtheory::dstudy(gstudy.out, colname.objects = id, data = data, colname.scores = dep)
# G study table----------------
table<- self$results$g
gstudy<- as.data.frame(gstudy.out)
var<- as.vector(gstudy[[2]])
percent<- as.vector(gstudy[[3]])
n <- as.vector(gstudy[[4]])
items <- as.vector(gstudy[[1]])
for (i in seq_along(items)) {
row <- list()
row[["var"]] <-var[i]
row[["percent"]] <- percent[i]
row[["n"]] <- n[i]
table$addRow(rowKey = items[i], values = row)
}
# G study table(Variance components)----------------
table<- self$results$d
dstudy<- as.data.frame(ds$components)
var<- as.vector(dstudy[[2]])
percent<- as.vector(dstudy[[3]])
n <- as.vector(dstudy[[4]])
items <- as.vector(dstudy[[1]])
for (i in seq_along(items)) {
row <- list()
row[["var"]] <-var[i]
row[["percent"]] <- percent[i]
row[["n"]] <- n[i]
table$addRow(rowKey = items[i], values = row)
}
# self$results$text2$setContent(dstudy.out$generalizability)
# Measures of D study---------------
gen <- ds$generalizability
depe <- ds$dependability
uni <- ds$var.universe
rel <- ds$var.error.rel
abs <- ds$var.error.abs
if(isTRUE(self$options$mea)){
table<- self$results$mea
row <- list()
row[['generalizability']] <- gen
row[['dependability']] <- depe
row[['universe']] <- uni
table$setRow(rowNo = 1, values = row)
}
if(isTRUE(self$options$error)){
table<- self$results$error
row <- list()
row[['relative']] <- rel
row[['absolute']] <- abs
table$setRow(rowNo = 1, values = row)
}
}
},
.plot1 = function(image, ggtheme, theme,...) {
if (is.null(image$state))
return(FALSE)
rm <- image$state
fill <- theme$fill[2]
color <- theme$color[1]
plot1 <- ggplot(data=rm, aes(x=Rater, y=Value)) +
geom_bar(
stat="identity",
# position="dodge",
width = 0.7,
fill=fill,
color=color
) + theme_bw() + coord_flip()
plot1+ggtheme
print(plot1)
TRUE
},
.plot2 = function(image, ggtheme, theme,...) {
if (is.null(image$state))
return(FALSE)
im <- image$state
fill <- theme$fill[2]
color <- theme$color[1]
plot2 <- ggplot(data=im, aes(x=Task, y=Value)) +
geom_bar(
stat="identity",
#position="dodge",
width = 0.7,
fill=fill,
color=color
) + theme_bw()+ coord_flip()
plot2+ggtheme
print(plot2)
TRUE
},
.plot3 = function(image, ggtheme, theme,...) {
if (is.null(image$state))
return(FALSE)
inter <- image$state
plot3<- ggplot(inter, aes(x=Task, y=Measure, group=Rater)) +
geom_line(size=1.2,aes(color=Rater))+
geom_point(size=3,aes(color=Rater)) + theme_bw()
if (self$options$angle > 0) {
plot3 <- plot3 + ggplot2::theme(
axis.text.x = ggplot2::element_text(
angle = self$options$angle, hjust = 1
)
)
}
plot3+ggtheme
print(plot3)
TRUE
},
.plot4 = function(image,...) {
if (is.null(image$state))
return(FALSE)
personmeasure <- image$state[[1]]
imeasure <- image$state[[2]]
vars <- image$state[[3]]
plot4<- ShinyItemAnalysis::ggWrightMap(personmeasure, imeasure,
item.names = vars,
binwidth = 0.5,
# size=18,
ylab.b = "Facet measure",
rel_widths = c(1, 1.5),
color = "deepskyblue")
print(plot4)
TRUE
},
# .plot5 = function(image, ggtheme, theme,...) {
#
# if (is.null(image$state))
# return(FALSE)
#
# rs <- image$state
#
# plot5<- ggplot(rs, aes(x=Subject, y=Measure, group=Rater)) +
# geom_line(size=1.2,aes(color=Rater))+
# geom_point(size=3,aes(color=Rater)) + theme_bw()
#
#
# if (self$options$angle1 > 0) {
# plot5 <- plot5 + ggplot2::theme(
# axis.text.x = ggplot2::element_text(
# angle = self$options$angle1, hjust = 1
# )
# )
# }
#
# plot5+ggtheme
#
# print(plot5)
# TRUE
#
# }
#
# Expected score curves-------------------
.plot5 = function(image, ...) {
num <- self$options$num
if (is.null(image$state))
return(FALSE)
res <- image$state
plot5 <- plot(res,
items = num,
type = "expected",
export = FALSE)
print(plot5)
TRUE
},
# Item response curve-------------------
.plot6 = function(image, ...) {
num1 <- self$options$num1
if (is.null(image$state))
return(FALSE)
res <- image$state
plot6 <- plot(res,
items = num1,
type = "items",
export = FALSE)
print(plot6)
TRUE
},
# interaction fit plot--------------
.plot7 = function(image,ggtheme, theme,...) {
if (is.null(image$state))
return(FALSE)
ifit <- image$state
plot7<- ggplot2::ggplot(ifit, aes(x = Index, y = Value, shape = Fit))+
geom_point(size=3, stroke=2)+
ggplot2::scale_shape_manual(values=c(3, 4))+
labs(title = "",
x = "Rater X Task",
y = "Values") +
ggplot2::geom_hline(yintercept = 1.5,linetype = "dotted", color='red', size=1.5)+
ggplot2::geom_hline(yintercept = 0.5,linetype = "dotted", color='red', size=1.5)
plot7 <- plot7+ggtheme
if (self$options$angle1 > 0) {
plot7 <- plot7 + ggplot2::theme(
axis.text.x = ggplot2::element_text(
angle = self$options$angle1, hjust = 1
)
)
}
print(plot7)
TRUE
},
.plot8 = function(image,ggtheme, theme,...) {
if (is.null(image$state))
return(FALSE)
pf <- image$state
plot8<- ggplot2::ggplot(pf, aes(x = Measure, y = Value, shape = Fit))+
geom_point(size=3, stroke=2)+
ggplot2::scale_shape_manual(values=c(3, 4))+
#ggplot2::scale_color_manual(values=c("red", "blue")+
ggplot2::coord_cartesian(xlim=c(-4, 4),ylim=c(0, 3))+
ggplot2::geom_hline(yintercept = 1.5,linetype = "dotted", color='red', size=1.5)+
ggplot2::geom_hline(yintercept = 0.5,linetype = "dotted", color='red', size=1.5)
plot8 <- plot8+ggtheme
print(plot8)
TRUE
}
)
)
hyunsooseol/snowIRT documentation built on March 20, 2024, 8 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.
# This file is a generated template, your changes will not be overwritten
#' @importFrom R6 R6Class
#' @import jmvcore
#' @importFrom jmvcore toB64
#' @importFrom TAM tam.mml.mfr
#' @importFrom TAM tam.personfit
#' @importFrom TAM tam.wle
#' @importFrom TAM tam.threshold
#' @importFrom TAM msq.itemfit
#' @importFrom TAM tam.wle
#' @importFrom ShinyItemAnalysis ggWrightMap
#' @importFrom gtheory gstudy
#' @importFrom gtheory dstudy
#' @import ggplot2
#' @export
facetClass <- if (requireNamespace('jmvcore', quietly=TRUE)) R6::R6Class(
"facetClass",
inherit = facetBase,
private = list(
.init = function() {
if (is.null(self$data) | is.null(self$options$facet)) {
self$results$instructions$setVisible(visible = TRUE)
}
self$results$instructions$setContent(
"<html>
<head>
</head>
<body>
<div class='instructions'>
<p>____________________________________________________________________________________</p>
<p>1. If your data format is in wide, you need to convert it to <b>long format</b> in order to run analysis.</p>
<p>2. The variables should be named <b>'subject'</b>,<b>'rater'</b> and <b>'task'</b> respectively. Any other variable name will result in an error message.</b>
<p>3. In the Facet variable box, you must put the variable <b>'rater'</b> first.</p>
<p>4. You can currently only put <b>two variables</b> in the Facet variable box.</p>
<p>5. We recommend using <a href='https://www.winsteps.com' target = '_blank'>Facet software</a> for analyzing various experimental designs.</p>
<p>6. Feature requests and bug reports can be made on my <a href='https://github.com/hyunsooseol/snowIRT/issues' target = '_blank'>GitHub</a>.</p>
<p>____________________________________________________________________________________</p>
</div>
</body>
</html>"
)
if (self$options$ifit)
self$results$ifit$setNote(
"Note",
"Display 'X' when both Infit and Outfit values exceed 1.5."
)
if (self$options$pfit)
self$results$pfit$setNote(
"Note",
"Display 'X' when both Infit and Outfit values exceed 1.5."
)
if(isTRUE(self$options$plot1)){
width <- self$options$width1
height <- self$options$height1
self$results$plot1$setSize(width, height)
}
if(isTRUE(self$options$plot2)){
width <- self$options$width2
height <- self$options$height2
self$results$plot2$setSize(width, height)
}
if(isTRUE(self$options$plot3)){
width <- self$options$width3
height <- self$options$height3
self$results$plot3$setSize(width, height)
}
if(isTRUE(self$options$plot4)){
width <- self$options$width4
height <- self$options$height4
self$results$plot4$setSize(width, height)
}
if(isTRUE(self$options$plot5)){
width <- self$options$width5
height <- self$options$height5
self$results$plot5$setSize(width, height)
}
if(isTRUE(self$options$plot6)){
width <- self$options$width6
height <- self$options$height6
self$results$plot6$setSize(width, height)
}
if(isTRUE(self$options$plot7)){
width <- self$options$width7
height <- self$options$height7
self$results$plot7$setSize(width, height)
}
if(isTRUE(self$options$plot8)){
width <- self$options$width8
height <- self$options$height8
self$results$plot8$setSize(width, height)
}
},
.run = function() {
# Example------------------------------
# Wide to long for dataset using reshape packate
# data <- read.csv("guilford.csv")
# attach(data)
# long<- reshape::melt(data, id.vars =c("subject","rater"),
# variable_name = "task")
#-----------------------------------------
# facet<- read.csv("long.csv")
# attach(facet)
# formula <- ~ rater*task+step
# facets = dplyr::select(facet, rater:task)
#
# res <- TAM::tam.mml.mfr(value,
# facets = facets,
# formulaA = formula,
# pid=subject)
# res1 <- res$xsi.facets
#---------------------------------------------
if (is.null(self$options$dep) ||
is.null(self$options$id) ||
is.null(self$options$facet)) return()
dep <- self$options$dep
id <- self$options$id
facets <- self$options$facet
data <- self$data
data <- na.omit(data)
data <- as.data.frame(data)
# Formula---------------
facets <- vapply(facets, function(x) jmvcore::composeTerm(x), '')
facets <- paste0(facets, collapse='*')
formula <- as.formula(paste0('~ step+', facets))
facets = dplyr::select(data, self$options$facet)
#self$results$text$setContent(formula)
res <- TAM::tam.mml.mfr(resp = data[[self$options$dep]],
facets = facets,
pid = data[[self$options$id]],
formulaA = formula)
#self$results$text1$setContent(res)
#self$results$text1$setContent(res$xsi.facets)
if(isTRUE(self$options$plot5)){
image <- self$results$plot5
image$setState(res)
}
if(isTRUE(self$options$plot6)){
image <- self$results$plot6
image$setState(res)
}
# Facet estimates--------------------------
res1 <- res$xsi.facets # Whole estimates
# Rater X Subject measure table (Not running with large subjects now)--------------
# if(isTRUE(self$options$rs | self$options$plot5)){
#
# facets = dplyr::select(data, subject:task)
# formula <- ~ rater*subject+task +step
#
# out <- TAM::tam.mml.mfr(resp = data[[self$options$dep]],
# facets = facets,
# pid = data[[self$options$id]],
# formulaA = formula)
# out1 <- out$xsi.facets
#
# if(isTRUE(self$options$sifit))
# {
#
# sifit <- TAM::msq.itemfit(out)
# sifit <- as.data.frame(sifit$itemfit)
#
# sifit<- dplyr::select(sifit, c("item", "Outfit_t","Outfit_p"))
#
# # THe order !!!(rater * item), otherwise table will be empty!!!
# sifit$item <- gsub("-rater", "rater", sifit$item)
# sifit$item <- gsub("task", "", sifit$item)
#
# sifit<- sifit |> tidyr::separate(item, c("rater","subject", "task"), "-")
#
# sifit<- data.frame(sifit)
# #self$results$text1$setContent(sifit)
# # Item fit table------------
#
# table <- self$results$sifit
#
# names <- dimnames(sifit)[[1]]
#
#
# for (name in names) {
#
# row <- list()
#
# row[["rater"]] <- sifit[name, 1]
# row[["subject"]] <- sifit[name, 2]
# row[["task"]] <- sifit[name, 3]
# row[["outfit"]] <- sifit[name, 4]
# row[["p"]] <- sifit[name, 5]
#
# table$addRow(rowKey=name, values=row)
#
# }
#
#
# }
#
# #---------------------------
# rs <- subset(out1, out1$facet == "rater:subject")
#
# rs<- rs |> tidyr::separate(parameter, c("rater", "subject"), ":")
# # inter$task <- gsub("task", "", inter$task)
# rs <- data.frame(rs$rater, rs$subject, rs$xsi, rs$se.xsi)
# colnames(rs) <- c("Rater", "Subject","Measure","SE")
#
# # Rater X subject measure table----------------
#
# table<- self$results$rs
#
# rs<- as.data.frame(rs)
#
# self$results$text1$setContent(rs)
#
# names <- dimnames(rs)[[1]]
#
#
# for (name in names) {
#
# row <- list()
#
# row[["rater"]] <- rs[name, 1]
# row[["subject"]] <- rs[name, 2]
# row[["measure"]] <- rs[name, 3]
# row[["se"]] <- rs[name, 4]
#
# table$addRow(rowKey=name, values=row)
#
# }
#
# image <- self$results$plot5
# image$setState(rs)
#
# }
#
# Task measure----------------------------
im <- subset(res1, res1$facet == "task")
im$parameter <- gsub("task", "", im$parameter)
# rater measure----------
rm <- subset(res1, res1$facet == "rater")
#interaction(Raw score)-----------------
if(isTRUE(self$options$raw)){
para<- res$item$item
score<- res$item$M
raw <- data.frame(para, score)
raw$para <- gsub("task", "", raw$para)
raw$para <- gsub("-rater", "rater", raw$para)
raw<- raw |> tidyr::separate(para, c("rater", "item"), "-")
table <- self$results$raw
names <- dimnames(raw)[[1]]
for (name in names) {
row <- list()
row[["rater"]] <- raw[name, 1]
row[["task"]] <- raw[name, 2]
row[["score"]] <- raw[name, 3]
table$addRow(rowKey=name, values=row)
}
}
# interaction measure-------
inter <- subset(res1, res1$facet == "rater:task")
inter<- inter |> tidyr::separate(parameter, c("rater", "task"), ":")
inter$task <- gsub("task", "", inter$task)
inter <- data.frame(inter$rater, inter$task, inter$xsi, inter$se.xsi)
colnames(inter) <- c("Rater", "Task","Measure","SE")
# step measure-----------
sm <- subset(res1, res1$facet == "step")
#---------------------------------------------------------------------
# Person ability----------
persons <- TAM::tam.wle(res)
per <-data.frame(persons$pid, persons$PersonScores,
persons$theta, persons$error,
persons$WLE.rel)
# WLE Reliability-------
pw<- as.vector(per[[5]])[1]
self$results$text$setContent(pw)
# Wrightmap plot---------
if(isTRUE(self$options$plot4)){
itemm<- data.frame(im$parameter, im$xsi)
# added rater measure into item-------
rmm <- subset(res1, res1$facet == "rater")
rmm<- data.frame(rmm$parameter, rmm$xsi)
colnames(rmm) <- c("im.parameter", "im.xsi")
itemm <- rbind(itemm, rmm)
#---------------------------------
colnames(itemm) <- c("vars", "measure")
itemm$vars <- gsub("task", "", itemm$vars)
#self$results$text1$setContent(itemm)
vars <- as.vector(itemm[[1]])
ime <- as.vector(itemm[[2]])
pme <- as.vector(per[[3]])
image <- self$results$plot4
state <- list(pme, ime, vars)
image$setState(state)
}
# Task measure table----------------
table<- self$results$im
im<- as.data.frame(im)
dif<- as.vector(im[[3]])
se<- as.vector(im[[4]])
items <- as.vector(im[[1]])
for (i in seq_along(items)) {
row <- list()
row[["measure"]] <-dif[i]
row[["se"]] <- se[i]
table$addRow(rowKey = items[i], values = row)
}
# Item bar plot----------
if(isTRUE(self$options$plot2)){
im <- as.data.frame(im)
colnames(im) <- c("Task", "facet", "Value", "SE")
# Rater bar plot--------
image <- self$results$plot2
image$setState(im)
}
# Rater measure table----------------
table<- self$results$rm
rm<- as.data.frame(rm)
dif<- as.vector(rm[[3]])
se<- as.vector(rm[[4]])
items <- as.vector(rm[[1]])
for (i in seq_along(items)) {
row <- list()
row[["measure"]] <-dif[i]
row[["se"]] <- se[i]
table$addRow(rowKey = items[i], values = row)
}
# Rater bar plot----------
if(isTRUE(self$options$plot1)){
rm<- as.data.frame(rm)
colnames(rm) <- c("Rater", "facet", "Value", "SE")
# Rater bar plot--------
image <- self$results$plot1
image$setState(rm)
}
# Interaction measure table----------------
table<- self$results$inter
inter<- as.data.frame(inter)
names <- dimnames(inter)[[1]]
# rater <- as.vector(inter[[1]])
# task <- as.vector(inter[[2]])
# dif<- as.vector(inter[[3]])
# se<- as.vector(inter[[4]])
#items <- as.vector(inter[[1]])
# for (i in seq_along(items)) {
#
# row <- list()
#
# row[["task"]] <- task[i]
# row[["measure"]] <-dif[i]
# row[["se"]] <- se[i]
#
# table$addRow(rowKey = items[i], values = row)
# }
for (name in names) {
row <- list()
row[["rater"]] <- inter[name, 1]
row[["task"]] <- inter[name, 2]
row[["measure"]] <- inter[name, 3]
row[["se"]] <- inter[name, 4]
table$addRow(rowKey=name, values=row)
}
# Interaction plot--------------
image <- self$results$plot3
image$setState(inter)
# Step measure table----------------
table<- self$results$sm
sm<- as.data.frame(sm)
dif<- as.vector(sm[[3]])
se<- as.vector(sm[[4]])
items <- as.vector(sm[[1]])
for (i in seq_along(items)) {
row <- list()
row[["measure"]] <-dif[i]
row[["se"]] <- se[i]
table$addRow(rowKey = items[i], values = row)
}
# Interaction fit table------------
# fit is shown for the rater*item combinations
ifit <- TAM::msq.itemfit(res)
ifit <- as.data.frame(ifit$itemfit)
ifit<- dplyr::select(ifit, c("item", "Outfit","Infit"))
# THe order !!!(rater * item), otherwise table will be empty!!!
ifit$item <- gsub("-rater", "rater", ifit$item)
ifit$item <- gsub("task", "", ifit$item)
ifit<- ifit |> tidyr::separate(item, c("rater", "task"), "-")
ifit<- data.frame(ifit)
# Display '*' when both infit and outfit values exceed 1.5
ifit$marker <- ifelse(ifit$Outfit > 1.5 &
ifit$Infit > 1.5, 'X', '')
# Item fit table------------
table <- self$results$ifit
names <- dimnames(ifit)[[1]]
for (name in names) {
row <- list()
row[["rater"]] <- ifit[name, 1]
row[["task"]] <- ifit[name, 2]
row[["outfit"]] <- ifit[name, 3]
row[["infit"]] <- ifit[name, 4]
row[["marker"]] <- ifit[name, 5]
table$addRow(rowKey=name, values=row)
}
if(isTRUE(self$options$plot7)){
ifit <- TAM::msq.itemfit(res)
ifit <- as.data.frame(ifit$itemfit)
ifit<- dplyr::select(ifit, c("item", "Outfit","Infit"))
Index<- dimnames(ifit)[[1]]
ifit$Index <- Index
ifit<- dplyr::select(ifit, c("Outfit","Infit","Index"))
ifit.plot<- reshape2::melt(ifit,
id.vars='Index',
variable.name="Fit",
value.name='Value')
image <- self$results$plot7
image$setState(ifit.plot)
}
# Person measure table-------------
table <- self$results$pm
# ps<- as.vector(per[[2]])
# pt<- as.vector(per[[3]])
# pe<- as.vector(per[[4]])
# pw<- as.vector(per[[5]])
#
# self$results$text$setContent(pw)
#
# items <- as.vector(per[[1]])
#
# for (i in seq_along(items)) {
#
# row <- list()
#
# row[["ps"]] <- ps[i]
# row[["pt"]] <- pt[i]
# row[["pe"]] <- pe[i]
# row[["pw"]] <- pw[i]
#
# table$addRow(rowKey = items[i], values = row)
# }
#
names<- dimnames(per)[[1]]
for (name in names) {
row <- list()
row[["ps"]] <- per[name, 2]
row[["pt"]] <- per[name, 3]
row[["pe"]] <- per[name, 4]
table$addRow(rowKey=name, values=row)
}
# Person fit table-----------
pfit <- TAM::tam.personfit(res)
pfit <- data.frame(pfit$outfitPerson,
pfit$infitPerson)
names(pfit) <- c("outfit", "infit")
# Display '*' when both infit and outfit values exceed 1.5
pfit$marker <- ifelse(pfit$outfit > 1.5 &
pfit$infit > 1.5, 'X', '')
table <- self$results$pfit
names<- dimnames(pfit)[[1]]
for (name in names) {
row <- list()
row[["outfit"]] <- pfit[name, 1]
row[["infit"]] <- pfit[name, 2]
row[["marker"]] <- pfit[name, 3]
table$addRow(rowKey=name, values=row)
}
# Person fit plot------------------
# Person ability----------
# persons <- TAM::tam.wle(res)
#
# per <-data.frame(persons$pid, persons$PersonScores,
# persons$theta, persons$error,
# persons$WLE.rel)
if(isTRUE(self$options$plot8)){
pfit <- TAM::tam.personfit(res)
pfit <- data.frame(pfit$outfitPerson,
pfit$infitPerson)
names(pfit) <- c("outfit", "infit")
pfit$Measure <- per$persons.theta
pf<- reshape2::melt(pfit,
id.vars='Measure',
variable.name="Fit",
value.name='Value')
image <- self$results$plot8
image$setState(pf)
}
###### Generalizability theory--------------------
if(isTRUE(self$options$g || self$options$d) || self$options$mea || self$options$error){
dep <- self$options$dep
id <- self$options$id
formula <- self$options$formula
# facet <- self$options$facet
# Example----------------------
# formula <- "value ~ (1 | subject) +(1 | rater) + (1 | task) +
# (1 | subject:rater) +
# (1 | rater:task) +
# (1 | subject:task)"
# Example----------
# vars <- c('A', 'B', 'C') # you'll populate this from self$options$...
# response <- 'bruce'
# fmla <- as.formula(paste0(jmvcore::composeTerm(response), '~', paste(jmvcore::composeTerms(vars), collapse='*')))
# trms <- attr(terms(fmla), 'term.labels')
# trms[1:6] #example---
# funnyTerms <- paste0('(1|', trms, ')')
# finalFmla <- paste0(jmvcore::composeTerm(response), '~', paste(funnyTerms, collapse='+'))
# finalFmla
#
#
# vars <- c(self$options$id, self$options$facet)
# response <- self$options$dep
# fmla <- as.formula(paste0(jmvcore::composeTerm(response), '~', paste(jmvcore::composeTerms(vars), collapse='*')))
# trms <- attr(terms(fmla), 'term.labels')
# funnyTerms <- paste0('(1|', trms, ')')
# formula <- paste0(jmvcore::composeTerm(response), '~', paste(funnyTerms, collapse='+'))
#
#
# self$results$text1$setContent(formula)
#
gstudy.out<- gtheory::gstudy(data = data, formula = formula)
ds<- gtheory::dstudy(gstudy.out, colname.objects = id, data = data, colname.scores = dep)
# G study table----------------
table<- self$results$g
gstudy<- as.data.frame(gstudy.out)
var<- as.vector(gstudy[[2]])
percent<- as.vector(gstudy[[3]])
n <- as.vector(gstudy[[4]])
items <- as.vector(gstudy[[1]])
for (i in seq_along(items)) {
row <- list()
row[["var"]] <-var[i]
row[["percent"]] <- percent[i]
row[["n"]] <- n[i]
table$addRow(rowKey = items[i], values = row)
}
# G study table(Variance components)----------------
table<- self$results$d
dstudy<- as.data.frame(ds$components)
var<- as.vector(dstudy[[2]])
percent<- as.vector(dstudy[[3]])
n <- as.vector(dstudy[[4]])
items <- as.vector(dstudy[[1]])
for (i in seq_along(items)) {
row <- list()
row[["var"]] <-var[i]
row[["percent"]] <- percent[i]
row[["n"]] <- n[i]
table$addRow(rowKey = items[i], values = row)
}
# self$results$text2$setContent(dstudy.out$generalizability)
# Measures of D study---------------
gen <- ds$generalizability
depe <- ds$dependability
uni <- ds$var.universe
rel <- ds$var.error.rel
abs <- ds$var.error.abs
if(isTRUE(self$options$mea)){
table<- self$results$mea
row <- list()
row[['generalizability']] <- gen
row[['dependability']] <- depe
row[['universe']] <- uni
table$setRow(rowNo = 1, values = row)
}
if(isTRUE(self$options$error)){
table<- self$results$error
row <- list()
row[['relative']] <- rel
row[['absolute']] <- abs
table$setRow(rowNo = 1, values = row)
}
}
},
.plot1 = function(image, ggtheme, theme,...) {
if (is.null(image$state))
return(FALSE)
rm <- image$state
fill <- theme$fill[2]
color <- theme$color[1]
plot1 <- ggplot(data=rm, aes(x=Rater, y=Value)) +
geom_bar(
stat="identity",
# position="dodge",
width = 0.7,
fill=fill,
color=color
) + theme_bw() + coord_flip()
plot1+ggtheme
print(plot1)
TRUE
},
.plot2 = function(image, ggtheme, theme,...) {
if (is.null(image$state))
return(FALSE)
im <- image$state
fill <- theme$fill[2]
color <- theme$color[1]
plot2 <- ggplot(data=im, aes(x=Task, y=Value)) +
geom_bar(
stat="identity",
#position="dodge",
width = 0.7,
fill=fill,
color=color
) + theme_bw()+ coord_flip()
plot2+ggtheme
print(plot2)
TRUE
},
.plot3 = function(image, ggtheme, theme,...) {
if (is.null(image$state))
return(FALSE)
inter <- image$state
plot3<- ggplot(inter, aes(x=Task, y=Measure, group=Rater)) +
geom_line(size=1.2,aes(color=Rater))+
geom_point(size=3,aes(color=Rater)) + theme_bw()
if (self$options$angle > 0) {
plot3 <- plot3 + ggplot2::theme(
axis.text.x = ggplot2::element_text(
angle = self$options$angle, hjust = 1
)
)
}
plot3+ggtheme
print(plot3)
TRUE
},
.plot4 = function(image,...) {
if (is.null(image$state))
return(FALSE)
personmeasure <- image$state[[1]]
imeasure <- image$state[[2]]
vars <- image$state[[3]]
plot4<- ShinyItemAnalysis::ggWrightMap(personmeasure, imeasure,
item.names = vars,
binwidth = 0.5,
# size=18,
ylab.b = "Facet measure",
rel_widths = c(1, 1.5),
color = "deepskyblue")
print(plot4)
TRUE
},
# .plot5 = function(image, ggtheme, theme,...) {
#
# if (is.null(image$state))
# return(FALSE)
#
# rs <- image$state
#
# plot5<- ggplot(rs, aes(x=Subject, y=Measure, group=Rater)) +
# geom_line(size=1.2,aes(color=Rater))+
# geom_point(size=3,aes(color=Rater)) + theme_bw()
#
#
# if (self$options$angle1 > 0) {
# plot5 <- plot5 + ggplot2::theme(
# axis.text.x = ggplot2::element_text(
# angle = self$options$angle1, hjust = 1
# )
# )
# }
#
# plot5+ggtheme
#
# print(plot5)
# TRUE
#
# }
#
# Expected score curves-------------------
.plot5 = function(image, ...) {
num <- self$options$num
if (is.null(image$state))
return(FALSE)
res <- image$state
plot5 <- plot(res,
items = num,
type = "expected",
export = FALSE)
print(plot5)
TRUE
},
# Item response curve-------------------
.plot6 = function(image, ...) {
num1 <- self$options$num1
if (is.null(image$state))
return(FALSE)
res <- image$state
plot6 <- plot(res,
items = num1,
type = "items",
export = FALSE)
print(plot6)
TRUE
},
# interaction fit plot--------------
.plot7 = function(image,ggtheme, theme,...) {
if (is.null(image$state))
return(FALSE)
ifit <- image$state
plot7<- ggplot2::ggplot(ifit, aes(x = Index, y = Value, shape = Fit))+
geom_point(size=3, stroke=2)+
ggplot2::scale_shape_manual(values=c(3, 4))+
labs(title = "",
x = "Rater X Task",
y = "Values") +
ggplot2::geom_hline(yintercept = 1.5,linetype = "dotted", color='red', size=1.5)+
ggplot2::geom_hline(yintercept = 0.5,linetype = "dotted", color='red', size=1.5)
plot7 <- plot7+ggtheme
if (self$options$angle1 > 0) {
plot7 <- plot7 + ggplot2::theme(
axis.text.x = ggplot2::element_text(
angle = self$options$angle1, hjust = 1
)
)
}
print(plot7)
TRUE
},
.plot8 = function(image,ggtheme, theme,...) {
if (is.null(image$state))
return(FALSE)
pf <- image$state
plot8<- ggplot2::ggplot(pf, aes(x = Measure, y = Value, shape = Fit))+
geom_point(size=3, stroke=2)+
ggplot2::scale_shape_manual(values=c(3, 4))+
#ggplot2::scale_color_manual(values=c("red", "blue")+
ggplot2::coord_cartesian(xlim=c(-4, 4),ylim=c(0, 3))+
ggplot2::geom_hline(yintercept = 1.5,linetype = "dotted", color='red', size=1.5)+
ggplot2::geom_hline(yintercept = 0.5,linetype = "dotted", color='red', size=1.5)
plot8 <- plot8+ggtheme
print(plot8)
TRUE
}
)
)
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.