- html - 出于某种原因,IE8 对我的 Sass 文件中继承的 html5 CSS 不友好?
- JMeter 在响应断言中使用 span 标签的问题
- html - 在 :hover and :active? 上具有不同效果的 CSS 动画
- html - 相对于居中的 html 内容固定的 CSS 重复背景?
我正在创建一个 Shiny 的应用程序来说明先验分布的导出,主要用于教学目的。
在应用程序中,人们被要求对利物浦下一次下雨需要多少天进行 10 次猜测。
他们的猜测被绘制在图表中,并在输入时显示在表格中以帮助理解。
当他们按下“提交”按钮时,包含其回复的单个 .csv 文件应上传到保管箱文件夹(用于后续分析)。
(此代码大部分取自 Persistent Data Storage in Shiny Apps 示例)。
一切都很顺利,当按下“提交”按钮时,多个 .csv 文件将上传到 dropbox 文件夹。
我不知道如何将输出保存为一个文件,但怀疑这与 observe
调用有关。
非常感谢您的帮助。
require(shiny)
#> Loading required package: shiny
library(tidyverse)
#> ── Attaching packages ────────────────────────────────────────────────────────── tidyverse 1.2.1 ──
#> ✔ ggplot2 2.2.1.9000 ✔ purrr 0.2.4
#> ✔ tibble 1.4.1 ✔ dplyr 0.7.4
#> ✔ tidyr 0.7.2 ✔ stringr 1.2.0
#> ✔ readr 1.1.1 ✔ forcats 0.2.0
#> ── Conflicts ───────────────────────────────────────────────────────────── tidyverse_conflicts() ──
#> ✖ dplyr::filter() masks stats::filter()
#> ✖ dplyr::lag() masks stats::lag()
library(rdrop2)
#Define output directory
outputDir <-
"output"
#Define all variables to be collected
fieldsAll <- c("name", "type", "g1", "g2", "g3","g4",
"g5", "g6", "g7", "g8", "g9", "g10")
#Define all mandatory variables
fieldsMandatory <- c("name", "type", "g1", "g2", "g3",
"g4", "g5", "g6", "g7", "g8", "g9",
"g10")
#Label mandatory fields
labelMandatory <- function(label) {
tagList(label,
span("*", class = "mandatory_star"))
}
#Get current Epoch time
epochTime <- function() {
return(as.integer(Sys.time()))
}
#Get a formatted string of the timestamp
humanTime <- function() {
format(Sys.time(), "%Y%m%d-%H%M%OS")
}
#CSS to use in the app
appCSS <-
".mandatory_star { color: red; }
.shiny-input-container { margin-top: 25px; }
#thankyou_msg { margin-left: 15px; }
#error { color: red; }
body { background: #fcfcfc; }
#header { background: #fff; border-bottom: 1px solid #ddd; margin: -20px -15px 0; padding: 15px 15px 10px; }
"
#UI
ui <- shinyUI(
fluidPage(
shinyjs::useShinyjs(),
shinyjs::inlineCSS(appCSS),
headerPanel(
'How many days until it next rains in Liverpool?'
),
sidebarPanel(
id = "form",
textInput("name", labelMandatory("Enter name"), value = ""),
selectInput(
"type",
labelMandatory("Select which group best describes you"),
choices = c("", "Manager", "IT",
"Finance"),
selected = ""
),
numericInput(
"g1",
labelMandatory("Guess 1"),
value = "",
min = 1,
max = 10,
step = 1
),
numericInput(
"g2",
labelMandatory("Guess 2"),
value = "",
min = 1,
max = 10,
step = 1
),
numericInput(
"g3",
labelMandatory("Guess 3"),
value = "",
min = 1,
max = 10,
step = 1
),
numericInput(
"g4",
labelMandatory("Guess 4"),
value = "",
min = 1,
max = 10,
step = 1
),
numericInput(
"g5",
labelMandatory("Guess 5"),
value = "",
min = 1,
max = 10,
step = 1
),
numericInput(
"g6",
labelMandatory("Guess 6"),
value = "",
min = 1,
max = 10,
step = 1
),
numericInput(
"g7",
labelMandatory("Guess 7"),
value = "",
min = 1,
max = 10,
step = 1
),
numericInput(
"g8",
labelMandatory("Guess 8"),
value = "",
min = 1,
max = 10,
step = 1
),
numericInput(
"g9",
labelMandatory("Guess 9"),
value = "",
min = 1,
max = 10,
step = 1
),
numericInput(
"g10",
labelMandatory("Guess 10"),
value = "",
min = 1,
max = 10,
step = 1
)
),
mainPanel(
br(),
p("Your guesses will appear here:"),
br(),
br(),
plotOutput("plot"),
br(),
p(
"After you are happy with your guesses, press submit to send data to the database."
),
br(),
tableOutput("table"),
br(),
actionButton("Submit", "Submit"),
fluidRow(shinyjs::hidden(div(
id = "thankyou_msg",
h3("Thanks, your response was submitted successfully!")
)))
)
)
)
#Server
server <- shinyServer(function(input, output, session) {
# Gather all the form inputs
formData <- reactive({
x <- reactiveValuesToList(input)
data.frame(names = names(x),
values = unlist(x, use.names = FALSE))
})
#Save the results to a file
saveData <- function(data) {
# Create a unique file name
fileName <-
sprintf("%s_%s_drive_time.csv",
humanTime(),
digest::digest(data))
# Write the data to a temporary file locally
filePath <- file.path(tempdir(), fileName)
write.csv(data, filePath, row.names = TRUE, quote = TRUE)
# Upload the file to Dropbox
drop_upload(filePath, path = outputDir)
}
#Observe for when all mandatory fields are completed
observe({
fields_filled <-
fieldsMandatory %>%
sapply(function(x)
! is.na(input[[x]]) && input[[x]] != "") %>%
all
shinyjs::toggleState("Submit", fields_filled)
# When the Submit button is clicked, submit the response
observeEvent(input$Submit, {
# User-experience stuff
shinyjs::disable("Submit")
shinyjs::show("thankyou_msg")
tryCatch({
saveData(formData())
shinyjs::reset("form")
shinyjs::hide("form")
shinyjs::show("thankyou_msg")
})
})
# isolate data input
values <- reactiveValues()
output$table <- renderTable({
input$addButton
Name <- isolate({
input$name
})
Type <- isolate({
input$type
})
Guess1 <- isolate({
input$g1
})
Guess2 <- isolate({
input$g2
})
Guess3 <- isolate({
input$g3
})
Guess4 <- isolate({
input$g4
})
Guess5 <- isolate({
input$g5
})
Guess6 <- isolate({
input$g6
})
Guess7 <- isolate({
input$g7
})
Guess8 <- isolate({
input$g8
})
Guess9 <- isolate({
input$g9
})
Guess10 <- isolate({
input$g10
})
df <-
data_frame(Name, Type, Guess1, Guess2, Guess3, Guess4,
Guess5, Guess6, Guess7, Guess8, Guess9, Guess10)
df
})
output$plot <- renderPlot({
input$addButton
x1 <- isolate({
input$g1
})
x2 <- isolate({
input$g2
})
x3 <- isolate({
input$g3
})
x4 <- isolate({
input$g4
})
x5 <- isolate({
input$g5
})
x6 <- isolate({
input$g6
})
x7 <- isolate({
input$g7
})
x8 <- isolate({
input$g8
})
x9 <- isolate({
input$g9
})
x10 <- isolate({
input$g10
})
df2 <-
data_frame(x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) %>%
gather()
ggplot(df2) +
geom_histogram(aes(x = as.numeric(value)), fill = "#18a7b5", stat =
"count") +
geom_hline(yintercept = seq(1, 10, 1),
col = "white",
lwd = 1) +
geom_vline(aes(xintercept = 4),
linetype = "dashed",
colour = "black") +
stat_function(
fun = function(x, mean, sd, n, bw) {
dnorm(x = x,
mean = mean,
sd = sd) * n * bw
},
args = c(
mean = mean(df2$value),
sd = sd(df2$value),
n = length(df2$value),
bw = 1
),
colour = "#b5185f"
) +
theme_bw() +
scale_x_continuous(limits = c(0, 10),
breaks = c(0, 1,2,3,4,5,6,7,8,9,10)) +
scale_y_continuous(limits = c(0, 10),
breaks = c(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10)) +
labs(x = "Number of days until rains", y = "",
title = "Estimated number of days until rain") +
theme(legend.position = "none")
})
})
})
# Run the application
shinyApp(ui = ui, server = server)
最佳答案
更改了几件事:* 将observeEvent
从observe
中取出* 事实上,缩小了observe
的范围* 在表创建中分配时不需要 isolate
require(shiny)
#> Loading required package: shiny
library(tidyverse)
#> ── Attaching packages ────────────────────────────────────────────────────────── tidyverse 1.2.1 ──
#> ✔ ggplot2 2.2.1.9000 ✔ purrr 0.2.4
#> ✔ tibble 1.4.1 ✔ dplyr 0.7.4
#> ✔ tidyr 0.7.2 ✔ stringr 1.2.0
#> ✔ readr 1.1.1 ✔ forcats 0.2.0
#> ── Conflicts ───────────────────────────────────────────────────────────── tidyverse_conflicts() ──
#> ✖ dplyr::filter() masks stats::filter()
#> ✖ dplyr::lag() masks stats::lag()
library(rdrop2)
#Define output directory
outputDir <-
"output"
#Define all variables to be collected
fieldsAll <- c("name", "type", "g1", "g2", "g3","g4",
"g5", "g6", "g7", "g8", "g9", "g10")
#Define all mandatory variables
fieldsMandatory <- c("name", "type", "g1", "g2", "g3",
"g4", "g5", "g6", "g7", "g8", "g9",
"g10")
#Label mandatory fields
labelMandatory <- function(label) {
tagList(label,
span("*", class = "mandatory_star"))
}
#Get current Epoch time
epochTime <- function() {
return(as.integer(Sys.time()))
}
#Get a formatted string of the timestamp
humanTime <- function() {
format(Sys.time(), "%Y%m%d-%H%M%OS")
}
#CSS to use in the app
appCSS <-
".mandatory_star { color: red; }
.shiny-input-container { margin-top: 25px; }
#thankyou_msg { margin-left: 15px; }
#error { color: red; }
body { background: #fcfcfc; }
#header { background: #fff; border-bottom: 1px solid #ddd; margin: -20px -15px 0; padding: 15px 15px 10px; }
"
#UI
ui <- shinyUI(
fluidPage(
shinyjs::useShinyjs(),
shinyjs::inlineCSS(appCSS),
headerPanel(
'How many days until it next rains in Liverpool?'
),
sidebarPanel(
id = "form",
textInput("name", labelMandatory("Enter name"), value = ""),
selectInput(
"type",
labelMandatory("Select which group best describes you"),
choices = c("", "Manager", "IT",
"Finance"),
selected = ""
),
numericInput(
"g1",
labelMandatory("Guess 1"),
value = "",
min = 1,
max = 10,
step = 1
),
numericInput(
"g2",
labelMandatory("Guess 2"),
value = "",
min = 1,
max = 10,
step = 1
),
numericInput(
"g3",
labelMandatory("Guess 3"),
value = "",
min = 1,
max = 10,
step = 1
),
numericInput(
"g4",
labelMandatory("Guess 4"),
value = "",
min = 1,
max = 10,
step = 1
),
numericInput(
"g5",
labelMandatory("Guess 5"),
value = "",
min = 1,
max = 10,
step = 1
),
numericInput(
"g6",
labelMandatory("Guess 6"),
value = "",
min = 1,
max = 10,
step = 1
),
numericInput(
"g7",
labelMandatory("Guess 7"),
value = "",
min = 1,
max = 10,
step = 1
),
numericInput(
"g8",
labelMandatory("Guess 8"),
value = "",
min = 1,
max = 10,
step = 1
),
numericInput(
"g9",
labelMandatory("Guess 9"),
value = "",
min = 1,
max = 10,
step = 1
),
numericInput(
"g10",
labelMandatory("Guess 10"),
value = "",
min = 1,
max = 10,
step = 1
)
),
mainPanel(
br(),
p("Your guesses will appear here:"),
br(),
br(),
plotOutput("plot"),
br(),
p(
"After you are happy with your guesses, press submit to send data to the database."
),
br(),
tableOutput("table"),
br(),
actionButton("Submit", "Submit"),
fluidRow(shinyjs::hidden(div(
id = "thankyou_msg",
h3("Thanks, your response was submitted successfully!")
)))
)
)
)
#Server
server <- shinyServer(function(input, output, session) {
# Gather all the form inputs
formData <- reactive({
x <- reactiveValuesToList(input)
data.frame(names = names(x),
values = unlist(x, use.names = FALSE))
})
#Save the results to a file
saveData <- function(data) {
# Create a unique file name
fileName <-
sprintf("%s_%s_drive_time.csv",
humanTime(),
digest::digest(data))
# Write the data to a temporary file locally
filePath <- file.path('C:\\Users\\SA31\\Desktop\\btc', fileName)
write.csv(data, filePath, row.names = TRUE, quote = TRUE)
# Upload the file to Dropbox
#drop_upload(filePath, path = outputDir)
}
# When the Submit button is clicked, submit the response
observeEvent(input$Submit, {
# User-experience stuff
shinyjs::disable("Submit")
shinyjs::show("thankyou_msg")
tryCatch({
#saveData(formData())
shinyjs::reset("form")
shinyjs::hide("form")
shinyjs::show("thankyou_msg")
})
#write.csv(create_table(),'submitted.csv')
saveData(create_table())
}, ignoreInit = TRUE, once = TRUE, ignoreNULL = T)
#Observe for when all mandatory fields are completed
observe({
fields_filled <-
fieldsMandatory %>%
sapply(function(x)
! is.na(input[[x]]) && input[[x]] != "") %>%
all
shinyjs::toggleState("Submit", fields_filled)
})
# isolate data input
values <- reactiveValues()
create_table <- reactive({
input$addButton
Name <- input$name
Type <- input$type
Guess1 <- input$g1
Guess2 <- input$g2
Guess3 <- input$g3
Guess4 <- input$g4
Guess5 <- input$g5
Guess6 <- input$g6
Guess7 <- input$g7
Guess8 <- input$g8
Guess9 <- input$g9
Guess10 <- input$g10
df <-
data_frame(Name, Type, Guess1, Guess2, Guess3, Guess4,
Guess5, Guess6, Guess7, Guess8, Guess9, Guess10)
df
})
output$table <- renderTable(create_table())
output$plot <- renderPlot({
input$addButton
x1 <- isolate({
input$g1
})
x2 <- isolate({
input$g2
})
x3 <- isolate({
input$g3
})
x4 <- isolate({
input$g4
})
x5 <- isolate({
input$g5
})
x6 <- isolate({
input$g6
})
x7 <- isolate({
input$g7
})
x8 <- isolate({
input$g8
})
x9 <- isolate({
input$g9
})
x10 <- isolate({
input$g10
})
df2 <-
data_frame(x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) %>%
gather()
ggplot(df2) +
geom_histogram(aes(x = as.numeric(value)), fill = "#18a7b5", stat =
"count") +
geom_hline(yintercept = seq(1, 10, 1),
col = "white",
lwd = 1) +
geom_vline(aes(xintercept = 4),
linetype = "dashed",
colour = "black") +
stat_function(
fun = function(x, mean, sd, n, bw) {
dnorm(x = x,
mean = mean,
sd = sd) * n * bw
},
args = c(
mean = mean(df2$value),
sd = sd(df2$value),
n = length(df2$value),
bw = 1
),
colour = "#b5185f"
) +
theme_bw() +
scale_x_continuous(limits = c(0, 10),
breaks = c(0, 1,2,3,4,5,6,7,8,9,10)) +
scale_y_continuous(limits = c(0, 10),
breaks = c(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10)) +
labs(x = "Number of days until rains", y = "",
title = "Estimated number of days until rain") +
theme(legend.position = "none")
})
})
# Run the application
shinyApp(ui = ui, server = server)
关于r - 保存在 Shiny 的应用程序中收集的 react 数据,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/48201169/
我正在通过 Rscript.exe 在托管到我的本地网络的服务器上运行 Shiny 应用程序。如果我们要将其移植到网上,我们可以通过我们设置的服务器基础设施来实现。 Shiny Server 是否添加
当我运行我的 Shiny 应用程序时,我的数据表的标题向左移动。见下文。 假设这张表在选项卡 A 上。 当我单击不同的选项卡(选项卡 B)时,标题会正确对齐,然后再次单击选项卡 A。有关更正的标题,请
是否有查询正在运行的 RStudio Shiny 网页以显示正在运行的服务器版本的变量或方法?例如。显示类似 shiny-0.10.1在网页上。 有任何想法吗? 最佳答案 您可以使用 packageV
我想在以下位置重现示例:https://scip.shinyapps.io/scip_app/ 基本上,我有一个 300 x 300 调整后的相关矩阵和一个 300 x 300 未调整的相关矩阵,我想
关闭。这个问题是opinion-based 。目前不接受答案。 想要改进这个问题吗?更新问题,以便 editing this post 可以用事实和引文来回答它。 . 去年关闭。 社区去年审查了是否重
在我部署应用程序时,应用程序中仍然存在一些异常情况,因此我想将它们从我的帐户中删除。我试过了,但没有找到任何选择。任何帮助将不胜感激。谢谢 最佳答案 在从 shiny.io 填充 token 信息后,
据我了解,Shiny Server 的开源版本不支持身份验证。 我们有一个环境使用 WebSEAL 代理服务来验证用户并将他们的访问引导到 Web 应用程序。 我们希望向经过身份验证的用户公开 Shi
我想将一个 R 应用程序(在装有 OS RHEL6.8 的实际 Shiny 服务器上运行良好)转移到另一个"new" Shiny 服务器。我的应用程序在第一台服务器上运行良好。这个想法是将它放在性能更
我正在通过 #RMarkdown 创建一个测试页面并尝试在其中添加 #Shiny 内容。在编织到 HTML 时,我收到以下错误。 Error in appshot.shiny.appobj(list(
有没有一种简单的方法可以在 shiny 中创建这样的东西? 最佳答案 RStudio 目前正在处理 sortable 包:RStudio/sortable 请注意,它目前正在开发中(标记为实验性),因
当我在一个非常简单的 Shiny 应用程序中按下操作按钮时,我试图调用另一个 Shiny 的应用程序。另一个应用程序位于一个带有 ui.R 和 server.R 文件的名为 Benefits 的文件夹
我最近试图在我的服务器上打开一个 Shiny 的服务器应用程序,并遇到了我以前从未见过的错误。 Error in loadNamespace(j -c "R -e \"install.pack
我有 Shiny 的应用程序,它显示旧数据(延迟 4 天!),但服务器数据已刷新(当天)。 奇怪的是,服务器上不存在旧数据集 - 似乎只存在于 Shiny 缓存中。 在服务器上,我有 1 个数据集由
我有一个在本地 R 服务器(端口 8787)上运行的应用程序。当我将它移动到 Shiny Server(端口 3838)时,我收到消息 ERROR: An error has occurred. Ch
我试图消除此表格与浏览器窗口左侧之间的空间,但当我这样做时,它弄乱了导航栏链接和标题的间距。 如何在不改变 navbar/ui/li 元素的填充/边距的情况下删除 excelR 表上的填充/边距? l
我已经阅读并实现了来自 link 的 Shiny 表中的复选框.但是当我在 R 中运行时,列中的输出是 , 等在每个“选择”单元格中,我希望“选择”列中的输出是复选框,我的问题的解决方案是什么?谢谢
我一直在开发一个 Shiny 的应用程序,它开始变得相当大。 我通过将应用程序的不同部分放入各自文件中的模块中解决了这个问题,然后获取文件。 问题是,当我在源文件的服务器部分(下例中的 events.
我对 Shiny 和 DataTables 还很陌生,所以这可能是个愚蠢的问题。由于某种原因,我无法更改列宽。我试过了 output$table<-DT::renderDataTable( {w
我安装了我的 Shiny 服务器,它在这个目录下的多个应用程序上工作正常: /srv/ Shiny 服务器/app1/srv/ Shiny 服务器/app2 我可以使用 www.mydomain.co
我想在我的 Shiny 应用程序中包含我的 myMardown.md 文档。 为了显示目录,我使用了 toc 选项,还使用了 css (myStyle.css) myMarkdown.md : ---
我是一名优秀的程序员,十分优秀!