Shiny Error: object 'data_survival_curve' not found - r

I can not figure out what is wrong with the following code. After running runApp('script.R'), I am getting the following error Error: object 'data_survival_curve' not found. I run debug in RStudio and on line nr 60 this variable is created and it exists till the moment when error comes.
script.R file:
library(shiny)
library(survival)
library(survminer)
library(directlabels)
data <- read.csv('dataset.csv', header = TRUE, sep = ",", fileEncoding="UTF-8")
unique_transplant_years_decreasing <- as.numeric(sort(unique(c(data$transplant_year)), decreasing = TRUE))
krivkaPreziti <- sidebarLayout(
# all inputs for graph survival analysis (krivka preziti)
sidebarPanel(
sliderInput("krivka_preziti_input_years", 'Years:',
min = unique_transplant_years_decreasing[length(unique_transplant_years_decreasing)],
max = unique_transplant_years_decreasing[1],
value = c(unique_transplant_years_decreasing[length(unique_transplant_years_decreasing)],
unique_transplant_years_decreasing[1]),
step = 1),
numericInput('krivka_preziti_input_seskupit_po', 'Group by (years):',
value = 0,
min = 0),
checkboxInput('krivka_preziti_input_facet', 'Facet', value = FALSE),
width = 3
),
# Create a spot for bar plot
mainPanel(
h2('Survival curve'),
br(),
plotOutput('krivka_preziti', height = "750px"),
width = 12
)
)
panelAnalyzaPreziti <- tabPanel(
'Survival analysis',
krivkaPreziti
)
ui <- navbarPage(
title = "Application",
panelAnalyzaPreziti
)
server <- shinyServer(
function(input, output, session)
{
output$krivka_preziti <- renderPlot(
{
krivka_year_bottom <- input$krivka_preziti_input_years[1]
krivka_year_top <- input$krivka_preziti_input_years[2]
krivka_seskupit_po <- input$krivka_preziti_input_seskupit_po
# data which fit the range of selected years
# data which meet the condition that survival_time is not NA
data_survival_curve <- data[data$transplant_year %in% seq(krivka_year_bottom, krivka_year_top) &
!is.na(data$survival_time) &
data$survival_time >= 0,]
# if seskupit_po != 0, then cut
if(krivka_seskupit_po != 0) {
data_survival_curve$time_period <- cut(as.numeric(data_survival_curve$transplant_year),
seq(krivka_year_bottom, krivka_year_top, krivka_seskupit_po),
include.lowest = T)
data_survival_curve <- data_survival_curve[!is.na(data_survival_curve$time_period),]
data_survival_curve$time_period <- as.factor(data_survival_curve$time_period)
}
else {
data_survival_curve$time_period = data_survival_curve$transplant_year
}
# validate number of rows of data set > 0
shiny::validate(
need(nrow(data_survival_curve) > 0, 'Broader your input')
)
surv_obj <- Surv(data_survival_curve$survival_time/365,data_survival_curve$patient_died)
fit <- survfit(surv_obj ~ time_period, data = data_survival_curve)
krivka_preziti_plt <- ggsurvplot(fit,
linetype = c('solid'),
ggtheme = theme_bw(),
surv.scale = 'percent',
xlab = 'Years',
ylab = '%',
censor = FALSE,
break.x.by = 1,
break.y.by = 0.1)
plot2 <- krivka_preziti_plt + geom_dl(aes(label = time_period), method = list("last.points"), cex = 0.8)
plot2
}
)
}
)
shinyApp(
ui = ui,
server = server
)
Here is the data set that I am using: enter link description here

I've been struggling with the same issue since almost 1 hour and finally found the solution !
There have been a change in the "ggsurvplot" function and you now need to specify the dataset used in the "fit" element. So in your code you have to add :
krivka_preziti_plt <- ggsurvplot(fit, data = data_survival_curve,
linetype = c('solid'),
ggtheme = theme_bw(),
surv.scale = 'percent',
xlab = 'Years',
ylab = '%',
censor = FALSE,
break.x.by = 1,
break.y.by = 0.1)
Source : Github Issue, 13th of January 2018

Related

Does aes_string() change any default settings in R? A problem with R Shiny and ggplot input$ interaction

