I have generated few plots using plotly and saved them as offline html (I don't want to generate them live as it would take so long to generate them in the background). The followings are the two plots taken from plotly site and I saved them as html.
#Graph 1
Animals <- c("giraffes", "orangutans", "monkeys")
SF_Zoo <- c(20, 14, 23)
LA_Zoo <- c(12, 18, 29)
data <- data.frame(Animals, SF_Zoo, LA_Zoo)
p <- plot_ly(data, x = ~Animals, y = ~SF_Zoo, type = 'bar', name = 'SF Zoo') %>%
add_trace(y = ~LA_Zoo, name = 'LA Zoo') %>%
layout(yaxis = list(title = 'Count'), barmode = 'group')
htmlwidgets::saveWidget(p, file="zoo.html")
#Graph 2
x <- c('Product A', 'Product B', 'Product C')
y <- c(20, 14, 23)
text <- c('27% market share', '24% market share', '19% market share')
data <- data.frame(x, y, text)
p <- plot_ly(data, x = ~x, y = ~y, type = 'bar', text = text,
marker = list(color = 'rgb(158,202,225)',
line = list(color = 'rgb(8,48,107)',
width = 1.5))) %>%
layout(title = "January 2013 Sales Report",
xaxis = list(title = ""),
yaxis = list(title = ""))
htmlwidgets::saveWidget(p, file="product.html")
I have written some shiny codes that can show html output from Rmarkdown but not the html that i generated from plotly above. Note that the first choice(sample) in the selectInput() is what I generated from default Rmarkdown html and that works. I also generated multiple rmarkdown html and I could also switch between htmls in the shiny app but not for plotly html.
ui= fluidPage(
titlePanel("opening web pages"),
sidebarPanel(
selectInput(inputId='test',label=1,choices=c("sample","zoo","product"))
),
mainPanel(
htmlOutput("inc")
)
)
server = function(input, output) {
getPage<-function() {
return(includeHTML(paste0("file:///C:/Users/home/Documents/",input$test,".html")))
}
output$inc<-renderUI({getPage()})
}
shinyApp(ui, server)
You can use an iframe for this - also have a look at addResourcePath:
ui = fluidPage(
titlePanel("opening web pages"),
sidebarPanel(selectInput(
inputId = 'test',
label = 1,
choices = c("sample", "zoo", "product")
)),
mainPanel(htmlOutput("inc"))
)
server = function(input, output) {
myhtmlfilepath <- getwd() # change to your path
addResourcePath('myhtmlfiles', myhtmlfilepath)
getPage <- function() {
return(tags$iframe(src = paste0("myhtmlfiles/", input$test, ".html"), height = "100%", width = "100%", scrolling = "yes"))
}
output$inc <- renderUI({
req(input$test)
getPage()
})
}
shinyApp(ui, server)
Related
I am having a hard time understanding how the container argument from function VisNetwork::VisConfigure works. It seems as though one can move the configuration list in another HTML container but my understanding is too limited (and I found no examples online).
My goal would be to place the configuration list in a shinydashboardPlus::dropdownBlock (i.e., in the dashboardHeader leftUI argument), see reproducible example below:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(visNetwork)
# Define the function to retrieve the parameters from VisConfigure
# See: https://github.com/datastorm-open/visNetwork/issues/333
visShinyGetOptionsFromConfigurator <- function (graph, input = paste0(graph$id, "_configurator")) {
if (!any(class(graph) %in% "visNetwork_Proxy")) {
stop("Can't use visGetPositions with visNetwork object. Only within shiny & using visNetworkProxy")
}
data <- list(id = graph$id, input = input)
graph$session$sendCustomMessage("visShinyGetOptionsFromConfigurator", data)
graph
}
ui <- dashboardPage(
dashboardHeader(title = "Test visConfigure container argument",
leftUi = tagList(
shinydashboardPlus::dropdownBlock(
id = "graphparams",
title = "Graph parameters",
icon = shiny::icon("gears"),
shinyWidgets::prettyRadioButtons(
inputId = "physics",
label = "Parameters should appear here",
choices = c("Yes","No"))))),
dashboardSidebar(width = 220),
dashboardBody(
fluidRow(box(id = "network",
title = "Network",
status = "primary",
width = 12,
solidHeader = TRUE,
collapsible = TRUE,
visNetworkOutput('network'))),
fluidRow(actionButton("ops", "Options"))))
server <- function(input, output, session) {
getDiagramPlot <- function(nodes, edges){
v <- visNetwork(
nodes,
edges) %>%
visIgraphLayout(layout = "layout_on_sphere", physics = TRUE, randomSeed = 1234) %>%
visPhysics(solver = "hierarchicalRepulsion",
hierarchicalRepulsion = list(springLength = 850, nodeDistance = 90),
stabilization = "onlyDynamicEdges") %>%
visOptions(highlightNearest = list(enabled = T, degree = 1, hover = F), autoResize = TRUE, collapse = FALSE) %>%
visEdges(color = list(highlight = "red")) %>%
visEdges(arrows = edges$arrows) %>%
visConfigure(enabled = TRUE, filter = "physics", container = NULL) %>%
visInteraction(multiselect = F)
return(v)
}
nodes <- data.frame(id = 0:20, label = LETTERS[1:21])
edges <- data.frame(from = 0, to = 1:20, value = seq(0.35, 0.5, length.out = 20))
output$network <- renderVisNetwork(
getDiagramPlot(nodes, edges)
)
# Send to console the settings from VisConfigure
# See: https://github.com/datastorm-open/visNetwork/issues/333
observeEvent(input$ops, { visNetworkProxy("network") %>% visShinyGetOptionsFromConfigurator() })
observe({ if(!is.null(input$network_configurator)) print(input$network_configurator)
})
session$onSessionEnded(stopApp)
}
shinyApp(ui, server)
Any idea?
Best,
C.
I tried to set container = input$graphparams but it didn't work.
I am trying with the below code.
library(shiny)
app <- shinyApp(
ui = fluidPage(
DT::dataTableOutput("mydatatable")
),
server = shinyServer(function(input, output, session) {
mycars <- reactive({ head(mtcars)})
output$mydatatable = DT::renderDataTable(mycars(), selection = 'single',
rownames = FALSE, options = list(dom = 't'))
selected_row <- reactiveVal(value = NULL)
observeEvent(input$mydatatable_rows_selected,{
selected_row(input$mydatatable_rows_selected)
})
observeEvent(selected_row(),
{
showModal(modalDialog(
title = "You have selected a row!",
ifelse(
mycars()$mpg[selected_row()] > 21,
tags$div(HTML(paste('cyl = ', tags$span(style = "color:red", mycars()$cyl[selected_row()]), sep = ""))),
tags$div(HTML(paste('cyl = ', tags$span(style = "color:blue", mycars()$cyl[selected_row()]), sep = "")))
)
))
})
})
)
app
Here I am trying to change color of 'cyl' value to red if 'mpg' value is greater than 21 else 'cyl' value will print in blue.
I have tried with few html codes but failed.
Thanks!
For this purpose the dataframe does not have to be reactive, so I removed that part in here. Make use of the formatStyle functionality:
app <- shinyApp(
ui = fluidPage(
DT::dataTableOutput("mydatatable")
),
server = shinyServer(function(input, output, session) {
mycars <- mtcars
output$mydatatable = DT::renderDataTable(datatable(mycars) %>%
formatStyle('cyl', 'mpg',
color = styleInterval(21.001, c('blue', 'red'))),
selection = 'single',
rownames = FALSE, options = list(dom = 't'))
})
)
app
I am wondering if there is a way to remove the index column (1st column) from the data table in Shiny.
For example, column of (1, 2, 3) before Name column as shown in the screenshot below:
Below is my code:
header <- dashboardHeader(
title = "Test"
)
sidebar <- dashboardSidebar(
)
body <- dashboardBody(
box(title = "Test", width = 7, status = "warning", DT::dataTableOutput("df"))
)
# UI
ui <- dashboardPage(header, sidebar, body)
# Server
server <- function(input, output, session) {
output$df = DT::renderDataTable(df, options = list(
autoWidth = TRUE,
columnDefs = list(list(width = '10px', targets = c(1,3)))))
}
# Shiny dashboard
shiny::shinyApp(ui, server)
Thanks in advance.
There is some excellent documentation of the package available at https://rstudio.github.io/DT/ I would highly recommend reading through.
At any rate, use the rownames = FALSE argument provided by the DT package as follows:
library(shinydashboard)
library(DT)
df <- mtcars
header <- dashboardHeader(
title = "Test"
)
sidebar <- dashboardSidebar(
)
body <- dashboardBody(
box(title = "Test", width = 7, status = "warning", DT::dataTableOutput("df"))
)
# UI
ui <- dashboardPage(header, sidebar, body)
# Server
server <- function(input, output, session) {
output$df = DT::renderDataTable(df, rownames = FALSE,
options = list(
autoWidth = TRUE,
columnDefs = list(list(width = '10px', targets = c(1,3)))))
}
# Shiny dashboard
shiny::shinyApp(ui, server)
I am trying to align the image I calling from the web to be in the center on my shiny app. I am using the html tag here because the image file is not saved in my computer, but I am calling it from the web. fifa_data[fifa_data$Name==input$player_name,]$Photo in my server.R file looks something like this: "https://cdn.sofifa.org/players/4/19/200104.png"
Here is an snapshot of what it looks like now, and the red square is where I want the image to be displayed:
Here is a snippet of my ui.R
ui2<- dashboardPage(
dashboardHeader(title="BIG Player Hunter"),
dashboardSidebar(
fluidRow(
uiOutput(outputId = "image")),
fluidRow(
uiOutput(outputId = "image2")),
fluidRow(
uiOutput(outputId = "image3")),
# uiOutput(outputId = "image2"),
# uiOutput(outputId = "image3")),
selectizeInput('player_name',"Player Name:",
choices=fifa_data$Name,
selected=NULL,
multiple=TRUE),
sliderInput("player_count",
"Number of players:",
min=1,
max=50,
value=5),
sliderInput("proximity",
"How close:",
min=0.01,
max=0.99,
value=0.05),
sliderInput("valuerange", "Price Range", min = 0, max = max(fifa_data$ValueNumeric_pounds),
value = c(25, 75)),
actionButton("search", "Search"),
sidebarMenu(
menuItem("Shoot 소개", tabName = "shoot_info", icon= icon("heart", lib= "glyphicon")),
menuItem("점수순위 및 분석", tabName = "leaderboard", icon= icon("bar-chart-o")),
menuItem("참가신청서", tabName = "signup", icon=icon("pencil", lib= "glyphicon"),
badgeLabel = "관리자", badgeColor = "red")
),
uiOutput("checkbox")
),
dashboardBody(
tabItem(tabName = "shoot_info",
fluidRow(
dataTableOutput("table1"),
chartJSRadarOutput("radarchart1")
)
)
)
)
Here is a sinner of my server.R
output$image<- renderUI({
tags$img(src= fifa_data[fifa_data$Name==input$player_name,]$Photo)
})
output$image2<- renderUI({
tags$img(src= fifa_data[fifa_data$Name==input$player_name,]$Flag)
})
output$image3<- renderUI({
tags$img(src= fifa_data[fifa_data$Name==input$player_name,]$`Club Logo`)
})
Try the below code for your requirement
library(shiny)
library(shinydashboard)
header <- dashboardHeader()
body <- dashboardBody()
sidebar <- dashboardSidebar(uiOutput("images"),
sliderInput("player_count",
"Number of players:",
min = 1,
max = 50,
value = 5),
sliderInput("proximity",
"How close:",
min = 0.01,
max = 0.99,
value = 0.05),
actionButton("search", "Search")
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output) {
output$images <- renderUI({
tags$div(img(src = "image1.png", width = 70, height = 90), img(src = "image2.png", width = 70, height = 90), img(src = "image3.png", width = 70, height = 90))
})
}
shinyApp(ui, server)
The screenshot of output
I have a simple shiny-app with just a dropdown listing districts of Afghanistan and a leaflet map of the same.
The shape file can be accessed at this link - using AFG_adm2.shp from http://www.gadm.org/download
here's the app code:
library(shiny)
library(leaflet)
library(rgdal)
library(sp)
afg <- readOGR(dsn = "data", layer ="AFG_adm2", verbose = FALSE, stringsAsFactors = FALSE)
ui <- fluidPage(
titlePanel("Test App"),
selectInput("yours", choices = c("",afg$NAME_2), label = "Select Country:"),
actionButton("zoomer","reset zoom"),
leafletOutput("mymap")
)
server <- function(input, output){
initial_lat = 33.93
initial_lng = 67.71
initial_zoom = 5
output$mymap <- renderLeaflet({
leaflet(afg) %>% #addTiles() %>%
addPolylines(stroke=TRUE, color = "#00000", weight = 1)
})
proxy <- leafletProxy("mymap")
observe({
if(input$yours!=""){
#get the selected polygon and extract the label point
selected_polygon <- subset(afg,afg$NAME_2==input$yours)
polygon_labelPt <- selected_polygon#polygons[[1]]#labpt
#remove any previously highlighted polygon
proxy %>% removeShape("highlighted_polygon")
#center the view on the polygon
proxy %>% setView(lng=polygon_labelPt[1],lat=polygon_labelPt[2],zoom=7)
#add a slightly thicker red polygon on top of the selected one
proxy %>% addPolylines(stroke=TRUE, weight = 2,color="red",data=selected_polygon,layerId="highlighted_polygon")
}
})
observeEvent(input$zoomer, {
leafletProxy("mymap") %>% setView(lat = initial_lat, lng = initial_lng, zoom = initial_zoom) %>% removeShape("highlighted_polygon")
})
}
# Run the application
shinyApp(ui = ui, server = server)
EDIT: I'm actually trying to add an action button which resets zoom to a default value (using leafletproxy and setview) and I want to put this button on the top-right corner of the map instead of it being above the map.
Can I use addLayersControl to do this?
EDIT2:
Code in full-app:
# Create the map
output$mymap <- renderLeaflet({
leaflet(afg) %>% addTiles() %>%
addPolygons(fill = TRUE,
fillColor = ~factpal(acdf$WP_2012), #which color for which attribute
stroke = TRUE,
fillOpacity = 1, #how dark/saturation the fill color should be
color = "black", #color of attribute boundaries
weight = 1, #weight of attribute boundaies
smoothFactor = 1,
layerId = aid
#popup = ac_popup
) %>% addPolylines(stroke=TRUE, color = "#000000", weight = 1) %>%
addLegend("bottomleft", pal = factpal, values = ~WP_2012,
title = "Party",
opacity = 1
) %>% setView(lng = initial_lng, lat = initial_lat, zoom = initial_zoom) %>%
addControl(html = actionButton("zoomer1","Reset", icon = icon("arrows-alt")), position = "topright")
})
I can't see the map tiles from addTiles or the zoom reset button from addControl. Any ideas why this might be happening?
You can use the addControl function directly:
output$mymap <- renderLeaflet({
leaflet(afg) %>% #addTiles() %>%
addPolylines(stroke=TRUE, color = "#00000", weight = 1) %>%
addControl(actionButton("zoomer","Reset"),position="topright")
})
You can achieve this by using the shiny absolutePanel() function in your UI, E.g.
library(shiny)
library(leaflet)
library(rgdal)
library(sp)
afg <- readOGR(dsn = "data", layer ="AFG_adm2", verbose = FALSE, stringsAsFactors = FALSE)
ui <- fluidPage(
tags$head(
tags$style(
HTML(
'
.outer {
position: fixed;
top: 80px;
left: 0;
right: 0;
bottom: 0;
overflow: hidden;
padding: 0;
}
#controls-filters {
background-color: white;
border:none;
padding: 10px 10px 10px 10px;
z-index:150;
}
'
)
)
),
titlePanel("Test App"),
absolutePanel(
id = "controls-filters",
class = "panel panel-default",
fixed = TRUE,
draggable = TRUE,
top = 100,
left = "auto",
right = 20,
bottom = "auto",
width = 330,
height = "auto",
selectInput("yours", choices = c("", afg$NAME_2), label = "Select Country:"),
actionButton("zoomer", "reset zoom")
),
div(class = "outer", leafletOutput("mymap"))
)
server <- function(input, output){
initial_lat = 33.93
initial_lng = 67.71
initial_zoom = 5
output$mymap <- renderLeaflet({
leaflet(afg) %>% #addTiles() %>%
addPolylines(stroke=TRUE, color = "#00000", weight = 1)
})
proxy <- leafletProxy("mymap")
observe({
if(input$yours!=""){
#get the selected polygon and extract the label point
selected_polygon <- subset(afg,afg$NAME_2==input$yours)
polygon_labelPt <- selected_polygon#polygons[[1]]#labpt
#remove any previously highlighted polygon
proxy %>% removeShape("highlighted_polygon")
#center the view on the polygon
proxy %>% setView(lng=polygon_labelPt[1],lat=polygon_labelPt[2],zoom=7)
#add a slightly thicker red polygon on top of the selected one
proxy %>% addPolylines(stroke=TRUE, weight = 2,color="red",data=selected_polygon,layerId="highlighted_polygon")
}
})
observeEvent(input$zoomer, {
leafletProxy("mymap") %>% setView(lat = initial_lat, lng = initial_lng, zoom = initial_zoom) %>% removeShape("highlighted_polygon")
})
}
# Run the application
shinyApp(ui = ui, server = server)
This should get you started but I would recommend structuring your app in such a way that it has a stand alone CSS file.