R/sdt.R

In frenchja/psych: Procedures for Psychological, Psychometric, and Personality Research

"sdt" <- 
 function(x) {
  # if(!is.matrix(x)) {stop("x must be a matrix")}
   stopifnot(prod(dim(x)) == 4 || length(x) == 4)
    if (is.vector(x)) {
     x <- matrix(x, 2)}
   a  <- x[1,1]
   b <- x[1,2]
   c <- x[2,1]
   d <- x[2,2]
   colnames(x) <- c("signal","noise")
   rownames(x) <- c("Signal","Noise")
   
 T <- sum(x)
 signals <- a+b
 H <- a/signals
 noise <- c+d
 F <- c/noise
 dprime <- qnorm(H) - qnorm(F)
 beta <- exp(((qnorm(F)^2 - qnorm(H))^2/2)) 
 Beta <- dnorm(qnorm(H))/dnorm(qnorm(F))
 Aprime <- .5 + sign((H-F) *((H-F)^2 + abs(H-F))/(4*max(H,F)-4 * H*F))
 aprime <- .5 +(H-F)*(1-H-F)/(4*H*(1-F))
  C <- -(qnorm(H)+qnorm(F))/2 
  Bprime <- sign(H-F) * ((H*(1-H) - F*(1-F))/((H*(1-H) + F*(1-F)) ))
 sdt <- list(x=x,dprime=dprime,Beta=Beta,lnBeta=log(Beta),beta=beta,lnbeta =log(beta),Aprime=Aprime,C=C,Bprime=Bprime,aprime=aprime)
return(sdt)
 }
 
 
 beta.w <- function(hit,fa) {
 zhr <- qnorm(hit)
 zfar <- qnorm(fa) 
 exp(-zhr*zhr/2+zfar*zfar/2)
}

aprime <-function(hit,fa) { a<-1/2+((hit-fa)*(1+hit-fa) / (4*hit*(1-fa))) 
b<-1/2-((fa-hit)*(1+fa-hit) / (4*fa*(1-hit)))
a[fa>hit] <-b[fa>hit]
a[fa==hit]<-.5 
a
}
 
 test.sdt <- function(n) {
 hits <- 1:n
 misses <- (n-1):0
 fa <- sample(n,n,replace=TRUE)
# fa <- n/4
 cr <- n-fa
 test.sdt <- data.frame(hits,misses,fa,cr)
 }
 
 
 "sdt" <- 
 function(x) {
 if(is.null(dim(x))) {# the case of a single problem
 if (length(x) == 2) {x <- matrix(x,nrow=1)
     H <- x[1]
     F <- x[2]
    colnames(x) <- c("Hit Rate","False Alarmes")} else {
     x <- matrix(x,nrow=1)
    # H <- x[,1]/(x[,1] + x[,2])
     F <- x[,3]/(x[,3] + x[,4])
    x[(x[,2] < 1)] <- .5
    H <- x[,1]/(x[,1] + x[,2])
    if (x[,3] < 1) {F <- x[,3]/(x[,3] + x[,4] + .5)}
      colnames(x) <- c("signal","noise","Signal","Noise")}} else {
   if(dim(x)[2] ==2) { H <- x[,1]
     F <- x[,2] 
      colnames(x) <- c("Hit Rate","False Alarmes")} else { #the vector case
     x[(x[,2] < 1),2] <- .5
     x[(x[,3] < 1),3] <- .5
     
      H <- x[,1]/(x[,1] + x[,2])
      F <- x[,3]/(x[,3] + x[,4])
   
   colnames(x) <- c("signal","noise","Signal","Noise")}
}
 
 dprime <- qnorm(H) - qnorm(F)
 beta <- dnorm(qnorm(H))/dnorm(qnorm(F)) #definitional
 cprime <-  -.5*(qnorm(H) + qnorm(F))/dprime   #macmillan
 beta.w <- exp(-qnorm(H)^2/2+qnorm(F)/2 ) #pallier  = beta    
 Aprime <- .5 +(H-F)*(1+H-F)/(4*H*(1-F)) #Grier
 Bprime <- sign(H-F) * ((H*(1-H) - F*(1-F))/((H*(1-H) + F*(1-F)) ))
 bprime <- ((1-H)*(1-F)-H*F)/((1-H)*(1-F)+H*F)
 sdt <- data.frame(x=x,dprime=dprime,beta=beta,cprime=cprime,lnBeta=log(beta),Aprime=Aprime,Bprime=Bprime,brime=bprime,beta.w = beta.w)
return(sdt)
 }