I am having a few problems with my Shiny which uses plotly to present the Multidimensional Scaling results.. Below is my code. An answer to any of my questions would be great, thanks in advance.
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 so,
a) How do I move the action button (go) 'Plot Players' down further so it is not blocked by the scroll-down list ?
b) I would like the data table to adjust to the zoom of the user. I can get it to work for plotly_click (adjust to the click of the user) but not for plotly_relayout or plotly_zoom. Or would it be an easier option to try use the zoomed points to order the points in the table (i.e. zoomed points at the top of the displayed table) rather than trying to have the table only showing the zoomed points?
c) Is it possible for the hover text to be different from the marker text. I.e. I want: marker = "text", text = Initials hoverinfo = "text", text = paste ("", Player, "Country: " , Country )) Perhaps adding a trace of initials might be an option?
d) The colour vector is not working properly. If you select to plot both girls and boys it works. However if you choose only girls for example when you are selecting the colour no longer is gold or blue. I would like to explicitly say that girls (Sex column = 'F') are plotted in gold and males are in blue. Here I did it for a non plotly plot: player.col = rep("gold", nrow(playerData)) # let all the rows of dat be coloured gold male = which(playerData$Sex=="M") player.col[male] = "blue" # colour this rows = 'M' blue - not gold
As you can see if both boys and girls are not plotted together the colours are pink....
Many thanks
Here is the data to run the code:
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
