我想插入从function.LetControl <-function（coverage）生成的图形。我无法在闪亮的图片上显示此图片，其他图片也可以使用。我相信可能是因为此功能在另一个功能内。有人可以帮我解决这个问题。
可执行代码如下：
library(shiny)
library(ggplot2)
library(rdist)
library(geosphere)
library(kableExtra)
library(readxl)
library(tidyverse)
#database
df<-structure(list(Properties = c(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35), Latitude = c(-23.8, -23.8, -23.9, -23.9, -23.9, -23.9, -23.9, -23.9, -23.9, -23.9, -23.9, -23.9, -23.9, -23.9,
+ -23.9, -23.9, -23.9, -23.9, -23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9), Longitude = c(-49.6, -49.6, -49.6, -49.6, -49.6, -49.6, -49.6, -49.6, -49.6, -49.6, -49.7,
+ -49.7, -49.7, -49.7, -49.7, -49.6, -49.6, -49.6, -49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6), Waste = c(526, 350, 526, 469, 285, 175, 175, 350, 350, 175, 350, 175, 175, 364,
+ 175, 175, 350, 45.5, 54.6,350,350,350,350,350,350,350,350,350,350,350,350,350,350,350,350)), class = "data.frame", row.names = c(NA, -35L))
function.clustering<-function(df,k,Filter1,Filter2){
if (Filter1==2){
Q1<-matrix(quantile(df$Waste, probs = 0.25))
Q3<-matrix(quantile(df$Waste, probs = 0.75))
L<-Q1-1.5*(Q3-Q1)
S<-Q3+1.5*(Q3-Q1)
df_1<-subset(df,Waste>L[1])
df<-subset(df_1,Waste<S[1])
}
#cluster
coordinates<-df[c("Latitude","Longitude")]
d<-as.dist(distm(coordinates[,2:1]))
fit.average<-hclust(d,method="average")
#Number of clusters
clusters<-cutree(fit.average, k)
nclusters<-matrix(table(clusters))
df$cluster <- clusters
#Localization
center_mass<-matrix(nrow=k,ncol=2)
for(i in 1:k){
center_mass[i,]<-c(weighted.mean(subset(df,cluster==i)$Latitude,subset(df,cluster==i)$Waste),
weighted.mean(subset(df,cluster==i)$Longitude,subset(df,cluster==i)$Waste))}
coordinates$cluster<-clusters
center_mass<-cbind(center_mass,matrix(c(1:k),ncol=1))
#Coverage
coverage<-matrix(nrow=k,ncol=1)
for(i in 1:k){
aux_dist<-distm(rbind(subset(coordinates,cluster==i),center_mass[i,])[,2:1])
coverage[i,]<-max(aux_dist[nclusters[i,1]+1,])}
coverage<-cbind(coverage,matrix(c(1:k),ncol=1))
colnames(coverage)<-c("Coverage_meters","cluster")
#Sum of Waste from clusters
sum_waste<-matrix(nrow=k,ncol=1)
for(i in 1:k){
sum_waste[i,]<-sum(subset(df,cluster==i)["Waste"])
}
sum_waste<-cbind(sum_waste,matrix(c(1:k),ncol=1))
colnames(sum_waste)<-c("Potential_Waste_m3","cluster")
#Output table
data_table <- Reduce(merge, list(df, coverage, sum_waste))
data_table <- data_table[order(data_table$cluster, as.numeric(data_table$Properties)),]
data_table_1 <- aggregate(. ~ cluster + Coverage_meters + Potential_Waste_m3, data_table[,c(1,7,6,2)], toString)
data_table_1<-kable(data_table_1[order(data_table_1$cluster), c(1,4,2,3)], align = "c", row.names = FALSE) %>%
kable_styling(full_width = FALSE)
#Scatter Plot
suppressPackageStartupMessages(library(ggplot2))
df1<-as.data.frame(center_mass)
colnames(df1) <-c("Latitude", "Longitude", "cluster")
g<-ggplot(data=df, aes(x=Longitude, y=Latitude, color=factor(clusters))) + geom_point(aes(x=Longitude, y=Latitude), size = 4)
Centro_View<- g + geom_text(data=df, mapping=aes(x=eval(Longitude), y=eval(Latitude), label=Waste), size=3, hjust=-0.1)+ geom_point(data=df1, mapping=aes(Longitude, Latitude), color= "green", size=4) + geom_text(data=df1, mapping = aes(x=Longitude, y=Latitude, label = 1:k), color = "black", size = 4)
plotGD<-print(Centro_View + ggtitle("Scatter Plot") + theme(plot.title = element_text(hjust = 0.5)))
}
function.LetControl<-function(coverage)
{
m <- mean(coverage[,1])
MR <- mean(abs(diff(coverage[,1])))
d2 <- 1.1284
LIC <- m - 3*(MR/d2)
LSC <- m + 3*(MR/d2)
LetCover<-plot(coverage[,1], type = "b", pch = 16, ylim = c(LIC-0.1*LIC,LSC+0.5*LSC), axes = FALSE)
axis(1, at = 1:35)
axis(2)
box()
grid()
abline(h = MR,
lwd = 2)
abline(h = LSC, lwd = 2, col = "red")
abline(h = LIC, lwd = 2, col = "red")}
ui <- fluidPage(
titlePanel("Clustering "),
sidebarLayout(
sidebarPanel(
helpText(h3("Generation of clustering")),
radioButtons("filter1", h3("Waste Potential"),
choices = list("Select all properties" = 1,
"Exclude properties that produce less than L and more than S" = 2),
selected = 1),
radioButtons("filter2", h3("Coverage do cluster"),
choices = list("Use default limitations" = 1,
"Do not limite coverage" = 2
),selected = 1),
tags$hr(),
helpText(h3("Are you satisfied with the solution?")),
helpText(h4("(1) Yes")),
helpText(h4("(2) No")),
helpText(h4("(a) Change the number of clusters")),
sliderInput("Slider", h3("Number of clusters"),
min = 2, max = 34, value = 8),
helpText(h4("(b) Change the filter options"))
),
mainPanel(
uiOutput("tabela"),
plotOutput("ScatterPlot"),
plotOutput("LetCoverage"),
)))
server <- function(input, output) {
f1<-renderText({input$filter1})
f2<-renderText({input$filter2})
Modelclustering<-reactive(function.clustering(df,input$Slider,1,1))
output$tabela <- renderUI(HTML(Modelclustering()[["plot_env"]][["data_table_1"]]))
output$ScatterPlot<-renderPlot(Modelclustering()[["plot_env"]][["plotGD"]])
output$LetCoverage <- renderPlot(Modelclustering()[["plot_env"]][["LetCover"]])
}
# Run the application
shinyApp(ui = ui, server = server)
错误1：参数1不是向量
错误2：数学的非数字参数
非常感谢您的朋友！
答案 0 :(得分：1)
通常，我们希望从函数中返回值，而不是尝试使用[["plot_env"]][["plotGD"]]来访问它们。在R中，要从一个函数返回多个元素，我们必须将它们包装在list()中。对于您的应用程序，功能function.clustering()需要返回3个元素：coverage数据，聚类表和散点图。这是通过以下方式处理的：
return(list(
"Data" = data_table_1,
"Plot" = plotGD,
"Coverage" = coverage
))
请注意，plotGD只是绘图对象，而不是打印的绘图。后者将绘图打印到绘图窗口/窗格，因此您必须进行两次[[]][[]]体操。
类似的电缆。返回data.frame（或data.table或matrix），然后在服务器函数中进行样式设置。
最后，要使用function.LetCoverage，我们只需传递聚类函数返回的第三个元素。这将绘制并渲染图。
HTH，
正在运行的应用程序：
library(shiny)
library(ggplot2)
library(rdist)
library(geosphere)
library(kableExtra)
library(readxl)
library(tidyverse)
#database
df<-structure(list(Properties = c(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35), Latitude = c(-23.8, -23.8, -23.9, -23.9, -23.9, -23.9, -23.9, -23.9, -23.9, -23.9, -23.9, -23.9, -23.9, -23.9,
+ -23.9, -23.9, -23.9, -23.9, -23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9), Longitude = c(-49.6, -49.6, -49.6, -49.6, -49.6, -49.6, -49.6, -49.6, -49.6, -49.6, -49.7,
+ -49.7, -49.7, -49.7, -49.7, -49.6, -49.6, -49.6, -49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6), Waste = c(526, 350, 526, 469, 285, 175, 175, 350, 350, 175, 350, 175, 175, 364,
+ 175, 175, 350, 45.5, 54.6,350,350,350,350,350,350,350,350,350,350,350,350,350,350,350,350)), class = "data.frame", row.names = c(NA, -35L))
function.clustering <- function(df, k, Filter1, Filter2) {
#df is database
#k is number of clusters
#Filter1 is equal to 1, if all properties are used
#Filter1 is equal to 2 is to limit the use of properties that have potential for waste production <L e >S
if (Filter1 == 2) {
Q1 <- matrix(quantile(df$Waste, probs = 0.25))
Q3 <- matrix(quantile(df$Waste, probs = 0.75))
L <- Q1 - 1.5 * (Q3 - Q1)
S <- Q3 + 1.5 * (Q3 - Q1)
df_1 <- subset(df, Waste > L[1])
df <- subset(df_1, Waste < S[1])
}
#cluster
coordinates <- df[c("Latitude", "Longitude")]
d <- as.dist(distm(coordinates[, 2:1]))
fit.average <- hclust(d, method = "average")
#Number of clusters
clusters <- cutree(fit.average, k)
nclusters <- matrix(table(clusters))
df$cluster <- clusters
#Localization
center_mass <- matrix(nrow = k, ncol = 2)
for (i in 1:k) {
center_mass[i, ] <-
c(
weighted.mean(
subset(df, cluster == i)$Latitude,
subset(df, cluster == i)$Waste
),
weighted.mean(
subset(df, cluster == i)$Longitude,
subset(df, cluster == i)$Waste
)
)
}
coordinates$cluster <- clusters
center_mass <- cbind(center_mass, matrix(c(1:k), ncol = 1))
#Coverage
coverage <- matrix(nrow = k, ncol = 1)
for (i in 1:k) {
aux_dist <-
distm(rbind(subset(coordinates, cluster == i), center_mass[i, ])[, 2:1])
coverage[i, ] <- max(aux_dist[nclusters[i, 1] + 1, ])
}
coverage <- cbind(coverage, matrix(c(1:k), ncol = 1))
colnames(coverage) <- c("Coverage_meters", "cluster")
#Sum of Waste from clusters
sum_waste <- matrix(nrow = k, ncol = 1)
for (i in 1:k) {
sum_waste[i, ] <- sum(subset(df, cluster == i)["Waste"])
}
sum_waste <- cbind(sum_waste, matrix(c(1:k), ncol = 1))
colnames(sum_waste) <- c("Potential_Waste_m3", "cluster")
#Output table
data_table <- Reduce(merge, list(df, coverage, sum_waste))
data_table <-
data_table[order(data_table$cluster, as.numeric(data_table$Properties)), ]
data_table_1 <-
aggregate(. ~ cluster + Coverage_meters + Potential_Waste_m3,
data_table[, c(1, 7, 6, 2)],
toString)
#Scatter Plot
suppressPackageStartupMessages(library(ggplot2))
df1 <- as.data.frame(center_mass)
colnames(df1) <- c("Latitude", "Longitude", "cluster")
g <-
ggplot(data = df, aes(
x = Longitude,
y = Latitude,
color = factor(clusters)
)) + geom_point(aes(x = Longitude, y = Latitude), size = 4)
Centro_View <-
g + geom_text(
data = df,
mapping = aes(
x = eval(Longitude),
y = eval(Latitude),
label = Waste
),
size = 3,
hjust = -0.1
) + geom_point(
data = df1,
mapping = aes(Longitude, Latitude),
color = "green",
size = 4
) + geom_text(
data = df1,
mapping = aes(x = Longitude, y = Latitude, label = 1:k),
color = "black",
size = 4
)
plotGD <-
Centro_View +
ggtitle("Scatter Plot") +
theme(plot.title = element_text(hjust = 0.5))
return(list(
"Data" = data_table_1,
"Plot" = plotGD,
"Coverage" = coverage
))
}
function.LetControl <- function(coverage) {
m <- mean(coverage[, 1])
MR <- mean(abs(diff(coverage[, 1])))
d2 <- 1.1284
LIC <- m - 3 * (MR / d2)
LSC <- m + 3 * (MR / d2)
plot(
coverage[, 1],
type = "b",
pch = 16,
ylim = c(LIC - 0.1 * LIC, LSC + 0.5 * LSC),
axes = FALSE
)
axis(1, at = 1:35)
axis(2)
box()
grid()
abline(h = MR,
lwd = 2)
abline(h = LSC, lwd = 2, col = "red")
abline(h = LIC, lwd = 2, col = "red")
}
ui <- fluidPage(
titlePanel("Clustering "),
sidebarLayout(
sidebarPanel(
helpText(h3("Generation of clustering")),
radioButtons("filter1", h3("Waste Potential"),
choices = list("Select all properties" = 1,
"Exclude properties that produce less than L and more than S" = 2),
selected = 1),
radioButtons("filter2", h3("Coverage do cluster"),
choices = list("Use default limitations" = 1,
"Do not limite coverage" = 2
),selected = 1),
tags$hr(),
helpText(h3("Are you satisfied with the solution?")),
helpText(h4("(1) Yes")),
helpText(h4("(2) No")),
helpText(h4("(a) Change the number of clusters")),
sliderInput("Slider", h3("Number of clusters"),
min = 2, max = 34, value = 8),
helpText(h4("(b) Change the filter options"))
),
mainPanel(
uiOutput("tabela"),
plotOutput("ScatterPlot"),
plotOutput("LetCoverage"),
)))
server <- function(input, output) {
f1<-renderText({input$filter1})
f2<-renderText({input$filter2})
Modelclustering<-reactive(function.clustering(df,input$Slider,1,1))
output$tabela <- renderUI({
data_table_1 <- Modelclustering()[[1]]
x <- kable(data_table_1[order(data_table_1$cluster), c(1, 4, 2, 3)], align = "c", row.names = FALSE)
x <- kable_styling(kable_input = x, full_width = FALSE)
HTML(x)
})
output$ScatterPlot <- renderPlot({
Modelclustering()[[2]]
})
output$LetCoverage <- renderPlot({
function.LetControl(Modelclustering()[[3]])
})
}
# Run the application
shinyApp(ui = ui, server = server)