Complete code R Shiny app example lab 7


Packages used:

library(shiny)
library(tidyverse)
library(MASS)
library(splines)
library(ISLR)

Code for UI.R

# Define UI for application that draws a histogram
shinyUI(fluidPage(

    # Application title
    titlePanel("Statistics in the Sky with Diamonds"),
    
    # Description
    p("A Shiny application, predicting the Carat of different Cuts of Diamonds, by their Price."),
    
    

    # Sidebar with a slider input for number of bins
    sidebarLayout(
        sidebarPanel(
        
            sliderInput("priceInput", "Price", 0, 20000, c(100, 10000)),
            sliderInput("caratInput", "Carat", 0, 5, c(0, 5), step = 0.1),
            checkboxGroupInput("cutInput", "Diamond Cut",
                     choices = c("Fair", "Good", "Very Good", "Premium", "Ideal"),
                     selected = c("Fair", "Good", "Very Good", "Premium", "Ideal")),
            selectInput("colInput", "Colour Choice", 
                     choices = c("Pastel1", "Paired", "Spectral", "RdBu", "PuOr"),
                     selected = "Spectral"),
            checkboxInput("regInput", "Linear Regression", value = FALSE, width = NULL),
            checkboxInput("polyInput", "Polynomial Regression", value = FALSE, width = NULL),
            checkboxInput("stepInput", "Stepwise Regression", value = FALSE, width = NULL),
            sliderInput("stepcutInput", "Stepwise Cut", value = 5, min = 2, max = 20),
            ),

        # Show a plot of the generated distribution
        mainPanel(
            
            # Sub-Heading
            h4("Graphical Output"),
            
            # Main Graphical Output
            plotOutput("diaPlot"),
            
            # Sub-Heading
            h4("Statistical Analysis"),
            
            # Statistical Analysis Outcome
            tableOutput("modelres"),
            
            # Text Commentary 
            textOutput("statout")
        )
    )
))

Code for Server.R

# Define server logic required to draw a histogram
shinyServer(function(input, output) {
    
    # Plotting Example
    output$diaPlot <- renderPlot({

        filtered <- 
            diamonds %>%
            filter(price >= input$priceInput[1],
                   price <= input$priceInput[2],
                   carat >= input$caratInput[1],
                   carat <= input$caratInput[2],
                   cut == input$cutInput
            )
        model.lin <- lm(carat ~ price, data = filtered)
        model.pol <- lm(carat ~ price + I(price^2) + I(price^3), data = filtered)
        model.step <- lm(carat ~ cut(x = price, breaks = input$stepcutInput), data = filtered)
        
        x_pred <- seq(min(filtered$price), max(filtered$price), length.out = 500)
        y_pred.lin <- predict(model.lin, newdata = tibble(price = x_pred))
        y_pred.pol <- predict(model.pol, newdata = tibble(price = x_pred))
        y_pred.step <- predict(model.step, newdata = tibble(price = x_pred))
        
        ggplot(data = filtered, 
               mapping = aes(x = price, y = carat, colour = cut)) + 
            geom_point() +
            geom_line(data = tibble(price = x_pred, carat = y_pred.lin), size = input$regInput, col = "blue") +
            geom_line(data = tibble(price = x_pred, carat = y_pred.pol), size = input$polyInput, col = "red") +
            geom_line(data = tibble(price = x_pred, carat = y_pred.step), size = input$stepInput, col = "green") +
            scale_color_brewer(palette = input$colInput) + 
            theme_minimal()
        
        
        
    })
    
    # Model Table output
    output$modelres <- renderTable({
        filtered <- 
            diamonds %>%
            filter(price >= input$priceInput[1],
                   price <= input$priceInput[2],
                   carat >= input$caratInput[1],
                   carat <= input$caratInput[2],
                   cut == input$cutInput
            )
        model.lin <- lm(carat ~ price, data = filtered)
        model.pol <- lm(carat ~ price + I(price^2) + I(price^3), data = filtered)
        model.step <- lm(carat ~ cut(x = price, breaks = input$stepcutInput), data = filtered)
        
        model.lin.sum <- summary(model.lin)
        model.pol.sum <- summary(model.pol)
        model.step.sum <- summary(model.step)
        
        tablemodelres <- matrix(c("Linear Regression", "Polynomial Regression", "Stepwise Regression",
                                  round(model.lin.sum$r.squared, 3), round(model.pol.sum$r.squared, 3), 
                                  round(model.step.sum$r.squared, 3), round(model.lin.sum$adj.r.squared, 3), 
                                  round(model.pol.sum$adj.r.squared, 3), round(model.step.sum$adj.r.squared, 3),
                                  model.lin.sum$df[2], model.pol.sum$df[2], model.step.sum$df[2]), ncol = 4)
        colnames(tablemodelres) <- c(" ", "R-squared", "Adj R-squared", "df")
        
        
        tablemodelres
        })
    
    # Model Statistical Output (Text)
    output$statout <- renderText({
        
        filtered <- 
            diamonds %>%
            filter(price >= input$priceInput[1],
                   price <= input$priceInput[2],
                   carat >= input$caratInput[1],
                   carat <= input$caratInput[2],
                   cut == input$cutInput
            )
        model.lin <- lm(carat ~ price, data = filtered)
        model.pol <- lm(carat ~ price + I(price^2) + I(price^3), data = filtered)
        model.step <- lm(carat ~ cut(x = price, breaks = input$stepcutInput), data = filtered)
        
        model.lin.sum <- summary(model.lin)
        model.pol.sum <- summary(model.pol)
        model.step.sum <- summary(model.step)
        
        model.lin.sum[["name"]] <- "Linear Regression"
        model.pol.sum[["name"]] <- "Polynomial Regression"
        model.step.sum[["name"]] <- "Stepwise Regression"
        
        # Best fitting model, with R-squared
        if(model.lin.sum$adj.r.squared > model.pol.sum$adj.r.squared & model.step.sum$adj.r.squared){
                model.text.out <- model.lin.sum
        } else if(model.pol.sum$adj.r.squared > model.lin.sum$adj.r.squared & model.step.sum$adj.r.squared){
                model.text.out <- model.pol.sum
        } else if (model.step.sum$adj.r.squared > model.lin.sum$adj.r.squared & model.pol.sum$adj.r.squared){
                model.text.out <- model.step.sum
        }
        
        paste0("The regression analysis which most accounts for the relationship is: ", model.text.out$name, ". ", 
               "With an Adjusted R-squared of: ", round(model.text.out$adj.r.squared, 3), ", F(",
               model.text.out$fstatistic[2], ", ", model.text.out$fstatistic[3], ")")
    })

        

})