Accessing a data frame produced in a different RenderPlot - r

I've written a Shiny app that allows the user to select two points on a raster, resulting in the computation of a route using different parameters.
The visualisation of the route is only one component I want to happen. I also want to be able to create summary statistics of the route and show these in a different plot (so the route is shown on the left, and the statistics on the right).
However, I'm not sure how to make the route accessible within another Plot. What I want to be accessible to the other Plot is the
elevation <- data.frame(extract(dem, AtoB4))
Elevation will then be used to create the summary statistics that will be shown in the right column.
Any thoughts on how to do this is appreciated. Recommendations of a different way to do it completely is also appreciated.
Reproducible example:
ui.R
# Define UI for application that plots features of movies
ui <- fluidPage(
titlePanel("xx"),
# Sidebar layout with a input and output definitions
fluidRow(
# Inputs
column(width = 2,
p("Drag a box on the Elevation plot to generate Least Cost Paths using different number of neighbours"),
p("Least Cost Path generated using",strong("4 neighbours"), style = "color:red"),
p("Least Cost Path generated using",strong("8 neighbours"), style = "color:black"),
p("Least Cost Path generated using",strong("16 neighbours"), style = "color:blue")
),
# Outputs
column(4,
plotOutput(outputId = "mapPlot", brush = "plot_brush")
),
column(6,
plotOutput(outputId = "stats_plots"))
)
)
server.R
library(shiny)
library(raster)
library(gdistance)
library(sp)
library(rgdal)
dem <- raster(system.file("external/maungawhau.grd", package="gdistance"))
# Define server function required to create the scatterplot
conductance_calc <- function(input_dem, neighbours) {
altDiff <- function(x){x[2] - x[1]}
hd <- transition(input_dem, altDiff, neighbours, symm=FALSE)
slope <- geoCorrection(hd)
adj <- adjacent(input_dem, cells=1:ncell(input_dem), pairs=TRUE, directions=16)
speed <- slope
speed[adj] <- 6 * exp(-3.5 * abs(slope[adj] + 0.05))
Conductance <- geoCorrection(speed)
return(Conductance)
}
server <- function(input, output) {
output$mapPlot <- renderPlot( {
plot(dem, axes = FALSE, legend = FALSE)
Conductance <-conductance_calc(dem, 16)
if(is.null(input$plot_brush)) return("NULL\n")
A <- c(as.numeric(unlist(input$plot_brush))[1], as.numeric(unlist(input$plot_brush))[3])
B <- c(as.numeric(unlist(input$plot_brush))[2], as.numeric(unlist(input$plot_brush))[4])
AtoB16 <- shortestPath(Conductance, A, B, output="SpatialLines")
###
Conductance <- conductance_calc(dem, 8)
if(is.null(input$plot_brush)) return("NULL\n")
A <- c(as.numeric(unlist(input$plot_brush))[1], as.numeric(unlist(input$plot_brush))[3])
B <- c(as.numeric(unlist(input$plot_brush))[2], as.numeric(unlist(input$plot_brush))[4])
AtoB8 <- shortestPath(Conductance, A, B, output="SpatialLines")
###
Conductance <-conductance_calc(dem, 4)
if(is.null(input$plot_brush)) return("NULL\n")
A <- c(as.numeric(unlist(input$plot_brush))[1], as.numeric(unlist(input$plot_brush))[3])
B <- c(as.numeric(unlist(input$plot_brush))[2], as.numeric(unlist(input$plot_brush))[4])
AtoB4 <- shortestPath(Conductance, A, B, output="SpatialLines")
####
plot(dem, axes = FALSE, legend = FALSE)
lines(AtoB4, col = "red")
lines(AtoB8, col = "black")
lines(AtoB16, col = "blue")
elevation <<- data.frame(extract(dem, AtoB4))
names(elevation) <- "metres"
})
output$stats_plots <- renderPlot( {
})
}

Related

How can I summarize reactive data from outside a render function in a Shiny app?

