0
私はShinyの多次元スケーリングの結果をプロットするためにいくつかの問題があります。以下は私のコードです。私の質問のいずれかに対する答えは、前もっておかげです。Shinyの問題点を示しています
library(shinythemes)
library(devtools)
library(shiny)
library(knitr)
library(plotly)
library(DT)
library(shinydashboard)
library(dplyr)
# UI for People
shinyUI(dashboardPage(skin="yellow", dashboardHeader(title = "MDS"),
dashboardSidebar(fluidRow(column(12,selectInput("position", label = "Choose Position", choices = c("Forward" = "Forward", "Back" = "Back")))),
uiOutput("Player"),
fluidRow(column(12, offset = 3, actionButton("go", "Plot Players", style = "color: #00004c;")))),
dashboardBody(fluidRow(column(12, plotlyOutput("plot"))),
fluidRow(column(2, checkboxInput("checkbox", "See Player Details", value = FALSE))),
fluidRow(column(12, DT::dataTableOutput('tableData')))) ))
# Server for people
shinyServer(function(input, output) {
People <- read.csv("People.csv", header = TRUE)
Forward = People[People$Position == "Forward",]
Back = People[People$Position == "Back",]
# Changing factors to characters
People$Initials = as.character(People$Initials)
People$Player = as.character(People$Player)
output$Player <- renderUI({
players = People[People$Position == input$position,1]
players1 = c("All Players", players)
selectInput("players", "Select Players", players1, multiple = TRUE) })
# Presaved data sets by column value Position
positionInput <- reactive ({
switch(input$data,
"Forward" = Forward,
"Back" = Back)})
data <- eventReactive(input$go, {
if (is.null(input$players)) return()
else if(input$position == 'Forward')
{if (input$players=="All Players"){
Dataplayers = Forward
players.rows = row.names(Forward)
cms = cmdscale(dist(Forward[, c(7:10)]), k=2, eig=TRUE)
p1 <- cms$points[players.rows,1]
p2 <- cms$points[players.rows,2]
xlim = c(min(cms$points[,1]), max(cms$points[,1]))
ylim = c(min(cms$points[,2]), max(cms$points[,2]))
df = isolate(cbind(p1, p2, Dataplayers))
info = list(df = df, players.rows = players.rows, xlim = xlim, ylim = ylim, Dataplayers = Dataplayers)
return(info)
}
picked = isolate(input$players) # Return on selected players
Dataplayers = Forward[Forward$Player %in% picked,]
players.rows = row.names(Forward[Forward$Player %in% picked,])
cms = cmdscale(dist(Forward[, c(7:10)]), k=2, eig=TRUE)
p1 <- cms$points[players.rows,1]
p2 <- cms$points[players.rows,2]
xlim = c(min(cms$points[,1]), max(cms$points[,1]))
ylim = c(min(cms$points[,2]), max(cms$points[,2]))
df = isolate(cbind(p1, p2, Dataplayers))
info = list(df = df, players.rows = players.rows, xlim = xlim, ylim = ylim, Dataplayers = Dataplayers)
return(info)
}
else if(input$position == 'Back')
{
if (input$players=="All Players"){
Dataplayers = Back
players.rows = row.names(Back)
cms = cmdscale(dist(Back[, c(7:10)]), k=2, eig=TRUE)
p1 <- cms$points[players.rows,1]
p2 <- cms$points[players.rows,2]
xlim = c(min(cms$points[,1]), max(cms$points[,1]))
ylim = c(min(cms$points[,2]), max(cms$points[,2]))
df = isolate(cbind(p1, p2, Dataplayers))
info = list(df = df, players.rows = players.rows, xlim = xlim, ylim = ylim, Dataplayers = Dataplayers)
return(info)
}
picked = isolate(input$players) # Return on selected players
Dataplayers = Back[Back$Player %in% picked,]
players.rows = row.names(Back[Back$Player %in% picked,])
cms = cmdscale(dist(Back[, c(7:10)]), k=2, eig=TRUE)
p1 <- cms$points[players.rows,1]
p2 <- cms$points[players.rows,2]
xlim = c(min(cms$points[,1]), max(cms$points[,1]))
ylim = c(min(cms$points[,2]), max(cms$points[,2]))
df = isolate(cbind(p1, p2, Dataplayers))
info = list(df = df, players.rows = players.rows, xlim = xlim, ylim = ylim, Dataplayers = Dataplayers)
return(info)
}})
output$plot <- renderPlotly({
if (is.null(data())) return() # i.e. if action button is not pressed
else if(input$position == 'Forward'){
playerData = data()$df
ax <- list(
zeroline = FALSE,
showline = TRUE,
showticklabels = FALSE,
mirror = "ticks",
gridcolor = toRGB("white"),
zerolinewidth = 0,
linecolor = toRGB("black"),
linewidth = 2
)
p = plot_ly(playerData, x = p1, y = p2, mode = "markers",
color = Sex, colors=c("blue","goldenrod2"),
hoverinfo = "text", text = paste ("", Player , "<br>" , "Country: " , Country),
source = "mds") %>%
layout(plot_bgcolor='transparent') %>%
layout(paper_bgcolor='transparent') %>%
config(displayModeBar = T) %>% # Keep Mode bar
layout(xaxis = ax, yaxis = ax) # No Axis
p
}
else if(input$position == 'Back'){
playerData = data()$df
ax <- list(
zeroline = FALSE,
showline = TRUE,
showticklabels = FALSE,
mirror = "ticks",
gridcolor = toRGB("white"),
zerolinewidth = 0,
linecolor = toRGB("black"),
linewidth = 2
)
p = plot_ly(playerData, x = p1, y = p2, mode = "markers",
color = Sex, colors=c("blue","goldenrod2"),
hoverinfo = "text", text = paste ("", Player , "<br>" , "Country: " , Country),
source = "mds") %>%
layout(plot_bgcolor='transparent') %>%
layout(paper_bgcolor='transparent') %>%
config(displayModeBar = T) %>% # Kepp Mode bar
layout(xaxis = ax, yaxis = ax) # No Axis
p
}})
output$tableData <- DT::renderDataTable({
if (is.null(data())) return()
if(input$checkbox==FALSE) return(NULL)
# Try to get the zoomed data
event.data <- event_data("plotly_zoom", source = "mds")
# "plotly_relayout" "plotly_zoom" # : These aren't working
# Row numbers
# print(event.data$pointNumber + 1)
playerData = data()$Dataplayers
# playerData = print(playerData[event.data$pointNumber + 1,]) # This returns each row as it is clicked. One row at a time can be seen
playerData %>%
select(c(1:10)) %>%
DT::datatable(rownames= FALSE, options = list(lengthMenu = c(5, 10), pageLength = 10))})
})
[OK]をので、それがスクロールダウンリストによってブロックされていないので、
a）はどのように私はダウン、さらにアクションボタン（進む）「プロットプレーヤー」を移動できますか？
b）ユーザーのズームに合わせてデータテーブルを調整します。 plotly_click（ユーザーのクリックに合わせる）では動作させることができますが、plotly_relayoutやplotly_zoomでは動作しません。または、ズームした点のみを表示するようにするのではなく、ズームした点を使用してテーブル内の点を並べ替えること（つまり、表示された表の上部にあるズームした点）を試す方が簡単でしょうか？
c）ホバーテキストがマーカーテキストと異なる可能性がありますか？私。marker = "text"、text =頭文字 hoverinfo = "text"、text = paste（ ""、Player、 "Country："、Country）） おそらくイニシャルのトレースを追加するのはオプションですか？
d）カラーベクトルが正しく機能していません。 女の子と男の子の両方をプロットするように選択すると、それは機能します。しかし、色を選択しているときなど、女の子だけを選択した場合は、もはや金や青ではありません。私は、女の子（Sex column = 'F'）が金色にプロットされ、男性は青色であると明示したいと思います。 ここで私は非プロットのプロットのためにそれをしました： player.col = rep（ "gold"、nrow（playerData））＃datのすべての行を金色にします。 male = which（playerData $ Sex == "M" ） player.col [male] = "blue"＃この行の色= 'M' blue - 金色ではない
男の子と女の子が一緒にプロットされていないことがわかります....
ここで感謝
は、コードを実行するためのデータである。
Player Initials Age Country Sex Position Score Score2 Score3 Score4
1 Emily Duffy ED 22 Ireland F Forward 9 3 2 5
2 Jim Turner JT 26 England M Forward 8 4 6 5
3 Rachael Neill RN 17 Australia F Forward 9 6 7 5
4 Andrew Paul AP 45 Wales M Forward 5 7 4 5
5 Mark Andrew MA 34 Ireland M Forward 5 8 5 4
6 Peter Bell PB 56 Spain M Forward 5 7 6 3
7 Amy Coy AC 77 France F Forward 6 6 7 5
8 James Leavy JL 88 Portugal M Forward 10 7 4 5
9 John Connors JC 87 Hungary M Forward 9 7 3 6
10 Paula Polley PP 62 Russia F Forward 8 8 2 6
11 Sarah Turner ST 23 China F Forward 10 9 5 6
12 Kerry McGowan KMcG 27 Japan F Forward 7 6 6 6
13 Liz Foy LF 71 England F Forward 5 6 7 6
14 Ann Mercer AM 19 Peru F Back 4 6 9 6
15 Pete Morrison PM 70 Norway M Back 7 6 8 6
16 Emma Duffy ED 69 Poland F Back 8 6 7 4
17 Lucy Paul LP 38 Iceland F Back 8 4 5 6
18 Rebecca Coyle PC 43 Greenland F Back 9 4 6 6
19 Ben Carey BC 45 Holland M Back 5 3 6 6