7
\$\begingroup\$

I frequently get a situation in which I want a pretty binned column from a vector of values, so that I divide the vector in approximately even ranges and choose 'sensible' values so that it looks pretty when using the column in pivot tables or other reports. Sensible herein includes rounding values like 10123.1 to 10000 and 123.54 to 120 or 125

The following is what I came up with, and I was hoping someone else could have a look an see how I could do it more intelligently (I ended up taking a few shortcuts as it was a bit harder than I expected, it doesn't nicely handle small (decimal) values, for example).

The following is the output I would quite like when running an analysis on the data:

Grouped_Description
A.    102 -     6,000 (17% of obs)
B.  6,000 -    10,000 (16% of obs)
C. 10,000 -    20,000 (23% of obs)
D. 20,000 -    50,000 (22% of obs)
E. 50,000 - 2,580,000 (22% of obs)
F.        Missing data (1% of obs)

The following code is what I came up with, and brings the following when calling it like :

 > pretty_bins(mtcars$hp, return_vector=FALSE)
    hp                   hp.BINS hp.BINS.Sortorder hp.BINS.Min hp.BINS.Max hp.BINS.Prop
1  110 B. 100 - 150 (31% of obs)               B.          100         150      0.31250
2  110 B. 100 - 150 (31% of obs)               B.          100         150      0.31250
3   93 A.  50 - 100 (28% of obs)               A.           50         100      0.28125
4  110 B. 100 - 150 (31% of obs)               B.          100         150      0.31250
5  175 C. 150 - 200 (19% of obs)               C.          150         200      0.18750
6  105 B. 100 - 150 (31% of obs)               B.          100         150      0.31250
7  245 D. 200 - 250 (16% of obs)               D.          200         250      0.15625
8   62 A.  50 - 100 (28% of obs)               A.           50         100      0.28125
9   95 A.  50 - 100 (28% of obs)               A.           50         100      0.28125
10 123 B. 100 - 150 (31% of obs)               B.          100         150      0.31250
....

Or just calling it like:

>bin_example <- data.frame(source=mtcars$hp, source.binned=pretty_bins(mtcars$hp))
   source             source.binned
1     110 B. 100 - 150 (31% of obs)
2     110 B. 100 - 150 (31% of obs)
3      93 A.  50 - 100 (28% of obs)
4     110 B. 100 - 150 (31% of obs)
5     175 C. 150 - 200 (19% of obs)
6     105 B. 100 - 150 (31% of obs)
7     245 D. 200 - 250 (16% of obs)

Here is the code, suggestions are very much appreciated.

pretty_bins <- function(x, n=5, return_vector=TRUE){
  # Takes a vector, 
  # if return_vector = TRUE:  returns a vector pretty pivot-table binned names. 
  # if return_vector = FALSE: returns a data frame with the source values, 
  #                           description and components
  # 
  # Example usage: 
  # pretty_bins(mtcars$hp) 
  # pretty_bins(mtcars$hp, return_vector=FALSE) 
  require(dplyr)

  # First extract the variable name from the function call
  # (http://stackoverflow.com/questions/9666151/r-pass-variable-name-to-plotting-function-title-in-r)
  varname = deparse(substitute(x))
  if(grepl("\\$", varname)) {
    varname <- strsplit(varname, "\\$")[[1]][2]
  }

  bins <- cut(x, breaks=pretty(x, n=n), include.lowest=TRUE)
  # Is in format (NUMBER, NUMBER], change to character and extract start/end 
  # (http://stackoverflow.com/questions/8464312/r-converting-comma-separated-entry-to-columns)
  bins <- as.character(bins)
  df <- do.call("rbind", strsplit(bins, ","))
  # Remove preceding stuff
  df[,1] <- substr(df[,1], 2, nchar(df[,1]))
  df[,2] <- substr(df[,2], 1, nchar(df[,2])-1)

  # Create a data frame with all values
  df <- cbind(
    data.frame(value=x, bins, stringsAsFactors=FALSE),
    data.frame(apply(df, 2, as.numeric))
  )
  df$bins[is.na(df$bins)] <- "Missing data" 

  props <- data.frame(prop.table(table(df$bins)))
  props$Var1 <- as.character(props$Var1) # Prevent factor warning when joining
  df <- left_join(df, props, by=c("bins"="Var1"))

  groups <- unique(df[,c("bins","X1", "X2", "Freq")])

  # Add the ranks for naming
  groups$rank = rank(groups$X1)

  # Desired output: 
  #   A.   100 -  1000 (XX% of obs)
  #   B.  1000 - 10000 (XX% of obs)
  groups$Sorting <- paste0(
    toupper(letters[groups$rank]), ". ")  # Append letter for sorting
  groups$Min = format(groups$X1, decimal=".", big.mark =",")
  groups$Sep = " - "
  groups$Max = format(groups$X2, decimal=".", big.mark =",")
  groups$PropPrefix = " ("
  groups$PropTxt = format(groups$Freq*100, digits=1, decimal=".", big.mark =",")
  groups$PropSuffix = "% of obs)"

  # Prepend with spaces to align different columns
  groups$Min <- format(groups$Min, width = max(nchar(groups$Min)))
  groups$Max <- format(groups$Max, width = max(nchar(groups$Max)))

  groups$Description = paste0(groups$Sorting,
                              groups$Min,
                              groups$Sep,
                              groups$Max,
                              groups$PropPrefix,
                              groups$PropTxt,
                              groups$PropSuffix
  )
  groups <- groups %>%
    mutate(Description = ifelse(bins=="Missing data",
                                paste0(Sorting, 
                                       "Missing values ",
                                       PropPrefix, 
                                       PropTxt,
                                       PropSuffix),
                                Description))
  df = left_join(df, groups, by="bins")
  df <- select(df, 
               source_variable=value, 
               variable_bins=Description, 
               Sortorder=Sorting, 
               Min=X1.x, 
               Max=X2.x, 
               Prop=Freq.x)
  names(df)[names(df)=="source_variable"] <- varname
  names(df)[names(df)=="variable_bins"] <- paste0(varname, ".BINS")
  names(df)[3:6] <- paste0(varname, ".BINS.", names(df)[3:6])

  if(return_vector){
    return(df[, c(paste0(varname, ".BINS"))])
  } else{
    return(df)
  }
}
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.