For this particular shiny example I am trying to apply a circular model and display and summarize it within the ggplot and a summary table. This is straightforward up until trying to add in reactive 'brushplot' capabilities. Each of the data points represent a date and the point of the selective graph is to be able to discard undesirable dates. As far as I've figured out, this requires the filtering and model fitting to be within a renderPlot which then leads to complications (unable to find the data/model) trying to call the filtered data and the circular model's statistical outputs outside the function and/or within another reactive function. This yields the Error: object 'k_circ.lm' not found So my questions are:
How can I read the filtered data from the renderPlot function
to the summarytable matrix?
How could I similarly add the fitted model values and residuals from k_circ.lm?
Is there a better or simpler way to arrange app to avoid this?
Alternatative code lines are commented out for a working (if poorly formatted) summary table.
library(dplyr) # For data manipulation
library(ggplot2) # For drawing plots
library(shiny) # For running the app
library(plotly) # For data manipulation
library(circular) # For Circular regressions
library(gridExtra)
# Define UI ----
ui <- fluidPage(
# App title ----
titlePanel("Circular Brushplot Demo"),
# Sidebar layout with input and output definitions ----
sidebarLayout(
sidebarPanel(
actionButton("exclude_toggle", "Toggle points"),
actionButton("exclude_reset", "Reset")
),
# Main panel for displaying outputs ----
mainPanel(
#reactive plot output with point and 'brush' selection
fluidRow(plotOutput("k", height = 400,
click = "k_click",
brush = brushOpts(
id = "k_brush" ))),
plotOutput("s", height = 400)
)
)
)
# Define server logic
server <- function(input, output) {
psideg <- c(356,97,211,232,343,292,157,302,335,302,324,85,324,340,157,238,254,146,232,122,329)
thetadeg <- c(119,162,221,259,270,29,97,292,40,313,94,45,47,108,221,270,119,248,270,45,23)
## Data in radians then to "circular format"
psirad <- psideg*2*pi/360
thetarad <- thetadeg*2*pi/360
cpsirad <- circular(psirad)
cthetarad <- circular(thetarad)
cdat <- data.frame(cpsirad, cthetarad)
###### reactive brush plot ########
# For storing which rows have been excluded
vals <- reactiveValues(
keeprows = rep(TRUE, nrow(cdat)))
output$k <- renderPlot({
# Plot the kept and excluded points as two separate data sets
keep <- cdat[ vals$keeprows, , drop = FALSE]
exclude <- cdat[!vals$keeprows, , drop = FALSE]
## Fits circular model specifically for 'keeprows' of selected data
k_circlm <- lm.circular(type = "c-c", y = keep$cthetarad, x = keep$cpsirad, order = 1)
k_circlm
ggplot(keep, aes(cthetarad, cpsirad)) +
geom_point(aes(cthetarad, cpsirad, colour = keep$Vmag, size = 5))+
scale_colour_gradient(low ="blue", high = "red")+
geom_smooth(method = lm, fullrange = TRUE, color = "black") +
geom_point(data = exclude, shape = 13, size = 5, fill = NA, color = "black", alpha = 0.25) +
annotate("text", x = min(keep$cthetarad), y = Inf, hjust = .1, vjust = 1,
label = paste0("p value 1 = ", round(k_circlm$p.values[1], 2)), size = 7)+
annotate("text", x = min(keep$cthetarad), y = Inf, hjust = .1, vjust = 2.5,
label = paste0("p value 2 = ", round(k_circlm$p.values[2], 2)), size = 7)+
annotate("text", x = min(keep$cthetarad), y = Inf, hjust = .1, vjust = 4,
label = paste0("rho = ", round(k_circlm$rho, 2)), size = 7)+
xlab("Lighthouse Direction (radians)")+ ylab("ADCP site direction (radians)")+
theme(axis.title.x = element_text(size = 20), axis.title.y = element_text(size = 20))
})
# Toggle points that are clicked
observeEvent(input$k_click, {
res <- nearPoints(cdat, input$k_click, allRows = TRUE)
vals$keeprows <- xor(vals$keeprows, res$selected_)})
# Toggle points that are brushed, when button is clicked
observeEvent(input$exclude_toggle, {
res <- brushedPoints(cdat, input$k_brush, allRows = TRUE)
vals$keeprows <- xor(vals$keeprows, res$selected_)})
# Reset all points
observeEvent(input$exclude_reset, {
vals$keeprows <- rep(TRUE, nrow(cdat))})
output$s <- renderPlot({
# Create Summary table
summarytable <- data.frame(matrix(ncol = 4, nrow = nrow(keep)))
colnames(summarytable) <- c( "Psi_dir", "Theta_dir", "Fitted_values", "Residuals")
# Un-comment lines below to read from non-reactive data for working summary table
#summarytable$Psi_dir <- round(cdat$cpsirad, 2)
#summarytable$Theta_dir <- round(cdat$cthetarad, 2)
# attempting to pull from circlm within render plot
# comment out for summarytable to work
summarytable$Psi_dir <- round(keep$cpsirad, 2)
summarytable$Theta_dir <- round(keep$cthetarad, 2)
summarytable$Fitted_values <- round(k_circ.lm$fitted)
summarytable$Residuals <- round(k_circ.lm$residuals)
# outputing table with minimal formatting
summarytable <-na.omit(summarytable)
t <- tableGrob(summarytable)
Q <- grid.arrange(t, nrow = 1)
Q
}
)
}
shinyApp(ui = ui, server = server)
Here's a few ideas - but there are multiple approaches to handling this, and you probably want to restructure your server function a bit more after working with this further.
First, you probably want a reactive expression that will update your model based on vals$keeprows as this changes with your clicks. Then, you can access the model results from this expression from both your plot and data table.
Here is an example:
fit_model <- reactive({
## Keep and exclude based on reactive value keeprows
keep = cdat[ vals$keeprows, , drop = FALSE]
exclude = cdat[!vals$keeprows, , drop = FALSE]
## Fits circular model specifically for 'keeprows' of selected data
k_circlm <- lm.circular(type = "c-c", y = keep$cthetarad, x = keep$cpsirad, order = 1)
## Returns list of items including what to keep, exclude, and model
list(k_circlm = k_circlm, keep = keep, exclude = exclude)
})
It will return a list that you can access from the plot:
output$k <- renderPlot({
exclude <- fit_model()[["exclude"]]
keep <- fit_model()[["keep"]]
k_circlm <- fit_model()[["k_circlm"]]
ggplot(keep, aes(cthetarad, cpsirad)) +
...
And can access the same from your table (though you have as renderPlot?):
output$s <- renderPlot({
keep = fit_model()[["keep"]]
k_circ.lm <- fit_model()[["k_circlm"]]
# Create Summary table
summarytable <- data.frame(matrix(ncol = 4, nrow = nrow(keep)))
...
Note that because the table length changes with rows kept, you might want to use nrow(keep) as I have above, rather than nrow(cdat), unless I am mistaken.
I also loaded gridExtra library for testing this.
I suspect there are a number of other improvements you could consider, but thought this might help you get to a functional state first.

Shiny R app to create cumulative distribution

I want to create a simple R shiny app that would let a person choose few things :
a) How many years (trials) we want to test?
b) What we want to test (b.1 - GDP,b.2 - Life Expectancy,b.3 - Happiness)
c) According to the chosen b) variable, I would like to take different probability functions.
For example, if Life expectancy is chosen, p(x)=(80-x)*0.0025+0.02, and then I would like to have a cumulative distribution graph shown. I took code from google, tried updating it but it didn't work so i would appreciate your help..
library(shiny)
# Define UI for application that draws a probability plot
shinyUI(fluidPage(
# Application title
titlePanel("Cumulative Binomial Probability Plot"),
# Sidebar with a slider input for value of lambda
sidebarLayout(
sidebarPanel(
sliderInput("lambda",
"age you want to reach",
min = 75,
max = 100,
value = 1)
),
# Show a plot of the generated probability plot
mainPanel(
plotOutput("ProbPlot")
)
)
))
# SERVER
library(shiny)
library(ggplot2)
library(scales)
# Shiny Application
shinyServer(function(input, output) {
# Reactive expressions
output$ProbPlot <- renderPlot({
# generate lambda based on input$lambda from ui.R
l=0:1
lambda <- seq(min(l), max(l), length.out = input$lambda)
probability=(80-lambda)*0.0025+0.02
# generate trials based on lambda value
powers=0.00025
muCalculation <- function(lambda, powers) {(80-lambda)*powers+0.002}
probability_at_lambda <- sapply(input$lambda, muCalculation, seq(75, 100, 1))
# draw the probability
par(bg = '#191661', fg = '#ffffff', col.main = '#ffffff', col.lab = '#ffffff', col.axis =
'#ffffff')
plot(probability_at_lambda,type="o",col="#b1aef4", xlab="N", ylab="Probability",
xlim=c(75, 100), ylim=c(0.0, 1.0), pch=19)
title(main="Cumulative Binomial Probability")
})
})
It's not clear to me what you want to do. But the R stats package has an empirical cumulative distribution function ecdf which you can plot. See the help ?ecdf to get details on how it works. E.g,
x <- rnorm(1000)
xcdf <- ecdf(x)
plot(xcdf)

