R語言程式設計導論

林嶔 (Lin, Chin)

Lesson 15 圖形化互動App

第一節:創造互動式圖形(1)

– ui.R

library(shiny)

fluidPage(
  fluidRow(
    column(width = 4,
           plotOutput("plot1", height = 350,
                      click = "plot_click",
                      dblclick = dblclickOpts(id = "plot_dblclick"),
                      hover = hoverOpts(id = "plot_hover"),
                      brush = brushOpts(id = "plot_brush")
           )
    )
  ),
  fluidRow(
    column(width = 3,
           verbatimTextOutput("click_info")
    ),
    column(width = 3,
           verbatimTextOutput("dblclick_info")
    ),
    column(width = 3,
           verbatimTextOutput("hover_info")
    ),
    column(width = 3,
           verbatimTextOutput("brush_info")
    )
  )
)

– server.R

library(shiny)

data(cars)
dat = cars

shinyServer(function(input, output) {
  output$plot1 <- renderPlot({
    plot(dat)
  })
  
  output$click_info <- renderPrint({
    cat("input$plot_click:\n")
    str(input$plot_click)
  })
  output$hover_info <- renderPrint({
    cat("input$plot_hover:\n")
    str(input$plot_hover)
  })
  output$dblclick_info <- renderPrint({
    cat("input$plot_dblclick:\n")
    str(input$plot_dblclick)
  })
  output$brush_info <- renderPrint({
    cat("input$plot_brush:\n")
    str(input$plot_brush)
  })
  
})

第一節:創造互動式圖形(2)

– 這邊需要用到兩個新函數:reactiveValues()、observe()和observeEvent()

library(shiny)

fluidPage(
  fluidRow(
    column(width = 4,
           plotOutput("plot1", height = 400,
                      brush = brushOpts(id = "plot1_brush", resetOnNew = TRUE))
    ),
    column(width = 4,
           plotOutput("plot2", height = 400)
    ),
    column(width = 4,
           plotOutput("plot3", height = 400,
                      dblclick = "plot3_dblclick",
                      brush = brushOpts(id = "plot3_brush", resetOnNew = TRUE))
    )
  )
)
library(shiny)

data(cars)
dat = cars

shinyServer(function(input, output) {
  
  ranges1 = reactiveValues(x = NULL, y = NULL)
  
  observe({
    brush1 = input$plot1_brush
    if (!is.null(brush1)) {
      ranges1$x = c(brush1$xmin, brush1$xmax)
      ranges1$y = c(brush1$ymin, brush1$ymax)
    } else {
      ranges1$x = NULL
      ranges1$y = NULL
    }
  })
  
  output$plot1 <- renderPlot({
    plot(dat)
  })
  
  output$plot2 <- renderPlot({
    plot(dat, xlim = ranges1$x, ylim = ranges1$y)
  })
  
  ranges2 <- reactiveValues(x = NULL, y = NULL)
  
  output$plot3 <- renderPlot({
    plot(dat, xlim = ranges2$x, ylim = ranges2$y)
  })
  
  observeEvent(input$plot3_dblclick, {
    brush2 <- input$plot3_brush
    if (!is.null(brush2)) {
      ranges2$x <- c(brush2$xmin, brush2$xmax)
      ranges2$y <- c(brush2$ymin, brush2$ymax)
    } else {
      ranges2$x <- NULL
      ranges2$y <- NULL
    }
  })
  
})

練習1:手動標註系統(1)

– 我們先看看裡面的一個文字檔案,而這個檔案描述的是5張圖的人類位置在哪:

