#r #ggplot2 #shiny #plotly
#r #ggplot2 #блестящий #построение
Вопрос:
Я разрабатываю блестящее приложение, в котором я строю диаграмму рассеяния и функцию подгонки сплайна к ней, степень функции сплайна может быть изменена с помощью ползунка, значения которого варьируются от 2-12, как показано ниже:
ui <- tabPanel(sidebarLayout(
sidebarPanel(sliderInput('degree', 'Degree of the Polynomial:', min = 2, max = 12, value = 3, step = 1)),
mainPanel(plotlyOutput("plot"))))
Ниже приведен код на стороне сервера:
server <- function(input, output, session){
observeEvent(input$degree, {
output$plot <- renderPlotly({
m <- lm(formula = y ~ splines::bs(x, df = input$degree), df4)
#plot
g <- ggplot(data = df4, aes_string(x = df4$x, y = df4$y)) theme_bw()
geom_point(colour = "blue", size = 0.1)
geom_smooth(formula = y ~ splines::bs(x, df = input$degree), method = "lm", color = "green3", level = 1, size = 1)
h <- g xlab("X (mm)") ylab("Z (um)")
ggplotly(h) %>% add_annotations(text= sprintf("R^2: %f", summary(m)[8]), xref="paper", yref="paper", x=0.05,y=0.9)
})
})
}
df4 это набор данных, который был использован для построения диаграммы рассеяния, которая выглядит следующим образом:
Теперь я хочу, чтобы значение степени подгонки сплайна выбиралось автоматически на основе значения R ^ 2.
Например, если 0,8 является установленным пороговым значением для R^2 значения, то эта степень сплайновой функции должна автоматически выбираться в качестве значения по умолчанию ползунка, где значение R^2 пересекает пороговое значение 0,8 в первый раз.
В целом, я хочу, чтобы установленное по умолчанию значение ползунка (которое здесь установлено на 3) было динамическим на основе установленного порогового значения R^2 .
Ответ №1:
Это должно сделать это. Вам необходимо оценить модель вне отображаемого вывода, чтобы вы могли определить правильную степень. Затем вам нужно использовать renderUI() для построения ползунка, чтобы вы могли передать идентифицированное значение degree в value аргумент. Затем вы можете создать график, не находясь внутри наблюдателя событий, потому что это уже реактивная функция, и наблюдая за ползунком ввода степени.
ui <- fluidPage(sidebarLayout(
sidebarPanel(uiOutput("slider")),
mainPanel(plotlyOutput("plot"))))
server <- function(input, output, session){
library(ggplot2)
library(plotly)
library(splines)
set.seed(1)
## set number of observations
n <- 400
## generate x in [0,1]
x <- 0:(n-1)/(n-1)
## create compled function of x
f <- 0.2*x^11*(10*(1-x))^6 10*(10*x)^3*(1-x)^10
## create y = f(x) random noise
y <- f rnorm(n, 0, sd = 2)
df4 <- data.frame(x=x, y=y)
deg <- 2
r2 <- 0
while(r2 < .8){
deg <- deg 1
m <- lm(formula = y ~ splines::bs(x, df = deg), df4)
r2 <- summary(m)$r.squared
}
output$slider <- renderUI(sliderInput('degree',
'Degree of the Polynomial:',
min = 2,
max = 300,
value = deg,
step = 1) )
output$plot <- renderPlotly({
#plot
m <- lm(formula = y ~ splines::bs(x, df = input$degree), df4)
g <- ggplot(data = df4, aes(x = x, y = y)) theme_bw()
geom_point(colour = "blue", size = 0.1)
geom_smooth(formula = y ~ splines::bs(x, df = input$degree), method = "lm", color = "green3", level = 1, size = 1)
h <- g xlab("X (mm)") ylab("Z (um)")
ggplotly(h) %>% add_annotations(text= sprintf("R^2: %f", summary(m)[8]), xref="paper", yref="paper", x=0.05,y=0.9)
})
}
shinyApp(ui, server)
РЕДАКТИРОВАТЬ добавить загрузку файла
Я добавил кнопку загрузки файла и текстовое поле вместе с параметрами выбора переменных для x- и y-переменных из имен в загруженном наборе данных.
ui <- fluidPage(sidebarLayout(
sidebarPanel(
fileInput('file1', 'Choose file to upload',
accept = c(
'text/csv',
'text/comma-separated-values',
'text/tab-separated-values',
'text/plain',
'.csv',
'.tsv'
)
),
uiOutput("xvar"),
uiOutput("yvar"),
uiOutput("slider")),
mainPanel(plotlyOutput("plot"))))
server <- function(input, output, session){
library(ggplot2)
library(plotly)
library(splines)
df4 <- reactive({
req(input$file1)
inFile <- input$file1
read.csv(inFile$datapath, header = TRUE)
})
output$xvar <- renderUI({
req(df4())
selectInput("xvar", "X-variable", choices=names(df4()), selected = NULL)
})
output$yvar <- renderUI({
req(df4())
selectInput("yvar", "Y-variable", choices=names(df4()), selected = NULL)
})
deg <- reactive({
req(input$yvar)
degr <- 2
r2 <- 0
while(r2 < .8){
degr <- degr 1
form <- paste(input$yvar, "~ splines::bs(", input$xvar, ", df = ", degr, ")")
m <- lm(formula = form, df4())
r2 <- summary(m)$r.squared
}
degr
})
output$slider <- renderUI({
req(deg())
sliderInput('degree',
'Degree of the Polynomial:',
min = 2,
max = 300,
value = deg(),
step = 1) })
output$plot <- renderPlotly({
req(deg())
#plot
form <- paste(input$yvar, "~ splines::bs(", input$xvar, ", df = ", input$degree, ")")
m <- lm(formula = form, df4())
g <- ggplot(data = df4(), aes_string(x = input$xvar, y = input$yvar)) theme_bw()
geom_point(colour = "blue", size = 0.1)
geom_smooth(formula = y ~ splines::bs(x, df = input$degree), method = "lm", color = "green3", level = 1, size = 1)
h <- g xlab("X (mm)") ylab("Z (um)")
ggplotly(h) %>% add_annotations(text= sprintf("R^2: %f", summary(m)[8]), xref="paper", yref="paper", x=0.05,y=0.9)
})
}
shinyApp(ui, server)
Комментарии:
1. Я получаю данные df4, загружая некоторые файлы данных в приложение shiny. И когда я попытался сделать это по-своему, он показывает эту ошибку: «Операция не разрешена без активного реактивного контекста. (Вы пытались сделать что-то, что может быть сделано только изнутри реактивного выражения или наблюдателя.) «Итак, должен ли я включить код в реактивную функцию?
2. @kolas0202 Я отредактировал ответ, включив кнопку загрузки файла и средства выбора для x- и y-переменных из имен набора данных. Поскольку все эти различные спецификации могут изменить характер ответа (как это было здесь), было бы полезно с самого начала знать, какие требования предъявляются к решению.
Ответ №2:
Это сложно без некоторых выборочных данных, но предположим, что у нас был следующий набор данных:
set.seed(1)
df4 <- data.frame(x = 1:10, y = rnorm(10, (1:10)/10))
df4
#> x y
#> 1 1 -0.5264538
#> 2 2 0.3836433
#> 3 3 -0.5356286
#> 4 4 1.9952808
#> 5 5 0.8295078
#> 6 6 -0.2204684
#> 7 7 1.1874291
#> 8 8 1.5383247
#> 9 9 1.4757814
#> 10 10 0.6946116
При построении графика это выглядит так:
plot(df)
таким образом, он имеет небольшую тенденцию к росту.
Если мы хотим найти количество сплайнов, которое соответствует квадрату r> 0,8, мы можем сделать:
library(splines)
i <- 3
while(summary(lm(formula = y ~ bs(x, df = i), df4))$r.squared < 0.8) i <- i 1
Итак, теперь i — наименьшее число сплайнов, которое дает r в квадрате 0,8 или более:
i
#> [1] 8
И мы можем вписаться i в нашу фиксированную модель:
fit <- lm(formula = y ~ splines::bs(x, df = i), df4)
summary(fit)
#>
#> Call:
#> lm(formula = y ~ splines::bs(x, df = i), data = df4)
#>
#> Residuals:
#> 1 2 3 4 5 6 7 8
#> 0.00008 -0.00216 0.01512 -0.04776 0.08208 -0.08208 0.04776 -0.01512
#> 9 10
#> 0.00216 -0.00008
#>
#> Coefficients:
#> Estimate Std. Error t value Pr(>|t|)
#> (Intercept) -0.5265 0.1360 -3.871 0.1609
#> splines::bs(x, df = i)1 4.4178 0.4344 10.170 0.0624 .
#> splines::bs(x, df = i)2 -4.1409 0.4194 -9.874 0.0643 .
#> splines::bs(x, df = i)3 5.2151 0.3247 16.064 0.0396 *
#> splines::bs(x, df = i)4 -1.3020 0.3068 -4.244 0.1473
#> splines::bs(x, df = i)5 2.3384 0.3245 7.206 0.0878 .
#> splines::bs(x, df = i)6 1.9458 0.4199 4.634 0.1353
#> splines::bs(x, df = i)7 2.0650 0.4309 4.792 0.1310
#> splines::bs(x, df = i)8 1.2212 0.1924 6.349 0.0995 .
#> ---
#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
#>
#> Residual standard error: 0.136 on 1 degrees of freedom
#> Multiple R-squared: 0.9974, Adjusted R-squared: 0.9769
#> F-statistic: 48.6 on 8 and 1 DF, p-value: 0.1105
и
lines(10:100/10, predict(fit, newdata = list(x = 10:100/10)), col = "red")
Создано 2020-11-30 пакетом reprex (версия 0.3.0)