R/winsor.R

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

"winsor" <-
function(x, trim=.2,na.rm=TRUE) {  
    if(is.vector(x) ) {
   ans <-  wins(x,trim=trim,na.rm=na.rm) } else {
   if (is.matrix(x) | is.data.frame(x)) {ans <- apply(x,2,wins,trim=trim,na.rm=na.rm) } }
   return(ans)
}

"winsor.means" <-
function(x, trim=.2,na.rm=TRUE) {  
    if(is.vector(x) ) {
   ans <-  win.mean(x,trim=trim,na.rm=na.rm) } else {
   if (is.matrix(x) | is.data.frame(x)) {ans <- apply(x,2,win.mean,trim=trim,na.rm=na.rm) } }
   return(ans)
}

"winsor.mean" <-
function(x, trim=.2,na.rm=TRUE) {  
    if(is.vector(x) ) {
   ans <-  win.mean(x,trim=trim,na.rm=na.rm) } else {
   if (is.matrix(x) | is.data.frame(x)) {ans <- apply(x,2,win.mean,trim=trim,na.rm=na.rm) } }
   return(ans)
}

"winsor.var" <-
function(x, trim=.2,na.rm=TRUE) {  
    if(is.vector(x) ) {
   ans <-  win.var(x,trim=trim,na.rm=na.rm) } else {
   if (is.matrix(x) | is.data.frame(x)) {ans <- apply(x,2,win.var,trim=trim,na.rm=na.rm) } }
   return(ans)
}

"winsor.sd" <-
function(x, trim=.2,na.rm=TRUE) {  
    if(is.vector(x) ) {
   ans <-  sqrt(win.var(x,trim=trim,na.rm=na.rm) )} else {
   if (is.matrix(x) | is.data.frame(x)) {ans <- apply(x,2,win.var,trim=trim,na.rm=na.rm) 
    ans <- sqrt(ans) } }
   return(ans)
}

 #added winsor.var and winsor.sd and winsor.mean (to supplement winsor.means) August 28, 2009 following a suggestion by Jim Lemon
  #corrected January 15, 2009 to use the quantile function rather than sorting.
  #suggested by Michael Conklin in correspondence with Karl Healey
  #this preserves the order of the data
"wins" <- 
 function(x,trim=.2, na.rm=TRUE) {
    if ((trim < 0) | (trim>0.5) ) 
        stop("trimming must be reasonable")
      qtrim <- quantile(x,c(trim,.5, 1-trim),na.rm = na.rm)
      xbot <- qtrim[1]
      xtop <- qtrim[3]
       if(trim<.5) { 
      x[x < xbot]  <- xbot
      x[x > xtop] <- xtop} else {x[!is.na(x)] <- qtrim[2]}
     return(x) } 
    
    
"win.mean" <- 
function(x,trim=.2, na.rm=TRUE) {
    if ((trim < 0) | (trim>0.5) ) 
        stop("trimming must be reasonable")
     if (trim < .5) {
   ans <-  mean(wins(x,trim =trim,na.rm=na.rm),na.rm=na.rm)
   return(ans)} else {return(median(x,na.rm=TRUE))} 
   }
   
   
"win.var" <- 
function(x,trim=.2, na.rm=TRUE) {
    if ((trim < 0) | (trim > 0.5) )   {stop("trimming must be reasonable")}
     if (trim < .5) {
   ans <-  var(wins(x,trim =trim,na.rm=na.rm),na.rm=na.rm)
          return(ans)
    } else {return(median(x,na.rm=TRUE))
    }
}