Fowllowing the description of dynamic shiny app at topic [R Shiny Dynamic Input
, i want to get a data into shiny app. I wrote in ui.R
library(fPortfolio)
library(quantmod)
library(shiny)
ui <- shinyUI(fluidPage(
titlePanel("Portfolio optimization"),
sidebarLayout(
sidebarPanel(
numericInput("numInputs", "A number of stocks", 2),
# place to hold dynamic inputs
uiOutput("inputGroup")
),
mainPanel(
tabPanel("Trading Statistics",
fixedRow(
column(8,
fixedRow(column(4,tableOutput("tablePerformance")),
column(4,tableOutput("tableRisk"))),
fixedRow(column(4,tableOutput("tableDaily")),
column(4,tableOutput("tableMonthly"))))
))
)
)
))
and in server.r
library(fPortfolio)
library(quantmod)
library(shiny)
server<-shinyServer(function(input, output){
observeEvent(input$numInputs, {
output$inputGroup = renderUI({
input_list <- lapply(1:input$numInputs, function(i) {
# for each dynamically generated input, give a different name
inputName <- paste("input", i, sep = "")
textInput(inputName, inputName, value = 1)
})
do.call(tagList, input_list)
})
})
data <- read.csv("E:/stock vn data/dulieuvietnam/metastock_all_data.txt", header = TRUE, stringsAsFactors = FALSE)
Tickers <- data[!duplicated(data$X.Ticker.),1]
Tickers <- subset(Tickers,substr(Tickers,1,1)!= "^")
PriceList <- list()
for (i in 1:length(Tickers)){
PriceList[[i]] <- subset(data[,c(2,6)],data$X.Ticker. == Tickers[i])
names(PriceList[[i]]) <- c("Date",Tickers[i])
PriceList[[i]][PriceList[[i]]==0]<-NA
PriceList[[i]] <- na.locf(PriceList[[i]])
}
PriceList[[(length(Tickers)+1)]]<-subset(data[,c(2,6)],data$X.Ticker. == "^VNINDEX")
names(PriceList[[(length(Tickers)+1)]]) <- c("Date","VNINDEX")
PriceList[[(length(Tickers)+1)]][PriceList[[(length(Tickers)+1)]]==0]<-NA
PriceList[[(length(Tickers)+1)]] <- na.locf(PriceList[[(length(Tickers)+1)]])
dataPrice <- PriceList[[1]]
for (k in 2:length(PriceList)){
dataPrice <-merge(dataPrice,PriceList[[k]],all=TRUE)
}
output$tablePerformance<-renderTable({
})
})
.
When i run runApp(), the app only shows input with label "A number of stocks" that has default value is 2. However, interface of app did not show two text input.
Please help me!
Related
I sincerely apologize but it has been a month now of trying but I still cannot figure out. The main question: How to use Shiny R to appear "run code" button in one page and then when pressed & finished calculating two new results in separate tabs/windows appear?
I have a code saved as "Button_test.R" with the following content:
long_code <- source("long_code.R")$value
library(shiny)
shinyApp(
fluidPage(
titlePanel("Test results"),
actionButton("run", "run code")),
function(input, output, session){
vals <- reactiveValues()
mainPanel(titlePanel("Test results"))
fluidRow(
column(12,
dataTableOutput('table'),
)
)
observeEvent(input$run, {
vals$long_code_out <- long_code()
showModal(modalDialog("calculation finished!"))
output$table <- renderDataTable(pred)
stopApp()
})
}
)
The "long_code.R" file contains the following files (gasoline pls data -- available using pls package) and codes:
function(){
library(pls)
library(prospectr)
library(Metrics)
library(factoextra)
data(gasoline)
gasTrain <- gasoline[1:50,]
gasTest <- gasoline[51:60,]
gas1 <- plsr(octane ~ NIR, ncomp = 10, data = gasTrain, validation =
"LOO")
pred <- predict(gas1, ncomp = 2, newdata = gasTest)
write.csv(pred,"pred.csv")
jpeg('pca.jpg')
plot(RMSEP(gas1), legendpos = "topright")
dev.off()
}
When I first run the "Button_test.R" it showed "run code" with the page below:
run code page
Then, when I pressed the "run code," the calculation was finished. However, I am interested to produce in 2 separates pages (new tabs or new windows) the results for "pca.jpg" plot and "pred" results similar below:
pca.jpg plot
pred results
I am not sure how to do it and where do I put the code. I am sorry for this long code. It is just necessary to produce the results. My apologies.
Try this code:
library(shiny)
long_code <- function(){
library(pls)
library(prospectr)
library(Metrics)
library(factoextra)
data(gasoline)
gasTrain <- gasoline[1:50,]
gasTest <- gasoline[51:60,]
gas1 <- plsr(octane ~ NIR, ncomp = 10, data = gasTrain, validation = "LOO")
pred <- predict(gas1, ncomp = 2, newdata = gasTest)
p1 <- plot(RMSEP(gas1), legendpos = "topright")
p2 <- as.data.frame(pred)
myresult <- list(p1,p2)
## you can write files on server side
# write.csv(pred,"pred.csv")
#
jpeg('pca.jpg')
plot(RMSEP(gas1), legendpos = "topright")
dev.off()
return(myresult)
}
ui <- navbarPage("Test Results",id = "inTabset",
tabPanel ("Home", value="tab1", actionButton("run", "run code")
),
tabPanel ("My Plot", value="tab2",
fluidRow(column(10, plotOutput("myplot")) )
),
tabPanel("My Table", value="tab3",
fluidRow(column(12,dataTableOutput('table')))
)
)
server <- function(input, output, session){
vals <- reactiveValues()
observeEvent(input$run, {
req(input$run)
vals$long_code_out <- long_code()
showModal(modalDialog("calculation finished!"))
myresults <- long_code()
output$myplot <- renderPlot({
myresults <- long_code()
myresults[[1]]
})
output$table <- renderDataTable({
myresults[[2]]
})
#stopApp()
## you can save files below this line
write.csv(myresults[[2]],"pred.csv")
})
}
shinyApp(ui = ui, server = server)
I have a function that's arranging a plot in a grid:
plotFunc <- function(a,b)
{
p <- qplot(a,b)
p2 <- xyplot(1~1)
r <- grid::rectGrob(gp=gpar(fill="grey90"))
t <- grid::textGrob("text")
g <- gridExtra::grid.arrange(t, p, p2, r, ncol=2)
return(g)
}
So the return value is:
"gtable" "gTree" "grob" "gDesc"
I want to use a shiny app in order to be able to select a and b values display the resulting plot and also have the option to save it to a file.
Here's my code:
data:
set.seed(1)
vals.df <- data.frame(b=1:6,a=sample(1:2,6,replace=T))
Shiny code:
library(shiny)
library(ggplot2)
library(lattice)
library(SpaDES)
library(devtools)
server <- function(input, output)
{
output$b <- renderUI({
selectInput("b", "B", choices = unique(dplyr::filter(vals.df,a == input$a)$b))
})
my.plot <- reactive({function(){plotFunc(a = input$a,b == input$b)}})
output$plot <- renderPlot({
my.plot()
})
output$save <- downloadHandler(
filename = function() {
paste0(input$a,"_",input$b,".png")
},
content = function(file) {
ggsave(my.plot(),filename=file)
}
)
}
ui <- fluidPage(
# App title ----
titlePanel("Feature Plots"),
# Sidebar layout with a input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
# select name
selectInput("a", "A", choices = unique(vals.df$a)),
uiOutput("b"),
downloadButton('save', 'Save to File')
),
# Main panel for displaying outputs ----
mainPanel(
# The plot is called feature.plot and will be created in ShinyServer part
plotOutput("plot")
)
)
)
When I run shinyApp(ui = ui, server = server) and select a and b values from their lists a figure is not displayed to the screen and when I click the Save to File button I get this error:
ERROR: no applicable method for 'grid.draw' applied to an object of class "function"
I tried wrapping the my.plot() calls with grid.draw but I get the same error:
no applicable method for 'grid.draw' applied to an object of class "function"
Any idea?
Note that I can't get it to work even if plotFunc returns the ggplot2 object (i.e., the grid calls are commented out). But solving this for the example above is more general and would also solve it for the ggplot2 more specific case.
You can do like this:
my.plot <- reactive({
if(!is.null(input$a) & !is.null(input$b)){
plotFunc(a = input$a,b = input$b)
}
})
The change i did was to remove the function. I wasnt sure why you need it and i think it caused the error in the download. Moreover, the second input you give over as a logical statement == which will create an error.
Full code would read:
set.seed(1)
vals.df <- data.frame(b=1:6,a=sample(1:2,6,replace=T))
plotFunc <- function(a,b)
{
p <- qplot(a,b)
p2 <- xyplot(1~1)
r <- grid::rectGrob(gp=gpar(fill="grey90"))
t <- grid::textGrob("text")
g <- gridExtra::grid.arrange(t, p, p2, r, ncol=2)
return(g)
}
library(shiny)
library(ggplot2)
library(lattice)
library(SpaDES)
library(devtools)
server <- function(input, output)
{
output$b <- renderUI({
selectInput("b", "B", choices = unique(dplyr::filter(vals.df,a == input$a)$b))
})
my.plot <- reactive({
if(!is.null(input$a) & !is.null(input$b)){
plotFunc(a = input$a,b = input$b)
}
})
output$plot <- renderPlot({
my.plot()
})
output$save <- downloadHandler(
filename = function() {
paste0(input$a,"_",input$b,".png")
},
content = function(file) {
ggsave(my.plot(),filename=file)
}
)
}
ui <- fluidPage(
# App title ----
titlePanel("Feature Plots"),
# Sidebar layout with a input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
# select name
selectInput("a", "A", choices = unique(vals.df$a)),
uiOutput("b"),
downloadButton('save', 'Save to File')
),
# Main panel for displaying outputs ----
mainPanel(
# The plot is called feature.plot and will be created in ShinyServer part
plotOutput("plot")
)
)
)
shinyApp(ui = ui, server = server)
I am trying to create an input form that adds a row to an existing dataframe.
I used the method described here.
The problem I am having is that I have two date input types that are transformed to integer with this code.
Here is some sample data:
x_df <- data.frame(title = character(1), start = character(1), end = character(1))
x$title <- "Test1"
x$start <- as.Date("2017-12-16")
x$end <- as.Date("2017-12-17")
And my code:
library(shiny)
runApp(
list(
ui = fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("Employee", "Choose an employee:",
choices_employee),
dateInput("Date_from", "From:", format = "yyyy/mm/dd"),
dateInput("Datum_until", "Until:", format = "yyyy/mm/dd"),
actionButton("Add", "Add")
)
)
),
server = function(input, output) {
values <- reactiveValues()
values$df <- x_df
addData <- observe({
# your action button condition
if(input$Add > 0) {
# create the new line to be added from your inputs
newLine <- isolate(c(input$Employee, input$Date_from, input$Date_until))
# update your data
# note the unlist of newLine, this prevents a bothersome warning message that the rbind will return regarding rownames because of using isolate.
values$df <- isolate(rbind(as.matrix(values$df), unlist(newLine)))
x_df <<- as.data.frame(values$df)
}
})
}
)
)
I think it's isolate() that is transforming the date into an integer, anyone knows how I can make this work? Any help is greatly appreciated. If my question is not clear enough please let me know and I will try my best to improve it.
Thanks!
The code in the OP's post is not working. So, it is changed to get the output using renderDataTable from DT package. Also, changed the as.matrix and unlist which could change the column type when there are mixed class columns. For e.g.
unlist(as.list(Sys.Date() + 0:5))
#[1] 17537 17538 17539 17540 17541 17542
The corrected code is below
library(DT)
library(shiny)
runApp(
list(
ui = fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("Employee", "Choose an employee:",
choices_employee),
dateInput("Date_from", "From:", format = "yyyy/mm/dd"),
dateInput("Date_until", "Until:", format = "yyyy/mm/dd"),
actionButton("Add", "Add")
),
mainPanel(
dataTableOutput("table")
)
)
),
server = function(input, output) {
values <- reactiveValues()
values$df <- x_df
addData <- observe({
if(input$Add > 0) {
# create the new line to be added from your inputs
newLine <- isolate(data.frame(title = input$Employee, start = as.Date(input$Date_from),
end = as.Date(input$Date_until), stringsAsFactors= FALSE))
values$df <- isolate(rbind(values$df, newLine))
}
})
output$table <- renderDataTable({values$df })
}
)
)
-output
data
x_df <- data.frame(title = character(1), start = character(1), end = character(1))
x_df$title <- "Test1"
x_df$start <- as.Date("2017-12-16")
x_df$end <- as.Date("2017-12-17")
choices_employee = LETTERS[1:5]
How do I create a scrollable list of tables within a tabPanel?
Based on Outputing N tables in shiny, where N depends on the data, I have tried the following
Server.R
userHist <- list(
data.frame(X=1:10,Y=11:20),
data.frame(X=1:10,Y=11:20))
output$groupHistory <- renderUI({
userHistList <- lapply( seq(userHist), function(i){
hist_i <- userHist[[i]]
TabName <- paste0("User", i)
fluidRow( column(10,
h2(TabName),
hr(),
column(3, renderTable(hist_i, rownames=TRUE) )
) )
} )
userHistList
})
ui.R
tabsetPanel(id="tabsetpanel",
tabPanel(h1("Group History"),
style="overflow-y:scroll;",
uiOutput("groupHistory")
)
)
There is a main firefox scrollbar that shows up when the list gets long, but there is a second scrollbar for the table that does not scroll vertically. Ideally I would also eliminate horizontal scrolling.
You need to call the render first to create the output objects and the compose the UI with those objects:
ui <- fluidPage(
tabsetPanel(
id = "tabsetpanel",
tabPanel(
style = "overflow-y:scroll; max-height: 600px",
h1("Group History"),
numericInput("n_users", "Number of Users", value = 5, min = 1, max = 10),
uiOutput("group_history")
)
)
)
server <- shinyServer(function(input, output) {
df_list <- reactive({
n <- input$n_users
# generate some observations
obs_x <- seq(3)
obs_y <- obs_x + n
# generate the df
df_template <- data.frame(x = obs_x, y = obs_y)
# make a list of df and return
lapply(seq(n), function(n) {
df_template
})
})
# use the constructed renders and compose the ui
output$group_history <- renderUI({
table_output_list <- lapply(seq(input$n_users), function(i) {
table_name <- paste0("table", i)
tab_name <- paste("User", i)
fluidRow(
column(
width = 10,
h2(tab_name),
hr(), column(3, tableOutput(table_name))
)
)
})
# Convert the list to a tagList - this is necessary for the list of items
# to display properly.
do.call(tagList, table_output_list)
})
# Call renderTable for each one. Tables are only actually generated when they
# are visible on the web page.
observe({
data <- df_list()
for (i in seq(input$n_users)) {
# Need local so that each item gets its own number. Without it, the value
# of i in the renderPlot() will be the same across all instances, because
# of when the expression is evaluated.
local({
my_i <- i
tab_name <- paste0("table", my_i)
output[[tab_name]] <- renderTable(data[[my_i]], rownames = TRUE)
})
}
})
})
shinyApp(ui, server)
Based off of Winston Chang's work here
I wrapped the list in fluidPage or wellPanel and everything works as I want.
Server.R
userHist <- list(
data.frame(X=1:10,Y=11:20),
data.frame(X=1:10,Y=11:20))
output$groupHistory <- renderUI({
userHistList <- lapply( seq(userHist), function(i){
hist_i <- userHist[[i]]
TabName <- paste0("User", i)
fluidRow( column(10,
h2(TabName),
hr(),
column(3, renderTable(hist_i, rownames=TRUE) )
) )
} )
table_output_list <- fluidPage(userHistList,
style="overflow-y:scroll; max-height: 90vh")
})
UI.R
tabsetPanel(id="tabsetpanel",
tabPanel(h1("Group History"),
style="overflow: visible",
uiOutput("groupHistory")
)
)
I am trying to print dataset values in shiny web app. But I am only able to print data set name using below code. How can I print dataset values?
library(MASS)
library(shinythemes)
library(shiny)
library(ggplot2)
mass.tmp <- data(package = "MASS")[3]
mass.datasets <- as.vector(mass.tmp$results[,3])
ui <- fluidPage(
theme = shinytheme("superhero"),
titlePanel("Linear Regression Modelling"),
sidebarLayout(
sidebarPanel(
selectInput("dsname", "Dataset:",choices = c(mass.datasets))
,
uiOutput("x_axis")
# ,
# textOutput("txt"),
# tableOutput("tab")
),
mainPanel(
tags$br(),
tags$br()
)
)
)
server <- function(input, output) {
num_ds <- function(ds)
{
nums <- sapply(ds,is.numeric)
num_ds <- ds[,nums]
return(num_ds)
}
ds_ext <- reactive({ num_ds(input$dsname) })
output$x_axis <- renderUI({
col_opts <- get(ds_ext())
selectInput("x_axis2", "Independent Variable:", choices = names(col_opts))
})
}
shinyApp(ui = ui, server = server)
Actually I am trying to solve error in above code "Incorrect number of dimensions". I have written function which would return data frame with only numeric variables so that I can analyze. But getting error in line I guess where I am creating object x_axis. pls help.