I'm creating a Shiny app in Rstudio and I had trouble inserting an input$char into a ggplot boxplot, where input$char was the variable for y-axis, and the x-axis was not an input variable, but instead from the data frame. The issue was that the data wouldn't appear in the graph, but the input function of the dropdown menu still changed the y-axis in the graph when the app was loaded.
Example code:
g = reactive({ggplot(data=iris, aes(x=Species, y=input$ybox))+ theme(legend.position = "top")})
output$Boxplot = renderPlot(g() + geom_boxplot(aes(fill=Species)) + scale_fill_brewer(palette
= "Set2"))
I found through another post on here that aes_string() could fix the problem, and it did. Where aes is in ggplot, I fixed the error with aes_string() and let x="Species" in the function....
except now all of my other variables are not recognized in the rest of my shiny app! Where ever there is Species or another input$char variable, they are not recognized and I receive an error. Either object 'Species' not found, or unused arguments 'input$char;,...,'Species'.
Example code that gives error:
selection = reactive({iris[, aes(c(input$xcol, input$ycol, 'Species'))]})
fit = reactive({knn3(Species ~ ., data=selection(), k = input$K)})
output$KNNplot = renderPlot({decisionplot(fit(), selection(), class=Species,main=paste('Decision Boundary for KNN (',input$K,')', sep=' '))})
Is there any way I can have both a solution to the ggplot error and for the rest of my app to still work?
Edit (Reproducible code):
library(shiny)
library(shinyWidgets)
library(lattice)
library(ggplot2)
library(RColorBrewer)
library(nnet)
library(naivebayes)
library(e1071)
library(randomForest)
library(MASS)
# function for decisionplot.R
decisionplot <- function(model, data, class = NULL, predict_type = "class",
resolution = 100, showgrid = TRUE, ...) {
if(!is.null(class)) cl <- data[,class] else cl <- 1
data <- data[,1:2]
k <- length(unique(cl))
plot(data, col = as.integer(cl)+1L, pch = as.integer(cl)+1L, ...)
# make grid
r <- sapply(data, range, na.rm = TRUE)
xs <- seq(r[1,1], r[2,1], length.out = resolution)
ys <- seq(r[1,2], r[2,2], length.out = resolution)
g <- cbind(rep(xs, each=resolution), rep(ys, time = resolution))
colnames(g) <- colnames(r)
g <- as.data.frame(g)
### guess how to get class labels from predict
### (unfortunately not very consistent between models)
p <- predict(model, g, type = predict_type)
if(is.list(p)) p <- p$class
p <- as.factor(p)
if(showgrid) points(g, col = as.integer(p)+1L, pch = ".")
z <- matrix(as.integer(p), nrow = resolution, byrow = TRUE)
contour(xs, ys, z, add = TRUE, drawlabels = FALSE,
lwd = 2, levels = (1:(k-1))+.5)
invisible(z)
}
ui = fluidPage(
navlistPanel(
tabPanel("Descriptive Statistics",
fluidRow(
column(6,
wellPanel(selectInput('ybox', 'Y Variable', names(iris)[1:4], selected = names(iris)[[2]])),
plotOutput('Boxplot'))),
fluidRow(
column(12,
wellPanel(selectInput('xdens', 'X Variable', names(iris)[1:4], selected= names(iris)[2])),
plotOutput("Densplot")))),
tabPanel("Naive Bayes Classifier",
wellPanel(selectInput('xcol5', 'X Variable', names(iris)[1:4], selected = names(iris)[[1]]),
selectInput('ycol5', 'Y Variable', names(iris)[1:4], selected = names(iris)[[2]])),
plotOutput('NBplot'))
))
server = function(input, output) {
# Boxplot
g = reactive({ggplot(data=iris, aes_(x='Species', y=iris[[as.name(input$ybox)]]))+ theme(legend.position = "top")})
output$Boxplot = renderPlot(g() + geom_boxplot(aes(fill=Species)) + scale_fill_brewer(palette = "Set2") + ylab(input$ybox))
# Densityplot
c = reactive({ggplot(iris, aes_(iris[[as.name(input$xdens)]]))})
mu = reactive({ddply(iris, "Species", summarise, grp.mean=mean(c()))})
dc = reactive({c() + geom_density(kernel="gaussian", aes(color=Species, fill=Species), alpha=0.4) +
geom_vline(data=mu(), aes(xintercept=mu()$grp.mean, color=Species),linetype="dashed") +
theme(legend.position = "top") + xlab(input$xdens)})
output$Densplot = renderPlot({dc() + scale_color_brewer(palette="Dark2") + scale_fill_brewer(palette = "Dark2")})
#example model
selection5 = reactive({iris[, c(input$xcol5, input$ycol5, 'Species')]})
fit5 = reactive({naive_bayes(Species ~ ., data=selection5(), usekernel = T)})
output$NBplot = renderPlot({decisionplot(fit5(), selection5(), class = "Species",
main = "Decision Boundary for Naive Bayes Classifier")})
}
shinyApp(ui = ui, server = server)
Your selection5 was an issue. The following code gives a reactive data frame.
#example model
selection5 <- reactive({
# df <- iris[, c(input$xcol5, input$ycol5, 'Species')] ## this call does not work
df <- data.frame(x=iris[[input$xcol5]], y=iris[[input$ycol5]], Species=iris[, "Species"])
})

