Question

我尝试在Shiny的情节顶部添加第二个x轴来修改绘图。但是，交互式点击最终会导致转换的coords返回。我想知道是否有正确的方法来获得正确的点击返回，也就是说，点击图表上的主题列将返回打印出该患者的所有数据。

library(shiny)

## generate data
for (i in 1:19){
  ID = sprintf("%02d", i)
  Fail =sprintf("%03d", round(runif(1,0,300)))
  Score = runif(4,-3,3)
  di = data.frame(ID=ID,Class=LETTERS[1:4],Score=Score,Fail=Fail)
  if (i==1) dta=di
  else dta=rbind(dta,di)
}
dta$Type = "Tag2"
dta$Type[dta$Class %in% c("A","D")] = "Tag1"

thm <- theme(legend.title = element_text(size = 10),
        legend.title.align=0.1,
        legend.text = element_text(size = 12),
        plot.title = element_text(size=16),
        axis.title=element_text(size=14, face="bold"),
        axis.text.x = element_text(size=11, angle = 90, hjust = 1))

ui <- fluidPage(
 fluidRow(
  column(7,
       plotOutput("plot1", click = "plot1_click")
 ),
 column(4,
       br(), br(), br(),
       htmlOutput("x_value"),
       verbatimTextOutput("selected_rows")
))
)

server <- function(input, output) {
 output$plot1 <- renderPlot({

 P1 <- ggplot(dta, aes(ID, Class)) +
  geom_tile(aes(fill = Score), color = "white") +
  scale_fill_gradientn(colours=c("navyblue", "white","red")) + 
  ylab("Class") + xlab("List of subjects") + 
  labs(fill = "Score \nLevel") + 
  thm  +
  facet_grid(Type~.,scales="free_y", space="free_y",labeller=labeller(Type = label_wrap_gen(10))) +
  theme( panel.spacing.y = unit(0, "lines"),   strip.switch.pad.grid = unit(0, "cm"),
         panel.border = element_rect(color = "black", fill = NA, size = 1),
         panel.background = element_rect(fill = NA), 
         strip.background =element_rect(fill="lightblue",color="black",size=1))+
         scale_y_discrete(expand = c(0,0)) + scale_x_discrete(expand = c(0,0))

P2 <- ggplot(dta, aes(Fail, Class)) +
  geom_tile(aes(fill = Score), color = "white") +
  scale_fill_gradientn(colours=c("navyblue", "white","red")) + 
  ylab("Class") + xlab("Subjects' Failure") + 
  labs(fill = "Score \nLevel") + 
  thm  +
  facet_grid(Type~.,scales="free_y", space="free_y",labeller=labeller(Type = label_wrap_gen(10))) +
  theme( panel.spacing.y = unit(0, "lines"),   strip.switch.pad.grid = unit(0, "cm"),
         panel.border = element_rect(color = "black", fill = NA, size = 1),
         panel.background = element_rect(fill = NA), 
         strip.background =element_rect(fill="lightblue",color="black",size=1))+
         scale_y_discrete(expand = c(0,0)) + scale_x_discrete(expand = c(0,0))

g1 <- ggplotGrob(P1)    
g2 <- ggplotGrob(P2)

## Get the position of the plot panel in g1
pp <- c(subset(g1$layout, name == "panel-1-1", se = t:r))

vinvert_title_grob <- function(grob) {
  heights <- grob$heights
  grob$heights[1] <- heights[3]
  grob$heights[3] <- heights[1]
  grob$vp[[1]]$layout$heights[1] <- heights[3]
  grob$vp[[1]]$layout$heights[3] <- heights[1]

  grob$children[[1]]$hjust <- 1 - grob$children[[1]]$hjust 
  grob$children[[1]]$vjust <- 1 - grob$children[[1]]$vjust 
  grob$children[[1]]$y <- unit(1, "npc") - grob$children[[1]]$y
  grob
}

# Copy "Elevation (ft)" xlab from g2 and swap margins
index <- which(g2$layout$name == "xlab-b")
xlab <- g2$grobs[[index]]
xlab <- vinvert_title_grob(xlab)

# Put xlab at the top of g1
g1 <- gtable_add_rows(g1, g2$heights[g2$layout[index, ]$t], pp$t-1)
g1 <- gtable_add_grob(g1, xlab, pp$t, pp$l, pp$t, pp$r, clip = "off", name="topxlab")

# Get "feet" axis (axis line, tick marks and tick mark labels) from g2
index <- which(g2$layout$name == "axis-b-1")
xaxis <- g2$grobs[[index]]

# Move the axis line to the bottom (Not needed in your example)
xaxis$children[[1]]$y <- unit.c(unit(0, "npc"), unit(0, "npc"))

# Swap axis ticks and tick mark labels
ticks <- xaxis$children[[2]]
ticks$heights <- rev(ticks$heights)
ticks$grobs <- rev(ticks$grobs)

# Move tick marks
ticks$grobs[[2]]$y <- ticks$grobs[[2]]$y - unit(1, "npc") + unit(3, "pt")

# Sswap tick mark labels' margins
ticks$grobs[[1]] <- vinvert_title_grob(ticks$grobs[[1]])

# Put ticks and tick mark labels back into xaxis
xaxis$children[[2]] <- ticks

# Add axis to top of g1
g1 <- gtable_add_rows(g1, g2$heights[g2$layout[index, ]$t], pp$t)
g1 <- gtable_add_grob(g1, xaxis, pp$t+1, pp$l, pp$t+1, pp$r, clip = "off", name = "axis-t")

#pa = dual_xaxis(data=dta)
grid.newpage()
grid.draw(g1)
})

# Print the name of the x value
output$x_value <- renderText({
 if (is.null(input$plot1_click$x)) return("")
 else {
  lvls <- levels(dta$ID)
  name <- lvls[round(input$plot1_click$x)]
  HTML("You've selected <code>", name, "</code>",
       "<br><br>Here are socres that ",
       "match the selection:")
  }
})

# Print the rows of the data frame which match the x value
output$selected_rows <- renderPrint({
 if (is.null(input$plot1_click$x)) return()
  else {
  keeprows <- round(input$plot1_click$x) == as.numeric(dta$ID)
  head(dta[keeprows, ])
  }
})
}

shinyApp(ui, server)

使用上面的代码，我需要点击主题12的相对位置以获得如下所示的返回：

  ID Class      Score Fail Type
1 01     A  0.1547077  229 Tag1
2 01     B -2.7327629  229 Tag2
3 01     C -1.0500660  229 Tag2
4 01     D -0.9531061  229 Tag1

在绘图修改后，闪亮的交互式点击返回移位的坐标

0 个答案: