根据一个或多个下拉选择创建具有不同类型线型的折线图
Create a line chart with different type of linetypes based on one or more dropdown selections
在下面闪亮的应用程序中，我正在尝试根据边栏中的下拉菜单 selection 创建点线图。当一个指标被 selected 但不能用 2 个指标时，我已经设法创建了一个折线图。对于 x 和 y 我想要一个 solid 行，对于 x1 和 y1 我想要一个 dashed 行，对于 x2 和 y2 虚线。当我 select 2 个指标时，我仍然只得到其中一个 solid 行。
library(shiny)
library(shinydashboard)
library(plotly)
library(tidyr)
library(dplyr)
library(DT)
BRAND<-c("CHOKIS","CHOKIS","CHOKIS","CHOKIS","CHOKIS","CHOKIS","LARA CHOCO CHIPS","LARA CHOCO CHIPS","LARA CHOCO CHIPS")
BRAND_COLOR<-c("#8050f0","#8050f0","#8050f0","#8050f0","#8050f0","#8050f0","#f050c0","#f050c0","#f050c0")
SellOut.x<-c(23,34,56,77,78,34,34,64,76)
SellOut.y<-c(43,54,76,78,87,98,76,76,56)
GrossProfit.x1<-c(23,34,56,75,78,34,34,64,76)
GrossProfit.y1<-c(33,54,76,76,87,98,76,76,56)
GrossSales.x2<-c(53,34,56,77,78,34,34,84,76)
GrossSales.y2<-c(63,54,76,78,87,98,76,76,86)
r<-c(58,46,76,76,54,21,69,98,98)
graph1.data<-data.frame(BRAND,BRAND_COLOR,r)
# data frame containing columns to be added
df6 <- data.frame(SellOut.x, SellOut.y, GrossProfit.x1, GrossProfit.y1, GrossSales.x2, GrossSales.y2)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
selectInput("metric","Metric",c('Gross Sales','Gross Profit','Sell Out'),multiple = T,selected = "Sell Out")
),
dashboardBody(
DTOutput("df"),
plotlyOutput("plot")
)
)
server <- function(input, output) {
choices <- reactive({
c3 <- gsub(" ", "", input$metric) # remove space
return(c3)
})
reactiveDf <- reactive({
if(length(choices()) > 0){
# if choices match column names of df6
g1 <- apply(sapply(X = choices(), FUN = grepl, colnames(df6)), MARGIN = 1, FUN = any)
addedDf <- df6[, g1] # columns to be added
# colnames(addedDf) <- c("x", "y", "x1", "y1", "x2", "y2")[1:ncol(addedDf)] # change column names <---- does not work as it always picks x & y as the first two vars
ab <- colnames(addedDf)
abc <- sapply(strsplit(ab,split="\."),"[")[2,] ### this works
colnames(addedDf) <- abc
combinedDf <- cbind(graph1.data, addedDf) # add columns
#combinedDf$label<-paste(combinedDf$BRAND,"-",input$metric)
return(combinedDf)
}else{
#graph1.data$label<-paste(graph1.data$BRAND,"-",input$metric)
return(graph1.data)
}
})
output$df<-renderDT({
reactiveDf()
})
output$plot<-renderPlotly({
Df <- req(reactiveDf())
metric<-input$metric
brand.colors <- reactiveDf()$BRAND_COLOR
names(brand.colors) <- reactiveDf()$BRAND
data<-unique(reactiveDf()$BRAND)
ind=which(names(brand.colors) %in% data)
if(length(metric) == 1) {
for ( i in 1:length(brand.colors))
{
Df$BRAND[i]=paste(reactiveDf()$BRAND[i],metric)
}
names(brand.colors) <- Df$BRAND
p <- Df %>%
ggplot2::ggplot(aes(x, y, color = BRAND))
p <- p +
ggplot2::geom_line(aes(x)) +
# warnings suppressed on text property
suppressWarnings(ggplot2::geom_point(aes(x, y, size = r,
#text = hovertext
), show.legend = TRUE)) +
ggplot2::scale_color_manual(values = brand.colors)
}
else if(length(metric) == 2) {
}
else{
}
})
}
shinyApp(ui, server)
第一个问题是下面的语句
colnames(addedDf) <- c("x", "y", "x1", "y1", "x2", "y2")[1:ncol(addedDf)]
因为它只允许您指定 x 和 y 作为名称，而不管您 select；售罄、总销售额或总利润。我现在已经更新了长格式剩余问题的代码。
library(shiny)
library(shinydashboard)
library(plotly)
library(tidyr)
library(dplyr)
library(DT)
BRAND<-c("CHOKIS","CHOKIS","CHOKIS","CHOKIS","CHOKIS","CHOKIS","LARA CHOCO CHIPS","LARA CHOCO CHIPS","LARA CHOCO CHIPS")
BRAND_COLOR<-c("#8050f0","#8050f0","#8050f0","#8050f0","#8050f0","#8050f0","#f050c0","#f050c0","#f050c0")
SellOut.x<-c(23,34,56,77,78,34,34,64,76)
SellOut.y<-c(43,54,76,78,87,98,76,76,56)
GrossProfit.x1<-c(23,34,56,75,78,34,34,64,76)
GrossProfit.y1<-c(33,54,76,76,87,98,76,76,56)
GrossSales.x2<-c(53,34,56,77,78,34,34,84,76)
GrossSales.y2<-c(63,54,76,78,87,98,76,76,86)
r<-c(58,46,76,76,54,21,69,98,98)
mt <- c('Sell Out','Gross Sales','Gross Profit')
graph1.data<-data.frame(BRAND,BRAND_COLOR,r)
dfc <- data.frame(series=c(0,1,2), lines=c("solid","dashed","dotted"))
# data frame containing columns to be added
df6 <- data.frame(SellOut.x, SellOut.y, GrossProfit.x1, GrossProfit.y1, GrossSales.x2, GrossSales.y2)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
selectInput("metric","Metric",c('Gross Sales','Gross Profit','Sell Out'),multiple = T,selected = "Sell Out")
),
dashboardBody(
DTOutput("df"),
plotlyOutput("plot")
)
)
server <- function(input, output) {
choices <- reactive({
c3 <- gsub(" ", "", input$metric) # remove space
return(c3)
})
mydata <- eventReactive(input$metric, {
if(length(choices()) > 0){
g1 <- apply(sapply(X = choices(), FUN = grepl, colnames(df6)), MARGIN = 1, FUN = any)
addedDf <- df6[, g1] # columns to be added
ab <- colnames(addedDf)
colnames(addedDf) <- sapply(strsplit(ab,split="\."),"[")[2,]
combinedDf <- cbind(graph1.data, addedDf)
abc <- colnames(combinedDf)
if (sum(as.character(abc) %in% c("x", "y"))>0) { df1 <- combinedDf %>% rename(x0=x,y0=y)
}else df1 <- combinedDf
#mt <- c('Sell Out','Gross Sales','Gross Profit')
mydf <- df1 %>% # rename(x0=x,y0=y) %>%
dplyr::mutate(row = 1:n(),r=r) %>%
pivot_longer(cols = -c(row,BRAND,BRAND_COLOR,r)) %>%
separate(col = name, into = c("var", "series"), sep = 1) %>%
pivot_wider(id_cols = c(BRAND,BRAND_COLOR,r,row, series), names_from = "var", values_from = "value") %>%
dplyr::mutate(metric=ifelse(series==0,mt[1],ifelse(series==1,mt[3],mt[2]))) %>%
dplyr::mutate(label=ifelse(series==0,paste(BRAND,mt[1]),ifelse(series==1,paste(BRAND,mt[3]),paste(BRAND,mt[2])))) %>% print(n=Inf)
}else {mydf <- graph1.data}
mydf
}, ignoreNULL = FALSE)
output$df <- renderDT({
mydata()
})
myplot <- reactive({
req(mydata(),input$metric)
brand.colors <- mydata()$BRAND_COLOR
names(brand.colors) <- mydata()$label
linetype <- dfc$lines[dfc$series %in% unique(mydata()$series)]
print(linetype)
if(length(input$metric) == 1) {
p <- mydata() %>% ggplot2::ggplot(aes(x, y, color = label))
}else {
p <- mydata() %>% ggplot2::ggplot(aes(x, y, group=metric, color = label))
}
p <- p + ggplot2::geom_line(aes(x, linetype=series)) + ##
# warnings suppressed on text property
suppressWarnings(ggplot2::geom_point(aes(x, y, size = r), show.legend = TRUE)) +
ggplot2::scale_color_manual(values = brand.colors) +
scale_linetype_manual(name="", breaks=mydata()$series, values = linetype)
p
})
output$plot <- renderPlotly({
req(myplot())
ggplotly(myplot())
})
}
shinyApp(ui, server)
在下面闪亮的应用程序中，我正在尝试根据边栏中的下拉菜单 selection 创建点线图。当一个指标被 selected 但不能用 2 个指标时，我已经设法创建了一个折线图。对于 x 和 y 我想要一个 solid 行，对于 x1 和 y1 我想要一个 dashed 行，对于 x2 和 y2 虚线。当我 select 2 个指标时，我仍然只得到其中一个 solid 行。
library(shiny)
library(shinydashboard)
library(plotly)
library(tidyr)
library(dplyr)
library(DT)
BRAND<-c("CHOKIS","CHOKIS","CHOKIS","CHOKIS","CHOKIS","CHOKIS","LARA CHOCO CHIPS","LARA CHOCO CHIPS","LARA CHOCO CHIPS")
BRAND_COLOR<-c("#8050f0","#8050f0","#8050f0","#8050f0","#8050f0","#8050f0","#f050c0","#f050c0","#f050c0")
SellOut.x<-c(23,34,56,77,78,34,34,64,76)
SellOut.y<-c(43,54,76,78,87,98,76,76,56)
GrossProfit.x1<-c(23,34,56,75,78,34,34,64,76)
GrossProfit.y1<-c(33,54,76,76,87,98,76,76,56)
GrossSales.x2<-c(53,34,56,77,78,34,34,84,76)
GrossSales.y2<-c(63,54,76,78,87,98,76,76,86)
r<-c(58,46,76,76,54,21,69,98,98)
graph1.data<-data.frame(BRAND,BRAND_COLOR,r)
# data frame containing columns to be added
df6 <- data.frame(SellOut.x, SellOut.y, GrossProfit.x1, GrossProfit.y1, GrossSales.x2, GrossSales.y2)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
selectInput("metric","Metric",c('Gross Sales','Gross Profit','Sell Out'),multiple = T,selected = "Sell Out")
),
dashboardBody(
DTOutput("df"),
plotlyOutput("plot")
)
)
server <- function(input, output) {
choices <- reactive({
c3 <- gsub(" ", "", input$metric) # remove space
return(c3)
})
reactiveDf <- reactive({
if(length(choices()) > 0){
# if choices match column names of df6
g1 <- apply(sapply(X = choices(), FUN = grepl, colnames(df6)), MARGIN = 1, FUN = any)
addedDf <- df6[, g1] # columns to be added
# colnames(addedDf) <- c("x", "y", "x1", "y1", "x2", "y2")[1:ncol(addedDf)] # change column names <---- does not work as it always picks x & y as the first two vars
ab <- colnames(addedDf)
abc <- sapply(strsplit(ab,split="\."),"[")[2,] ### this works
colnames(addedDf) <- abc
combinedDf <- cbind(graph1.data, addedDf) # add columns
#combinedDf$label<-paste(combinedDf$BRAND,"-",input$metric)
return(combinedDf)
}else{
#graph1.data$label<-paste(graph1.data$BRAND,"-",input$metric)
return(graph1.data)
}
})
output$df<-renderDT({
reactiveDf()
})
output$plot<-renderPlotly({
Df <- req(reactiveDf())
metric<-input$metric
brand.colors <- reactiveDf()$BRAND_COLOR
names(brand.colors) <- reactiveDf()$BRAND
data<-unique(reactiveDf()$BRAND)
ind=which(names(brand.colors) %in% data)
if(length(metric) == 1) {
for ( i in 1:length(brand.colors))
{
Df$BRAND[i]=paste(reactiveDf()$BRAND[i],metric)
}
names(brand.colors) <- Df$BRAND
p <- Df %>%
ggplot2::ggplot(aes(x, y, color = BRAND))
p <- p +
ggplot2::geom_line(aes(x)) +
# warnings suppressed on text property
suppressWarnings(ggplot2::geom_point(aes(x, y, size = r,
#text = hovertext
), show.legend = TRUE)) +
ggplot2::scale_color_manual(values = brand.colors)
}
else if(length(metric) == 2) {
}
else{
}
})
}
shinyApp(ui, server)
第一个问题是下面的语句
colnames(addedDf) <- c("x", "y", "x1", "y1", "x2", "y2")[1:ncol(addedDf)]
因为它只允许您指定 x 和 y 作为名称，而不管您 select；售罄、总销售额或总利润。我现在已经更新了长格式剩余问题的代码。
library(shiny)
library(shinydashboard)
library(plotly)
library(tidyr)
library(dplyr)
library(DT)
BRAND<-c("CHOKIS","CHOKIS","CHOKIS","CHOKIS","CHOKIS","CHOKIS","LARA CHOCO CHIPS","LARA CHOCO CHIPS","LARA CHOCO CHIPS")
BRAND_COLOR<-c("#8050f0","#8050f0","#8050f0","#8050f0","#8050f0","#8050f0","#f050c0","#f050c0","#f050c0")
SellOut.x<-c(23,34,56,77,78,34,34,64,76)
SellOut.y<-c(43,54,76,78,87,98,76,76,56)
GrossProfit.x1<-c(23,34,56,75,78,34,34,64,76)
GrossProfit.y1<-c(33,54,76,76,87,98,76,76,56)
GrossSales.x2<-c(53,34,56,77,78,34,34,84,76)
GrossSales.y2<-c(63,54,76,78,87,98,76,76,86)
r<-c(58,46,76,76,54,21,69,98,98)
mt <- c('Sell Out','Gross Sales','Gross Profit')
graph1.data<-data.frame(BRAND,BRAND_COLOR,r)
dfc <- data.frame(series=c(0,1,2), lines=c("solid","dashed","dotted"))
# data frame containing columns to be added
df6 <- data.frame(SellOut.x, SellOut.y, GrossProfit.x1, GrossProfit.y1, GrossSales.x2, GrossSales.y2)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
selectInput("metric","Metric",c('Gross Sales','Gross Profit','Sell Out'),multiple = T,selected = "Sell Out")
),
dashboardBody(
DTOutput("df"),
plotlyOutput("plot")
)
)
server <- function(input, output) {
choices <- reactive({
c3 <- gsub(" ", "", input$metric) # remove space
return(c3)
})
mydata <- eventReactive(input$metric, {
if(length(choices()) > 0){
g1 <- apply(sapply(X = choices(), FUN = grepl, colnames(df6)), MARGIN = 1, FUN = any)
addedDf <- df6[, g1] # columns to be added
ab <- colnames(addedDf)
colnames(addedDf) <- sapply(strsplit(ab,split="\."),"[")[2,]
combinedDf <- cbind(graph1.data, addedDf)
abc <- colnames(combinedDf)
if (sum(as.character(abc) %in% c("x", "y"))>0) { df1 <- combinedDf %>% rename(x0=x,y0=y)
}else df1 <- combinedDf
#mt <- c('Sell Out','Gross Sales','Gross Profit')
mydf <- df1 %>% # rename(x0=x,y0=y) %>%
dplyr::mutate(row = 1:n(),r=r) %>%
pivot_longer(cols = -c(row,BRAND,BRAND_COLOR,r)) %>%
separate(col = name, into = c("var", "series"), sep = 1) %>%
pivot_wider(id_cols = c(BRAND,BRAND_COLOR,r,row, series), names_from = "var", values_from = "value") %>%
dplyr::mutate(metric=ifelse(series==0,mt[1],ifelse(series==1,mt[3],mt[2]))) %>%
dplyr::mutate(label=ifelse(series==0,paste(BRAND,mt[1]),ifelse(series==1,paste(BRAND,mt[3]),paste(BRAND,mt[2])))) %>% print(n=Inf)
}else {mydf <- graph1.data}
mydf
}, ignoreNULL = FALSE)
output$df <- renderDT({
mydata()
})
myplot <- reactive({
req(mydata(),input$metric)
brand.colors <- mydata()$BRAND_COLOR
names(brand.colors) <- mydata()$label
linetype <- dfc$lines[dfc$series %in% unique(mydata()$series)]
print(linetype)
if(length(input$metric) == 1) {
p <- mydata() %>% ggplot2::ggplot(aes(x, y, color = label))
}else {
p <- mydata() %>% ggplot2::ggplot(aes(x, y, group=metric, color = label))
}
p <- p + ggplot2::geom_line(aes(x, linetype=series)) + ##
# warnings suppressed on text property
suppressWarnings(ggplot2::geom_point(aes(x, y, size = r), show.legend = TRUE)) +
ggplot2::scale_color_manual(values = brand.colors) +
scale_linetype_manual(name="", breaks=mydata()$series, values = linetype)
p
})
output$plot <- renderPlotly({
req(myplot())
ggplotly(myplot())
})
}
shinyApp(ui, server)