box_info = read.csv("examples/label.csv", header = TRUE, stringsAsFactors = FALSE)
box_info
##    obj_name   col_left col_right   row_bot   row_top prob img_id
## 1    person 0.60728125 0.7782344 0.8139110 0.1637471    1      1
## 2    person 0.00000000 0.0971250 0.7015925 0.6154801    1      1
## 3    person 0.50981250 0.6211250 0.8687150 0.4078505    1      2
## 4    person 0.01529687 0.2058281 0.9194159 0.3903271    1      2
## 5    person 0.79756250 0.9907812 0.9042757 0.4001636    1      2
## 6    person 0.32854688 0.6720156 0.8738333 0.2985208    1      3
## 7    person 0.88721875 0.9362500 0.7515368 0.5911255    1      4
## 8    person 0.39248437 0.4289219 0.3639394 0.2303463    1      4
## 9    person 0.47934375 0.4961250 0.6005000 0.5788542    1      5
## 10   person 0.76668750 0.7721250 0.5681875 0.5610833    1      5

練習1:手動標註系統(2)

library(jpeg)
library(imager)

Show_img = function (img, box_info = NULL, col_bbox = '#FFFFFF00', col_label = '#FF0000FF') {
  
  par(mar = rep(0, 4))
  plot(NA, xlim = c(0, 1), ylim = c(1, 0), xaxt = "n", yaxt = "n", bty = "n")
  img = (img - min(img))/(max(img) - min(img))
  img = as.raster(img)
  rasterImage(img, 0, 1, 1, 0, interpolate=FALSE)
  
  
  if (!is.null(box_info)) {
    if (nrow(box_info) > 0) {
      for (i in 1:nrow(box_info)) {
        size = max(box_info[i,3] - box_info[i,2], 0.2)
        rect(xleft = box_info[i,2], xright = box_info[i,2] + 0.06*sqrt(size)*nchar(box_info[i,1]),
             ybottom = box_info[i,5] + 0.08*sqrt(size), ytop = box_info[i,5],
             col = col_label, border = col_label, lwd = 0)
        text(x = box_info[i,2] + 0.03*sqrt(size) * nchar(box_info[i,1]),
             y = box_info[i,5] + 0.04*sqrt(size),
             labels = box_info[i,1],
             col = 'white', cex = 1.5*sqrt(size), font = 2)
        rect(xleft = box_info[i,2], xright = box_info[i,3],
             ybottom = box_info[i,4], ytop = box_info[i,5],
             col = col_bbox, border = col_label, lwd = 5*sqrt(size))
      }
    }
  }
  
}
img = readJPEG("examples/2.jpeg")
Show_img(img, box_info[box_info[,"img_id"] == 2,])

img = readJPEG("examples/3.jpeg")
Show_img(img, box_info[box_info[,"img_id"] == 3,])

練習1:手動標註系統(3)

  1. 讓使用者能夠自己上傳一張圖片上去

  2. 框出物件的位置在哪,並選擇框選的物件為何(目前只有人類供選擇)

  3. 按下按鍵後紀錄框的位置

  4. 將資訊記錄在資料表內,而img_id設定為圖像的檔名

  5. 如果使用者覺得框錯了,可以把它刪除

  6. 使用者最終能下載該資料表

練習1答案

library(shiny)
library(DT)
library(jpeg)
library(imager)

fluidPage(
  fluidRow(
    column(width = 4,
           fileInput("files", label = h4("Upload your jpeg image:"), multiple = FALSE, accept = "image/jpeg"),
           br(),
           radioButtons("obj", label = h4("Please select a object name:"), c("person" = "person")),
           br(),
           downloadButton("download", label = "Download file", class = NULL)
    ),
    column(width = 7,
           plotOutput("plot", height = 416, width = 416,
                      dblclick = "plot_dblclick",
                      brush = brushOpts(id = "plot_brush", resetOnNew = TRUE)),
           br(),
           actionButton("delete", strong("Delete selected box!"), icon("list-alt")),
           br(),
           br(),
           DT::dataTableOutput('table')
    )
  )
)
library(shiny)
library(DT)
library(jpeg)
library(imager)

