##-----tools--------------
isop.version <-function() {
#no spaces in line below, or version-script can not recognise
version<-0.922
print(paste("ISOP version: ",version))
version
}

##turning list of vectors to matrix
isop.asmatrix <-function(source) {
  getcol <- function(col) 
    sapply( 1:dim(source)[1], function(row) source[[row,col]] )
  sapply(1:length(source), getcol)
}

isop.sortbyrowcolSum<-function(m,freq) {
 freq=freq[order(rowSums(m))]
 matrix=m[order(rowSums(m)), order(colSums(m))] 
 data.frame( matrix, freq)
}

isop.plot2d<-function(what, title) {
  plot(seq(1,length(y=what)),what, type="l", col=1, xlab = "response vectors", ylab = "discrimination")
  title(main = title )
  for(i in 2:dim(isop.matrix)[2]) 
  lines(seq(1,length(y=what[,i])),what[,i], col=i )
}

isop.plot3d<-function(what, theta = 300, phi = 30, expand = 0.5, col = heat.colors(prod(dim(what))), bg = "white") {
  op <- par(bg = bg)
  what<-what[,names(what)!="freq"]
  ##cut frequencys away
  persp(1:dim(what)[1], 1:dim(what)[2], isop.asmatrix(what), theta = theta, phi = phi , expand = expand , col = col, xlab = "response vectors", ylab = "items", zlab = "discrimination" , ticktype = "detailed")
}

isop.plotFreqs<-function(what) 
  barplot(height = what$freq, names=1:(dim(what)[1]), xlab = "response vectors", ylab = "frequency")
  


# 1 set multivariate
#-----------------criteria-----------------
#

isop.calc1set <- function(raw = isop.matrix[c(2,3,5,7)], result="all"
, isoll=0.4646, verbose=TRUE)
{

isop.criteriumS <- function (coords.x,coords)
    (( sum(coords.x <= coords) == length(coords) ) & ( sum(coords.x < coords) > 1 )) |
    (( sum(coords.x >= coords) == length(coords) ) & ( sum(coords.x > coords) > 1 ))

isop.criteriumD <- function (coords.x,coords)
    ( sum(coords.x < coords) > 0 ) & ( sum(coords.x > coords) > 0 )

isop.criteriumT <- function (coords.x,coords)
    sum(coords.x == coords) > 0


isop.generateSDT <- function(x, nx, criterium)
{
  crit <-  function (index.x,co) 
    criterium( x[index.x,], co )
  mat.lr <- function(index)
    sum( nx[ sapply(index.x,crit, x[index,])] )
  index.x <- 1:length(nx)
  sapply(index.x, mat.lr)
} 


  xnx <- as.data.frame(table(as.data.frame(raw)))
  xnx <- xnx[xnx$Freq!=0,]
  x   <- isop.asmatrix(xnx[,1:(dim(xnx)[2]-1)])
  nx  <- xnx$Freq

  if ( verbose ) {
    print("calculating concordant matrix")
    print(c("duration:", durS<-system.time(Smat <- isop.generateSDT(x, nx, isop.criteriumS))[3], "seconds"))
    print("calculating discordant matrix")
    print(c("duration:", durD<-system.time(Dmat <- isop.generateSDT(x, nx, isop.criteriumD))[3], "seconds"))
    print("calculating tied matrix")
    print(c("duration:", durT<-system.time(Tmat <- isop.generateSDT(x, nx, isop.criteriumT))[3], "seconds"))
    print(c("Overall time: ",durS+durD+durT))
  } else {
    Smat <- isop.generateSDT(x, nx, isop.criteriumS)
    Dmat <- isop.generateSDT(x, nx, isop.criteriumD)
    Tmat <- isop.generateSDT(x, nx, isop.criteriumT)
  }

  ns <- sum(nx*Smat)  
  nd <- sum(nx*Dmat)
  nt <- sum(nx*Tmat)
  nss <- sum(nx*Smat^2)  
  ndd <- sum(nx*Dmat^2)
  nsd <- sum(nx*Smat*Dmat)

  ps <- ns/(ns+nd+nt)
  pd <- nd/(ns+nd+nt)
  pt <- nt/(ns+nd+nt)
  pss <- nss/(ns+nd+nt)^2
  pdd <- ndd/(ns+nd+nt)^2
  psd <- nsd/(ns+nd+nt)^2

  stddev <- sqrt( (16/(1-pt)^4) * (ps^2*pdd-2*ps*pd*psd+pd^2*pss) )
  gamma <- (ns - nd) / (ns + nd)
  compatibility <- ns + nt
  n <- sum(nx)
  nsq <- sum(nx)^2
  sumsdt <- ns+nd+nt
  isoto <- (sum( nx*(Smat+Tmat) ) - sum(nx^2)) / (nsq - sum(nx^2))
  isoto2set <- compatibility / (compatibility+ nd)
  z <- gamma*sqrt(sqrt(nsq))/stddev
  ubas <- sqrt( 2*(1-gamma^2)/ps+pd )
  
  nsoll <- sqrt ((sum( nx*(Smat+Tmat) ) - sum(nx^2)) / isoll + sum(nx^2))

  invector <- function(vec, val) {
    length(vec[vec == val])>0
  }

  if ( ( length(result) == 1 ) && (result == "all") ) 
return (data.frame(ns,nd,nt,nss,ndd,nsd,ps,pd,pt,pss,pdd,psd,gamma,stddev,ubas,isoto,compatibility,nsq,z,isoto2set,n,sumsdt,isoll,nsoll,nsoll^2))
    resvec <- NULL
 #initialize namevec with dummy value to concat with
    namevec <- NULL 
    if ( invector(result,"n") ) {
      resvec <- c(resvec,ns,nd,nt,nss,ndd,nsd)
      namevec <- c("ns","nd","nt","nss","ndd","nsd")
    }
    if ( invector(result,"p") ) {
      resvec <- c(resvec,ps,pd,pt,pss,pdd,psd) 
      namevec <- c(namevec,"ps","pd","pt","pss","pdd","psd")
    }
    if ( invector(result,"g") ) {
      resvec <- c(resvec,gamma)
      namevec <- c(namevec,"Predictability")
    }
    if ( invector(result,"s") ) {
      resvec <- c(resvec,stddev) 
      namevec <- c(namevec,"std-dev")
    }
    if ( invector(result,"ubas") ) {
      resvec <- c(resvec,ubas) 
      namevec <- c(namevec,"upper bound asymptotic std-dev")
    }
    if ( invector(result,"i") ) {
      resvec <- c(resvec,isoto)
      namevec <- c(namevec,"Isotonicity")
    }
    if ( invector(result,"c") ) {
      resvec <- c(resvec,compatibility) 
      namevec <- c(namevec,"Compatibility")
    }
    if ( invector(result,"nsq") ) {
      resvec <- c(resvec,nsq)
      namevec <- c(namevec,"nsq")
    }
    if ( invector(result,"z") ) {
      resvec <- c(resvec,z)
      namevec <- c(namevec,"z")
    }
    if ( invector(result,"dbg") ) {
      resvec <- c(resvec,isoto2set,n,sumsdt,isoll,nsoll,nsoll^2)
      namevec <- c(namevec,"isoto2set","n","sumsdt","isoll","nsoll","nsoll^2")
    }

  names(resvec) <- namevec
  data.frame(resvec)
 
}


