# Pivot-friendly binning of arbitrary vector

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 =",")
groupsPropSuffix = "% of obs)" # Prepend with spaces to align different columns groupsMin <- 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)
}
}