Show_img = function (img, box_info = NULL, col_bbox = '#FFFFFF00', col_label = '#FF0000FF') {
  
  par(mar = rep(0, 4))
  plot(NA, xlim = c(0, 1), ylim = c(1, 0), xaxt = "n", yaxt = "n", bty = "n")
  img = (img - min(img))/(max(img) - min(img))
  img = as.raster(img)
  rasterImage(img, 0, 1, 1, 0, interpolate=FALSE)
  
  
  if (!is.null(box_info)) {
    if (nrow(box_info) > 0) {
      for (i in 1:nrow(box_info)) {
        size = max(box_info[i,3] - box_info[i,2], 0.2)
        rect(xleft = box_info[i,2], xright = box_info[i,2] + 0.06*sqrt(size)*nchar(box_info[i,1]),
             ybottom = box_info[i,5] + 0.08*sqrt(size), ytop = box_info[i,5],
             col = col_label, border = col_label, lwd = 0)
        text(x = box_info[i,2] + 0.03*sqrt(size) * nchar(box_info[i,1]),
             y = box_info[i,5] + 0.04*sqrt(size),
             labels = box_info[i,1],
             col = 'white', cex = 1.5*sqrt(size), font = 2)
        rect(xleft = box_info[i,2], xright = box_info[i,3],
             ybottom = box_info[i,4], ytop = box_info[i,5],
             col = col_bbox, border = col_label, lwd = 5*sqrt(size))
      }
    }
  }
  
}

shinyServer(function(input, output) {
  
  IMAGE = reactive({
    if (is.null(input$files)) {return()} else {
      img = readJPEG(input$files$datapath)
      return(img) 
    }
  })
  
  MY_TABLE = reactiveValues(table = NULL)
  
  output$plot = renderPlot({
    img = IMAGE()
    if (!is.null(input$files$name)) {
      box_info = MY_TABLE$table
      box_info = box_info[box_info[,"img_id"] == input$files$name,]
    } else {
      box_info = NULL
    }
    if (is.null(img)) {return()} else {
      Show_img(img = img, box_info = box_info)
    }
  })
  
  observeEvent(input$plot_dblclick, {
    brush = input$plot_brush
    if (!is.null(brush) & !is.null(input$files$name)) {
      new_table = data.frame(obj_name = input$obj,
                             col_left = brush$xmin,
                             col_right = brush$xmax,
                             row_bot = brush$ymax,
                             row_top = brush$ymin,
                             prob = 1,
                             img_id = input$files$name,
                             stringsAsFactors = FALSE)
      MY_TABLE$table = rbind(MY_TABLE$table, new_table)
    }
  })
  
  observeEvent(input$delete, {
    selection = as.numeric(input$table_rows_selected)
    if (length(selection)!=0) {
      MY_TABLE$table = MY_TABLE$table[-selection,]
    }
  })
  
  output$table = DT::renderDataTable({
    dat = MY_TABLE$table
    if (is.null(dat)) {return()} else {
      dat[,2] = round(dat[,2], 3)
      dat[,3] = round(dat[,3], 3)
      dat[,4] = round(dat[,4], 3)
      dat[,5] = round(dat[,5], 3)
      Result = DT::datatable(dat)
      return(Result)
    }
  })
  
  output$download = downloadHandler(
    filename = function() {'label.csv'},
    content = function(con) {
      dat = MY_TABLE$table
      if (is.null(dat)) {return()} else {
        write.csv(dat, con, row.names = FALSE)
      }
    }
  )
  
  
})

第二節:學習如何套用別人寫好的程式(1)

– 你應該有注意到你的App是沒有辦法用帳號密碼保護的,而要做這件事情確實是有難度,畢竟我們似乎是沒有學過兩個頁面的切換功能,那讓我們再google看看吧:

F16_5

– 其中的第三個討論串:Starting Shiny app after password input就是在講這件事情

F16_6

第二節:學習如何套用別人寫好的程式(2)

rm(list = ls())
library(shiny)

Logged = FALSE;
my_username <- "test"
my_password <- "test"

ui1 <- function(){
  tagList(
    div(id = "login",
        wellPanel(textInput("userName", "Username"),
                  passwordInput("passwd", "Password"),
                  br(),actionButton("Login", "Log in"))),
    tags$style(type="text/css", "#login {font-size:10px;   text-align: left;position:absolute;top: 40%;left: 50%;margin-top: -100px;margin-left: -150px;}")
  )}