# 2 set multivariate
#-----------------criteria-----------------
#




isop.calc2set <- function(raw,set1,set2, verbose=TRUE, result="all")
{
  
isop.dominate <- function (coords.x,coords)
 (( sum(coords.x >= coords) == length(coords) ) & ( sum(coords.x > coords) > 0 )) 


isop.same <- function (coords.x,coords)
    sum(coords.x != coords) == 0

isop.criteriumS2set <- function (co.x,co,indexset1,indexset2)
    (( if( isop.dominate(co.x[indexset1], co[indexset1]) ) 
           isop.dominate(co.x[indexset2], co[indexset2])
       else F )
    |
     ( if( isop.dominate(co[indexset1], co.x[indexset1]) )
           isop.dominate(co[indexset2], co.x[indexset2])
       else F ))

isop.criteriumD2set <- function (co.x,co,indexset1,indexset2)
    (( isop.dominate(co.x[indexset1], co[indexset1]) &
       isop.dominate(co[indexset2], co.x[indexset2]) )
    |
    ( isop.dominate(co[indexset1], co.x[indexset1]) &
      isop.dominate(co.x[indexset2], co[indexset2]) ))

isop.criteriumT2set <- function (co.x,co,indexset1,indexset2)
    isop.same( co.x[indexset1], co[indexset1] ) |
    isop.same( co.x[indexset2], co[indexset2] )



isop.generateSDT2set <- function(x,nx,set1,set2, criterium)
{
  
  crit <-  function (index.x,co,indexset1,indexset2) 
    criterium(x[index.x,] , co ,indexset1,indexset2) 

  mat.lr <- function(index)
  { 
    sum( nx[ sapply( index.x,crit, x[index,] ,indexset1,indexset2 ) ] )
  }
  
  index.x <- 1:length(nx)

  indexset1 <- 1:length(set1)
  indexset2 <- length(set1)+1:length(set2)

  sapply(index.x, mat.lr)
} 

  #print(set1)
  #print(set2)
#  if ( (length(set1)==1) & (length(set2)==1) )
#     x <- table(raw[,set2],raw[,set1])
#  else x <- table(cbind(raw[,set2],raw[,set1]))
  xnx <- as.data.frame(table(as.data.frame(cbind(raw[,set1],raw[,set2]))))
  xnx <- xnx[xnx$Freq!=0,]
  x   <- isop.asmatrix(xnx[,1:(dim(xnx)[2]-1)])
  nx  <- xnx$Freq

  if ( verbose ) {
    print("calculating concordant matrix")
    print(paste("duration:", durS<-system.time(Smat <- isop.generateSDT2set(x, nx, set1, set2, isop.criteriumS2set))[3], "seconds"))
    print("calculating discordant matrix")
    print(paste("duration:", durD<-system.time(Dmat <- isop.generateSDT2set(x, nx, set1, set2, isop.criteriumD2set))[3], "seconds"))
    print("calculating tied matrix")
    print(paste("duration:", durT<-system.time(Tmat <- isop.generateSDT2set(x, nx, set1, set2, isop.criteriumT2set))[3], "seconds"))
    print(paste("Overall time: ",durS+durD+durT))
  } else {
    Smat <- isop.generateSDT2set(x, nx, set1, set2, isop.criteriumS2set)
    Dmat <- isop.generateSDT2set(x, nx, set1, set2, isop.criteriumD2set)
    Tmat <- isop.generateSDT2set(x, nx, set1, set2, isop.criteriumT2set)
  }

  ns <- sum(nx*Smat)  
  nd <- sum(nx*Dmat)
  nt <- sum(nx*Tmat)
  nss <- sum(nx*Smat^2)  
  ndd <- sum(nx*Dmat^2)
  nsd <- sum(nx*Smat*Dmat)

  ps <- ns/(ns+nd+nt)
  pd <- nd/(ns+nd+nt)
  pt <- nt/(ns+nd+nt)
  pss <- nss/(ns+nd+nt)^2
  pdd <- ndd/(ns+nd+nt)^2
  psd <- nsd/(ns+nd+nt)^2

  stddev <- sqrt( (16/(1-pt)^4) * (ps^2*pdd-2*ps*pd*psd+pd^2*pss) )
  gamma <- (ns - nd) / (ns + nd)
  compatibility <- ns + nt
  nsq <- ns+nd+nt
  isoto <- compatibility / nsq
  z <- gamma*sqrt(sqrt(nsq))/stddev
  ubas <- sqrt( 2*(1-gamma^2)/ps+pd )

  invector <- function(vec, val) {
    length(vec[vec == val])>0
  }

  if ( ( length(result) == 1 ) && (result == "all") ) 
return (data.frame(ns,nd,nt,nss,ndd,nsd,ps,pd,pt,pss,pdd,psd,gamma,stddev,ubas,isoto,compatibility,nsq,z))
  
    resvec <- NULL
    namevec <- NULL
    if ( invector(result,"n") ) {
      resvec <- c(ns,nd,nt,nss,ndd,nsd)
      namevec <- c("ns","nd","nt","nss","ndd","nsd")
    }
    if ( invector(result,"p") ) {
      resvec <- c(resvec,ps,pd,pt,pss,pdd,psd) 
      namevec <- c(namevec,"ps","pd","pt","pss","pdd","psd")
    }
    if ( invector(result,"g") ) {
      resvec <- c(resvec,gamma) 
      namevec <- c(namevec,"Predictability")
    }
    if ( invector(result,"s") ) {
      resvec <- c(resvec,stddev) 
      namevec <- c(namevec,"std-dev")
    }
    if ( invector(result,"ubas") ) {
      resvec <- c(resvec,ubas) 
      namevec <- c(namevec,"upper bound asymptotic std-dev")
    }
    if ( invector(result,"i") ) {
      resvec <- c(resvec,isoto)
      namevec <- c(namevec,"isotonicity")
    }
    if ( invector(result,"c") ) {
      resvec <- c(resvec,compatibility) 
      namevec <- c(namevec,"compatibility")
    }
    if ( invector(result,"nsq") ) {
      resvec <- c(resvec,nsq)
      namevec <- c(namevec,"nsq")
    }
    if ( invector(result,"z") ) {
      resvec <- c(resvec,z)
      namevec <- c(namevec,"z")
    }
 
    names(resvec) <- namevec
    data.frame(resvec)
}

