MSAN 622 Parallel Coordinates with Brushing using Shiny

global.r

require(ggplot2)
require(GGally)
require(shiny)

# Helper function: capitalize first letter of text
capitalize <- function(text) {
    result <- toupper(substring(text, 1, 1))
    result <- paste(result, substring(text, 2), sep = "")
    return(result)
}

# Load dataset
data(diamonds)

# Since this is a large dataset, take a small sample
# Increase size after debugging code
df <- diamonds[sample(1:dim(diamonds)[1],100),1:7]

# Capitalize all column names to improve display
names(df) <- sapply(names(df), capitalize)

# Determine which columns to keep for parallel coordiantes
keep <- sapply(df, is.numeric)

# Get column indicies for use in ggparcood()
numberColumns <- c(1:ncol(df))[keep]
factorColumns <- c(1:ncol(df))[!keep]

# Associate column indicies with names
names(numberColumns) <- names(df)[keep]
names(factorColumns) <- names(df)[!keep]

# Return basic parallel coordinate plot
getPlot <- function(
        colorIndex = factorColumns[1],      # Column index
        caratRange = range(df["Carat"]),    # Range for carat
        depthRange = range(df["Depth"]),    # Range for depth
        tableRange = range(df["Table"]),    # Range for table
        priceRange = range(df["Price"])     # Range for price
    ) {   
    
    # Note the colorIndex returned is a character,
    # so we must convert it back into an integer
    colorIndex <- as.integer(colorIndex)
    
    # Generate base parallel coordinates plot
    p <- ggparcoord(
        
        # This dataset will be melted by ggparcoord()
        data = df,
        
        # Only include numeric values in plot
        columns = numberColumns,
        
        # Color lines by the specified column
        groupColumn = colorIndex,
        
        # The technique used to annotate axis lines with
        # the ranges requires the scale to be normalized
        scale = "uniminmax",
        
        # Make the lines very transparent, so that
        # the selected lines are more visible
        alphaLines = 0.05,
        
        # Provide a plot title
        title = "Diamonds"
    )
    
    # Determine which rows are in selected ranges
    focusRows <- rep(TRUE, nrow(df))
    focusRows <- focusRows & (df$Carat >= caratRange[1])
    focusRows <- focusRows & (df$Carat <= caratRange[2])
    focusRows <- focusRows & (df$Depth >= depthRange[1])
    focusRows <- focusRows & (df$Depth <= depthRange[2])
    focusRows <- focusRows & (df$Table >= tableRange[1])
    focusRows <- focusRows & (df$Table <= tableRange[2])
    focusRows <- focusRows & (df$Price >= priceRange[1])
    focusRows <- focusRows & (df$Price <= priceRange[2])
    focusRows <- which(focusRows)

    # Subset data used by plot (already melted and scaled)
    # to only include focus rows.
    focusData <- subset(
        p$data, 
        as.numeric(p$data$.ID) %in% focusRows
    )
    
    # Plot highlighted lines
    p <- p + geom_line(
        data = focusData,
        alpha = 0.4,
        mapping = aes(x = variable, y = value)
    )
    
    # Modify padding around plot
    p <- p + scale_x_discrete(expand = c(0.025, 0.0))
    p <- p + scale_y_continuous(expand = c(0.02, 0.0))

    # Customize style
    p <- p + theme_minimal()
    p <- p + theme(legend.position = "bottom")
    p <- p + theme(axis.ticks = element_blank())
    p <- p + theme(axis.title = element_blank())
    p <- p + theme(axis.text.y = element_blank())
    p <- p + theme(panel.grid.minor = element_blank())
    p <- p + theme(panel.grid.major.y = element_blank())        
    
    # Add text annotations for range of vertical axis lines
    rangeLabels <- c(
        sapply(df[keep], min),      # Plot min values first
        sapply(df[keep], max)       # Plot max values last
    )

    # Plot a label for each line along x-axis
    xPositions <- rep(1:length(numberColumns), times = 2)
    
    # Plot text at top and bottom of axis lines
    # Need to know how data was scaled
    yPositions <- rep(
        extendrange(p$data$value, f = 0.1),
        each = length(numberColumns)
    )

    # Plot text annotations
    p <- p + annotate(
        "text", size = 3,
        x = xPositions,
        y = yPositions,
        label = as.character(rangeLabels)
    )
    
    return(p)
}

server.r

shinyServer(function(input, output) {
    
    output$plot <- reactivePlot(function() {
        print(getPlot(
            colorIndex = input$column,
            caratRange = input$carat,
            depthRange = input$depth,
            tableRange = input$table,
            priceRange = input$price)
        )
    })
    
})

ui.r

shinyUI(pageWithSidebar(
    headerPanel("Diamonds (with Brushing)"),
    
    sidebarPanel(
        radioButtons(
            inputId = "column", 
            label = "Color Lines By:",
            choices = factorColumns
        ),
        
        br(),
        
        sliderInput(
            inputId = "carat",
            label = "Carat Range:",
            
            # Use extendrange to account for any round-off
            min = extendrange(df["Carat"])[1],
            max = extendrange(df["Carat"])[2],
            value = extendrange(df["Carat"])
        ),
        
        sliderInput(
            inputId = "depth",
            label = "Depth Range:",
            min = extendrange(df["Depth"])[1],
            max = extendrange(df["Depth"])[2],
            value = extendrange(df["Depth"])
        ),
        
        sliderInput(
            inputId = "table",
            label = "Table Range:",
            min = extendrange(df["Table"])[1],
            max = extendrange(df["Table"])[2],
            value = extendrange(df["Table"])
        ),
        
        sliderInput(
            inputId = "price",
            label = "Price Range:",
            min = extendrange(df["Price"])[1],
            max = extendrange(df["Price"])[2],
            value = extendrange(df["Price"])
        )
    ),
    
    mainPanel(plotOutput("plot"))
))