ui2 <- function(){tagList(tabPanel("Test"))}

ui = (htmlOutput("page"))
server = (function(input, output,session) {

  USER <- reactiveValues(Logged = Logged)

  observe({ 
    if (USER$Logged == FALSE) {
      if (!is.null(input$Login)) {
        if (input$Login > 0) {
          Username <- isolate(input$userName)
          Password <- isolate(input$passwd)
          Id.username <- which(my_username == Username)
          Id.password <- which(my_password == Password)
          if (length(Id.username) > 0 & length(Id.password) > 0) {
            if (Id.username == Id.password) {
              USER$Logged <- TRUE
            } 
          }
        } 
      }
    }    
  })
  observe({
    if (USER$Logged == FALSE) {

      output$page <- renderUI({
        div(class="outer",do.call(bootstrapPage,c("",ui1())))
      })
    }
    if (USER$Logged == TRUE) 
    {
      output$page <- renderUI({
        div(class="outer",do.call(navbarPage,c(inverse=TRUE,title = "Contratulations you got in!",ui2())))
      })
    }
  })
})

#runApp(list(ui = ui, server = server))

第二節:學習如何套用別人寫好的程式(3)

– global.R

library(shiny)

Logged = FALSE;
my_username <- "test"
my_password <- "test"

ui1 <- function(){
  tagList(
    div(id = "login",
        wellPanel(textInput("userName", "Username"),
                  passwordInput("passwd", "Password"),
                  br(),actionButton("Login", "Log in"))),
    tags$style(type="text/css", "#login {font-size:10px;   text-align: left;position:absolute;top: 40%;left: 50%;margin-top: -100px;margin-left: -150px;}")
  )}

ui2 <- function(){tagList(tabPanel("Test"))}

– ui.R

library(shiny)

htmlOutput("page")
library(shiny)

function(input, output,session) {

  USER <- reactiveValues(Logged = Logged)

  observe({ 
    if (USER$Logged == FALSE) {
      if (!is.null(input$Login)) {
        if (input$Login > 0) {
          Username <- isolate(input$userName)
          Password <- isolate(input$passwd)
          Id.username <- which(my_username == Username)
          Id.password <- which(my_password == Password)
          if (length(Id.username) > 0 & length(Id.password) > 0) {
            if (Id.username == Id.password) {
              USER$Logged <- TRUE
            } 
          }
        } 
      }
    }    
  })
  observe({
    if (USER$Logged == FALSE) {

      output$page <- renderUI({
        div(class="outer",do.call(bootstrapPage,c("",ui1())))
      })
    }
    if (USER$Logged == TRUE) 
    {
      output$page <- renderUI({
        div(class="outer",do.call(navbarPage,c(inverse=TRUE,title = "Contratulations you got in!",ui2())))
      })
    }
  })
}

第二節:學習如何套用別人寫好的程式(4)

– global.R

library(shiny)

Logged = FALSE;
my_username <- "test"
my_password <- "test"

ui1 <- function(){
  tagList(
    div(id = "login",
        wellPanel(textInput("userName", "Username"),
                  passwordInput("passwd", "Password"),
                  br(),actionButton("Login", "Log in"))),
    tags$style(type="text/css", "#login {font-size:10px;   text-align: left;position:absolute;top: 40%;left: 50%;margin-top: -100px;margin-left: -150px;}")
  )}

ui2 <- function(){tagList(tabPanel("Test",
                                   sliderInput("obs", "Number of observations:", min = 0, max = 1000, value = 500),
                                   plotOutput("distPlot")))}

– ui.R

library(shiny)

htmlOutput("page")
library(shiny)

