R/scoring.R

Defines functions reverse normalize std2perc perc2std perc_rank raw_score std_score .scale_param raw2std

Documented in normalize perc2std perc_rank raw2std raw_score reverse std2perc std_score

# Converte un punteggio grezzo in standardizzato partendo da una tabella normativa
raw2std <- function(x, std.norm, raw.norm, sep="-")
{
    std.norm <- as.character(std.norm)
    raw.norm <- as.character(raw.norm)
    norm <- score_explode(raw.norm, sep=sep, out.names=std.norm)
    keep <- !is.na(norm)
    std.norm <- as.vector(norm[keep])
    raw.norm <- as.integer(names(norm[keep]))
    x.std <- raw.norm[match(x,std.norm)]
    return(x.std)
}

# Data una certa scala, estrae la media e la deviazione standard di riferimento
.scale_param <- function(scale=c("z","t","nce","iq","wss","stanine","sten"))
{
    scale <- tolower(scale[1])
    scale <- match.arg(scale)
    m <- switch(scale,"z"=0,"t"=50,"nce"=50,"iq"=100,"wss"=10,"stanine"=5,"sten"=5.5)
    s <- switch(scale,"z"=1,"t"=10,"nce"=49/qnorm(0.99),"iq"=15,"wss"=3,"stanine"=2,"sten"=2)
    return(list(m=m,s=s))
}

# Converte un punteggio grezzo in punteggio standardizzato
std_score <- function(x,m=NULL,s=NULL,scale=c("z","t","nce","iq","wss","stanine","sten"),integer=FALSE,out.names=x)
{
    if(is.null(m))
        m <- mean(x,na.rm=TRUE)
    if(is.null(s))
        s <- sd(x,na.rm=TRUE)
    n <- list("m"=length(m),"s"=length(s))
    if(n$m>1 & n$s==1) {
        s <- rep.int(s,n$m)
        n$s <- n$m
    } else {
        if(n$m==1 & n$s>1) {
            m <- rep.int(m,n$s)
            n$m <- n$s
        }
    }
    if(n$m != n$s)
        stop("m and s must be the same length.")
    pars <- .scale_param(scale=scale)
    if(n$m==1) {
        q <- pars$m + pars$s * ((x-m)/s)
        names(q) <- out.names
    } else {
        q <- sapply(seq_len(n$m),
            function(i)
                pars$m + pars$s * ((x-m[i])/s[i])
        )
        cn <- names(m)
        if(is.null(cn))
            cn <- names(s)
        colnames(q) <- cn
        rownames(q) <- out.names
        q <- data.frame(q, check.names=FALSE)
    }
    if(integer) {
        if(n$m==1)
            q <- integer_round(q)
        else
            q[,] <- apply(q, 2, integer_round)
    }
    return(q)
}

# Converte un punteggio standardizzato in punteggio grezzo
raw_score <- function(q,m,s,scale=c("z","t","nce","iq","wss","stanine","sten"),integer=FALSE,out.names=q)
{
    n <- list("m"=length(m),"s"=length(s))
    if(n$m>1 & n$s==1) {
        s <- rep.int(s,n$m)
        n$s <- n$m
    } else {
        if(n$m==1 & n$s>1) {
            m <- rep.int(m,n$s)
            n$m <- n$s
        }
    }
    if(n$m != n$s)
        stop("m and s must be the same length.")
    pars <- .scale_param(scale=scale)
    if(n$m==1) {
        x <- m+(s*(q-pars$m))/pars$s
        names(x) <- out.names
    } else {
        x <- sapply(seq_len(n$m),
            function(i)
                m[i]+(s[i]*(q-pars$m))/pars$s
        )
        cn <- names(m)
        if(is.null(cn))
            cn <- names(s)
        colnames(x) <- cn
        rownames(x) <- out.names
        x <- data.frame(x, check.names=FALSE)
    }
    if(integer) {
        if(n$m==1)
            x <- integer_round(x)
        else
            x[,] <- apply(x, 2, integer_round)
    }


    return(x)
}

# Calcola il rango percentile corrispondente a un punteggio grezzo
perc_rank <- function(x, breaks, fun="<=", perc=TRUE, digits=1, out.names=as.character(breaks))
{
    x <- as.vector(x[!is.na(x)])
    r <- numeric(length(breaks))
    for(i in 1:length(breaks))
        r[i] <- sum(outer(x, breaks[i], fun))
    r <- r/length(x)
    if(perc)
        r <- r*100
    if(!is.null(digits))
        r <- round(r,digits)
    names(r) <- out.names
    return(r)
}

# Calcola il percentile teorico corrispondente a un punteggio standardizzato
perc2std <- function(p, scale=c("z","t","nce","iq","wss","stanine","sten"))
{
    pars <- .scale_param(scale=scale)
    z <- qnorm(p/100)
    q <- pars$m + pars$s * z
    return(q)
}

# Calcola il punteggio standardizzato corrispondente a un percentile teorico
std2perc <- function(q, scale=c("z","t","nce","iq","wss","stanine","sten"))
{
    pars <- .scale_param(scale=scale)
    z <- (q - pars$m) / pars$s
    p <- pnorm(z) * 100
    return(p)
}

# Riscala un punteggio entro un nuovo minimo e un nuovo massimo
normalize <- function(x, new.min, new.max, x.min=min(x), x.max=max(x))
{
    x.new <- new.min + (new.max - new.min) * (x - x.min)/(x.max - x.min)
    return(x.new)
}
normalise <- normalize

# Inverte un punteggio scambiando massimo con minimo
reverse <- function(x, x.min=min(x), x.max=max(x))
{
    x.new <- x.max-x+x.min
    return(x.new)
}
DavideMassidda/testing documentation built on Oct. 12, 2023, 4:32 p.m.