.Rmd 文件中用于回归的交互式滑块
interactive slider in .Rmd file for Regression
我尝试编写我的第一个交互式 .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")
```
我不知道如何正确使用滑块输入法。我想要我的线性回归线 a 的滑块和 b 的滑块，这样你就可以在那里输入你的系数截距 (b) 和 mietspiegel$wfl (a) 并在此之后查看新的回归线。
要使 geom_abline 依赖于您的滑块，您应该将 ggplot 部分包装到 renderPlot 函数中，然后将参数 a 设置为 input$a 并将参数 b 到 input$b。 （您使用 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")
})
已编辑： 我在下面的代码中添加了更多问题的答案作为评论
---
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))
})
```
我尝试编写我的第一个交互式 .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")
```
我不知道如何正确使用滑块输入法。我想要我的线性回归线 a 的滑块和 b 的滑块，这样你就可以在那里输入你的系数截距 (b) 和 mietspiegel$wfl (a) 并在此之后查看新的回归线。
要使 geom_abline 依赖于您的滑块，您应该将 ggplot 部分包装到 renderPlot 函数中，然后将参数 a 设置为 input$a 并将参数 b 到 input$b。 （您使用 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")
})
已编辑： 我在下面的代码中添加了更多问题的答案作为评论
---
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))
})
```