function(input, output,session) {
  
  USER <- reactiveValues(Logged = Logged)
  
  observe({ 
    if (USER$Logged == FALSE) {
      if (!is.null(input$Login)) {
        if (input$Login > 0) {
          Username <- isolate(input$userName)
          Password <- isolate(input$passwd)
          Id.username <- which(my_username == Username)
          Id.password <- which(my_password == Password)
          if (length(Id.username) > 0 & length(Id.password) > 0) {
            if (Id.username == Id.password) {
              USER$Logged <- TRUE
            } 
          }
        } 
      }
    }    
  })
  observe({
    if (USER$Logged == FALSE) {
      
      output$page <- renderUI({
        div(class="outer",do.call(bootstrapPage,c("",ui1())))
      })
    }
    if (USER$Logged == TRUE) 
    {
      output$page <- renderUI({
        div(class="outer",do.call(navbarPage,c(inverse=TRUE,title = "Contratulations you got in!",ui2())))
      })

      output$distPlot = renderPlot({
        
        # generate an rnorm distribution and plot it
        dist = rnorm(input$obs)
        hist(dist)
      })
      
    }
  })
}

練習2:讓剛剛的標註系統上增加帳號密碼的輸入

– 請你設計兩個頁面的程序,讓使用者在使用標註系統之前需要輸入帳號密碼!

練習2答案

library(shiny)
library(DT)
library(jpeg)
library(imager)

Logged = FALSE;
my_username <- "test"
my_password <- "test"

Show_img = function (img, box_info = NULL, col_bbox = '#FFFFFF00', col_label = '#FF0000FF') {
  
  par(mar = rep(0, 4))
  plot(NA, xlim = c(0, 1), ylim = c(1, 0), xaxt = "n", yaxt = "n", bty = "n")
  img = (img - min(img))/(max(img) - min(img))
  img = as.raster(img)
  rasterImage(img, 0, 1, 1, 0, interpolate=FALSE)
  
  
  if (!is.null(box_info)) {
    if (nrow(box_info) > 0) {
      for (i in 1:nrow(box_info)) {
        size = max(box_info[i,3] - box_info[i,2], 0.2)
        rect(xleft = box_info[i,2], xright = box_info[i,2] + 0.06*sqrt(size)*nchar(box_info[i,1]),
             ybottom = box_info[i,5] + 0.08*sqrt(size), ytop = box_info[i,5],
             col = col_label, border = col_label, lwd = 0)
        text(x = box_info[i,2] + 0.03*sqrt(size) * nchar(box_info[i,1]),
             y = box_info[i,5] + 0.04*sqrt(size),
             labels = box_info[i,1],
             col = 'white', cex = 1.5*sqrt(size), font = 2)
        rect(xleft = box_info[i,2], xright = box_info[i,3],
             ybottom = box_info[i,4], ytop = box_info[i,5],
             col = col_bbox, border = col_label, lwd = 5*sqrt(size))
      }
    }
  }
  
}

ui1 <- function(){
  tagList(
    div(id = "login",
        wellPanel(textInput("userName", "Username"),
                  passwordInput("passwd", "Password"),
                  br(),actionButton("Login", "Log in"))),
    tags$style(type="text/css", "#login {font-size:10px;   text-align: left;position:absolute;top: 40%;left: 50%;margin-top: -100px;margin-left: -150px;}")
  )}

ui2 <- function(){tagList(tabPanel("Main page",
                                   fluidRow(
                                     column(width = 4,
                                            fileInput("files", label = h4("Upload your jpeg image:"), multiple = FALSE, accept = "image/jpeg"),
                                            br(),
                                            radioButtons("obj", label = h4("Please select a object name:"), c("person" = "person")),
                                            br(),
                                            downloadButton("download", label = "Download file", class = NULL)
                                     ),
                                     column(width = 7,
                                            plotOutput("plot", height = 416, width = 416,
                                                       dblclick = "plot_dblclick",
                                                       brush = brushOpts(id = "plot_brush", resetOnNew = TRUE)),
                                            br(),
                                            actionButton("delete", strong("Delete selected box!"), icon("list-alt")),
                                            br(),
                                            br(),
                                            DT::dataTableOutput('table')
                                     )
                                   )))}
