#' @title Create DIGRAM Object
#' @name digram.object
#' @description Create a digram.object.
#' @usage digram.object(project=NULL,data=data.frame(),variables=colnames(data),filter.conditions=data.frame(variable.number=numeric(0),min=numeric(0),max=numeric(0)),recursive.structure=c(),comments="")
#' @param project The name of the DIGRAM project
#' @param data The data.frame or matrix with the data
#' @param variables A vector of column names or numbers from the dataset to include in the recoded dataset (the order matters in the recoded data) *or* a list of variables each element in the form list(variable.name="",variable.label="",ncat=0,category.names=c(),variable.type=c("nominal","ordinal"),minimum=0,maximum=1,cutpoints=c())
#' @param filter.conditions A data.frame with three columns: variable.number, max, and min. Only cases, for which all values of filter variables belong to the intervals defined by the corresponding minimum and maximum values (both included), will be used in the analysis.
#' @param recursive.structure A vector of cutpoints to define the recursive blocks
#' @param comments A string
#' @export
#' @return Returns a digram.object
#' @author Jeppe Bundsgaard <jebu@@edu.au.dk>
#' @examples
#' library(iarm)
#' do<-digram.object(project = "desc2",data = desc2,variables = c(5:14,2:4,1),recursive.structure = c(10,13))
#' @references
#' Kreiner, S. (2003). *Introduction to DIGRAM*. Dept. of Biostatistics, University of Copenhagen.
<-(project=,=(),variables=,filter.conditions=,recursive.structure=,comments="") {
((project)) ("You need to provide a project name")
#if(inherits(data,"tbl_df")) data<-as.data.frame(data)
(!(variables,"list")) {
vars<-((variables)) () ((variables,("numeric","integer"))) ()[variables] variables
num.vars<-(vars)
variables<-()
(i 1:num.vars) {
iminus<-i-1
numletters<-(i<=(26(1:5)))[1]
variable.label<-""
k<-iminus
(j numletters:1) {r<-(k%%26);variable.label<-([r+(numletters<2||j>1,1,0)],variable.label); k<-(k/26)}
variable.name<-vars[i]
column.number<-(()%in%vars[i])
(!((,vars[i]], "labels"))) {
categories<-(,vars[i]], "labels")
} {
# Test for integer/float/character...
categories<-((,vars[i]]))
categories<-categories[order(categories)]
}
ncat<-(categories)
variable.type<-((categories,"numeric") | (categories,"integer"),"ordinal","nominal")
minimum<-(variable.type=="ordinal") (categories) 0
maximum<-(variable.type=="ordinal") (categories) ncat-1
# Record 2: <Minimum> <Cutpoint(1)>...<Last cutpoint> ... <Maximum>
cutpoints<-(variable.type=="ordinal") categories[order(categories)] 0:(ncat-1)
cutpoints<-cutpoints-ncat]
# Categories
(ncat<1) (("Not enough categories in",variable.name))
category.names<-(Category=0:(ncat-1),Name=categories)
(((,vars[i]],("double")))) ,vars[i]]<-(,vars[i]])
(!((,vars[i]],("integer","numeric")))) {
r2<-((category.names,1,(x) {
("'",x"Name"],"'=",x"Category"])
}),collapse = ";")
,vars[i]]<-car::recode(,vars[i]],r2, = T)
}
variables[i]]<-(variable.name=variable.name,variable.label=variable.label,column.number=column.number,ncat=ncat,category.names=category.names,variable.type=variable.type,minimum=minimum,maximum=maximum,cutpoints=cutpoints)
}
}
# The number of recursive blocks should appear on a separate record.
((recursive.structure)) recursive.structure<-(variables)
recursive.blocks<-(recursive.structure)
do<-(project=project,=,recoded=,variables=variables,filter.conditions=filter.conditions,recursive.blocks=recursive.blocks,recursive.structure=recursive.structure,comments=comments,commandsrun=())
(do)<-"digram.object"
# print(do)
do$recoded<-digram.recode(do)
do
}
onlyif<-(y) {i<-0;(z y) {(!(z) & z>0) i<-i+z };i}
digram.recode<-(do) {
<-do$
variables<-do$variables
filter.conditions<-do$filter.conditions
# Recode data
((variables,(x) {
cutpoints2<-((x$minimum,x$cutpoints+.000001,x$cutpoints,x$maximum), = 2,byrow = F)
froms<-(cutpoints2,1,,collapse=":")
tos<-0:((x$cutpoints))
recodestr<-(((((froms,tos),=2,byrow = F),1,,collapse="="),(x$maximum+.000001,":hi=NA")),collapse=";")
column.number<-x$column.number
datacol<-,column.number]
# If this is a combined variable, add the columns together
((datacol)) datacol<-(datacol,1,(y) {
((x$combine.type)) x$combine.type<-"sum"
switch (x$combine.type,
"sum" = (y),
"or" = (y),
"xor" = ((y>0)==1,y[y>0],0),
"and" = (((y))==1,y[1],0),
"onlyif" = onlyif(y)
)
})
(!(x$reverse) && x$reverse) datacol<-car::recode(datacol,(tos,(tos),sep = "=",collapse = ";"))
(!(filter.conditions)) {
minmax<-filter.conditions[filter.conditions$variable.number==column.number,2:3]
((minmax)>0) {
minval<-minmax[1]
maxval<-minmax[2]
datacol<-car::recode(datacol,("lo:",(minval-.000001),"=NA;",(maxval+.000001),":hi=NA"))
}
}
datacol<-car::recode(datacol,recodestr)
recoded<-("col"=datacol)
(recoded)<-x$variable.name
(recoded)
}))
}
#' Create a tidygraph object from a digram.object
#'
#' @param do A digram.object.
#' @param LD A data.frame with columns for item1, item2 and gamma coefficient. Items can be variable.names, variable.columns or item numbers.
#' @param DIF A data.frame with columns for item, exogenous variable and gamma coefficient. Items and exogenous variables can be variable.names, variable.columns or item numbers.
#' @param summarize.testlets If true, don't collapse testlets, but summarize number of local dependent item pairs (both ways) in each testlet.
#' @usage as_tbl_graph(do)
#' @return Returns a tbl_graph
#' @export
#' @seealso [tidygraph::as_tbl_graph()]
#' @examples
#' library(ggraph)
#' library(tidygraph)
#' dograph<-as_tbl_graph(DHP)
#' ggraph(dograph,layout="fr")+geom_edge_link()+geom_node_label(mapping = aes(label=label))
#' ggraph(dograph,layout="fr")+geom_edge_link()+geom_node_label(mapping = aes(label=name))
#'
#' # Show arrows
#' ggraph(dograph,layout="fr")+geom_edge_link(end_cap = square(.5, 'cm'),arrow = arrow(angle=10,length=unit(.2,"cm")))+geom_node_label(mapping = aes(label=label))
#'
#' # A digram.object with a testlet
#' dograph<-as_tbl_graph(code.testlet(DHP,"a b c"))
#' ggraph(dograph,layout="fr")+geom_edge_link(end_cap = square(.5, 'cm'),arrow = arrow(angle=10,length=unit(.2,"cm")))+geom_node_label(mapping = aes(label=label))
#'
#' # Local dependecy and DIF
#' dograph<-as_tbl_graph(DHP,LD=data.frame(item1=c(5,3),item2=c(6,5),gamma=c(.53,-.38)),DIF=data.frame(item=c(4),exo=c(8),gamma=c(.27)))
#' ggraph(dograph,layout="fr")+geom_edge_link(mapping=aes(label=ifelse(!is.na(gamma),abs(gamma),""),alpha=ifelse(!is.na(gamma),gamma,1),color=ifelse(!is.na(gamma),2,1)),angle_calc="along",label_dodge=unit(.25,"cm"),end_cap = square(.5, 'cm'),arrow = arrow(angle=10,length=unit(.2,"cm")))+geom_node_label(mapping = aes(label=label))
<-(do,items=,exo.names=,exo.labels=exo.names,LD=,DIF=,summarize.testlets=F){
(!(do,"digram.object")) ("do needs to be of class digram.object")
resp<-do$recoded
((items)) items<-1:do$recursive.structure[1]
((exo.names)) {
exo<-((resp)>do$recursive.structure[1]) (do$recursive.structure[1]+1):(resp)
exo.names<-(do,exo)
((exo,"character")) exo<-(exo,exo.names)
exo.labels<-(do,exo)
}
item.names<-(do,items)
((items,"character")) items<-(items,item.names)
item.labels<-(do,items)
nitems<-(items)
nexo<-(exo.names)
ntestlets<-0
(!(LD) || !(DIF)) {
(!summarize.testlets) {
(collapse.testlets) <- ()
collapse.testlets()
ntestlets<-(items>(do$variables))
}
} (!(do$testlets)) {
testlet.edges<-(do$testlets,(x) {
testlet<-x$testlet
nitem<-(testlet)
from<-((1:(nitem-1),(y) (testlet[y]+2,nitem-y))) # We add 2 because we have theta and total score
to<-((2:nitem,(y) testlet[y:nitem]+2)) # Ditto
(from,to,to,from)
})
testlet.edges<-(((testlet.edges),=2))
(testlet.edges)<-("from","to")
testlet.edges$<-
}
(!(do$)) {
("Graphing of split items not implemented yet.")
}
(!(LD)) {
((LD)>0){
((LD)!=3) ("LD needs to have three columns: item1, item2, and gamma")
(LD)<-("from","to","gamma")
maxnl<-((LD$from),(LD$to))
LD$from<-((LD$from),1,(x) (x==item.names.shorten(item.names,maxnl))) + 2 # We add 2 because we have theta and total score
LD$to<-((LD$to),1,(x) (x==item.names.shorten(item.names,maxnl))) + 2
}
}
(!(DIF)) {
((DIF)>0){
((DIF)!=3) ("DIF needs to have three columns: item, exo, and gamma")
(DIF)<-("to","from","gamma")
#maxnl<-max(nchar(apply(array(DIF$from),1,sub,pattern=",.*",replacement="")),nchar(DIF$to))
maxnl<-((DIF$to))
# DIF$from<-apply(array(DIF$from),1,function(x) which(sub(",.*","",x)==item.names.shorten(exo.names,maxnl))) + 2 + nitems # We add 2 and nitems because we have theta and total score and items before exos
DIF$to<-(DIF$to,(x) {a<-(x==item.names.shorten(item.names,maxnl)); ((a),,a)}) + 2
DIF$from<-(DIF$from,,exo.names) + 2 + nitems # We add 2 and nitems because we have theta and total score and items before exos
hasNA<-(DIF$to) | (DIF$from)
((hasNA)) DIF<-DIF!hasNA,]
#DIF$to<-apply(array(DIF$to),1,match,item.names) + 2 # We add 2 because we have theta and total score
}
}
# nitems<-length(items)
# nexo<-length(exo)
# c("Theta","Total Score")
nodes<-((=("θ","S"),label=("θ","S"),=("Ability",2),stringsAsFactors = F),#,column.number=c(0,0)
(=item.names,label=item.labels,=(("Item",nitems-ntestlets),("Testlet",ntestlets)))
)
(nexo>0) nodes<-(nodes, #t(sapply(1:do$recursive.structure[1], function(x) unlist(do$variables[[x]][c("variable.name","variable.label","column.number")]))),
(=exo.names,label=exo.labels,=("Exo",nexo))#t(sapply((do$recursive.structure[1]+1):do$recursive.structure[2], function(x) unlist(do$variables[[x]][c("variable.name","variable.label","column.number")])))
)
edges<-(
from=(1,(2,nitems)),
to=(2,3:(nitems+2)))
(nexo>0) edges<-(edges,(
from=(nitems+3):(nitems+nexo+2),
to=(1,nexo)))
edges$<-
(("testlet.edges")) edges<-(edges,testlet.edges)
(("LD")) edges<-(edges,LD)
(("DIF")) edges<-(edges,DIF)
tbl_graph(nodes=nodes,edges=edges,directed = T)
}
#' Code items as a testlet/local dependant
#'
#' @param do A digram.object
#' @param testlet String. The items that are part of a testlet/are local dependant. Give as a list of comma separated variable numbers, variable labels or variable names. If there is spaces in the variable names, they can be delimited by ".
#' @param names A vector of strings naming the testlets. If names are not given, they are composed of the testlet item names.
#' @param append Logical. Append new testlet variables to the existing ones.
#'
#' @return Returns a digram.object with the revised testlet-data.frame.
#' @export
#' @details Local dependence is often caused by items sharing a common stimulus. This is called testlets or item bundles (Wang & Wilson 2006. Coding for Local Dependence is the same as identifying a testlet or an item bundle.
#' @references
#' Wang, W.-C., & Wilson, M. (2005). The Rasch Testlet Model. *Applied Psychological Measurement*, 29(2), 126–149. https://doi.org/10.1177/0146621604271053
#' @examples
#' data(DHP)
#' do<-code.testlet(do=DHP,testlet=c("ab,dhp36 dhp37,5 6"))
<-(do,testlet=,=,=,=F) {
do$commandsrun<-(do$commandsrun,())
(!(do,"digram.object")) ("do needs to be a digram.object")
((testlet)) ("You need to provide a list of variables which are local dependent")
testlet.strs<-(("\"",testlet),(x = testlet, ='(?<=")\\s*,\\s*(?=")',perl = T),testlet.strs<-(x = testlet, ="\\s*,\\s*"))[1]]
no<-0
testlets<-(testlet.strs,(x) {
no<<-no+1
(("\"",x)) {
res<-('"[^"]+"\\s*',x)[1]]
res<-(res,(x))
testlet<-()
(i 2:(res)) {
testlet<-(testlet,((x,res[i-1],res[i]-1))) #gsub("\"","",)
}
} testlet<-(x," |\\+")[1]]
((testlet)<2) testlet<-(testlet,"")[1]]
testlet<-(testlet,(x) (("^[0-9]$",x),(x),x))
testlet<-(testlet,get.column.no,do=do)
label<-(([no]),
((do,testlet),collapse = " + "),
[no])
(([no])){
itemnames<-(do,testlet)
<-str_overlap(itemnames)
(=="") <-(itemnames,collapse = " + ")
} <-[no]
(testlet=testlet,=,label=label)
})
( && !(do$testlets)) {
do$testlets<-(do$testlets,testlets)
} do$testlets<-testlets
do
}
str_overlap<-(arr,="") {
((arr)==0) ()
(=="") (str_overlap(arr-1],arr[1]))
str2=arr[1]
(i 1:()) {
((,i,i)!=(str2,i,i)) {i<-i-1;}
}
(("[-_.:;,+?]\\s*$","",str_overlap(arr-1],(,1,i))))
}
# Internal function to collapse testlets
collapse.testlets<-(){
(!(do$testlets)) {
testletno<-0
(tlist do$testlets){
testletno<-testletno+1
testlet<-tlist$testlet
testlet<-(testlet[testlet %in% items])
newitem<-(do$variables)+testletno
resp,newitem]<<-
((testlet)>0) {
items<<-(items,newitem)
olditems<-(items %in% testlet)
# Recode
resp,newitem]<<-(resp,testlet],1,,na.rm=T)
# Combine names and labels
newname<-tlist$
item.names<<-(item.names,newname)
(resp)[newitem]<<-newname
item.labels<<-(item.labels,tlist$label)
item.names<<-item.names-olditems]
item.labels<<-item.labels-olditems]
# Remove item-nums
items<<-(items-olditems])
}
}
}
}
#' Code items to be split (as having DIF)
#'
#' @param do A digram.object
#' @param split.var String. The variables to split (having DIF). A comma separated list of variable numbers, labels or names.
#' @param split.on String. The exogenous variables to split on (causing DIF). A comma separated list of exogenous variable numbers, labels or names.
#' @param append Logical.
#' @details If more variables and exogenous variables are given, all possible combinations of these are split.
#' @return a modified digram.object
#' @export
#'
#' @examples
#' data(DHP)
#' do<-code.split(DHP,"a,b","under60")
<-(do,split.var,split.on,=F) {
do$commandsrun<-(do$commandsrun,())
(!(do,"digram.object")) ("do needs to be a digram.object")
((split.var)) ("You need to provide one or more variables to split")
((split.on)) ("You need to provide one or more exogenous variables to split on")
( && !(do$splits)) splits<-do$splits splits<-()
vars<-(x = split.var, =" *, *")[1]]
var.nums<-(vars,get.column.no,do=do)
exos<-(x = split.on, =" *, *")[1]]
exo.nums<-(exos,get.column.no,do=do)
do$splits<-(splits,expand.grid(=var.nums,exo=exo.nums))
# TODO: Update testlets
do
}
#' Combine several digram.objects into a combined.digram.objects.
#'
#' @param ... digram.objects to combine
#' @param project Name of project
#'
#' @return Returns a combined.digram.objects
#' @export
#' @details This function is useful when preparing a multidimensional analysis. Each digram.object represents a dimension.¸
#' @examples
#' do1<-DHP
#' do2<-DHP
#' digram.objects.combine(do1,do2)
<-(,project="") {
digram.objects<-()
nr<-0
(do digram.objects) {
(!(do,what = "digram.object")) ("The objects need to be of class digram.object.")
(nr==0) nr<-(do$)
((do$)!=nr) ("The digram.objects need to have the same number of data rows.")
nr<-(do$)
}
cdo<-(project=project,digram.objects=digram.objects)
(cdo)<-"combined.digram.objects"
cdo
}
