R devel - Mar 2004 - ridit()

I have tried to encode a ridit function.

(cf. Bross IDJ: How to use ridit analyses.
In: Biometrics 1958(14): 18-38. 
Application e.g.:
Goossen WTF. Exploiting the Nursing Minimum Data Set for the Netherlands.
In: Medinfo 2001 2001: 1334-1338.
http://cmbi.bjmu.edu.cn/2001/medinfo_2001/Papers/Ch16/Goossen.pdf.)

Questions and hints:
- Is there already a ridit function in R?
- Argument ``b.sel.attrs'' could be omitted.
- Perhaps there are more efficient ways than calculating:
  viq.ridit <- apply( t( t(x) * vjq.ridit.attr ), 1, sum, na.rm=T ) /
        apply( x, 1, sum, na.rm=T )
- There seems to be a problem with the recursive call of CALC.ridit()
  when attr.groups is set to a dataframe with as many rows as there
  are columns in x (third example).
  (See also my question to R-help:
  https://www.stat.math.ethz.ch/pipermail/r-help/2004-March/045915.html)

Examples:
- CALC.ridit()
- CALC.ridit( attr.groups=c('x','x','y','y') )
- CALC.ridit( attr.groups=data.frame(
G1=c('1x','1x','1y','1y'),
G2=c('2x','2x','2y','2z') ) )

Wolfram


CALC.ridit <-           # x: columns=attributes, rows=cases
      x= t( data.frame(
row.names=c('I','II','III','IV' )
            , A=c(20,8,2,0), B=c( 2,6,8,14), C=c(8,16,10,6) ) )
    , sum.attr=NULL     # vector with sum of cases per attributes
    , attr.groups=NULL  # separate calculation for groups of attributes
                        # e.g.:
c('x','x','y','y')
    , b.sel.attrs=NULL  # selection of attributes
    , na.ridit=NA       # or: 0.5 (?)
){
    if( ! is.null( b.sel.attrs ) ){
        x <- x[,b.sel.attrs]
        sum.attr <- sum.attr[b.sel.attrs]
    }
    if( is.null( sum.attr ) ){
        if( is.vector( x ) )  sum.attr <- sum(x)
        sum.attr <- apply( x, 2, sum, na.rm=T )
    }
    if( is.null( attr.groups ) ){
        vjq.ridit.attr <- 
            ( cumsum( sum.attr ) - sum.attr / 2 ) / sum( sum.attr, na.rm=T )
        if( is.vector( x ) )
            viq.ridit <- x * vjq.ridit.attr / x
        else
            viq.ridit <- apply( t( t(x) * vjq.ridit.attr ), 1, sum, na.rm=T )
/
                apply( x, 1, sum, na.rm=T )
        viq.ridit[ ! is.finite( viq.ridit ) ] <- na.ridit
        viq.ridit
    }else{
warning( 'This code branch is not testet enough.\n' )
        as.data.frame.list( tapply( X=seq( 1 : ncol(x) )
            , INDEX=attr.groups, simplify=T
            , FUN=function( z ) CALC.ridit( x=x[,z], sum.attr=sum.attr[z] )
            ))
    }
}