library(shiny)
library(DT)
library(jpeg)
library(imager)

htmlOutput("page")
library(shiny)
library(DT)
library(jpeg)
library(imager)

function(input, output,session) {
  
  USER <- reactiveValues(Logged = Logged)
  
  observe({ 
    if (USER$Logged == FALSE) {
      if (!is.null(input$Login)) {
        if (input$Login > 0) {
          Username <- isolate(input$userName)
          Password <- isolate(input$passwd)
          Id.username <- which(my_username == Username)
          Id.password <- which(my_password == Password)
          if (length(Id.username) > 0 & length(Id.password) > 0) {
            if (Id.username == Id.password) {
              USER$Logged <- TRUE
            } 
          }
        } 
      }
    }    
  })
  observe({
    if (USER$Logged == FALSE) {
      
      output$page <- renderUI({
        div(class="outer",do.call(bootstrapPage,c("",ui1())))
      })
    }
    if (USER$Logged == TRUE) 
    {
      output$page <- renderUI({
        div(class="outer",do.call(navbarPage,c(inverse=TRUE,title = "Contratulations you got in!",ui2())))
      })

      IMAGE = reactive({
        if (is.null(input$files)) {return()} else {
          img = readJPEG(input$files$datapath)
          return(img) 
        }
      })
      
      MY_TABLE = reactiveValues(table = NULL)
      
      output$plot = renderPlot({
        img = IMAGE()
        if (!is.null(input$files$name)) {
          box_info = MY_TABLE$table
          box_info = box_info[box_info[,"img_id"] == input$files$name,]
        } else {
          box_info = NULL
        }
        if (is.null(img)) {return()} else {
          Show_img(img = img, box_info = box_info)
        }
      })
      
      observeEvent(input$plot_dblclick, {
        brush = input$plot_brush
        if (!is.null(brush) & !is.null(input$files$name)) {
          new_table = data.frame(obj_name = input$obj,
                                 col_left = brush$xmin,
                                 col_right = brush$xmax,
                                 row_bot = brush$ymax,
                                 row_top = brush$ymin,
                                 prob = 1,
                                 img_id = input$files$name,
                                 stringsAsFactors = FALSE)
          MY_TABLE$table = rbind(MY_TABLE$table, new_table)
        }
      })
      
      observeEvent(input$delete, {
        selection = as.numeric(input$table_rows_selected)
        if (length(selection)!=0) {
          MY_TABLE$table = MY_TABLE$table[-selection,]
        }
      })
      
      output$table = DT::renderDataTable({
        dat = MY_TABLE$table
        if (is.null(dat)) {return()} else {
          dat[,2] = round(dat[,2], 3)
          dat[,3] = round(dat[,3], 3)
          dat[,4] = round(dat[,4], 3)
          dat[,5] = round(dat[,5], 3)
          Result = DT::datatable(dat)
          return(Result)
        }
      })
      
      output$download = downloadHandler(
        filename = function() {'label.csv'},
        content = function(con) {
          dat = MY_TABLE$table
          if (is.null(dat)) {return()} else {
            write.csv(dat, con, row.names = FALSE)
          }
        }
      )
      
    }
  })
}

第三節:Google圖表在網頁應用程式的應用(1)

– 大家可以在googleVis examples找到一些例子

– 請複製貼上以下範例在Rstudio中

– 請至這裡下載範例資料

dat = read.csv("Example_data.csv", header = TRUE)
head(dat)
##       eGFR Disease Survival.time Death Diabetes Cancer      SBP      DBP
## 1 34.65379       1     0.4771037     0        0      1 121.2353 121.3079
## 2 37.21183       1     3.0704424     0        1      1 122.2000 122.6283
## 3 32.60074       1     0.2607117     1        0      0 118.9136 121.7621
## 4 29.68481       1            NA    NA        0      0 118.2212 112.7043
## 5 28.35726       0     0.1681673     1        0      0 116.7469 115.7705
## 6 33.95012       1     1.2238556     0        0      0 119.9936 116.3872
##   Education Income
## 1         2      0
## 2         2      0
## 3         0      0
## 4         1      0
## 5         0      0
## 6         1      0
library(googleVis)

