Related
I am new to Shiny and have been trying to learn in my spare time. I have a dataframe of Fantasy Football statistics that I am trying to plot based on selectinput()'s and sliderbar()'s. I used renderprint() to ensure my inputs and correct when the slider's or selects are changed. I have the sliders and select inputs in a reactive() where I am simply subsetting the data. I am then feeding the reactive function into my ggplot() as the data. When trying to plot these graphs I am getting an "Error: object 'columnName' not found", but for only some columns. Please help me find the source of this issue.
Best, Davis
Here is the code:
######################################################################
#------------------------Load libraries------------------------------#
######################################################################
library(shiny)
library(bslib)
library(shinydashboardPlus)
library(ggplot2)
library(shinyWidgets)
######################################################################
#------------------------Data import and Clean-----------------------#
######################################################################
FantFootDF <- read_excel("~/Desktop/Fantasy/2021 Fantasy Stats.xltx")
FantFootDF <- as.data.frame(FantFootDF)
colnames(FantFootDF) <- paste(FantFootDF[1,])
FantFootDF <- FantFootDF[-1,]
colnames(FantFootDF) <- c("Rk","Player","Team","FantPos","Age",
"G","GS","Cmp","PAtt","PYds","PTD",
"Int","RuAtt","RuYds","RuYA","RuTD",
"Rec","ReYds","ReYA","ReTD","Fmb","FL",
"TTD","2PM","2PP","FantPt","PPR","DKPt",
"FDPt","VBD","PosRank","OvRank")
FantFootDF[!is.na(FantFootDF$FantPos),]
NumColumns <- c("Rk","Age",
"G","GS","Cmp","PAtt","PYds","PTD",
"Int","RuAtt","RuYds","RuYA","RuTD",
"Rec","ReYds","ReYA","ReTD","Fmb","FL",
"TTD","2PM","2PP","FantPt","PPR","DKPt",
"FDPt","VBD","PosRank","OvRank")
FantFootDF[NumColumns] <- lapply(FantFootDF[NumColumns], as.numeric)
FantFootDF[is.na(FantFootDF)] = 0
FinalDF <- FantFootDF
######################################################################
#------------------------User Interface------------------------------#
######################################################################
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Fantasy Football GUI"),
#Sidebar
sidebarLayout(
sidebarPanel(
pickerInput("position",
"Position(s)",
choices = unique(FinalDF$FantPos),
options = list(`actions-box` = TRUE),
multiple = T),
pickerInput("playername",
"Player Name",
choices = unique(FinalDF$Player),
options = list(`actions-box` = TRUE),
multiple = T),
pickerInput("team",
"Team",
choices = unique(FinalDF$Team),
options = list(`actions-box` = TRUE),
multiple = T),
sliderInput("age",
"Age",
min = min(FinalDF$Age),
max = max(FinalDF$Age),
value = c(min(FinalDF$Age), max(FinalDF$Age))),
sliderInput("completions",
"Completions",
min = min(FinalDF$Cmp),
max = max(FinalDF$Cmp),
value = c(min(FinalDF$Cmp), max(FinalDF$Cmp))),
sliderInput("Pattempts",
"Passing Attempts",
min = min(FinalDF$PAtt),
max = max(FinalDF$PAtt),
value = c(min(FinalDF$PAtt), max(FinalDF$PAtt))),
sliderInput("Pyards",
"Passing Yards",
min = min(FinalDF$PYds),
max = max(FinalDF$PYds),
value = c(min(FinalDF$PYds), max(FinalDF$PYds))),
sliderInput("Ptds",
"Passing TD's",
min = min(FinalDF$PTD),
max = max(FinalDF$PTD),
value = c(min(FinalDF$PTD), max(FinalDF$PTD))),
sliderInput("RuAttempts",
"Rushing Attempts",
min = min(FinalDF$RuAtt),
max = max(FinalDF$RuAtt),
value = c(min(FinalDF$RuAtt), max(FinalDF$RuAtt))),
sliderInput("RuYards",
"Rushing Yards",
min = min(FinalDF$RuYds),
max = max(FinalDF$RuYds),
value = c(min(FinalDF$RuYds), max(FinalDF$RuYds))),
sliderInput("RuYperA",
"Yards per Rushing Attempt",
min = min(FinalDF$RuYA),
max = max(FinalDF$RuYA),
value = c(min(FinalDF$RuYA), max(FinalDF$RuYA))),
sliderInput("RuTDs",
"Rushing TD's",
min = min(FinalDF$RuTD),
max = max(FinalDF$RuTD),
value = c(min(FinalDF$RuTD), max(FinalDF$RuTD))),
sliderInput("rec",
"Receptions",
min = min(FinalDF$Rec),
max = max(FinalDF$Rec),
value = c(min(FinalDF$Rec), max(FinalDF$Rec))),
sliderInput("ReYards",
"Receiving Yards",
min = min(FinalDF$ReYds),
max = max(FinalDF$ReYds),
value = c(min(FinalDF$ReYds), max(FinalDF$ReYds))),
sliderInput("ReYperA",
"Yards per Reception",
min = min(FinalDF$ReYA),
max = max(FinalDF$ReYA),
value = c(min(FinalDF$ReYA), max(FinalDF$ReYA))),
sliderInput("ReTDs",
"Receiving TD's",
min = min(FinalDF$ReTD),
max = max(FinalDF$ReTD),
value = c(min(FinalDF$ReTD), max(FinalDF$ReTD))),
sliderInput("fumb",
"Fumbles",
min = min(FinalDF$Fmb),
max = max(FinalDF$Fmb),
value = c(min(FinalDF$Fmb), max(FinalDF$Fmb))),
sliderInput("ppr",
"1 PPR Total Points",
min = min(FinalDF$PPR),
max = max(FinalDF$PPR),
value = c(min(FinalDF$PPR), max(FinalDF$PPR)))
),
#Main Panel
mainPanel(
selectInput("plottype",
"Which Plot",
choices = c("PPR by Player",
"PPR by Team",
"PPR by Age")),
plotOutput("plot1"),
tableOutput("table"),
verbatimTextOutput("minmax")
)
)
)
######################################################################
#--------------------------------Server------------------------------#
######################################################################
server <- function(input, output) {
#Reactive to subset data and reduce size in graps
df <- reactive({
a = subset(FinalDF,
FantPos = input$position,
Player = input$playername,
Team = input$team,
Age >= input$age[1] & Age <= input$age[2],
Cmp >= input$completions[1] & Cmp <= input$completions[2],
PAtt >= input$Pattempts[1] & PAtt <= input$Pattempts[2],
PYds >= input$Pyards[1] & PYds <= input$Pyards[2],
PTD >= input$Ptds[1] & PTD <= input$Ptds[2],
RuYA >= input$RuYperA[1] & RuYA <= input$RuYperA[2],
RuAtt >= input$RuAttempts[1] & RuAtt <= input$RuAttempts[2],
RuYds >= input$RuYards[1] & RuYds <= input$RuYards[2],
RuTD >= input$RuTDs[1] & RuTD <= input$RuTDs[2],
Rec >= input$rec[1] & Rec <= input$rec[2],
ReYds >= input$ReYards[1] & ReYds <= input$ReYards[2],
ReYA >= input$ReYperA[1] & ReYA <= input$ReYperA[2],
ReTD >= input$ReTDs[1] & ReTD <= input$ReTDs[2],
Fmb >= input$fumb[1] & Fmb <= input$fumb[2],
PPR >= input$ppr[1] & PPR <= input$ppr[2]
)
return(a)
})
#Plot
output$plot1 <- renderPlot({
# generate bins based on input$bins from ui.R
if(input$plottype == "PPR by Player"){
ggplot(data = df()) +
geom_point(data = df(),
aes(x = Player,
y = PPR,
color = FantPos)) +
ggtitle("PPR Points") +
xlab("Player") +
ylab("PPR Points")
}
else if(input$plottype == "PPR by Team"){
ggplot(data = df()) +
geom_point(data = df(),
aes(x = Team,
y = PPR,
color = FantPos)) +
ggtitle("PPR Points") +
xlab("Player") +
ylab("PPR Points")
}
else if(input$plottype == "PPR by Age"){
ggplot(data = df()) +
geom_point(data = df(),
aes(x = Age,
y = PPR,
color = FantPos)) +
ggtitle("PPR Points") +
xlab("Player") +
ylab("PPR Points")
}
})
#Checking inputs
output$minmax <- renderText(
paste("age", input$age[1], input$age[2], "\ncompletions =",
input$completions[1],input$completions[2],"\nPattempts =",
input$Pattempts[1],input$Pattempts[2],"\nPyards =",
input$Pyards[1],input$Pyards[2],"\nPtds =",
input$Ptds[1],input$Ptds[2],"\nRuYperA =",
input$RuYperA[1],input$RuYperA[2],"\nRuAttempts =",
input$RuAttempts[1],input$RuAttempts[2],"\nRuYards =",
input$RuYards[1],input$RuYards[2],"\nRuTDs =",
input$RuTDs[1],input$RuTDs[2],"\nrec =",
input$rec[1],input$rec[2],"\nReYards =",
input$ReYards[1],input$ReYards[2],"\nReYperA =",
input$ReYperA[1],input$ReYperA[2],"\nReTDs =",
input$ReTDs[1],input$ReTDs[2],"\nfumb =",
input$fumb[1],input$fumb[2],"\nppr =",
input$ppr[1], input$ppr[2])
)
}
# Run the application
shinyApp(ui = ui, server = server)
My apologies. I will be sure to include a reproducible example next time. I replicated the code by making a smaller DataFrame. The replicated code and it worked, so I had another look at my original data. There was a column that was NA at the end. When renaming the columns I forgot the index at the end. I also changed from subset to filter. Not sure why the last column with no name messed everything up, but the shiny ran how I wanted after those changes.
I am trying to create a barchart which shows percentage change between the bars for each category of performance test (smallpt,compress etc)
Current Graph Example:
Data:
CG2400Host <- data.frame(
smallpt = c(38.934),
compress = c(58.036),
ffte = c(5629.20),
johntheripper = c(8067),
mtdgemm = c(2.043463),
stockfish = c(16746109),
streamCopy = c(83562.0),
streamScale = c(79536.7),
streamTriad = c(82708.4),
streamAdd = c(83041.6),
dbenchOneClient = c(579.090),
dbenchSixClient = c(2814.47),
dbenchTwelveClient = c(4141.33),
dbenchFortyEight = c(4044.82),
dbenchOneHundredTwentyEight = c(851.355),
dbenchTwoHundredFiftyEight = c(870.838)
)
CG2300Host <- data.frame(
smallpt = c(19.712),
compress = c(52.873),
ffte = c(4626.09),
johntheripper = c(8729),
mtdgemm = c(5.494281),
stockfish = c(17610837),
streamCopy = c(79427.8),
streamScale = c(60582.3),
streamTriad = c(69226.6),
streamAdd = c(67805.7),
dbenchOneClient = c(47.8331),
dbenchSixClient = c(67.661),
dbenchTwelveClient = c(82.4374),
dbenchFortyEight = c(109.27),
dbenchOneHundredTwentyEight = c(111.981),
dbenchTwoHundredFiftyEight = c(95.2279)
)
GB1UHost <- data.frame(
smallpt = c(17.530),
compress = c(44.628),
ffte = c(7365.97),
johntheripper = c(11684),
mtdgemm = c(1.161368),
stockfish = c(22878029),
streamCopy = c(44096.4),
streamScale = c(29866.3),
streamTriad = c(31804.6),
streamAdd = c(31796.5),
dbenchOneClient = c(755.644),
dbenchSixClient = c(3333.72),
dbenchTwelveClient = c(4497.29),
dbenchFortyEight = c(3510.50),
dbenchOneHundredTwentyEight = c(2092.10),
dbenchTwoHundredFiftyEight = c(1720.72)
)
DellHost <- data.frame(
smallpt = c(19.081),
compress = c(38.394),
ffte = c(8569.61),
johntheripper = c(13365),
mtdgemm = c(1.791839),
stockfish = c(22134688),
streamCopy = c(133314.5),
streamScale = c(89241.6),
streamTriad = c(94915.5),
streamAdd = c(93186.8),
dbenchOneClient = c(852.674),
dbenchSixClient = c(3369.59),
dbenchTwelveClient = c(4348.31),
dbenchFortyEight = c(1497.37),
dbenchOneHundredTwentyEight = c(1528.85),
dbenchTwoHundredFiftyEight = c(1505.47)
)
Current code:
createHostComparisonBarchart <- function(CG2300DF,CG2400DF,GB1UDF,DellDF){
BarChartNames<-c("Smallpt Barchart","Compressed G-Zip","FFTE","John The Ripper","Mt-dgemm","Stockfish","Stream - Copy",
"Stream - Scale","Stream - Triad","Stream - Add","Dbench 1 Client","Dbench 6 Client","Dbench 12 Client",
"Dbench 48 Client","Dbench 128 Client","Dbench 256 Client")
UnitNames <- c("seconds","seconds","MFLOPS/s","Crypts/s","MFLOPS/s","Nodes/s","MB/s","MB/s","MB/s","MB/s","MB/s","MB/s",
"MB/s","MB/s","MB/s","MB/s")
IndexNames <- c("smallpt","compress","ffte","johntheripper","mtdgemm","stockfish","streamCopy","streamScale","streamTriad",
"streamAdd","dbenchOneClient","dbenchSixClient","dbenchTwelveClient","dbenchFortyEight","dbenchOneHundredTwentyEight",
"dbenchTwoHundredFiftyEight")
for (i in 1:length(BarChartNames)){
values <- data.frame(
serverType <- c("CG2300","CG2400","GB1U","R6525 Dell"),
result <- c(CG2300DF[i],CG2400DF[i],GB1UDF[i],DellDF[i])
)
p<-ggplot(data=values, aes(x=serverType, y=result,fill=serverType)) +
geom_bar(stat="identity")+theme_minimal()+
xlab("Server Type")+
ylab(UnitNames[i])+
ggtitle(BarChartNames[i])
print(p)
}
}
I have a function for calculating the percentage change between the values:
percentageChangeCalc <-function(serverADF,serverBDF){
percentChange <-c()
for (i in 1:length(colnames(serverADF))){
val <- (serverBDF[i] - serverADF[i])/ serverADF[i]
percentChange <- append(percentChange,val)
}
percentChange
}
Since each "bar" in the chart is compared to the one next to it...
percentageChangeCalc(CG2300Host,CG2400Host)
percentageChangeCalc(CG400Host,GB1UHost)
percentageChangeCalc(GB1UHost,DellHost)
would work.
I have tried different iterations of implementing this from using geom_text to geom_label but I seem to keep getting Error: Discrete value supplied to continuous scale. This makes me think it is not possible to carry out this with my current data.
I am aiming for something like:
Any help appreciated.
Maybe this helps:
library(tidyverse)
set.seed(1337)
data <- tibble(year = seq(2014, 2019), value = rpois(6, lambda = 10))
data
#> # A tibble: 6 × 2
#> year value
#> <int> <int>
#> 1 2014 10
#> 2 2015 5
#> 3 2016 8
#> 4 2017 8
#> 5 2018 6
#> 6 2019 12
data %>%
mutate(
diff = dplyr::lead(value) - value,
label_y = value %>% map2_dbl(diff, ~ 1.1 * max(.x, .x + .y))
) %>%
ggplot(aes(year)) +
geom_col(aes(y = value)) +
geom_errorbar(aes(ymin = value, ymax = value + diff), color = "red", width = 0.3) +
geom_label(aes(y = label_y, label = diff), color = "red")
#> Warning: Removed 1 rows containing missing values (geom_label).
Created on 2022-02-22 by the reprex package (v2.0.0)
This is my first shiny app. I would like for the user to be able to update the number of facet columns and the dimensions of downloaded plot. readNWISuv, the function to download data can take a long time if multiple years are queried. Currently, the app downloads the data each time the user wants to change the plot format or plot dimensions. Not sure if I need to use reactiveValues, but I would assume that I want the data to be downloaded and manipulated outside of renderPlot. Thanks!
library(shiny)
library(dataRetrieval)
library(lubridate)
library(tidyverse)
library(plotly)
#flow wrecker
ui <- pageWithSidebar( #fluidPage(
# Application title
titlePanel("Flow Record"),
# Sidebar with a date input
#sidebarLayout
sidebarPanel(
dateRangeInput("daterange", "Date range: (yyyy-mm-dd)",
start = Sys.Date()-10,
min = "1980-10-01"),
textInput("gage", "USGS Gage #", "11532500"),
#actionButton("dload","Download data"),
selectInput("facet_x", "Facet Column #:", 2, choices =1:4),
submitButton("Update View", icon("refresh")),
helpText("When you click the button above, you should see",
"the output below update to reflect the values you",
"entered above:"),
#verbatimTextOutput("value"),
downloadButton('downloadImage', 'Download figure'),
numericInput("fig_x", "Fig. Dim. x:", 10, min = 3, max = 16),
numericInput("fig_y", "Fig. Dim. y:", 10, min = 3, max = 16),
width = 3
),
# Show a plot of the generated WY
mainPanel(
plotlyOutput("WYfacet")
)
)
# Define server draw WY facets
server <- function(input, output) {
parameterCd <- "00060" # discharge
#water year
wtr_yr <- function(dates, start_month=10) {
# Convert dates into POSIXlt
dates.posix = as.POSIXlt(dates)
# Year offset
offset = ifelse(dates.posix$mon >= start_month - 1, 1, 0)
# Water year
adj.year = dates.posix$year + 1900 + offset
# Return the water year
adj.year
}
output$WYfacet <- renderPlotly({
#progress bar
withProgress(readNWISuv(input$gage, parameterCd, input$daterange[1], input$daterange[2],tz="America/Los_Angeles") %>% addWaterYear,
message = 'Download in progress',
detail = 'This may take a while...', value = 1)
#download
temperatureAndFlow <- readNWISuv(input$gage, parameterCd, input$daterange[1], input$daterange[2],tz="America/Los_Angeles") %>% addWaterYear
names(temperatureAndFlow)<-c("agc","site","date","WY", "flow","a","tzone")
temperatureAndFlow$commonDate <- as.Date(format(temperatureAndFlow$date, format="2000-%m-%d"))
tf.df<-temperatureAndFlow %>%
filter(WY<=max(WY) & WY>=if_else(month(min(date))<10,min(WY)+1,min(WY)))
tf.df$date.d<-format(tf.df$date, format="%Y-%m-%d")
#mutate commonDate
df4 <- tf.df %>%
mutate(WY=factor(wtr_yr(date.d))) %>%
#seq along dates starting with the beginning of your water year
mutate(commonDate=as.Date(paste0(ifelse(month(date.d) < 10, "2001", "2000"),
"-", month(date.d), "-", day(date.d))), Date=date.d)
#plot
ploty<-ggplot(data = df4,mapping = aes(x = commonDate, y = flow,label=Date, colour = factor(WY))) +
geom_line() +
labs(x = " ", y = "Discharge (cfs)") +
facet_wrap(facets = ~WY,ncol=as.integer(input$facet_x)) +
scale_y_log_eng()+
annotation_logticks(sides = "l")+
theme_bw()+
theme(panel.grid.minor.x = element_blank())+
scale_x_date(labels = function(x) format(x, "%b"),date_breaks = "1 months")+
guides(colour=FALSE)
ggplotly(ploty, tooltip=c("flow","Date"))
})
#fig dimensions
output$fig_x <- renderText({ input$fig_x })
output$fig_y <- renderText({ input$fig_y })
#facet columns
output$facet_x <- renderText({ input$facet_x })
#download to computer
output$downloadImage <- downloadHandler(
filename = function(){paste("plot",'.png',sep='')},
content = function(file){
ggsave(file,width = input$fig_x,height = input$fig_y, dpi = 600, units = "in", device='png')
print(ggplot(data = df4,mapping = aes(x = commonDate, y = flow, colour = factor(WY))) +
geom_line() +
#geom_point()+
#geom_vline(data = trip,aes(xintercept=commonDate),trip_df,color="black")+
labs(x = " ", y = "Discharge (cfs)") +
facet_wrap(facets = ~WY,ncol=as.integer(input$facet_x)) +
scale_y_log_eng()+
annotation_logticks(sides = "l")+
theme_bw()+
theme(panel.grid.minor.x = element_blank())+
scale_x_date(labels = function(x) format(x, "%b"),date_breaks = "1 months")+
guides(colour=FALSE))
})
}
# Run the application
shinyApp(ui = ui, server = server)
There are a few changes to make to your sever section to make this work. Primarily:
splitting the creation of the dataframe into a new eventReactive function, dependent on an actionButton.
referring to the function inside the renderPlotly call
Try this:
## Within ui function call ############################################
# submitButton("Update View", icon("refresh")), # line to replace
actionButton(inputId = "update", "Update View", icon("refresh")),
## (if you want to keep a button to control when data is downloaded ##
server <- function(input, output) {
parameterCd <- "00060" # discharge
#water year
wtr_yr <- function(dates, start_month=10) {
# Convert dates into POSIXlt
dates.posix = as.POSIXlt(dates)
# Year offset
offset = ifelse(dates.posix$mon >= start_month - 1, 1, 0)
# Water year
adj.year = dates.posix$year + 1900 + offset
# Return the water year
adj.year
}
# New part here - use `reactive` to make df4 a new thing, which is processed separately. The `eventReactive` function waits till it sees the button pressed.
df4 <- eventReactive(input$update, ignoreNULL = FALSE, {
#progress bar
withProgress(readNWISuv(input$gage, parameterCd, input$daterange[1], input$daterange[2],tz="America/Los_Angeles") %>% addWaterYear,
message = 'Download in progress',
detail = 'This may take a while...', value = 1)
#download
temperatureAndFlow <- readNWISuv(input$gage, parameterCd, input$daterange[1], input$daterange[2],tz="America/Los_Angeles") %>% addWaterYear
names(temperatureAndFlow)<-c("agc","site","date","WY", "flow","a","tzone")
temperatureAndFlow$commonDate <- as.Date(format(temperatureAndFlow$date, format="2000-%m-%d"))
tf.df<-temperatureAndFlow %>%
filter(WY<=max(WY) & WY>=if_else(month(min(date))<10,min(WY)+1,min(WY)))
tf.df$date.d<-format(tf.df$date, format="%Y-%m-%d")
#mutate commonDate
tf.df %>%
mutate(WY=factor(wtr_yr(date.d))) %>%
#seq along dates starting with the beginning of your water year
mutate(commonDate=as.Date(paste0(ifelse(month(date.d) < 10, "2001", "2000"),
"-", month(date.d), "-", day(date.d))), Date=date.d)
})
output$WYfacet <- renderPlotly({
# req will pause plot loading till new data downloaded above, but changes to display will render without new download
req(df4())
#plot
ploty<-ggplot(data = df4(), # Put brackets here to refer to df4 as a reactive input!!!
mapping = aes(x = commonDate, y = flow, label=Date, colour = factor(WY))) +
geom_line() +
labs(x = " ", y = "Discharge (cfs)") +
facet_wrap(facets = ~WY,ncol=as.integer(input$facet_x)) +
scale_y_log10()+
# annotation_logticks(sides = "l")+
theme_bw()+
theme(panel.grid.minor.x = element_blank())+
scale_x_date(labels = function(x) format(x, "%b"),date_breaks = "1 months")+
guides(colour=FALSE)
ggplotly(ploty, tooltip=c("flow","Date"))
})
#fig dimensions
output$fig_x <- renderText({ input$fig_x })
output$fig_y <- renderText({ input$fig_y })
#facet columns
output$facet_x <- renderText({ input$facet_x })
#download to computer
output$downloadImage <- downloadHandler(
filename = function(){paste("plot",'.png',sep='')},
content = function(file){
ggsave(file,width = input$fig_x,height = input$fig_y, dpi = 600, units = "in", device='png')
print(ggplot(data = df4() ,mapping = aes(x = commonDate, y = flow, colour = factor(WY))) +
geom_line() +
#geom_point()+
#geom_vline(data = trip,aes(xintercept=commonDate),trip_df,color="black")+
labs(x = " ", y = "Discharge (cfs)") +
facet_wrap(facets = ~WY,ncol=as.integer(input$facet_x)) +
scale_y_log10()+
annotation_logticks(sides = "l")+
theme_bw()+
theme(panel.grid.minor.x = element_blank())+
scale_x_date(labels = function(x) format(x, "%b"),date_breaks = "1 months")+
guides(colour=FALSE))
})
}
I need to get the dataframe from a function in rShiny server. But that function returns a Plot and the return value cannot be changed as the plots are used in the future use.
have not pasted the whole code as its like 200 lines each for the function and also for the rshiny server.
Hist_Read_data4 <- full_join(Hist_Read_data1,Hist_Read_data_opst, by = c("timestamp"))%>%
arrange(timestamp)%>%
subset(timestamp >= as.POSIXct(start_timestamp, origin = "1970-01-01") & timestamp <= as.POSIXct(end_timestamp, origin = "1970-01-01"))%>%
mutate(value.y = na.locf(value.y, na.rm = FALSE))%>%
mutate(value.y = fct_explicit_na(value.y, na_level = "None"))%>%
mutate(value.x = na.locf(value.x, na.rm=FALSE))%>%
mutate(new_value = abs(value.x - lag(value.x)))%>%
mutate(new_value = replace_na(new_value, 0))%>%
mutate(new_value = cumsum(new_value))
plot <- ggplot() +
geom_path(data = Hist_Read_data4, mapping = aes(x = timestamp, y=value.x, color = value.y), na.rm = TRUE, linejoin = 'round' , size=1.5, group = 1)
//Hist_Read_data4 is the dataframe which i need to return//
//plot is the return value of the function//
output$HoverText <- renderText({
coordinfo <- input$PlotHover
nearpts <- nearPoints(Hist_Read_data4, coordinfo, xvar= "timestamp", yvar = "value.y", threshold = 20)
})
need Hist_Read_data4 in inside nearpoints. But it cannot be accessed as its inside a function named chooseDevice() in a separate script file named data_funcs.R
I do not want to change the return value of the chooseDevice function from plot to returning this dataframe as it will complicate the whole code and 2 months work will be wasted.
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