isop.testItems <- function(raw,selection=1:dim(raw)[2],items=selection,result=c("g","s","i"),verbose=TRUE)
{
  #dim(raw)[2] is the number of items

  transformItemnr <- function(itemnr) (1:dim(raw)[2])[selection==itemnr][1]
  relitems<-sapply(items,transformItemnr)
  raw<-raw[selection]
  gentest <- function(i) {
    if ( i == 1 ) set2 <- 2:dim(raw)[2]
    else if ( i == dim(raw)[2] ) set2 <- 1:(dim(raw)[2]-1)
         else set2 <- c( 1:(i-1) , (i+1):dim(raw)[2] )
    if ( verbose ) print( paste("Testing item ",selection[i]," against all other items" ) )
    isop.calc2set(raw,i,set2,verbose,result)
  }
  resvec<-sapply(relitems,gentest)
  dimnames(resvec)[[2]]<-paste("item ",items)
  resvec
}

#----------------system characteristics----------


isop.calcTau<-function(raw, sortit = T) {
  points<-rowSums(raw)
  asum<- rowsum(raw, points)
  pointfreq<-as.integer(table(points))
  taus<-(asum/pointfreq)
  dimnames(taus)[[1]]<-1:(dim(taus)[[1]])
  if (sortit) res<-isop.sortbyrowcolSum(taus, pointfreq)
         else res<-data.frame(taus,freq=pointfreq)
  res
}
 
