Related
I am new to shiny (and just joined the Stack Overflow, so apologies if I'm not following all etiquette rules yet :) ), and although I have managed to get my code working, there is something that I just cannot get my head around. Below is a code that solves a system of two differential equations, with coefficients being selected using Shiny sliders, and in the main panel I am trying to select which of the two variables to plot. The problem is that since selection of the plotting variable is part of the "input", if I change a variable that I want to plot, this results in the recalculation of the whole thing. I have attached a short code illustrating this problem on the example of a small system, but in reality I have a really large system of ODEs that takes quite a lot of time to solve, so I really need to make sure that if the sliders with parameters are not changed, the system is only solved once, and I can then separately plot each of the variables without a time-consuming recalculation of the whole thing.
I have had a look at "reactive" as an option, but can't see how to make it work for this. Could you please have a look at the short code below and let me know if that's possible, and more specifically, how to make it plot either U or V but without solving the system again.
Thanks a lot in advance!
library(deSolve)
library(shiny)
library(shinyWidgets)
library(plotly)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(
column(width=6,
sliderInput("a", "Coef 1",0, 5, 1, step=0.2),
sliderInput("b", "Coef 2", 0, 5, 1, step=0.2)
)
)
),
mainPanel(
selectInput("Var",
label = "Choose variable to plot:",
choices = c("First"="U", "Second"="V"),
selected = c("U")
),
plotlyOutput("plot0")
)
)
)
LV=function(t,y,p){ # define Lotka-Volterra system
with(as.list(p),{
z=rep(0,2)
z[1]=y[1]-a*y[1]*y[2]
z[2]=b*y[1]*y[2]-y[2]
return(list(z))
})
}
Run_LV=function(p){ # run the simmulation
t = seq(from=0, to=10, by=0.1)
y0=c(1.5,0.7) # initial condition
para=c(list("a"=p$a,"b"=p$b)) # values of parameters
out = ode(y=y0, times=t, func=LV, parms=para ,method="ode45")
return(list("out"=out))
}
server <- function(input, output) {
output$plot0=renderPlot({
sim=Run_LV(input)
sol=sim$out
xvar=sol[,1] # time
if(input$Var=="U"){
yvar=sol[,2] # will plot U component
}else{
yvar=sol[,3] # will plot V component
}
data<- data.frame(xvar,yvar)
p=plot_ly(data,x=~xvar, y=~yvar, type = 'scatter', mode = 'lines')
p
})
}
shinyApp(ui = ui, server = server)
Here one of my Lotka-Volterra teaching apps implemented as Markdown document. I hope that it can serve as an example:
---
title: "Resource Dependent Lotka Volterra Model"
output: html_document
runtime: shiny
---
```{r, echo=FALSE}
suppressMessages(library(deSolve))
lv <- function (t, x, parms) {
with(as.list(c(x, parms)),{
ds <- s_in - b * s * p + g * k + pulse(t, s_start, s_duration, s_pulse)
dp <- c * s * p - d * k * p
dk <- e * p * k - f * k
list(c(ds, dp, dk))
})
}
#parms <- c(s_in=0, b=0, c=0.1, d=0.1, e=0.1, f=0.1, g=0, s_start=0, s_duration=0, s_pulse=0)
times <- seq(0, 200, by=0.2)
#init <- c(s=1, p=1, k=0.5)
pulse <- function(t, s_start, s_duration, h_pulse) {
if ((s_start <= t) & (t < (s_start + s_duration))) h_pulse else 0
}
```
```{r, echo = FALSE, }
simulate <- reactive({
parms <- c(s_in=input$s_in,
b=input$b, c=input$c, d=input$d, e=input$e, f=input$f, g=input$g,
s_start=input$s_start, s_duration=input$s_duration, s_pulse=input$s_pulse)
init <- c(s=input$S0, p=input$P0, k=input$K0)
ode(init, times, lv, parms, method="adams")
})
```
```{r, echo=FALSE}
renderPlot({
#print(system.time(
res <- simulate()
#))
par(lwd=2)
par(las=1)
par(cex.axis=1.4)
layout(matrix(c(1,2), nrow=1, byrow=TRUE), widths=c(2, 1))
matplot(res[,1], res[,2:4], type="l", xlab="time", col=c("black", "forestgreen", "red"), lwd=3, ylab="state variables")
legend("topright", legend=c("S", "P", "K"), col=c("black", "forestgreen", "red"), lwd=3, lty=1:3, cex=1.4)
plot(res[,3], res[,4], type="l", xlab="P", ylab="K")
})
```
<small>
```{r, echo=FALSE}
inputPanel(flowLayout(
h4("Initial values:"),
numericInput(
"S0", label = "S0: Substrate", value = 1.0, min = 0, max = 2, step = 0.1
),
numericInput(
"P0", label = "P0: Producer", value = 1.0, min = 0, max = 2, step = 0.1
),
numericInput(
"K0", label = "K0: Consumer", value = 0.5, min = 0, max = 2, step = 0.1
)),
flowLayout(
h4("Model parameters:"),
numericInput(
"b", label = "b: substrate utilisation", value = 0.0, min = 0, max = 1, step = 0.01
),
numericInput(
"c", label = "c: producer growth", value = 0.1, min = 0, max = 1, step = 0.1
),
numericInput(
"d", label = "d: predation loss", value = 0.1, min = 0, max = 1, step = 0.1
),
numericInput(
"e", label = "e: consumer growth", value = 0.1, min = 0, max = 1, step = 0.1
),
numericInput(
"f", label = "f: consumer mortality", value = 0.1, min = 0, max = 1, step = 0.1
),
numericInput(
"g", label = "g: substrate recycling", value = 0.0, min = 0, max = 1, step = 0.01
)),
flowLayout(
h4("Substrate import:"),
numericInput(
"s_in", label = "S_in (import baselevel)", value = 0.0, min = 0, max = 1, step = 0.01
),
sliderInput(
"s_pulse", label = "s_pulse (pulse height):", min = 0.0, max = 1.0, value = 0, step = 0.1
),
sliderInput(
"s_start", label = "s_start (time of pulse):",min = 0.0, max = max(times), value = 10, step = 1
),
sliderInput(
"s_duration", label = "s_duration (duration):", min = 0.0, max = 5, value = 1, step = 0.1
)
), textsize="50%")
```
</small>
### 3D State diagram
```{r, echo=FALSE}
library(scatterplot3d)
renderPlot({
res <- simulate()
scatterplot3d(res[,2], res[,3], res[,4], type="l", xlab="S", ylab="P", zlab="K", color="red", lwd=2)
}, width=600, height=400)
```
Here is my code I have 3 different questions, I searched evrywhere and tryied sooo many things, but it always gave me an error .
First how can I add a function to save my rglwidgetoutput to any file ?
And also mby save the log .
Secound: If I open the program it always opens a small "focus" window, can I somehow remove that ?
And last but not least, I have a Log , and I want to rename the data_planes so the logfile looks better :)
#######################################################################################
# Install librarys #
#######################################################################################
#install.packages("shiny")
#install.packages("rgl")
#install.packages("shinythemes")
#install.packages("devtools")
library(shiny)
library(rgl)
library(shinythemes)
library(devtools)
#install_github("rgl", "trestletech", "js-class")
#install_github("rgl", "trestletech", "js-class")
#######################################################################################
# User Interface #
#######################################################################################
ui <- fluidPage(theme = shinytheme("slate"),
headerPanel("Block Theory"),
sidebarPanel(
numericInput(inputId = "dd", label = "Dip direction:", value = "", width = "80%", min = 0, max = 360),
numericInput(inputId = "fa", label = "Fracture angle:", value = "", width = "80%", min = 0, max = 90),
numericInput(inputId = "position_x", label = "Position:", value = "", width = "40%"),
numericInput(inputId = "position_y", label = "", value = "", width = "40%"),
numericInput(inputId = "position_z", label = "", value = "", width = "40%"),
#selectInput("form", "Form:",
# c("Circle", "Square", "Ellipsoid")),
actionButton(inputId = "add", label = "Add a plane"),
actionButton(inputId = "plotbutton", label = "Update")
),
mainPanel(
tabsetPanel(
tabPanel("Plot", rglwidgetOutput(outputId = "plot")), # Output
tabPanel("Log", verbatimTextOutput(outputId = "log_planes")), # Log File
# OPTIONS :
tabPanel("Preferences",
checkboxInput("axes_lim", "axes min / max"),
conditionalPanel(
condition = "input.axes_lim == true",
splitLayout(
numericInput(inputId = "min_x", label = "x min:", value = "0", width = "90%"),
numericInput(inputId = "max_x", label = "x max:", value = "1000", width = "90%")),
splitLayout(
numericInput(inputId = "min_y", label = "y min:", value = "0", width = "90%"),
numericInput(inputId = "max_y", label = "y max:", value = "1000", width = "90%")),
splitLayout(
numericInput(inputId = "min_z", label = "z min:", value = "0", width = "90%"),
numericInput(inputId = "max_z", label = "z max:", value = "1000", width = "90%"))),
checkboxInput("axes", "Change axes ratio"),
conditionalPanel(
condition = "input.axes == true",
sliderInput("x_axis", "x axis:",min = 0, max = 1, value = 1, step = 0.1),
sliderInput("y_axis", "y axis:",min = 0, max = 1, value = 1, step = 0.1),
sliderInput("z_axis", "z axis:",min = 0, max = 1, value = 1, step = 0.1)),
checkboxInput("theme", "Change shiny theme"),
conditionalPanel(
condition = "input.theme == true",
shinythemes::themeSelector() )
))
) # /Main panel
) # /ui
#######################################################################################
# SERVER #
#######################################################################################
server <- function(input, output) {
data_planes <- data.frame()
makeReactiveBinding("data_planes")
observe({
input$add
isolate({
data_planes <<- rbind(data_planes, data.frame(input$dd, input$fa , input$position_x , input$position_y , input$position_z))
data_planes <<- na.omit(data_planes)
})
})
output$plot <- renderRglwidget({
input$plotbutton
isolate({
####################################################
# Open 3d plot:
x<-sample(input$min_x:input$max_x, 100)
y<-sample(input$min_y:input$max_y, 100)
z<-sample(input$min_z:input$max_z, 100)
plot3d(x, y, z, type = "n",xlim = c(min(x), max(x)), ylim = c(min(y), max(y)), zlim = c(min(z), max(z),expand = 1.03))
aspect3d(input$x_axis , input$y_axis , input$z_axis)
####################################################
i=1;
while (i <= nrow(data_planes)) {
phi <- data_planes[i,1] * pi / 180
theta <- data_planes[i,2] * pi / 180
Px <- data_planes[i,3]
Py <- data_planes[i,4]
Pz <- data_planes[i,5]
n <- c(sin(theta)*sin(phi), sin(theta) * cos(phi), cos(theta))
# n <- c(-sin(theta)*sin(phi), sin(theta) * cos(phi), -cos(theta))
P_n <- cos(phi)*sin(theta)*Px+(sin(phi)*sin(theta))*Py+cos(phi)*Pz # d = -P * n
# planes3d() plots equation: a*x + b*y + c*z + d = 0
a <- -sin(theta)*sin(phi)
b <- sin(theta) * cos(phi)
c <- -cos(theta)
d <- P_n
cols<-rgb(runif(5),runif(5),runif(5)) #random color genarator
i <- i + 1
planes3d(a, b, c , d , col = cols, alpha = 0.6)
}
rglwidget() # opens the plot inside of main panel
})
})
output$log_planes <- renderPrint(data_planes)
}
#######################################################################################
shinyApp(ui = ui, server = server
)
It's not easy to save rgl output to a PDF. You can save it to an html page using code like this:
htmlwidgets::saveWidget(rglwidget(), file = "rgl.html")
This will fail if it can't find Pandoc; you can use
htmlwidgets::saveWidget(rglwidget(), file = "rgl.html", selfcontained = FALSE)
without Pandoc, but it will create both the HTML file and a subdir of supporting files.
The little window you're seeing is probably the rgl output window. If you never want to see that, run
options(rgl.useNULL = TRUE)
before loading the rgl package. This is a good idea on a Shiny app, because they may be running on a server somewhere and you don't want to try to open an rgl window there.
Sorry, I don't really understand your third question.
So I am trying to tackle the following but I may have started down the wrong road.
As these sample sizes increase, I need to update the y-limits so the highest bar in geom_histogram() doesn't go off the top. The especially happens if the st. dev. is set near 0.
This is literally my second day working with Shiny and reactive applications so I feel I've gotten myself into a pickle.
I think I need to save the ggplot() objects and then update their ylimit reactively with the value of the largest bar from the last histogram. Just not sure if I can do that the way this thing is set up now.
(I am realizing I had a similar problem over 2 years ago)
ggplot2 Force y-axis to start at origin and float y-axis upper limit
This is different because it is the height of a histogram that needs to tell the y-axis to increase, not the largest data value. Also, because Shiny.
My server.R function looks like
library(shiny)
library(ggplot2)
library(extrafont)
# Define server logic for random distribution application
function(input, output, session) {
data <- reactive({
set.seed(123)
switch(input$dist,
norm = rnorm(input$n,
sd = input$stDev),
unif = runif(input$n,-4,4),
lnorm = rlnorm(input$n)
)
})
height="100%"
plotType <- function(blah, maxVal, stDev, n, type) {
roundUp <- function(x) 10^ceiling(log10(x)+0.001)
maxX<- roundUp(maxVal)
breakVal<-max(floor(maxX/10),1)
switch(type,
norm = ggplot(as.data.frame(blah), aes(x=blah))+
geom_histogram(binwidth = 0.2,
boundary = 0,
colour = "black") +
scale_y_continuous(limits = c(0, maxX),
breaks = seq(0, maxX, breakVal),
expand = c(0, 0)) +
scale_x_continuous(breaks = seq(-4, 4, 1),
expand = c(0, 0)) +
theme_set(theme_bw(base_size = 40) +
ylab("Frequency")+
xlab("")+
coord_cartesian(xlim=c(-4, 4))+
ggtitle(paste("n = ",n, "St Dev =", stDev," Normal Distribution ", sep = ' ')),
unif = ggplot(as.data.frame(blah), aes(x=blah))+
geom_histogram(binwidth=0.1, boundary =0,colour = "black")+
scale_y_continuous(limits = c(0,roundUp(maxVal*(3/stDev))),
breaks=seq(0,roundUp(maxVal*(3/stDev)), roundUp(maxVal*(3/stDev))/10),
expand = c(0, 0))+
scale_x_continuous(breaks=seq(-4,4,1),expand = c(0, 0))+
theme_set(theme_bw(base_size = 40))+
ylab("Frequency")+xlab("")+
coord_cartesian(xlim=c(-4,4))+
ggtitle(paste("n = ",n, " Uniform Distribution ", sep = ' ')),
lnorm = ggplot(as.data.frame(blah), aes(x=blah))+
geom_histogram(binwidth=0.2, boundary =0,colour = "black")+
scale_y_continuous(limits = c(0,maxX),
breaks=seq(0,maxX, breakVal),
expand = c(0, 0))+
scale_x_continuous(breaks=seq(0,8,1),expand = c(0, 0))+
theme_set(theme_bw(base_size = 40))+
ylab("Frequency")+xlab("")+
coord_cartesian(xlim=c(0,8))+
ggtitle(paste("n = ",n, " Log-Normal Distribution ", sep = ' '))
)
}
observe({
updateSliderInput(session, "n",
step = input$stepSize,
max=input$maxN)
})
plot.dat <- reactiveValues(main=NULL, layer1=NULL)
#plotType(data, maxVal, stDev, n, type)
output$plot <- renderPlot({
plotType(data(),
switch(input$dist,
norm = max((input$n)/7,1),
unif = max((input$n)/50,1),
lnorm =max((input$n)/8,1)
),
input$stDev,
input$n,
input$dist) })
# Generate a summary of the data
output$summary <- renderTable(
as.array(round(summary(data())[c(1,4,6)],5)),
colnames=FALSE
)
output$stDev <- renderTable(
as.array(sd(data())),
colnames=FALSE
)
# Generate an HTML table view of the data
output$table <- renderTable({
data.frame(x=data())
})
}
And my ui.R looks like
library(shiny)
library(shinythemes)
library(DT)
# Define UI for random distribution application
shinyUI(fluidPage(theme = shinytheme("slate"),
# Application title
headerPanel("Michael's Shiny App"),
# Sidebar with controls to select the random distribution type
# and number of observations to generate. Note the use of the
# br() element to introduce extra vertical spacing
sidebarLayout(
sidebarPanel(
tags$head(tags$style("#plot{height:90vh !important;}")),
radioButtons("dist", "Distribution:",
c("Standard Normal" = "norm",
"Uniform" = "unif",
"Log-normal" = "lnorm")),
br(),
numericInput("stepSize", "Step", 1, min = 1, max = NA, step = NA,
width = NULL),
numericInput("maxN", "Max Sample Size", 50, min = NA, max = NA, step = NA,
width = NULL),
br(),
sliderInput("n",
"Number of observations:",
value = 0,
min = 1,
max = 120000,
step = 5000,
animate=animationOptions(interval=1200, loop=T)),
sliderInput("stDev",
"Standard Deviation:",
value = 1,
min = 0,
max = 3,
step = 0.1,
animate=animationOptions(interval=1200, loop=T)),
p("Summary Statistics"),
tabPanel("Summary", tableOutput("summary")),
p("Sample St. Dev."),
tabPanel("Standard Dev", tableOutput("stDev")),
width =2
),
# Show a tabset that includes a plot, summary, and table view
# of the generated distribution
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Plot", plotOutput("plot")),
tabPanel("Table", tableOutput("table"))
))
)))
The whole thing has a lot of redundancy. What I want to do, is once the biggest bar on the histogram gets close to the upper y-limit, I want the ylimit to jump to the next power of 10.
Any suggestions are greatly appreciated.
Update Loosely, the solution that I ended up using is as follows: In the renderPlot() function, you need to save the ggplot object. Then as mentioned below, access the ymax value (still within renderPlot()),
ggplot_build(norm)$layout$panel_ranges[[1]]$y.range[[2]]
and then use that to update the y-axis. I used the following function to make the axis limit "nice".
roundUpNice <- function(x, nice=c(1,2,4,5,6,8,10)) {
10^floor(log10(x)) * nice[[which(x <= 10^floor(log10(x)) * nice)[[1]]]]
}
Then updating the y-axis. (still within renderplot())
ymaxX = roundUpNice(ggplot_build(norm)$layout$panel_ranges[[1]]$y.range[[2]])
norm+scale_y_continuous(limits = c(0, max(ymaxX, 20)),
expand=c(0,0))
First, store the histogram (default axes).
p1 <- ggplot(...) + geom_histogram()
Then, Use ggplot_build(p1) to access the heights of the histogram bars. For example,
set.seed(1)
df <- data.frame(x=rnorm(10000))
library(ggplot2)
p1 <- ggplot(df, aes(x=x)) + geom_histogram()
bar_max <- max(ggplot_build(p1)[['data']][[1]]$ymax) # where 1 is index 1st layer
bar_max # returns 1042
You will need a function to tell you what the next power of 10 is, for example:
nextPowerOfTen <- function(x) as.integer(floor(log10(x) + 1))
# example: nextPowerOfTen(999) # returns 3 (10^3=1000)
You will want to check whether the bar_max is within some margin (based on your preference) of the next power of 10. If an adjustment is triggered, you can simply do p1 + scale_y_continuous(limits=c(0,y_max_new)).
I found the answer hidden in the "scale_y_continuous()" portion of your code. The app was very close, but in some cases, the data maxed out the y-axis, which made it appear like it was running further than the axis limits as you said.
To fix this problem, the expand argument within the scale_y_continuous section needs to be set to "c(0.05, 0)", instead of "c(0, 0)".
First, I've replicated an example of the graph run-off you were describing by setting the sample size to 50 and standard deviation to 0.3 within your app. After running the original code with "expand=c(0, 0)", we can see we get the following graph:
This problem is fixed by changing the argument to "expand=c(0.05, 0)", as shown here:
For copies of the fixed scripts, see below.
Part 1 -- server.R
library(shiny)
library(ggplot2)
library(extrafont)
# Define server logic for random distribution application
function(input, output, session) {
data <- reactive({
set.seed(123)
switch(input$dist,
norm = rnorm(input$n,
sd = input$stDev),
unif = runif(input$n,-4,4),
lnorm = rlnorm(input$n)
)
})
height="100%"
plotType <- function(blah, maxVal, stDev, n, type){
roundUp <- function(x){10^ceiling(log10(x)+0.001)}
maxX<- roundUp(maxVal)
breakVal<-max(floor(maxX/10),1)
switch(type,
norm=ggplot(as.data.frame(blah), aes(x=blah)) +
geom_histogram(binwidth = 0.2,
boundary = 0,
colour = "black") +
scale_y_continuous(limits = c(0, maxX),
breaks = seq(0, maxX, breakVal),
expand = c(0.05, 0)) +
scale_x_continuous(breaks = seq(-4, 4, 1),
expand = c(0, 0)) +
theme_set(theme_bw(base_size = 40)) +
ylab("Frequency") +
xlab("") +
coord_cartesian(xlim=c(-4, 4))+
ggtitle(paste("n = ",n, "St Dev =", stDev,
" Normal Distribution ", sep = ' ')),
unif=ggplot(as.data.frame(blah), aes(x=blah)) +
geom_histogram(binwidth=0.1, boundary=0, colour="black")+
scale_y_continuous(
limits = c(0,roundUp(maxVal*(3/stDev))),
breaks=seq(0,roundUp(maxVal*(3/stDev)),
roundUp(maxVal*(3/stDev))/10),
expand = c(0.05, 0))+
scale_x_continuous(breaks=seq(-4,4,1),expand=c(0, 0)) +
theme_set(theme_bw(base_size = 40))+
ylab("Frequency")+xlab("")+
coord_cartesian(xlim=c(-4,4))+
ggtitle(paste("n = ",n,
" Uniform Distribution ", sep = ' ')),
lnorm=ggplot(as.data.frame(blah), aes(x=blah))+
geom_histogram(binwidth=0.2,boundary=0, colour="black") +
scale_y_continuous(limits=c(o,maxX),
breaks=seq(0,maxX, breakVal),
expand = c(0.05, 0)) +
scale_x_continuous(breaks=seq(0,8,1),
expand = c(0, 0)) +
theme_set(theme_bw(base_size = 40)) +
ylab("Frequency") +
xlab("") +
coord_cartesian(xlim=c(0,8)) +
ggtitle(paste("n = ",n,
" Log-Normal Distribution ",
sep = ' '))
)
}
observe({
updateSliderInput(session, "n",
step = input$stepSize,
max=input$maxN)
})
plot.dat <- reactiveValues(main=NULL, layer1=NULL)
#plotType(data, maxVal, stDev, n, type)
output$plot <- renderPlot({
plotType(data(),
switch(input$dist,
norm = max((input$n)/7,1),
unif = max((input$n)/50,1),
lnorm =max((input$n)/8,1)
),
input$stDev,
input$n,
input$dist) })
# Generate a summary of the data
output$summary <- renderTable(
as.array(round(summary(data())[c(1,4,6)],5)),
colnames=FALSE
)
output$stDev <- renderTable(
as.array(sd(data())),
colnames=FALSE
)
# Generate an HTML table view of the data
output$table <- renderTable({
data.frame(x=data())
})
}
Part 2 -- ui.R
library(shiny)
library(shinythemes)
library(DT)
# Define UI for random distribution application
shinyUI(fluidPage(theme = shinytheme("slate"),
# Application title
headerPanel("Michael's Shiny App"),
# Sidebar with controls to select the random distribution type
# and number of observations to generate. Note the use of the
# br() element to introduce extra vertical spacing
sidebarLayout(
sidebarPanel(
tags$head(tags$style("#plot{height:90vh !important;}")),
radioButtons("dist", "Distribution:",
c("Standard Normal" = "norm",
"Uniform" = "unif",
"Log-normal" = "lnorm")),
br(),
numericInput("stepSize", "Step", 1,
min = 1, max = NA, step = NA, width = NULL),
numericInput("maxN", "Max Sample Size", 50,
min = NA, max = NA, step = NA,width = NULL),
br(),
sliderInput("n", "Number of observations:", value = 0,
min = 1, max = 120000, step = 5000,
animate=animationOptions(interval=1200, loop=T)),
sliderInput("stDev","Standard Deviation:",value = 1,
min = 0,max = 3,step = 0.1,
animate=animationOptions(interval=1200, loop=T)),
p("Summary Statistics"),
tabPanel("Summary", tableOutput("summary")),
p("Sample St. Dev."),
tabPanel("Standard Dev", tableOutput("stDev")),
width =2),
# Show a tabset that includes a plot, summary, and table view
# of the generated distribution
mainPanel(tabsetPanel(type = "tabs",
tabPanel("Plot", plotOutput("plot")),
tabPanel("Table", tableOutput("table"))
))
)))
Update Loosely, the solution that I ended up using is as follows: In the renderPlot() function, you need to save the ggplot object. Then as mentioned below, access the ymax value (still within renderPlot()),
ggplot_build(p1)$layout$panel_ranges[[1]]$y.range[[2]]
and then use that to update the y-axis. I used the following function to make the axis limit "nice".
roundUpNice <- function(x, nice=c(1,2,4,5,6,8,10)) {
if(length(x) != 1) stop("'x' must be of length 1")
10^floor(log10(x)) * nice[[which(x <= 10^floor(log10(x)) * nice)[[1]]]]
}
I tried to apply economic order quantitz which I need to visualize. However, I would like to indicate equilibrium points in economic order quantity where I have overlapped lines. Unfortunately,
eq <- xx[which.min(abs(xx$holdingcost - xx$orderingcost)), ]
this part is not working exaclty. It does not put point at equilibrium point everytime.
Here is the code.
ui.R
library(shiny)
shinyUI(pageWithSidebar(
headerPanel("Economic Order Quantity"),
sidebarPanel(
h3(strong("Parameters",style = "color:black")),
br(),
sliderInput("D", "Annual Demand Quantity (D)",min = 1, max = 1000, step= 10, value = 500),
sliderInput("S", "Ordering Cost (S)",min = 1, max = 1000, step= 1, value = 500),
sliderInput("h", "Holding Cost (i)",min = 0.01, max = 1, step= 0.01, value = 0.3),
sliderInput("C", "Cost per unit (c) ",min = 1, max = 500, step= 1, value = 150)
),
mainPanel(
plotOutput("plotgraph1"))))
server.R
library(shiny)
require(ggplot2)
require(scales)
shinyServer(function(input, output) {
output$plotgraph1<-renderPlot({
Q<-((2*input$D*input$S)/(input$h*input$C))^(1/2)
xdata <- seq(1,Q*(1.7),1)
HCOCdata <- matrix(1,1)
HCdata <- matrix(1,1)
OCdata <- matrix(1,1)
for (i in xdata) {
OC<-(input$D/i)*input$S
HC<-(i/2)*input$h*input$C
HCOC<-OC+HC
HCdata[i]<- HC
OCdata[i]<- OC
HCOCdata[i]<- HCOC
}
HCOCcost <- data.frame(HCOCcost=HCOCdata)
holdingcost <- data.frame(holdingcost=HCdata)
orderingcost <- data.frame(orderingcost=OCdata)
Quantity <- xdata
CostType <- c("HCOCcost","holdingcost","orderingcost")
xx<-cbind(Quantity,HCOCcost,holdingcost,orderingcost)
y <- ggplot(xx, aes(x=Quantity, y=Cost), group = xx , colour=xx ) +
geom_line(size=1,aes(y=HCOCcost, colour = "HCOCcost"), linetype=2) + geom_line(size=1,aes(y=holdingcost, colour = "holdingcost")) + geom_line(size=1,aes(y=orderingcost, colour = "orderingcost"))
eq <- xx[which.min(abs(xx$holdingcost - xx$orderingcost)), ]
y1 <- y + scale_y_continuous(limits=c(0, max(HCOCcost)/10),labels=comma) + geom_point(data = eq, aes(y = holdingcost), size = 4 , color="red")
y1 })})
I created a shiny app, in which I want to display the residual of a log-linear model using a mosaic plot. I need to use the data from a reactive expression and pass it to loglm. It seem pretty strait forward, but when I do that I get the following error : "objet 'mod' introuvable".
I've already figured which line is causing the problem, but I don't know how to fix it. Running the code below as is should work fine.
However, uncomment the line # mod <- loglm( formula = reformulate(f), data = mod ), in server and you should get the same error I get.
Any help would be greatly appreciated.
ui <- fluidPage(
titlePanel("Shiny Viz!"),
fluidRow( class= "R1",
tabsetPanel(type= "pills",
tabPanel("Log-linear model",
fluidRow(
column(3, offset=1,
selectInput("model", label= "Choose model to fit:",
choices= c("(SPT)","(SP,ST,PT)","(ST,PT)","(SP,PT)","(SP,ST)")),
selectInput("type", label= "Visualise the expected or observed values?",
choices = c("observed", "expected")),
sliderInput("n_breaks", label = "Degree Celcius per bin:",
min = .5, max = 5, value = 1, step = .5)),
column(8, plotOutput("loglinear.mosaic", height= "600px") )
))))
)
library(ggplot2)
library(data.table)
library(vcd)
library(vcdExtra)
server <- function(input, output) {
# Create data
DF <- data.table( Temp = runif(5000, 0, 30),
Presence = factor(rbinom(5000, 1, runif(20, 0.1, 0.60))),
Period = factor(as.integer(runif(5000, 1, 9))) )
# Reactive expression
loglinear <- reactive({
DF[ , Temperature.category := cut_interval(Temp, length= input$n_breaks)]
Tab <- xtabs(formula= ~ Period + Temperature.category + Presence,
data = DF)
return(Tab)
})
# mosaic plot
output$loglinear.mosaic <- renderPlot({
mod <- loglinear()
f <- switch(input$model,
"(SPT)"= c("Presence*Period*Temperature.category"),
"(SP,ST,PT)" = c("Presence*Period","Presence*Temperature.category","Period*Temperature.category"),
"(ST,PT)" = c("Presence*Temperature.category","Period*Temperature.category"),
"(SP,PT)" = c("Presence*Period","Period*Temperature.category"),
"(SP,ST)" = c("Presence*Period","Presence*Temperature.category"))
# mod <- loglm( formula = reformulate(f), data = mod )
mosaic(mod,
gp= shading_hcl,
spacing = spacing_highlighting,
type= input$type,
labeling_args= list(offset_varnames = c(right = 1, left=.5),
offset_labels = c(right = .1),
set_varnames = c(Temperature.category="Temperature", Period="Period",
Presence="Status")),
set_labels=list(Presence = c("Ab","Pr")),
margins = c(right = 5, left = 3, bottom = 1, top =3))
})
}
shinyApp(ui = ui, server = server)
I still haven't found what is causing the problem with loglm, but I've figured another way of getting the result I wanted.
I used glm to fit the model instead of loglm, then used mosaic.glm from the vcdExtra package to create the mosaic plot. The code is pretty much the same except that the data as to be a data.frame and the column 'Temperature.category', 'Period' and 'Presence' must be factor to be used with glm.
However, I am still clueless as to why loglm can't find the object 'mod', but glm can? I'd realy want to know the reason. Since my answers doesn't answer that question, I'll accept an other answer if someone has an explanation.
Here's what the code using glm:
ui <- fluidPage(
titlePanel("Shiny Viz!"),
fluidRow( class= "R1",
tabsetPanel(type= "pills",
tabPanel("Log-linear model",
fluidRow(
column(3, offset=1,
selectInput("model", label= "Choose model to fit:",
choices= c("(SPT)","(SP,ST,PT)","(ST,PT)","(SP,PT)","(SP,ST)")),
selectInput("type", label= "Visualise the expected or observed values?",
choices = c("observed", "expected")),
sliderInput("n_breaks", label = "Degree Celcius per bin:",
min = .5, max = 5, value = 1, step = .5)),
column(8, plotOutput("loglinear.mosaic", height= "800px") )
))))
)
library(ggplot2)
library(data.table)
library(vcd)
library(vcdExtra)
server <- function(input, output) {
DF <- data.table( Temp = runif(5000, 0, 30),
Presence = factor(rbinom(5000, 1, runif(20, 0.1, 0.60))),
Period = factor(as.integer(runif(5000, 1, 9)) ) )
# data to data.frame format
loglinear <- reactive({
DF[ , Temperature.category := cut_interval(Temp, length= input$n_breaks)]
# add 'Freq' column
dat <- data.frame(as.table(xtabs(formula= ~ Period + Temperature.category + Presence,
data = DF)), stringsAsFactors = T)
return(dat)
})
# mosaic plot
output$loglinear.mosaic <- renderPlot({
mod <- loglinear()
f <- switch(input$model,
"(SPT)"= c("Presence*Period*Temperature.category"),
"(SP,ST,PT)" = c("Presence*Period","Presence*Temperature.category","Period*Temperature.category"),
"(ST,PT)" = c("Presence*Temperature.category","Period*Temperature.category"),
"(SP,PT)" = c("Presence*Period","Period*Temperature.category"),
"(SP,ST)" = c("Presence*Period","Presence*Temperature.category"))
# fit model using glm
mod.glm <- glm(formula = reformulate(f, response = "Freq"), data= mod, family= poisson)
mosaic.glm(mod.glm,
formula = ~ Temperature.category + Period + Presence,
gp= shading_hcl,
spacing = spacing_highlighting,
type= input$type,
labeling_args= list(rot_labels = c(left = 0, right = 0),
offset_varnames = c(left=1.5, right = 1),
offset_labels = c(left=.5, right = .1),
set_varnames = c(Temperature.category="Temperature", Period="Period",
Presence="Status")),
set_labels=list(Presence = c("Ab","Pr")),
margins = c(right = 5, left = 4, bottom = 1, top =3))
})
}