第三節:Google圖表在網頁應用程式的應用(2)

– 圓餅圖

TAB = table(dat$Income)
TAB = data.frame(TAB)
colnames(TAB) = c("Income", "Freq")
TAB[,1] = c("Low income", "Middle-class", "Wealthy")
Pie = gvisPieChart(TAB)
plot(Pie)

– 長條圖

m1.0 = mean(dat[dat[,"Income"] == 0,]$SBP, na.rm = TRUE)
m1.1 = mean(dat[dat[,"Income"] == 1,]$SBP, na.rm = TRUE)
m1.2 = mean(dat[dat[,"Income"] == 2,]$SBP, na.rm = TRUE)
m2.0 = mean(dat[dat[,"Income"] == 0,]$eGFR, na.rm = TRUE)
m2.1 = mean(dat[dat[,"Income"] == 1,]$eGFR, na.rm = TRUE)
m2.2 = mean(dat[dat[,"Income"] == 2,]$eGFR, na.rm = TRUE)

DF = data.frame(Income = c("Low income", "Middle-class", "Wealthy"),
                SBP = c(m1.0, m1.1, m1.2),
                eGFR = c(m2.0, m2.1, m2.2))

Column = gvisColumnChart(DF)
plot(Column)

第三節:Google圖表在網頁應用程式的應用(3)

newdat = dat[,c("SBP", "DBP")]
SC1 = gvisScatterChart(newdat)
plot(SC1)
newdat = dat[,c("eGFR", "SBP")]
SC2 = gvisScatterChart(newdat,
                        options=list(
                        title = "eGFR vs SBP",
                        legend = "none",
                        colors="['#ff0000']",
                        pointSize = 2,
                        explorer="{actions: ['dragToZoom',
                                  'rightClickToReset'],
                                  maxZoomIn:0.05}"
                        ))
plot(SC2)
cat(SC2$html$chart, file = "SC2.html")

第三節:Google圖表在網頁應用程式的應用(4)

– ui.R

library(shiny)
library(googleVis)

fluidPage(
  htmlOutput("chart1")
)

– server.R

library(shiny)
library(googleVis)

shinyServer(function(input, output, session) {
  
  output$chart1 <- renderGvis({
    
    newdat = data.frame(x1 = rnorm(100), x2 = rnorm(100))
    SC1 = gvisScatterChart(newdat)
    SC1
    
  })
  
})

練習3:上傳分析資料並畫出散步圖

– 請在這裡下載練習用檔案

library(shiny)

shinyUI(pageWithSidebar(
  
  headerPanel("Linear regression for two continuous variables."), 
  
  sidebarPanel(
    fileInput(inputId="files", label=h4("Upload your data file:"), multiple=FALSE, accept="text/plain"),
    helpText("Note: you only can upload the .txt file."),
    uiOutput("choose_columns1"),   #這裡是關鍵
    uiOutput("choose_columns2"),   #這裡是關鍵
    radioButtons("method", "What is the method to analysis?", choices = c("Pearson correlation" = "pearson", "Spearman correlation" = "spearman")),
    radioButtons("Color", "Select the color of histogram:", choices = c("Red" = "red", "Blue" = "blue", "Green" = "green"))
  ),
  
  mainPanel(
    verbatimTextOutput("summary"),
    plotOutput("plot",width = "500px", height = "500px")
  )  
  
))
library(shiny)

