Updating y-axis Reactively with geom_histogram from ggplot and Shiny R - r

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]]]]
}

Related

R Shiny - Warning: Error in [.data.frame: undefined columns selected when creating two interactive plots

I am creating two interactive plots in R Shiny and while I can get one plot to show up and work, the second plot keeps giving me the "Warning: Error in [.data.frame: undefined columns selected" and will not appear.
I have looked at many solutions online and none so far have been able to help me or fix my issue.
I am having a hard time seeing how my columns are undefined, but I am also relatively new to R Shiny and could be easily overlooking something, so I was hoping someone could help me figure this out.
Here is my code:
library(shiny)
library(dplyr)
library(readr)
library(ggplot2)
library(tidyverse)
age <- c(1, 4, 7,10, 15)
v_m_1 <- c(10, 14, 17, 20, 25)
v_m_2 <- c(9, 13, 16, 19, 24)
sex <- c("F", "M","U", "F", "M")
P_v_rn <- c(0.11, 0.51, 0.61, 0.91, 1)
C_v_rn <- c(11.1, 15.1, 16.1, 19.1, 20.1)
P_v_rk <- c(0.11, 0.51, 0.61, 0.91, 1)
B_v_rk <- c("Low", "Medium", "Medium", "High", "High")
df_test <- data.frame(age, v_m_1, v_m_2, sex, P_v_rn, C_v_rn, P_v_rk, B_v_rk)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Test"),
# Sidebar with a slider input for number of bins
verticalLayout(
sidebarLayout(
sidebarPanel(
selectInput(inputId = "xvar",
label = "Choose X variable", #All variables are numeric
c("Age" = 1),
selected = 1),
selectInput(inputId = "yvar",
label = "Choose bone variable", #All variables are numeric
c("v_m_1" = 2,
"v_m_2" = 3),
selected = 2),
checkboxInput(inputId = "regression",
label = "Fit LOESS - By Sex",
value = FALSE)),
mainPanel(
plotOutput('dataplot1')
)
),
tags$hr(),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "xvar_name",
label = "Choose X variable", #All variables are numeric
c("Age" = 1),
selected = 1),
selectInput(inputId = "yvar_name",
label = "Choose Y variable", #The first variable option is numeric, the rest are factors
c("P_v_rk" = 7,
"B_v_rk" = 8),
selected = 7),
selectInput(inputId = "zvar_name",
label = "Choose Z variable", #All variables are numeric
c("C_v_rn" = 6,
"P_v_rn" = 5),
selected = 6)),
# Show a plot of the generated distribution
mainPanel(
plotOutput('dataplot2')
)
),
tags$hr(),
))
# Define server logic required to draw a scatterplot
server <- function(input, output) {
df <- df_test %>%
select(age, v_m_1, v_m_2, sex, P_v_rn, C_v_rn, P_v_rk, B_v_rk)
df$B_v_rk <- as.factor(df$B_v_rk)
#Growth Curve
output$dataplot1 <- renderPlot({
xvar <- as.numeric(input$xvar)
yvar <- as.numeric(input$yvar)
Sex <- as.factor(df$sex)
p <- ggplot() +
aes(x = df[ ,xvar],
y = df[ ,yvar],
col = sex) +
geom_point(alpha = 0.5, aes(size = 1.5)) + # 50% transparent
labs(x = names(df[xvar]),
y = names(df[yvar])) +
theme_classic()
if(input$regression) {
# add a line to the plot
p <- p + geom_smooth()
}
p # The plot ('p') is the "return value" of the renderPlot function
})
#Environmental metrics
output$dataplot2 <- renderPlot({
xvar_name <- input$xvar_name
yvar_name <- input$yvar_name
zvar_name <- input$zvar_name
#Color palette for ggplots as blue color range was difficult for me
fun_color_range <- colorRampPalette(c("yellow", "red"))
my_colors <- fun_color_range(20)
p2 <- ggplot() +
aes(x = df[ ,xvar_name],
y = df[ ,yvar_name],
col = df[ ,zvar_name]) +
geom_point(alpha = 0.5, aes(size = 1.5)) + # 50% transparent
scale_colour_gradientn(colors = my_colors) +
labs(x = names(df[xvar_name]),
y = names(df[yvar_name])) +
theme_classic()
p2 # The plot ('p2') is the "return value" of the renderPlot function
})
}
# Run the application
shinyApp(ui = ui, server = server)
Again the first plot works fine, it is the second plot that is producing an error code.
I guess I am confused as the code for the first plot works fine but it won't work for the second plot.
For reference, this is the layout I want, except I want another plot in the error code location.
My guess is that the bug is in the line with names(df[xvar_name]). If df is a data frame, this will throw the error you quoted. To subset a data frame with indices or column names you either use double brackets (df[[...]]) or a comma (df[ ..., ... ]). I think you meant names(df[ , xvar_name ]). This error is repeated on the line below as well.
In general, to identify the place where the problem occurs, use browser() in your code.

Using Shiny (RStudio) library on SAP Analytics Cloud

