我正在编写一个新的 Shiny 应用程序，我想使用plot3d() 绘制旋转的 3D 散点图，如下所示:
# Spinning 3d Scatterplot
library(rgl)
plot3d(wt, disp, mpg, col="red", size=3)
我正在尝试使用类似于此处所做的操作:
shinyRGL examples ，带有选项 renderWebGL({}) 和 webGLOutput()。但我不断收到此错误:
Error in match(x, table, nomatch = 0L) : 'match' requires vector arguments
我不明白为什么。
这是我现在使用的数据集的示例:
n=100
taxi <- data.frame(conversion=c(rep(1,20),rep(0,80)),
day = sample(1:7, n, TRUE),
hour = sample(0:23,n, TRUE),
source= sample(1:4, n, TRUE),
service= sample(1:5, n, TRUE),
relevancy= sample(1:4, n, TRUE),
tollfree= sample(c(0,1), n, TRUE),
distance= sample(0:15, n, TRUE),
similarity= sample(seq(0,1,0.01), n, TRUE),
simi.names= sample(c('[0,0.25)','[0.25,0.5)','[0.5,0.75)','[0.75,1]'), n, TRUE),
dist.names= sample(c('[0,1)','[1,2)','[2,3)','[3,4)','[4,15]'), n, TRUE),
week= sample(1:7, n, TRUE),
rel= sample(c(1,4), n, TRUE))
我有这个 ui.R:
shinyUI(navbarPage("",
tabPanel("Data",
sidebarLayout(
sidebarPanel(
selectInput("dataset", h5("Choose a dataset:"), choices = c("taxicabs", "liquor stores")),
radioButtons("discrete", h5("I want to discretize:"), choices = c("similarity", "distance","similarity & distance","none"),
inline=F, selected = "none"),
radioButtons("agg", h5("I want to aggregate:"), choices = c("day in weekdays/weekends", "relevancy in binary relevancy",
"day in weekdays/weekends & relevancy in binary relevancy","none"),
inline=F, selected = "none"),
checkboxGroupInput("checkGroup", label = h5("Dataset Features:"),
choices = c("day","hour","source","service","relevancy","tollfree","distance","similarity"), inline = F,
selected = c("day","hour","source","service","relevancy","tollfree","distance","similarity"))
),
mainPanel(
numericInput("obs", label = h5("Number of observations to view"), 15, min = 10, max = 20, step = 1),
tableOutput("view"),
tableOutput("var")
)
)
),
tabPanel("Model",
h3("Best logistic model with logit link and variable selection via stepwise AIC "),
verbatimTextOutput("model"),
downloadButton('downloadReport',label = 'Download coefficients'),
h3("MSE"),
tableOutput("measures"),
h3("Response fit"),
plotOutput('plot')
),
tabPanel("Visualize Fit on Features",
fluidRow(
column(4, selectInput("featureDisplay_x",
label = h3("X-Axis Feature"),
choices = NULL)),
column(4, selectInput("featureDisplay_y",
label = h3("Y-Axis Feature"),
choices = NULL))
),
fluidRow(
column(4,
plotOutput("distPlotA")
),
column(4,
plotOutput("distPlotB")
),
column(4,
webGLOutput("webGL")
)
)
)
))
这用于服务器。R
options(rgl.useNULL=TRUE)
library(shiny)
library(reshape2)
library(ggplot2)
library(dplyr)
library(rgl)
library(shinyRGL)
source("webGLParser.R")
shinyServer(function(input, output, session) {
datasetInput <- reactive({
switch(input$dataset,
"taxicabs" = taxi,
"liquor stores" = liq)
})
observe({
choices <- c("day", "hour", "source", "service", "relevancy", "tollfree", "distance", "similarity")
if (grepl("day in weekdays/weekends", input$agg)) {
choices[1] <- "week"
}
if (grepl("relevancy", input$agg)) {
choices[5] <- "rel"
}
if (grepl("similarity", input$discrete)) {
choices[8] <- "simi.names"
}
if (grepl("distance", input$discrete)) {
choices[7] <- "dist.names"
}
updateCheckboxGroupInput(session, "checkGroup", choices = choices,
inline = F, selected = choices)
})
datasetagg <- reactive({
cg <- input$checkGroup
dis <- input$discrete
cg_not_d_or_s <- cg[!(cg %in% c("distance", "similarity"))]
if(input$discrete == "similarity & distance") {
#all discrete
right_join(
datasetInput() %>%
select_(.dots = cg) %>%
group_by_(.dots = cg) %>%
summarise(count=n()),
datasetInput() %>%
filter(conversion==1) %>%
select_(.dots = cg) %>%
count_(vars = cg)
) %>% mutate(prop.conv = n/count)
} else if(input$discrete == "distance") {
cg_not_dis <- cg[cg != "similarity"]
# one continuous
right_join(
datasetInput() %>%
group_by_(.dots = cg_not_dis) %>%
summarise_(.dots = setNames(c("mean(similarity)", "n()"),
c("simi.mean", "count"))) %>%
select_(.dots = c(cg_not_dis, "simi.mean", "count")),
datasetInput() %>%
filter(conversion==1) %>%
select_(.dots = cg_not_dis) %>%
count_(vars = cg_not_dis)
) %>% mutate(prop.conv = n/count)
} else if(input$discrete == "similarity") {
cg_not_dis <- cg[cg != "distance"]
# one continuous
right_join(
datasetInput() %>%
group_by_(.dots = cg_not_dis) %>%
summarise_(.dots = setNames(c("mean(distance)", "n()"),
c("dist.mean", "count"))) %>%
select_(.dots = c(cg_not_dis, "dist.mean", "count")),
datasetInput() %>%
filter(conversion==1) %>%
select_(.dots = cg_not_dis) %>%
count_(vars = cg_not_dis)
) %>% mutate(prop.conv = n/count)
} else if(input$discrete == "none") {
# two
right_join(
datasetInput() %>%
select_(.dots = cg) %>%
group_by_(.dots = cg_not_d_or_s) %>%
summarise(dist.mean=mean(distance), simi.mean=mean(similarity), count=n()),
datasetInput() %>%
filter(conversion==1) %>%
select_(.dots = cg) %>%
count_(vars = cg_not_d_or_s)
) %>% mutate(prop.conv = n/count)
}
})
# head of the table
output$view <- renderTable({
head(datasetagg(), n = input$obs)
})
output$var <- renderPrint({
if(sum(sapply(droplevels(datasetagg()),function(x)length(levels(x)))==1)==0) {
paste(' *** ' )
} else if (sum(sapply(droplevels(datasetagg()),function(x)length(levels(x)))==1)>=1){
paste('***Warning: ' ,names(which(sapply(droplevels(datasetagg()),function(x)length(levels(x)))==1)), 'have just 1 level and should not be selected fo the model.' )
}
})
name <- reactive({
names.datasetagg <- names(datasetagg())
names.datasetagg[names.datasetagg == 'hour'] <- paste('I((0.2034*sin(-0.298*as.numeric(',names.datasetagg[names.datasetagg == 'hour'],')+21.679)+0.3177))')
names.datasetagg <- as.formula(paste0('cbind(n,count) ~ ',paste(names.datasetagg[! (names.datasetagg %in% c("n","count","prop.conv"))],collapse = '+')))
})
fit <- reactive({
step(glm(name(), family=binomial(logit), weights = count, data=datasetagg()),
scope=~., trace=0, direction='both', k=2)
})
# model
output$model <- renderPrint({
summary(fit()) #best model glm.step.aic.l
})
# measures
output$measures <- renderPrint({
sqrt((sum((fit()$fitted.values-datasetagg()[,'prop.conv'])^2 * datasetagg()[,'count']))/sum(datasetagg()[,'count']))
})
# download report
output$downloadReport <- downloadHandler(
filename = "mycoefficients.json",
content = function(file) {
write.table(coefficients(fit()), file, sep="\t")
})
# plot fit
output$plot <- renderPlot({
ggplot(data.frame(datasetagg(),pred=fit()$fitted.values), aes(x=prop.conv)) +
geom_histogram(aes(y=..density..),
binwidth=.02,
colour="black", fill="white") +
geom_density(aes(x=pred),alpha=.2, fill="#E4002B")+xlab("Proportion of convertions")
})
# graphs
observe({
updateSelectInput(session, "featureDisplay_x",
choices =ifelse(input$checkGroup=='distance',"dist.mean",ifelse(input$checkGroup=='similarity',"simi.mean",input$checkGroup)),
selected=input$checkGroup[1])
updateSelectInput(session, "featureDisplay_y",
choices =ifelse(input$checkGroup=='distance',"dist.mean",ifelse(input$checkGroup=='similarity',"simi.mean",input$checkGroup)),
selected=input$checkGroup[6])
})
# dataset for prediction
a <- data.frame(matrix(c(1,18,1,1,1,0,5,0.25,'[0,0.25)','[0,1)',1,1),nrow=1))
names(a) <- c('day','hour','source','service','relevancy','tollfree','dist.mean','simi.mean','simi.names','dist.names','week','rel')
a[,c('dist.mean','simi.mean',"hour")] <- lapply(a[,c('dist.mean','simi.mean',"hour")],function(x) as.numeric(as.character(x)))
xvarData <- reactive({
col <- input$featureDisplay_x
b <- a[names(a) %in% names(datasetagg())[!(names(datasetagg()) %in% c('count', 'n', 'prop.conv'))]]
b <- b[-which(names(b) %in% col)]
sel <- c(names(datasetagg())[!(names(datasetagg()) %in% c('count', 'n', 'prop.conv'))],'mean')
pred <- predict(fit(),newdata = data.frame(datasetagg() %>% group_by_(.dots = col) %>% summarise(mean = mean(prop.conv)) %>%
cbind(b) %>%
select(one_of(sel)))
,type="response")
datasetagg() %>% group_by_(.dots = col) %>% summarise(mean = mean(prop.conv)) %>%
cbind(b) %>%
select(one_of(sel)) %>%
mutate(pred=pred) %>%
select_(.dots = c(col,'mean','pred'))
})
p1 <- function(data){
ggplot(melt(data(),id.vars = input$featureDisplay_x),aes_string(x=input$featureDisplay_x,y='value',colour='variable'))+
scale_colour_manual(values=c("#7A99AC","#E4002B"),labels=c("Average", "Predict"),name =" ")+
geom_point() + ylab("proportion of conversions") + ylim(0, 1)
}
output$distPlotA <- renderPlot(function() {
plot=p1(xvarData)
print(plot)
})
yvarData <- reactive({
col <- input$featureDisplay_y
b <- a[names(a) %in% names(datasetagg())[!(names(datasetagg()) %in% c('count', 'n', 'prop.conv'))]]
b <- b[-which(names(b) %in% col)]
sel <- c(names(datasetagg())[!(names(datasetagg()) %in% c('count', 'n', 'prop.conv'))],'mean')
pred <- predict(fit(),newdata = data.frame(datasetagg() %>% group_by_(.dots = col) %>% summarise(mean = mean(prop.conv)) %>%
cbind(b) %>%
select(one_of(sel)))
,type="response")
datasetagg() %>% group_by_(.dots = col) %>% summarise(mean = mean(prop.conv)) %>%
cbind(b) %>%
select(one_of(sel)) %>%
mutate(pred=pred) %>%
select_(.dots = c(col,'mean','pred'))
})
p2 <- function(data){
ggplot(melt(data(),id.vars = input$featureDisplay_y),aes_string(x=input$featureDisplay_y,y='value',colour='variable'))+
scale_colour_manual(values=c("#7A99AC","#E4002B"),labels=c("Average", "Predict"),name =" ")+
geom_point() + ylab("proportion of conversions") + ylim(0, 1)
}
output$distPlotB <- renderPlot(function() {
plot=p2(yvarData)
print(plot)
})
xyvarData <- reactive({
colx <- input$featureDisplay_x
coly <- input$featureDisplay_y
b <- a[names(a) %in% names(datasetagg())[!(names(datasetagg()) %in% c('count', 'n', 'prop.conv'))]]
b <- b[-which(names(b) %in% c(colx,coly))]
sel <- c(names(datasetagg())[!(names(datasetagg()) %in% c('count', 'n', 'prop.conv'))],'mean')
pred <- predict(fit(),newdata = data.frame(datasetagg() %>% group_by_(.dots = colx,coly) %>% summarise(mean = mean(prop.conv)) %>%
cbind(b) %>%
select(one_of(sel)))
,type="response")
datasetagg() %>% group_by_(.dots = colx, coly) %>% summarise(mean = mean(prop.conv)) %>%
cbind(b) %>%
select(one_of(sel)) %>%
mutate(pred=pred) %>%
select_(.dots = c(colx,coly,'mean','pred'))
})
output$webGL <- renderWebGL(function() { # the error is here!!!
output$webGL <- renderWebGL(function() {
rgl::plot3d(xyvarData()[,1],xyvarData()[,2],xyvarData()[,'mean'],col="#7A99AC",zlab = "proportion of conversions")
rgl::plot3d(xyvarData()[,1],xyvarData()[,2],xyvarData()[,'pred'],col="#E4002B",add=T)
})
})
})
很抱歉代码很长，我只是希望它能确保它是可重现的。
有什么建议吗？感谢您的帮助!
编辑:我也尝试过 plotly 但没有成功。我从这里得到了模板:plotly templates for Shiny我在 UI.R 中使用它:
graphOutput("ScatterPlot")
这在 Server.R 上:
output$ScatterPlot <- renderGraph(function() {
## Create your Plotly graph
trace1 <- list(
x = xyvarData()[,1],
y = xyvarData()[,2],
z = xyvarData()[,'mean'],
mode = "markers",
name = "trace0_y",
marker = list(
size = 12,
line = list(
color = "rgba(217, 217, 217, 0.14)",
width = 0.5
),
opacity = 0.8
),
type = "scatter3d"
)
trace2 <- list(
x = xyvarData()[,1],
y = xyvarData()[,2],
z = xyvarData()[,'pred'],
mode = "markers",
name = "trace1_y",
marker = list(
color = "rgb(127, 127, 127)",
size = 12,
symbol = "circle",
line = list(
color = "rgb(204, 204, 204)",
width = 1
),
opacity = 0.9
),
type = "scatter3d"
)
data <- list(trace1, trace2)
layout <- list(
autosize = FALSE,
width = 500,
height = 500,
margin = list(
l = 0,
r = 0,
b = 0,
t = 65
)
)
# define data
data <- list(trace1, trace2)
# define layout information
layout <- list(
autosize = FALSE,
width = 500,
height = 500,
margin = list(
l = 0,
r = 0,
b = 0,
t = 65
)
)
# This sends message up to the browser client, which will get fed through to
# Plotly's javascript graphing library embedded inside the graph
return(list(
list(
id="trendPlot",
task="newPlot",
data=data,
layout=layout
)
))
})
而不是 webGLOutput() 和 renderWebGL({})。
最佳答案
好的，我刚刚知道了。感谢 Joe Cheng，我决定使用threejs并且工作整齐!
现在，我在 UI.R
uiOutput("ScatterPlot")
在 Server.R
output$plott <- renderScatterplotThree({
col <- c(rep("#7A99AC",table(xyvarData()[,'variable'])[[1]]),rep("#E4002B",table(xyvarData()[,'variable'])[[2]]))
scatterplot3js(xyvarData()[,1],xyvarData()[,2],xyvarData()[,'value'], color=col, size=0.5,
axisLabels=c(input$featureDisplay_x,"prop.conversions",input$featureDisplay_y),zlim=c(0,1))
})
output$ScatterPlot <- renderUI({
scatterplotThreeOutput("plott")
})
而不是 webGLOutput() 和 renderWebGL({})。
关于r - 在 Shiny 应用程序中旋转 3D 散点图，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/31327076/