Shiny save as pdf or plot

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.

How can I use for loop inside shiny server?

This is my very first question here, can anybody help me to solve this problem? I will really appreciate that!
I am trying to create a vector based on existing vectors. But the for loop inside shiny server didn't work for me. I have tried many ways but still cannot make it.
ui <- (
tabPanel(
"Momentum Analysis",
sidebarPanel(
width = 4,
textInput("ticker2", "Stock ticker:"),
dateRangeInput(
"date2",
"Date Range:",
max = Sys.Date(),
end = Sys.Date(),
startview = "year"
),
numericInput(
"alpha",
"Volatility smoothing parameter:",
min = 0,
max = 1,
value = 0.05
),
numericInput(
"beta",
"Momentum smoothing parameter:",
min = 0,
max = 1,
value = 0.05
),
radioButtons("type2",
"Chart Type:",
c(
"Momentum vs. Volatility" = "mvv",
"Signal to Noise Ratio" = "snr"
)),
actionButton(
"plot2",
"Plot",
icon("line-chart"),
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
),
div(
style = "display: inline-block;
vertical-align: top",
downloadButton("download2", "Download historical stock price data")
)
),
mainPanel(plotOutput("chart2"))
)
)
)
server <- function(input, output){
stock2 <-
reactive(
getSymbols(
toupper(input$ticker2),
from = as.Date(input$date2[1]) - 150,
to = input$date2[2],
src = "google",
auto.assign = F
)
)
stock3 <- reactive(as.data.table(stock2()))
stock <- reactive(as.data.frame(stock3()))
stock.return <- reactive(diff(log(stock()[, 5])))
stock.mu <- reactive(mean(stock.return()))
stock.var <- reactive((stock.return() - stock.mu()) ^ 2)
stock.var.smoothed <- reactive(rep(0, length(stock.return())))
stock.var.smoothed <- reactive({
for (i in 2:length(stock.var())) {
stock.var.smoothed[1] <- stock.var()[1]
stock.var.smoothed[i] <-
(1 - input$alpha) * stock.var.smoothed()[i - 1] + input$alpha * stock.var()[i]
}
})
stock.std.smoothed <- reactive(sqrt(stock.var.smoothed()))
stock.std.smoothed.annually <- reactive(stock.var.smoothed() * sqrt(252))
stock.momentum <- reactive(stock.return())
stock.momentum.smoothed <- reactive(rep(0, length(stock.return())))
stock.momentum.smoothed <- reactive({
for (i in 2:length(stock.return())) {
stock.momentum.smoothed[1] <- stock.momentum()[1]
stock.momentum.smoothed[i] <-
(1 - input$beta) * stock.momentum.smoothed()[i - 1] + input$beta * stock.return()[i]
}
})
stock.momentum.smoothed.annually <-
reactive(stock.momentum.smoothed() * 252 / 100)
stock.SNR <-
reactive(stock.momentum.smoothed.annually() / stock.std.smoothed.annually())
output$chart2 <- renderPlot({
req(input$plot2)
if (input$type2 == "mvv"){
plot(
stock.momentum.smoothed(),
main = "Momentum v.s. Volatility",
col = "red",
type = "l",
xaxt = "n",
ylab = "Momentum v.s. Volatility",
xlab = "Date",
ylim = c(-2, 2)
)
lines(stock.std.smoothed())
axis(1, at = 1:length(stock()[, 1]), labels = stock()[, 1])
}
else if (input$type2 == "snr"){
plot(
stock.SNR(),
main = "Signal to Noise",
type = "l",
col = "red",
ylim = c(-1, 1),
xaxt = "n",
ylab = "Signal to Noise Ratio",
xlab = "Date"
)
abline(h = 0.5)
axis(1, at = 1:length(stock()[, 1]), labels = stock()[, 1])
}
})
output$download2 <- downloadHandler(
filename = function() {
paste(toupper(input$ticker2),
" ",
input$date2[1],
" ",
input$date2[2],
".xlsx",
sep = "")
},
content = function(file) {
write.xlsx2(stock2()[paste0(input$date2, "/"),], file)
}
)
}
I am trying to plot the stock's momentum vs volatility, both are smoothed. My app has some other tabs but they are irrelevant so I just hided the code.
The only problem here is the loop and the reactive function. Thank you!
Please refer to Konrad Rudolph's answer
For loop inside reactive function in Shiny
I was trying to assign a vector with a function (reactive). But I didn't give any return to that function and so that I cannot call this function.

Updating y-axis Reactively with geom_histogram from ggplot and Shiny 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]]]]
}

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