R/slope_intercept.R

In fairy1991/coolpackage: Interactive graphics for linear regression

#' Slope and intercept for a line of best fit
#'
#' This function allows you to visualize the effect of choosing different values of slopes and intercepts on a simple line fit.
#'
#' @keywords intercept, slope
#' 
#' @import shiny
#' @import ggplot2
#' @import dplyr
#'
#' @export
#' @examples
#'
#' 
#'
slope_intercept = function(outlier = "none"){
  
  ## UI definition
  ui <- fluidPage(
    headerPanel('Guess coefficients for a simple linear regression'),
  
    sidebarPanel(
      
        tabsetPanel(type = "tabs", 
                    tabPanel("Trial 1", 
                             sliderInput(inputId = "interceptslider1",
                                         label = "Choose a value for the intercept",
                                         value = 0.5, min = 0, max = 1, step = 0.01),
                             sliderInput(inputId = "slopeslider1",
                                         label = "Choose a value for the slope",
                                         value = 0, min = -1, max = 1, step = 0.01),
                             actionButton(inputId = "trial1button",
                                          label = "Show this line")),
                    tabPanel("Trial 2",
                             sliderInput(inputId = "interceptslider2",
                                         label = "Choose a value for the intercept",
                                         value = 0.5, min = 0, max = 1, step = 0.01),
                             sliderInput(inputId = "slopeslider2",
                                         label = "Choose a value for the slope",
                                         value = 0, min = -1, max = 1, step = 0.01),
                             actionButton(inputId = "trial2button",
                                          label = "Show this line")),
                    tabPanel("Trial 3",
                             sliderInput(inputId = "interceptslider3",
                                         label = "Choose a value for the intercept",
                                         value = 0.5, min = 0, max = 1, step = 0.01),
                             sliderInput(inputId = "slopeslider3",
                                         label = "Choose a value for the slope",
                                         value = 0, min = -1, max = 1, step = 0.01),
                             actionButton(inputId = "trial3button",
                                          label = "Show this line"))
        ),
      hr(),
      actionButton(inputId = "refresh",
                   label = "New dataset"),
      actionButton(inputId = "answer",
                   label = "Show best fit"),
      helpText("Trial 1: Blue"),
      helpText("Trial 2: Purple"),
      helpText("Trial 3: Green"),
      helpText("Best fit: Black")
    ),
    mainPanel(
      plotOutput("heightplot"),
      tableOutput("table1"),
      hr(),
      tableOutput("table2")
    )
  )

  ## Server definition
  server <- function(input, output, session) {
    ## generate new dataset based on input
    observeEvent(input$refresh, session$reload())
    
    
    
    if (outlier == "extreme") {
      
      sign = c(1, -1)
      randomsign = sample(sign,x <- 1:12)
      samplesize = sample(20:50, 1)
      intercept = runif(1, 0, 1)
      slope = runif(1, -intercept, 1 - intercept)
      
      data.example = data.frame(x = runif(samplesize-1, 0, 1)) %>%
        mutate(y = intercept + slope * x + rnorm(samplesize-1, mean = 0, sd = 0.05))
      
      data.example = rbind(data.example, c(intercept, randomsign*(intercept + slope*intercept + runif(1, intercept + slope*intercept + 0.15, intercept + slope*intercept + 2)))) %>%
        arrange(x) %>%
        mutate(., fitted = fitted(lm(y ~ x, data = .)))
    }
    
    
    else if (outlier == "moderate") {
      
      sign = c(1, -1)
      randomsign = sample(sign,x <- 1:12)
      samplesize = sample(20:50, 1)
      intercept = runif(1, 0, 1)
      slope = runif(1, -intercept, 1 - intercept)
      
      data.example = data.frame(x = runif(samplesize-1, 0, 1)) %>%
        mutate(y = intercept + slope * x + rnorm(samplesize-1, mean = 0, sd = 0.05))
      
      data.example = rbind(data.example, c(intercept, randomsign*(intercept + slope*intercept + runif(1, intercept + slope*intercept + 0.05, intercept + slope*intercept + 0.75)))) %>%
        arrange(x) %>%
        mutate(., fitted = fitted(lm(y ~ x, data = .)))
    }
    
    
    
    
    
    else {
      
    ## generate data
    samplesize = sample(20:50, 1)
    intercept = runif(1, 0, 1)
    slope = runif(1, -intercept, 1 - intercept)

    data.example = data.frame(x = runif(samplesize, 0, 1)) %>%
      mutate(y = intercept + slope * x + rnorm(samplesize, mean = 0, sd = 0.05)) %>%
      arrange(x) %>%
      mutate(., fitted = fitted(lm(y ~ x, data = .)))
    }
  
    ## fitted values based on user input
    height.pred1 <- reactive({
      data.frame(x.value = 0:1) %>%
        mutate(fx = input$interceptslider1 + input$slopeslider1 * x.value)
    })
    
    height.pred2 <- reactive({
      data.frame(x.value = 0:1) %>%
        mutate(fx = input$interceptslider2 + input$slopeslider2 * x.value)
    })
    
    height.pred3 <- reactive({
      data.frame(x.value = 0:1) %>%
        mutate(fx = input$interceptslider3 + input$slopeslider3 * x.value)
    })



    ## add least squares fit based on input
    model <- eventReactive(input$answer, lm(y ~ x, data = data.example))

    ## model output
    output$summary <- renderPrint({
      summary(model())$coef[,1]
    })
    
    
    
    # Reactive expression to compose a data frame containing all the user specified values
    saveddata <- reactive({
      
      # Compose data frame
      data.frame(
        Intercept = as.character(c(input$interceptslider1, input$interceptslider2, input$interceptslider3)),
        Slope = as.character(c(input$slopeslider1, input$slopeslider2, input$slopeslider3))
      )
    }) 
    

    # Show the values using an HTML table
    output$table1 <- renderTable({
      saveddata()
    })
    
    
    
    bestfittable <- reactive({
      
      data.frame(
        Intercept = as.character(signif(summary(model())$coef[1,1]), digits = 4),
        Slope = as.character(signif(summary(model())$coef[2,1]), digits = 4)
      )
    }) 
    
    output$table2 <- renderTable({
      bestfittable()
    })
    
    
    
    
    
  
    if(outlier == "extreme") {
  
   ## plot
    output$heightplot <- renderPlot({
      
      p1 <- ggplot(data.example, aes(x = x, y = y)) + geom_point(color = "red", size = 1) +
        labs(x = "Value of x", y = "Value of y") + theme_bw()
      
      
      if (input$trial1button) {
        p1 <- p1 + geom_path(data = height.pred1(), aes(x = x.value, y = fx), color = "blue")
      }
      
      
      
      if (input$trial2button){
        p1 <- p1 + geom_path(data = height.pred2(), aes(x = x.value, y = fx), color = "purple")
      }
      if (input$trial3button){
        p1 <- p1 + geom_path(data = height.pred3(), aes(x = x.value, y = fx), color = "green")
        
      }
      if (input$answer) {
        p1 <- p1 + geom_line(data = data.example, aes(x = x, y = fitted), color = "black")
      }
      
      print(p1)
      
    })
  
    }
    
    else if (outlier == "moderate") {
      
      ## plot
      output$heightplot <- renderPlot({
        
        p1 <- ggplot(data.example, aes(x = x, y = y)) + geom_point(color = "red", size = 1) +
          labs(x = "Value of x", y = "Value of y") + theme_bw()
        
        
        if (input$trial1button) {
          p1 <- p1 + geom_path(data = height.pred1(), aes(x = x.value, y = fx), color = "blue")
        }
        
        
        
        if (input$trial2button){
          p1 <- p1 + geom_path(data = height.pred2(), aes(x = x.value, y = fx), color = "purple")
        }
        if (input$trial3button){
          p1 <- p1 + geom_path(data = height.pred3(), aes(x = x.value, y = fx), color = "green")
          
        }
        if (input$answer) {
          p1 <- p1 + geom_line(data = data.example, aes(x = x, y = fitted), color = "black")
        }
        
        print(p1)
        
      })
      
    }
    
    else {
      
      ## plot
      output$heightplot <- renderPlot({
        
        p1 <- ggplot(data.example, aes(x = x, y = y)) + geom_point(color = "red", size = 1) +
          labs(x = "Value of x", y = "Value of y") + coord_cartesian(xlim = c(0, 1), ylim = c(0, 1)) + theme_bw()
        
        
        if (input$trial1button) {
          p1 <- p1 + geom_path(data = height.pred1(), aes(x = x.value, y = fx), color = "blue")
        }
        
        
        
        if (input$trial2button){
          p1 <- p1 + geom_path(data = height.pred2(), aes(x = x.value, y = fx), color = "purple")
        }
        if (input$trial3button){
          p1 <- p1 + geom_path(data = height.pred3(), aes(x = x.value, y = fx), color = "green")
          
        }
        if (input$answer) {
          p1 <- p1 + geom_line(data = data.example, aes(x = x, y = fitted), color = "black")
        }
        
        print(p1)
        
      })
      
    }
    
}
  ## run app
  shinyApp(ui = ui, server = server)

}