Last active
January 6, 2023 14:34
-
-
Save calpolystat/8e898319968d31b27310 to your computer and use it in GitHub Desktop.
Correlation and Regression Game: Shiny app at http://www.statistics.calpoly.edu/shiny
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Correlation and Regression Game Shiny App | |
| Base R code created by Irvin Alcaraz | |
| Shiny app files created by Irvin Alcaraz | |
| Cal Poly Statistics Dept Shiny Series | |
| http://statistics.calpoly.edu/shiny |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Title: Correlation and Regression Game | |
| Author: Irvin Alcaraz | |
| AuthorUrl: https://www.linkedin.com/in/irvinalcaraz | |
| License: MIT | |
| DisplayMode: Normal | |
| Tags: Correlation, regression | |
| Type: Shiny |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| The MIT License (MIT) | |
| Copyright (c) 2015 Irvin Alcaraz | |
| Permission is hereby granted, free of charge, to any person obtaining a copy | |
| of this software and associated documentation files (the "Software"), to deal | |
| in the Software without restriction, including without limitation the rights | |
| to use, copy, modify, merge, publish, distribute, sublicense, and/or sell | |
| copies of the Software, and to permit persons to whom the Software is | |
| furnished to do so, subject to the following conditions: | |
| The above copyright notice and this permission notice shall be included in | |
| all copies or substantial portions of the Software. | |
| THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR | |
| IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, | |
| FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE | |
| AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER | |
| LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, | |
| OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN | |
| THE SOFTWARE. |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| library(shiny) | |
| library(shinyBS) | |
| library(ggplot2) | |
| library(magrittr) | |
| library(ggvis) | |
| ###A function to create random data with a certain correlation | |
| create = function(n,rho){ | |
| x1 = rnorm(n,sample(c(0,1,3),1),sample(c(1,2),1)) | |
| x2 = rnorm(n,sample(c(2,4,6),1),sample(c(1,2,3),1)) | |
| xctr = scale(cbind(x1,x2),center=TRUE,scale=FALSE) | |
| Q = qr.Q(qr(xctr[ , 1, drop=FALSE])) | |
| P = tcrossprod(Q) | |
| x2o = (diag(n)-P) %*% xctr[ , 2] | |
| xc2 = cbind(xctr[ , 1], x2o) | |
| Y = xc2 %*% diag(1/sqrt(colSums(xc2^2))) | |
| if (rho==1){ | |
| x3 = Y[ , 1] | |
| }else{ | |
| x3 = Y[ , 2] + (1 / tan(acos(rho))) * Y[ , 1] | |
| } | |
| return(list(x1,sample(c(1,2,3,4),1)+x3)) | |
| } | |
| ###Shiny Server Code### | |
| shinyServer(function(input,output,session){ | |
| ###Code for correlation tab### | |
| correlated = reactive({ | |
| input$newdataset | |
| create(isolate(input$nobs),sample(seq(-1,1,by=.1),size=1)) | |
| }) | |
| checker <- reactiveValues(cheat = "no") | |
| observe({ | |
| if(input$newdataset != 0){ | |
| closeAlert(session,alertId="a") | |
| checker$cheat <- "no" | |
| } | |
| }) | |
| observe({ | |
| input$cheat | |
| if(input$cheat!=0){ | |
| checker$cheat <- "yes" | |
| } | |
| }) | |
| output$showcorr = renderUI({ | |
| checker$cheat | |
| isolate({ | |
| if (checker$cheat == "no"){ | |
| paste("") | |
| }else{ | |
| dataCorr = data.frame(exp=unlist(correlated()[[1]]),res=unlist(correlated()[[2]])) | |
| withMathJax() | |
| paste0("The correct answer is ",round(cor(dataCorr$exp,dataCorr$res),1),".") | |
| } | |
| }) | |
| }) | |
| # output$correlationPlot <- renderPlot({ | |
| observe({ | |
| # corr.data = data.frame(exp=unlist(correlated()[[1]]),res=unlist(correlated()[[2]])) | |
| # ggplot(data=corr.data)+geom_point(aes(x=exp,y=res)) | |
| exp=unlist(correlated()[[1]]) | |
| res=unlist(correlated()[[2]]) | |
| contrib=((exp-mean(exp))/sd(exp))*((res-mean(res))/sd(res))/length(res) | |
| corr.data = data.frame(exp=exp,res=res,contrib=contrib) | |
| corr.data %>% | |
| ggvis(~exp, ~res,key:=~contrib) %>% | |
| layer_points() %>% | |
| add_tooltip(function(df){ | |
| paste0("Correlation contribution:",br(),round(df$contrib,5),br(),"Coordinates (Exp,Res):",br(), | |
| "(",round(df$exp,3),",",round(df$res,3),")") | |
| })%>% | |
| bind_shiny("correlationPlot") | |
| }) | |
| observe({ | |
| input$answer | |
| isolate({ | |
| corr.data = data.frame(exp=unlist(correlated()[[1]]),res=unlist(correlated()[[2]])) | |
| if (input$answer != 0){ | |
| if (isolate(input$rho) == round(cor(corr.data$exp,corr.data$res),1)){ | |
| createAlert(session, | |
| inputId = "correct", | |
| title = "Correct!", | |
| message = "You have guessed the correct correlation, click 'New Data' to play again", | |
| type = "success", | |
| dismiss = TRUE, | |
| block = FALSE, | |
| append = FALSE, | |
| alertId = "a" | |
| ) | |
| }else{ | |
| createAlert(session, | |
| inputId = "correct", | |
| title = paste(input$rho," is incorrect..."), | |
| message = "Change your correlation and click 'Submit' to try again.", | |
| type = "danger", | |
| dismiss = TRUE, | |
| block = FALSE, | |
| append = FALSE, | |
| alertId = "a" | |
| ) | |
| } | |
| } | |
| }) | |
| }) | |
| ###CODE FOR REGRESSION TAB### | |
| corr.dat = reactive({ | |
| input$getdata | |
| create(isolate(input$obs),isolate(input$corr)) | |
| }) | |
| check <- reactiveValues(hit = "getdata") | |
| observe({ | |
| input$getdata | |
| check$hit <- "getdata" | |
| check$showit <- "no" | |
| }) | |
| observe({ | |
| input$go | |
| check$hit <- "go" | |
| check$showit <- "no" | |
| }) | |
| observe({ | |
| input$showit | |
| if(input$showit!=0){ | |
| check$showit <- "yes" | |
| } | |
| }) | |
| toplotornottoplot = reactive({ | |
| input$go | |
| reg.data = data.frame(expl=unlist(corr.dat()[[1]]),resp=unlist(corr.dat()[[2]])) | |
| model = lm(resp~expl,data=reg.data) | |
| coefs = data.frame(a=input$b0,b=input$b1) | |
| pred.fits = input$b0 + input$b1*reg.data$expl | |
| seg.data = data.frame(x0=reg.data$expl,y0=reg.data$resp,x1=reg.data$expl,y1=pred.fits) | |
| if(input$getdata==0 & input$go ==0){ | |
| p = ggplot()+geom_point(data=reg.data,aes(x=expl,y=resp))+xlim(0,NA) | |
| }else{ | |
| if(check$hit == "getdata"){ | |
| p = ggplot()+geom_point(data=reg.data,aes(x=expl,y=resp))+xlim(0,NA) | |
| closeAlert(session,alertId="a1") | |
| }else{ | |
| p = ggplot()+geom_point(data=reg.data,aes(x=expl,y=resp)) | |
| p = p+geom_abline(data=coefs,aes(intercept=a,slope=b)) | |
| p = p+geom_segment(data=seg.data,aes(x=x0,y=y0,xend=x1,yend=y1),color='red')+xlim(0,NA) | |
| } | |
| } | |
| list(p) | |
| }) | |
| output$regressionPlot <- renderPlot({ | |
| reg.data = data.frame(expl=unlist(corr.dat()[[1]]),resp=unlist(corr.dat()[[2]])) | |
| model = lm(resp~expl,data=reg.data) | |
| coefs = data.frame(a=input$b0,b=input$b1) | |
| pred.fits = input$b0 + input$b1*reg.data$expl | |
| seg.data = data.frame(x0=reg.data$expl,y0=reg.data$resp,x1=reg.data$expl,y1=pred.fits) | |
| toplotornottoplot() | |
| }) | |
| #SSE stuff | |
| # output$SSE = renderUI({ | |
| # | |
| # input$go | |
| # input$getdata | |
| # isolate({ | |
| # if(input$go != 0){ | |
| # if(check$hit == "getdata"){ | |
| # h6(paste("")) | |
| # }else{ | |
| # reg.data = data.frame(expl=unlist(corr.dat()[[1]]),resp=unlist(corr.dat()[[2]])) | |
| # model = lm(resp~expl,data=reg.data) | |
| # pred.fits = input$b0 + input$b1*reg.data$expl | |
| # realsse = sum((model$resid)^2) | |
| # predsse = sum((reg.data$resp-pred.fits)^2) | |
| # # predsst = sum((reg.data$resp-mean(reg.data$resp))^2) | |
| # # realRsquare = summary(model)$r.squared | |
| # # predRsquare = 1-(predsse/predsst) | |
| # # if(input$sseOrRsq == "Rsq"){ | |
| # # h6(paste("The current R-sq from your inputs is",round(predRsquare,3),". The R-sq for the correct model is ",round(realRsquare,3),". Yours will be bit off since your are using rounded values."),align="center") | |
| # # }else{ | |
| # h6(paste("The current SSE from your inputs is",round(predsse,3),". The SSE for the correct model is ",round(realsse,3),". Yours will be bit off since your are using rounded values."),align="center") | |
| # # } | |
| # | |
| # } | |
| # } | |
| # }) | |
| # }) | |
| output$realline = renderUI({ | |
| check$showit | |
| isolate({ | |
| if (check$showit == "no"){ | |
| paste("") | |
| }else{ | |
| reg.data = data.frame(expl=unlist(corr.dat()[[1]]),resp=unlist(corr.dat()[[2]])) | |
| model = lm(resp~expl,data=reg.data) | |
| withMathJax() | |
| paste0("The correct answer is b0=",round(model[[1]][1]),", and b1=",round(model[[1]][2],1),".") | |
| } | |
| }) | |
| }) | |
| observe({ | |
| input$go | |
| isolate({ | |
| reg.data = data.frame(expl=unlist(corr.dat()[[1]]),resp=unlist(corr.dat()[[2]])) | |
| model = lm(resp~expl,data=reg.data) | |
| coefs = data.frame(a=coef(model)[1],b=coef(model)[2]) | |
| if(input$go != 0){ | |
| if(round(model[[1]][1])==input$b0 && round(model[[1]][2],1)==input$b1){ | |
| createAlert(session, | |
| inputId = "success", | |
| title = "Success!", | |
| message = paste("Your inputs for the model were approximately correct!",br(), | |
| "The real values were:",br(), | |
| "Intercept = ",round(model[[1]][1],3)," Slope = ",round(model[[1]][2],3),br(), | |
| "Click 'New Data' to play again."), | |
| type = "success", | |
| dismiss = TRUE, | |
| block = FALSE, | |
| append = FALSE, | |
| alertId = "a1") | |
| }else{ | |
| createAlert(session, | |
| inputId = "success", | |
| title = "Incorrect.", | |
| message = paste("Your inputs, Intercept=",input$b0," and Slope=",input$b1, | |
| " for the model were incorrect.", | |
| " Change your inputs and hit 'Submit' to try again"), | |
| type = "danger", | |
| dismiss = TRUE, | |
| block = FALSE, | |
| append = FALSE, | |
| alertId = "a1") | |
| } | |
| } | |
| }) | |
| }) | |
| }) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| # ------------------------------------------------ | |
| # App Title: Games of Correlation and Regression | |
| # Author: Irvin Alcaraz | |
| # ------------------------------------------------ | |
| library(shiny) | |
| library(shinyBS) | |
| library(ggplot2) | |
| library(ggvis) | |
| library(magrittr) | |
| shinyUI(navbarPage("Data games", | |
| tabPanel("Correlation Game", | |
| withMathJax(), | |
| p("Correlation is a statistical measurement used to quantify the strength and direction of | |
| a linear relationship.",br(), | |
| "\\(\\bullet\\) This value is unitless, and thus is not affected by location and scale of the variables, | |
| and bound between -1 and 1.",br(), | |
| "\\(\\bullet\\) It is typically denoted by \\(r\\) or by \\(\\rho\\).",br(), | |
| "\\(\\bullet\\) A correlation of -1 would mean that the data have a perfectly negative relationship, which would appear in the scatterplot as | |
| a perfect line with a negative slope.",br(), | |
| "\\(\\bullet\\) Similarly, a correlation of 1 would mean that the data are perfectly positively correlated, which would appear in the scatterplot as a perfect line | |
| with a positive slope.",br(), | |
| "\\(\\bullet\\) If data have no relationship, they would have a correlation of 0, and would appear as a random | |
| scatter of points in the scatterplot.",br(), | |
| "\\(\\bullet\\) The correlation presented in this application is generated using the Pearson | |
| Correlation Coefficient method.",br(), | |
| "\\(\\bullet\\) The formula used to calculate this is value is \\({1\\over n-1}\\sum_{i=1}^n{(x_i-\\bar{x})(y_i-\\bar{y})\\over s_xs_y}\\)"), | |
| sidebarLayout( | |
| sidebarPanel( | |
| helpText("Number of Observations"), | |
| selectInput("nobs","",c(10,100,1000),100), | |
| actionButton("newdataset","New Data"), | |
| HTML("<hr style='height: 2px; color: #F3F3F3; background-color: #F3F3F3; border: none;'>"), | |
| helpText('Guess the Correlation, \\(\\rho\\)'), | |
| sliderInput("rho","",min=-1,max=1,value=0,step=.1), | |
| actionButton("answer","Submit"), | |
| actionButton("cheat","Show Answer"), | |
| div("Shiny app by", | |
| a(href="https://www.linkedin.com/in/irvinalcaraz",target="_blank", | |
| "Irvin Alcaraz"),align="right", style = "font-size: 8pt"), | |
| div("Base R code by", | |
| a(href="https://www.linkedin.com/in/irvinalcaraz",target="_blank", | |
| "Irvin Alcaraz"),align="right", style = "font-size: 8pt"), | |
| div("Shiny source files:", | |
| a(href="https://gist.github.com/calpolystat/8e898319968d31b27310", | |
| target="_blank","GitHub Gist"),align="right", style = "font-size: 8pt"), | |
| div(a(href="http://www.statistics.calpoly.edu/shiny",target="_blank", | |
| "Cal Poly Statistics Dept Shiny Series"),align="right", style = "font-size: 8pt") | |
| ), | |
| mainPanel( | |
| bsAlert("correct"), | |
| # plotOutput("correlationPlot") | |
| ggvisOutput("correlationPlot"), | |
| uiOutput("showcorr") | |
| ) | |
| )), | |
| tabPanel("Regression Game", | |
| sidebarLayout( | |
| sidebarPanel( | |
| tags$head(tags$link(rel = "icon", type = "image/x-icon",href = "https://webresource.its.calpoly.edu/cpwebtemplate/5.0.1/common/images_html/favicon.ico")), | |
| withMathJax(), | |
| selectInput("obs","Number of Observations",c(10,100,1000),100), | |
| helpText('Correlation, \\(\\rho\\)'), | |
| sliderInput("corr","",min=-1,max=1,value=0,step=.1), | |
| actionButton("getdata","New Data"), | |
| HTML("<hr style='height: 2px; color: #F3F3F3; background-color: #F3F3F3; border: none;'>"), | |
| HTML("<hr style='height: 2px; color: #F3F3F3; background-color: #F3F3F3; border: none;'>"), | |
| helpText('The intercept, \\(\\hat{\\beta_0}\\) (round to the nearest whole number)'), | |
| numericInput("b0","",value=0), | |
| helpText('The slope, \\(\\hat{\\beta_1}\\) (round to the nearest tenth)'), | |
| numericInput("b1","",value=0), | |
| ##helpText("Assessment method"), | |
| ##radioButtons("sseOrRsq","",choices=c("Maximize \\(R^2\\)"="Rsq","Minimize \\(SSE\\)"="sse"),selected="Rsq"), | |
| HTML("<hr style='height: 2px; color: #F3F3F3; background-color: #F3F3F3; border: none;'>"), | |
| actionButton("go","Submit"), | |
| actionButton("showit","Show Answer"), | |
| div("Shiny app by", | |
| a(href="https://www.linkedin.com/in/irvinalcaraz",target="_blank", | |
| "Irvin Alcaraz"),align="right", style = "font-size: 8pt"), | |
| div("Base R code by", | |
| a(href="https://www.linkedin.com/in/irvinalcaraz",target="_blank", | |
| "Irvin Alcaraz"),align="right", style = "font-size: 8pt"), | |
| div("Shiny source files:", | |
| a(href="https://gist.github.com/calpolystat/8e898319968d31b27310", | |
| target="_blank","GitHub Gist"),align="right", style = "font-size: 8pt"), | |
| div(a(href="http://www.statistics.calpoly.edu/shiny",target="_blank", | |
| "Cal Poly Statistics Dept Shiny Series"),align="right", style = "font-size: 8pt") | |
| ), | |
| mainPanel( | |
| p("Often, we wish to predict the value of some variable, called the response, based on | |
| the value of another linearly related variable, called the explanatory. This idea is called linear regression. | |
| We will deal with simple linear regression, which makes use of a single response and predictor. | |
| In order to estimate the response variable based on the explanatory we will fit a line, | |
| also called a model, to the data. This line is called the least squares regression line, and it attempts to | |
| minimize the deviations of the points from the line, or the residuals.",br(), | |
| "\\(\\bullet\\) The population regression line is: \\(Y=\\beta_o+\\beta_1X\\)",br(), | |
| "\\(\\bullet\\) When given a random sample of data, we estimate this by: \\(\\hat{y}=b_0+b_1x\\)",br(), | |
| "\\(\\bullet\\)To assess, whether or not the estimated line is the best line we can look at two values.",br(), | |
| "\\(\\qquad\\circ\\) We can minimize a value called the sum of squared errors, denoted \\(SSE=\\sum_{i=1}^n(y_i-\\hat{y_i})^2\\).",br(), | |
| "\\(\\qquad\\circ\\) Equivalently, we can maximize a value called the coefficient of determination. We denote this value as | |
| \\(R^2=1-{SSE \\over SST}\\), where \\(SST=\\sum_{i=1}^n(y_i-\\bar{y})^2\\)"), | |
| bsAlert("success"), | |
| uiOutput("SSE"), | |
| plotOutput("regressionPlot"), | |
| uiOutput("realline") | |
| ) | |
| )) | |
| )) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
errors in both server.R and ui.R :
Warning: Error in tag: argument is missing, with no default
59: tag
58: tags$form
54: sidebarPanel
ERROR: argument is missing, with no default