I have a Shiny App which I want to implement in a existing website, therefore I need to translate the ui.R into a HTML UI.I got most of the things from ui.R work in HTML UI, but I have questions concerning uiOutput, html Output and the File Upload.
Q1:How do implement an dynamic Slider, that I have created with renderUI({})? The dynamic selection I have created with renderUI({}) works fine, but with the slider I get the following error:min, max, amd value must all be numeric values It seems that no numeric values can be send to server.R from the HMTL UI.
Q2:: How would a working HMTL File Upload would look like? Mine seems to upload files, but I cannot pass it to server.R.
Here is an example:
server.R:
library(shiny)
#sample data
years<-c(1990,1995,2000,2005,2010)
oryear<-years[3]
shinyServer(function(input, output, session) {
#Input uploaded file
inFile<-input$ascii_layer
#make dynamic selection
output$selectUI <- renderUI({
selectInput("test_select", "Test selection", years, selected=oryear)
})
#make dynamic slider
output$slider <- renderUI({
sliderInput("inSlider", "Slider", min=input$min_val, max=input$max_val, value=2000)
})
})
ui.R:
library(shiny)
shinyUI(pageWithSidebar(
headerPanel("Test Shiny App"),
sidebarPanel(
#File Upload
fileInput('ascii_layer', 'Choose ASCII Layer', multiple=FALSE, accept='asc'),
#HTML Selection Output from server.R
htmlOutput("selectUI"),
#Numeric Inputs
numericInput("min_val", "Enter Minimum Value", 1993),
numericInput("max_val", "Enter Maximum Value", 2013)
#display dynamic UI
uiOutput("slider")
),
mainPanel()
))
HMTL UI:
<html>
<head>
<script src="shared/jquery.js" type="text/javascript"></script>
<script src="shared/shiny.js" type="text/javascript"></script>
<link rel="stylesheet" type="text/css" href="shared/shiny.css"/>
</head>
<body>
<h1>HTML UI</h1>
<!—- File Upload—->
<p>
<form action="input_file.htm" method="post" enctype="multipart/form-data">
<p>Choose Distance to Road Layer:<br>
<input name="ascii_layer" type="file" size="50" maxlength="100000" accept="*.asc">
</p>
</form>
</p>
<!—-Numeric Inputs—->
<p>
<label>Enter Minimum Value:</label><br />
<input type="number" name="min_val" value="1993" />
</p>
<p>
<label>Enter Maximum Value:</label><br />
<input type="number" name="max_val" value="1993" />
</p>
<!—-Dynamic Selection—->
<div id="selectUI" class="shiny-html-output"></div>
<!—-Dynamic Slider—->
<div id="slider" class="shiny-html-output"></div>
</body>
</html>
There were several errors in your Shiny code. A fixed version is given below. Run this by copy-and-pasting into the R terminal and view the source code from your browser to get your html-ui. I suggest you take a look at the Shiny tutorials online (e.g. http://rstudio.github.io/shiny/tutorial) for further detail on file upload etc.
library(shiny)
#sample data
years <- c(1990,1995,2000,2005,2010)
oryear <- years[3]
server <- function(input, output, session) {
#Input uploaded file
# inFile<-input$ascii_layer
output$contents <- renderTable({
inFile <- input$ascii_layer
if (is.null(inFile))
return(NULL)
read.csv(inFile$datapath)
})
#make dynamic selection
output$selectUI <- renderUI({
selectInput("test_select", "Test selection", years, selected=oryear)
})
#make dynamic slider
output$slider <- renderUI({
sliderInput("inSlider", "Slider", min=input$min_val, max=input$max_val, value=2000)
})
}
ui <- pageWithSidebar(
headerPanel("Test Shiny App"),
sidebarPanel(
#File Upload
fileInput('ascii_layer', 'Choose ASCII Layer', multiple=FALSE, accept='asc'),
#HTML Selection Output from server.R
uiOutput("selectUI"),
#Numeric Inputs
numericInput("min_val", "Enter Minimum Value", 1993),
numericInput("max_val", "Enter Maximum Value", 2013),
#display dynamic UI
uiOutput("slider")
),
mainPanel(
tableOutput('contents')
)
)
runApp(list(ui = ui, server = server))
Related
I've been struggling with this, below is a much simplified version of my issue but here is the idea : I have a table with 4 text areas using an html template. When the user types into one of the 4 text areas (he can only input text in one), a score is assigned - cell 1 =1, cell 2 = 2 etc. Pulling the string content is not a problem but I can't seem to get the score assigned to save properly I'm not sure of what I am doing wrong.
library(shiny)
ui <- fluidPage(
column(
12,
actionButton("save_project", "save")),
column(
width = 12,
h4("Assessment #1"),
htmlTemplate(
filename = "market_table.html",
indicator = "market_creation_attr_1"
)
)
)
server <- function(input, output, session) {
market_ table_1_score <- reactiveVal(NULL)
observeEvent(c(input$market_creation_attr_1_market_rating_1,input$market_creation_attr_1_market_rating_2,input$market_creation_attr_1_market_rating_3,input$market_creation_attr_1_market_rating_4), {
if (!is.na(input$market_creation_attr_1_market_rating_1)||is.null(input$market_creation_attr_1_market_rating_1)){
market_table_1_score<-1
} else if (!is.na(input$market_creation_attr_1_market_rating_2)){
market_table_1_score<-2
}else if (!is.na(input$market_creation_attr_1_market_rating_3)){
market_table_1_score<-3
}else if(!is.na(input$market_creation_attr_1_market_rating_4)){
market_table_1_score<-4
}
market_table_1_score
})
observeEvent(input$save_project, {
inputs <- reactiveValuesToList(input)
filepath <- file.path("save", paste0("input-.rds"))
saveRDS(inputs, file = filepath)
all_values <- reactiveValuesToList(values)
filepath <- file.path("save", paste0("values--.rds"))
saveRDS(all_values, file = filepath)
})
}
shinyApp(ui=ui, server=server)
And this is the template of the html table (not sure that's relevant)
<div class="market-table">
<ul class="market-header">
<li style="border-right: 1px solid black"><div>Market Typology</div></li>
<li><div>Highly Developed</div></li>
<li><div>Moderately Developed</div></li>
<li><div>Under Developed</div></li>
<li><div>Highly Under Developed</div></li>
</ul>
<ul class="market-row">
<li>INDICAOTR</li>
<li>
<textarea id="{{ paste0(indicator, '_market_rating_1')}}" rows="5" maxlength="500"></textarea>
</li>
<li>
<textarea id="{{ paste0(indicator, '_market_rating_2')}}" rows="5" maxlength="500"></textarea>
</li>
<li>
<textarea id="{{ paste0(indicator, '_market_rating_3')}}" rows="5" maxlength="500"></textarea>
</li>
<li>
<textarea id="{{ paste0(indicator, '_market_rating_4')}}" rows="5" maxlength="500"></textarea>
</li>
</ul>
</div>
Any advice is greatly appreciated!
after spending several hours on the (I'm still a beginner), I found noticed 2 major errors : 1. in my condition, it shouldn't be !is.na, rather I should have used !='' 2. and this is pretty important, I didn't create an empty object to store the reactive values...oops.
Here is a working code (see template in my original question)
library(shiny)
ui <- fluidPage(
column(
12,
actionButton("save_project", "save")),
column(
width = 12,
h4("Assessment #1"),
htmlTemplate(
filename = "market_table.html",
indicator = "market_creation_attr_1"
)
)
)
server <- function(input, output, session) {
values <- reactiveValues()
market_typology_table_1_score <- reactiveVal(NULL)
observeEvent(c(input$market_creation_attr_1_market_rating_1,input$market_creation_attr_1_market_rating_2,input$market_creation_attr_1_market_rating_3,input$market_creation_attr_1_market_rating_4), {
if (input$market_creation_attr_1_market_rating_1!=''){
market_ table_1_score<-1
} else if (input$market_creation_attr_1_market_rating_2!=''){
market_ table_1_score<-2
}else if (input$market_creation_attr_1_market_rating_3!=''){
market_ table_1_score<-3
}else if(input$market_creation_attr_1_market_rating_4!=''){
market_table_1_score<-4
}
values$market_typology_table_1_score<-isolate(market_typology_table_1_score)
})
observeEvent(input$save_project, {
inputs <- reactiveValuesToList(input)
filepath <- file.path("save", paste0("input.rds"))
saveRDS(inputs, file = filepath)
all_values <- reactiveValuesToList(values)
filepath <- file.path("save", paste0("values.rds"))
saveRDS(all_values, file = filepath)
})
}
shinyApp(ui=ui, server=server)
I've written and optimized a Shiny app, and now I'm struggling with the IT section of the organization where I work to have it published on their servers.
Currently, they are claiming that the app is not W3C compliant, which is true, according to the W3C validator.
The errors I'm trying to solve, with no success, are:
<form class="well" role="complementary"> Bad value “complementary” for attribute “role” on element “form”.
<label class="control-label" id="foo-label" for="foo"> The value of the “for” attribute of the “label” element must be the ID of a non-hidden form control.
Such errors can be seen also in very minimal shiny apps, like:
# Reprex adapted from https://shiny.rstudio.com/gallery/tabsets.html
library(shiny)
# Define UI for random distribution app ----
ui <- fluidPage(
# App title ----
titlePanel("Tabsets"),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
# Input: Select the random distribution type ----
radioButtons("dist", "Distribution type:",
c("Normal" = "norm",
"Uniform" = "unif",
"Log-normal" = "lnorm",
"Exponential" = "exp")),
# br() element to introduce extra vertical spacing ----
br(),
# Input: Slider for the number of observations to generate ----
sliderInput("n",
"Number of observations:",
value = 500,
min = 1,
max = 1000)
),
# Main panel for displaying outputs ----
mainPanel(
# Output: Tabset w/ plot, summary, and table ----
tabsetPanel(type = "tabs",
tabPanel("Plot", plotOutput("plot")),
tabPanel("Summary", verbatimTextOutput("summary")),
tabPanel("Table", tableOutput("table"))
)
)
)
)
# Define server logic for random distribution app ----
server <- function(input, output) {
# Reactive expression to generate the requested distribution ----
d <- reactive({
dist <- switch(input$dist,
norm = rnorm,
unif = runif,
lnorm = rlnorm,
exp = rexp,
rnorm)
dist(input$n)
})
# Generate a plot of the data ----
output$plot <- renderPlot({
dist <- input$dist
n <- input$n
hist(d(),
main = paste("r", dist, "(", n, ")", sep = ""),
col = "#75AADB", border = "white")
})
}
# Create Shiny app ----
shinyApp(ui, server)
The second error seems to be related, somehow, to radiobuttons only, whereas the first one seems to afflict all the shiny apps I've found on the web and tested with the W3C validator so far.
For completeness, I report also the HTML code generated by the shiny app in the reprex:
<!DOCTYPE html>
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8"/>
<script type="application/shiny-singletons"></script>
<script type="application/html-dependencies">jquery[3.6.0];shiny-css[1.7.1];shiny-javascript[1.7.1];ionrangeslider-javascript[2.3.1];strftime[0.9.2];ionrangeslider-css[2.3.1];bootstrap[3.4.1]</script>
<script src="shared/jquery.min.js"></script>
<link href="shared/shiny.min.css" rel="stylesheet" />
<script src="shared/shiny.min.js"></script>
<script src="shared/ionrangeslider/js/ion.rangeSlider.min.js"></script>
<script src="shared/strftime/strftime-min.js"></script>
<link href="shared/ionrangeslider/css/ion.rangeSlider.css" rel="stylesheet" />
<meta name="viewport" content="width=device-width, initial-scale=1" />
<link href="shared/bootstrap/css/bootstrap.min.css" rel="stylesheet" />
<link href="shared/bootstrap/accessibility/css/bootstrap-accessibility.min.css" rel="stylesheet" />
<script src="shared/bootstrap/js/bootstrap.min.js"></script>
<script src="shared/bootstrap/accessibility/js/bootstrap-accessibility.min.js"></script> <title>Tabsets</title>
</head>
<body>
<div class="container-fluid">
<h2>Tabsets</h2>
<div class="row">
<div class="col-sm-4">
<form class="well" role="complementary">
<div id="dist" class="form-group shiny-input-radiogroup shiny-input-container" role="radiogroup" aria-labelledby="dist-label">
<label class="control-label" id="dist-label" for="dist">Distribution type:</label>
<div class="shiny-options-group">
<div class="radio">
<label>
<input type="radio" name="dist" value="norm" checked="checked"/>
<span>Normal</span>
</label>
</div>
<div class="radio">
<label>
<input type="radio" name="dist" value="unif"/>
<span>Uniform</span>
</label>
</div>
<div class="radio">
<label>
<input type="radio" name="dist" value="lnorm"/>
<span>Log-normal</span>
</label>
</div>
<div class="radio">
<label>
<input type="radio" name="dist" value="exp"/>
<span>Exponential</span>
</label>
</div>
</div>
</div>
<br/>
<div class="form-group shiny-input-container">
<label class="control-label" id="n-label" for="n">Number of observations:</label>
<input class="js-range-slider" id="n" data-skin="shiny" data-min="1" data-max="1000" data-from="500" data-step="1" data-grid="true" data-grid-num="9.99" data-grid-snap="false" data-prettify-separator="," data-prettify-enabled="true" data-keyboard="true" data-data-type="number"/>
</div>
</form>
</div>
<div class="col-sm-8" role="main">
<div class="tabbable">
<ul class="nav nav-tabs" data-tabsetid="9747">
<li class="active">
Plot
</li>
<li>
Summary
</li>
<li>
Table
</li>
</ul>
<div class="tab-content" data-tabsetid="9747">
<div class="tab-pane active" data-value="Plot" id="tab-9747-1">
<div id="plot" class="shiny-plot-output" style="width:100%;height:400px;"></div>
</div>
<div class="tab-pane" data-value="Summary" id="tab-9747-2">
<pre class="shiny-text-output noplaceholder" id="summary"></pre>
</div>
<div class="tab-pane" data-value="Table" id="tab-9747-3">
<div id="table" class="shiny-html-output"></div>
</div>
</div>
</div>
</div>
</div>
</div>
</body>
</html>
Do you have any suggestions?
Thanks!
This message was also posted on RStudio Community: sorry for cross-posting.
The following only deals with the first of the errors you mention (as this one is pretty clear thanks to #BenBolkers comment), but hopefully it points you to the right tools to use.
I'd use htmltools::tagQuery to make the needed modifications - please check the following:
# Reprex adapted from https://shiny.rstudio.com/gallery/tabsets.html
library(shiny)
library(htmltools)
# Define UI for random distribution app ----
ui <- fluidPage(
# App title ----
titlePanel("Tabsets"),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
{querySidebarPanel <- tagQuery(sidebarPanel(
# Input: Select the random distribution type ----
radioButtons("dist", "Distribution type:",
c("Normal" = "norm",
"Uniform" = "unif",
"Log-normal" = "lnorm",
"Exponential" = "exp")),
# br() element to introduce extra vertical spacing ----
br(),
# Input: Slider for the number of observations to generate ----
sliderInput("n",
"Number of observations:",
value = 500,
min = 1,
max = 1000)
))
querySidebarPanel$find(".well")$removeAttrs("role")$addAttrs("role" = "none")$allTags()},
# Main panel for displaying outputs ----
mainPanel(
# Output: Tabset w/ plot, summary, and table ----
tabsetPanel(type = "tabs",
tabPanel("Plot", plotOutput("plot")),
tabPanel("Summary", verbatimTextOutput("summary")),
tabPanel("Table", tableOutput("table"))
)
)
)
)
# Define server logic for random distribution app ----
server <- function(input, output) {
# Reactive expression to generate the requested distribution ----
d <- reactive({
dist <- switch(input$dist,
norm = rnorm,
unif = runif,
lnorm = rlnorm,
exp = rexp,
rnorm)
dist(input$n)
})
# Generate a plot of the data ----
output$plot <- renderPlot({
dist <- input$dist
n <- input$n
hist(d(),
main = paste("r", dist, "(", n, ")", sep = ""),
col = "#75AADB", border = "white")
})
}
# Create Shiny app ----
shinyApp(ui, server)
Please also see this related chapter from "Outstanding User Interfaces with Shiny".
I have the following ui.R
library(datasets)
# Use a fluid Bootstrap layout
fluidPage(
# Give the page a title
titlePanel("Telephones by region"),
# Generate a row with a sidebar
sidebarLayout(
# Define the sidebar with one input
sidebarPanel(
selectInput("region", "Region:",
choices=colnames(WorldPhones)),
hr(),
helpText("Some text and then some code.")
),
# Create a spot for the barplot
mainPanel(
plotOutput("phonePlot")
)
)
)
Where the helpText() produces:
<span class="help-block">
Some text and then some code.
</span>
How can I modify helpText so that in can include code block:
<span class="help-block">
Some text and then <code>some code</code>.
</span>
Use
helpText("Some text and then ", code("some code"), ".")
Since yesterday I run a shiny app with radiobuttons in a HTML table. I used a code like this:
ui.r
shinyUI(pageWithSidebar(
headerPanel('Download Example'),
sidebarPanel(),
mainPanel(
fluidRow(
HTML('<div class="attr-col">
<ul>
<li>
<input type="radio" name="var" id="var1" value="A" checked="checked"/>
Option 1
</li>
<li>
<input type="radio" name="var" id="var2" value="B" />
Option 2
</li>
</ul>
</div>'
)
),
fluidRow(
verbatimTextOutput("sel")
)
)
))
server.r
shinyServer(function(input, output) {
output$sel<-renderText ({ input$var })
})
The code above works good in R 3.0.2 and shiny 0.11.1 ! But with R 3.2.0 and shiny 0.12.0 it doesn't.
I need to keep the HTML because I use a CSS to format a big table with other objects. I don't understand why in the new version the input$var can't reach the server. It is changed something in the code?
Sorry about that. Can you try changing the outer div to <div class="attr-col shiny-input-radiogroup" id="var">?
I am building this app using the Rook package in R:
library(Rook)
s <- Rhttpd$new()
s$start(quiet=T)
PIC.DIR = paste(getwd(), 'pic', sep='/')
my.app <- function(env){
## Start with a predefined lognormal mean and median, and allow a user to input custom values
req <- Request$new(env)
res <- Response$new()
E <- 1.5
MED <- 1
xmax <- 5
breaks <- 500
## Allow user to input custom mean/median values
if (!is.null(req$POST())){
E <- as.numeric(req$POST()[["mean"]])
MED <- as.numeric(req$POST()[["median"]])
xmax <- as.numeric(req$POST()[["xmax"]])
breaks <- as.numeric(req$POST()[["breaks"]])
}
mu <- log(MED)
sd <- sqrt(2*log(E/MED))
MO <- exp(mu - sd^2)
rate <- rlnorm(1000000, mu, sd)
today <- Sys.Date()
dt <- format(today, format="%m/%d/%y")
sc <- paste("Source: My Source, accessed ", dt)
png(file=paste(PIC.DIR, "/mypic.png", sep=""), width=1024, height=612)
h1 <- hist(rate, freq=F, col="red", xlim=c(0,xmax), breaks=breaks, main="Rate",
xlab="Rate", ylab="# of Studies", sub=sc)
dev.off()
res$write('<head>
<title> Rate Curve </title>
</head>
<h1>Rate Distribution Analysis</h1>')
res$write(paste("<img src='", s$full_url("pic"), "/mypic.png'",
"width='1024 px' height='612 px' />", sep = ""))
res$write('<p>
Input Lognormal Parameters:<form method="POST"> </br>
mean: <input type="text" name="mean" value="1.5" /> </t>
median: <input type="text" name="median" value="1" /> </br>
</br>
Graphics parameters </br>
X-axis limit: <input type="text" name="xmax" value="5" /> </t>
Histogram breaks: <input type="text" name="breaks" value="500" /> </br>
<input type="submit" name="Go" />\n</form>
</p>')
res$finish()
}
s$add(app=my.app, name='lognorm')
s$add(app = File$new(PIC.DIR), name = "pic")
s$browse('lognorm')
The browser initially loads fine, but when I try to enter different values in the inputs, I get this error:
R Custom HTTP Handler Not Found
Unable to locate custom HTTP handler for /custom/lognorm_mode
Is the package which implements this HTTP handler loaded?
Any ideas on how to solve this?
Instead of the last part
s$add(app=my.app, name='lognorm')
s$add(app = File$new(PIC.DIR), name = "pic")
s$browse('lognorm')
Try
library(Rook)
myPort <- 23845
myInterface <- "127.0.0.1"
status <- -1
status <- .Internal(startHTTPD(myInterface, myPort))
if (status == 0) {
unlockBinding("httpdPort", environment(tools:::startDynamicHelp))
assign("httpdPort", myPort, environment(tools:::startDynamicHelp))
s <- Rhttpd$new()
s$listenAddr <- myInterface
s$listenPort <- myPort
s$launch(name = "lognorm", app = my.app)
}
This should keep the server alive even after the web page is launched.
(Source http://jeffreyhorner.tumblr.com/post/33814488298/deploy-rook-apps-part-ii)