interaktive Slider in .Rmd Datei für Regression

Question

Ich versuche, meine erste interaktive .Rmd Datei zu kodieren:

Ich möchte nur die Interaktion in einer linearen Regression zeigen x ~ y von

y(x)= a*x + b 

mir nur zwei Schieber nehmen will:

einen für b und einen für einen

meinen Code ist bis jetzt:

--- 
output: html_document 
runtime: shiny 
--- 

## some text... 

*some more text 

<br><br> 

```{r setup, include=FALSE} 
knitr::opts_chunk$set(echo = TRUE) 
``` 


```{r, echo = FALSE, message=FALSE, warnings=FALSE} 

mietspiegel <- read.table("http://www.stat.uni-muenchen.de/service/datenarchiv/miete/miete03.asc", header=TRUE) 
mieten_regression <- lm(mietspiegel$nm ~ mietspiegel$wfl) 
mieten_regression$coefficients 

b <- mieten_regression$coefficients[1]  # Coefficient No. 1 Intercept 
a <- mieten_regression$coefficients[2]  # Coefficient No. 2 mietspiegel$wfl 

# Slider ... 
inputPanel(sliderInput("b", "Coefficient No. 1 Intercept", min = 0, max = 2000, step = 1, value = b), 
sliderInput("a", "Coefficient No. 2 Wohnflaeche", min = 0, max = 200, step = 10, value = a), 
actionButton("sample", "Resample")) 

# Scatterplott 
library(ggplot2) 
ggplot(mietspiegel, 
aes(y=nm, x=wfl)) + 
geom_abline(intercept = b, slope = a, colour = "red") + # Add inear regression line  
geom_point(shape=1) + # Use hollow circles 
xlab("Fläche") + 
ylab("Price") 

``` 

Ich weiß nicht, wie Sie den Schieberegler korrekt verwenden. Ich möchte für meine lineare Regressionslinie einen Schieberegler für a und einen Schieberegler für b, damit Sie dort Ihre Koeffizienten intercept (b) und mietspiegel $ wfl (a) eingeben können und danach die neue Regressionsgerade sehen.

Answer 1

Um geom_abline auf Ihrem Schieber abhängig Sie den ggplot Teil in renderPlot Funktion wickeln sollten und dann die Parameter a-input$a und den Parameter b-input$b. (Der Zugriff auf den Wert des gegebenen Widget mit input$id)

renderPlot({ 
    library(ggplot2) 
    ggplot(mietspiegel, 
     aes(y=nm, x=wfl)) + 
    geom_abline(intercept = input$b, slope = input$a, colour = "red") + # Add inear regression line  
    geom_point(shape=1) + # Use hollow circles 
    xlab("Fläche") + 
    ylab("Price") 
}) 

---

EDITED: Ich habe Antworten auf weitere Fragen als Kommentare im Code unten

--- 
output: html_document 
runtime: shiny 
--- 

## some text... 

*some more text 

<br><br> 

```{r setup, include=FALSE} 
knitr::opts_chunk$set(echo = TRUE) 
``` 


