Related
I am having an issue with the ggplot code line where R doesn't like the "group = Year".
Here is what my data looks like:
> head(data.scores.pa)
NMDS1 NMDS2 NMDS3 Site Year Elevation Fire history
1 -0.737547 0.73473457 0.7575643 BF 2004 1710 Burnt
......
> head(spp.scrs2)
species MDS1 MDS2 pval
1 Acrothamnus.montanus 0.8383 -0.02382347 1e-04
........
> head(vec.sp.df.pa)
MDS1 MDS2 species pvals
Elevation 0.834847 0.747474 Elevation 0.005
Here is the code I am using:
>xy <- ggplot(data.scores.pa, aes(x = NMDS1, y = NMDS2, group = Year)) +
geom_point(size = 3, aes(shape = Fire history, colour = Year))+
stat_ellipse(mapping = NULL, data = NULL, geom = "path", position = "identity", type = "t", level = 0.95, segments = 51, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) +
geom_segment(data=vec.sp.df.pa, aes(x=0,xend=MDS1,y=0,yend=MDS2),
arrow = arrow(length = unit(0.5,"cm")),colour="grey")+
geom_text_repel(data=vec.sp.df.pa,aes(x=MDS1,y=MDS2,label=species),size=2)+
geom_segment(data=spp.scrs2,aes(x=0,xend=MDS1,y=0,yend=MDS2),
arrow = arrow(length = unit(0.5, "cm")),colour="black")+
geom_text_repel(data=spp.scrs2, aes(x=MDS1,y=MDS2,label=species),size=2)+
annotate("text", x = -1.6, y = 1, label = paste0("3D stress: ", format(ord.pa$stress, digits = 4)), hjust = 0) +
theme_cowplot() + scale_color_brewer(palette = "BrBG", direction = 1) +
theme(panel.border = element_rect(colour = "black"))+
ggtitle("All Sites - distance data using Bray-Curtis")+
labs(x = "NMDS1", y = "NMDS2")
> Error in FUN(X[[i]], ...) : object 'Year' not found
However, when I remove the geom_segment and geom_text_repel code lines it fixes the problem and I am able to plot the graph...
Is anyone able to provide some insight into this issue?
Thank you!
Using the plotly library, I made the following plot in R:
library(dplyr)
library(ggplot2)
library(plotly)
set.seed(123)
df <- data.frame(var1 = rnorm(1000,10,10),
var2 = rnorm(1000,5,5))
df <- df %>% mutate(var3 = ifelse(var1 <= 5 & var2 <= 5, "a", ifelse(var1 <= 10 & var2 <= 10, "b", "c")))
plot = df %>%
ggplot() + geom_point(aes(x=var1, y= var2, color= var3))
ggplotly(plot)
This is a simple scatter plot - two random variables are generated, and then the colors of the points are decided by some criteria (e.g. if var1 and var2 are between certain ranges).
From here, I could also summary statistics:
df$var3 = as.factor(df$var3)
summary = df %>%
group_by(var3) %>%
summarize(Mean_var1 = mean(var1), Mean_var2 = mean(var2), count=n())
# A tibble: 3 x 4
var3 Mean_var1 Mean_var2 count
* <fct> <dbl> <dbl> <int>
1 a -1.70 0.946 158
2 b 4.68 4.94 260
3 c 15.8 6.49 582
My question: is it possible to add some buttons to this plot which would allow the user to color the points based on custom choices? E.g. something like this :
Now, the user can type in any range they want - and the color of the points change, and the some summary statistics are generated.
Can someone please show me how to do this in R?
I had this idea - first I would create this massive table that would create all possible range combinations of "var1" and "var2":
vec1 <- c(-20:40,1)
vec2 <- c(-20:40,1)
a <- expand.grid(vec1, vec2)
for (i in seq_along(vec1)) {
for (j in seq_along(vec2)) {
df <- df %>% mutate(var3 = ifelse(var1 <= i & var2 <= i, "a", ifelse(var1 <= j & j <= 10, "b", "c")))
}
}
Then, depending on which ranges the user wants - an SQL style statement isolate the rows from this massive table corresponding to those ranges :
custom_df = df[df$var1 > -20 & df$var1 <10 & df$var1 > -20 & df$var2 <10 , ]
Then, an individual grap would be made for "custom_df" and summary statistics would also be recorded for "custom_df":
summary = custom_df %>%
group_by(var3) %>%
summarize(Mean_var1 = mean(var1), Mean_var2 = mean(var2), count=n())
But I am not sure how to neatly and efficiently do this in R.
Can someone please show me how to do this?
Thanks
I have built a small shiny app to perform most of your requirements. Based on your pre-defined large dataframe df, user can define the following:
Choose the minimum and maximum value for variables var1 and var2.
Choose criteria to define the variable var3, which is used to display different colors of data points. This is a range now.
Save plot as a HTML file.
Summary stats displayed as a table.
You can define further options to provide the user the option to choose color and so on. For that perhaps you should google on how to use scale_color_manual().
Update: Added user option to choose red and green color based on var1 and var2 range values.
library(shiny)
library(plotly)
library(dplyr)
library(DT)
### define a large df
set.seed(123)
df <- data.frame(var1 = rnorm(1000,10,10),
var2 = rnorm(1000,15,15))
ui <- fluidPage(
titlePanel(p("My First Test App", style = "color:red")),
sidebarLayout(
sidebarPanel(
p("Choose Variable limits"),
# Horizontal line ----
tags$hr(),
uiOutput("var1a"), uiOutput("var1b"),
uiOutput("var2a"), uiOutput("var2b"),
uiOutput("criteria")
),
mainPanel(
DTOutput("summary"), br(),
plotlyOutput("plot"),
br(), br(), br(),
uiOutput("saveplotbtn")
)
)
)
server <- function(input, output, session){
output$var1a <- renderUI({
tagList(
numericInput("var11", "Variable 1 min",
min = min(df$var1), max = max(df$var1), value = min(df$var1))
)
})
output$var1b <- renderUI({
if (is.null(input$var11)){
low1 <- min(df$var1)
}else low1 <- max(min(df$var1),input$var11) ## cannot be lower than var 1 minimum
tagList(
numericInput("var12", "Variable 1 max", min = low1, max = max(df$var1), value = max(df$var1))
)
})
output$var2a <- renderUI({
tagList(
numericInput("var21", "Variable 2 min",
min = min(df$var2), max = max(df$var2), value = min(df$var2))
)
})
output$var2b <- renderUI({
if (is.null(input$var21)){
low2 <- min(df$var2)
}else low2 <- max(min(df$var2),input$var21) ## cannot be lower than var 2 minimum
tagList(
numericInput("var22", "Variable 2 max", min = low2, max = max(df$var2), value = max(df$var2))
)
})
output$criteria <- renderUI({
req(input$var11,input$var12,input$var21,input$var22)
tagList(
sliderInput("crit11", "Variable 1 red color range:",
min = -10, max = 0, value = c(-10,0)),
sliderInput("crit12", "Variable 2 red color range:",
min = -25, max = 0, value = c(-25,0)),
sliderInput("crit21", "Variable 1 green color range:",
min = 0.1, max = 10, value = c(0.1,10)),
sliderInput("crit22", "Variable 2 green color range:",
min = 0.1, max = 20, value = c(0.1,20))
)
})
dat <- reactive({
req(input$crit11,input$crit12,input$crit21,input$crit22)
df <- df %>% filter(between(var1, input$var11, input$var12)) %>%
filter(between(var2, input$var21, input$var22))
# df1 <- df %>% mutate(var3 = ifelse(var1 <= i & var2 <= i, "a", ifelse(var1 <= j & var2 <= j , "b", "c")))
df1 <- df %>% mutate(var3 = ifelse(between(var1, input$crit11[1], input$crit11[2]) & between(var2, input$crit12[1], input$crit12[2]), "a",
ifelse(between(var1, input$crit21[1], input$crit21[2]) & between(var2, input$crit22[1], input$crit22[2]), "b", "c")))
})
summari <- reactive({
req(dat())
df1 <- dat()
df1$var3 = as.factor(df1$var3)
summary = df1 %>%
group_by(var3) %>%
dplyr::summarize(Mean_var1 = mean(var1), Mean_var2 = mean(var2), count=n())
})
output$summary <- renderDT(summari())
rv <- reactiveValues()
observe({
req(dat())
p <- ggplot(data=dat()) + geom_point(aes(x=var1, y= var2, color= var3))
pp <- ggplotly(p)
rv$plot <- pp
})
output$plot <- renderPlotly({
rv$plot
})
output$saveplotbtn <- renderUI({
div(style="display: block; padding: 5px 350px 5px 50px;",
downloadBttn("saveHTML",
HTML("HTML"),
style = "fill",
color = "default",
size = "lg",
block = TRUE,
no_outline = TRUE
) )
})
output$saveHTML <- downloadHandler(
filename = function() {
paste("myplot", Sys.Date(), ".html", sep = "")
},
content = function(file) {
htmlwidgets::saveWidget(as_widget(rv$plot), file, selfcontained = TRUE) ## self-contained
}
)
}
shinyApp(ui, server)
I am trying to build a dynamic Shiny app that insert sliders in a bs_accordion_sidebar.
The "add" button is working well but I can't figure out what I should add in my "delete" button code to update the barplot ?
Also, when clicking on the panel title, I think it should collapse and change his color but nothing happen ?
Thanks for any help !
library(shiny)
library(bsplus)
# global button counter
cpt <- 0
# function to create a new slider input
newinput <- function(ID, tag){
div(id=ID,
bs_append(
tag = tag,
title_side = ID,
content_side = NULL,
content_main = sliderInput( inputId = paste0("slider_",ID),
label = paste0("slider_",ID),
value = 0,
min=0,
max=10)
)
)
}
# UI
ui <- shinyUI(fluidPage(
titlePanel("bs_append and insertUI"),
sidebarPanel(
fluidRow(
actionButton("add", "+"),
mytag <- bs_accordion_sidebar(id = "accordion",
spec_side = c(width = 4, offset = 0),
spec_main = c(width = 8, offset = 0)),
div(id = "placeholder"),
actionButton("delete", "-")
)
),
mainPanel(
plotOutput('show_inputs')
),
use_bs_accordion_sidebar()
))
# SERVER
server <- shinyServer(function(input, output) {
# reactive function to collect all input values
AllInputs <- reactive({
myvalues <- sapply(names(input)[!names(input) %in% c("add", "delete")], function(x) input[[x]])
print(myvalues)
return(myvalues)
})
# simple output barplot
output$show_inputs <- renderPlot({
barplot(AllInputs())
})
# take a dependency on 'add' button
observeEvent(input$add, {
cpt <<- cpt + 1
insertUI(
selector ='#placeholder',
where = "beforeEnd",
ui = newinput(ID = cpt,
tag = mytag)
)
})
# take a dependency on 'delete' button
observeEvent(input$delete, {
removeUI(selector = paste0('#', cpt))
cpt <<- cpt - 1
})
})
shinyApp(ui, server)
I have found the answer here : https://stackoverflow.com/a/51517902/12812645
it was necessary to nullify the input deleted by removeUI
here is the corrected code using shinyjs :
library(shiny)
library(bsplus)
library(shinyjs)
# global button counter
cpt <- 0
# function to create a new slider input
newinput <- function(ID, tag){
div(id=ID,
bs_append(
tag = tag,
title_side = ID,
content_side = NULL,
content_main = sliderInput( inputId = paste0("slider_",ID),
label = paste0("slider_",ID),
value = 0,
min=0,
max=10)
)
)
}
# UI
ui <- shinyUI(fluidPage(
titlePanel("bs_append and insertUI"),
sidebarPanel(
fluidRow(
actionButton("add", "+"),
mytag <- bs_accordion_sidebar(id = "accordion",
spec_side = c(width = 4, offset = 0),
spec_main = c(width = 8, offset = 0)),
div(id = "placeholder"),
actionButton("delete", "-")
)
),
mainPanel(
plotOutput('show_inputs')
),
useShinyjs(debug = TRUE),
use_bs_accordion_sidebar()
))
# SERVER
server <- shinyServer(function(input, output) {
# reactive function to collect all input values
AllInputs <- reactive({
myvalues <- sapply(names(input)[!names(input) %in% c("add", "delete")], function(x) input[[x]])
myvalues <- unlist(myvalues[!unlist(lapply(myvalues, is.null))])
print(myvalues)
return(myvalues)
})
# simple output barplot
output$show_inputs <- renderPlot({
barplot(AllInputs())
})
# take a dependency on 'add' button
observeEvent(input$add, {
cpt <<- cpt + 1
insertUI(
selector ='#placeholder',
where = "beforeEnd",
ui = newinput(ID = cpt,
tag = mytag)
)
})
# take a dependency on 'delete' button
observeEvent(input$delete, {
removeUI(selector = paste0('#', cpt))
runjs(paste0('Shiny.onInputChange("slider_',cpt,'", null)'))
cpt <<- cpt - 1
})
})
shinyApp(ui, server)
To a 3 year old post
ggplot2: facet_wrap strip color based on variable in data set
Baptiste has given the following solution:
d <- data.frame(fruit = rep(c("apple", "orange", "plum", "banana", "pear", "grape")),
farm = rep(c(0,1,3,6,9,12), each=6),
weight = rnorm(36, 10000, 2500),
size=rep(c("small", "large")))
p1 = ggplot(data = d, aes(x = farm, y = weight)) +
geom_jitter(position = position_jitter(width = 0.3),
aes(color = factor(farm)), size = 2.5, alpha = 1) +
facet_wrap(~fruit)
dummy <- ggplot(data = d, aes(x = farm, y = weight))+ facet_wrap(~fruit) +
geom_rect(aes(fill=size), xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf) +
theme_minimal()
library(gtable)
g1 <- ggplotGrob(p1)
g2 <- ggplotGrob(dummy)
gtable_select <- function (x, ...)
{
matches <- c(...)
x$layout <- x$layout[matches, , drop = FALSE]
x$grobs <- x$grobs[matches]
x
}
panels <- grepl(pattern="panel", g2$layout$name)
strips <- grepl(pattern="strip-t", g2$layout$name)
g2$layout$t[panels] <- g2$layout$t[panels] - 1
g2$layout$b[panels] <- g2$layout$b[panels] - 1
new_strips <- gtable_select(g2, panels | strips)
library(grid)
grid.newpage()
grid.draw(new_strips)
gtable_stack <- function(g1, g2){
g1$grobs <- c(g1$grobs, g2$grobs)
g1$layout <- transform(g1$layout, z= z-max(z), name="g2")
g1$layout <- rbind(g1$layout, g2$layout)
g1
}
## ideally you'd remove the old strips, for now they're just covered
new_plot <- gtable_stack(g1, new_strips)
grid.newpage()
grid.draw(new_plot)
(I have just updated the "strip-t" pattern and opened the grid library as it was suggested in the old post)
I repost this because it's an old brillant stuff and I want to use it myself for a presentation.
I'm a beginner in ggplot and this could also help me for various scripts.
Here are my questions :
- How is it possible to choose the color and not to give the same blue and red please? In my script, I have 3 colors to set, and I hope it can be less agressive. Is it possible to do it ?
- Another question, is it possible to integrate this in the legend, i.e to know what are this colors refering ?
Many thanks
you can change the strip colours with the fill scale in the dummy plot. Combining the legends is a bit tricky, but here's a starting point.
library(ggplot2)
library(gtable)
library(gridExtra)
library(grid)
gtable_stack <- function(g1, g2){
g1$grobs <- c(g1$grobs, g2$grobs)
g1$layout <- transform(g1$layout, z= z-max(z), name="g2")
g1$layout <- rbind(g1$layout, g2$layout)
g1
}
gtable_select <- function (x, ...)
{
matches <- c(...)
x$layout <- x$layout[matches, , drop = FALSE]
x$grobs <- x$grobs[matches]
x
}
d <- data.frame(fruit = rep(c("apple", "orange", "plum", "banana", "pear", "grape")),
farm = rep(c(0,1,3,6,9,12), each=6),
weight = rnorm(36, 10000, 2500),
size=rep(c("small", "large")))
p1 = ggplot(data = d, aes(x = farm, y = weight)) +
geom_jitter(position = position_jitter(width = 0.3),
aes(color = factor(farm)), size = 2.5, alpha = 1) +
facet_wrap(~fruit)
dummy <- ggplot(data = d, aes(x = farm, y = weight))+ facet_wrap(~fruit) +
geom_rect(aes(fill=size), xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf) +
theme_minimal() + scale_fill_brewer(palette = "Pastel2")
g1 <- ggplotGrob(p1)
g2 <- ggplotGrob(dummy)
# extract legends
leg <- g1$grobs[[grep("guide-box", g1$layout$name)]]
dummy_leg <- g2$grobs[[grep("guide-box", g2$layout$name)]]
combined_leg <- rbind.gtable(leg, dummy_leg)
g1$grobs[[grep("guide-box", g1$layout$name)]] <- combined_leg
# move dummy panels one cell up
panels <- grepl(pattern="panel", g2$layout$name)
strips <- grepl(pattern="strip-t", g2$layout$name)
g2$layout$t[panels] <- g2$layout$t[panels] - 1
g2$layout$b[panels] <- g2$layout$b[panels] - 1
new_strips <- gtable_select(g2, panels | strips)
# stack new strips on top of gtable
# ideally you'd remove the old strips, for now they're just covered
new_plot <- gtable_stack(g1, new_strips)
grid.newpage()
grid.draw(new_plot)
I am using Shiny R, but I do not know to solve a problem in server. The "climate2" and "weather10" objects were not found. Likely, the "latlong" and "comp" objects show problems, but I do not know. The "latlong" argument of "forecast10day" function does not work with my "latlong" object and the "semi_join" function does not work with my "comp" object. I am copying only a part of the code because it is very long.
Many thanks!
Global R.
# Climate
climate <- cbind(tmin,tmax[,-c(1:3)],rhpm[,-c(1:3)],rham[,-c(1:3)])
names(climate) <- c("Long","Lat","Month","Tmin","Tmax","RHmin","RHmax")
head(climate,2)
Server:
latlong <- reactive({
latlong <- as.character(c(input$Lat,input$Long))
weather.10 <- forecast10day(set_location(lat_long = paste(latlong,collapse = ",")))
names(weather.10)[names(weather.10) == "temp_high"] <- "Tmax"
names(weather.10)[names(weather.10) == "temp_low"] <- "Tmin"
weather.10$Tmax <- fahrenheit.to.celsius(weather.10$Tmax, round = 0)
weather.10$Tmin <- fahrenheit.to.celsius(weather.10$Tmin, round = 0)
})
#Outputs
output$text0 <- renderText({
if(input$Irrigation =="No")
if(round(mean(min(weather.10$Tmin))) > 17 && round(mean(max(weather.10$Tmax))) < 35 && round(mean(min(weather.10$ave_humidity))) > 34 && round(mean(max(weather.10$ave_humidity))) < 87)
{
paste("The combination Biological and Chemical control is recomended in Drought or Rainy period.")
}else{
paste("Biological or chemical control or both may be inefficient and there are low risk of epidemics")
}
})
comp <- reactive ({
#Selecting options of user
comp <- data.frame(input$Long, input$Lat,input$Month)
climate <- semi_join(climate, comp, by=c("Long","Lat","Month"))
climate2 <- data.frame(unique(climate$Long),unique(climate$Lat),unique(climate$Month),round(mean(climate$Tmin)),
round(mean(climate$Tmax)),round(mean(climate$RHmin)),
round(mean(climate$RHmax)))
names(climate2) <- c("Long", "Lat","Mont","Tmin","Tmax","RHmin","RHmax")
})
output$text1 <- renderText({
if(input$Irrigation =="50-60%")
if(climate2$Tmax > 17 && climate2$Tmin < 35 && climate2$RHmin > 34 && climate2$RHmax < 87)
{
paste("The combination Biological and Chemical control is recomended.")
}else{
paste("Biological or chemical control or both may be inefficient. You can see more information in FORECASTING.")
}
})
This is my UI.
ui <- fluidPage(theme = shinytheme("superhero"),
h3("Information system to control Dry Root Rot in Common Beans"),
sidebarLayout(sidebarPanel(
numericInput("Long", label = h3("Longitude:"), value = -49),
numericInput("Lat", label = h3("Latitude:"), value = -17),
actionButton("recalc", "Show point"),
selectInput(inputId = "Irrigation",label = "Irrigation (Soil Available Water)",
choices = c("No","50-60%","80-90%","110-120%","140-150%"),
selected = "80-90%"
),
selectInput(inputId = "Month", label = "Current Month", choices = c("Jan","Feb","March","April","May","June","July",
"Aug","Sep","Oct","Nov","Dec")),