isop.sysch<-function(raw) {
  taudf<-isop.calcTau(raw)
  taus<-taudf[,names(taudf)!="freq"]
  freq<-taudf$freq
  p<-taus/max(taus)
  data.frame(p, freq)
}

#------------------- 

#type = 1 -> W1
#type = 2 -> W2

isop.W12 <- function( raw, items=1:dim(raw)[2], type, showWi=(type==1) )
{
  if(type == 1) isop.W1( raw, items, type, showWi )
  else { 
    if(type == 2) isop.W2( raw, items, type, showWi )
    else print("Error: please use only type=1 or 2 for W1 or W2")
  }
}

isop.W1 <- function( raw, items=1:dim(raw)[2], type=1, showWi=(type==1) )
{ 
    print("!!!Attention: Values could be wrong!!!")
  rawcut <- isop.asmatrix(raw[items])
  if (type==1) {
    print("calcutating W1")
 
    xnx <- as.data.frame(table(as.data.frame(rawcut)))
    xnx <- xnx[xnx$Freq!=0,]
    x   <- isop.asmatrix(xnx[,1:(dim(xnx)[2]-1)])
    nx  <- xnx$Freq

  }
  else {
    print("calcutating W2")
    x   <- t(rawcut)
    nx  <- rep(1,dim(x)[1])

  }
  
  nx<-nx/sum(nx)#wirklich nötig?
  

#  print("nx")
#  print(nx) 
#  print("x")
#  print(x) 

  #xi ist x im paper
  #xxi ist x' im paper  

  genesi <- function(xindex,itemnr) {

    gensxi <- function(xxindex) {

      sxxi <- function(xi,xxi,refitemnr) { 

        if (refitemnr == 1) j <- 2:length(xi)
        else
          if (refitemnr == length(xi)) j <- 1:(length(xi)-1)
          else
            j <- c( 1:(refitemnr-1) , (refitemnr+1):length(xi) )
        #if( xi[refitemnr] == xxi[refitemnr] ) { print(c(xi[refitemnr], xxi[refitemnr)); 0 }
        #else 
        sum( sign(xi[refitemnr]-xxi[refitemnr]) * sign(xi[j]-xxi[j]) == 1 ) 
      }
      nx[xxindex] * sxxi(x[xindex,],x[xxindex,],itemnr)

    }
    nx[xindex] * sum(sapply((xindex+1):(dim(x)[1]),gensxi))

  }

  genedi <- function(xindex,itemnr) {

    gendxi <- function(xxindex) {

      dxxi <- function(xi,xxi,refitemnr) { 

        if (refitemnr == 1) j <- 2:length(xi)
        else
          if (refitemnr == length(xi)) j <- 1:(length(xi)-1)
          else
            j <- c( 1:(refitemnr-1) , (refitemnr+1):length(xi) )
        #if( xi[refitemnr] == xxi[refitemnr] ) 0
        #else 
        sum( sign(xi[refitemnr]-xxi[refitemnr]) * sign(xi[j]-xxi[j]) == -1 ) 
        #if (cnt!=0) cnt+1

      }
      nx[xxindex] * dxxi(x[xindex,],x[xxindex,],itemnr)

    }
    nx[xindex] * sum(sapply((xindex+1):(dim(x)[1]),gendxi))

  }

  esisum <- edisum <- 0
  
    doesi <- function ( itemnr ) sum(sapply(1:(dim(x)[1]-1),genesi, itemnr))
    doedi <- function ( itemnr ) sum(sapply(1:(dim(x)[1]-1),genedi, itemnr))

    esi <- sapply(1:(dim(x)[2]), doesi)
    edi <- sapply(1:(dim(x)[2]), doedi)
    esisum<-sum(esi)
    edisum<-sum(edi)
    w <-  ((esisum - edisum) / (esisum + edisum))
    
  if ( showWi ) {
    wi <- (esi - edi) / (esi + edi)
    wvec <- matrix(nr=1)
    wvec <- c(wi,w)
    names(wvec) <- c(items,"Test")
    data.frame(wvec)

  } 
  else w 
  
}