```{r, echo = FALSE, message=FALSE, warnings=FALSE} 

mietspiegel <- read.table("http://www.stat.uni-muenchen.de/service/datenarchiv/miete/miete03.asc", header=TRUE) 
mieten_regression <- lm(mietspiegel$nm ~ mietspiegel$wfl) 
mieten_regression$coefficients 

b <- mieten_regression$coefficients[1]  # Coefficient No. 1 Intercept 
a <- mieten_regression$coefficients[2]  # Coefficient No. 2 mietspiegel$wfl 



# Slider ... 

inputPanel(
    sliderInput("b", "Coefficient No. 1 Intercept", min = 0, max = 200, step = 10, value = b), 

    sliderInput("a", "Coefficient No. 2 Wohnflaeche", min = 0, max = 20, step = 1, value = a), 

    actionButton("residuen", "Zeige Residuen an") 

) 


# Scatterplott 

renderPlot({ 
    library(ggplot2) 
    ggplot(mietspiegel, aes(y=nm, x=wfl)) + 
    geom_abline(intercept = input$b, slope = input$a, colour = "red") + # Add inear regression line  
    geom_point(shape=1) + # Use hollow circles 
    xlab("Flaeche") + # changed Fläche to Flaeche :) 
    ylab("Price") 
}) 


# Two ways of showing residual plots when the button "Resample" is pressed: 

# (i) Easy way - use conditionalPanel 
# conditionalPanel(
# condition = "input.residuen !== 0", 
# list(
#  hr(), 
#  h3("Residuen"), 
#  plotOutput("residuals"), 
#  hr() 
# ) 
#) 
# 
# output$residuals <- renderPlot({ 
#  par(mfrow = c(2,2)) 
#  plot(mieten_regression) 
#  par(mfrow = c(1,1)) 
# }) 

# ----------------------------------------------------------------------------- 

# (ii) More difficlult but more powerful way - use render renderUI with a condition. 
# Using modulo operator you can show and hide plots by pressing 

uiOutput("dynamic_residuals") 



output$dynamic_residuals <- renderUI({ 
    if ((input$residuen + 1) %% 2 == 0) { 
    return(list(
     hr(), 
     h3("Residuen"), 
     plotOutput("residuals"), 
     hr() 
    )) 
    } else { 
    return(NULL) 
    } 
}) 

output$residuals <- renderPlot({ 
    par(mfrow = c(2,2)) 
     plot(mieten_regression) 
    par(mfrow = c(1,1)) 
}) 
# You can read it in this way: 
# - use renderPlot function that sends a plot to the plotOutput 
# - create "plotOutput" via "renderUI" and place it (together with hr and h3 tags) in the document but only if the button (input$residuen) is clicked. 

``` 



## Second part of your question 

<hr> 


```{r, echo = FALSE, message=FALSE, warnings=FALSE} 

# define functions for two Errorfields  

mean_abs_diff <- function(a,b,x,y) {mean(abs(a * x + b - y))} # middle absolute changing from y 
    mean_sqr_diff <- function(a,b,x,y) {sqrt(mean((a * x + b - y)^2))} # sqrt of the middle square changing from y 
``` 



```{r, echo = FALSE, message=FALSE, warnings=FALSE} 


renderPrint({ 
    # Errors vs changings of a 
    mad <- mean_abs_diff(input$a, input$b, mietspiegel$wfl, mietspiegel$nm) 
    msd <- mean_sqr_diff(input$a, input$b,mietspiegel$wfl, mietspiegel$nm) 

    cat(" Mean absolute difference: ", round(mad, 2), "\n", 
     "Mean squared difference: ", round(msd, 2)) 
}) 


``` 





```{r, echo = FALSE, message=FALSE, warnings=FALSE} 

# To generate new plots depending on changing values of the sliders, again, 
# wrap the code into renderPlot and replace "a" and "b" with "input$a" and "input$b" 

# You also can use mfrow to combine all these plots into one 

x <- seq(-50, 50, 1) 

renderPlot({ 
    par(mfrow = c(2,2), mar = c(3,3,3,3)) 

    plot(x, sapply(x, function(y) mean_sqr_diff(input$a, input$a + y,mietspiegel$wfl, mietspiegel$nm)), 
     xlab = "additive changing of b (delta b)", ylab = "sqrt of the middle sqaure error", type = "l") 


    plot(x, sapply(x, function(y) mean_abs_diff(input$a, input$a + y,mietspiegel$wfl, mietspiegel$nm)), 
     xlab = "additive changing of b (delta b)", ylab = "middle absolute error", type = "l") 

     # Errors vs changings of b 

    x <- seq(-1, 1, 0.1) 

    plot(x, sapply(x, function(y) mean_sqr_diff(input$a + y, input$b,mietspiegel$wfl, mietspiegel$nm)), 
      xlab = "additive changing of a (delta a)", ylab = "sqrt of the middle sqaure error", type = "l") 


    plot(x, sapply(x, function(y) mean_abs_diff(input$a + y, input$b,mietspiegel$wfl, mietspiegel$nm)), 
      xlab = "additive changing of a (delta a)", ylab = "middle absolute error", type = "l") 
    par(mfrow = c(1,1)) 
}) 
```