用于回归的.Rmd文件中的交互式滑块

我尝试编写我的第一个交互式.Rmd文件：

我只想用线性回归x~y来表示相互作用

 y(x)= a*x + b

我只想拿两个滑块：

一个是b，一个是a

到目前为止，我的代码是：

--- 
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")

```

--
输出：html\u文档
运行时间：闪亮
---
##一些文字。。。
*更多的文字



```{r设置，include=FALSE}
knitr:：opts_chunk$set（echo=TRUE）
```
```{r，echo=FALSE，message=FALSE，warnings=FALSE}
mietspiegel要使
geom_abline
依赖于您的滑块，您应该将ggplot部分包装到
renderPlot
函数中，然后将参数
a
设置为
输入$a
，并将参数
b
设置为
输入$b
。（使用
input$id
访问给定小部件的值）


编辑：我在下面的代码中添加了更多问题的答案作为注释

--- 
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))
})
```

--
输出：html\u文档
运行时间：闪亮
---
##一些文字。。。
*更多的文字



```{r设置，include=FALSE}
knitr:：opts_chunk$set（echo=TRUE）
```
```{r，echo=FALSE，message=FALSE，warnings=FALSE}
mietspiegel要使
geom_abline
依赖于您的滑块，您应该将ggplot部分包装到
renderPlot
函数中，然后将参数
a
设置为
输入$a
，并将参数
b
设置为
输入$b
。（使用
input$id
访问给定小部件的值）


编辑：我在下面的代码中添加了更多问题的答案作为注释

--- 
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))
})
```

--
输出：html\u文档
运行时间：闪亮
---
##一些文字。。。
*更多的文字



```{r设置，include=FALSE}
knitr:：opts_chunk$set（echo=TRUE）
```
```{r，echo=FALSE，message=FALSE，warnings=FALSE}
mietspiegel thx现在一切正常…我能给你发个下午吗？我有两个关于代码的特殊任务…我如何才能在直线图（回归线）中建立一个小的红色圆圈来标记精确的a或b错误我不能说我理解得正确-你的意思是，如果，例如，
平均绝对差：723.04
，那么你希望在四个图（基本R图）中的每一个图中都有一个小的红点吗它描述了723.04的值？这和我的线性回归图中的红点或红空心圆…我看你的邮箱^^^^它现在运行良好…我可以给你发送一个pm吗？我有两个关于代码的特殊任务…我如何才能在直线图（回归线）中建立一个小的红色圆圈来标记精确的a或b错误我不能说我理解得正确-你的意思是，如果，例如，
平均绝对差：723.04
，那么你希望在四个图（基本R图）中的每一个图中都有一个小的红点吗哪个描述了723.04的值？这和我的线性回归图中的红点或红空心圆…我看看你的邮箱^^