isop.W2 <- function( raw, items=1:dim(raw)[2], type=2, showWi=(type==1) )
{ 
    print("!!!Attention: Values could be wrong!!!")
  raw <- isop.asmatrix(raw[items])
  if (type==1) {
    print("calcutating W1")


  
    pmap   <- t(raw)
    freq  <- rep(1,dim(pmap)[1])

#      print (xnx)
  }
  else {
    print("calcutating W2")
    xnx <- as.data.frame(table(as.data.frame(raw)))
    xnx <- xnx[xnx$Freq!=0,]
    pmap   <- isop.asmatrix(xnx[,1:(dim(xnx)[2]-1)])
    freq  <- xnx$Freq
  }
  
  #print(freq)
  #nx<-nx/sum(nx)#wirklich nötig?

  aiixf <- function(xx,i,ii,xsgn,freq,pmap,koeff) {
    a<-freq[xx] * ( xsgn * sign(pmap[xx,i] - pmap[xx,ii]) == koeff ) 
    #print(paste(xsgn,"mal sgn(", pmap[xx,i],"-",pmap[xx,ii],")[",sign(pmap[xx,i] - pmap[xx,ii]),"]ist",koeff,"+>",a))
    a
  }
  
  aixx <- function(ii,x,i,freq,pmap,koeff) {
    bufxx <- 1:dim(pmap)[1]
    xxf <- bufxx[!(bufxx==x)]
    xsgn <- (sign(pmap[x,i] - pmap[x,ii]))
    #print(c(x,i,ii,xsgn))
    #print( paste(xsgn,"ist sgn(", pmap[x,i],"-",pmap[x,ii]) ) 
    #print(koeff)
    sum(sapply(xxf,aiixf,i,ii,xsgn,freq,pmap,koeff))
  }

  aix <- function(i,x,freq,pmap,koeff) {
    bufii <- 1:dim(pmap)[2]
    iif <- bufii[!(bufii==i)]
    #print(koeff)
    sum(sapply(iif,aixx,x,i,freq,pmap,koeff))
  }
  
  ax <- function(x,freq,pmap,koeff) {
    #print(koeff)
    i<-1:dim(pmap)[2]
    sum(sapply(i,aix,x,freq,pmap,koeff))
  }
  #print("init done")
  
  xindex<-1:1:dim(pmap)[1]
  esx<-sapply(xindex,ax,freq,pmap,1)
  #print("esx done")
  #print(esx)


  edx<-sapply(xindex,ax,freq,pmap,-1)
  #print("edx done")
  #print(edx)


  etx<-sapply(xindex,ax,freq,pmap,0)
  #print("etx done")
  #print(etx)



  es<-sum(freq*esx)
  #print(es)

  ed<-sum(freq*edx)
  #print(ed)

  et<-sum(freq*etx)
  #print(et)

  ess<-sum(freq*esx^2)
  #print(ess)

  edd<-sum(freq*edx^2)
  #print(edd)

  esd<-sum(freq*etx^2)
  #print(esd)

  w <-  ((es - ed) / (es + ed))

  ps <- es/(es+ed+et)
  pd <- ed/(es+ed+et)
  pt <- et/(es+ed+et)
  pss <- ess/(es+ed+et)^2
  pdd <- edd/(es+ed+et)^2
  psd <- esd/(es+ed+et)^2
 
  print(c(ps,pd,pt,pss,pdd,psd))

  stddev <- sqrt( (4/(1-pt)^4) * (ps^2*pdd-2*ps*pd*psd+pd^2*pss) )

  print(paste("For testing purposes: stddev = ",stddev))

    
  if ( showWi ) {
    wx <- (esx - edx) / (esx + edx)
    wvec <- matrix(nr=1)
    wvec <- c(wx,w)
    names(wvec) <- c(items,"Test")
    data.frame(wvec)
  } 
  else w 
  
}