shinyServer(function(input, output) {
  
  DATA <- reactive({
    if (is.null(input$files)) {return()} else {
      dat <- read.table(input$files$datapath,header=T)
      return(dat) 
    }
  })
  
  output$choose_columns1 <- renderUI({  #這裡是關鍵
    dat = DATA()
    if (is.null(dat)) {return()} else {
      colnames <- colnames(dat)
      selectInput("Y", h4("Choose a dependence variable:"), choices = colnames)
    }
  })
  
  output$choose_columns2 <- renderUI({  #這裡是關鍵
    dat = DATA()
    if (is.null(dat)|is.null(input$Y)) {return()} else {
      colnames <- colnames(dat)
      selectInput("X", h4("Choose a independence variable:"), choices = colnames[which(colnames!=input$Y)])
    }
  })
  
  output$summary <- renderPrint({
    dat = DATA()
    if (is.null(dat)|is.null(input$Y)|is.null(input$X)) {return()} else {
      X <- dat[,input$X]  #這裡是關鍵
      Y <- dat[,input$Y]  #這裡是關鍵
      Result=cor.test(X,Y,method=input$method)
      return(Result)
    }  
  })
  
  output$plot <- renderPlot({
    dat = DATA()
    if (is.null(dat)|is.null(input$Y)|is.null(input$X)) {return()} else {
      X <- dat[,input$X]  #這裡是關鍵
      Y <- dat[,input$Y]  #這裡是關鍵
      plot(X,Y,pch=19,col=input$Color)
      abline(lm(Y~X),col="black")   
    }  
  })
  
})

練習3答案

library(shiny)
library(googleVis)

shinyUI(pageWithSidebar(
  
  headerPanel("Linear regression for two continuous variables."), 
  
  sidebarPanel(
    fileInput(inputId="files", label=h4("Upload your data file:"), multiple=FALSE, accept="text/plain"),
    helpText("Note: you only can upload the .txt file."),
    uiOutput("choose_columns1"),   #這裡是關鍵
    uiOutput("choose_columns2"),   #這裡是關鍵
    radioButtons("method", "What is the method to analysis?", choices = c("Pearson correlation" = "pearson", "Spearman correlation" = "spearman")),
    radioButtons("Color", "Select the color of histogram:", choices = c("Red" = "#ff0000", "Blue" = "#0000ff", "Green" = "#00ff00"))
  ),
  
  mainPanel(
    verbatimTextOutput("summary"),
    htmlOutput("plot")
  )  
  
))
library(shiny)
library(googleVis)

shinyServer(function(input, output) {
  
  DATA <- reactive({
    if (is.null(input$files)) {return()} else {
      dat <- read.table(input$files$datapath,header=T)
      return(dat) 
    }
  })
  
  output$choose_columns1 <- renderUI({  #這裡是關鍵
    dat = DATA()
    if (is.null(dat)) {return()} else {
      colnames <- colnames(dat)
      selectInput("Y", h4("Choose a dependence variable:"), choices = colnames)
    }
  })
  
  output$choose_columns2 <- renderUI({  #這裡是關鍵
    dat = DATA()
    if (is.null(dat)|is.null(input$Y)) {return()} else {
      colnames <- colnames(dat)
      selectInput("X", h4("Choose a independence variable:"), choices = colnames[which(colnames!=input$Y)])
    }
  })
  
  output$summary <- renderPrint({
    dat = DATA()
    if (is.null(dat)|is.null(input$Y)|is.null(input$X)) {return()} else {
      X <- dat[,input$X]  #這裡是關鍵
      Y <- dat[,input$Y]  #這裡是關鍵
      Result=cor.test(X,Y,method=input$method)
      return(Result)
    }  
  })
  
  output$plot <- renderGvis({
    dat = DATA()
    if (is.null(dat)|is.null(input$Y)|is.null(input$X)) {return()} else {
      X <- dat[,input$X]  #這裡是關鍵
      Y <- dat[,input$Y]  #這裡是關鍵
      newdat = data.frame(X = X, Y = Y)
      SC2 = gvisScatterChart(newdat,
                             options=list(
                               legend = "none",
                               colors=paste0("['", input$Color, "']"),
                               pointSize = 2,
                               explorer="{actions: ['dragToZoom',
                                  'rightClickToReset'],
                                  maxZoomIn:0.05}"
                             ))
      SC2
      
    }  
  })
  
})

小結

– 現在我們的網頁功能越來越多,也越來越漂亮了。