I've developed a perfectly functional app using Shiny package that I would like to run on SAC using its R functionalities; however, and despite Shiny being listed as one of the packages supported by SAC (https://blogs.sap.com/2020/03/18/r-packages-for-sap-analytics-cloud/) my app won't run.
I wish I could give you more details, but the script I run on R and the one I try to run on SAC are one and the same, as well as the mock up data; so it's beyond me why SAP won't let me do it. Am I missing something? Has anyone tried Shiny on SAC before without major issues?
Thanks in advance!
Edit: Here is my code, without needing any input data.
library(ggplot2)
ui <- fluidPage(
titlePanel("Bass Diffusion Model Visualisation"),
sidebarLayout(
sidebarPanel(
h2("Baseline model (blue)"),
sliderInput(
"innovation_base",
"Innovation effect:",
min = 0,
max = 1,
value = 0.03
),
sliderInput(
"imitation_base",
"Imitation effect:",
min = 0,
max = 1,
value = 0.38
),
h2("Challenger model (red)"),
sliderInput(
"innovation",
"Innovation effect:",
min = 0,
max = 1,
value = 0.02
),
sliderInput(
"imitation",
"Imitation effect:",
min = 0,
max = 1,
value = 0.42
)
),
mainPanel(
h2("Rate of adoption"),
plotOutput("adoptionPlot"),
h2("Cumulative adoption"),
plotOutput("cumAdoptionPlot"))
))
server <- function(input, output) {
output$adoptionPlot <- renderPlot({
bass_base <-
difcurve(
n = 20,
w = c(input$innovation_base, input$imitation_base, 100),
type = "bass"
)
bass_challenger <-
difcurve(
n = 20,
w = c(input$innovation, input$imitation, 100),
type = "bass"
)
plot_adoption <- ggplot(as.data.frame(bass_base)) +
aes(y = Adoption, x = 1:nrow(bass_base)) +
geom_line(colour = "blue") +
geom_line(data = as.data.frame(bass_challenger), colour = 'red') +
labs(x = "years")
plot_adoption
})
output$cumAdoptionPlot <- renderPlot({
bass_base <-
difcurve(
n = 20,
w = c(input$innovation_base, input$imitation_base, 100),
type = "bass"
)
bass_challenger <-
difcurve(
n = 20,
w = c(input$innovation, input$imitation, 100),
type = "bass"
)
plot_cumAdoption <- ggplot(as.data.frame(bass_base)) +
aes(y = `Cumulative Adoption`, x = 1:nrow(bass_base)) +
geom_line(colour = "blue") +
geom_line(data = as.data.frame(bass_challenger), colour = 'red') +
labs(x = "years")
plot_cumAdoption
})
}
shinyApp(ui = ui, server = server)
The error I get is: 502 Bad Gateway: Registered endpoint failed to handle the request.

Shiny combining inputs

I have a data set with three laps (15s/lap) each of which shows the different speed for every second:
AA <- as.data.frame(cbind(c(10,12,11,12,12,11,12,13,11,9,9,12,11,10,12,9,8,7,9,8,7,9,9,8,9,7,9,10,10,10,7,6,7,8,8,7,6,6,7,8,7,6,7,8,8),
c(rep("Lap_1",15),rep("Lap_2",15),rep("Lap_3",15))))
I want to compare the three laps together, but for the first one I'd like to use a sliderInput to select only some of the 15 secondes. I'm having some difficulties to add that to my code. Here is what I have for the moment:
install.packages("shiny")
install.packages("ggplot2")
library(shiny)
library(ggplot2)
colnames(AA) <- c("Speed","Lap")
AA$Speed <- as.numeric(as.character(AA$Speed))
ui=shinyUI(
fluidPage(
titlePanel("Title here"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("lap_choose",
label = "Choose the laps",
choices = c("Lap_1","Lap_2","Lap_3")),
sliderInput("secs_1",
"Seconds in L1:",
min = 0,
max = 15,
value = c(3,10),
step=1)),
mainPanel(
plotOutput("Comparison"))
)
)
)
server=function(input,output){
#data manipulation
data_1=reactive({
return(AA[AA$Lap%in%input$lap_choose,])
})
output$Comparison <- renderPlot({
ggplot(data=data_1(), aes(Speed, fill = Lap)) +
stat_density(aes(y = ..density..),
position = "identity",
color = "black",
alpha = 0.8) +
xlab("Distribution") +
ylab("Density") +
ggtitle("Comparison") +
theme(plot.title = element_text(hjust = 0.5,size=24, face="bold"))
})
}
shinyApp(ui,server)
I should use the secs_1 at some point to update data_1, but didn't find out how yet. Any ideas?
If i am understanding correctly, you want to filter out some values(based on sec_1 sliderInput) if "lap" variable is "lap_1".
Try using ifelse statement in data_1 function.
data_1=reactive({
xc <- AA[AA$Lap%in%input$lap_choose,]
gh <- ifelse(xc$Lap == "Lap_1" & xc$Speed %in% c(input$secs_1[1],input$secs_1[2]),
FALSE, TRUE)
return(xc[gh,])
})

How can I add point with geom_point according to equilibrium point?

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 })})

Shiny - object from reactive expression not found when used in loglm

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))
})
}

Resources