Strategies for editing reactive functions in Shiny, 'data' must be of a vector type, was 'NULL' error

Goal: I am trying to create a shiny app that displays (1) the stressplot of a non-metric multidimensional scaling solution, (2) a ggplot of the point configuration, and (3) the results of clustering the point configuration by plotting the point configuration and superimposing chulls of the clustering.
Problem: The first two plots work without difficulty. Instead of a third plot, I get the error: 'data' must be of a vector type, was 'NULL'
I would appreciate any advice on how to resolve the specific problem, i.e. "error in array: 'data' must be of a vector type, was 'NULL'"
I would also appreciate any general advice on how to debug shiny. My only strategy is to treat the code like it isn't reactive code, and I suspect that this strategy isn't terribly effective.
My attempt to solve: I've searched the error on rseek and stack overflow and reviewed the posts. In some of the cases with similar errors the problem was that necessary data wasn't being calculated. I went through the code, treated it as normal (non-reactive) code, and used fake data. When I did this I didn't have any problem, so I assume it is something about the reactivity? Question 2 about how to debug is a reaction to the fact that trying to debug like the code wasn't dynamic didn't identify the problem.
Reproducible Example: I put together a shiny app that has randomly generated data. Before doing the testing I updated R and all the packages I use.
# Packages and options
library(shiny)
library(vegan)
library(cluster)
library(tidyverse)
options(digits = 3)
# Create dissimilarity matrix
d <- rnorm(1000)
mat <- matrix(d, ncol = 10)
diss_m <- daisy(mat) %>% as.matrix()
# Function
find_chulls <- function(df, x, y) {
ch <- chull(df[[x]], df[[y]])
df[ch,] %>% as.data.frame()
}
ui <- fluidPage(
titlePanel("Research"),
sidebarLayout(
sidebarPanel(
numericInput('dim', 'Dimensions', 2, min = 2, max = 15)
),
mainPanel(
h3('Stressplot'),
plotOutput('plot0'),
h3('Non-Metric Multidimensional Scaling'),
plotOutput('plot1'),
h3('2d Density Plot'),
plotOutput('plot2'),
h3('Cluster Analysis'),
plotOutput('plot3')
)
)
)
server <- function(input, output, session) {
nmds <- reactive({
metaMDS(diss_m,
distance = "euclidean",
k = input$dim,
trymax = 200,
autotransform = FALSE,
noshare = FALSE,
wascores = FALSE)
})
output$plot0 <- renderPlot({
stressplot(nmds())
})
pts <- reactive({
nmds()$points %>% as.data.frame()
})
output$plot1 <- renderPlot({
ggplot(pts(), aes(x = MDS1, y = MDS2)) +
geom_point()
})
output$plot2 <- renderPlot({
ggplot(pts(), aes(x = MDS1, y = MDS2)) +
geom_point() +
geom_density2d()
})
df_cl <- reactive({
km <- kmeans(x = pts(), centers = input$clust)
cl <- km$cluster
data.frame(pts(), clust = cl)
})
df_ch <- reactive({
df_ch_temp <- df_cl() %>% group_by(clust) %>% do(find_chulls(., 1, 2))
df_ch_temp %>% as.data.frame()
})
The plot below is the one that doesn't work
output$plot3 <- renderPlot({
ggplot(df_ch(), aes(x = MDS1, y = MDS2, fill = as.factor(clust))) + geom_polygon(alpha = 0.10)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Your input$clust is undefined in:
df_cl <- reactive({
km <- kmeans(x = pts(), centers = input$clust)
cl <- km$cluster
data.frame(pts(), clust = cl)
})
You need to add an input binding for clust, e.g.:
numericInput('clust', 'Clusters', 2, min = 2, max = 15)
As for debugging: I added browser() at the top in df_cl, then execution stops and you can inspect variables and run code in the terminal (e.g. in Rstudio). When I ran km <- kmeans(x = pts(), centers = input$clust) I got the error you described and could then see that input contains no clust element.

R: efficient way to plot many plots in sequence with background image

I am looking to plot a stop-motion animation of a sequence of plots in R. These will show dots moving around on a trajectory. I would like to show a map in the background so that the locations of the moving points correspond to the map coordinates. The way I have been doing this is through RgoogleMaps, where I created a map object and then stored it as a png file, then I set it as the background of the plot using the rasterImage function. Ultimately I am trying to have this be a shiny app (code below).
The problem is that the animation speed I have in shiny is too fast (I can slow it down but it doesn't look as good), so the plot goes opaque because it can't process it fast enough.
Basically I want to show one set of points per iteration with the same background. Is there a more efficient way to do this? Is there a way to, say, set the background image permanently without having to plot it each time. I save some time by using recordPlot() and then replaying it, but it still doesn't completely solve the problem. I have also tried seeing if I can make the raster lower resolution but the maxpixels and col arguments in as.raster don't seem to be doing anything for me.
I am not 100% sold on having to use GoogleMaps if there is a similar alternative that is much more efficient and will achieve roughly the same thing.
BC_googlemaps_point
library(shiny)
library(colorspace)
library(raster)
library(grDevices)
library(png)
#a png from Google Maps of the area above
bc_longlat_map_img <- png::readPNG("BC_googlemaps_point.png")
bc_longlat_map_img_ras <- grDevices::as.raster(bc_longlat_map_img, maxpixels=100)
bbox <- matrix(c(33.68208, -118.0554, 33.70493, -118.0279), byrow=TRUE, ncol=2)
rownames(bbox) <- c("lon","lat")
colnames(bbox) <- c("min","max")
#make some fake data
pt_data <- matrix(NA,nrow=1000, ncol=2)
colnames(pt_data) <- c("lon","lat")
#length of each side
plot_dims <- apply(bbox,1,diff)
pt_data[1:250,"lon"] <- bbox["lon","min"] + 0.2*plot_dims["lon"]
pt_data[1:250,"lat"] <- seq(bbox["lat","min"]+0.2*plot_dims["lat"], bbox["lat","max"]-0.2*plot_dims["lat"], length.out=250)
pt_data[251:500,"lon"] <- seq(bbox["lon","min"]+0.2*plot_dims["lon"], bbox["lon","max"]-0.2*plot_dims["lon"], length.out=250)
pt_data[251:500,"lat"] <- bbox["lat","max"] - 0.2*plot_dims["lat"]
pt_data[501:750,"lon"] <- bbox["lon","max"] - 0.2*plot_dims["lon"]
pt_data[501:750,"lat"] <- seq(bbox["lat","max"]-0.2*plot_dims["lat"], bbox["lat","min"]+0.2*plot_dims["lat"], length.out=250)
pt_data[751:1000,"lon"] <- seq(bbox["lon","max"]-0.2*plot_dims["lon"], bbox["lon","min"]+0.2*plot_dims["lon"], length.out=250)
pt_data[751:1000,"lat"] <- bbox["lat","min"] + 0.2*plot_dims["lat"]
#this is the slowest, have to replot the whole thing each time
for (ii in 1:1000) {
plot(bbox["lon",1]-1000, bbox["lat",1]-1000, xlim=bbox["lon",], ylim=bbox["lat",], xlab="Longitude", ylab="Latitude", las=1)
#read in current plots limits to fit Raster Image to
lims <- par()$usr
rasterImage(bc_longlat_map_img_ras, xleft=lims[1], ybottom=lims[3], xright=lims[2], ytop=lims[4])
points(x=pt_data[ii,"lon"], y=pt_data[ii,"lat"], pch=19, cex=3)
}
#plot first, then record, and only replay each time
#seems to be a bit faster
plot(bbox["lon",1]-1000, bbox["lat",1]-1000, xlim=bbox["lon",], ylim=bbox["lat",], xlab="Longitude", ylab="Latitude", las=1)
#read in current plots limits to fit Raster Image to
lims <- par()$usr
rasterImage(bc_longlat_map_img_ras, xleft=lims[1], ybottom=lims[3], xright=lims[2], ytop=lims[4])
plot_back <- recordPlot()
for (ii in 1:1000) {
replayPlot(plot_back)
points(x=pt_data[ii,"lon"], y=pt_data[ii,"lat"], pch=19, cex=3)
}
#example without the map background. very fast.
for (ii in 1:1000) {
plot(bbox["lon",1]-1000, bbox["lat",1]-1000, xlim=bbox["lon",], ylim=bbox["lat",], xlab="Longitude", ylab="Latitude", las=1)
points(x=pt_data[ii,"lon"], y=pt_data[ii,"lat"], pch=19, cex=3)
}
The shiny app I am trying to implement looks like this (code is repetitive):
shark_vis <- shinyApp(
ui= shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel("Inputs",
sliderInput("iter","Progress of simulation",value=1, min=1, max=1000, round=TRUE, step=1,
animate=animationOptions(interval=100, loop=FALSE))),
mainPanel(plotOutput("plot"))
)
)
),
server=shinyServer(
function(input, output) {
#current image dimensions
bbox <- matrix(c(33.68208, -118.0554, 33.70493, -118.0279), byrow=TRUE, ncol=2)
rownames(bbox) <- c("lon","lat")
colnames(bbox) <- c("min","max")
#make some fake data
pt_data <- matrix(NA,nrow=1000, ncol=2)
colnames(pt_data) <- c("lon","lat")
#length of each side
plot_dims <- apply(bbox,1,diff)
pt_data[1:250,"lon"] <- bbox["lon","min"] + 0.2*plot_dims["lon"]
pt_data[1:250,"lat"] <- seq(bbox["lat","min"]+0.2*plot_dims["lat"], bbox["lat","max"]-0.2*plot_dims["lat"], length.out=250)
pt_data[251:500,"lon"] <- seq(bbox["lon","min"]+0.2*plot_dims["lon"], bbox["lon","max"]-0.2*plot_dims["lon"], length.out=250)
pt_data[251:500,"lat"] <- bbox["lat","max"] - 0.2*plot_dims["lat"]
pt_data[501:750,"lon"] <- bbox["lon","max"] - 0.2*plot_dims["lon"]
pt_data[501:750,"lat"] <- seq(bbox["lat","max"]-0.2*plot_dims["lat"], bbox["lat","min"]+0.2*plot_dims["lat"], length.out=250)
pt_data[751:1000,"lon"] <- seq(bbox["lon","max"]-0.2*plot_dims["lon"], bbox["lon","min"]+0.2*plot_dims["lon"], length.out=250)
pt_data[751:1000,"lat"] <- bbox["lat","min"] + 0.2*plot_dims["lat"]
#plot and store
plot(bbox["lon",1]-1000, bbox["lat",1]-1000, xlim=bbox["lon",], ylim=bbox["lat",], xlab="Longitude", ylab="Latitude", las=1)
#read in current plots limits to fit Raster Image to
lims <- par()$usr
rasterImage(bc_longlat_map_img_ras, xleft=lims[1], ybottom=lims[3], xright=lims[2], ytop=lims[4])
plot_back <- recordPlot()
output$plot <- renderPlot({
replayPlot(plot_back)
points(x=pt_data[input$iter,"lon"], y=pt_data[input$iter,"lat"], pch=19, cex=3, col=1:2)
})
}
)
)
runApp(shark_vis)
You can use my googleway package to 'simulate' an animation onto an actual Google Map.
I've simplified your example so I could get it to work, but the idea should translate to your example too.
Here I'm animating the route between Melbourne and Sydney
To do the animation you load a series of circles onto the map, then set the opacity to either 0 or 1 depending on which ones you want shown.
In this instance the ones you want shown are dependant on the value of the input slider.
The trick to avoid re-drawing the map and shapes each time is to load all the circles at the start, then use the update_circles() function to change the attributes (i.e., opacity) of the circles.
Notes:
You need a valid Google Maps Javascript API key
The input data must be a data.frame, not a matrix
I haven't found the 'break' point yet - i.e., the point at which there are too many circles that they can't update quick enough
library(shiny)
library(googleway)
ui <- fluidPage(
sliderInput(inputId = "mySlider", label = "slider", min = 0, max = 222, value = 0, step = 1,
animate = animationOptions(interval=100, loop=FALSE)),
google_mapOutput("myMap", height = 800)
)
server <- function(input, output){
polyline <- "rqxeF_cxsZgr#xmCekBhMunGnWc_Ank#vBpyCqjAfbAqmBjXydAe{AoF{oEgTqjGur#ch#qfAhUuiCww#}kEtOepAtdD{dDf~BsgIuj#}tHi{C{bGg{#{rGsmG_bDbW{wCuTyiBajBytF_oAyaI}K}bEkqA{jDg^epJmbB{gC}v#i~D`#gkGmJ_kEojD_O{`FqvCetE}bGgbDm_BqpD}pEqdGiaBo{FglEg_Su~CegHw`Cm`Hv[mxFwaAisAklCuUgzAqmCalJajLqfDedHgyC_yHibCizK~Xo_DuqAojDshAeaEpg#g`Dy|DgtNswBcgDiaAgEqgBozB{jEejQ}p#ckIc~HmvFkgAsfGmjCcaJwwD}~AycCrx#skCwUqwN{yKygH}nF_qAgyOep#slIehDcmDieDkoEiuCg|LrKo~Eb}Bw{Ef^klG_AgdFqvAaxBgoDeqBwoDypEeiFkjBa|Ks}#gr#c}IkE_qEqo#syCgG{iEazAmeBmeCqvA}rCq_AixEemHszB_SisB}mEgeEenCqeDab#iwAmZg^guB}cCk_F_iAmkGsu#abDsoBylBk`Bm_CsfD{jFgrAerB{gDkw#{|EacB_jDmmAsjC{yBsyFaqFqfEi_Ei~C{yAmwFt{B{fBwKql#onBmtCq`IomFmdGueD_kDssAwsCyqDkx#e\\kwEyUstC}uAe|Ac|BakGpGkfGuc#qnDguBatBot#}kD_pBmmCkdAgkB}jBaIyoC}xAexHka#cz#ahCcfCayBqvBgtBsuDxb#yiDe{Ikt#c{DwhBydEynDojCapAq}AuAksBxPk{EgPgkJ{gA}tGsJezKbcAcdK__#uuBn_AcuGsjDwvC_|AwbE}~#wnErZ{nGr_#stEjbDakFf_#clDmKkwBbpAi_DlgA{lArLukCBukJol#w~DfCcpBwnAghCweA}{EmyAgaEbNybGeV}kCtjAq{EveBwuHlb#gyIg\\gmEhBw{G{dAmpHp_#a|MsnCcuGy~#agIe#e`KkoA}lBspBs^}sAmgIdpAumE{Y_|Oe|CioKouFwuIqnCmlDoHamBiuAgnDqp#yqIkmEqaIozAohAykDymA{uEgiE}fFehBgnCgrGmwCkiLurBkhL{jHcrGs}GkhFwpDezGgjEe_EsoBmm#g}KimLizEgbA{~DwfCwvFmhBuvBy~DsqCicBatC{z#mlCkkDoaDw_BagA}|Bii#kgCpj#}{E}b#cuJxQwkK}j#exF`UanFzM{fFumB}fCirHoTml#CoAh`A"
df <- decode_pl(polyline)
df$opacity <- 1
df$id <- 1:nrow(df)
rv <- reactiveValues()
rv$df <- df
map_key <- "your_api_key"
output$myMap <- renderGoogle_map({
google_map(key = map_key, data = df) %>%
add_circles(radius = 1000, id = "id", lat = "lat", lon = "lon",
fill_opacity = "opacity", stroke_opacity = "opacity")
})
observeEvent({
input$mySlider
},{
r <- input$mySlider
rv$df[r, "opacity"] <- 1
rv$df[-r, "opacity"] <- 0
google_map_update(map_id = "myMap") %>%
update_circles(data = rv$df, radius = 1000, id = "id",
fill_opacity = "opacity", stroke_opacity = "opacity")
})
}
shinyApp(ui, server)
Screenshots
Starting state: showing everything
step 34 on the slider
step 44 on the slider
step 82 on the slider

Assign the value to an object inside if clause and call it within plot method

I want to assign the position in a plot if a condition is TRUE in R.
I am using shiny R package. in the Server.R the codes are as following:
output$plotmahal<-renderPlot({
#identify the current position of project
x0<-subset(x1,Type==1)
xc<-x0[,c(input$KPI1,input$KPI2)]
#change list to integer
xc1<-as.numeric(unlist(xc))
#current point
d0<-xc1[1]
d1<-xc1[2]
#Centroid point
centroid<-colMeans(x[,c(input$KPI1,input$KPI2)])
c0<-centroid[1]
c1<-centroid[2]
#Quantile of .5 to show if the current is inside 50% of benchmark space or not
xq<-subset(x1,Type!=1)
qKPI1high<-quantile(xq[,input$KPI1],1)
qKPI2high<-quantile(xq[,input$KPI2],1)
qKPI1low<-quantile(xq[,input$KPI1],0)
qKPI2low<-quantile(xq[,input$KPI1],0)
if((d0>qKPI1low && d0<qKPI1high) && (d1>qKPI2low && d1<qKPI2high))
{currentstatus<-"Within Benchmark"}
else{
currentstatus<-"out of benchmark"}
output$c0<-renderText({
paste(currentstatus,input$currentstatus)
})
segments(d0,d1,c0,c1,col='brown',cex=10)
})
output$dss<-renderPlot({
if(is.element("out of benchmark",input$currentstatus)){
x<-c(1)
y<-c(1)
}
if(is.element("within benchmark",input$currentstatus)){
x<-c(1)
y<-c(2)
}
plot(x,y,xaxt='n',yaxt='n',cex=1,pch=19,col=ifelse(x==1,"red","green"),ylab="status",xlab="period")
axis(1,at=1:2,labels=c("t1","t2"))
axis(2,at=1:2,labels=c("within benchmark","out of bench"))
})
If the first condition is TRUE Assign the position of (1,1) in the graph to the point.witch will be in the position of (t1,Within benchmark) in the axis of of x and y respectively.
But it does not assign it.
If you want to change the value of currentstatus from within a reactive component, it should be a reactive value itself. Here is an example where a reactiveValues element is used to store currentstatus. It is updated from within one renderPlot and used in another, as in your code.
In this example, the value of currentstatus changes when the line crosses the color barrier.
## Sample data
dat <- mtcars
library(shiny)
shinyApp(
shinyUI(
fluidPage(
wellPanel(
radioButtons('column', 'Column:', choices=names(dat),
selected='mpg', inline=TRUE),
uiOutput('ui')
),
mainPanel(
fluidRow(column(8, plotOutput('plotmahal')),
column(4, plotOutput('dss')))
)
)
),
shinyServer(function(input, output){
## Reactive values
vals <- reactiveValues(currentstatus = 'Within')
## The input options
output$ui <- renderUI({
list(
sliderInput('inp', 'Range:', min=0, max=max(dat[[input$column]]),
value=mean(dat[[input$column]])),
helpText('Example: when the line crosses the color barrier, currenstatus changes.',
align='center', style='font-weight:800;')
)
})
output$plotmahal <- renderPlot({
## Update the value of currentstatus when the input is < or > the mean
mu <- mean(dat[[input$column]])
vals$currentstatus <- if (input$inp < mu) 'Within' else 'Out'
## Make a random graph
counts <- hist(dat[[input$column]], plot=FALSE)
image(x=seq(0, mu, length=20), (y=seq(0, max(counts$counts), length=20)),
(z=matrix(rnorm(400), 20)), col=heat.colors(20, alpha=0.5),
xlim=c(0, max(counts$breaks)), xlab='', ylab='')
image(x=seq(mu, max(counts$breaks), length=20), y=y, z=z,
col=colorRampPalette(c('lightblue', 'darkblue'), alpha=0.5)(20), add=TRUE)
abline(v = input$inp, lwd=4, col='firebrick4')
})
output$dss <- renderPlot({
## This prints the currentstatus variable to RStudio console
print(vals$currentstatus)
if(is.element("Out", vals$currentstatus))
x <- y <- 1
if(is.element("Within", vals$currentstatus)) {
x <- 1
y <- 2
}
plot(x, y, xaxt='n',yaxt='n',cex=1,pch=19,
col=ifelse(x==1,"red","green"),ylab="status",xlab="period",
xlim=c(0,3), ylim=c(0,3))
axis(1,at=1:2,labels=c("t1","t2"))
axis(2,at=1:2,labels=c("within benchmark","out of bench"))
})
})
)

Resources